{-|
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
/= :: DExp -> DExp -> Bool
$c/= :: DExp -> DExp -> Bool
== :: DExp -> DExp -> Bool
$c== :: 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
showList :: [DAlt] -> ShowS
$cshowList :: [DAlt] -> ShowS
show :: DAlt -> String
$cshow :: DAlt -> String
showsPrec :: Int -> DAlt -> ShowS
$cshowsPrec :: Int -> DAlt -> ShowS
Show, DAlt -> DAlt -> Bool
(DAlt -> DAlt -> Bool) -> (DAlt -> DAlt -> Bool) -> Eq DAlt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DAlt -> DAlt -> Bool
$c/= :: DAlt -> DAlt -> Bool
== :: DAlt -> DAlt -> Bool
$c== :: 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
showList :: [DDecl] -> ShowS
$cshowList :: [DDecl] -> ShowS
show :: DDecl -> String
$cshow :: DDecl -> String
showsPrec :: Int -> DDecl -> ShowS
$cshowsPrec :: Int -> DDecl -> ShowS
Show, DDecl -> DDecl -> Bool
(DDecl -> DDecl -> Bool) -> (DDecl -> DDecl -> Bool) -> Eq DDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DDecl -> DDecl -> Bool
$c/= :: DDecl -> DDecl -> Bool
== :: DDecl -> DDecl -> Bool
$c== :: DDecl -> DDecl -> Bool
Eq)

type DDefs = Ctxt DDecl

