IxMonadT.hs

{- stack script
 --resolver lts-14.20
 -}

{-# Language RebindableSyntax
           , ScopedTypeVariables
           , FlexibleInstances
           , NoMonomorphismRestriction
           , OverloadedStrings
           , InstanceSigs
           , RoleAnnotations
#-}

module IxMonadParser where

import Prelude (fromIntegral, fromInteger, IO, Show, print, putStrLn)

import Control.Applicative (pure, (<$>))
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Coerce (Coercible, coerce)
import Data.Function (($), (.))
import Data.Int (Int)
import Data.String (fromString)
import Data.Text (Text)
import Data.Tuple (fst, snd)
import GHC.Generics (Generic)
import qualified Control.Monad.IO.Class as CM
import qualified Control.Monad as CM

-- Define Example data
newtype SourceCode = SourceCode Text
newtype Tokenized = Tokenized [Text]
data    Expr = EInt Int | EStr Text | EVar Text | EApp Expr Expr deriving (Show)
newtype Syntax = Syntax { unSyntax :: Expr } deriving (Show)
newtype Core  = Core { unCore :: Expr } deriving (Show)

-- example transitions
source2Toke :: SourceCode -> Tokenized
source2Toke (SourceCode txt) = Tokenized [txt] -- can we coerce here as well?

toke2Syntax :: Tokenized -> Syntax
toke2Syntax _ = Syntax $ EApp (EVar "Fn") $ EInt . fromIntegral  $ 42

syntax2Core :: Syntax -> Core
syntax2Core = coerce -- "safe" newtype coerce

-- indexed monad
newtype IxMonadT i o m a = IxMonadT { runIx :: i -> m (a, o) }

evalIxMonadT :: (CM.Functor m) => IxMonadT i o m a -> i -> m a
evalIxMonadT st i = fst <$> runIx st i

execIxMonadT :: (CM.Functor m) => IxMonadT i o m a -> i -> m o
execIxMonadT st i = snd <$> runIx st i

return :: (CM.Monad m) => a -> IxMonadT s s m a
return a = IxMonadT $ \s -> CM.return (a, s)

(>>=) :: (CM.Monad m) => IxMonadT i c m a -> (a -> IxMonadT c o m b) -> IxMonadT i o m b
(>>=) v f = IxMonadT $ \i -> runIx v i CM.>>= \(a', o') -> runIx (f a') o'

(>>) :: (CM.Monad m) => IxMonadT i c m a -> IxMonadT c o m b -> IxMonadT i o m b
v >> w = v >>= \_ ->  w

instance MonadTrans (IxMonadT s s) where
  lift :: (CM.Monad m) => m a -> IxMonadT s s m a
  lift ma = IxMonadT $ \s -> ma CM.>>= (\a -> CM.return (a, s))

liftIO :: CM.MonadIO m => IO a -> IxMonadT s s m a
liftIO = lift . CM.liftIO

put :: (CM.Monad m) =>  o -> IxMonadT i o m ()
put o = IxMonadT $ \_ -> CM.return ((), o)

modify :: (CM.Monad m) => (i -> o) -> IxMonadT  i o m ()
modify f = IxMonadT $ \i -> CM.return ((), f i)

get :: CM.Monad m => IxMonadT s s m s
get = IxMonadT $ \x -> CM.return (x, x)

gets :: CM.Monad m => (a -> o) -> IxMonadT a o m a
gets f = IxMonadT $ \s -> CM.return (s, f s)

instance (CM.Monad m) => CM.Functor (IxMonadT i o m) where
  fmap :: (CM.Monad m) => (a -> b) -> IxMonadT i o m a -> IxMonadT i o m b
  fmap f v = IxMonadT $ \i ->
    runIx v i CM.>>= \(a', o') -> CM.return (f a', o')

-- demonstration function
run :: IxMonadT SourceCode Core IO Core
run = do
  toke <- gets source2Toke           -- :: IxMonadT IO SourceCode Tokenized ()
  liftIO $ putStrLn "inside IxMonad" -- :: IxMonadT IO Tokenized Tokenized ()
  syn <- gets toke2Syntax            -- :: IxMonadT IO Tokenized Syntax ()
  modify syntax2Core                 -- :: IxMonadT IO Syntax Core ()
  result <- get                      -- :: IxMonadT Syntax Core IO Core
                                     --    with get we can manipulate the value of the transformation
  liftIO $ print result              -- :: IxMonadT Syntax Core IO Core
  return result                      -- :: IxMonadT SourceCode Core IO Core -- (final type)

main :: IO ()
main = do
  let srcCode = SourceCode "here is my source code"
   in execIxMonadT run srcCode CM.>> print "done"