{-|
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
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
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
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
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
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 Int
nexttag LDefs
defs
     = let all :: [(Name, LDecl)]
all = 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)) = forall s a. State s a -> s -> (a, s)
runState (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LDefs
-> (Name, LDecl) -> State ([Name], [(Name, Int)]) (Name, DDecl)
addApps LDefs
defs) [(Name, LDecl)]
all) ([], [])
           anames' :: [(Name, Int)]
anames' = forall a. Ord a => [a] -> [a]
sort (forall a. Eq a => [a] -> [a]
nub [(Name, Int)]
anames)
           enames' :: [Name]
enames' = forall a. Eq a => [a] -> [a]
nub [Name]
enames
           newecons :: [(Name, Int, EvalApply DAlt)]
newecons = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a} {b} {c} {b} {c}.
Ord a =>
(a, b, c) -> (a, b, c) -> Ordering
conord forall a b. (a -> b) -> a -> b
$ 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 = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a} {b} {c} {b} {c}.
Ord a =>
(a, b, c) -> (a, b, c) -> Ordering
conord forall a b. (a -> b) -> a -> b
$ 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 forall a. [a] -> [a] -> [a]
++ [(Name, Int, EvalApply DAlt)]
newacons) in
           forall a. [(Name, a)] -> Ctxt a -> Ctxt a
addAlist ((Name, DDecl)
eval forall a. a -> [a] -> [a]
: (Name, DDecl)
app forall a. a -> [a] -> [a]
: (Name, DDecl)
app2 forall a. a -> [a] -> [a]
: [(Name, DDecl)]
condecls forall a. [a] -> [a] -> [a]
++ [(Name, DDecl)]
allD) 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
_) = 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 = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe 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
_) = forall a. a -> Maybe a
Just (a
n, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
args)
        fnData (a, LDecl)
_ = forall a. Maybe a
Nothing

addApps :: LDefs -> (Name, LDecl) -> State ([Name], [(Name, Int)]) (Name, DDecl)
addApps :: LDefs
-> (Name, LDecl) -> State ([Name], [(Name, Int)]) (Name, DDecl)
addApps LDefs
defs o :: (Name, LDecl)
o@(Name
n, LConstructor Name
_ Int
t Int
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
         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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
env = forall (m :: * -> *) a. Monad m => a -> m a
return 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' <- 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 forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n LDefs
defs of
                Just (LConstructor Name
_ Int
i Int
ar) -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
as in
                                               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 -> forall (m :: * -> *) a. Monad m => a -> m a
return 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' <- 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 forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n LDefs
defs of
                Just (LConstructor Name
_ Int
i Int
ar) -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
as in
                                           forall {m :: * -> *}.
MonadState ([Name], [(Name, Int)]) m =>
Name -> [DExp] -> Int -> m DExp
fixLazyApply Name
n [DExp]
args' Int
arity
                Maybe LDecl
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return 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) = 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) = 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 forall a. a -> [a] -> [a]
: [Name]
env) LExp
sc)
    aa [Name]
env (LCon Maybe Name
loc Int
i Name
n [LExp]
args) = 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) (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 [Name]
env (LProj t :: LExp
t@(LV Name
n) Int
i)
        | Name
n 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
                            forall (m :: * -> *) a. Monad m => a -> m a
return 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
                            forall (m :: * -> *) a. Monad m => a -> m a
return 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' <- 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
                                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CaseType -> DExp -> [DAlt] -> DExp
DCase CaseType
up DExp
e' [DAlt]
alts'
    aa [Name]
env (LConst Const
c) = forall (m :: * -> *) a. Monad m => a -> m a
return 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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a}.
[Name]
-> (a, LExp) -> StateT ([Name], [(Name, Int)]) Identity (a, DExp)
aaF [Name]
env) [(FDesc, LExp)]
args
             forall (m :: * -> *) a. Monad m => a -> m a
