Skip to content

Instantly share code, notes, and snippets.

@tonymorris
Created April 28, 2017 07:35
Show Gist options
  • Save tonymorris/935e19c091c04f33cdc5b2daf05cfdd9 to your computer and use it in GitHub Desktop.
Save tonymorris/935e19c091c04f33cdc5b2daf05cfdd9 to your computer and use it in GitHub Desktop.
Free monad with classy prisms on grammar
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveFunctor #-}
import Control.Lens
import Prelude hiding (readFile, writeFile, print)
import qualified Prelude as Prelude(readFile, writeFile, print)
data Free f a =
Done a
| More (f (Free f a))
instance Functor f => Functor (Free f) where
fmap f (Done a) =
Done (f a)
fmap f (More x) =
More (fmap (fmap f) x)
instance Functor f => Applicative (Free f) where
pure =
Done
Done f <*> Done a =
Done (f a)
Done f <*> More x =
More (fmap (fmap f) x)
More f <*> x =
More (fmap (<*> x) f)
instance Functor f => Monad (Free f) where
return =
Done
Done a >>= k =
k a
More f >>= k =
More (fmap (>>= k) f)
lift ::
Functor f =>
f a
-> Free f a
lift =
More . fmap Done
----
data ReadFile a =
ReadFile FilePath (String -> a)
class AsReadFile f where
_ReadFile :: Prism' (f a) (ReadFile a)
instance AsReadFile ReadFile where
_ReadFile =
id
instance Functor ReadFile where
fmap f (ReadFile p g) =
ReadFile p (f . g)
data WriteFile a =
WriteFile FilePath String a
class AsWriteFile f where
_WriteFile :: Prism' (f a) (WriteFile a)
instance AsWriteFile WriteFile where
_WriteFile =
id
instance Functor WriteFile where
fmap f (WriteFile p s a) =
WriteFile p s (f a)
data Print a =
Print String a
class AsPrint f where
_Print :: Prism' (f a) (Print a)
instance AsPrint Print where
_Print =
id
instance Functor Print where
fmap f (Print s a) =
Print s (f a)
data Coproduct f g a =
This (f a)
| That (g a)
swap ::
Coproduct f g a
-> Coproduct g f a
swap (This x) =
That x
swap (That x) =
This x
class AsThis (k :: (* -> *) -> (* -> *) -> * -> *) where
_This ::
Prism'
(k f g a)
(f a)
instance AsThis Coproduct where
_This =
prism'
This
(\c -> case c of
This x ->
Just x
That _ ->
Nothing)
class AsThat (k :: (* -> *) -> (* -> *) -> * -> *) where
_That ::
Prism'
(k f g a)
(g a)
instance AsThat Coproduct where
_That =
prism'
That
(\c -> case c of
This _ ->
Nothing
That x ->
Just x)
instance (Functor f, Functor g) => Functor (Coproduct f g) where
fmap f (This x) =
This (fmap f x)
fmap f (That y) =
That (fmap f y)
----
writeFile ::
(Functor f, AsWriteFile f) =>
FilePath
-> String
-> Free f ()
writeFile p s =
lift (_WriteFile # WriteFile p s ())
readFile ::
(Functor f, AsReadFile f) =>
FilePath
-> Free f String
readFile p =
lift (_ReadFile # ReadFile p id)
print ::
(Functor f, AsPrint f) =>
String
-> Free f ()
print s =
lift (_Print # Print s ())
----
class AsIO f where
asIO ::
f a
-> IO a
instance AsIO ReadFile where
asIO (ReadFile p k) =
fmap k (Prelude.readFile p)
instance AsIO WriteFile where
asIO (WriteFile p s k) =
fmap (\() -> k) (Prelude.writeFile p s)
instance AsIO Print where
asIO (Print s k) =
fmap (\() -> k) (Prelude.print s)
instance (AsIO f, AsIO g) => AsIO (Coproduct f g) where
asIO (This x) =
asIO x
asIO (That y) =
asIO y
interpret ::
AsIO f =>
Free f a
-> IO a
interpret (Done a) =
pure a
interpret (More x) =
asIO x >>= interpret
----
newtype ReadFilePrint a =
ReadFilePrint (Coproduct ReadFile Print a)
deriving Functor
makeWrapped '' ReadFilePrint
instance AsReadFile ReadFilePrint where
_ReadFile =
_Wrapped . _This . _ReadFile
instance AsPrint ReadFilePrint where
_Print =
_Wrapped . _That . _Print
instance AsIO ReadFilePrint where
asIO r =
asIO (r ^. _Wrapped)
newtype ReadFilePrintWriteFile a =
ReadFilePrintWriteFile (Coproduct (Coproduct ReadFile Print) WriteFile a)
deriving Functor
makeWrapped '' ReadFilePrintWriteFile
instance AsReadFile ReadFilePrintWriteFile where
_ReadFile =
_Wrapped . _This . _This . _ReadFile
instance AsPrint ReadFilePrintWriteFile where
_Print =
_Wrapped . _This . _That . _Print
instance AsWriteFile ReadFilePrintWriteFile where
_WriteFile =
_Wrapped . _That . _WriteFile
instance AsIO ReadFilePrintWriteFile where
asIO r =
asIO (r ^. _Wrapped)
program1 ::
(Functor f, AsReadFile f, AsPrint f) =>
Free f ()
program1 = do f <- readFile "/etc/ntp.conf"
print f
program2 ::
(Functor f, AsReadFile f, AsWriteFile f, AsPrint f) =>
Free f ()
program2 = do f <- readFile "/etc/shells"
writeFile "/tmp/abc" "hi"
print f
main ::
IO ()
main =
do interpret (program1 :: Free ReadFilePrint ())
interpret (program2 :: Free ReadFilePrintWriteFile ())
interpret (program1 :: Free ReadFilePrintWriteFile ())
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment