{-|
Module      : IRTS.Simplified
Description : Simplified expressions, where functions/constructors can only be applied to variables.

License     : BSD3
Maintainer  : The Idris Community.
-}
{-# LANGUAGE FlexibleContexts #-}
module IRTS.Simplified(simplifyDefs, SDecl(..), SExp(..), SAlt(..)) where

import Idris.Core.CaseTree
import Idris.Core.TT
import IRTS.Defunctionalise

import Control.Monad.State

data SExp = SV LVar
          | SApp Bool Name [LVar]
          | SLet LVar SExp SExp
          | SUpdate LVar SExp
          | SCon (Maybe LVar) -- location to reallocate, if available
                 Int Name [LVar]
          | SCase CaseType LVar [SAlt]
          | SChkCase LVar [SAlt]
          | SProj LVar Int
          | SConst Const
          -- Keep DExps for describing foreign things, because they get
          -- translated differently
          | SForeign FDesc FDesc [(FDesc, LVar)]
          | SOp PrimFn [LVar]
          | SNothing -- erased value, will never be inspected
          | SError String
  deriving Int -> SExp -> ShowS
[SExp] -> ShowS
SExp -> String
(Int -> SExp -> ShowS)
-> (SExp -> String) -> ([SExp] -> ShowS) -> Show SExp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SExp -> ShowS
showsPrec :: Int -> SExp -> ShowS
$cshow :: SExp -> String
show :: SExp -> String
$cshowList :: [SExp] -> ShowS
showList :: [SExp] -> ShowS
Show

data SAlt = SConCase Int Int Name [Name] SExp
          | SConstCase Const SExp
          | SDefaultCase SExp
  deriving Int -> SAlt -> ShowS
[SAlt] -> ShowS
SAlt -> String
(Int -> SAlt -> ShowS)
-> (SAlt -> String) -> ([SAlt] -> ShowS) -> Show SAlt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SAlt -> ShowS
showsPrec :: Int -> SAlt -> ShowS
$cshow :: SAlt -> String
show :: SAlt -> String
$cshowList :: [SAlt] -> ShowS
showList :: [SAlt] -> ShowS
Show

data SDecl = SFun Name [Name] Int SExp
  deriving Int -> SDecl -> ShowS
[SDecl] -> ShowS
SDecl -> String
(Int -> SDecl -> ShowS)
-> (SDecl -> String) -> ([SDecl] -> ShowS) -> Show SDecl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SDecl -> ShowS
showsPrec :: Int -> SDecl -> ShowS
$cshow :: SDecl -> String
show :: SDecl -> String
$cshowList :: [SDecl] -> ShowS
showList :: [SDecl] -> ShowS
Show


ldefs :: State (DDefs, Int) DDefs
ldefs :: State (DDefs, Int) DDefs
ldefs = do (l, h) <- StateT (DDefs, Int) Identity (DDefs, Int)
forall s (m :: * -> *). MonadState s m => m s
get
           return l

-- | Simplify an expression by let-binding argument expressions that
-- are not variables
-- The boolean parameter indicates whether the expression is at tail
-- call position.
simplify :: Bool -> DExp -> State (DDefs, Int) SExp
simplify :: Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
tl (DV Name
x)
    = do ctxt <- State (DDefs, Int) DDefs
ldefs
         case lookupCtxtExact x ctxt of
              Just (DConstructor Name
_ Int
t Int
0) -> SExp -> State (DDefs, Int) SExp
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExp -> State (DDefs, Int) SExp)
-> SExp -> State (DDefs, Int) SExp
forall a b. (a -> b) -> a -> b
$ Maybe LVar -> Int -> Name -> [LVar] -> SExp
SCon Maybe LVar
forall a. Maybe a
Nothing Int
t Name
x []
              Maybe DDecl