return 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) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PrimFn -> [DExp] -> DExp
DOp PrimFn
LFork) (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 [Name]
env (LOp PrimFn
f [LExp]
args) = do [DExp]
args' <- 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
                             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrimFn -> [DExp] -> DExp
DOp PrimFn
f [DExp]
args'
    aa [Name]
env LExp
LNothing = forall (m :: * -> *) a. Monad m => a -> m a
return DExp
DNothing
    aa [Name]
env (LError String
e) = forall (m :: * -> *) a. Monad m => a -> m a
return 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
                        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)
         = 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 forall a. [a] -> [a] -> [a]
++ [Name]
env) LExp
e)
    aaAlt [Name]
env (LConstCase Const
c LExp
e) = 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) = 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
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args forall a. Eq a => a -> a -> Bool
== Int
ar
             = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [DExp] -> DExp
DApp Bool
tc Name
n [DExp]
args
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args forall a. Ord a => a -> a -> Bool
< Int
ar
             = do (a
ens, [(Name, Int)]
ans) <- forall s (m :: * -> *). MonadState s m => m s
get
                  let alln :: [(Name, Int)]
alln = forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (Name
n, Int
x)) [forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args .. Int
ar]
                  forall s (m :: * -> *). MonadState s m => s -> m ()
put (a
ens, [(Name, Int)]
alln forall a. [a] -> [a] -> [a]
++ [(Name, Int)]
ans)
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [DExp] -> DExp
DApp Bool
tc (Name -> Int -> Name
mkUnderCon Name
n (Int
ar forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args)) [DExp]
args
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args forall a. Ord a => a -> a -> Bool
> Int
ar
             = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DExp -> [DExp] -> DExp
chainAPPLY (Bool -> Name -> [DExp] -> DExp
DApp Bool
tc Name
n (forall a. Int -> [a] -> [a]
take Int
ar [DExp]
args)) (forall a. Int -> [a] -> [a]
drop Int
ar [DExp]
args)

    fixLazyApply :: Name -> [DExp] -> Int -> m DExp
fixLazyApply Name
n [DExp]
args Int
ar
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args forall a. Eq a => a -> a -> Bool
== Int
ar
             = do ([Name]
ens, [(Name, Int)]
ans) <- forall s (m :: * -> *). MonadState s m => m s
get
                  forall s (m :: * -> *). MonadState s m => s -> m ()
put (Name
n forall a. a -> [a] -> [a]
: [Name]
ens, [(Name, Int)]
ans)
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [DExp] -> DExp
DApp Bool
False (forall {a}. Show a => a -> Name
mkFnCon Name
n) [DExp]
args
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args forall a. Ord a => a -> a -> Bool
< Int
ar
             = do ([Name]
ens, [(Name, Int)]
ans) <- forall s (m :: * -> *). MonadState s m => m s
get
                  let alln :: [(Name, Int)]
alln = forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (Name
n, Int
x)) [forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args .. Int
ar]
                  forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Name]
ens, [(Name, Int)]
alln forall a. [a] -> [a] -> [a]
++ [(Name, Int)]
ans)
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [DExp] -> DExp
DApp Bool
False (Name -> Int -> Name
mkUnderCon Name
n (Int
ar forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args)) [DExp]
args
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
args forall a. Ord a => a -> a -> Bool
> Int
ar
             = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DExp -> [DExp] -> DExp
chainAPPLY (Bool -> Name -> [DExp] -> DExp
DApp Bool
False Name
n (forall a. Int -> [a] -> [a]
take Int
ar [DExp]
args)) (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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
ns
      = (forall {a}. Show a => a -> Name
mkFnCon Name
n, Int
i,
          forall a. (Name -> a) -> EvalApply a
EvalCase (\Name
tlarg ->
            (Int -> Name -> [Name] -> DExp -> DAlt
DConCase (-Int
1) (forall {a}. Show a => a -> Name
mkFnCon Name
n) (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 (forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DV (forall a. Int -> [a] -> [a]
take Int
i (Int -> [Name]
genArgs Int
0))))))))
          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 <- 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 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 forall a. Num a => a -> a -> a
