In [1]:

    

import Data.Time

putStrLn "Notebook last run:"
getCurrentTime


    

    






Notebook last run:






    






2016-02-23 03:00:18.120647 UTC

In [2]:

    

class MyFunctor f where
    fmap' :: (a -> b) -> f a -> f b

instance MyFunctor (Either e) where
    fmap' g (Left e)  = Left e
    fmap' g (Right x) = Right (g x)

instance MyFunctor ((->) e) where
    -- fmap' g f = g . f
    fmap' = (.)

-- Testing Functor law on defined instances.
func_law x = fmap' id x == id x

func_law2 x = fmap' id f x == f x
  where
    f x = 2 * x

func_law (Left "Error String")
func_law (Right 1)
func_law2 (2::Int)


    

    






True






    






True






    






True

In [3]:

    

instance MyFunctor ((,) e) where
    fmap' g (e, a) = (e, g a)

data Pair a = Pair a a deriving (Eq, Show)

instance MyFunctor Pair where
    fmap' g (Pair x y) = Pair (g x) (g y)

func_law ("msg", 0.1)
func_law $ Pair 1 2


    

    






True






    






True

In [4]:

    

data ITree a = Leaf (Int -> a) 
             | Node [ITree a]

instance Eq a => Eq (ITree a) where
    Leaf g == Leaf h = g 0 == h 0
    Node xs == Node ys = and (zipWith (==) xs ys)
    Leaf _ == Node _ = False
    Node _ == Leaf _ = False

instance MyFunctor ITree where
    fmap' g (Leaf f)   = Leaf (g . f)
    fmap' g (Node its) = Node $ map (fmap' g) its

-- Test Functor identity law.
let f = Node [Leaf id, Leaf id] in
  fmap' id f == f


    

    






True

In [5]:

    