_ -> SExp -> State (DDefs, Int) SExp
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExp -> State (DDefs, Int) SExp)
-> SExp -> State (DDefs, Int) SExp
forall a b. (a -> b) -> a -> b
$ LVar -> SExp
SV (Name -> LVar
Glob Name
x)
simplify Bool
tl (DApp Bool
tc Name
n [DExp]
args) = [DExp] -> ([LVar] -> SExp) -> State (DDefs, Int) SExp
bindExprs [DExp]
args (Bool -> Name -> [LVar] -> SExp
SApp (Bool
tl Bool -> Bool -> Bool
|| Bool
tc) Name
n)
simplify Bool
tl (DForeign FDesc
ty FDesc
fn [(FDesc, DExp)]
args)
    = let ([FDesc]
fdescs, [DExp]
exprs) = [(FDesc, DExp)] -> ([FDesc], [DExp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(FDesc, DExp)]
args
      in [DExp] -> ([LVar] -> SExp) -> State (DDefs, Int) SExp
bindExprs [DExp]
exprs (\[LVar]
vars -> FDesc -> FDesc -> [(FDesc, LVar)] -> SExp
SForeign FDesc
ty FDesc
fn ([FDesc] -> [LVar] -> [(FDesc, LVar)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FDesc]
fdescs [LVar]
vars))
simplify Bool
tl (DLet Name
n DExp
v DExp
e) = do v' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
False DExp
v
                              e' <- simplify tl e
                              return (SLet (Glob n) v' e')
simplify Bool
tl (DUpdate Name
n DExp
e) = do e' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
False DExp
e
                               return (SUpdate (Glob n) e')
simplify Bool
tl (DC Maybe Name
loc Int
i Name
n [DExp]
args) = [DExp] -> ([LVar] -> SExp) -> State (DDefs, Int) SExp
bindExprs [DExp]
args (Maybe LVar -> Int -> Name -> [LVar] -> SExp
SCon (Name -> LVar
Glob (Name -> LVar) -> Maybe Name -> Maybe LVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Name
loc) Int
i Name
n)
simplify Bool
tl (DProj DExp
t Int
i) = DExp -> (LVar -> SExp) -> State (DDefs, Int) SExp
bindExpr DExp
t (\LVar
var -> LVar -> Int -> SExp
SProj LVar
var Int
i)
simplify Bool
tl (DCase CaseType
up DExp
e [DAlt]
alts)
    = do alts' <- (DAlt -> StateT (DDefs, Int) Identity SAlt)
-> [DAlt] -> StateT (DDefs, Int) Identity [SAlt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Bool -> DAlt -> StateT (DDefs, Int) Identity SAlt
sAlt Bool
tl) [DAlt]
alts
         bindExpr e (\LVar
var -> CaseType -> LVar -> [SAlt] -> SExp
SCase CaseType
up LVar
var [SAlt]
alts')
simplify Bool
tl (DChkCase DExp
e [DAlt]
alts)
    = do alts' <- (DAlt -> StateT (DDefs, Int) Identity SAlt)
-> [DAlt] -> StateT (DDefs, Int) Identity [SAlt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Bool -> DAlt -> StateT (DDefs, Int) Identity SAlt
sAlt Bool
tl) [DAlt]
alts
         bindExpr e (\LVar
var -> LVar -> [SAlt] -> SExp
SChkCase LVar
var [SAlt]
alts')
simplify Bool
tl (DConst Const
c) = SExp -> State (DDefs, Int) SExp
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Const -> SExp
SConst Const
c)
simplify Bool
tl (DOp PrimFn
p [DExp]
args) = [DExp] -> ([LVar] -> SExp) -> State (DDefs, Int) SExp
bindExprs [DExp]
args (PrimFn -> [LVar] -> SExp
SOp PrimFn
p)
simplify Bool
tl DExp
DNothing = SExp -> State (DDefs, Int) SExp
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return SExp
SNothing
simplify Bool
tl (DError String
str) = SExp -> State (DDefs, Int) SExp
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExp -> State (DDefs, Int) SExp)
-> SExp -> State (DDefs, Int) SExp
forall a b. (a -> b) -> a -> b
$ String -> SExp
SError String
str


-- | Let-bind a list of expressions to variables and construct the
-- inner expression with the bound variables.
-- If an expression in the list is already a variable we don’t bind it
-- again.
bindExprs :: [DExp] -> ([LVar] -> SExp) -> State (DDefs, Int) SExp
bindExprs :: [DExp] -> ([LVar] -> SExp) -> State (DDefs, Int) SExp
bindExprs [DExp]
es [LVar] -> SExp
f = [DExp] -> ([LVar] -> SExp) -> [LVar] -> State (DDefs, Int) SExp
bindExprs' [DExp]
es [LVar] -> SExp
f [] where
    bindExprs' :: [DExp] -> ([LVar] -> SExp) -> [LVar] -> State (DDefs, Int) SExp
bindExprs' [] [LVar] -> SExp
f [LVar]
vars = SExp -> State (DDefs, Int) SExp
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExp -> State (DDefs, Int) SExp)
-> SExp -> State (DDefs, Int) SExp
forall a b. (a -> b) -> a -> b
$ [LVar] -> SExp
f ([LVar] -> [LVar]
forall a. [a] -> [a]
reverse [LVar]
vars)
    bindExprs' (DExp
e:[DExp]
es) [LVar] -> SExp
f [LVar]
vars =
        DExp
