EffectSystem.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}

import Debug.Trace ( trace )

type Ident = String

data Value
  = Var Ident
  | Bool Bool
  | Fun Ident Comp
  | Hndlr Cases
  deriving (Show, Eq)

data Cases
  = CaseRet Ident Comp
  | CaseEnd
  | CaseOp OpName Ident Ident Comp Cases
  deriving (Show, Eq)

data Comp
  = Ret Value
  | Op OpName Value Ident Comp -- `op(v; y. c)`, `let y <- print "foo" in c` would be `print("foo"; y. c)`
  | DoIn Ident Comp Comp -- `do x <- c1 in c2`
  | If Value Comp Comp
  | App Value Value
  | WithHndl Value Comp -- `with v handle c`
  deriving (Show, Eq)

pattern c1 `AndThen` c2 = DoIn "_" c1 c2

type OpName = Ident

--------------------------------------------------------------------------------

type Env = [(Ident, Value)]

--------------------------------------------------------------------------------

eval :: Env -> Comp -> (Comp, Env)

eval env c =
  case trace ("c = " ++ show c) c of

    DoIn x (Ret v) c -> let
      env' = (x, v):env
      in eval env' c

    DoIn x (Op op v y c1) c2 ->
      eval env $ Op op v y (DoIn x c1 c2)

    -- Default.
    DoIn x c1 c2 -> let
      (c1', env') = eval env c1
      in eval env' $ DoIn x c1' c2

    If (Bool True) c1 c2 ->
      eval env c1

    If (Bool False) c1 c2 ->
      eval env c2

    App (Fun x c) v -> let
      env' = (x, v):env
      in eval env' c

    WithHndl (Hndlr h) (Ret v) -> let

      findCaseRetComp :: Cases -> (Ident, Comp)
      findCaseRetComp CaseEnd = error "Oops! This handler doesn't handle a return op!"
      findCaseRetComp (CaseRet x cr) = (x, cr)
      findCaseRetComp (CaseOp _ _ _ _ cases) = findCaseRetComp cases

      (x, cr) = findCaseRetComp h
      env' = (x, v):env
      in eval env' cr

    WithHndl (Hndlr h) (Op op v y c) -> let

      findCaseOp :: Cases -> Maybe (Ident, Ident, Comp)
      findCaseOp (CaseOp opI x k cI cases)
        | op == opI = Just (x, k, cI)
        | otherwise = findCaseOp cases
      findCaseOp _ = Nothing

      in case findCaseOp h of
        Just (x, k, cI) -> let
          env' = (x, v):(k, Fun y $ WithHndl (Hndlr h) c):env
          in eval env' cI
        Nothing -> eval env $ Op op v y (WithHndl (Hndlr h) c)

    -- Default.
    WithHndl h c -> let
      (c', env') = eval env c
      in eval env' $ WithHndl h c'

    -- An escaping operation.
    Op op arg retvar comp ->
      error $ "Unhandled operation `" ++ op ++ "`!"

    other -> error $ "Non-exhaustive pattern: " ++ show other

test = eval [] $ WithHndl h app
  where
    h = Hndlr $
      CaseOp "op" "val" "k" (Ret $ Bool True) $
        CaseRet "x" (Ret $ Var "x")
    app = App op $ Bool True
    op = Fun "x" (Op "op" (Var "x") "y" (Ret $ Var "y"))