{-# LANGUAGE KindSignatures GADTs StandaloneDeriving DeriveFunctor #-}

data NoFunc :: * -> * where
    NoFunc :: a -> NoFunc ()

deriving instance Functor (NoFunc)


    

    





Can't make a derived instance of ‘Functor interactive:IHaskell150.NoFunc’: Constructor ‘IHaskell150.NoFunc’ must be truly polymorphic in the last argument of the data type
In the stand-alone deriving instance for ‘Functor (interactive:IHaskell150.NoFunc)’

In [6]:

    

-- Yes: The following code compiles without error.
data Func1 a = Func1 a deriving (Functor)
data Func2 b = Func2 b deriving (Functor)
data CompFunc b = CompFunc (Func1 (Func2 b)) deriving (Functor)


    

In [7]:

    

data Break a = Yes | No deriving (Eq)

instance MyFunctor Break where
   fmap' f _ = No

-- Test Functor id law.
fmap' id Yes == Yes

-- Test Functor composition law.
let g = id
    h = const Yes
  in fmap' (g . h) Yes == (fmap' g . fmap' h) Yes


    

    






False






    






True

In [8]:

    

-- Evil Functor instance
instance MyFunctor [] where
  fmap' _ [] = []
  fmap' g (x:xs) = g x : g x : fmap g xs

-- Testing Functor identity law.
fmap' id [1,2,3] == [1,2,3]

-- Testing Functor composition law.
fmap' ((+ 1) . (* 2)) [1,2,3] == (fmap' (+ 1) . fmap' (* 2)) [1,2,3]


    

    






False






    






False

In [9]:

    

class MyApplicative f where
    pure'  :: a -> f a
    (<@>)  :: f (a -> b) -> f a -> f b
    
instance MyApplicative Maybe where
    pure' = Just
    Nothing <@> _ = Nothing
    _ <@> Nothing = Nothing
    Just g <@> Just a = Just (g a)


    

In [10]:

    

-- Test the Applicative laws.

-- Identity
-- pure' id <@> Nothing == Nothing
pure' id <@> Nothing -- The above causes the IHaskell kernel to hang, while working fine in ghci.
-- Curiously, even though the error message, below, calls for this,
-- when I attempt to use it I get an error saying the function
-- 'isNothing' is not in scope! (?!)
-- isNothing (pure' id <@> Nothing)
Just id <@> Just 3 == Just 3

-- Homomorphism
Just (+ 2) <@> Just 3 == Just ((+ 2) 3)

-- Interchange
Just (+ 2) <@> Just 3 == Just ($ 3) <@> Just (+ 2)

-- Composition
Just (+ 2) <@> (Just (+ 3) <@> Just 4) == Just (.) <@> Just (+ 2) <@> Just (+ 3) <@> Just 4


    

    






Nothing






    






True






    






True






    






True






    






True

In [11]:

    

newtype ZipList a = ZipList { getZipList :: [a] } deriving (Eq)
 
instance MyApplicative ZipList where
  pure' x = ZipList (repeat x)
  (ZipList gs) <@> (ZipList xs) = ZipList (zipWith ($) gs xs)

-- Test the Applicative laws.

-- Identity
pure' id <@> ZipList ([1,2,3] :: [Int]) == ZipList [1,2,3]

-- Homomorphism
pure' (+ 2) <@> ZipList ([1,2,3] :: [Int]) == ZipList (map (+ 2) [1,2,3])

-- Interchange
ZipList (replicate 3 (+ 2)) <@> pure' 1 == pure' ($ 1) <@> ZipList (replicate 3 (+ 2))

-- Composition
ZipList (replicate 3 (+ 2)) <@> (ZipList (replicate 3 (+ 3)) <@> ZipList [1,2,3]) ==
    pure' (.) <@> ZipList (replicate 3 (+ 2)) <@> ZipList (replicate 3 (+ 3)) <@> ZipList [1,2,3]


    

    






True






    






True






    






True






    






True

In [12]:

    

class Applicative f => Monoidal f where
  unit :: f ()
  unit  = pure ()
  
  (**) :: f a -> f b -> f (a,b)
  (**)  fa fb = pure (,) <*> fa <*> fb


    

In [13]:

    

class Monoidal f => MyApplicative f where
  pure'  :: a -> f a
  pure' x = fmap (const x) unit
  
  (<@>)    :: f (a -> b) -> f a -> f b
  fg <@> fx = fmap (uncurry ($)) (fg ** fx)


    

In [14]:

    

instance Monoidal Maybe

unit' :: Maybe () -> ()
unit' Nothing   = ()
unit' (Just ()) = ()

unjoin :: Maybe (a, b) -> (Maybe a, Maybe b)
unjoin Nothing       = (Nothing, Nothing)
unjoin (Just (x, y)) = (Just x, Just y)


    

In [15]:

    

import Data.Foldable

:t foldMap . foldMap
:t foldMap . foldMap . foldMap


    

    





foldMap . foldMap :: forall (t :: * -> *) m (t1 :: * -> *) a. (Foldable t, Foldable t1, Monoid m) => (a -> m) -> t (t1 a) -> m






    





foldMap . foldMap . foldMap :: forall (t :: * -> *) m (t1 :: * -> *) (t2 :: * -> *) a. (Foldable t, Foldable t1, Foldable t2, Monoid m) => (a -> m) -> t (t1 (t2 a)) -> m

In [16]:

    

import Data.Monoid

ls = [[1,2,3], [4,5,6], [7,8,9]]
(foldMap . foldMap) Sum ls
(foldMap . foldMap) Product ls


    

    






Sum {getSum = 45}






    






Product {getProduct = 362880}

In [17]:

    

toList :: Foldable f => f a -> [a]
toList = foldMap (: [])

data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)
  deriving (Show, Functor)

instance Foldable Tree where
   foldMap f Empty = mempty
   foldMap f (Leaf x) = f x
   foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r

toList $ Node (Leaf 1) 2 (Leaf 3)


    

    






[1,2,3]

In [18]:

    

concat :: [a] -> [a] -> [a]

-- concat [] ys = ys
-- concat (x:xs) ys = x : (concat xs ys)

-- concat xs ys = xs `mappend` ys
concat = mappend

concat [1,2,3] [4,5,6]


    

    






[1,2,3,4,5,6]

In [19]:

    

concatMap :: (a -> [b]) -> [a] -> [b]

-- concatMap _ [] = []
-- concatMap g (x:xs) = g x ++ (concatMap g xs)

-- concatMap g xs = fold $ fmap g xs
-- concatMap g xs = (fold . fmap g) xs
-- concatMap g xs = foldMap g xs
concatMap = foldMap


concatMap (\x -> [x, x]) [1, 2, 3]


    

    






[1,1,2,2,3,3]

In [20]:

    

and :: Foldable t => t Bool -> Bool
and = getAll . (foldMap All)

newtype All = All {getAll :: Bool}

instance Monoid All where
    mempty = All True
    mappend (All True) (All True) = All True
    mappend _          _          = All False
    
and $ Node (Leaf True) True (Leaf True)
and $ Node (Leaf True) True (Leaf False)


    

    






True






    






False

In [21]:

    

or :: Foldable t => t Bool -> Bool
or = getAny . (foldMap Any)

newtype Any = Any {getAny :: Bool}

instance Monoid Any where
    mempty = Any False
    mappend (Any False) (Any False) = Any False
    mappend _           _           = Any True
    
or $ Node (Leaf False) False (Leaf True)
or $ Node (Leaf False) False (Leaf False)


    

    






True






    






False

In [22]:

    

any :: Foldable t => t Bool -> Bool
any = or

any $ Node (Leaf False) False (Leaf True)
any $ Node (Leaf False) False (Leaf False)


    

    






True






    






False

In [23]:

    

all :: Foldable t => t Bool -> Bool
all = and

all $ Node (Leaf True) True (Leaf True)
all $ Node (Leaf True) True (Leaf False)


    

    






True






    






False

In [24]:

    

sum :: (Foldable t) => t Int -> Int
sum = getSum . (foldMap Sum)

newtype Sum = Sum {getSum :: Int}

instance Monoid Sum where
    mempty = Sum 0
    mappend (Sum x) (Sum y) = Sum (x + y)
    
sum $ Node (Leaf 1) 2 (Leaf 3)


    

    






6

In [25]:

    

product :: (Foldable t) => t Int -> Int
product = getProd . (foldMap Prod)

newtype Prod = Prod {getProd :: Int}

instance Monoid Prod where
    mempty = Prod 1
    mappend (Prod x) (Prod y) = Prod (x * y)
    
product $ Node (Leaf 1) 2 (Leaf 3)


    

    






6

In [26]:

    

maximum :: (Foldable t) => t Int -> Int
maximum = getMax . (foldMap Max)

newtype Max = Max {getMax :: Int}

instance Monoid Max where
    mempty = Max 0
    mappend (Max x) (Max y) | y > x     = Max y
                            | otherwise = Max x
                            
maximum $ Node (Leaf 1) 4 (Leaf 3)


    

    






4

In [27]:

    

minimum :: (Foldable t) => t Int -> Int
minimum = getMin . (foldMap Min)

newtype Min = Min {getMin :: Int}

instance Monoid Min where
    mempty = Min 1000000
    mappend (Min x) (Min y) | y < x     = Min y
                            | otherwise = Min x
                            
minimum $ Node (Leaf 1) 4 (Leaf 3)


    

    






1

In [28]:

    

elem :: (Foldable t, Eq a) => a -> t a -> Bool
elem x = getAny . (foldMap (Any . (== x)))

elem 4 $ Node (Leaf 1) 4 (Leaf 3)
elem 2 $ Node (Leaf 1) 4 (Leaf 3)


    

    






True






    






False

In [29]:

    

notElem :: (Foldable t, Eq a) => a -> t a -> Bool
notElem x = not . (elem x)

notElem 4 $ Node (Leaf 1) 4 (Leaf 3)
notElem 2 $ Node (Leaf 1) 4 (Leaf 3)


    

    






False






    






True

In [30]:

    

find :: Foldable t => (a -> Bool) -> t a -> Maybe a
find p = getFirst . foldMap (First . sel p)
  where sel p x | p x       = Just x
                | otherwise = Nothing

t1 = Node (Leaf 1) 4 (Leaf 3)

find (> 2) t1
find (> 4) t1


    

    






Just 4






    






Nothing

In [31]:

    

-- I don't seem to need the following line. I include it, here, because it was necessary,
-- when debugging the kernel hang mentioned, below, in GHCi.
import Prelude hiding (Traversable, sequenceA, traverse, mapM, sequence)
import Control.Applicative (WrappedMonad(..))

class (Functor t, Foldable t) => Traversable t where
  traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
  traverse g = sequenceA . fmap g

  sequenceA :: Applicative f => t (f a) -> f (t a)
  sequenceA = traverse id

  mapM :: Monad m => (a -> m b) -> t a -> m (t b)
  -- mapM g = unwrapMonad . sequenceA . (fmap (WrapMonad . g))
  mapM g = unwrapMonad . traverse (WrapMonad . g)
  
  sequence :: Monad m => t (m a) -> m (t a)
  sequence = mapM id
  
-- If I remove the following two lines, the kernel hangs when I attempt to run the cell.
main :: IO ()
main = putStrLn "Hello, World!"


    

In [32]:

    

instance Traversable Tree where
  sequenceA Empty          = pure Empty
  sequenceA (Leaf f)       = Leaf <$> f
  sequenceA (Node t1 f t2) = Node <$> (sequenceA t1) <*> f <*> (sequenceA t2)

t    = Node (Leaf [1]) [2, 3] (Leaf [4])
res  = foldMap (fmap Leaf) t
res' = sequenceA t

print t
print res
print res'


    

    






Node (Leaf [1]) [2,3] (Leaf [4])






    






[Leaf 1,Leaf 2,Leaf 3,Leaf 4]






    






[Node (Leaf 1) 2 (Leaf 4),Node (Leaf 1) 3 (Leaf 4)]

In [33]:

    

lofT2TofL :: [Tree a] -> Tree [a]
-- lofT2TofL []     = Empty
-- lofT2TofL (x:xs) = Node Empty (toList x) (lofT2TofL xs)
lofT2TofL = Leaf . concatMap toList

t1 = Empty
t2 = Leaf 1
t3 = Node (Leaf 2) 3 (Leaf 4)
l1 = [t1, t2, t3]

res = lofT2TofL l1

print l1
print res


    

    






[Empty,Leaf 1,Node (Leaf 2) 3 (Leaf 4)]






    






Leaf [1,2,3,4]

In [34]:

    

:t traverse
:t traverse . traverse


    

    





traverse :: forall (t :: * -> *) a (f :: * -> *) b. (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)






    





traverse . traverse :: forall (t :: * -> *) (f :: * -> *) (t1 :: * -> *) a b. (Applicative f, Traversable t, Traversable t1) => (a -> f b) -> t (t1 a) -> f (t (t1 b))

In [35]:

    

-- (traverse . traverse) allows us to traverse nested Traversables:

toList2 :: Tree (Tree [a]) -> [Tree(Tree a)]
toList2 = (traverse . traverse) id

tt1  = Leaf (Leaf [1])
tt2  = Node (Leaf (Leaf [1,2])) (Leaf [3]) (Leaf (Leaf [4]))
tt3  = Node (Leaf (Leaf [1,2])) (Leaf [3]) (Leaf (Leaf []))

res1 = toList2 tt1
res2 = toList2 tt2
res3 = toList2 tt3

print res1
print res2
print res3


    

    






[Leaf (Leaf 1)]






    






[Node (Leaf (Leaf 1)) (Leaf 3) (Leaf (Leaf 4)),Node (Leaf (Leaf 2)) (Leaf 3) (Leaf (Leaf 4))]






    






[]

In [36]:

    

import Data.Functor.Identity (Identity (..))

-- fmap :: (a -> b) -> t a -> t b
-- fmap g xs = <some function of 'traverse'>
--   g  :: a -> b
--   xs :: t a
--
-- traverse :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)
-- pure . g :: a -> f b
-- traverse (pure . g) xs :: f (t b)
-- runIdentity $ traverse (pure . g) xs :: t b (If f = Identity)
-- Want :: t b
-- fmap g xs = runIdentity $ traverse (pure . g) xs
fmap g = runIdentity . traverse (pure . g)

