{-|
Module      : IRTS.Defunctionalise
Description : Defunctionalise Idris' IR.

License     : BSD3
Maintainer  : The Idris Community.

To defunctionalise:

1. Create a data constructor for each function
2. Create a data constructor for each underapplication of a function
3. Convert underapplications to their corresponding constructors
4. Create an EVAL function which calls the appropriate function for data constructors
   created as part of step 1
5. Create an APPLY function which adds an argument to each underapplication (or calls
   APPLY again for an exact application)
6. Wrap overapplications in chains of APPLY
7. Wrap unknown applications (i.e. applications of local variables) in chains of APPLY
8. Add explicit EVAL to case, primitives, and foreign calls

-}
{-# 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] -- True = tail call
          | DLet Name DExp DExp -- name just for pretty printing
          | DUpdate Name DExp -- eval expression, then update var with it
          | DProj DExp Int
          | DC (Maybe Name) Int Name [DExp]
          | DCase CaseType DExp [DAlt]
          | DChkCase DExp [DAlt] -- a case where the type is unknown (for EVAL/APPLY)
          | DConst Const
          | DForeign FDesc FDesc [(FDesc, DExp)]
          | DOp PrimFn [DExp]
          | DNothing -- erased value, can be compiled to anything since it'll never
                     -- be inspected
          | 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 -- name, arg names, definition
           | DConstructor Name Int Int -- constructor name, tag, arity
  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
           -- sort newcons so that EVAL and APPLY cons get sequential tags
           ([(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 f (a : b : as)
--          = chainAPPLY (DApp False (sMN 0 "APPLY2") [f, a, b]) as
    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

-- For a function name, generate a list of
-- data constuctors, and whether to handle them in EVAL or APPLY

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]
: [] -- mkApplyCase n 0 i
    | 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
--       = (mkFnCon n, i,
--           EvalCase (\tlarg ->
--             (DConCase (-1) (mkFnCon n) (take i (genArgs 0))
--               (dupdate tlarg
--                 (DApp False n (map DV (take i (genArgs 0))))))))
          = 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

-- | Divide up a large case expression so that each has a maximum of
-- 'max' branches
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 -- must be the end

        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