-> (LVar -> State (DDefs, Int) SExp) -> State (DDefs, Int) SExp
bindExprM DExp
e (\LVar
var -> [DExp] -> ([LVar] -> SExp) -> [LVar] -> State (DDefs, Int) SExp
bindExprs' [DExp]
es [LVar] -> SExp
f (LVar
varLVar -> [LVar] -> [LVar]
forall a. a -> [a] -> [a]
:[LVar]
vars))

-- | Special case of 'bindExprs' for just one expression
bindExpr :: DExp -> (LVar -> SExp) -> State (DDefs, Int) SExp
bindExpr :: DExp -> (LVar -> SExp) -> State (DDefs, Int) SExp
bindExpr DExp
e LVar -> SExp
f = DExp
-> (LVar -> State (DDefs, Int) SExp) -> State (DDefs, Int) SExp
bindExprM DExp
e (SExp -> State (DDefs, Int) SExp
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExp -> State (DDefs, Int) SExp)
-> (LVar -> SExp) -> LVar -> State (DDefs, Int) SExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LVar -> SExp
f)

bindExprM :: DExp -> (LVar -> State (DDefs, Int) SExp) -> State (DDefs, Int) SExp
bindExprM :: DExp
-> (LVar -> State (DDefs, Int) SExp) -> State (DDefs, Int) SExp
bindExprM (DV Name
x) LVar -> State (DDefs, Int) SExp
f
    = do ctxt <- State (DDefs, Int) DDefs
ldefs
         case lookupCtxtExact x ctxt of
              Just (DConstructor Name
_ Int
t Int
0) -> DExp
-> (LVar -> State (DDefs, Int) SExp) -> State (DDefs, Int) SExp
bindExprM (Maybe Name -> Int -> Name -> [DExp] -> DExp
DC Maybe Name
forall a. Maybe a
Nothing Int
t Name
x []) LVar -> State (DDefs, Int) SExp
f
              Maybe DDecl
_ -> LVar -> State (DDefs, Int) SExp
f (Name -> LVar
Glob Name
x)
bindExprM DExp
e LVar -> State (DDefs, Int) SExp
f =
    do e' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
False DExp
e
       var <- freshVar
       f' <- f var
       return $ SLet var e' f'
    where
        freshVar :: StateT (DDefs, Int) Identity LVar
freshVar = do (defs, i) <- StateT (DDefs, Int) Identity (DDefs, Int)
forall s (m :: * -> *). MonadState s m => m s
get
                      put (defs, i + 1)
                      return (Glob (sMN i "R"))