- Int
n) in
              (Name
nm, Int
n, forall a. a -> EvalApply a
ApplyCase (Int -> Name -> [Name] -> DExp -> DAlt
DConCase (-Int
1) Name
nm (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 forall a. Num a => a -> a -> a
- (Int
n forall a. Num a => a -> a -> a
+ Int
1)))
                       (forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DV (forall a. Int -> [a] -> [a]
take Int
n (Int -> [Name]
genArgs Int
0) forall a. [a] -> [a] -> [a]
++
                         [Int -> String -> Name
sMN Int
0 String
"arg"])))))
                            forall a. a -> [a] -> [a]
:
              if (Int
ar forall a. Num a => a -> a -> a
- (Int
n forall a. Num a => a -> a -> a
+ Int
2) forall a. Ord a => a -> a -> Bool
>=Int
0 )
                 then (Name
nm, Int
n, forall a. a -> EvalApply a
Apply2Case (Int -> Name -> [Name] -> DExp -> DAlt
DConCase (-Int
1) Name
nm (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 forall a. Num a => a -> a -> a
- (Int
n forall a. Num a => a -> a -> a
+ Int
2)))
                       (forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DV (forall a. Int -> [a] -> [a]
take Int
n (Int -> [Name]
genArgs Int
0) forall a. [a] -> [a] -> [a]
++
                         [Int -> String -> Name
sMN Int
0 String
"arg0", Int -> String -> Name
sMN Int
0 String
"arg1"])))))
                            forall a. a -> [a] -> [a]
:
                            Name -> Int -> Int -> [(Name, Int, EvalApply DAlt)]
mkApplyCase Name
fname (Int
n forall a. Num a => a -> a -> a
+ Int
1) Int
ar
                 else Name -> Int -> Int -> [(Name, Int, EvalApply DAlt)]
mkApplyCase Name
fname (Int
n 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"]
               (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"))
                  (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {b} {a}. (a, b, EvalApply a) -> Maybe a
evalCase [(Name, Int, EvalApply DAlt)]
xs 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) = forall a. a -> Maybe a
Just (Name -> a
x (Int -> String -> Name
sMN Int
0 String
"arg"))
    evalCase (a, b, EvalApply 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 forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {b} {a}. (a, b, EvalApply a) -> Maybe a
applyCase [(Name, Int, EvalApply DAlt)]
xs of
                                [] -> DExp
DNothing
                                [DAlt]
cases ->
                                    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 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) = forall a. a -> Maybe a
Just a
x
    applyCase (a, b, EvalApply 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 forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {b} {a}. (a, b, EvalApply a) -> Maybe a
applyCase [(Name, Int, EvalApply DAlt)]
xs of
                                [] -> DExp
DNothing
                                [DAlt]
cases ->
                                    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 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) = forall a. a -> Maybe a
Just a
x
    applyCase (a, b, EvalApply 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 = 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 = 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 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) forall a. a -> [a] -> [a]
: [(Name, DDecl)]
acc)


genArgs :: Int -> [Name]
genArgs Int
i = Int -> String -> Name
sMN Int
i String
"P_c" forall a. a -> [a] -> [a]
: Int -> [Name]
genArgs (Int
i forall a. Num a => a -> a -> a
+ Int
1)

mkFnCon :: a -> Name
mkFnCon    a
n = Int -> String -> Name
sMN Int
0 (String
"P_" forall a. [a] -> [a] -> [a]
++ 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_" forall a. [a] -> [a] -> [a]
++ 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) = forall a. Show a => a -> String
show Name
n
     show' [String]
env (DApp Bool
_ Name
e [DExp]
args) = forall a. Show a => a -> String
show Name
e forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++
                                   String -> [String] -> String
showSep String
", " (forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DExp -> String
show' [String]
env) [DExp]
args) forall a. [a] -> [a] -> [a]
++String
")"
     show' [String]
env (DLet Name
n DExp
v DExp
e) = String
"let " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
v forall a. [a] -> [a] -> [a]
++ String
" in " forall a. [a] -> [a] -> [a]
++
                               [String] -> DExp -> String
