Lang.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}

{-|

## 2019-02-14

Trying to write an interpreter for a small monadic language of commands
with variables

@
x <- Foo "arg1"
Bar x
@

Of course, this should be properly typed.

##
2019-02-15
I think I need 2 passes in the parser:

* One pass to extract the sequence of expressions, maybe using Data.Dynamic to
  introduce placeholders for application of variables. Or simply an abstract
  representation of the function and its application?
* Another pass to construct the actual Haskell (monadic) expression  from the
  parsed terms

This probably means, at the end of the day, we would simply have an interpreter
for `Expr`essions  and `Statement`s...

OK, so when declaring variables, we make sure the value end up in a `Map Text Dynamic`,
and when referenced, we resolve the value and throw an error if it cannot be resolved.
`fromDynamic` returns a `Maybe a` so we can safely checks the return type as long as
we know it explicitly.

## 2019-02-06

Managed to get a first version working, seems to me there's a lot of boilerplate code
in here:

* Split "compiler" in 2 levels, one for `Statement`s and one for `Expr`s
* Used `Eff` based interpreter. Compilers run into `Eff m` monad providing suitable
  capabilities: a `State Env` to load and store variables, an `Action` interpreter,
  an `Error Text` to report errors in the compilation process
* The `Expr` compiler, `compileE` produces an `Atom` which then needs to be unpacked
  for consumption by further expressions and statements
* The `Call` typeclass provides a way to resolve arguments "generically", in a way
  that's dependent on the type of the `Action`'s constructor
* The `FromAtom` typeclass resolves `Atom`s into an actual value of some type. This
  handles both litteral values and variable references
-}
module Rex.Lang where

import           Control.Monad.Freer
import           Control.Monad.Freer.Error
import           Control.Monad.Freer.State
import           Data.Dynamic
import qualified Data.Map                  as Map
import           Text.Parsec               hiding (State, string)
import           Text.Parsec.Language      (haskellDef)
import qualified Text.Parsec.Token         as P

type String = [Char]

-- * Semantics
-- | Our basic vocabulary of `Action`s with a  phantom type to
-- represent result of the action.
data Action a where
  Foo :: Text -> Action Integer
  Bar :: Integer -> Action Text

runAction :: Eff (Action ': effs) a -> Eff effs a
runAction = interpret eval
  where
    eval :: Action x -> Eff m x
    eval (Foo t) = pure (fromIntegral $ length t)
    eval (Bar i) = pure (pack $ show i)

type Env = Map.Map Text Dynamic

-- * Interpretation

runProg :: Prog -> IO (Either Text ((), Env))
runProg = runM . runError . runState mempty . runAction . compileP

compileP :: forall m . (Member Action m, Member (State Env) m, Member (Error Text) m)
         => Prog -> Eff m ()
compileP [] = pure ()
compileP (Act e:rest) = compileE e >> compileP rest
compileP (Var t e:rest) = mkVar t e >> compileP rest
  where

    mkVar :: Text -> Expr -> Eff m ()
    mkVar name expr = compileE expr >>=
                      \case
                        Str v -> modify (Map.insert name (toDyn v))
                        INT v -> modify (Map.insert name (toDyn v))
                        a     -> throwError (pack $ "expression returned a reference" <> show a)

compileE :: forall m . (Member Action m, Member (State Env) m, Member (Error Text) m)
         => Expr -> Eff m Atom
compileE (Ap (At (Id "Foo")) args) = mkCall Foo args
compileE (Ap (At (Id "Bar")) args) = mkCall Bar args
compileE (At a) = pure a
compileE e  = throwError $ pack $ "cannot compile expression " <> show e


class Call a where
  mkCall :: forall m . (Member (Error Text) m, Member (State Env) m, Member Action m)
         => a -> [ Expr ] -> Eff m Atom

instance (Call (Action b),FromAtom a) => Call (a -> Action b) where
  mkCall f (At a:as) = fromAtom a >>= \ a' -> mkCall (f a') as
  mkCall _f [] = throwError (pack "not enough arguments")
  mkCall _f (e:_) = throwError (pack $ "cannot handle nested expression" <> show e)

instance Call (Action Integer) where
  mkCall f [] = INT <$> send f
  mkCall _f _ = throwError (pack "too many arguments")

instance Call (Action Text) where
  mkCall f [] = Str <$> send f
  mkCall _f _ = throwError (pack "too many arguments")

class FromAtom a where
  fromAtom :: (Member (State Env) m, Member (Error Text) m)
           => Atom -> Eff m a

instance FromAtom Text where
  fromAtom (Str s) = pure s
  fromAtom (Id n) = get >>= \ env -> (maybe (throwError $ "undefined variable " <> n) pure $ Map.lookup n env >>= fromDynamic)
  fromAtom a = throwError (pack $ "wrong atom type " <> show a <> ", expected Text")

instance FromAtom Integer where
  fromAtom (INT i) = pure i
  fromAtom (Id n) = get >>= \ env -> (maybe (throwError $ "undefined variable " <> n) pure $ Map.lookup n env >>= fromDynamic)
  fromAtom a = throwError (pack $ "wrong atom type " <> show a <> ", expected Int")

-- * Syntax

-- |Our `Atom`ic values from which we can build more complex expressions.
data Atom where
  INT :: Integer -> Atom
  Str :: Text -> Atom
  Id :: Text -> Atom
  deriving (Eq, Show)

data Expr where
  Ap :: Expr -> [ Expr ] -> Expr
  At :: Atom -> Expr
  deriving (Eq, Show)

data Statement where
  Act  :: Expr -> Statement
  Var :: Text -> Expr -> Statement
  deriving (Eq, Show)

type Prog = [ Statement ]

-- ** Parsing

parse :: Text -> Either ParseError Prog
parse = runParser parser () "" . unpack

parser :: Parsec String () Prog
parser = sepBy1 stmtParser eol

stmtParser :: Parsec String () Statement
stmtParser = try varParser <|> actParser
  where
    varParser =
      Var
      <$> variableDecl
      <*> (leftArrow >> exprParser)

    actParser =
      Act <$> exprParser

    exprParser :: Parsec String () Expr
    exprParser =
      Ap
      <$> (At <$> atomParser)
      <*> (fmap At <$> many1 atomParser)

    atomParser = identifier <|> integer <|> string

eol = P.semi lexer
lexer = P.makeTokenParser haskellDef
variableDecl = pack <$> P.identifier lexer
leftArrow = P.reserved lexer $ "<-"
identifier = Id <$> variableDecl
integer = INT <$> P.integer lexer
string = Str . pack <$> P.stringLiteral lexer