├── SKI.pdf ├── Freyd.pdf ├── Notes.pdf ├── Abstract.pdf ├── Diagonal.pdf ├── Filtered.pdf ├── FreeMono.pdf ├── MonoCata.key ├── MonoCata.pdf ├── Oredev.pdf ├── doubles.pdf ├── Actegories.pdf ├── Algebras1.pdf ├── Algebras2.pdf ├── Algebras3.pdf ├── Fibrations.pdf ├── NeuralLens.pdf ├── RecSchemes.pdf ├── Traversals.pdf ├── Universal.pdf ├── AlgebrasNotes.pdf ├── BladeRunner.jpeg ├── CrashCourse.key ├── Representable.pdf ├── DependentOptics.pdf ├── BartoszHaskellLove.pdf ├── TheDaoOfFP ├── DaoFP.pdf └── Haskell │ ├── 14-Applicative.hs │ ├── 2-Composition.hs │ ├── 18-Arrow.hs │ ├── 18-SimpleLens.hs │ ├── 20-DayHom.hs │ ├── 18-ProCompose.hs │ ├── 1-Types.hs │ ├── 6-FunctionTypes.hs │ ├── 5-ProductTypes.hs │ ├── 9-Yoneda.hs │ ├── 18-FreeApp.hs │ ├── 18-Coend.hs │ ├── 7-Nats.hs │ ├── 20-Lan.hs │ ├── 18-Ends.hs │ ├── 18-Lens.hs │ ├── 9-Universals.hs │ ├── 20-Ran.hs │ ├── 7-List.hs │ ├── 19-Tannaka.hs │ ├── 8-Functors.hs │ ├── 9-Natural.hs │ ├── 19-Optics.hs │ ├── 6-Revisited.hs │ ├── 4-SumTypes.hs │ └── 15-FreeMonad.hs ├── WeightedColimits.pdf ├── CrashCourse ScalaIO.pdf ├── .gitignore ├── Profunctor_Optics_Topos.pdf ├── FreeMonoidsInitialAlgebras.pdf ├── SolvingConstraintsWithMonads.pdf └── ProfunctorOptics-LambdaWorld2017.pdf /SKI.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/SKI.pdf -------------------------------------------------------------------------------- /Freyd.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Freyd.pdf -------------------------------------------------------------------------------- /Notes.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Notes.pdf -------------------------------------------------------------------------------- /Abstract.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Abstract.pdf -------------------------------------------------------------------------------- /Diagonal.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Diagonal.pdf -------------------------------------------------------------------------------- /Filtered.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Filtered.pdf -------------------------------------------------------------------------------- /FreeMono.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/FreeMono.pdf -------------------------------------------------------------------------------- /MonoCata.key: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/MonoCata.key -------------------------------------------------------------------------------- /MonoCata.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/MonoCata.pdf -------------------------------------------------------------------------------- /Oredev.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Oredev.pdf -------------------------------------------------------------------------------- /doubles.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/doubles.pdf -------------------------------------------------------------------------------- /Actegories.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Actegories.pdf -------------------------------------------------------------------------------- /Algebras1.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Algebras1.pdf -------------------------------------------------------------------------------- /Algebras2.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Algebras2.pdf -------------------------------------------------------------------------------- /Algebras3.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Algebras3.pdf -------------------------------------------------------------------------------- /Fibrations.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Fibrations.pdf -------------------------------------------------------------------------------- /NeuralLens.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/NeuralLens.pdf -------------------------------------------------------------------------------- /RecSchemes.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/RecSchemes.pdf -------------------------------------------------------------------------------- /Traversals.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Traversals.pdf -------------------------------------------------------------------------------- /Universal.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Universal.pdf -------------------------------------------------------------------------------- /AlgebrasNotes.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/AlgebrasNotes.pdf -------------------------------------------------------------------------------- /BladeRunner.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/BladeRunner.jpeg -------------------------------------------------------------------------------- /CrashCourse.key: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/CrashCourse.key -------------------------------------------------------------------------------- /Representable.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Representable.pdf -------------------------------------------------------------------------------- /DependentOptics.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/DependentOptics.pdf -------------------------------------------------------------------------------- /BartoszHaskellLove.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/BartoszHaskellLove.pdf -------------------------------------------------------------------------------- /TheDaoOfFP/DaoFP.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/TheDaoOfFP/DaoFP.pdf -------------------------------------------------------------------------------- /WeightedColimits.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/WeightedColimits.pdf -------------------------------------------------------------------------------- /CrashCourse ScalaIO.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/CrashCourse ScalaIO.pdf -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | *.pygtex 3 | *.pygstyle 4 | *.aux 5 | *.log 6 | *.out 7 | *.gz 8 | .DS_Store 9 | *.toc 10 | -------------------------------------------------------------------------------- /Profunctor_Optics_Topos.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/Profunctor_Optics_Topos.pdf -------------------------------------------------------------------------------- /FreeMonoidsInitialAlgebras.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/FreeMonoidsInitialAlgebras.pdf -------------------------------------------------------------------------------- /SolvingConstraintsWithMonads.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/SolvingConstraintsWithMonads.pdf -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/14-Applicative.hs: -------------------------------------------------------------------------------- 1 | class Monoidal f where 2 | unit :: f () 3 | (>*<) :: f a -> f b -> f (a, b) 4 | 5 | -------------------------------------------------------------------------------- /ProfunctorOptics-LambdaWorld2017.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/BartoszMilewski/Publications/HEAD/ProfunctorOptics-LambdaWorld2017.pdf -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/2-Composition.hs: -------------------------------------------------------------------------------- 1 | 2 | postCompWith :: (a -> b) -> (x -> a) -> (x -> b) 3 | postCompWith f = \h -> f . h 4 | 5 | preCompWith :: (a -> b) -> (b -> x) -> (a -> x) 6 | preCompWith f = \h -> h . f 7 | 8 | injectBool :: Bool -> Int 9 | injectBool b = if b then 1 else 0 10 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/18-Arrow.hs: -------------------------------------------------------------------------------- 1 | class Profunctor p where 2 | dimap :: (s -> a) -> (b -> t) -> (p a b -> p s t) 3 | 4 | class Profunctor p => PreArrow p where 5 | (>>>) :: p a x -> p x b -> p a b 6 | arr :: (a -> b) -> p a b 7 | 8 | class PreArrow p => Arrow p where 9 | first :: p a b -> p (a, c) (b, c) 10 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/18-SimpleLens.hs: -------------------------------------------------------------------------------- 1 | data LensE s a where 2 | LensE :: (s -> (c, a), (c, a) -> s) -> LensE s a 3 | 4 | 5 | toGet :: LensE s a -> (s -> a) 6 | toGet (LensE (l, r)) = snd . l 7 | 8 | toSet :: LensE s a -> (s -> a -> s) 9 | toSet (LensE (l, r)) s a = r (fst (l s), a) 10 | 11 | {- Doesn't compile 12 | getResidue :: LensE s a -> c 13 | getResidue (LensE (l, r)) = fst . l 14 | -} -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/20-DayHom.hs: -------------------------------------------------------------------------------- 1 | -- Exercise 2 | type DayHom g h a = forall b. g b -> h (a, b) 3 | 4 | data Day f g a where 5 | Day :: ((x, y) -> a) -> f x -> g y -> Day f g a 6 | 7 | -- Witnesses of the adjunction in the functor category 8 | 9 | ltor :: (forall a. Day f g a -> h a) -> (forall a. f a -> DayHom g h a) 10 | ltor day_h fa = \gb -> day_h (Day (uncurry (,)) fa gb) 11 | 12 | rtol :: Functor h => (forall a. f a -> DayHom g h a) -> (forall a. Day f g a -> h a) 13 | rtol f_hom (Day xy_a fx gy) = fmap xy_a (f_hom fx gy) -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/18-ProCompose.hs: -------------------------------------------------------------------------------- 1 | class Profunctor p where 2 | dimap :: (s -> a) -> (b -> t) -> (p a b -> p s t) 3 | 4 | data Procompose p q a b where 5 | Procompose :: q a x -> p x b -> Procompose p q a b 6 | 7 | mapOut :: Procompose p q a b -> (forall x. q a x -> p x b -> c) -> c 8 | mapOut (Procompose qax pxb) f = (f qax pxb) 9 | 10 | instance (Profunctor p, Profunctor q) => Profunctor (Procompose p q) 11 | where 12 | dimap l r (Procompose qax pxb) = 13 | Procompose (dimap l id qax) (dimap id r pxb) 14 | 15 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/1-Types.hs: -------------------------------------------------------------------------------- 1 | data Void 2 | -- Void has no constructor 3 | 4 | -- Unique arrow from the initial Void to any type a 5 | -- Since Void has no constructor, 6 | -- no element of Void can be passed to this function 7 | absurd :: Void -> a 8 | absurd v = undefined 9 | 10 | -- Unique arrow from any type a to () -- the terminal type 11 | unit :: a -> () 12 | unit a = () 13 | 14 | -- x is an element of the type Int 15 | -- it's value is 42 16 | x :: Int 17 | x = 42 18 | -- Categorically it's equivalent to: 19 | y :: () -> Int 20 | y () = 42 21 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/6-FunctionTypes.hs: -------------------------------------------------------------------------------- 1 | import Data.Complex 2 | 3 | curry :: ((c, a) -> b) -> (c -> (a -> b)) 4 | curry f = \c -> (\a -> f (c, a)) 5 | 6 | uncurry :: (c -> (a -> b)) -> ((c, a) -> b) 7 | uncurry f = \(c, a) -> f c a 8 | 9 | apply :: (a -> b, a) -> b 10 | apply (f, x) = f x 11 | 12 | ($) :: (a -> b) -> a -> b 13 | f $ x = f x 14 | 15 | pair :: a -> b -> (a, b) 16 | pair a b = (a, b) 17 | 18 | pairWithTen :: a -> (Int, a) 19 | pairWithTen = pair 10 -- partial application of pair 20 | 21 | type C = Complex Double 22 | 23 | h :: (Double, Double, Double) -> (C -> C) 24 | h (a, b, c) = \x -> (a :+ 0) * x * x + (b :+ 0) * x + (c :+ 0) 25 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/5-ProductTypes.hs: -------------------------------------------------------------------------------- 1 | thrd :: (a, b, c) -> c 2 | thrd (_, _, c) = c 3 | 4 | data Product a b = Pair { fst' :: a, snd' :: b } 5 | 6 | ic :: Product Int Char 7 | ic = Pair 10 'A' 8 | 9 | swap' :: (a, b) -> (b, a) 10 | swap' x = (snd x, fst x) 11 | 12 | swap (x, y) = (y, x) 13 | 14 | assoc :: ((a, b), c) -> (a, (b, c)) 15 | assoc ((a, b), c) = (a, (b, c)) 16 | 17 | runit :: (a, ()) -> a 18 | runit (a, _) = a 19 | 20 | class Monoid m where 21 | mappend :: (m, m) -> m 22 | mempty :: () -> m 23 | 24 | 25 | -- Exercises 26 | 27 | maybeAB :: Either b (a, b) -> (Maybe a, b) 28 | maybeAB (Left b) = (Nothing, b) 29 | maybeAB (Right (a, b)) = (Just a, b) 30 | -- Another possibility: 31 | -- maybeAB (Right (a, b)) = (Nothing, b) -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/9-Yoneda.hs: -------------------------------------------------------------------------------- 1 | yoneda :: Functor f => (forall x. (a -> x) -> f x) -> f a 2 | yoneda g = g id 3 | 4 | -- the inverse to yoneda 5 | yoneda_1 :: Functor f => f a -> (forall x. (a -> x) -> f x) 6 | yoneda_1 y = \h -> fmap h y 7 | 8 | class Contravariant f where 9 | contramap :: (b -> a) -> f a -> f b 10 | 11 | coyoneda :: Contravariant f => (forall x. (x -> a) -> f x) -> f a 12 | coyoneda g = g id 13 | 14 | -- the inverse to coyoneda 15 | coyoneda_1 :: Contravariant f => f a -> (forall x. (x -> a) -> f x) 16 | coyoneda_1 y = \h -> contramap h y 17 | 18 | 19 | toNatural :: (x -> y) -> (forall z. (z -> x) -> (z -> y)) 20 | toNatural f = \h -> f . h 21 | 22 | toNatural' :: (x -> y) -> (forall z. (z -> x) -> (z -> y)) 23 | toNatural' f = (f . ) 24 | 25 | fromNatural :: (forall z. (z -> x) -> (z -> y)) -> (x -> y) 26 | fromNatural alpha = alpha id 27 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/18-FreeApp.hs: -------------------------------------------------------------------------------- 1 | class Monoidal f where 2 | unit :: f () 3 | (>*<) :: f a -> f b -> f (a, b) 4 | 5 | data FreeA f x where 6 | DoneA :: x -> FreeA f x 7 | MoreA :: ((a, b) -> x) -> f a -> FreeA f b -> FreeA f x 8 | 9 | instance Functor f => Functor (FreeA f) where 10 | fmap :: Functor f => (x -> x') -> FreeA f x -> FreeA f x' 11 | fmap h (DoneA x) = DoneA (h x) 12 | fmap h (MoreA ab_x fa free_b) = MoreA (h . ab_x) fa free_b 13 | 14 | instance Functor f => Monoidal (FreeA f) where 15 | unit = DoneA () 16 | (DoneA x) >*< fry = fmap (x,) fry 17 | (MoreA abx fa frb) >*< fry = MoreA (reassoc abx) fa (frb >*< fry) 18 | 19 | reassoc :: ((a, b)-> x) -> (a, (b, y)) -> (x, y) 20 | reassoc abx (a, (b, y)) = (abx (a, b), y) 21 | 22 | instance Functor f => Applicative (FreeA f) where 23 | pure = DoneA 24 | ff <*> fx = fmap app (ff >*< fx) 25 | 26 | app :: (a -> b, a) -> b 27 | app (f, a) = f a 28 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/18-Coend.hs: -------------------------------------------------------------------------------- 1 | class Profunctor p where 2 | dimap :: (s -> a) -> (b -> t) -> (p a b -> p s t) 3 | 4 | data Coend p where 5 | Coend :: p x x -> Coend p 6 | 7 | newtype ProPair q p a b x y = ProPair (q a y, p x b) 8 | 9 | instance (Profunctor p, Profunctor q) => Profunctor (ProPair q p a b) where 10 | dimap :: (Profunctor p, Profunctor q) => (x' -> x)-> (y -> y') -> 11 | ProPair q p a b x y -> ProPair q p a b x' y' 12 | dimap l r (ProPair (qay, pxb)) = ProPair (dimap id r qay, dimap l id pxb) 13 | 14 | newtype CoEndCompose p q a b = CoEndCompose (Coend (ProPair q p a b)) 15 | 16 | instance (Profunctor p, Profunctor q) => Profunctor (CoEndCompose p q) where 17 | dimap :: (Profunctor p, Profunctor q) => (s -> a) -> (b -> t) -> 18 | CoEndCompose p q a b -> CoEndCompose p q s t 19 | dimap l r (CoEndCompose (Coend (ProPair (qay, pxb)))) = 20 | CoEndCompose (Coend (ProPair (dimap l id qay, dimap id r pxb))) 21 | 22 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/7-Nats.hs: -------------------------------------------------------------------------------- 1 | data Nat where 2 | Z :: Nat 3 | S :: Nat -> Nat 4 | 5 | zero, one, two, three :: Nat 6 | zero = Z 7 | one = S zero 8 | two = S one 9 | three = S two 10 | 11 | -- Elimination rule 12 | rec :: a -> (a -> a) -> (Nat -> a) 13 | rec init step = \n -> 14 | case n of 15 | Z -> init 16 | (S m) -> step (rec init step m) 17 | 18 | plus :: Nat -> Nat -> Nat 19 | plus n = rec init step 20 | where 21 | init = n 22 | step = S 23 | 24 | plus' :: Nat -> Nat -> Nat 25 | plus' n m = case m of 26 | Z -> n 27 | (S k) -> S (plus' k n) 28 | 29 | -- Exercises 30 | 31 | plus'' :: Nat -> (Nat -> Nat) 32 | plus'' n = rec init step n 33 | where 34 | init :: Nat -> Nat 35 | init = id 36 | -- Given a function that adds n to its argument 37 | -- Generate a function that adds (n + 1) to its argument 38 | step :: (Nat -> Nat) -> (Nat -> Nat) 39 | step f = S . f 40 | 41 | toInt :: Nat -> Int 42 | toInt n = rec init step n 43 | where 44 | init = 0 45 | step m = m + 1 46 | test = toInt (plus'' two three) -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/20-Lan.hs: -------------------------------------------------------------------------------- 1 | -- Left Kan extension of f along p 2 | data Lan p f b where 3 | Lan :: (p e -> b) -> f e -> Lan p f b 4 | 5 | unit :: forall p f e'. f e' -> Lan p f (p e') 6 | unit fe = Lan id fe 7 | 8 | -- Universal property 9 | 10 | type Alpha p f g = forall e. f e -> g (p e) 11 | 12 | sigma :: Functor g => Alpha p f g -> forall b. (Lan p f b -> g b) 13 | sigma alpha (Lan pe_b fe) = fmap pe_b (alpha fe) 14 | 15 | factorize :: Functor g => Alpha p f g -> f e -> g (p e) 16 | factorize alpha = sigma alpha . unit 17 | 18 | -- Exercise 19 | 20 | instance Functor (Lan p f) where 21 | fmap :: (b -> b') -> Lan p f b -> Lan p f b' 22 | fmap g (Lan pe_b fe) = Lan (g . pe_b) fe 23 | 24 | data Density f c where 25 | D :: (f d -> c) -> f d -> Density f c 26 | 27 | class Comonad w where 28 | extract :: w c -> c 29 | duplicate :: w c -> w (w c) 30 | 31 | instance Comonad (Density f) where 32 | extract :: Density f c -> c 33 | extract (D fd_c fd) = fd_c fd 34 | duplicate :: Density f c -> Density f (Density f c) 35 | duplicate (D fd_c fd) = D (D fd_c) fd 36 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/18-Ends.hs: -------------------------------------------------------------------------------- 1 | 2 | type End p = forall x. p x x 3 | 4 | data Coend p where 5 | Coend :: p x x -> Coend p 6 | 7 | type Natural f g = forall x. f x -> g x 8 | 9 | data Yo f a x y = Yo ((a -> x) -> f y) 10 | 11 | yoneda :: Functor f => End (Yo f a) -> f a 12 | yoneda (Yo g) = g id 13 | 14 | yoneda_1 :: Functor f => f a -> End (Yo f a) 15 | yoneda_1 fa = Yo (\h -> fmap h fa) 16 | 17 | data CoY f a x y = CoY (x -> a) (f y) 18 | 19 | coyoneda :: Functor f => Coend (CoY f a) -> f a 20 | coyoneda (Coend (CoY g fa)) = fmap g fa 21 | 22 | coyoneda_1 :: Functor f => f a -> Coend (CoY f a) 23 | coyoneda_1 fa = Coend (CoY id fa) 24 | 25 | data Day f g x where 26 | Day :: ((a, b) -> x) -> f a -> g b -> Day f g x 27 | 28 | instance Functor (Day f g) where 29 | fmap :: (a -> b) -> Day f g a -> Day f g b 30 | fmap h (Day xy_a fx gy) = Day (h . xy_a) fx gy 31 | 32 | assoc :: Day f (Day g h) x -> Day (Day f g) h x 33 | -- result Day yd_x (Day ac_y fa gc) hd 34 | -- pick y = (a, c) 35 | assoc (Day ab_x fa (Day cd_b gc hd)) = 36 | Day (\((a, c), d) -> ab_x (a, cd_b (c, d))) (Day id fa gc) hd 37 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/18-Lens.hs: -------------------------------------------------------------------------------- 1 | data LensE s t a b where 2 | LensE :: (s -> (c, a)) -> ((c, b) -> t) -> LensE s t a b 3 | 4 | toGet :: LensE s t a b -> (s -> a) 5 | toGet (LensE l r) = snd . l 6 | 7 | toSet :: LensE s t a b -> (s -> b -> t) 8 | toSet (LensE l r) s a = r (fst (l s), a) 9 | 10 | prodLens :: LensE (c, a) (c, b) a b 11 | prodLens = LensE id id 12 | 13 | compLens :: LensE a b a' b' -> LensE s t a b -> LensE s t a' b' 14 | compLens (LensE l2 r2) (LensE l1 r1) = LensE l3 r3 15 | where l3 = assoc' . bimap id l2 . l1 16 | r3 = r1 . bimap id r2 . assoc 17 | 18 | assoc :: ((c, c'), b') -> (c, (c', b')) 19 | assoc ((c, c'), b') = (c, (c', b')) 20 | 21 | assoc' :: (c, (c', a')) -> ((c, c'), a') 22 | assoc' (c, (c', a')) = ((c, c'), a') 23 | 24 | instance Bifunctor (,) where 25 | bimap f g (a, b) = (f a, g b) 26 | 27 | class Bifunctor f where 28 | bimap :: (a -> a') -> (b -> b') -> (f a b -> f a' b') 29 | 30 | l3 :: LensE (c, (c', a')) (c, (c', b')) a' b' 31 | l3 = compLens prodLens prodLens 32 | 33 | x :: (String, (Bool, Int)) 34 | x = ("Outer", (True, 42)) 35 | 36 | main :: IO () 37 | main = do 38 | print $ toGet l3 x 39 | print $ toSet l3 x 'z' 40 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/9-Universals.hs: -------------------------------------------------------------------------------- 1 | import Data.Bits 2 | 3 | apply :: (a -> b, a) -> b 4 | apply = uncurry id 5 | 6 | newtype LeftFunctor a b x = LF ((x, a) -> b) 7 | 8 | newtype RightFunctor a b x = RF (x -> (a -> b)) 9 | 10 | class Contravariant f where 11 | contramap :: (b -> a) -> (f a -> f b) 12 | 13 | class Bifunctor f where 14 | bimap :: (a -> a') -> (b -> b') -> (f a b -> f a' b') 15 | 16 | instance Bifunctor (,) where 17 | bimap g h (a, b) = (g a, h b) 18 | 19 | instance Contravariant (LeftFunctor a b) where 20 | contramap g (LF f) = LF (f . bimap g id) 21 | 22 | alpha :: forall a b x. LeftFunctor a b x -> RightFunctor a b x 23 | alpha (LF f) = RF (curry f) 24 | 25 | -- the inverse 26 | alpha_1 :: forall a b x. RightFunctor a b x -> LeftFunctor a b x 27 | alpha_1 (RF h) = LF (uncurry h) 28 | 29 | q :: Int -> Bool 30 | q n = n `mod` 2 == 0 31 | 32 | h :: (Int -> a) -> Bool -> a 33 | h q' True = q' 0 34 | h q' False = q' 1 35 | 36 | -- Exercises 37 | 38 | q' :: Int -> Bool 39 | q' x = testBit x 0 40 | test1 = fmap (h q' . q) [-1, 0, 1, 2, 3] 41 | test2 = fmap q' [-1, 0, 1, 2, 3] 42 | 43 | -- The equalizer of id and reverse 44 | 45 | q'' :: String -> Maybe Char 46 | q'' s = if even len 47 | then Nothing 48 | else Just (s !! (len `div` 2)) 49 | where len = length s 50 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/20-Ran.hs: -------------------------------------------------------------------------------- 1 | -- Right Kan extension of f along p 2 | 3 | newtype Ran p f b = Ran (forall e. (b -> p e) -> f e) 4 | 5 | counit :: forall p f e'. Ran p f (p e') -> f e' 6 | counit (Ran h) = h id 7 | 8 | -- Universal property 9 | 10 | type Alpha p f g = forall e. g (p e) -> f e 11 | 12 | sigma :: Functor g => Alpha p f g -> forall b. (g b -> Ran p f b) 13 | sigma alpha gb = Ran (\b_pe -> alpha $ fmap b_pe gb) 14 | 15 | factorize :: Functor g => Alpha p f g -> forall e. g (p e) -> f e 16 | factorize alpha = counit . sigma alpha 17 | 18 | -- By eqiational reasoning, this is equivalent to 19 | factorize' :: Functor g => Alpha p f g -> forall e. g (p e) -> f e 20 | factorize' alpha = alpha 21 | 22 | -- Codensity monad 23 | 24 | newtype Codensity f c = C (forall d. (c -> f d) -> f d) 25 | 26 | runCodensity :: Codensity f c -> forall d. (c -> f d) -> f d 27 | runCodensity (C h) = h 28 | 29 | -- Exercises 30 | 31 | instance Functor (Ran p f) where 32 | fmap :: (b -> b') -> Ran p f b -> Ran p f b' 33 | fmap g (Ran k) = Ran (\b'_pe -> k (b'_pe . g)) 34 | 35 | instance Functor (Codensity f) where 36 | fmap h (C k) = C (\c_fd -> k (c_fd . h)) 37 | 38 | instance Applicative (Codensity f) where 39 | pure :: c -> Codensity f c 40 | pure x = C (\k -> k x) 41 | (<*>) :: Codensity f (a -> b) -> Codensity f a -> Codensity f b 42 | C k <*> C k' = C (\b_fd -> k (\ab -> k' (b_fd . ab))) 43 | 44 | instance Monad (Codensity f) where 45 | return = pure 46 | m >>= kl = C (\k -> runCodensity m (\a -> runCodensity (kl a) k)) 47 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/7-List.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding (foldr, map) 2 | 3 | data List a where 4 | Nil :: List a 5 | Cons :: (a, List a) -> List a 6 | 7 | -- Elimination rule 8 | recList :: c -> ((a, c) -> c) -> (List a -> c) 9 | recList init step = \as -> 10 | case as of 11 | Nil -> init 12 | Cons (a, as) -> step (a, recList init step as) 13 | 14 | foldr :: (a -> c -> c) -> c -> [a] -> c 15 | foldr step init = \as -> 16 | case as of 17 | [] -> init 18 | a : as -> step a (foldr step init as) 19 | 20 | sum :: [Nat] -> Nat 21 | sum = foldr plus Z 22 | 23 | -- From previous module 24 | 25 | data Nat where 26 | Z :: Nat 27 | S :: Nat -> Nat 28 | 29 | plus :: Nat -> Nat -> Nat 30 | plus n m = case m of 31 | Z -> n 32 | (S k) -> S (plus k n) 33 | 34 | -- Functoriality 35 | mapList :: (a -> b) -> List a -> List b 36 | mapList f = recList init step 37 | where 38 | init = Nil 39 | step (a, bs) = Cons (f a, bs) 40 | 41 | map :: (a -> b) -> [a] -> [b] 42 | map f [] = [] 43 | map f (a : as) = f a : map f as 44 | 45 | badMap :: (a -> b) -> [a] -> [b] 46 | badMap f [] = [] 47 | badMap f (a : as) = badMap f as 48 | 49 | test' = badMap id [1, 2, 3] 50 | 51 | -- Exercises 52 | h :: [a] -> Maybe a 53 | h [] = Nothing 54 | h (a : as) = Just a 55 | 56 | h' :: [a] -> Maybe a 57 | h' [] = Nothing 58 | h' (a : as) = h as 59 | 60 | third :: [a] -> Maybe a 61 | third [] = Nothing 62 | third (a : as) = second as 63 | second :: [a] -> Maybe a 64 | second [] = Nothing 65 | second (a : as) = h as 66 | 67 | test = third [1, 2, 3, 4] 68 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/19-Tannaka.hs: -------------------------------------------------------------------------------- 1 | --import Data.Functor.Identity 2 | import Prelude hiding(reverse) 3 | import Data.Bool (bool) 4 | 5 | -- Cayley 6 | 7 | reverse :: [a] -> [a] 8 | reverse [] = [] 9 | reverse (a : as) = reverse as ++ [a] 10 | 11 | {- Imported from Prelude 12 | instance Monoid [a] where 13 | mempty = [] 14 | mappend as bs = as ++ bs 15 | -} 16 | 17 | type DList a = [a] -> [a] 18 | 19 | rep :: [a] -> DList a 20 | rep as = \xs -> as ++ xs 21 | 22 | unRep :: DList a -> [a] 23 | unRep f = f [] 24 | 25 | -- rep [] = id 26 | -- rep (xs ++ ys) = rep xs . rep ys 27 | 28 | rev :: [a] -> DList a 29 | rev [] = rep [] 30 | rev (a : as) = rev as . rep [a] 31 | 32 | fastReverse :: [a] -> [a] 33 | fastReverse = unRep . rev 34 | 35 | test2 = take 10 $ reverse [1..10000000] 36 | test3 = take 10 $ fastReverse [1..10000000] 37 | 38 | reverse' :: [a] -> [a] 39 | reverse' = foldl (\as a -> a : as) [] 40 | 41 | -- Tannaka 42 | 43 | data Identity a = Identity a 44 | 45 | runIdentity :: Identity a -> a 46 | runIdentity (Identity a) = a 47 | 48 | instance Functor Identity where 49 | fmap g (Identity a) = Identity (g a) 50 | 51 | toTannaka :: (a -> b) -> (forall f. Functor f => f a -> f b) 52 | toTannaka g fa = fmap g fa 53 | 54 | fromTannaka :: (forall f. Functor f => f a -> f b) -> (a -> b) 55 | fromTannaka g a = runIdentity (g (Identity a)) 56 | 57 | type Getter a b = forall f. Functor f => f a -> f b 58 | 59 | boolToStrGetter :: Getter Bool String 60 | boolToStrGetter = toTannaka show . toTannaka (bool (-1) 1) 61 | 62 | test1 :: String 63 | test1 = (fromTannaka boolToStrGetter) False 64 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/8-Functors.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding (Functor, fmap) 2 | import Data.Kind ( Type ) 3 | 4 | class Functor f where 5 | fmap :: (a -> b) -> (f a -> f b) 6 | 7 | instance Functor Maybe where 8 | fmap g Nothing = Nothing 9 | fmap g (Just a) = Just (g a) 10 | 11 | data WithInt a = WithInt a Int 12 | 13 | instance Functor WithInt where 14 | fmap f (WithInt a n) = WithInt (f a) n 15 | 16 | newtype Identity a = Identity a 17 | 18 | instance Functor Identity where 19 | fmap f (Identity a) = Identity (f a) 20 | 21 | newtype Constant c a = Constant c 22 | 23 | instance Functor (Constant c) where 24 | fmap f (Constant c) = (Constant c) 25 | 26 | class Bifunctor f where 27 | bimap :: (a -> a') -> (b -> b') -> (f a b -> f a' b') 28 | 29 | instance Bifunctor (,) where 30 | bimap g h (a, b) = (g a, h b) 31 | 32 | data MoreThanA a b = More a (Maybe b) 33 | 34 | instance Bifunctor MoreThanA where 35 | bimap g h (More a Nothing) = More (g a) Nothing 36 | bimap g h (More a (Just b)) = More (g a) (Just (h b)) 37 | 38 | class Contravariant f where 39 | contramap :: (b -> a) -> (f a -> f b) 40 | 41 | newtype Predicate a = Predicate (a -> Bool) 42 | 43 | instance Contravariant Predicate where 44 | contramap f (Predicate h) = Predicate (h . f) 45 | 46 | newtype Tester a = Tester ((a -> Bool) -> Bool) 47 | 48 | instance Functor Tester where 49 | fmap f (Tester g) = Tester g' 50 | where g' h = g (h . f) 51 | 52 | class Profunctor f where 53 | dimap :: (a' -> a) -> (b -> b') -> (f a b -> f a' b') 54 | 55 | instance Profunctor (->) where 56 | dimap f g h = g . h . f 57 | 58 | newtype Compose' g f a = Compose' (g (f a)) 59 | 60 | data Compose :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) 61 | where 62 | Compose :: (g (f a)) -> Compose g f a 63 | 64 | instance (Functor g, Functor f) => Functor (Compose g f) where 65 | fmap h (Compose gfa) = Compose (fmap (fmap h) gfa) 66 | 67 | instance (Functor g, Contravariant f) => Contravariant (Compose g f) where 68 | contramap h (Compose gfa) = Compose (fmap (contramap h) gfa) 69 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/9-Natural.hs: -------------------------------------------------------------------------------- 1 | import Data.Kind (Type) 2 | import Prelude hiding (reverse) 3 | import GHC.CmmToAsm.AArch64.Instr (x0) 4 | 5 | data Natural' :: (Type -> Type) -> (Type -> Type) -> Type where 6 | Natural' :: (forall a. f a -> g a) -> Natural' f g 7 | 8 | type Natural f g = forall a. f a -> g a 9 | 10 | oneWay :: 11 | forall f g a b. (Functor f, Functor g) => 12 | Natural f g -> (a -> b) -> f a -> g b 13 | oneWay alpha h = fmap @g h . alpha @a 14 | 15 | otherWay :: 16 | forall f g a b. (Functor f, Functor g) => 17 | Natural f g -> (a -> b) -> f a -> g b 18 | otherWay alpha h = alpha @b . fmap @f h 19 | 20 | safeHead :: Natural [] Maybe 21 | safeHead [] = Nothing 22 | safeHead (a : as) = Just a 23 | 24 | reverse :: Natural [] [] 25 | reverse [] = [] 26 | reverse (a : as) = reverse as ++ [a] 27 | 28 | -- Horizontal composition 29 | 30 | -- Define some dummy functors 31 | data F x 32 | data F' x 33 | data G x 34 | data G' x 35 | data H x 36 | instance Functor G' where 37 | fmap = undefined 38 | instance Functor G where 39 | fmap = undefined 40 | instance Functor H where 41 | fmap = undefined 42 | 43 | -- Define some dummy natural transformations 44 | 45 | alpha :: forall x. F x -> F' x 46 | alpha = undefined 47 | 48 | beta :: forall x. G x -> G' x 49 | beta = undefined 50 | 51 | beta_alpha :: forall x. G (F x) -> G' (F' x) 52 | beta_alpha = beta . fmap alpha 53 | 54 | beta_alpha' = fmap alpha . beta 55 | 56 | -- Whiskering 57 | 58 | beta_f :: forall x. G (F x) -> G' (F x) 59 | beta_f = beta 60 | 61 | g_alpha :: forall x. G (F x) -> G (F' x) 62 | g_alpha = fmap alpha 63 | 64 | h_beta_f :: forall x. H (G (F x)) -> H (G' (F x)) 65 | h_beta_f = fmap beta 66 | 67 | -- Exercises 68 | -- safeHead :: Natural [] Maybe 69 | -- reverse :: Natural [] [] 70 | 71 | comp1 :: [[a]] -> Maybe [a] 72 | comp1 = safeHead . fmap reverse 73 | 74 | comp2 :: [[a]] -> Maybe [a] 75 | comp2 = fmap reverse . safeHead 76 | 77 | test1 = comp1 [[], [4], [5, 6]] 78 | test2 = comp2 [[], [4], [5, 6]] 79 | 80 | comp1' :: [[a]] -> [Maybe a] 81 | comp1' = reverse . fmap safeHead 82 | 83 | comp2' :: [[a]] -> [Maybe a] 84 | comp2' = fmap safeHead . reverse 85 | 86 | test1' = comp1 [[], [4], [5, 6]] 87 | test2' = comp2 [[], [4], [5, 6]] -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/19-Optics.hs: -------------------------------------------------------------------------------- 1 | class Profunctor p where 2 | dimap :: (a' -> a) -> (b -> b') -> p a b -> p a' b' 3 | 4 | type Iso s t a b = (s -> a, b -> t) 5 | 6 | type IsoP s t a b = forall p. Profunctor p => p a b -> p s t 7 | 8 | toIsoP :: (s -> a, b -> t) -> IsoP s t a b 9 | toIsoP (f, g) = dimap f g 10 | 11 | class Profunctor p => Cartesian p where 12 | alpha :: p a b -> p (c, a) (c, b) 13 | 14 | data LensE s t a b where 15 | LensE :: (s -> (c, a)) -> ((c, b) -> t) -> LensE s t a b 16 | 17 | type LensP s t a b = forall p. Cartesian p => p a b -> p s t 18 | 19 | toLensP :: LensE s t a b -> LensP s t a b 20 | toLensP (LensE from to) = dimap from to . alpha 21 | 22 | data FlipLens a b s t = FlipLens (s -> a) (s -> b -> t) 23 | 24 | instance Profunctor (FlipLens a b) where 25 | dimap f g (FlipLens get set) = FlipLens (get . f) (fmap g . set . f) 26 | 27 | instance Cartesian (FlipLens a b) where 28 | alpha(FlipLens get set) = FlipLens get' set' 29 | where get' = get . snd 30 | set' = \(x, s) b -> (x, set s b) 31 | 32 | fromLensP :: LensP s t a b -> (s -> a, s -> b -> t) 33 | fromLensP pp = (get', set') 34 | where FlipLens get' set' = pp (FlipLens id (\s b -> b)) 35 | 36 | -- Exercise solutions 37 | 38 | fromIsoP :: IsoP s t a b -> (s -> a, b -> t) 39 | fromIsoP h = unAd (h (Ad (id, id))) 40 | 41 | newtype Adapter a b s t = Ad (s -> a, b -> t) 42 | 43 | unAd :: Adapter a b s t -> (s -> a, b -> t) 44 | unAd (Ad p) = p 45 | 46 | instance Profunctor (Adapter a b) where 47 | dimap f g (Ad (h, h')) = Ad (h . f, g . h') 48 | 49 | data Prism s t a b where 50 | Prism :: (s -> Either c a) -> (Either c b -> t) -> Prism s t a b 51 | 52 | toMatch :: Prism s t a b -> (s -> Either t a) 53 | toMatch (Prism from to) s = 54 | case from s of 55 | Left c -> Left (to (Left c)) 56 | Right a -> Right a 57 | 58 | toBuild :: Prism s t a b -> (b -> t) 59 | toBuild (Prism from to) b = to (Right b) 60 | 61 | toPrism :: (s -> Either t a) -> (b -> t) -> Prism s t a b 62 | toPrism match build = Prism from to 63 | where 64 | from = match 65 | to (Left c) = c 66 | to (Right b) = build b 67 | 68 | class Profunctor p => Cocartesian p where 69 | alpha' :: p a b -> p (Either c a) (Either c b) 70 | 71 | type PrismP s t a b = forall p. Cocartesian p => p a b -> p s t 72 | 73 | toPrismP :: Prism s t a b -> PrismP s t a b 74 | toPrismP (Prism from to) = dimap from to . alpha' 75 | 76 | type Traversal s t a b = s -> ([b] -> t, [a]) 77 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/6-Revisited.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding (either) 2 | 3 | -- Universal property of sum 4 | mapOut :: (a -> c, b -> c) -> (Either a b -> c) 5 | mapOut (f, g) = \aorb -> case aorb of 6 | Left a -> f a 7 | Right b -> g b 8 | 9 | either :: (a -> c) -> (b -> c) -> Either a b -> c 10 | either f _ (Left x) = f x 11 | either _ g (Right y) = g y 12 | 13 | unEither :: (Either a b -> c) -> (a -> c, b -> c) 14 | unEither h = (h . Left, h . Right) 15 | 16 | -- Universal property of product 17 | mapIn :: (c -> a, c -> b) -> (c -> (a, b)) 18 | mapIn (f, g) = \c -> (f c, g c) 19 | 20 | (&&&) :: (c -> a) -> (c -> b) -> (c -> (a, b)) 21 | (f &&& g) c = (f c, g c) 22 | 23 | fork :: (c -> (a, b)) -> (c -> a, c -> b) 24 | fork h = (fst . h, snd . h) 25 | 26 | -- Functoriality of sum 27 | h :: (a -> a') -> (b -> b') -> Either a b -> Either a' b' 28 | h f g = either (Left . f) (Right . g) 29 | 30 | bimap :: (a -> a') -> (b -> b') -> Either a b -> Either a' b' 31 | bimap f g (Left a) = Left (f a) 32 | bimap f g (Right b) = Right (g b) 33 | 34 | 35 | -- Functoriality of product 36 | h' :: (a -> a') -> (b -> b') -> (a, b) -> (a', b') 37 | h' f g = (f . fst) &&& (g . snd) 38 | 39 | bimap' :: (a -> a') -> (b -> b') -> (a, b) -> (a', b') 40 | bimap' f g (a, b) = (f a, g b) 41 | 42 | -- Functoriality of function type 43 | dimap :: (a' -> a) -> (b -> b') -> (a -> b) -> (a' -> b') 44 | dimap f g h = g . h . f 45 | 46 | -- Distributivity 47 | dist'' :: Either (b, a) (c, a) -> (Either b c, a) 48 | dist'' = either f g 49 | where 50 | f :: (b, a) -> (Either b c, a) 51 | f = f' &&& f'' 52 | g :: (c, a) -> (Either b c, a) 53 | g = g' &&& g'' 54 | f' :: (b, a) -> Either b c 55 | f' = Left . fst 56 | g' :: (c, a) -> Either b c 57 | g' = Right . fst 58 | f'' :: (b, a) -> a 59 | f'' = snd 60 | g'' :: (c, a) -> a 61 | g'' = snd 62 | 63 | dist' :: Either (b, a) (c, a) -> (Either b c, a) 64 | dist' = either ((Left . fst) &&& snd) ((Right . fst) &&& snd) 65 | 66 | dist :: Either (b, a) (c, a) -> (Either b c, a) 67 | dist (Left (b, a)) = (Left b, a) 68 | dist (Right (c, a)) = (Right c, a) 69 | 70 | undist :: (Either b c, a) -> Either (b, a) (c, a) 71 | undist (Left b, a) = Left (b, a) 72 | undist (Right c, a) = Right (c, a) 73 | 74 | undist' = uncurry (either (curry Left) (curry Right)) 75 | 76 | -- Exercises 77 | -- 2 x a = a + a 78 | toSum :: (Bool, a) -> Either a a 79 | toSum (True, a) = Left a 80 | toSum (False, a) = Right a 81 | 82 | fromSum :: Either a a -> (Bool, a) 83 | fromSum (Left a) = (True, a) 84 | fromSum (Right a) = (False, a) -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/4-SumTypes.hs: -------------------------------------------------------------------------------- 1 | -- We want to use our own definitions here 2 | import Prelude hiding (Either, Left, Right, Maybe, Nothing, Just) 3 | 4 | -- We primed some definition to avoid name conflicts 5 | data Bool' where 6 | True' :: () -> Bool' 7 | False' :: () -> Bool' 8 | 9 | data Bool'' where 10 | True'' :: Bool'' 11 | False'' :: Bool'' 12 | 13 | x' :: Bool 14 | x' = True 15 | 16 | type A = Int -- any type will do 17 | 18 | x :: A 19 | x = 5 20 | y :: A 21 | y = 7 22 | z :: A 23 | z = 11 24 | 25 | h :: Bool -> A 26 | h b = if b then x else y 27 | 28 | not :: Bool -> Bool 29 | not b = if b then False else True 30 | 31 | data RGB where 32 | Red :: RGB 33 | Green :: RGB 34 | Blue :: RGB 35 | 36 | c :: RGB 37 | c = Blue 38 | 39 | h1 :: RGB -> A 40 | h1 Red = x 41 | h1 Green = y 42 | h1 Blue = z 43 | 44 | h2 :: Bool -> A 45 | h2 True = x 46 | h2 False = y 47 | 48 | h3 :: RGB -> A 49 | h3 c = case c of 50 | Red -> x 51 | Green -> y 52 | Blue -> z 53 | 54 | h4 :: Bool -> A 55 | h4 b = case b of 56 | True -> x 57 | False -> y 58 | 59 | c' :: Char 60 | c' = 'a' 61 | 62 | yesno :: Char -> Bool 63 | yesno c = case c of 64 | 'y' -> True 65 | 'Y' -> True 66 | _ -> False 67 | 68 | data Either a b where 69 | Left :: a -> Either a b 70 | Right :: b -> Either a b 71 | 72 | -- Placate the compiler with 'undefined' 73 | f :: a -> c 74 | f = undefined 75 | g :: b -> c 76 | g = undefined 77 | 78 | h5 :: Either a b -> c 79 | h5 (Left a) = f a 80 | h5 (Right b) = g b 81 | 82 | h6 :: Either a b -> c 83 | h6 e = case e of 84 | Left a -> f a 85 | Right b -> g b 86 | 87 | data Maybe' a where 88 | Nothing' :: () -> Maybe' a 89 | Just' :: a -> Maybe' a 90 | 91 | data Maybe a = Nothing | Just a 92 | 93 | data Void 94 | absurd :: a -> Void 95 | absurd a = undefined 96 | 97 | f' :: Either () Void -> () 98 | f' (Left ()) = () 99 | f' (Right _) = () 100 | 101 | f_1 :: () -> Either () Void 102 | f_1 _ = Left () 103 | 104 | -- Exercises 105 | 106 | from :: Either a Void -> a 107 | from (Left a) = a 108 | from (Right v) = undefined -- will never be called 109 | 110 | to :: a -> Either a Void 111 | to x = Left x 112 | 113 | sym :: Either a b -> Either b a 114 | sym (Left a) = Right a 115 | sym (Right b) = Left b 116 | 117 | f1 :: a -> x 118 | f1 = undefined 119 | f2 :: b -> x 120 | f2 = undefined 121 | f3 :: c -> x 122 | f3 = undefined 123 | 124 | h7 :: Either (Either a b) c -> x 125 | h7 (Left (Left a)) = f1 a 126 | h7 (Left (Right b)) = f2 b 127 | h7 (Right c) = f3 c 128 | 129 | h7' :: Either a (Either b c) -> x 130 | h7' (Left a) = f1 a 131 | h7' (Right (Left b)) = f2 b 132 | h7' (Right (Right c)) = f3 c 133 | -------------------------------------------------------------------------------- /TheDaoOfFP/Haskell/15-FreeMonad.hs: -------------------------------------------------------------------------------- 1 | import Data.Kind ( Type ) 2 | import Data.Functor.Const 3 | 4 | type Natural f g = forall a. f a -> g a 5 | 6 | class HFunctor (hf :: (Type -> Type) -> Type -> Type) where 7 | hmap :: (Functor f, Functor g) => 8 | Natural f g -> Natural (hf f) (hf g) 9 | 10 | data Phi f g a where 11 | IdF :: a -> Phi f g a 12 | CompF :: f (g a) -> Phi f g a 13 | 14 | instance Functor f => HFunctor (Phi f) where 15 | hmap :: (Functor f, Functor g, Functor h) => 16 | Natural g h -> Natural (Phi f g) (Phi f h) 17 | hmap alpha (IdF a) = IdF a 18 | hmap alpha (CompF fga) = CompF (fmap alpha fga) 19 | 20 | instance (Functor f, Functor g) => Functor (Phi f g) where 21 | fmap h (IdF a) = IdF (h a) 22 | fmap h (CompF fga) = CompF (fmap (fmap h) fga) 23 | 24 | data FreeMonad f a where 25 | Pure :: a -> FreeMonad f a 26 | Free :: f (FreeMonad f a) -> FreeMonad f a 27 | 28 | instance HFunctor FreeMonad where 29 | hmap :: (Functor f, Functor g) => 30 | Natural f g -> Natural (FreeMonad f) (FreeMonad g) 31 | hmap _ (Pure a) = Pure a 32 | hmap alpha (Free ffa) = Free (alpha (fmap (hmap alpha) ffa)) 33 | 34 | instance (Functor f) => Functor (FreeMonad f) where 35 | fmap h (Pure a) = Pure (h a) 36 | fmap h (Free ffa) = Free (fmap (fmap h) ffa) 37 | 38 | eta :: a -> FreeMonad f a 39 | eta = Pure 40 | 41 | mu :: Functor f => FreeMonad f (FreeMonad f a) -> FreeMonad f a 42 | mu (Pure fa) = fa 43 | mu (Free ffa) = Free (fmap mu ffa) 44 | 45 | instance Functor f => Applicative (FreeMonad f) where 46 | pure = eta 47 | Pure f <*> Pure a = Pure (f a) 48 | Pure f <*> Free ffa = Free (fmap (fmap f) ffa) 49 | Free ff <*> fa = Free (fmap (<*> fa) ff) 50 | 51 | instance Functor f => Monad (FreeMonad f) where 52 | return = pure 53 | (Pure a) >>= k = k a 54 | (Free ffa) >>= k = Free (fmap (>>= k) ffa) 55 | -- or, equivalently, using mu: 56 | -- m >>= k = mu (fmap k m) 57 | 58 | type MAlg f g a = (a -> g a, f (g a) -> g a) 59 | 60 | mcata :: Functor f => MAlg f g a -> FreeMonad f a -> g a 61 | mcata (l, r) (Pure a) = l a 62 | mcata (l, r) (Free ffa) = 63 | r (fmap (mcata (l, r)) ffa) 64 | 65 | -- Stack calculator 66 | 67 | data StackF k = Push Int k 68 | | Top (Int -> k) 69 | | Pop k 70 | | Add k 71 | deriving Functor 72 | 73 | type FreeStack = FreeMonad StackF 74 | 75 | liftF :: (Functor f) => f r -> FreeMonad f r 76 | liftF fr = Free (fmap Pure fr) 77 | 78 | push :: Int -> FreeStack () 79 | push n = liftF (Push n ()) 80 | 81 | pop :: FreeStack () 82 | pop = liftF (Pop ()) 83 | 84 | top :: FreeStack Int 85 | top = liftF (Top id) 86 | 87 | add :: FreeStack () 88 | add = liftF (Add ()) 89 | 90 | calc :: FreeStack Int 91 | calc = do 92 | push 3 93 | push 4 94 | add 95 | x <- top 96 | pop 97 | return x 98 | 99 | newtype StackAction k = St ([Int] -> ([Int], k)) 100 | deriving Functor 101 | 102 | runAction :: StackAction k -> [Int] -> ([Int], k) 103 | runAction (St act) ns = act ns 104 | 105 | runAlg :: MAlg StackF StackAction a 106 | runAlg = (stop, go) 107 | where 108 | stop :: a -> StackAction a 109 | stop a = St (\xs -> (xs, a)) 110 | 111 | go :: StackF (StackAction k) -> StackAction k 112 | go (Pop k) = St (\ns -> runAction k (tail ns)) 113 | go (Top ik) = St (\ns -> runAction (ik (head ns)) ns) 114 | go (Push n k) = St (\ns -> runAction k (n: ns)) 115 | go (Add k) = St (\ns -> runAction k 116 | ((head ns + head (tail ns)): tail (tail ns))) 117 | 118 | run :: FreeMonad StackF k -> ([Int], k) 119 | run prog = runAction (mcata runAlg prog) [] 120 | 121 | test1 :: ([Int], Int) 122 | test1 = run calc 123 | 124 | -- Exercises 125 | 126 | data Rose a = Leaf a | Rose [Rose a] 127 | deriving Functor 128 | 129 | roseToFree :: Rose a -> FreeMonad [] a 130 | roseToFree (Leaf a) = Pure a 131 | roseToFree (Rose rs) = Free (fmap roseToFree rs) 132 | 133 | freeToRose :: FreeMonad [] a -> Rose a 134 | freeToRose (Pure a) = Leaf a 135 | freeToRose (Free as) = Rose (fmap freeToRose as) 136 | 137 | data Bin a = Bin a a 138 | 139 | data Tree a = Tip a | Branch (Tree a) (Tree a) 140 | 141 | treeToFree :: Tree a -> FreeMonad Bin a 142 | treeToFree (Tip a) = Pure a 143 | treeToFree (Branch left right) = Free (Bin (treeToFree left) (treeToFree right)) 144 | 145 | freeToTree :: FreeMonad Bin a -> Tree a 146 | freeToTree (Pure a) = Tip a 147 | freeToTree (Free (Bin left right)) = Branch (freeToTree left) (freeToTree right) 148 | 149 | showAlg :: MAlg StackF (Const String) a 150 | showAlg = (stop, go) 151 | where stop :: a -> Const String a 152 | stop a = Const "Stop! " 153 | go :: StackF (Const String a) -> Const String a 154 | go (Push n k) = Const ("Push " ++ show n ++ " " ++ getConst k) 155 | go (Top k) = Const ("Top " ++ getConst (k 42)) -- dummy 156 | go (Pop k) = Const ("Pop " ++ getConst k) 157 | go (Add k) = Const ("Add " ++ getConst k) 158 | 159 | test2 = getConst $ mcata showAlg calc 160 | --------------------------------------------------------------------------------