show' ([String]
env forall a. [a] -> [a] -> [a]
++ [forall a. Show a => a -> String
show Name
n]) DExp
e
     show' [String]
env (DUpdate Name
n DExp
e) = String
"!update " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e 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 forall a. [a] -> [a] -> [a]
++ String
"CON " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
", " (forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DExp -> String
show' [String]
env) [DExp]
args) forall a. [a] -> [a] -> [a]
++ String
")"
       where atloc :: Maybe Name -> String
atloc Maybe Name
Nothing = String
""
             atloc (Just Name
l) = String
"@" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Name -> LExp
LV Name
l) forall a. [a] -> [a] -> [a]
++ String
":"
     show' [String]
env (DProj DExp
t Int
i) = forall a. Show a => a -> String
show DExp
t forall a. [a] -> [a] -> [a]
++ String
"!" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i
     show' [String]
env (DCase CaseType
up DExp
e [DAlt]
alts) = String
"case" forall a. [a] -> [a] -> [a]
++ String
update forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e forall a. [a] -> [a] -> [a]
++ String
" of {\n\t" forall a. [a] -> [a] -> [a]
++
                                    String -> [String] -> String
showSep String
"\n\t| " (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' " forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e forall a. [a] -> [a] -> [a]
++ String
" of {\n\t" forall a. [a] -> [a] -> [a]
++
                                    String -> [String] -> String
showSep String
"\n\t| " (forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DAlt -> String
showAlt [String]
env) [DAlt]
alts)
     show' [String]
env (DConst Const
c) = forall a. Show a => a -> String
show Const
c
     show' [String]
env (DForeign FDesc
ty FDesc
n [(FDesc, DExp)]
args)
           = String
"foreign " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FDesc
n forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
", " (forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DExp -> String
show' [String]
env) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(FDesc, DExp)]
args)) forall a. [a] -> [a] -> [a]
++ String
")"
     show' [String]
env (DOp PrimFn
f [DExp]
args) = forall a. Show a => a -> String
show PrimFn
f forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
", " (forall a b. (a -> b) -> [a] -> [b]
map ([String] -> DExp -> String
show' [String]
env) [DExp]
args) forall a. [a] -> [a] -> [a]
++ String
")"
     show' [String]
env (DError String
str) = String
"error " forall a. [a] -> [a] -> [a]
++ 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)
          = forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Name]
args) forall a. [a] -> [a] -> [a]
++ String
") => "
             forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e
     showAlt [String]
env (DConstCase Const
c DExp
e) = forall a. Show a => a -> String
show Const
c forall a. [a] -> [a] -> [a]
++ String
" => " forall a. [a] -> [a] -> [a]
++ [String] -> DExp -> String
show' [String]
env DExp
e
     showAlt [String]
env (DDefaultCase DExp
e) = String
"_ => " 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
   | forall (t :: * -> *) a. Foldable t => t a -> Int
length [DAlt]
branches 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Int -> DAlt -> Bool
tagLT (Int
x forall a. Num a => a -> a -> a
+ [DAlt] -> Int
tagHead [DAlt]
xs)) [DAlt]
xs in
                    [DAlt]
batch 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 forall a. Ord a => a -> a -> Bool
< Int
j
        tagLT Int
i (DConCase Int
j Name
_ [Name]
_ DExp
_) = Int
i 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" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (a, DDecl) -> String
showDef (forall a. Ctxt a -> [(Name, a)]
toAlist DDefs
ds)
  where showDef :: (a, DDecl) -> String
showDef (a
x, DFun Name
fn [Name]
args DExp
exp)
            = forall a. Show a => a -> String
show Name
fn forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Name]
args) forall a. [a] -> [a] -> [a]
++ String
") = \n\t" forall a. [a] -> [a] -> [a]
++
              forall a. Show a => a -> String
show DExp
exp forall a. [a] -> [a] -> [a]
++ String
"\n"
        showDef (a
x, DConstructor Name
n Int
t Int
a) = String
"Constructor " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
t