Free monad with classy prisms on grammar

free-classy-prisms.hs

{-# 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 ())