{-# LANGUAGE FlexibleContexts, PatternGuards #-}
module IRTS.Defunctionalise(module IRTS.Defunctionalise
, module IRTS.Lang
) where
import Idris.Core.CaseTree
import Idris.Core.TT
import IRTS.Lang
import Control.Monad
import Control.Monad.State
import Data.List
import Data.Maybe
data DExp = DV Name
| DApp Bool Name [DExp]
| DLet Name DExp DExp
| DUpdate Name DExp
| DProj DExp Int
| DC (Maybe Name) Int Name [DExp]
| DCase CaseType DExp [DAlt]
| DChkCase DExp [DAlt]
| DConst Const
| DForeign FDesc FDesc [(FDesc, DExp)]
| DOp PrimFn [DExp]
| DNothing
| DError String
deriving DExp -> DExp -> Bool
(DExp -> DExp -> Bool) -> (DExp -> DExp -> Bool) -> Eq DExp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DExp -> DExp -> Bool
== :: DExp -> DExp -> Bool
$c/= :: DExp -> DExp -> Bool
/= :: DExp -> DExp -> Bool
Eq
data DAlt = DConCase Int Name [Name] DExp
| DConstCase Const DExp
| DDefaultCase DExp
deriving (Int -> DAlt -> ShowS
[DAlt] -> ShowS
DAlt -> String
(Int -> DAlt -> ShowS)
-> (DAlt -> String) -> ([DAlt] -> ShowS) -> Show DAlt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DAlt -> ShowS
showsPrec :: Int -> DAlt -> ShowS
$cshow :: DAlt -> String
show :: DAlt -> String
$cshowList :: [DAlt] -> ShowS
showList :: [DAlt] -> ShowS
Show, DAlt -> DAlt -> Bool
(DAlt -> DAlt -> Bool) -> (DAlt -> DAlt -> Bool) -> Eq DAlt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DAlt -> DAlt -> Bool
== :: DAlt -> DAlt -> Bool
$c/= :: DAlt -> DAlt -> Bool
/= :: DAlt -> DAlt -> Bool
Eq)
data DDecl = DFun Name [Name] DExp
| DConstructor Name Int Int
deriving (Int -> DDecl -> ShowS
[DDecl] -> ShowS
DDecl -> String
(Int -> DDecl -> ShowS)
-> (DDecl -> String) -> ([DDecl] -> ShowS) -> Show DDecl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DDecl -> ShowS
showsPrec :: Int -> DDecl -> ShowS
$cshow :: DDecl -> String
show :: DDecl -> String
$cshowList :: [DDecl] -> ShowS
showList :: [DDecl] -> ShowS
Show, DDecl -> DDecl -> Bool
(DDecl -> DDecl -> Bool) -> (DDecl -> DDecl -> Bool) -> Eq DDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DDecl -> DDecl -> Bool
== :: DDecl -> DDecl -> Bool
$c/= :: DDecl -> DDecl -> Bool
/= :: DDecl -> DDecl -> Bool
Eq)
type DDefs = Ctxt DDecl
defunctionalise :: Int -> LDefs -> DDefs
defunctionalise :: Int -> LDefs -> DDefs
defunctionalise Int
nexttag LDefs
defs
= let all :: [(Name, LDecl)]
all = LDefs -> [(Name, LDecl)]
forall a. Ctxt a -> [(Name, a)]
toAlist LDefs
defs
([(Name, DDecl)]
allD, ([Name]
enames, [(Name, Int)]
anames)) = State ([Name], [(Name, Int)]) [(Name, DDecl)]
-> ([Name], [(Name, Int)])
-> ([(Name, DDecl)], ([Name], [(Name, Int)]))
forall s a. State s a -> s -> (a, s)
runState (((Name, LDecl)
-> StateT ([Name], [(Name, Int)]) Identity (Name, DDecl))
-> [(Name, LDecl)] -> State ([Name], [(Name, Int)]) [(Name, DDecl)]
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 (LDefs
-> (Name, LDecl)
-> StateT ([Name], [(Name, Int)]) Identity (Name, DDecl)
addApps LDefs
defs) [(Name, LDecl)]
all) ([], [])
anames' :: [(Name, Int)]
anames' = [(Name, Int)] -> [(Name, Int)]
forall a. Ord a => [a] -> [a]
sort ([(Name, Int)] -> [(Name, Int)]
forall a. Eq a => [a] -> [a]
nub [(Name, Int)]
anames)
enames' :: [Name]
enames' = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub [Name]
enames
newecons :: [(Name, Int, EvalApply DAlt)]
newecons = ((Name, Int, EvalApply DAlt)
-> (Name, Int, EvalApply DAlt) -> Ordering)
-> [(Name, Int, EvalApply DAlt)] -> [(Name, Int, EvalApply DAlt)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Name, Int, EvalApply DAlt)
-> (Name, Int, EvalApply DAlt) -> Ordering
forall {a} {b} {c} {b} {c}.
Ord a =>
(a, b, c) -> (a, b, c) -> Ordering
conord ([(Name, Int, EvalApply DAlt)] -> [(Name, Int, EvalApply DAlt)])
-> [(Name, Int, EvalApply DAlt)] -> [(Name, Int, EvalApply DAlt)]
forall a b. (a -> b) -> a -> b
$ ((Name, Int) -> [(Name, Int, EvalApply DAlt)])
-> [(Name, Int)] -> [(Name, Int, EvalApply DAlt)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Name] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]
toCons [Name]
enames') ([(Name, LDecl)] -> [(Name, Int)]
getFn [(Name, LDecl)]
all)
newacons :: [(Name, Int, EvalApply DAlt)]
newacons = ((Name, Int, EvalApply DAlt)
-> (Name, Int, EvalApply DAlt) -> Ordering)
-> [(Name, Int, EvalApply DAlt)] -> [(Name, Int, EvalApply DAlt)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Name, Int, EvalApply DAlt)
-> (Name, Int, EvalApply DAlt) -> Ordering
forall {a} {b} {c} {b} {c}.
Ord a =>
(a, b, c) -> (a, b, c) -> Ordering
conord ([(Name, Int, EvalApply DAlt)] -> [(Name, Int, EvalApply DAlt)])
-> [(Name, Int, EvalApply DAlt)] -> [(Name, Int, EvalApply DAlt)]
forall a b. (a -> b) -> a -> b
$ ((Name, Int) -> [(Name, Int, EvalApply DAlt)])
-> [(Name, Int)] -> [(Name, Int, EvalApply DAlt)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(Name, Int)] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]
toConsA [(Name, Int)]
anames') ([(Name, LDecl)] -> [(Name, Int)]
getFn [(Name, LDecl)]
all)
eval :: (Name, DDecl)
eval = [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkEval [(Name, Int, EvalApply DAlt)]
newecons
app :: (Name, DDecl)
app = [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkApply [(Name, Int, EvalApply DAlt)]
newacons
app2 :: (Name, DDecl)
app2 = [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkApply2 [(Name, Int, EvalApply DAlt)]
newacons
condecls :: [(Name, DDecl)]
condecls = Int -> [(Name, Int, EvalApply DAlt)] -> [(Name, DDecl)]
declare Int
nexttag ([(Name, Int, EvalApply DAlt)]
newecons [(Name, Int, EvalApply DAlt)]
-> [(Name, Int, EvalApply DAlt)] -> [(Name, Int, EvalApply DAlt)]
forall a. [a] -> [a] -> [a]
++ [(Name, Int, EvalApply DAlt)]
newacons) in
[(Name, DDecl)] -> DDefs -> DDefs
forall a. [(Name, a)] -> Ctxt a -> Ctxt a
addAlist ((Name, DDecl)
eval (Name, DDecl) -> [(Name, DDecl)] -> [(Name, DDecl)]
forall a. a -> [a] -> [a]
: (Name, DDecl)
app (Name, DDecl) -> [(Name, DDecl)] -> [(Name, DDecl)]
forall a. a -> [a] -> [a]
: (Name, DDecl)
app2 (Name, DDecl) -> [(Name, DDecl)] -> [(Name, DDecl)]
forall a. a -> [a] -> [a]
: [(Name, DDecl)]
condecls [(Name, DDecl)] -> [(Name, DDecl)] -> [(Name, DDecl)]
forall a. [a] -> [a] -> [a]
++ [(Name, DDecl)]
allD) DDefs
forall {k} {a}. Map k a
emptyContext
where conord :: (a, b, c) -> (a, b, c) -> Ordering
conord (a
n, b
_, c
_) (a
n', b
_, c
_) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
n a
n'
getFn :: [(Name, LDecl)] -> [(Name, Int)]
getFn :: [(Name, LDecl)] -> [(Name, Int)]
getFn [(Name, LDecl)]
xs = ((Name, LDecl) -> Maybe (Name, Int))
-> [(Name, LDecl)] -> [(Name, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Name, LDecl) -> Maybe (Name, Int)
forall {a}. (a, LDecl) -> Maybe (a, Int)
fnData [(Name, LDecl)]
xs
where fnData :: (a, LDecl) -> Maybe (a, Int)
fnData (a
n, LFun [LOpt]
_ Name
_ [Name]
args LExp
_) = (a, Int) -> Maybe (a, Int)
forall a. a -> Maybe a
Just (a
n, [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
args)
fnData (a, LDecl)
_ = Maybe (a, Int)
forall a. Maybe a
Nothing
addApps :: LDefs -> (Name, LDecl) -> State ([Name], [(Name, Int)]) (Name, DDecl)
addApps :: LDefs
-> (Name, LDecl)
-> StateT ([Name], [(Name, Int)]) Identity (Name, DDecl)
addApps LDefs
defs o :: (Name, LDecl)
o@(Name
n, LConstructor Name
_ Int
t Int
a)
= (Name, DDecl)
-> StateT ([Name], [(Name, Int)]) Identity (Name, DDecl)
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Name -> Int -> Int -> DDecl
DConstructor Name
n Int
t Int
a)
addApps LDefs
defs (Name
n, LFun [LOpt]
_ Name
_ [Name]
args LExp
e)
= do DExp
e' <- [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
args LExp
e
(Name, DDecl)
-> StateT ([Name], [(Name, Int)]) Identity (Name, DDecl)
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Name -> [Name] -> DExp -> DDecl
DFun Name
n [Name]
args DExp
e')
where
aa :: [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa :: [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env (LV Name
n) | Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
env = DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DV Name
n
| Bool
otherwise = [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env (Bool -> LExp -> [LExp] -> LExp
LApp Bool
False (Name -> LExp
LV Name
n) [])
aa [Name]
env (LApp Bool
tc (LV Name
n) [LExp]
args)
= do [DExp]
args' <- (LExp -> State ([Name], [(Name, Int)]) DExp)
-> [LExp] -> StateT ([Name], [(Name, Int)]) Identity [DExp]
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] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env) [LExp]
args
case Name -> LDefs -> Maybe LDecl
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n LDefs
defs of
Just (LConstructor Name
_ Int
i Int
ar) -> DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [DExp] -> DExp
DApp Bool
tc Name
n [DExp]
args'
Just (LFun [LOpt]
_ Name
_ [Name]
as LExp
_) -> let arity :: Int
arity = [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
as in
Bool -> Name -> [DExp] -> Int -> State ([Name], [(Name, Int)]) DExp
forall {m :: * -> *} {a}.
MonadState (a, [(Name, Int)]) m =>
Bool -> Name -> [DExp] -> Int -> m DExp
fixApply Bool
tc Name
n [DExp]
args' Int
arity
Maybe LDecl
Nothing -> DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DExp] -> DExp
chainAPPLY (Name -> DExp
DV Name
n) [DExp]
args'
aa [Name]
env (LLazyApp Name
n [LExp]
args)
= do [DExp]
args' <- (LExp -> State ([Name], [(Name, Int)]) DExp)
-> [LExp] -> StateT ([Name], [(Name, Int)]) Identity [DExp]
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] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env) [LExp]
args
case Name -> LDefs -> Maybe LDecl
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n LDefs
defs of
Just (LConstructor Name
_ Int
i Int
ar) -> DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [DExp] -> DExp
DApp Bool
False Name
n [DExp]
args'
Just (LFun [LOpt]
_ Name
_ [Name]
as LExp
_) -> let arity :: Int
arity = [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
as in
Name -> [DExp] -> Int -> State ([Name], [(Name, Int)]) DExp
forall {m :: * -> *}.
MonadState ([Name], [(Name, Int)]) m =>
Name -> [DExp] -> Int -> m DExp
fixLazyApply Name
n [DExp]
args' Int
arity
Maybe LDecl
Nothing -> DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DExp] -> DExp
chainAPPLY (Name -> DExp
DV Name
n) [DExp]
args'
aa [Name]
env (LForce (LLazyApp Name
n [LExp]
args)) = [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env (Bool -> LExp -> [LExp] -> LExp
LApp Bool
False (Name -> LExp
LV Name
n) [LExp]
args)
aa [Name]
env (LForce LExp
e) = (DExp -> DExp)
-> State ([Name], [(Name, Int)]) DExp
-> State ([Name], [(Name, Int)]) DExp
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM DExp -> DExp
eEVAL ([Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env LExp
e)
aa [Name]
env (LLet Name
n LExp
v LExp
sc) = (DExp -> DExp -> DExp)
-> State ([Name], [(Name, Int)]) DExp
-> State ([Name], [(Name, Int)]) DExp
-> State ([Name], [(Name, Int)]) DExp
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (Name -> DExp -> DExp -> DExp
DLet Name
n) ([Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env LExp
v) ([Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa (Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
env) LExp
sc)
aa [Name]
env (LCon Maybe Name
loc Int
i Name
n [LExp]
args) = ([DExp] -> DExp)
-> StateT ([Name], [(Name, Int)]) Identity [DExp]
-> State ([Name], [(Name, Int)]) DExp
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Maybe Name -> Int -> Name -> [DExp] -> DExp
DC Maybe Name
loc Int
i Name
n) ((LExp -> State ([Name], [(Name, Int)]) DExp)
-> [LExp] -> StateT ([Name], [(Name, Int)]) Identity [DExp]
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] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env) [LExp]
args)
aa [Name]
env (LProj t :: LExp
t@(LV Name
n) Int
i)
| Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
env = do DExp
t' <- [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env LExp
t
DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ DExp -> Int -> DExp
DProj (Name -> DExp -> DExp
DUpdate Name
n DExp
t') Int
i
aa [Name]
env (LProj LExp
t Int
i) = do DExp
t' <- [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env LExp
t
DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ DExp -> Int -> DExp
DProj DExp
t' Int
i
aa [Name]
env (LCase CaseType
up LExp
e [LAlt]
alts) = do DExp
e' <- [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env LExp
e
[DAlt]
alts' <- (LAlt -> StateT ([Name], [(Name, Int)]) Identity DAlt)
-> [LAlt] -> StateT ([Name], [(Name, Int)]) Identity [DAlt]
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] -> LAlt -> StateT ([Name], [(Name, Int)]) Identity DAlt
aaAlt [Name]
env) [LAlt]
alts
DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ CaseType -> DExp -> [DAlt] -> DExp
DCase CaseType
up DExp
e' [DAlt]
alts'
aa [Name]
env (LConst Const
c) = DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ Const -> DExp
DConst Const
c
aa [Name]
env (LForeign FDesc
t FDesc
n [(FDesc, LExp)]
args)
= do [(FDesc, DExp)]
args' <- ((FDesc, LExp)
-> StateT ([Name], [(Name, Int)]) Identity (FDesc, DExp))
-> [(FDesc, LExp)]
-> StateT ([Name], [(Name, Int)]) Identity [(FDesc, DExp)]
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]
-> (FDesc, LExp)
-> StateT ([Name], [(Name, Int)]) Identity (FDesc, DExp)
forall {a}.
[Name]
-> (a, LExp) -> StateT ([Name], [(Name, Int)]) Identity (a, DExp)
aaF [Name]
env) [(FDesc, LExp)]
args
DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ FDesc -> FDesc -> [(FDesc, DExp)] -> DExp
DForeign FDesc
t FDesc
n [(FDesc, DExp)]
args'
aa [Name]
env (LOp PrimFn
LFork [LExp]
args) = ([DExp] -> DExp)
-> StateT ([Name], [(Name, Int)]) Identity [DExp]
-> State ([Name], [(Name, Int)]) DExp
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PrimFn -> [DExp] -> DExp
DOp PrimFn
LFork) ((LExp -> State ([Name], [(Name, Int)]) DExp)
-> [LExp] -> StateT ([Name], [(Name, Int)]) Identity [DExp]
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] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env) [LExp]
args)
aa [Name]
env (LOp PrimFn
f [LExp]
args) = do [DExp]
args' <- (LExp -> State ([Name], [(Name, Int)]) DExp)
-> [LExp] -> StateT ([Name], [(Name, Int)]) Identity [DExp]
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] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env) [LExp]
args
DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ PrimFn -> [DExp] -> DExp
DOp PrimFn
f [DExp]
args'
aa [Name]
env LExp
LNothing = DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
DNothing
aa [Name]
env (LError String
e) = DExp -> State ([Name], [(Name, Int)]) DExp
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> State ([Name], [(Name, Int)]) DExp)
-> DExp -> State ([Name], [(Name, Int)]) DExp
forall a b. (a -> b) -> a -> b
$ String -> DExp
DError String
e
aaF :: [Name]
-> (a, LExp) -> StateT ([Name], [(Name, Int)]) Identity (a, DExp)
aaF [Name]
env (a
t, LExp
e) = do DExp
e' <- [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env LExp
e
(a, DExp) -> StateT ([Name], [(Name, Int)]) Identity (a, DExp)
forall a. a -> StateT ([Name], [(Name, Int)]) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
t, DExp
e')
aaAlt :: [Name] -> LAlt -> StateT ([Name], [(Name, Int)]) Identity DAlt
aaAlt [Name]
env (LConCase Int
i Name
n [Name]
args LExp
e)
= (DExp -> DAlt)
-> State ([Name], [(Name, Int)]) DExp
-> StateT ([Name], [(Name, Int)]) Identity DAlt
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Name -> [Name] -> DExp -> DAlt
DConCase Int
i Name
n [Name]
args) ([Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa ([Name]
args [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
env) LExp
e)
aaAlt [Name]
env (LConstCase Const
c LExp
e) = (DExp -> DAlt)
-> State ([Name], [(Name, Int)]) DExp
-> StateT ([Name], [(Name, Int)]) Identity DAlt
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Const -> DExp -> DAlt
DConstCase Const
c) ([Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env LExp
e)
aaAlt [Name]
env (LDefaultCase LExp
e) = (DExp -> DAlt)
-> State ([Name], [(Name, Int)]) DExp
-> StateT ([Name], [(Name, Int)]) Identity DAlt
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM DExp -> DAlt
DDefaultCase ([Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env LExp
e)
fixApply :: Bool -> Name -> [DExp] -> Int -> m DExp
fixApply Bool
tc Name
n [DExp]
args Int
ar
| [DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ar
= DExp -> m DExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> m DExp) -> DExp -> m DExp
forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [DExp] -> DExp
DApp Bool
tc Name
n [DExp]
args
| [DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ar
= do (a
ens, [(Name, Int)]
ans) <- m (a, [(Name, Int)])
forall s (m :: * -> *). MonadState s m => m s
get
let alln :: [(Name, Int)]
alln = (Int -> (Name, Int)) -> [Int] -> [(Name, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (Name
n, Int
x)) [[DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args .. Int
ar]
(a, [(Name, Int)]) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (a
ens, [(Name, Int)]
alln [(Name, Int)] -> [(Name, Int)] -> [(Name, Int)]
forall a. [a] -> [a] -> [a]
++ [(Name, Int)]
ans)
DExp -> m DExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> m DExp) -> DExp -> m DExp
forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [DExp] -> DExp
DApp Bool
tc (Name -> Int -> Name
mkUnderCon Name
n (Int
ar Int -> Int -> Int
forall a. Num a => a -> a -> a
- [DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args)) [DExp]
args
| [DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
ar
= DExp -> m DExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> m DExp) -> DExp -> m DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DExp] -> DExp
chainAPPLY (Bool -> Name -> [DExp] -> DExp
DApp Bool
tc Name
n (Int -> [DExp] -> [DExp]
forall a. Int -> [a] -> [a]
take Int
ar [DExp]
args)) (Int -> [DExp] -> [DExp]
forall a. Int -> [a] -> [a]
drop Int
ar [DExp]
args)
fixLazyApply :: Name -> [DExp] -> Int -> m DExp
fixLazyApply Name
n [DExp]
args Int
ar
| [DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ar
= do ([Name]
ens, [(Name, Int)]
ans) <- m ([Name], [(Name, Int)])
forall s (m :: * -> *). MonadState s m => m s
get
([Name], [(Name, Int)]) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
ens, [(Name, Int)]
ans)
DExp -> m DExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> m DExp) -> DExp -> m DExp
forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Name -> Name
forall {a}. Show a => a -> Name
mkFnCon Name
n) [DExp]
args
| [DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ar
= do ([Name]
ens, [(Name, Int)]
ans) <- m ([Name], [(Name, Int)])
forall s (m :: * -> *). MonadState s m => m s
get
let alln :: [(Name, Int)]
alln = (Int -> (Name, Int)) -> [Int] -> [(Name, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (Name
n, Int
x)) [[DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args .. Int
ar]
([Name], [(Name, Int)]) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Name]
ens, [(Name, Int)]
alln [(Name, Int)] -> [(Name, Int)] -> [(Name, Int)]
forall a. [a] -> [a] -> [a]
++ [(Name, Int)]
ans)
DExp -> m DExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> m DExp) -> DExp -> m DExp
forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Name -> Int -> Name
mkUnderCon Name
n (Int
ar Int -> Int -> Int
forall a. Num a => a -> a -> a
- [DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args)) [DExp]
args
| [DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
ar
= DExp -> m DExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> m DExp) -> DExp -> m DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DExp] -> DExp
chainAPPLY (Bool -> Name -> [DExp] -> DExp
DApp Bool
False Name
n (Int -> [DExp] -> [DExp]
forall a. Int -> [a] -> [a]
take Int
ar [DExp]
args)) (Int -> [DExp] -> [DExp]
forall a. Int -> [a] -> [a]
drop Int
ar [DExp]
args)
chainAPPLY :: DExp -> [DExp] -> DExp
chainAPPLY DExp
f [] = DExp
f
chainAPPLY DExp
f (DExp
a : [DExp]
as) = DExp -> [DExp] -> DExp
chainAPPLY (Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Int -> String -> Name
sMN Int
0 String
"APPLY") [DExp
f, DExp
a]) [DExp]
as
eEVAL :: DExp -> DExp
eEVAL DExp
x = Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Int -> String -> Name
sMN Int
0 String
"EVAL") [DExp
x]
data EvalApply a = EvalCase (Name -> a)
| ApplyCase a
| Apply2Case a
toCons :: [Name] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]
toCons :: [Name] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]
toCons [Name]
ns (Name
n, Int
i)
| Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
ns
= (Name -> Name
forall {a}. Show a => a -> Name
mkFnCon Name
n, Int
i,
(Name -> DAlt) -> EvalApply DAlt
forall a. (Name -> a) -> EvalApply a
EvalCase (\Name
tlarg ->
(Int -> Name -> [Name] -> DExp -> DAlt
DConCase (-Int
1) (Name -> Name
forall {a}. Show a => a -> Name
mkFnCon Name
n) (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
i (Int -> [Name]
genArgs Int
0))
(Name -> DExp -> DExp
dupdate Name
tlarg
(Bool -> Name -> [DExp] -> DExp
DApp Bool
False Name
n ((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DV (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
i (Int -> [Name]
genArgs Int
0))))))))
(Name, Int, EvalApply DAlt)
-> [(Name, Int, EvalApply DAlt)] -> [(Name, Int, EvalApply DAlt)]
forall a. a -> [a] -> [a]
: []
| Bool
otherwise = []
where dupdate :: Name -> DExp -> DExp
dupdate Name
tlarg DExp
x = Name -> DExp -> DExp
DUpdate Name
tlarg DExp
x
toConsA :: [(Name, Int)] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]
toConsA :: [(Name, Int)] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]
toConsA [(Name, Int)]
ns (Name
n, Int
i)
| Just Int
ar <- Name -> [(Name, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Int)]
ns
= Name -> Int -> Int -> [(Name, Int, EvalApply DAlt)]
mkApplyCase Name
n Int
ar Int
i
| Bool
otherwise = []
mkApplyCase :: Name -> Int -> Int -> [(Name, Int, EvalApply DAlt)]
mkApplyCase Name
fname Int
n Int
ar | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ar = []
mkApplyCase Name
fname Int
n Int
ar
= let nm :: Name
nm = Name -> Int -> Name
mkUnderCon Name
fname (Int
ar Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) in
(Name
nm, Int
n, DAlt -> EvalApply DAlt
forall a. a -> EvalApply a
ApplyCase (Int -> Name -> [Name] -> DExp -> DAlt
DConCase (-Int
1) Name
nm (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n (Int -> [Name]
genArgs Int
0))
(Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Name -> Int -> Name
mkUnderCon Name
fname (Int
ar Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)))
((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DV (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n (Int -> [Name]
genArgs Int
0) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
[Int -> String -> Name
sMN Int
0 String
"arg"])))))
(Name, Int, EvalApply DAlt)
-> [(Name, Int, EvalApply DAlt)] -> [(Name, Int, EvalApply DAlt)]
forall a. a -> [a] -> [a]
:
if (Int
ar Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
0 )
then (Name
nm, Int
n, DAlt -> EvalApply DAlt
forall a. a -> EvalApply a
Apply2Case (Int -> Name -> [Name] -> DExp -> DAlt
DConCase (-Int
1) Name
nm (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n (Int -> [Name]
genArgs Int
0))
(Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Name -> Int -> Name
mkUnderCon Name
fname (Int
ar Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)))
((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DV (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n (Int -> [Name]
genArgs Int
0) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
[Int -> String -> Name
sMN Int
0 String
"arg0", Int -> String -> Name
sMN Int
0 String
"arg1"])))))
(Name, Int, EvalApply DAlt)
-> [(Name, Int, EvalApply DAlt)] -> [(Name, Int, EvalApply DAlt)]
forall a. a -> [a] -> [a]
:
Name -> Int -> Int -> [(Name, Int, EvalApply DAlt)]
mkApplyCase Name
fname (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
ar
else Name -> Int -> Int -> [(Name, Int, EvalApply DAlt)]
mkApplyCase Name
fname (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
ar
mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkEval [(Name, Int, EvalApply DAlt)]
xs = (Int -> String -> Name
sMN Int
0 String
"EVAL", Name -> [Name] -> DExp -> DDecl
DFun (Int -> String -> Name
sMN Int
0 String
"EVAL") [Int -> String -> Name
sMN Int
0 String
"arg"]
(Name -> Int -> DExp -> [DAlt] -> DExp
forall {p}. p -> Int -> DExp -> [DAlt] -> DExp
mkBigCase (Int -> String -> Name
sMN Int
0 String
"EVAL") Int
256 (Name -> DExp
DV (Int -> String -> Name
sMN Int
0 String
"arg"))
(((Name, Int, EvalApply DAlt) -> Maybe DAlt)
-> [(Name, Int, EvalApply DAlt)] -> [DAlt]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Name, Int, EvalApply DAlt) -> Maybe DAlt
forall {a} {b} {a}. (a, b, EvalApply a) -> Maybe a
evalCase [(Name, Int, EvalApply DAlt)]
xs [DAlt] -> [DAlt] -> [DAlt]
forall a. [a] -> [a] -> [a]
++
[DExp -> DAlt
DDefaultCase (Name -> DExp
DV (Int -> String -> Name
sMN Int
0 String
"arg"))])))
where
evalCase :: (a, b, EvalApply a) -> Maybe a
evalCase (a
n, b
t, EvalCase Name -> a
x) = a -> Maybe a
forall a. a -> Maybe a
Just (Name -> a
x (Int -> String -> Name
sMN Int
0 String
"arg"))
evalCase (a, b, EvalApply a)
_ = Maybe a
forall a. Maybe a
Nothing
mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkApply [(Name, Int, EvalApply DAlt)]
xs = (Int -> String -> Name
sMN Int
0 String
"APPLY", Name -> [Name] -> DExp -> DDecl
DFun (Int -> String -> Name
sMN Int
0 String
"APPLY") [Int -> String -> Name
sMN Int
0 String
"fn", Int -> String -> Name
sMN Int
0 String
"arg"]
(case ((Name, Int, EvalApply DAlt) -> Maybe DAlt)
-> [(Name, Int, EvalApply DAlt)] -> [DAlt]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Name, Int, EvalApply DAlt) -> Maybe DAlt
forall {a} {b} {a}. (a, b, EvalApply a) -> Maybe a
applyCase [(Name, Int, EvalApply DAlt)]
xs of
[] -> DExp
DNothing
[DAlt]
cases ->
Name -> Int -> DExp -> [DAlt] -> DExp
forall {p}. p -> Int -> DExp -> [DAlt] -> DExp
mkBigCase (Int -> String -> Name
sMN Int
0 String
"APPLY") Int
256
(Name -> DExp
DV (Int -> String -> Name
sMN Int
0 String
"fn"))
([DAlt]
cases [DAlt] -> [DAlt] -> [DAlt]
forall a. [a] -> [a] -> [a]
++
[DExp -> DAlt
DDefaultCase DExp
DNothing])))
where
applyCase :: (a, b, EvalApply a) -> Maybe a
applyCase (a
n, b
t, ApplyCase a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
applyCase (a, b, EvalApply a)
_ = Maybe a
forall a. Maybe a
Nothing
mkApply2 :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkApply2 :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkApply2 [(Name, Int, EvalApply DAlt)]
xs = (Int -> String -> Name
sMN Int
0 String
"APPLY2", Name -> [Name] -> DExp -> DDecl
DFun (Int -> String -> Name
sMN Int
0 String
"APPLY2") [Int -> String -> Name
sMN Int
0 String
"fn", Int -> String -> Name
sMN Int
0 String
"arg0", Int -> String -> Name
sMN Int
0 String
"arg1"]
(case ((Name, Int, EvalApply DAlt) -> Maybe DAlt)
-> [(Name, Int, EvalApply DAlt)] -> [DAlt]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Name, Int, EvalApply DAlt) -> Maybe DAlt
forall {a} {b} {a}. (a, b, EvalApply a) -> Maybe a
applyCase [(Name, Int, EvalApply DAlt)]
xs of
[] -> DExp
DNothing
[DAlt]
cases ->
Name -> Int -> DExp -> [DAlt] -> DExp
forall {p}. p -> Int -> DExp -> [DAlt] -> DExp
mkBigCase (Int -> String -> Name
sMN Int
0 String
"APPLY") Int
256
(Name -> DExp
DV (Int -> String -> Name
sMN Int
0 String
"fn"))
([DAlt]
cases [DAlt] -> [DAlt] -> [DAlt]
forall a. [a] -> [a] -> [a]
++
[DExp -> DAlt
DDefaultCase
(Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Int -> String -> Name
sMN Int
0 String
"APPLY")
[Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Int -> String -> Name
sMN Int
0 String
"APPLY")
[Name -> DExp
DV (Int -> String -> Name
sMN Int
0 String
"fn"),
Name -> DExp
DV (Int -> String -> Name
sMN Int
0 String
"arg0")],
Name -> DExp
DV (Int -> String -> Name
sMN Int
0 String
"arg1")])
])))
where
applyCase :: (a, b, EvalApply a) -> Maybe a
applyCase (a
n, b
t, Apply2Case a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
applyCase (a, b, EvalApply a)
_ = Maybe a
forall a. Maybe a
Nothing
declare :: Int -> [(Name, Int, EvalApply DAlt)] -> [(Name, DDecl)]
declare :: Int -> [(Name, Int, EvalApply DAlt)] -> [(Name, DDecl)]
declare Int
t [(Name, Int, EvalApply DAlt)]
xs = Int
-> [(Name, Int, EvalApply DAlt)]
-> [(Name, DDecl)]
-> [(Name, DDecl)]
forall {c}.
Int -> [(Name, Int, c)] -> [(Name, DDecl)] -> [(Name, DDecl)]
dec' Int
t [(Name, Int, EvalApply DAlt)]
xs [] where
dec' :: Int -> [(Name, Int, c)] -> [(Name, DDecl)] -> [(Name, DDecl)]
dec' Int
t [] [(Name, DDecl)]
acc = [(Name, DDecl)] -> [(Name, DDecl)]
forall a. [a] -> [a]
reverse [(Name, DDecl)]
acc
dec' Int
t ((Name
n, Int
ar, c
_) : [(Name, Int, c)]
xs) [(Name, DDecl)]
acc = Int -> [(Name, Int, c)] -> [(Name, DDecl)] -> [(Name, DDecl)]
dec' (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Name, Int, c)]
xs ((Name
n, Name -> Int -> Int -> DDecl
DConstructor Name
n Int
t Int
ar) (Name, DDecl) -> [(Name, DDecl)] -> [(Name, DDecl)]
forall a. a -> [a] -> [a]
: [(Name, DDecl)]
acc)
genArgs :: Int -> [Name]
genArgs Int
i = Int -> String -> Name
sMN Int
i String
"P_c" Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Int -> [Name]
genArgs (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
mkFnCon :: a -> Name
mkFnCon a
n = Int -> String -> Name
sMN Int
0 (String
"P_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n)
mkUnderCon :: Name -> Int -> Name
mkUnderCon Name
n Int
0 = Name
n
mkUnderCon Name
n Int
missing = Int -> String -> Name
sMN Int
missing (String
"U_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n)
instance Show DExp where
show :: DExp -> String
show DExp
e = [String] -> DExp -> String
show' [] DExp
e where
show' :: [String] -> DExp -> String
show' [String]
env (DV Name
n) = Name -> String
forall a. Show a => a -> String
show Name
n
show' [String]
env (DApp Bool
_ Name
e [DExp]
args) = Name -> String
forall a. Show a => a -> String
show Name
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String -> [String] -> String
showSep String
", " ((DExp -> String) -> [DExp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DExp -> String
show' [String]
env) [DExp]
args) String -> ShowS
forall a. [a] -> [a] -> [a]
++String
")"
show' [String]
env (DLet Name
n DExp
v DExp
e) = String
"let " 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
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in " String -> ShowS
forall a. [a] -> [a] -> [a]
++
[String] -> DExp -> String
show' ([String]
env [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [Name -> String
forall a. Show a => a -> String
show Name
n]) DExp
e
show' [String]
env (DUpdate Name
n DExp
e) = String
"!update " 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
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
show' [String]
env (DC Maybe Name
loc Int
i Name
n [DExp]
args) = Maybe Name -> String
atloc Maybe Name
loc String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"CON " 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
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
", " ((DExp -> String) -> [DExp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DExp -> String
show' [String]
env) [DExp]
args) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
where atloc :: Maybe Name -> String
atloc Maybe Name
Nothing = String
""
atloc (Just Name
l) = String
"@" String -> ShowS
forall a. [a] -> [a] -> [a]
++ LExp -> String
forall a. Show a => a -> String
show (Name -> LExp
LV Name
l) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":"
show' [String]
env (DProj DExp
t Int
i) = DExp -> String
forall a. Show a => a -> String
show DExp
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"!" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
show' [String]
env (DCase CaseType
up DExp
e [DAlt]
alts) = String
"case" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
update String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" of {\n\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String -> [String] -> String
showSep String
"\n\t| " ((DAlt -> String) -> [DAlt] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DAlt -> String
showAlt [String]
env) [DAlt]
alts)
where update :: String
update = case CaseType
up of
CaseType
Shared -> String
" "
CaseType
Updatable -> String
"! "
show' [String]
env (DChkCase DExp
e [DAlt]
alts) = String
"case' " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" of {\n\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++
String -> [String] -> String
showSep String
"\n\t| " ((DAlt -> String) -> [DAlt] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DAlt -> String
showAlt [String]
env) [DAlt]
alts)
show' [String]
env (DConst Const
c) = Const -> String
forall a. Show a => a -> String
show Const
c
show' [String]
env (DForeign FDesc
ty FDesc
n [(FDesc, DExp)]
args)
= String
"foreign " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FDesc -> String
forall a. Show a => a -> String
show FDesc
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
", " ((DExp -> String) -> [DExp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DExp -> String
show' [String]
env) (((FDesc, DExp) -> DExp) -> [(FDesc, DExp)] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map (FDesc, DExp) -> DExp
forall a b. (a, b) -> b
snd [(FDesc, DExp)]
args)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
show' [String]
env (DOp PrimFn
f [DExp]
args) = PrimFn -> String
forall a. Show a => a -> String
show PrimFn
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
", " ((DExp -> String) -> [DExp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DExp -> String
show' [String]
env) [DExp]
args) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
show' [String]
env (DError String
str) = String
"error " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
str
show' [String]
env DExp
DNothing = String
"____"
showAlt :: [String] -> DAlt -> String
showAlt [String]
env (DConCase Int
_ Name
n [Name]
args DExp
e)
= Name -> String
forall a. Show a => a -> String
show Name
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
", " ((Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name -> String
forall a. Show a => a -> String
show [Name]
args) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") => "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e
showAlt [String]
env (DConstCase Const
c DExp
e) = Const -> String
forall a. Show a => a -> String
show Const
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" => " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e
showAlt [String]
env (DDefaultCase DExp
e) = String
"_ => " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e
mkBigCase :: p -> Int -> DExp -> [DAlt] -> DExp
mkBigCase p
cn Int
max DExp
arg [DAlt]
branches
| [DAlt] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DAlt]
branches Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
max = DExp -> [DAlt] -> DExp
DChkCase DExp
arg [DAlt]
branches
| Bool
otherwise = DExp -> [DAlt] -> DExp
DChkCase DExp
arg [DAlt]
branches
groupsOf :: Int -> [DAlt] -> [[DAlt]]
groupsOf :: Int -> [DAlt] -> [[DAlt]]
groupsOf Int
x [] = []
groupsOf Int
x [DAlt]
xs = let ([DAlt]
batch, [DAlt]
rest) = (DAlt -> Bool) -> [DAlt] -> ([DAlt], [DAlt])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Int -> DAlt -> Bool
tagLT (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [DAlt] -> Int
tagHead [DAlt]
xs)) [DAlt]
xs in
[DAlt]
batch [DAlt] -> [[DAlt]] -> [[DAlt]]
forall a. a -> [a] -> [a]
: Int -> [DAlt] -> [[DAlt]]
groupsOf Int
x [DAlt]
rest
where tagHead :: [DAlt] -> Int
tagHead (DConstCase (I Int
i) DExp
_ : [DAlt]
_) = Int
i
tagHead (DConCase Int
t Name
_ [Name]
_ DExp
_ : [DAlt]
_) = Int
t
tagHead (DDefaultCase DExp
_ : [DAlt]
_) = -Int
1
tagLT :: Int -> DAlt -> Bool
tagLT Int
i (DConstCase (I Int
j) DExp
_) = Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
j
tagLT Int
i (DConCase Int
j Name
_ [Name]
_ DExp
_) = Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
j
tagLT Int
i (DDefaultCase DExp
_) = Bool
False
dumpDefuns :: DDefs -> String
dumpDefuns :: DDefs -> String
dumpDefuns DDefs
ds = String -> [String] -> String
showSep String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Name, DDecl) -> String) -> [(Name, DDecl)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Name, DDecl) -> String
forall {a}. (a, DDecl) -> String
showDef (DDefs -> [(Name, DDecl)]
forall a. Ctxt a -> [(Name, a)]
toAlist DDefs
ds)
where showDef :: (a, DDecl) -> String
showDef (a
x, DFun Name
fn [Name]
args DExp
exp)
= 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 -> [String] -> String
showSep String
", " ((Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name -> String
forall a. Show a => a -> String
show [Name]
args) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") = \n\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++
DExp -> String
forall a. Show a => a -> String
show DExp
exp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
showDef (a
x, DConstructor Name
n Int
t Int
a) = 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
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
t