sAlt :: Bool -> DAlt -> State (DDefs, Int) SAlt
sAlt :: Bool -> DAlt -> StateT (DDefs, Int) Identity SAlt
sAlt Bool
tl (DConCase Int
i Name
n [Name]
args DExp
e) = do e' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
tl DExp
e
                                   return (SConCase (-1) i n args e')
sAlt Bool
tl (DConstCase Const
c DExp
e) = do e' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
tl DExp
e
                              return (SConstCase c e')
sAlt Bool
tl (DDefaultCase DExp
e) = do e' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
tl DExp
e
                              return (SDefaultCase e')

simplifyDefs :: DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]
simplifyDefs :: DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]
simplifyDefs DDefs
ctxt [] = [(Name, SDecl)] -> TC [(Name, SDecl)]
forall a. a -> TC a
forall (m :: * -> *) a. Monad m => a -> m a
return []
simplifyDefs DDefs
ctxt (con :: (Name, DDecl)
con@(Name
n, DConstructor Name
_ Int
_ Int
_) : [(Name, DDecl)]
xs)
    = do xs' <- DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]
simplifyDefs DDefs
ctxt [(Name, DDecl)]
xs
         return xs'
simplifyDefs DDefs
ctxt ((Name
n, DFun Name
n' [Name]
args DExp
exp) : [(Name, DDecl)]
xs)
    = do let sexp :: SExp
sexp = State (DDefs, Int) SExp -> (DDefs, Int) -> SExp
forall s a. State s a -> s -> a
evalState (Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
True DExp
exp) (DDefs
ctxt, Int
0)
         (exp', locs) <- StateT Int TC SExp -> Int -> TC (SExp, Int)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Name -> DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp
scopecheck Name
n DDefs
ctxt ([Name] -> [Int] -> [(Name, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
args [Int
0..]) SExp
sexp) ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
args)
         xs' <- simplifyDefs ctxt xs
         return ((n, SFun n' args ((locs + 1) - length args) exp') : xs')

lvar :: s -> m ()
lvar s
v = do i <- m s
forall s (m :: * -> *). MonadState s m => m s
get
            put (max i v)

scopecheck :: Name -> DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp
scopecheck :: Name -> DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp
scopecheck Name
fn DDefs
ctxt [(Name, Int)]
envTop SExp
tm = [(Name, Int)] -> SExp -> StateT Int TC SExp
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
envTop SExp
tm where
    failsc :: String -> m a
failsc String
err = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Codegen error in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
fn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err

    sc :: [(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
env (SV (Glob Name
n)) =
       case Name -> [(Name, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n ([(Name, Int)] -> [(Name, Int)]
forall a. [a] -> [a]
reverse [(Name, Int)]
env) of -- most recent first
              Just Int
i -> do Int -> m ()
forall {m :: * -> *} {s}. (MonadState s m, Ord s) => s -> m ()
lvar Int
i; SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LVar -> SExp
SV (Int -> LVar
Loc Int
i))
              Maybe Int
Nothing -> case Name -> DDefs -> Maybe DDecl
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n DDefs
ctxt of
                              Just (DConstructor Name
_ Int
i Int
ar) ->
                                  if Bool
True -- ar == 0
                                     then SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LVar -> Int -> Name -> [LVar] -> SExp
SCon Maybe LVar
forall a. Maybe a
Nothing Int
i Name
n [])
                                     else String -> m SExp
forall {m :: * -> *} {a}. MonadFail m => String -> m a
failsc (String -> m SExp) -> String -> m SExp
forall a b. (a -> b) -> a -> b
$ String
"Constructor " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                                 String
" has arity " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ar
                              Just DDecl
_ -> SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LVar -> SExp
SV (Name -> LVar
Glob Name
n))
                              Maybe DDecl
Nothing -> String -> m SExp
forall {m :: * -> *} {a}. MonadFail m => String -> m a
failsc (String -> m SExp) -> String -> m SExp
forall a b. (a -> b) -> a -> b
$ String
"No such variable " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n
    sc [(Name, Int)]
env (SApp Bool
tc Name
f [LVar]
args)
       = do args' <- (LVar -> m LVar) -> [LVar] -> m [LVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env) [LVar]
args
            case lookupCtxtExact f ctxt of
                Just (DConstructor Name
n Int
tag Int
ar) ->
                    if Bool
True -- (ar == length args)
                       then SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExp -> m SExp) -> SExp -> m SExp
forall a b. (a -> b) -> a -> b
$ Maybe LVar -> Int -> Name -> [LVar] -> SExp
SCon Maybe LVar
forall a. Maybe a
Nothing Int
tag Name
n [LVar]
args'
                       else String -> m SExp
forall {m :: * -> *} {a}. MonadFail m => String -> m a
failsc (String -> m SExp) -> String -> m SExp
forall a b. (a -> b) -> a -> b
$ String
"Constructor " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
f String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                   String
" has arity " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ar
                Just DDecl
_ -> SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExp -> m SExp) -> SExp -> m SExp
forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [LVar] -> SExp
SApp Bool
tc Name
f [LVar]
args'
                Maybe DDecl
Nothing -> String -> m SExp
forall {m :: * -> *} {a}. MonadFail m => String -> m a
failsc (String -> m SExp) -> String -> m SExp
forall a b. (a -> b) -> a -> b
$ String
"No such variable " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
f
    sc [(Name, Int)]
env (SForeign FDesc
ty FDesc
f [(FDesc, LVar)]
args)
       = do args' <- ((FDesc, LVar) -> m (FDesc, LVar))
-> [(FDesc, LVar)] -> m [(FDesc, LVar)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ (FDesc
t, LVar
a) -> do a' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env LVar
a
                                          return (t, a')) [(FDesc, LVar)]
args
            return $ SForeign ty f args'
    sc [(Name, Int)]
env (SCon Maybe LVar
loc Int
tag Name
f [LVar]
args)
       = do loc' <- case Maybe LVar
loc of
                         Maybe LVar
Nothing -> Maybe LVar -> m (Maybe LVar)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LVar
forall a. Maybe a
Nothing
                         Just LVar
l -> do l' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env LVar
l
                                      return (Just l')
            args' <- mapM (scVar env) args
            case lookupCtxtExact f ctxt of
                Just (DConstructor Name
n Int
tag Int
ar) ->
                    if Bool
True -- (ar == length args)
                       then SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExp -> m SExp) -> SExp -> m SExp
forall a b. (a -> b) -> a -> b
$ Maybe LVar -> Int -> Name -> [LVar] -> SExp
SCon Maybe LVar
loc' Int
tag Name
n [LVar]
args'
                       else String -> m SExp
forall {m :: * -> *} {a}. MonadFail m => String -> m a
failsc (String -> m SExp) -> String -> m SExp
forall a b. (a -> b) -> a -> b
$ String
"Constructor " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
f String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                     String
" has arity " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ar
                Maybe DDecl
_ -> String -> m SExp
forall {m :: * -> *} {a}. MonadFail m => String -> m a
failsc (String -> m SExp) -> String -> m SExp
forall a b. (a -> b) -> a -> b
$ String
"No such constructor " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
f
    sc [(Name, Int)]
env (SProj LVar
e Int
i)
       = do e' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env LVar
e
            return (SProj e' i)
    sc [(Name, Int)]
env (SCase CaseType
up LVar
e [SAlt]
alts)
       = do e' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env LVar
e
            alts' <- mapM (scalt env) alts
            return (SCase up e' alts')
    sc [(Name, Int)]
env (SChkCase LVar
e [SAlt]
alts)
       = do e' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env LVar
e
            alts' <- mapM (scalt env) alts
            return (SChkCase e' alts')
    sc [(Name, Int)]
env (SLet (Glob Name
n) SExp
v SExp
e)
       = do let env' :: [(Name, Int)]
env' = [(Name, Int)]
env [(Name, Int)] -> [(Name, Int)] -> [(Name, Int)]
forall a. [a] -> [a] -> [a]
++ [(Name
n, [(Name, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int)]
env)]
            v' <- [(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
env SExp
v
            n' <- scVar env' (Glob n)
            e' <- sc env' e
            return (SLet n' v' e')
    sc [(Name, Int)]
env (SUpdate (Glob Name
n) SExp
e)
       = do -- n already in env
            e' <- [(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
env SExp
e
            n' <- scVar env (Glob n)
            return (SUpdate n' e')
    sc [(Name, Int)]
env (SOp PrimFn
prim [LVar]
args)
       = do args' <- (LVar -> m LVar) -> [LVar] -> m [LVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env) [LVar]
args
            return (SOp prim args')
    sc [(Name, Int)]
env SExp
x = SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return SExp
x

    scVar :: [(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env (Glob Name
n) =
       case Name -> [(Name, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n ([(Name, Int)] -> [(Name, Int)]
forall a. [a] -> [a]
reverse [(Name, Int)]
env) of -- most recent first
              Just Int
i -> do Int -> m ()
forall {m :: * -> *} {s}. (MonadState s m, Ord s) => s -> m ()
lvar Int
i; LVar -> m LVar
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> LVar
Loc Int
i)
              Maybe Int
Nothing -> case Name -> DDefs -> Maybe DDecl
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n DDefs
ctxt of
                              Just (DConstructor Name
_ Int
i Int
ar) ->
                                  String -> m LVar
forall {m :: * -> *} {a}. MonadFail m => String -> m a
failsc String
"can't pass constructor here"
                              Just DDecl
_ -> LVar -> m LVar
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> LVar
Glob Name
n)
                              Maybe DDecl
Nothing -> String -> m LVar
forall {m :: * -> *} {a}. MonadFail m => String -> m a
failsc (String -> m LVar) -> String -> m LVar
forall a b. (a -> b) -> a -> b
$ String
"No such variable " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                               String
" in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SExp -> String
forall a. Show a => a -> String
show SExp
tm String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(Name, Int)] -> String
forall a. Show a => a -> String
show [(Name, Int)]
envTop
    scVar [(Name, Int)]
_ LVar
x = LVar -> m LVar
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return LVar
x

    scalt :: [(Name, Int)] -> SAlt -> m SAlt
scalt [(Name, Int)]
env (SConCase Int
_ Int
i Name
n [Name]
args SExp
e)
       = do let env' :: [(Name, Int)]
env' = [(Name, Int)]
env [(Name, Int)] -> [(Name, Int)] -> [(Name, Int)]
forall a. [a] -> [a] -> [a]
++ [Name] -> [Int] -> [(Name, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
args [[(Name, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int)]
env..]
            tag <- case Name -> DDefs -> Maybe DDecl
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n DDefs
ctxt of
                        Just (DConstructor Name
_ Int
i Int
ar) ->
                             if Bool
True -- (length args == ar)
                                then Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
                                else String -> m Int
forall {m :: * -> *} {a}. MonadFail m => String -> m a
failsc (String -> m Int) -> String -> m Int
forall a b. (a -> b) -> a -> b
$ String
"Constructor " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                            String
" has arity " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ar
                        Maybe DDecl
_ -> String -> m Int
forall {m :: * -> *} {a}. MonadFail m => String -> m a
failsc (String -> m Int) -> String -> m Int
forall a b. (a -> b) -> a -> b
$ String
"No constructor " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n
            e' <- sc env' e
            return (SConCase (length env) tag n args e')
    scalt [(Name, Int)]
env (SConstCase Const
c SExp
e) = do e' <- [(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
env SExp
e
                                    return (SConstCase c e')
    scalt [(Name, Int)]
env (SDefaultCase SExp
e) = do e' <- [(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
env SExp
e
                                    return (SDefaultCase e')