res = fmap (+ 1) t2
print t2
print res


    

    






Leaf 1






    






Leaf 2

In [37]:

    

-- foldMap :: (Foldable t, Monoid m) => (a -> m) -> t a -> m
-- foldMap g xs = <some function of 'traverse'>
--   g  :: a -> m
--   xs :: t a
--
-- traverse                          :: (Applicative f, Traversable t) => (a -> f b) -> t a -> f (t b)
-- AppMon . g                        :: a -> AppMon m b
-- traverse (AppMon . g)             :: t a -> AppMon m (t b)
-- traverse (AppMon . g) xs          :: AppMon m (t b)
-- getMon $ traverse (AppMon . g) xs :: m
-- ..
-- Want :: m
-- foldMap g xs = getMon $ traverse (AppMon . g) xs
foldMap g = getMon . traverse (AppMon . g)

-- Applicative wrapper around a Monoid.
newtype AppMon m a = AppMon {getMon :: m}

instance Functor (AppMon m) where
    fmap _ (AppMon m) = (AppMon m)
    
instance (Monoid m) => Applicative (AppMon m) where
    pure _  = AppMon mempty
    x <*> y = AppMon $ getMon x `mappend` getMon y
    
res = getSum $ foldMap Sum t3
print t3
print res


    

    






Node (Leaf 2) 3 (Leaf 4)






    






9