defunctionalise :: Int -> LDefs -> DDefs
defunctionalise :: Int -> LDefs -> DDefs
defunctionalise nexttag :: Int
nexttag defs :: 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
           (allD :: [(Name, DDecl)]
allD, (enames :: [Name]
enames, anames :: [(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)
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 (n :: a
n, _, _) (n' :: a
n', _, _) = 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 xs :: [(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 (n :: a
n, LFun _ _ args :: [Name]
args _) = (a, Int) -> Maybe (a, Int)
forall a. a -> Maybe a
Just (a
n, [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
args)
        fnData _ = 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 defs :: LDefs
defs o :: (Name, LDecl)
o@(n :: Name
n, LConstructor _ t :: Int
t a :: Int
a)
    = (Name, DDecl)
-> StateT ([Name], [(Name, Int)]) Identity (Name, DDecl)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Name -> Int -> Int -> DDecl
DConstructor Name
n Int
t Int
a)
addApps defs :: LDefs
defs (n :: Name
n, LFun _ _ args :: [Name]
args e :: 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 (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 env :: [Name]
env (LV n :: Name
n) | Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
env = DExp -> State ([Name], [(Name, Int)]) DExp
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 env :: [Name]
env (LApp tc :: Bool
tc (LV n :: Name
n) args :: [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)
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 _ i :: Int
i ar :: Int
ar) -> DExp -> State ([Name], [(Name, Int)]) DExp
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 _ _ as :: [Name]
as _) -> let arity :: Int
arity = [Name] -> 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
                Nothing -> DExp -> State ([Name], [(Name, Int)]) DExp
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 env :: [Name]
env (LLazyApp n :: Name
n args :: [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)
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 _ i :: Int
i ar :: Int
ar) -> DExp -> State ([Name], [(Name, Int)]) DExp
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 _ _ as :: [Name]
as _) -> let arity :: Int
arity = [Name] -> 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
                Nothing -> DExp -> State ([Name], [(Name, Int)]) DExp
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 env :: [Name]
env (LForce (LLazyApp n :: Name
n args :: [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 env :: [Name]
env (LForce e :: 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 env :: [Name]
env (LLet n :: Name
n v :: LExp
v sc :: 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 env :: [Name]
env (LCon loc :: Maybe Name
loc i :: Int
i n :: Name
n args :: [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)
mapM ([Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env) [LExp]
args)
    aa env :: [Name]
env (LProj t :: LExp
t@(LV n :: Name
n) i :: Int
i)
        | Name
n Name -> [Name] -> 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 (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 env :: [Name]
env (LProj t :: LExp
t i :: Int
i) = do DExp
t' <- [Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env LExp
t
                            DExp -> State ([Name], [(Name, Int)]) DExp
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 env :: [Name]
env (LCase up :: CaseType
up e :: LExp
e alts :: [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)
mapM ([Name] -> LAlt -> StateT ([Name], [(Name, Int)]) Identity DAlt
aaAlt [Name]
env) [LAlt]
alts
                                  DExp -> State ([Name], [(Name, Int)]) DExp
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 env :: [Name]
env (LConst c :: Const
c) = DExp -> State ([Name], [(Name, Int)]) DExp
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 env :: [Name]
env (LForeign t :: FDesc
t n :: FDesc
n args :: [(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)
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 (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 env :: [Name]
env (LOp LFork args :: [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)
mapM ([Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env) [LExp]
args)
    aa env :: [Name]
env (LOp f :: PrimFn
f args :: [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)
mapM ([Name] -> LExp -> State ([Name], [(Name, Int)]) DExp
aa [Name]
env) [LExp]
args
                             DExp -> State ([Name], [(Name, Int)]) DExp
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 env :: [Name]
env LNothing = DExp -> State ([Name], [(Name, Int)]) DExp
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
DNothing
    aa env :: [Name]
env (LError e :: String
e) = DExp -> State ([Name], [(Name, Int)]) DExp
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 env :: [Name]
env (t :: a
t, e :: 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 (m :: * -> *) a. Monad m => a -> m a
return (a
t, DExp
e')

    aaAlt :: [Name] -> LAlt -> StateT ([Name], [(Name, Int)]) Identity DAlt
aaAlt env :: [Name]
env (LConCase i :: Int
i n :: Name
n args :: [Name]
args e :: 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 env :: [Name]
env (LConstCase c :: Const
c e :: 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 env :: [Name]
env (LDefaultCase e :: 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 tc :: Bool
tc n :: Name
n args :: [DExp]
args ar :: Int
ar
        | [DExp] -> 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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ar
             = do (ens :: a
ens, ans :: [(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 (\x :: Int
x -> (Name
n, Int
x)) [[DExp] -> 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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args)) [DExp]
args
        | [DExp] -> 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 (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 n :: Name
n args :: [DExp]
args ar :: Int
ar
        | [DExp] -> 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 (ens :: [Name]
ens, ans :: [(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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ar
             = do (ens :: [Name]
ens, ans :: [(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 (\x :: Int
x -> (Name
n, Int
x)) [[DExp] -> 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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args)) [DExp]
args
        | [DExp] -> 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 (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 f :: DExp
f [] = DExp
f
--     chainAPPLY f (a : b : as)
--          = chainAPPLY (DApp False (sMN 0 "APPLY2") [f, a, b]) as
    chainAPPLY f :: DExp
f (a :: DExp
a : as :: [DExp]
as) = DExp -> [DExp] -> DExp
chainAPPLY (Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Int -> String -> Name
sMN 0 "APPLY") [DExp
f, DExp
a]) [DExp]
as

eEVAL :: DExp -> DExp
eEVAL x :: DExp
x = Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Int -> String -> Name
sMN 0 "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 ns :: [Name]
ns (n :: Name
n, i :: Int
i)
    | Name
n Name -> [Name] -> 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 (\tlarg :: Name
tlarg ->
            (Int -> Name -> [Name] -> DExp -> DAlt
DConCase (-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 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 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 tlarg :: Name
tlarg x :: 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 ns :: [(Name, Int)]
ns (n :: Name
n, i :: Int
i)
    | Just ar :: 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 fname :: Name
fname n :: Int
n ar :: Int
ar | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ar = []
mkApplyCase fname :: Name
fname n :: Int
n ar :: 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 (-1) Name
nm (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n (Int -> [Name]
genArgs 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
+ 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 0) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
                         [Int -> String -> Name
sMN 0 "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
+ 2) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=0 )
                 then (Name
nm, Int
n, DAlt -> EvalApply DAlt
forall a. a -> EvalApply a
Apply2Case (Int -> Name -> [Name] -> DExp -> DAlt
DConCase (-1) Name
nm (Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
n (Int -> [Name]
genArgs 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
+ 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 0) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
                         [Int -> String -> Name
sMN 0 "arg0", Int -> String -> Name
sMN 0 "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
+ 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
+ 1) Int
ar

mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkEval xs :: [(Name, Int, EvalApply DAlt)]
xs = (Int -> String -> Name
sMN 0 "EVAL", Name -> [Name] -> DExp -> DDecl
DFun (Int -> String -> Name
sMN 0 "EVAL") [Int -> String -> Name
sMN 0 "arg"]
               (Name -> Int -> DExp -> [DAlt] -> DExp
forall p. p -> Int -> DExp -> [DAlt] -> DExp
mkBigCase (Int -> String -> Name
sMN 0 "EVAL") 256 (Name -> DExp
DV (Int -> String -> Name
sMN 0 "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 0 "arg"))])))
  where
    evalCase :: (a, b, EvalApply a) -> Maybe a
evalCase (n :: a
n, t :: b
t, EvalCase x :: Name -> a
x) = a -> Maybe a
forall a. a -> Maybe a
Just (Name -> a
x (Int -> String -> Name
sMN 0 "arg"))
    evalCase _ = Maybe a
forall a. Maybe a
Nothing

mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkApply xs :: [(Name, Int, EvalApply DAlt)]
xs = (Int -> String -> Name
sMN 0 "APPLY", Name -> [Name] -> DExp -> DDecl
DFun (Int -> String -> Name
sMN 0 "APPLY") [Int -> String -> Name
sMN 0 "fn", Int -> String -> Name
sMN 0 "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
                                cases :: [DAlt]
cases ->
                                    Name -> Int -> DExp -> [DAlt] -> DExp
forall p. p -> Int -> DExp -> [DAlt] -> DExp
mkBigCase (Int -> String -> Name
sMN 0 "APPLY") 256
                                               (Name -> DExp
DV (Int -> String -> Name
sMN 0 "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 (n :: a
n, t :: b
t, ApplyCase x :: a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
    applyCase _ = Maybe a
forall a. Maybe a
Nothing

mkApply2 :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkApply2 :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
mkApply2 xs :: [(Name, Int, EvalApply DAlt)]
xs = (Int -> String -> Name
sMN 0 "APPLY2", Name -> [Name] -> DExp -> DDecl
DFun (Int -> String -> Name
sMN 0 "APPLY2") [Int -> String -> Name
sMN 0 "fn", Int -> String -> Name
sMN 0 "arg0", Int -> String -> Name
sMN 0 "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
                                cases :: [DAlt]
cases ->
                                    Name -> Int -> DExp -> [DAlt] -> DExp
forall p. p -> Int -> DExp -> [DAlt] -> DExp
mkBigCase (Int -> String -> Name
sMN 0 "APPLY") 256
                                               (Name -> DExp
DV (Int -> String -> Name
sMN 0 "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 0 "APPLY")
                                       [Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Int -> String -> Name
sMN 0 "APPLY")
                                              [Name -> DExp
DV (Int -> String -> Name
sMN 0 "fn"),
                                               Name -> DExp
DV (Int -> String -> Name
sMN 0 "arg0")],
                                               Name -> DExp
DV (Int -> String -> Name
sMN 0 "arg1")])
                                               ])))
  where
    applyCase :: (a, b, EvalApply a) -> Maybe a
applyCase (n :: a
n, t :: b
t, Apply2Case x :: a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
    applyCase _ = Maybe a
forall a. Maybe a
Nothing


declare :: Int -> [(Name, Int, EvalApply DAlt)] -> [(Name, DDecl)]
declare :: Int -> [(Name, Int, EvalApply DAlt)] -> [(Name, DDecl)]
declare t :: Int
t xs :: [(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' t :: Int
t [] acc :: [(Name, DDecl)]
acc = [(Name, DDecl)] -> [(Name, DDecl)]
forall a. [a] -> [a]
reverse [(Name, DDecl)]
acc
   dec' t :: Int
t ((n :: Name
n, ar :: Int
ar, _) : xs :: [(Name, Int, c)]
xs) acc :: [(Name, DDecl)]
acc = Int -> [(Name, Int, c)] -> [(Name, DDecl)] -> [(Name, DDecl)]
dec' (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 i :: Int
i = Int -> String -> Name
sMN Int
i "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
+ 1)

mkFnCon :: a -> Name
mkFnCon    n :: a
n = Int -> String -> Name
sMN 0 ("P_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n)
mkUnderCon :: Name -> Int -> Name
mkUnderCon n :: Name
n 0       = Name
n
mkUnderCon n :: Name
n missing :: Int
missing = Int -> String -> Name
sMN Int
missing ("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 e :: DExp
e = [String] -> DExp -> String
show' [] DExp
e where
     show' :: [String] -> DExp -> String
show' env :: [String]
env (DV n :: Name
n) = Name -> String
forall a. Show a => a -> String
show Name
n
     show' env :: [String]
env (DApp _ e :: Name
e args :: [DExp]
args) = Name -> String
forall a. Show a => a -> String
show Name
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ "(" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                   String -> [String] -> String
showSep ", " ((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]
++")"
     show' env :: [String]
env (DLet n :: Name
n v :: DExp
v e :: DExp
e) = "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 -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ " 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' env :: [String]
env (DUpdate n :: Name
n e :: DExp
e) = "!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 -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
     show' env :: [String]
env (DC loc :: Maybe Name
loc i :: Int
i n :: Name
n args :: [DExp]
args) = Maybe Name -> String
atloc Maybe Name
loc String -> ShowS
forall a. [a] -> [a] -> [a]
++ "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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep ", " ((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]
++ ")"
       where atloc :: Maybe Name -> String
atloc Nothing = ""
             atloc (Just l :: Name
l) = "@" 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]
++ ":"
     show' env :: [String]
env (DProj t :: DExp
t i :: Int
i) = DExp -> String
forall a. Show a => a -> String
show DExp
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ "!" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
     show' env :: [String]
env (DCase up :: CaseType
up e :: DExp
e alts :: [DAlt]
alts) = "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]
++ " of {\n\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                    String -> [String] -> String
showSep "\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
                           Shared -> " "
                           Updatable -> "! "
     show' env :: [String]
env (DChkCase e :: DExp
e alts :: [DAlt]
alts) = "case' " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ " of {\n\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                                    String -> [String] -> String
showSep "\n\t| " ((DAlt -> String) -> [DAlt] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DAlt -> String
showAlt [String]
env) [DAlt]
alts)
     show' env :: [String]
env (DConst c :: Const
c) = Const -> String
forall a. Show a => a -> String
show Const
c
     show' env :: [String]
env (DForeign ty :: FDesc
ty n :: FDesc
n args :: [(FDesc, DExp)]
args)
           = "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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep ", " ((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]
++ ")"
     show' env :: [String]
env (DOp f :: PrimFn
f args :: [DExp]
args) = PrimFn -> String
forall a. Show a => a -> String
show PrimFn
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ "(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep ", " ((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]
++ ")"
     show' env :: [String]
env (DError str :: String
str) = "error " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
str
     show' env :: [String]
env DNothing = "____"

     showAlt :: [String] -> DAlt -> String
showAlt env :: [String]
env (DConCase _ n :: Name
n args :: [Name]
args e :: DExp
e)
          = Name -> String
forall a. Show a => a -> String
show Name
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ "(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep ", " ((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 -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e
     showAlt env :: [String]
env (DConstCase c :: Const
c e :: DExp
e) = Const -> String
forall a. Show a => a -> String
show Const
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ " => " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e
     showAlt env :: [String]
env (DDefaultCase e :: DExp
e) = "_ => " 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 cn :: p
cn max :: Int
max arg :: DExp
arg branches :: [DAlt]
branches
   | [DAlt] -> 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 x :: Int
x [] = []
groupsOf x :: Int
x xs :: [DAlt]
xs = let (batch :: [DAlt]
batch, rest :: [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 i :: Int
i) _ : _) = Int
i
        tagHead (DConCase t :: Int
t _ _ _ : _) = Int
t
        tagHead (DDefaultCase _ : _) = -1 -- must be the end

        tagLT :: Int -> DAlt -> Bool
tagLT i :: Int
i (DConstCase (I j :: Int
j) _) = Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
j
        tagLT i :: Int
i (DConCase j :: Int
j _ _ _) = Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
j
        tagLT i :: Int
i (DDefaultCase _) = Bool
False

dumpDefuns :: DDefs -> String
dumpDefuns :: DDefs -> String
dumpDefuns ds :: DDefs
ds = String -> [String] -> String
showSep "\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 (x :: a
x, DFun fn :: Name
fn args :: [Name]
args exp :: DExp
exp)
            = Name -> String
forall a. Show a => a -> String
show Name
fn String -> ShowS
forall a. [a] -> [a] -> [a]
++ "(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep ", " ((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]
++ ") = \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]
++ "\n"
        showDef (x :: a
x, DConstructor n :: Name
n t :: Int
t a :: Int
a) = "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 -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
t