{-# 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)
Int Name [LVar]
| SCase CaseType LVar [SAlt]
| SChkCase LVar [SAlt]
| SProj LVar Int
| SConst Const
| SForeign FDesc FDesc [(FDesc, LVar)]
| SOp PrimFn [LVar]
| SNothing
| 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 (DDefs
l, Int
h) <- StateT (DDefs, Int) Identity (DDefs, Int)
forall s (m :: * -> *). MonadState s m => m s
get
DDefs -> State (DDefs, Int) DDefs
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return DDefs
l
simplify :: Bool -> DExp -> State (DDefs, Int) SExp
simplify :: Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
tl (DV Name
x)
= do DDefs
ctxt <- State (DDefs, Int) DDefs
ldefs
case Name -> DDefs -> Maybe DDecl
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
x DDefs
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 SExp
v' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
False DExp
v
SExp
e' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
tl DExp
e
SExp -> State (DDefs, Int) SExp
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LVar -> SExp -> SExp -> SExp
SLet (Name -> LVar
Glob Name
n) SExp
v' SExp
e')
simplify Bool
tl (DUpdate Name
n DExp
e) = do SExp
e' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
False DExp
e
SExp -> State (DDefs, Int) SExp
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LVar -> SExp -> SExp
SUpdate (Name -> LVar
Glob Name
n) SExp
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 [SAlt]
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
DExp -> (LVar -> SExp) -> State (DDefs, Int) SExp
bindExpr DExp
e (\LVar
var -> CaseType -> LVar -> [SAlt] -> SExp
SCase CaseType
up LVar
var [SAlt]
alts')
simplify Bool
tl (DChkCase DExp
e [DAlt]
alts)
= do [SAlt]
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
DExp -> (LVar -> SExp) -> State (DDefs, Int) SExp
bindExpr DExp
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
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))
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 DDefs
ctxt <- State (DDefs, Int) DDefs
ldefs
case Name -> DDefs -> Maybe DDecl
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
x DDefs
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 SExp
e' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
False DExp
e
LVar
var <- StateT (DDefs, Int) Identity LVar
freshVar
SExp
f' <- LVar -> State (DDefs, Int) SExp
f LVar
var
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 -> SExp -> SExp
SLet LVar
var SExp
e' SExp
f'
where
freshVar :: StateT (DDefs, Int) Identity LVar
freshVar = do (DDefs
defs, Int
i) <- StateT (DDefs, Int) Identity (DDefs, Int)
forall s (m :: * -> *). MonadState s m => m s
get
(DDefs, Int) -> StateT (DDefs, Int) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (DDefs
defs, Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
LVar -> StateT (DDefs, Int) Identity LVar
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> LVar
Glob (Int -> String -> Name
sMN Int
i String
"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 SExp
e' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
tl DExp
e
SAlt -> StateT (DDefs, Int) Identity SAlt
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Name -> [Name] -> SExp -> SAlt
SConCase (-Int
1) Int
i Name
n [Name]
args SExp
e')
sAlt Bool
tl (DConstCase Const
c DExp
e) = do SExp
e' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
tl DExp
e
SAlt -> StateT (DDefs, Int) Identity SAlt
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Const -> SExp -> SAlt
SConstCase Const
c SExp
e')
sAlt Bool
tl (DDefaultCase DExp
e) = do SExp
e' <- Bool -> DExp -> State (DDefs, Int) SExp
simplify Bool
tl DExp
e
SAlt -> StateT (DDefs, Int) Identity SAlt
forall a. a -> StateT (DDefs, Int) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExp -> SAlt
SDefaultCase SExp
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 [(Name, SDecl)]
xs' <- DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]
simplifyDefs DDefs
ctxt [(Name, DDecl)]
xs
[(Name, SDecl)] -> TC [(Name, SDecl)]
forall a. a -> TC a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name, SDecl)]
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)
(SExp
exp', Int
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)
[(Name, SDecl)]
xs' <- DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]
simplifyDefs DDefs
ctxt [(Name, DDecl)]
xs
[(Name, SDecl)] -> TC [(Name, SDecl)]
forall a. a -> TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
n, Name -> [Name] -> Int -> SExp -> SDecl
SFun Name
n' [Name]
args ((Int
locs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
args) SExp
exp') (Name, SDecl) -> [(Name, SDecl)] -> [(Name, SDecl)]
forall a. a -> [a] -> [a]
: [(Name, SDecl)]
xs')
lvar :: s -> m ()
lvar s
v = do s
i <- m s
forall s (m :: * -> *). MonadState s m => m s
get
s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (s -> s -> s
forall a. Ord a => a -> a -> a
max s
i s
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
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
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 [LVar]
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 Name -> DDefs -> Maybe DDecl
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
f DDefs
ctxt of
Just (DConstructor Name
n Int
tag Int
ar) ->
if Bool
True
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 [(FDesc, LVar)]
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 LVar
a' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env LVar
a
(FDesc, LVar) -> m (FDesc, LVar)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FDesc
t, LVar
a')) [(FDesc, LVar)]
args
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
$ FDesc -> FDesc -> [(FDesc, LVar)] -> SExp
SForeign FDesc
ty FDesc
f [(FDesc, LVar)]
args'
sc [(Name, Int)]
env (SCon Maybe LVar
loc Int
tag Name
f [LVar]
args)
= do Maybe LVar
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 LVar
l' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env LVar
l
Maybe LVar -> m (Maybe LVar)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LVar -> Maybe LVar
forall a. a -> Maybe a
Just LVar
l')
[LVar]
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 Name -> DDefs -> Maybe DDecl
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
f DDefs
ctxt of
Just (DConstructor Name
n Int
tag Int
ar) ->
if Bool
True
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 LVar
e' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env LVar
e
SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LVar -> Int -> SExp
SProj LVar
e' Int
i)
sc [(Name, Int)]
env (SCase CaseType
up LVar
e [SAlt]
alts)
= do LVar
e' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env LVar
e
[SAlt]
alts' <- (SAlt -> m SAlt) -> [SAlt] -> m [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 ([(Name, Int)] -> SAlt -> m SAlt
scalt [(Name, Int)]
env) [SAlt]
alts
SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CaseType -> LVar -> [SAlt] -> SExp
SCase CaseType
up LVar
e' [SAlt]
alts')
sc [(Name, Int)]
env (SChkCase LVar
e [SAlt]
alts)
= do LVar
e' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env LVar
e
[SAlt]
alts' <- (SAlt -> m SAlt) -> [SAlt] -> m [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 ([(Name, Int)] -> SAlt -> m SAlt
scalt [(Name, Int)]
env) [SAlt]
alts
SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LVar -> [SAlt] -> SExp
SChkCase LVar
e' [SAlt]
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)]
SExp
v' <- [(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
env SExp
v
LVar
n' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env' (Name -> LVar
Glob Name
n)
SExp
e' <- [(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
env' SExp
e
SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LVar -> SExp -> SExp -> SExp
SLet LVar
n' SExp
v' SExp
e')
sc [(Name, Int)]
env (SUpdate (Glob Name
n) SExp
e)
= do
SExp
e' <- [(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
env SExp
e
LVar
n' <- [(Name, Int)] -> LVar -> m LVar
forall {m :: * -> *}.
(MonadState Int m, MonadFail m) =>
[(Name, Int)] -> LVar -> m LVar
scVar [(Name, Int)]
env (Name -> LVar
Glob Name
n)
SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LVar -> SExp -> SExp
SUpdate LVar
n' SExp
e')
sc [(Name, Int)]
env (SOp PrimFn
prim [LVar]
args)
= do [LVar]
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
SExp -> m SExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimFn -> [LVar] -> SExp
SOp PrimFn
prim [LVar]
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
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..]
Int
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
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
SExp
e' <- [(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
env' SExp
e
SAlt -> m SAlt
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Name -> [Name] -> SExp -> SAlt
SConCase ([(Name, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Int)]
env) Int
tag Name
n [Name]
args SExp
e')
scalt [(Name, Int)]
env (SConstCase Const
c SExp
e) = do SExp
e' <- [(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
env SExp
e
SAlt -> m SAlt
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Const -> SExp -> SAlt
SConstCase Const
c SExp
e')
scalt [(Name, Int)]
env (SDefaultCase SExp
e) = do SExp
e' <- [(Name, Int)] -> SExp -> m SExp
sc [(Name, Int)]
env SExp
e
SAlt -> m SAlt
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SExp -> SAlt
SDefaultCase SExp
e')