{-|
Module      : IRTS.Lang
Description : Internal representation of Idris' constructs.

License     : BSD3
Maintainer  : The Idris Community.
-}
{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric, FlexibleContexts,
             PatternGuards #-}

module IRTS.Lang where

import Idris.Core.CaseTree
import Idris.Core.TT

import Control.Monad.State hiding (lift)
import Data.Data (Data)
import Data.List
import qualified Data.Map.Strict as Map
import Data.Typeable (Typeable)
import GHC.Generics (Generic)

data Endianness = Native | BE | LE deriving (Int -> Endianness -> ShowS
[Endianness] -> ShowS
Endianness -> String
(Int -> Endianness -> ShowS)
-> (Endianness -> String)
-> ([Endianness] -> ShowS)
-> Show Endianness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Endianness -> ShowS
showsPrec :: Int -> Endianness -> ShowS
$cshow :: Endianness -> String
show :: Endianness -> String
$cshowList :: [Endianness] -> ShowS
showList :: [Endianness] -> ShowS
Show, Endianness -> Endianness -> Bool
(Endianness -> Endianness -> Bool)
-> (Endianness -> Endianness -> Bool) -> Eq Endianness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Endianness -> Endianness -> Bool
== :: Endianness -> Endianness -> Bool
$c/= :: Endianness -> Endianness -> Bool
/= :: Endianness -> Endianness -> Bool
Eq)

data LVar = Loc Int | Glob Name
  deriving (Int -> LVar -> ShowS
[LVar] -> ShowS
LVar -> String
(Int -> LVar -> ShowS)
-> (LVar -> String) -> ([LVar] -> ShowS) -> Show LVar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LVar -> ShowS
showsPrec :: Int -> LVar -> ShowS
$cshow :: LVar -> String
show :: LVar -> String
$cshowList :: [LVar] -> ShowS
showList :: [LVar] -> ShowS
Show, LVar -> LVar -> Bool
(LVar -> LVar -> Bool) -> (LVar -> LVar -> Bool) -> Eq LVar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LVar -> LVar -> Bool
== :: LVar -> LVar -> Bool
$c/= :: LVar -> LVar -> Bool
/= :: LVar -> LVar -> Bool
Eq)

-- ASSUMPTION: All variable bindings have unique names here
-- Constructors commented as lifted are not present in the LIR provided to the different backends.
data LExp = LV Name
          | LApp Bool LExp [LExp]    -- True = tail call
          | LLazyApp Name [LExp]     -- True = tail call
          | LLazyExp LExp            -- lifted out before compiling
          | LForce LExp              -- make sure Exp is evaluted
          | LLet Name LExp LExp      -- name just for pretty printing
          | LLam [Name] LExp         -- lambda, lifted out before compiling
          | LProj LExp Int           -- projection
          | LCon (Maybe Name)        -- Location to reallocate, if available
                 Int Name [LExp]
          | LCase CaseType LExp [LAlt]
          | LConst Const
          | LForeign FDesc           -- Function descriptor (usually name as string)
                     FDesc           -- Return type descriptor
                     [(FDesc, LExp)] -- first LExp is the FFI type description
          | LOp PrimFn [LExp]
          | LNothing
          | LError String
  deriving (LExp -> LExp -> Bool
(LExp -> LExp -> Bool) -> (LExp -> LExp -> Bool) -> Eq LExp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LExp -> LExp -> Bool
== :: LExp -> LExp -> Bool
$c/= :: LExp -> LExp -> Bool
/= :: LExp -> LExp -> Bool
Eq, Eq LExp
Eq LExp =>
(LExp -> LExp -> Ordering)
-> (LExp -> LExp -> Bool)
-> (LExp -> LExp -> Bool)
-> (LExp -> LExp -> Bool)
-> (LExp -> LExp -> Bool)
-> (LExp -> LExp -> LExp)
-> (LExp -> LExp -> LExp)
-> Ord LExp
LExp -> LExp -> Bool
LExp -> LExp -> Ordering
LExp -> LExp -> LExp
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LExp -> LExp -> Ordering
compare :: LExp -> LExp -> Ordering
$c< :: LExp -> LExp -> Bool
< :: LExp -> LExp -> Bool
$c<= :: LExp -> LExp -> Bool
<= :: LExp -> LExp -> Bool
$c> :: LExp -> LExp -> Bool
> :: LExp -> LExp -> Bool
$c>= :: LExp -> LExp -> Bool
>= :: LExp -> LExp -> Bool
$cmax :: LExp -> LExp -> LExp
max :: LExp -> LExp -> LExp
$cmin :: LExp -> LExp -> LExp
min :: LExp -> LExp -> LExp
Ord)

data FDesc = FCon Name
           | FStr String
           | FUnknown
           | FIO FDesc
           | FApp Name [FDesc]
  deriving (Int -> FDesc -> ShowS
[FDesc] -> ShowS
FDesc -> String
(Int -> FDesc -> ShowS)
-> (FDesc -> String) -> ([FDesc] -> ShowS) -> Show FDesc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FDesc -> ShowS
showsPrec :: Int -> FDesc -> ShowS
$cshow :: FDesc -> String
show :: FDesc -> String
$cshowList :: [FDesc] -> ShowS
showList :: [FDesc] -> ShowS
Show, FDesc -> FDesc -> Bool
(FDesc -> FDesc -> Bool) -> (FDesc -> FDesc -> Bool) -> Eq FDesc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FDesc -> FDesc -> Bool
== :: FDesc -> FDesc -> Bool
$c/= :: FDesc -> FDesc -> Bool
/= :: FDesc -> FDesc -> Bool
Eq, Eq FDesc
Eq FDesc =>
(FDesc -> FDesc -> Ordering)
-> (FDesc -> FDesc -> Bool)
-> (FDesc -> FDesc -> Bool)
-> (FDesc -> FDesc -> Bool)
-> (FDesc -> FDesc -> Bool)
-> (FDesc -> FDesc -> FDesc)
-> (FDesc -> FDesc -> FDesc)
-> Ord FDesc
FDesc -> FDesc -> Bool
FDesc -> FDesc -> Ordering
FDesc -> FDesc -> FDesc
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FDesc -> FDesc -> Ordering
compare :: FDesc -> FDesc -> Ordering
$c< :: FDesc -> FDesc -> Bool
< :: FDesc -> FDesc -> Bool
$c<= :: FDesc -> FDesc -> Bool
<= :: FDesc -> FDesc -> Bool
$c> :: FDesc -> FDesc -> Bool
> :: FDesc -> FDesc -> Bool
$c>= :: FDesc -> FDesc -> Bool
>= :: FDesc -> FDesc -> Bool
$cmax :: FDesc -> FDesc -> FDesc
max :: FDesc -> FDesc -> FDesc
$cmin :: FDesc -> FDesc -> FDesc
min :: FDesc -> FDesc -> FDesc
Ord)

data Export = ExportData FDesc -- Exported data descriptor (usually string)
            | ExportFun Name -- Idris name
                        FDesc -- Exported function descriptor
                        FDesc -- Return type descriptor
                        [FDesc] -- Argument types
  deriving (Int -> Export -> ShowS
[Export] -> ShowS
Export -> String
(Int -> Export -> ShowS)
-> (Export -> String) -> ([Export] -> ShowS) -> Show Export
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Export -> ShowS
showsPrec :: Int -> Export -> ShowS
$cshow :: Export -> String
show :: Export -> String
$cshowList :: [Export] -> ShowS
showList :: [Export] -> ShowS
Show, Export -> Export -> Bool
(Export -> Export -> Bool)
-> (Export -> Export -> Bool) -> Eq Export
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Export -> Export -> Bool
== :: Export -> Export -> Bool
$c/= :: Export -> Export -> Bool
/= :: Export -> Export -> Bool
Eq, Eq Export
Eq Export =>
(Export -> Export -> Ordering)
-> (Export -> Export -> Bool)
-> (Export -> Export -> Bool)
-> (Export -> Export -> Bool)
-> (Export -> Export -> Bool)
-> (Export -> Export -> Export)
-> (Export -> Export -> Export)
-> Ord Export
Export -> Export -> Bool
Export -> Export -> Ordering
Export -> Export -> Export
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Export -> Export -> Ordering
compare :: Export -> Export -> Ordering
$c< :: Export -> Export -> Bool
< :: Export -> Export -> Bool
$c<= :: Export -> Export -> Bool
<= :: Export -> Export -> Bool
$c> :: Export -> Export -> Bool
> :: Export -> Export -> Bool
$c>= :: Export -> Export -> Bool
>= :: Export -> Export -> Bool
$cmax :: Export -> Export -> Export
max :: Export -> Export -> Export
$cmin :: Export -> Export -> Export
min :: Export -> Export -> Export
Ord)

data ExportIFace = Export Name -- FFI descriptor
                          String -- interface file
                          [Export]
  deriving (Int -> ExportIFace -> ShowS
[ExportIFace] -> ShowS
ExportIFace -> String
(Int -> ExportIFace -> ShowS)
-> (ExportIFace -> String)
-> ([ExportIFace] -> ShowS)
-> Show ExportIFace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExportIFace -> ShowS
showsPrec :: Int -> ExportIFace -> ShowS
$cshow :: ExportIFace -> String
show :: ExportIFace -> String
$cshowList :: [ExportIFace] -> ShowS
showList :: [ExportIFace] -> ShowS
Show, ExportIFace -> ExportIFace -> Bool
(ExportIFace -> ExportIFace -> Bool)
-> (ExportIFace -> ExportIFace -> Bool) -> Eq ExportIFace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExportIFace -> ExportIFace -> Bool
== :: ExportIFace -> ExportIFace -> Bool
$c/= :: ExportIFace -> ExportIFace -> Bool
/= :: ExportIFace -> ExportIFace -> Bool
Eq, Eq ExportIFace
Eq ExportIFace =>
(ExportIFace -> ExportIFace -> Ordering)
-> (ExportIFace -> ExportIFace -> Bool)
-> (ExportIFace -> ExportIFace -> Bool)
-> (ExportIFace -> ExportIFace -> Bool)
-> (ExportIFace -> ExportIFace -> Bool)
-> (ExportIFace -> ExportIFace -> ExportIFace)
-> (ExportIFace -> ExportIFace -> ExportIFace)
-> Ord ExportIFace
ExportIFace -> ExportIFace -> Bool
ExportIFace -> ExportIFace -> Ordering
ExportIFace -> ExportIFace -> ExportIFace
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ExportIFace -> ExportIFace -> Ordering
compare :: ExportIFace -> ExportIFace -> Ordering
$c< :: ExportIFace -> ExportIFace -> Bool
< :: ExportIFace -> ExportIFace -> Bool
$c<= :: ExportIFace -> ExportIFace -> Bool
<= :: ExportIFace -> ExportIFace -> Bool
$c> :: ExportIFace -> ExportIFace -> Bool
> :: ExportIFace -> ExportIFace -> Bool
$c>= :: ExportIFace -> ExportIFace -> Bool
>= :: ExportIFace -> ExportIFace -> Bool
$cmax :: ExportIFace -> ExportIFace -> ExportIFace
max :: ExportIFace -> ExportIFace -> ExportIFace
$cmin :: ExportIFace -> ExportIFace -> ExportIFace
min :: ExportIFace -> ExportIFace -> ExportIFace
Ord)

-- Primitive operators. Backends are not *required* to implement all
-- of these, but should report an error if they are unable

data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy
            | LUDiv IntTy | LSDiv ArithTy | LURem IntTy | LSRem ArithTy
            | LAnd IntTy | LOr IntTy | LXOr IntTy | LCompl IntTy
            | LSHL IntTy | LLSHR IntTy | LASHR IntTy
            | LEq ArithTy | LLt IntTy | LLe IntTy | LGt IntTy | LGe IntTy
            | LSLt ArithTy | LSLe ArithTy | LSGt ArithTy | LSGe ArithTy
            | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy
            | LStrConcat | LStrLt | LStrEq | LStrLen
            | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy
            | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy
            | LBitCast ArithTy ArithTy -- Only for values of equal width

            | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan
            | LFATan2 | LFSqrt | LFFloor | LFCeil | LFNegate

            | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev | LStrSubstr
            | LReadStr | LWriteStr

            -- system info
            | LSystemInfo

            | LFork
            | LPar -- evaluate argument anywhere, possibly on another
                   -- core or another machine. 'id' is a valid implementation
            | LExternal Name
            | LCrash

            | LNoOp
  deriving (Int -> PrimFn -> ShowS
[PrimFn] -> ShowS
PrimFn -> String
(Int -> PrimFn -> ShowS)
-> (PrimFn -> String) -> ([PrimFn] -> ShowS) -> Show PrimFn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrimFn -> ShowS
showsPrec :: Int -> PrimFn -> ShowS
$cshow :: PrimFn -> String
show :: PrimFn -> String
$cshowList :: [PrimFn] -> ShowS
showList :: [PrimFn] -> ShowS
Show, PrimFn -> PrimFn -> Bool
(PrimFn -> PrimFn -> Bool)
-> (PrimFn -> PrimFn -> Bool) -> Eq PrimFn
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PrimFn -> PrimFn -> Bool
== :: PrimFn -> PrimFn -> Bool
$c/= :: PrimFn -> PrimFn -> Bool
/= :: PrimFn -> PrimFn -> Bool
Eq, Eq PrimFn
Eq PrimFn =>
(PrimFn -> PrimFn -> Ordering)
-> (PrimFn -> PrimFn -> Bool)
-> (PrimFn -> PrimFn -> Bool)
-> (PrimFn -> PrimFn -> Bool)
-> (PrimFn -> PrimFn -> Bool)
-> (PrimFn -> PrimFn -> PrimFn)
-> (PrimFn -> PrimFn -> PrimFn)
-> Ord PrimFn
PrimFn -> PrimFn -> Bool
PrimFn -> PrimFn -> Ordering
PrimFn -> PrimFn -> PrimFn
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PrimFn -> PrimFn -> Ordering
compare :: PrimFn -> PrimFn -> Ordering
$c< :: PrimFn -> PrimFn -> Bool
< :: PrimFn -> PrimFn -> Bool
$c<= :: PrimFn -> PrimFn -> Bool
<= :: PrimFn -> PrimFn -> Bool
$c> :: PrimFn -> PrimFn -> Bool
> :: PrimFn -> PrimFn -> Bool
$c>= :: PrimFn -> PrimFn -> Bool
>= :: PrimFn -> PrimFn -> Bool
$cmax :: PrimFn -> PrimFn -> PrimFn
max :: PrimFn -> PrimFn -> PrimFn
$cmin :: PrimFn -> PrimFn -> PrimFn
min :: PrimFn -> PrimFn -> PrimFn
Ord, (forall x. PrimFn -> Rep PrimFn x)
-> (forall x. Rep PrimFn x -> PrimFn) -> Generic PrimFn
forall x. Rep PrimFn x -> PrimFn
forall x. PrimFn -> Rep PrimFn x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PrimFn -> Rep PrimFn x
from :: forall x. PrimFn -> Rep PrimFn x
$cto :: forall x. Rep PrimFn x -> PrimFn
to :: forall x. Rep PrimFn x -> PrimFn
Generic)

-- Supported target languages for foreign calls

data FCallType = FStatic | FObject | FConstructor
  deriving (Int -> FCallType -> ShowS
[FCallType] -> ShowS
FCallType -> String
(Int -> FCallType -> ShowS)
-> (FCallType -> String)
-> ([FCallType] -> ShowS)
-> Show FCallType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FCallType -> ShowS
showsPrec :: Int -> FCallType -> ShowS
$cshow :: FCallType -> String
show :: FCallType -> String
$cshowList :: [FCallType] -> ShowS
showList :: [FCallType] -> ShowS
Show, FCallType -> FCallType -> Bool
(FCallType -> FCallType -> Bool)
-> (FCallType -> FCallType -> Bool) -> Eq FCallType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FCallType -> FCallType -> Bool
== :: FCallType -> FCallType -> Bool
$c/= :: FCallType -> FCallType -> Bool
/= :: FCallType -> FCallType -> Bool
Eq, Eq FCallType
Eq FCallType =>
(FCallType -> FCallType -> Ordering)
-> (FCallType -> FCallType -> Bool)
-> (FCallType -> FCallType -> Bool)
-> (FCallType -> FCallType -> Bool)
-> (FCallType -> FCallType -> Bool)
-> (FCallType -> FCallType -> FCallType)
-> (FCallType -> FCallType -> FCallType)
-> Ord FCallType
FCallType -> FCallType -> Bool
FCallType -> FCallType -> Ordering
FCallType -> FCallType -> FCallType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FCallType -> FCallType -> Ordering
compare :: FCallType -> FCallType -> Ordering
$c< :: FCallType -> FCallType -> Bool
< :: FCallType -> FCallType -> Bool
$c<= :: FCallType -> FCallType -> Bool
<= :: FCallType -> FCallType -> Bool
$c> :: FCallType -> FCallType -> Bool
> :: FCallType -> FCallType -> Bool
$c>= :: FCallType -> FCallType -> Bool
>= :: FCallType -> FCallType -> Bool
$cmax :: FCallType -> FCallType -> FCallType
max :: FCallType -> FCallType -> FCallType
$cmin :: FCallType -> FCallType -> FCallType
min :: FCallType -> FCallType -> FCallType
Ord)

data FType = FArith ArithTy
           | FFunction
           | FFunctionIO
           | FString
           | FUnit
           | FPtr
           | FManagedPtr
           | FCData
           | FAny
  deriving (Int -> FType -> ShowS
[FType] -> ShowS
FType -> String
(Int -> FType -> ShowS)
-> (FType -> String) -> ([FType] -> ShowS) -> Show FType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FType -> ShowS
showsPrec :: Int -> FType -> ShowS
$cshow :: FType -> String
show :: FType -> String
$cshowList :: [FType] -> ShowS
showList :: [FType] -> ShowS
Show, FType -> FType -> Bool
(FType -> FType -> Bool) -> (FType -> FType -> Bool) -> Eq FType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FType -> FType -> Bool
== :: FType -> FType -> Bool
$c/= :: FType -> FType -> Bool
/= :: FType -> FType -> Bool
Eq, Eq FType
Eq FType =>
(FType -> FType -> Ordering)
-> (FType -> FType -> Bool)
-> (FType -> FType -> Bool)
-> (FType -> FType -> Bool)
-> (FType -> FType -> Bool)
-> (FType -> FType -> FType)
-> (FType -> FType -> FType)
-> Ord FType
FType -> FType -> Bool
FType -> FType -> Ordering
FType -> FType -> FType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FType -> FType -> Ordering
compare :: FType -> FType -> Ordering
$c< :: FType -> FType -> Bool
< :: FType -> FType -> Bool
$c<= :: FType -> FType -> Bool
<= :: FType -> FType -> Bool
$c> :: FType -> FType -> Bool
> :: FType -> FType -> Bool
$c>= :: FType -> FType -> Bool
>= :: FType -> FType -> Bool
$cmax :: FType -> FType -> FType
max :: FType -> FType -> FType
$cmin :: FType -> FType -> FType
min :: FType -> FType -> FType
Ord)

-- FIXME: Why not use this for all the IRs now?
data LAlt' e = LConCase Int Name [Name] e
             | LConstCase Const e
             | LDefaultCase e
  deriving (Int -> LAlt' e -> ShowS
[LAlt' e] -> ShowS
LAlt' e -> String
(Int -> LAlt' e -> ShowS)
-> (LAlt' e -> String) -> ([LAlt' e] -> ShowS) -> Show (LAlt' e)
forall e. Show e => Int -> LAlt' e -> ShowS
forall e. Show e => [LAlt' e] -> ShowS
forall e. Show e => LAlt' e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> LAlt' e -> ShowS
showsPrec :: Int -> LAlt' e -> ShowS
$cshow :: forall e. Show e => LAlt' e -> String
show :: LAlt' e -> String
$cshowList :: forall e. Show e => [LAlt' e] -> ShowS
showList :: [LAlt' e] -> ShowS
Show, LAlt' e -> LAlt' e -> Bool
(LAlt' e -> LAlt' e -> Bool)
-> (LAlt' e -> LAlt' e -> Bool) -> Eq (LAlt' e)
forall e. Eq e => LAlt' e -> LAlt' e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall e. Eq e => LAlt' e -> LAlt' e -> Bool
== :: LAlt' e -> LAlt' e -> Bool
$c/= :: forall e. Eq e => LAlt' e -> LAlt' e -> Bool
/= :: LAlt' e -> LAlt' e -> Bool
Eq, Eq (LAlt' e)
Eq (LAlt' e) =>
(LAlt' e -> LAlt' e -> Ordering)
-> (LAlt' e -> LAlt' e -> Bool)
-> (LAlt' e -> LAlt' e -> Bool)
-> (LAlt' e -> LAlt' e -> Bool)
-> (LAlt' e -> LAlt' e -> Bool)
-> (LAlt' e -> LAlt' e -> LAlt' e)
-> (LAlt' e -> LAlt' e -> LAlt' e)
-> Ord (LAlt' e)
LAlt' e -> LAlt' e -> Bool
LAlt' e -> LAlt' e -> Ordering
LAlt' e -> LAlt' e -> LAlt' e
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall e. Ord e => Eq (LAlt' e)
forall e. Ord e => LAlt' e -> LAlt' e -> Bool
forall e. Ord e => LAlt' e -> LAlt' e -> Ordering
forall e. Ord e => LAlt' e -> LAlt' e -> LAlt' e
$ccompare :: forall e. Ord e => LAlt' e -> LAlt' e -> Ordering
compare :: LAlt' e -> LAlt' e -> Ordering
$c< :: forall e. Ord e => LAlt' e -> LAlt' e -> Bool
< :: LAlt' e -> LAlt' e -> Bool
$c<= :: forall e. Ord e => LAlt' e -> LAlt' e -> Bool
<= :: LAlt' e -> LAlt' e -> Bool
$c> :: forall e. Ord e => LAlt' e -> LAlt' e -> Bool
> :: LAlt' e -> LAlt' e -> Bool
$c>= :: forall e. Ord e => LAlt' e -> LAlt' e -> Bool
>= :: LAlt' e -> LAlt' e -> Bool
$cmax :: forall e. Ord e => LAlt' e -> LAlt' e -> LAlt' e
max :: LAlt' e -> LAlt' e -> LAlt' e
$cmin :: forall e. Ord e => LAlt' e -> LAlt' e -> LAlt' e
min :: LAlt' e -> LAlt' e -> LAlt' e
Ord, (forall a b. (a -> b) -> LAlt' a -> LAlt' b)
-> (forall a b. a -> LAlt' b -> LAlt' a) -> Functor LAlt'
forall a b. a -> LAlt' b -> LAlt' a
forall a b. (a -> b) -> LAlt' a -> LAlt' b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LAlt' a -> LAlt' b
fmap :: forall a b. (a -> b) -> LAlt' a -> LAlt' b
$c<$ :: forall a b. a -> LAlt' b -> LAlt' a
<$ :: forall a b. a -> LAlt' b -> LAlt' a
Functor, Typeable (LAlt' e)
Typeable (LAlt' e) =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> LAlt' e -> c (LAlt' e))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (LAlt' e))
-> (LAlt' e -> Constr)
-> (LAlt' e -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (LAlt' e)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (LAlt' e)))
-> ((forall b. Data b => b -> b) -> LAlt' e -> LAlt' e)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> LAlt' e -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> LAlt' e -> r)
-> (forall u. (forall d. Data d => d -> u) -> LAlt' e -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> LAlt' e -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e))
-> Data (LAlt' e)
LAlt' e -> Constr
LAlt' e -> DataType
(forall b. Data b => b -> b) -> LAlt' e -> LAlt' e
forall e. Data e => Typeable (LAlt' e)
forall e. Data e => LAlt' e -> Constr
forall e. Data e => LAlt' e -> DataType
forall e.
Data e =>
(forall b. Data b => b -> b) -> LAlt' e -> LAlt' e
forall e u.
Data e =>
Int -> (forall d. Data d => d -> u) -> LAlt' e -> u
forall e u.
Data e =>
(forall d. Data d => d -> u) -> LAlt' e -> [u]
forall e r r'.
Data e =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LAlt' e -> r
forall e r r'.
Data e =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LAlt' e -> r
forall e (m :: * -> *).
(Data e, Monad m) =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
forall e (m :: * -> *).
(Data e, MonadPlus m) =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
forall e (c :: * -> *).
Data e =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (LAlt' e)
forall e (c :: * -> *).
Data e =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LAlt' e -> c (LAlt' e)
forall e (t :: * -> *) (c :: * -> *).
(Data e, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (LAlt' e))
forall e (t :: * -> * -> *) (c :: * -> *).
(Data e, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (LAlt' e))
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> LAlt' e -> u
forall u. (forall d. Data d => d -> u) -> LAlt' e -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LAlt' e -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LAlt' e -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (LAlt' e)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LAlt' e -> c (LAlt' e)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (LAlt' e))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (LAlt' e))
$cgfoldl :: forall e (c :: * -> *).
Data e =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LAlt' e -> c (LAlt' e)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LAlt' e -> c (LAlt' e)
$cgunfold :: forall e (c :: * -> *).
Data e =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (LAlt' e)
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (LAlt' e)
$ctoConstr :: forall e. Data e => LAlt' e -> Constr
toConstr :: LAlt' e -> Constr
$cdataTypeOf :: forall e. Data e => LAlt' e -> DataType
dataTypeOf :: LAlt' e -> DataType
$cdataCast1 :: forall e (t :: * -> *) (c :: * -> *).
(Data e, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (LAlt' e))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (LAlt' e))
$cdataCast2 :: forall e (t :: * -> * -> *) (c :: * -> *).
(Data e, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (LAlt' e))
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (LAlt' e))
$cgmapT :: forall e.
Data e =>
(forall b. Data b => b -> b) -> LAlt' e -> LAlt' e
gmapT :: (forall b. Data b => b -> b) -> LAlt' e -> LAlt' e
$cgmapQl :: forall e r r'.
Data e =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LAlt' e -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LAlt' e -> r
$cgmapQr :: forall e r r'.
Data e =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LAlt' e -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LAlt' e -> r
$cgmapQ :: forall e u.
Data e =>
(forall d. Data d => d -> u) -> LAlt' e -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> LAlt' e -> [u]
$cgmapQi :: forall e u.
Data e =>
Int -> (forall d. Data d => d -> u) -> LAlt' e -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> LAlt' e -> u
$cgmapM :: forall e (m :: * -> *).
(Data e, Monad m) =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
$cgmapMp :: forall e (m :: * -> *).
(Data e, MonadPlus m) =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
$cgmapMo :: forall e (m :: * -> *).
(Data e, MonadPlus m) =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
Data, Typeable)

type LAlt = LAlt' LExp

data LDecl = LFun [LOpt] Name [Name] LExp -- options, name, arg names, def
           | LConstructor Name Int Int -- constructor name, tag, arity
  deriving (Int -> LDecl -> ShowS
[LDecl] -> ShowS
LDecl -> String
(Int -> LDecl -> ShowS)
-> (LDecl -> String) -> ([LDecl] -> ShowS) -> Show LDecl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LDecl -> ShowS
showsPrec :: Int -> LDecl -> ShowS
$cshow :: LDecl -> String
show :: LDecl -> String
$cshowList :: [LDecl] -> ShowS
showList :: [LDecl] -> ShowS
Show, LDecl -> LDecl -> Bool
(LDecl -> LDecl -> Bool) -> (LDecl -> LDecl -> Bool) -> Eq LDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LDecl -> LDecl -> Bool
== :: LDecl -> LDecl -> Bool
$c/= :: LDecl -> LDecl -> Bool
/= :: LDecl -> LDecl -> Bool
Eq, Eq LDecl
Eq LDecl =>
(LDecl -> LDecl -> Ordering)
-> (LDecl -> LDecl -> Bool)
-> (LDecl -> LDecl -> Bool)
-> (LDecl -> LDecl -> Bool)
-> (LDecl -> LDecl -> Bool)
-> (LDecl -> LDecl -> LDecl)
-> (LDecl -> LDecl -> LDecl)
-> Ord LDecl
LDecl -> LDecl -> Bool
LDecl -> LDecl -> Ordering
LDecl -> LDecl -> LDecl
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LDecl -> LDecl -> Ordering
compare :: LDecl -> LDecl -> Ordering
$c< :: LDecl -> LDecl -> Bool
< :: LDecl -> LDecl -> Bool
$c<= :: LDecl -> LDecl -> Bool
<= :: LDecl -> LDecl -> Bool
$c> :: LDecl -> LDecl -> Bool
> :: LDecl -> LDecl -> Bool
$c>= :: LDecl -> LDecl -> Bool
>= :: LDecl -> LDecl -> Bool
$cmax :: LDecl -> LDecl -> LDecl
max :: LDecl -> LDecl -> LDecl
$cmin :: LDecl -> LDecl -> LDecl
min :: LDecl -> LDecl -> LDecl
Ord)

type LDefs = Ctxt LDecl

data LOpt = Inline | NoInline
  deriving (Int -> LOpt -> ShowS
[LOpt] -> ShowS
LOpt -> String
(Int -> LOpt -> ShowS)
-> (LOpt -> String) -> ([LOpt] -> ShowS) -> Show LOpt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LOpt -> ShowS
showsPrec :: Int -> LOpt -> ShowS
$cshow :: LOpt -> String
show :: LOpt -> String
$cshowList :: [LOpt] -> ShowS
showList :: [LOpt] -> ShowS
Show, LOpt -> LOpt -> Bool
(LOpt -> LOpt -> Bool) -> (LOpt -> LOpt -> Bool) -> Eq LOpt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LOpt -> LOpt -> Bool
== :: LOpt -> LOpt -> Bool
$c/= :: LOpt -> LOpt -> Bool
/= :: LOpt -> LOpt -> Bool
Eq, Eq LOpt
Eq LOpt =>
(LOpt -> LOpt -> Ordering)
-> (LOpt -> LOpt -> Bool)
-> (LOpt -> LOpt -> Bool)
-> (LOpt -> LOpt -> Bool)
-> (LOpt -> LOpt -> Bool)
-> (LOpt -> LOpt -> LOpt)
-> (LOpt -> LOpt -> LOpt)
-> Ord LOpt
LOpt -> LOpt -> Bool
LOpt -> LOpt -> Ordering
LOpt -> LOpt -> LOpt
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LOpt -> LOpt -> Ordering
compare :: LOpt -> LOpt -> Ordering
$c< :: LOpt -> LOpt -> Bool
< :: LOpt -> LOpt -> Bool
$c<= :: LOpt -> LOpt -> Bool
<= :: LOpt -> LOpt -> Bool
$c> :: LOpt -> LOpt -> Bool
> :: LOpt -> LOpt -> Bool
$c>= :: LOpt -> LOpt -> Bool
>= :: LOpt -> LOpt -> Bool
$cmax :: LOpt -> LOpt -> LOpt
max :: LOpt -> LOpt -> LOpt
$cmin :: LOpt -> LOpt -> LOpt
min :: LOpt -> LOpt -> LOpt
Ord)

addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
addTags Int
i [(Name, LDecl)]
ds = Int -> [(Name, LDecl)] -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
forall {a}.
Int -> [(a, LDecl)] -> [(a, LDecl)] -> (Int, [(a, LDecl)])
tag Int
i [(Name, LDecl)]
ds []
  where tag :: Int -> [(a, LDecl)] -> [(a, LDecl)] -> (Int, [(a, LDecl)])
tag Int
i ((a
n, LConstructor Name
n' (-1) Int
a) : [(a, LDecl)]
as) [(a, LDecl)]
acc
            = Int -> [(a, LDecl)] -> [(a, LDecl)] -> (Int, [(a, LDecl)])
tag (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(a, LDecl)]
as ((a
n, Name -> Int -> Int -> LDecl
LConstructor Name
n' Int
i Int
a) (a, LDecl) -> [(a, LDecl)] -> [(a, LDecl)]
forall a. a -> [a] -> [a]
: [(a, LDecl)]
acc)
        tag Int
i ((a
n, LConstructor Name
n' Int
t Int
a) : [(a, LDecl)]
as) [(a, LDecl)]
acc
            = Int -> [(a, LDecl)] -> [(a, LDecl)] -> (Int, [(a, LDecl)])
tag Int
i [(a, LDecl)]
as ((a
n, Name -> Int -> Int -> LDecl
LConstructor Name
n' Int
t Int
a) (a, LDecl) -> [(a, LDecl)] -> [(a, LDecl)]
forall a. a -> [a] -> [a]
: [(a, LDecl)]
acc)
        tag Int
i ((a, LDecl)
x : [(a, LDecl)]
as) [(a, LDecl)]
acc = Int -> [(a, LDecl)] -> [(a, LDecl)] -> (Int, [(a, LDecl)])
tag Int
i [(a, LDecl)]
as ((a, LDecl)
x (a, LDecl) -> [(a, LDecl)] -> [(a, LDecl)]
forall a. a -> [a] -> [a]
: [(a, LDecl)]
acc)
        tag Int
i [] [(a, LDecl)]
acc  = (Int
i, [(a, LDecl)] -> [(a, LDecl)]
forall a. [a] -> [a]
reverse [(a, LDecl)]
acc)

data LiftState = LS (Maybe Name) Int [(Name, LDecl)]
                    (Map.Map ([Name], LExp) Name) -- map from args/expressions
                          -- to names, so we don't create the same function
                          -- multiple times

setBaseName :: Name -> State LiftState ()
setBaseName :: Name -> State LiftState ()
setBaseName Name
n
    = do LS Maybe Name
_ Int
i [(Name, LDecl)]
ds Map ([Name], LExp) Name
done <- StateT LiftState Identity LiftState
forall s (m :: * -> *). MonadState s m => m s
get
         LiftState -> State LiftState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Maybe Name
-> Int -> [(Name, LDecl)] -> Map ([Name], LExp) Name -> LiftState
LS (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n) Int
i [(Name, LDecl)]
ds Map ([Name], LExp) Name
done)

lname :: Name -> Int -> Name
lname (NS Name
n [Text]
x) Int
i = Name -> [Text] -> Name
NS (Name -> Int -> Name
lname Name
n Int
i) [Text]
x
lname (UN Text
n) Int
i = Int -> Text -> Name
MN Int
i Text
n
lname Name
x Int
i = Int -> String -> Name
sMN Int
i (Name -> String
showCG Name
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_lam")

getNextName :: State LiftState Name
getNextName :: State LiftState Name
getNextName
    = do LS Maybe Name
mn Int
i [(Name, LDecl)]
ds Map ([Name], LExp) Name
done <- StateT LiftState Identity LiftState
forall s (m :: * -> *). MonadState s m => m s
get
         let newn :: Name
newn = case Maybe Name
mn of
                         Maybe Name
Nothing -> Name -> Int -> Name
lname (String -> Name
sUN String
"_") Int
i
                         Just Name
n -> Name -> Int -> Name
lname Name
n Int
i
         LiftState -> State LiftState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Maybe Name
-> Int -> [(Name, LDecl)] -> Map ([Name], LExp) Name -> LiftState
LS Maybe Name
mn (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [(Name, LDecl)]
ds Map ([Name], LExp) Name
done)
         Name -> State LiftState Name
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
newn

renameArgs :: [Name] -> LExp -> ([Name], LExp)
renameArgs :: [Name] -> LExp -> ([Name], LExp)
renameArgs [Name]
args LExp
e
   = let newargNames :: [Name]
newargNames = (Int -> Name) -> [Int] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Int -> String -> Name
sMN Int
i String
"lift") [Int
0..]
         newargs :: [(Name, Name)]
newargs = [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
args [Name]
newargNames in
         (((Name, Name) -> Name) -> [(Name, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Name) -> Name
forall a b. (a, b) -> b
snd [(Name, Name)]
newargs, [(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
newargs LExp
e)

addFn :: Name -> LDecl -> State LiftState ()
addFn :: Name -> LDecl -> State LiftState ()
addFn Name
fn LDecl
d
    = do LS Maybe Name
n Int
i [(Name, LDecl)]
ds Map ([Name], LExp) Name
done <- StateT LiftState Identity LiftState
forall s (m :: * -> *). MonadState s m => m s
get
         LiftState -> State LiftState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Maybe Name
-> Int -> [(Name, LDecl)] -> Map ([Name], LExp) Name -> LiftState
LS Maybe Name
n Int
i ((Name
fn, LDecl
d) (Name, LDecl) -> [(Name, LDecl)] -> [(Name, LDecl)]
forall a. a -> [a] -> [a]
: [(Name, LDecl)]
ds) Map ([Name], LExp) Name
done)

makeFn :: [Name] -> LExp -> State LiftState Name
makeFn :: [Name] -> LExp -> State LiftState Name
makeFn [Name]
args LExp
exp
    = do Name
fn <- State LiftState Name
getNextName
         let ([Name]
args', LExp
exp') = [Name] -> LExp -> ([Name], LExp)
renameArgs [Name]
args LExp
exp
         LS Maybe Name
n Int
i [(Name, LDecl)]
ds Map ([Name], LExp) Name
done <- StateT LiftState Identity LiftState
forall s (m :: * -> *). MonadState s m => m s
get
         case ([Name], LExp) -> Map ([Name], LExp) Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Name]
args', LExp
exp') Map ([Name], LExp) Name
done of
              Just Name
fn -> Name -> State LiftState Name
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
fn
              Maybe Name
Nothing ->
                do Name -> LDecl -> State LiftState ()
addFn Name
fn ([LOpt] -> Name -> [Name] -> LExp -> LDecl
LFun [LOpt
Inline] Name
fn [Name]
args' LExp
exp')
                   LS Maybe Name
n Int
i [(Name, LDecl)]
ds Map ([Name], LExp) Name
done <- StateT LiftState Identity LiftState
forall s (m :: * -> *). MonadState s m => m s
get
                   LiftState -> State LiftState ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Maybe Name
-> Int -> [(Name, LDecl)] -> Map ([Name], LExp) Name -> LiftState
LS Maybe Name
n Int
i [(Name, LDecl)]
ds (([Name], LExp)
-> Name -> Map ([Name], LExp) Name -> Map ([Name], LExp) Name
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ([Name]
args', LExp
exp') Name
fn Map ([Name], LExp) Name
done))
                   Name -> State LiftState Name
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
fn

liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]
liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]
liftAll [(Name, LDecl)]
xs =
  let (LS Maybe Name
_ Int
_ [(Name, LDecl)]
decls Map ([Name], LExp) Name
_) = State LiftState () -> LiftState -> LiftState
forall s a. State s a -> s -> s
execState (((Name, LDecl) -> State LiftState ())
-> [(Name, LDecl)] -> State LiftState ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, LDecl) -> State LiftState ()
liftDef [(Name, LDecl)]
xs) (Maybe Name
-> Int -> [(Name, LDecl)] -> Map ([Name], LExp) Name -> LiftState
LS Maybe Name
forall a. Maybe a
Nothing Int
0 [] Map ([Name], LExp) Name
forall k a. Map k a
Map.empty) in
      [(Name, LDecl)]
decls

liftDef :: (Name, LDecl) -> State LiftState ()
liftDef :: (Name, LDecl) -> State LiftState ()
liftDef (Name
n, LFun [LOpt]
opts Name
_ [Name]
args LExp
e) =
    do Name -> State LiftState ()
setBaseName Name
n
       LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
args LExp
e
       Name -> LDecl -> State LiftState ()
addFn Name
n ([LOpt] -> Name -> [Name] -> LExp -> LDecl
LFun [LOpt]
opts Name
n [Name]
args LExp
e')
liftDef (Name
n, LDecl
x) = Name -> LDecl -> State LiftState ()
addFn Name
n LDecl
x

lift :: [Name] -> LExp -> State LiftState LExp
lift :: [Name] -> LExp -> State LiftState LExp
lift [Name]
env (LV Name
v) = LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> LExp
LV Name
v) -- Lifting happens before these can exist...
lift [Name]
env (LApp Bool
tc (LV Name
n) [LExp]
args) = do [LExp]
args' <- (LExp -> State LiftState LExp)
-> [LExp] -> StateT LiftState Identity [LExp]
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 LiftState LExp
lift [Name]
env) [LExp]
args
                                    LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> LExp -> [LExp] -> LExp
LApp Bool
tc (Name -> LExp
LV Name
n) [LExp]
args')
lift [Name]
env (LApp Bool
tc LExp
f [LExp]
args) = do LExp
f' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
env LExp
f
                               Name
fn <- [Name] -> LExp -> State LiftState Name
makeFn [Name]
env LExp
f'
                               [LExp]
args' <- (LExp -> State LiftState LExp)
-> [LExp] -> StateT LiftState Identity [LExp]
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 LiftState LExp
lift [Name]
env) [LExp]
args
                               LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> LExp -> [LExp] -> LExp
LApp Bool
tc (Name -> LExp
LV Name
fn) ((Name -> LExp) -> [Name] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> LExp
LV [Name]
env [LExp] -> [LExp] -> [LExp]
forall a. [a] -> [a] -> [a]
++ [LExp]
args'))
lift [Name]
env (LLazyApp Name
n [LExp]
args) = do [LExp]
args' <- (LExp -> State LiftState LExp)
-> [LExp] -> StateT LiftState Identity [LExp]
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 LiftState LExp
lift [Name]
env) [LExp]
args
                                LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [LExp] -> LExp
LLazyApp Name
n [LExp]
args')
lift [Name]
env (LLazyExp (LConst Const
c)) = LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Const -> LExp
LConst Const
c)
-- lift env (LLazyExp (LApp tc (LV (Glob f)) args))
--                       = lift env (LLazyApp f args)
lift [Name]
env (LLazyExp LExp
e) = do LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
env LExp
e
                           let usedArgs :: [Name]
usedArgs = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> LExp -> [Name]
usedIn [Name]
env LExp
e'
                           Name
fn <- [Name] -> LExp -> State LiftState Name
makeFn [Name]
usedArgs LExp
e'
                           LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [LExp] -> LExp
LLazyApp Name
fn ((Name -> LExp) -> [Name] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> LExp
LV [Name]
usedArgs))
lift [Name]
env (LForce LExp
e) = do LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
env LExp
e
                         LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LExp -> LExp
LForce LExp
e')
lift [Name]
env (LLet Name
n LExp
v LExp
e) = do LExp
v' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
env LExp
v
                           LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift ([Name]
env [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
n]) LExp
e
                           LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> LExp -> LExp -> LExp
LLet Name
n LExp
v' LExp
e')
lift [Name]
env (LLam [Name]
args (LLam [Name]
args' LExp
e)) = [Name] -> LExp -> State LiftState LExp
lift [Name]
env ([Name] -> LExp -> LExp
LLam ([Name]
args [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
args') LExp
e)
lift [Name]
env (LLam [Name]
args LExp
e) = do LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift ([Name]
env [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
args) LExp
e
                            let usedArgs :: [Name]
usedArgs = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> LExp -> [Name]
usedIn [Name]
env LExp
e'
                            Name
fn <- [Name] -> LExp -> State LiftState Name
makeFn ([Name]
usedArgs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
args) LExp
e'
                            LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> LExp -> [LExp] -> LExp
LApp Bool
False (Name -> LExp
LV Name
fn) ((Name -> LExp) -> [Name] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> LExp
LV [Name]
usedArgs))
lift [Name]
env (LProj LExp
t Int
i) = do LExp
t' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
env LExp
t
                          LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LExp -> Int -> LExp
LProj LExp
t' Int
i)
lift [Name]
env (LCon Maybe Name
loc Int
i Name
n [LExp]
args) = do [LExp]
args' <- (LExp -> State LiftState LExp)
-> [LExp] -> StateT LiftState Identity [LExp]
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 LiftState LExp
lift [Name]
env) [LExp]
args
                                  LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Name -> Int -> Name -> [LExp] -> LExp
LCon Maybe Name
loc Int
i Name
n [LExp]
args')
lift [Name]
env (LCase CaseType
up LExp
e [LAlt]
alts) = do [LAlt]
alts' <- (LAlt -> StateT LiftState Identity LAlt)
-> [LAlt] -> StateT LiftState Identity [LAlt]
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 LAlt -> StateT LiftState Identity LAlt
liftA [LAlt]
alts
                                LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
env LExp
e
                                LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (CaseType -> LExp -> [LAlt] -> LExp
LCase CaseType
up LExp
e' [LAlt]
alts')
  where
    liftA :: LAlt -> StateT LiftState Identity LAlt
liftA (LConCase Int
i Name
n [Name]
args LExp
e) = do LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift ([Name]
env [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
args) LExp
e
                                     LAlt -> StateT LiftState Identity LAlt
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Name -> [Name] -> LExp -> LAlt
forall e. Int -> Name -> [Name] -> e -> LAlt' e
LConCase Int
i Name
n [Name]
args LExp
e')
    liftA (LConstCase Const
c LExp
e) = do LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
env LExp
e
                                LAlt -> StateT LiftState Identity LAlt
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Const -> LExp -> LAlt
forall e. Const -> e -> LAlt' e
LConstCase Const
c LExp
e')
    liftA (LDefaultCase LExp
e) = do LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
env LExp
e
                                LAlt -> StateT LiftState Identity LAlt
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LExp -> LAlt
forall e. e -> LAlt' e
LDefaultCase LExp
e')
lift [Name]
env (LConst Const
c) = LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Const -> LExp
LConst Const
c)
lift [Name]
env (LForeign FDesc
t FDesc
s [(FDesc, LExp)]
args) = do [(FDesc, LExp)]
args' <- ((FDesc, LExp) -> StateT LiftState Identity (FDesc, LExp))
-> [(FDesc, LExp)] -> StateT LiftState Identity [(FDesc, LExp)]
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 LiftState Identity (FDesc, LExp)
forall {a}.
[Name] -> (a, LExp) -> StateT LiftState Identity (a, LExp)
liftF [Name]
env) [(FDesc, LExp)]
args
                                  LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (FDesc -> FDesc -> [(FDesc, LExp)] -> LExp
LForeign FDesc
t FDesc
s [(FDesc, LExp)]
args')
  where
    liftF :: [Name] -> (a, LExp) -> StateT LiftState Identity (a, LExp)
liftF [Name]
env (a
t, LExp
e) = do LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
env LExp
e
                          (a, LExp) -> StateT LiftState Identity (a, LExp)
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
t, LExp
e')
lift [Name]
env (LOp PrimFn
f [LExp]
args) = do [LExp]
args' <- (LExp -> State LiftState LExp)
-> [LExp] -> StateT LiftState Identity [LExp]
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 LiftState LExp
lift [Name]
env) [LExp]
args
                           LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimFn -> [LExp] -> LExp
LOp PrimFn
f [LExp]
args')
lift [Name]
env (LError String
str) = LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LExp -> State LiftState LExp) -> LExp -> State LiftState LExp
forall a b. (a -> b) -> a -> b
$ String -> LExp
LError String
str
lift [Name]
env LExp
LNothing = LExp -> State LiftState LExp
forall a. a -> StateT LiftState Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return LExp
LNothing

allocUnique :: LDefs -> (Name, LDecl) -> (Name, LDecl)
allocUnique :: LDefs -> (Name, LDecl) -> (Name, LDecl)
allocUnique LDefs
defs p :: (Name, LDecl)
p@(Name
n, LConstructor Name
_ Int
_ Int
_) = (Name, LDecl)
p
allocUnique LDefs
defs (Name
n, LFun [LOpt]
opts Name
fn [Name]
args LExp
e)
    = let e' :: LExp
e' = State [(Name, Int)] LExp -> [(Name, Int)] -> LExp
forall s a. State s a -> s -> a
evalState (LExp -> State [(Name, Int)] LExp
findUp LExp
e) [] in
          (Name
n, [LOpt] -> Name -> [Name] -> LExp -> LDecl
LFun [LOpt]
opts Name
fn [Name]
args LExp
e')
  where
    -- Keep track of 'updatable' names in the state, i.e. names whose heap
    -- entry may be reused, along with the arity which was there
    findUp :: LExp -> State [(Name, Int)] LExp
    findUp :: LExp -> State [(Name, Int)] LExp
findUp (LApp Bool
t (LV Name
n) [LExp]
as)
       | Just (LConstructor Name
_ Int
i Int
ar) <- Name -> LDefs -> Maybe LDecl
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n LDefs
defs,
         Int
ar Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [LExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LExp]
as
          = LExp -> State [(Name, Int)] LExp
findUp (Maybe Name -> Int -> Name -> [LExp] -> LExp
LCon Maybe Name
forall a. Maybe a
Nothing Int
i Name
n [LExp]
as)
    findUp (LV Name
n)
       | Just (LConstructor Name
_ Int
i Int
0) <- Name -> LDefs -> Maybe LDecl
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n LDefs
defs
          = LExp -> State [(Name, Int)] LExp
forall a. a -> StateT [(Name, Int)] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LExp -> State [(Name, Int)] LExp)
-> LExp -> State [(Name, Int)] LExp
forall a b. (a -> b) -> a -> b
$ Maybe Name -> Int -> Name -> [LExp] -> LExp
LCon Maybe Name
forall a. Maybe a
Nothing Int
i Name
n [] -- nullary cons are global, no need to update
    findUp (LApp Bool
t LExp
f [LExp]
as) = Bool -> LExp -> [LExp] -> LExp
LApp Bool
t (LExp -> [LExp] -> LExp)
-> State [(Name, Int)] LExp
-> StateT [(Name, Int)] Identity ([LExp] -> LExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
f StateT [(Name, Int)] Identity ([LExp] -> LExp)
-> StateT [(Name, Int)] Identity [LExp] -> State [(Name, Int)] LExp
forall a b.
StateT [(Name, Int)] Identity (a -> b)
-> StateT [(Name, Int)] Identity a
-> StateT [(Name, Int)] Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LExp -> State [(Name, Int)] LExp)
-> [LExp] -> StateT [(Name, Int)] Identity [LExp]
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 LExp -> State [(Name, Int)] LExp
findUp [LExp]
as
    findUp (LLazyApp Name
n [LExp]
as) = Name -> [LExp] -> LExp
LLazyApp Name
n ([LExp] -> LExp)
-> StateT [(Name, Int)] Identity [LExp] -> State [(Name, Int)] LExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LExp -> State [(Name, Int)] LExp)
-> [LExp] -> StateT [(Name, Int)] Identity [LExp]
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 LExp -> State [(Name, Int)] LExp
findUp [LExp]
as
    findUp (LLazyExp LExp
e) = LExp -> LExp
LLazyExp (LExp -> LExp)
-> State [(Name, Int)] LExp -> State [(Name, Int)] LExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
e
    findUp (LForce LExp
e) = LExp -> LExp
LForce (LExp -> LExp)
-> State [(Name, Int)] LExp -> State [(Name, Int)] LExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
e
    -- use assumption that names are unique!
    findUp (LLet Name
n LExp
val LExp
sc) = Name -> LExp -> LExp -> LExp
LLet Name
n (LExp -> LExp -> LExp)
-> State [(Name, Int)] LExp
-> StateT [(Name, Int)] Identity (LExp -> LExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
val StateT [(Name, Int)] Identity (LExp -> LExp)
-> State [(Name, Int)] LExp -> State [(Name, Int)] LExp
forall a b.
StateT [(Name, Int)] Identity (a -> b)
-> StateT [(Name, Int)] Identity a
-> StateT [(Name, Int)] Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LExp -> State [(Name, Int)] LExp
findUp LExp
sc
    findUp (LLam [Name]
ns LExp
sc) = [Name] -> LExp -> LExp
LLam [Name]
ns (LExp -> LExp)
-> State [(Name, Int)] LExp -> State [(Name, Int)] LExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
sc
    findUp (LProj LExp
e Int
i) = LExp -> Int -> LExp
LProj (LExp -> Int -> LExp)
-> State [(Name, Int)] LExp
-> StateT [(Name, Int)] Identity (Int -> LExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
e StateT [(Name, Int)] Identity (Int -> LExp)
-> StateT [(Name, Int)] Identity Int -> State [(Name, Int)] LExp
forall a b.
StateT [(Name, Int)] Identity (a -> b)
-> StateT [(Name, Int)] Identity a
-> StateT [(Name, Int)] Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> StateT [(Name, Int)] Identity Int
forall a. a -> StateT [(Name, Int)] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
    findUp (LCon (Just Name
l) Int
i Name
n [LExp]
es) = Maybe Name -> Int -> Name -> [LExp] -> LExp
LCon (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
l) Int
i Name
n ([LExp] -> LExp)
-> StateT [(Name, Int)] Identity [LExp] -> State [(Name, Int)] LExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LExp -> State [(Name, Int)] LExp)
-> [LExp] -> StateT [(Name, Int)] Identity [LExp]
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 LExp -> State [(Name, Int)] LExp
findUp [LExp]
es
    findUp (LCon Maybe Name
Nothing Int
i Name
n [LExp]
es)
           = do [(Name, Int)]
avail <- StateT [(Name, Int)] Identity [(Name, Int)]
forall s (m :: * -> *). MonadState s m => m s
get
                Maybe Name
v <- [(Name, Int)]
-> [(Name, Int)]
-> Int
-> StateT [(Name, Int)] Identity (Maybe Name)
forall {m :: * -> *} {t} {a}.
(Eq t, MonadState [(a, t)] m) =>
[(a, t)] -> [(a, t)] -> t -> m (Maybe a)
findVar [] [(Name, Int)]
avail ([LExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LExp]
es)
                Maybe Name -> Int -> Name -> [LExp] -> LExp
LCon Maybe Name
v Int
i Name
n ([LExp] -> LExp)
-> StateT [(Name, Int)] Identity [LExp] -> State [(Name, Int)] LExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LExp -> State [(Name, Int)] LExp)
-> [LExp] -> StateT [(Name, Int)] Identity [LExp]
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 LExp -> State [(Name, Int)] LExp
findUp [LExp]
es
    findUp (LForeign FDesc
t FDesc
s [(FDesc, LExp)]
es)
           = FDesc -> FDesc -> [(FDesc, LExp)] -> LExp
LForeign FDesc
t FDesc
s ([(FDesc, LExp)] -> LExp)
-> StateT [(Name, Int)] Identity [(FDesc, LExp)]
-> State [(Name, Int)] LExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((FDesc, LExp) -> StateT [(Name, Int)] Identity (FDesc, LExp))
-> [(FDesc, LExp)] -> StateT [(Name, Int)] Identity [(FDesc, LExp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ (FDesc
t, LExp
e) -> do LExp
e' <- LExp -> State [(Name, Int)] LExp
findUp LExp
e
                                                   (FDesc, LExp) -> StateT [(Name, Int)] Identity (FDesc, LExp)
forall a. a -> StateT [(Name, Int)] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (FDesc
t, LExp
e')) [(FDesc, LExp)]
es
    findUp (LOp PrimFn
o [LExp]
es) = PrimFn -> [LExp] -> LExp
LOp PrimFn
o ([LExp] -> LExp)
-> StateT [(Name, Int)] Identity [LExp] -> State [(Name, Int)] LExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LExp -> State [(Name, Int)] LExp)
-> [LExp] -> StateT [(Name, Int)] Identity [LExp]
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 LExp -> State [(Name, Int)] LExp
findUp [LExp]
es
    findUp (LCase CaseType
Updatable e :: LExp
e@(LV Name
n) [LAlt]
as)
           = CaseType -> LExp -> [LAlt] -> LExp
LCase CaseType
Updatable LExp
e ([LAlt] -> LExp)
-> StateT [(Name, Int)] Identity [LAlt] -> State [(Name, Int)] LExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LAlt -> StateT [(Name, Int)] Identity LAlt)
-> [LAlt] -> StateT [(Name, Int)] Identity [LAlt]
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, Int)] Identity LAlt
doUpAlt Name
n) [LAlt]
as
    findUp (LCase CaseType
t LExp
e [LAlt]
as)
           = CaseType -> LExp -> [LAlt] -> LExp
LCase CaseType
t (LExp -> [LAlt] -> LExp)
-> State [(Name, Int)] LExp
-> StateT [(Name, Int)] Identity ([LAlt] -> LExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
e StateT [(Name, Int)] Identity ([LAlt] -> LExp)
-> StateT [(Name, Int)] Identity [LAlt] -> State [(Name, Int)] LExp
forall a b.
StateT [(Name, Int)] Identity (a -> b)
-> StateT [(Name, Int)] Identity a
-> StateT [(Name, Int)] Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (LAlt -> StateT [(Name, Int)] Identity LAlt)
-> [LAlt] -> StateT [(Name, Int)] Identity [LAlt]
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 LAlt -> StateT [(Name, Int)] Identity LAlt
findUpAlt [LAlt]
as
    findUp LExp
t = LExp -> State [(Name, Int)] LExp
forall a. a -> StateT [(Name, Int)] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return LExp
t

    findUpAlt :: LAlt -> StateT [(Name, Int)] Identity LAlt
findUpAlt (LConCase Int
i Name
t [Name]
args LExp
rhs) = do [(Name, Int)]
avail <- StateT [(Name, Int)] Identity [(Name, Int)]
forall s (m :: * -> *). MonadState s m => m s
get
                                           LExp
rhs' <- LExp -> State [(Name, Int)] LExp
findUp LExp
rhs
                                           [(Name, Int)] -> StateT [(Name, Int)] Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [(Name, Int)]
avail
                                           LAlt -> StateT [(Name, Int)] Identity LAlt
forall a. a -> StateT [(Name, Int)] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LAlt -> StateT [(Name, Int)] Identity LAlt)
-> LAlt -> StateT [(Name, Int)] Identity LAlt
forall a b. (a -> b) -> a -> b
$ Int -> Name -> [Name] -> LExp -> LAlt
forall e. Int -> Name -> [Name] -> e -> LAlt' e
LConCase Int
i Name
t [Name]
args LExp
rhs'
    findUpAlt (LConstCase Const
i LExp
rhs) = Const -> LExp -> LAlt
forall e. Const -> e -> LAlt' e
LConstCase Const
i (LExp -> LAlt)
-> State [(Name, Int)] LExp -> StateT [(Name, Int)] Identity LAlt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
rhs
    findUpAlt (LDefaultCase LExp
rhs) = LExp -> LAlt
forall e. e -> LAlt' e
LDefaultCase (LExp -> LAlt)
-> State [(Name, Int)] LExp -> StateT [(Name, Int)] Identity LAlt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
rhs

    doUpAlt :: Name -> LAlt -> StateT [(Name, Int)] Identity LAlt
doUpAlt Name
n (LConCase Int
i Name
t [Name]
args LExp
rhs)
           = do [(Name, Int)]
avail <- StateT [(Name, Int)] Identity [(Name, Int)]
forall s (m :: * -> *). MonadState s m => m s
get
                [(Name, Int)] -> StateT [(Name, Int)] Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ((Name
n, [Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
args) (Name, Int) -> [(Name, Int)] -> [(Name, Int)]
forall a. a -> [a] -> [a]
: [(Name, Int)]
avail)
                LExp
rhs' <- LExp -> State [(Name, Int)] LExp
findUp LExp
rhs
                [(Name, Int)] -> StateT [(Name, Int)] Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [(Name, Int)]
avail
                LAlt -> StateT [(Name, Int)] Identity LAlt
forall a. a -> StateT [(Name, Int)] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LAlt -> StateT [(Name, Int)] Identity LAlt)
-> LAlt -> StateT [(Name, Int)] Identity LAlt
forall a b. (a -> b) -> a -> b
$ Int -> Name -> [Name] -> LExp -> LAlt
forall e. Int -> Name -> [Name] -> e -> LAlt' e
LConCase Int
i Name
t [Name]
args LExp
rhs'
    doUpAlt Name
n (LConstCase Const
i LExp
rhs) = Const -> LExp -> LAlt
forall e. Const -> e -> LAlt' e
LConstCase Const
i (LExp -> LAlt)
-> State [(Name, Int)] LExp -> StateT [(Name, Int)] Identity LAlt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
rhs
    doUpAlt Name
n (LDefaultCase LExp
rhs) = LExp -> LAlt
forall e. e -> LAlt' e
LDefaultCase (LExp -> LAlt)
-> State [(Name, Int)] LExp -> StateT [(Name, Int)] Identity LAlt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
rhs

    findVar :: [(a, t)] -> [(a, t)] -> t -> m (Maybe a)
findVar [(a, t)]
_ [] t
i = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    findVar [(a, t)]
acc ((a
n, t
l) : [(a, t)]
ns) t
i | t
l t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
i = do [(a, t)] -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([(a, t)] -> [(a, t)]
forall a. [a] -> [a]
reverse [(a, t)]
acc [(a, t)] -> [(a, t)] -> [(a, t)]
forall a. [a] -> [a] -> [a]
++ [(a, t)]
ns)
                                              Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
n)
    findVar [(a, t)]
acc ((a, t)
n : [(a, t)]
ns) t
i = [(a, t)] -> [(a, t)] -> t -> m (Maybe a)
findVar ((a, t)
n (a, t) -> [(a, t)] -> [(a, t)]
forall a. a -> [a] -> [a]
: [(a, t)]
acc) [(a, t)]
ns t
i


-- Return variables in list which are used in the expression

usedArg :: t a -> a -> [a]
usedArg t a
env a
n | a
n a -> t a -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
env = [a
n]
              | Bool
otherwise = []

usedIn :: [Name] -> LExp -> [Name]
usedIn :: [Name] -> LExp -> [Name]
usedIn [Name]
env (LV Name
n) = [Name] -> Name -> [Name]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => t a -> a -> [a]
usedArg [Name]
env Name
n
usedIn [Name]
env (LApp Bool
_ LExp
e [LExp]
args) = [Name] -> LExp -> [Name]
usedIn [Name]
env LExp
e [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (LExp -> [Name]) -> [LExp] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Name] -> LExp -> [Name]
usedIn [Name]
env) [LExp]
args
usedIn [Name]
env (LLazyApp Name
n [LExp]
args) = (LExp -> [Name]) -> [LExp] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Name] -> LExp -> [Name]
usedIn [Name]
env) [LExp]
args [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name] -> Name -> [Name]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => t a -> a -> [a]
usedArg [Name]
env Name
n
usedIn [Name]
env (LLazyExp LExp
e) = [Name] -> LExp -> [Name]
usedIn [Name]
env LExp
e
usedIn [Name]
env (LForce LExp
e) = [Name] -> LExp -> [Name]
usedIn [Name]
env LExp
e
usedIn [Name]
env (LLet Name
n LExp
v LExp
e) = [Name] -> LExp -> [Name]
usedIn [Name]
env LExp
v [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name] -> LExp -> [Name]
usedIn ([Name]
env [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Name
n]) LExp
e
usedIn [Name]
env (LLam [Name]
ns LExp
e) = [Name] -> LExp -> [Name]
usedIn ([Name]
env [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
ns) LExp
e
usedIn [Name]
env (LCon Maybe Name
v Int
i Name
n [LExp]
args) = let rest :: [Name]
rest = (LExp -> [Name]) -> [LExp] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Name] -> LExp -> [Name]
usedIn [Name]
env) [LExp]
args in
                                   case Maybe Name
v of
                                      Maybe Name
Nothing -> [Name]
rest
                                      Just Name
n -> [Name] -> Name -> [Name]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => t a -> a -> [a]
usedArg [Name]
env Name
n [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
rest
usedIn [Name]
env (LProj LExp
t Int
i) = [Name] -> LExp -> [Name]
usedIn [Name]
env LExp
t
usedIn [Name]
env (LCase CaseType
up LExp
e [LAlt]
alts) = [Name] -> LExp -> [Name]
usedIn [Name]
env LExp
e [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ (LAlt -> [Name]) -> [LAlt] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Name] -> LAlt -> [Name]
usedInA [Name]
env) [LAlt]
alts
  where usedInA :: [Name] -> LAlt -> [Name]
usedInA [Name]
env (LConCase Int
i Name
n [Name]
ns LExp
e) = [Name] -> LExp -> [Name]
usedIn [Name]
env LExp
e
        usedInA [Name]
env (LConstCase Const
c LExp
e) = [Name] -> LExp -> [Name]
usedIn [Name]
env LExp
e
        usedInA [Name]
env (LDefaultCase LExp
e) = [Name] -> LExp -> [Name]
usedIn [Name]
env LExp
e
usedIn [Name]
env (LForeign FDesc
_ FDesc
_ [(FDesc, LExp)]
args) = (LExp -> [Name]) -> [LExp] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Name] -> LExp -> [Name]
usedIn [Name]
env) (((FDesc, LExp) -> LExp) -> [(FDesc, LExp)] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map (FDesc, LExp) -> LExp
forall a b. (a, b) -> b
snd [(FDesc, LExp)]
args)
usedIn [Name]
env (LOp PrimFn
f [LExp]
args) = (LExp -> [Name]) -> [LExp] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Name] -> LExp -> [Name]
usedIn [Name]
env) [LExp]
args
usedIn [Name]
env LExp
_ = []

lsubst :: Name -> LExp -> LExp -> LExp
lsubst :: Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new (LV Name
x) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
x = LExp
new
lsubst Name
n LExp
new (LApp Bool
t LExp
e [LExp]
args) = let e' :: LExp
e' = Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new LExp
e
                                   args' :: [LExp]
args' = (LExp -> LExp) -> [LExp] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new) [LExp]
args in
                                   Bool -> LExp -> [LExp] -> LExp
LApp Bool
t LExp
e' [LExp]
args'
lsubst Name
n LExp
new (LLazyApp Name
fn [LExp]
args) = let args' :: [LExp]
args' = (LExp -> LExp) -> [LExp] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new) [LExp]
args in
                                      Name -> [LExp] -> LExp
LLazyApp Name
fn [LExp]
args'
lsubst Name
n LExp
new (LLazyExp LExp
e) = LExp -> LExp
LLazyExp (Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new LExp
e)
lsubst Name
n LExp
new (LForce LExp
e) = LExp -> LExp
LForce (Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new LExp
e)
lsubst Name
n LExp
new (LLet Name
v LExp
val LExp
sc) = Name -> LExp -> LExp -> LExp
LLet Name
v (Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new LExp
val) (Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new LExp
sc)
lsubst Name
n LExp
new (LLam [Name]
ns LExp
sc) = [Name] -> LExp -> LExp
LLam [Name]
ns (Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new LExp
sc)
lsubst Name
n LExp
new (LProj LExp
e Int
i) = LExp -> Int -> LExp
LProj (Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new LExp
e) Int
i
lsubst Name
n LExp
new (LCon Maybe Name
lv Int
t Name
cn [LExp]
args) = let args' :: [LExp]
args' = (LExp -> LExp) -> [LExp] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new) [LExp]
args in
                                       Maybe Name -> Int -> Name -> [LExp] -> LExp
LCon Maybe Name
lv Int
t Name
cn [LExp]
args'
lsubst Name
n LExp
new (LOp PrimFn
op [LExp]
args) = let args' :: [LExp]
args' = (LExp -> LExp) -> [LExp] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new) [LExp]
args in
                                 PrimFn -> [LExp] -> LExp
LOp PrimFn
op [LExp]
args'
lsubst Name
n LExp
new (LForeign FDesc
fd FDesc
rd [(FDesc, LExp)]
args)
     = let args' :: [(FDesc, LExp)]
args' = ((FDesc, LExp) -> (FDesc, LExp))
-> [(FDesc, LExp)] -> [(FDesc, LExp)]
forall a b. (a -> b) -> [a] -> [b]
map (\(FDesc
d, LExp
a) -> (FDesc
d, Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new LExp
a)) [(FDesc, LExp)]
args in
           FDesc -> FDesc -> [(FDesc, LExp)] -> LExp
LForeign FDesc
fd FDesc
rd [(FDesc, LExp)]
args'
lsubst Name
n LExp
new (LCase CaseType
t LExp
e [LAlt]
alts) = let e' :: LExp
e' = Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new LExp
e
                                    alts' :: [LAlt]
alts' = (LAlt -> LAlt) -> [LAlt] -> [LAlt]
forall a b. (a -> b) -> [a] -> [b]
map ((LExp -> LExp) -> LAlt -> LAlt
forall a b. (a -> b) -> LAlt' a -> LAlt' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> LExp -> LExp -> LExp
lsubst Name
n LExp
new)) [LAlt]
alts in
                                    CaseType -> LExp -> [LAlt] -> LExp
LCase CaseType
t LExp
e' [LAlt]
alts'
lsubst Name
n LExp
new LExp
tm = LExp
tm

rename :: [(Name, Name)] -> LExp -> LExp
rename :: [(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns tm :: LExp
tm@(LV Name
x)
   = case Name -> [(Name, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
x [(Name, Name)]
ns of
          Just Name
n -> Name -> LExp
LV Name
n
          Maybe Name
_ -> LExp
tm
rename [(Name, Name)]
ns (LApp Bool
t LExp
e [LExp]
args)
    = let e' :: LExp
e' = [(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns LExp
e
          args' :: [LExp]
args' = (LExp -> LExp) -> [LExp] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns) [LExp]
args in
          Bool -> LExp -> [LExp] -> LExp
LApp Bool
t LExp
e' [LExp]
args'
rename [(Name, Name)]
ns (LLazyApp Name
fn [LExp]
args)
    = let args' :: [LExp]
args' = (LExp -> LExp) -> [LExp] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns) [LExp]
args in
          Name -> [LExp] -> LExp
LLazyApp Name
fn [LExp]
args'
rename [(Name, Name)]
ns (LLazyExp LExp
e) = LExp -> LExp
LLazyExp ([(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns LExp
e)
rename [(Name, Name)]
ns (LForce LExp
e) = LExp -> LExp
LForce ([(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns LExp
e)
rename [(Name, Name)]
ns (LLet Name
v LExp
val LExp
sc) = Name -> LExp -> LExp -> LExp
LLet Name
v ([(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns LExp
val) ([(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns LExp
sc)
rename [(Name, Name)]
ns (LLam [Name]
args LExp
sc) = [Name] -> LExp -> LExp
LLam [Name]
args ([(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns LExp
sc)
rename [(Name, Name)]
ns (LProj LExp
e Int
i) = LExp -> Int -> LExp
LProj ([(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns LExp
e) Int
i
rename [(Name, Name)]
ns (LCon Maybe Name
lv Int
t Name
cn [LExp]
args) = let args' :: [LExp]
args' = (LExp -> LExp) -> [LExp] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns) [LExp]
args in
                                    Maybe Name -> Int -> Name -> [LExp] -> LExp
LCon Maybe Name
lv Int
t Name
cn [LExp]
args'
rename [(Name, Name)]
ns (LOp PrimFn
op [LExp]
args) = let args' :: [LExp]
args' = (LExp -> LExp) -> [LExp] -> [LExp]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns) [LExp]
args in
                              PrimFn -> [LExp] -> LExp
LOp PrimFn
op [LExp]
args'
rename [(Name, Name)]
ns (LForeign FDesc
fd FDesc
rd [(FDesc, LExp)]
args)
     = let args' :: [(FDesc, LExp)]
args' = ((FDesc, LExp) -> (FDesc, LExp))
-> [(FDesc, LExp)] -> [(FDesc, LExp)]
forall a b. (a -> b) -> [a] -> [b]
map (\(FDesc
d, LExp
a) -> (FDesc
d, [(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns LExp
a)) [(FDesc, LExp)]
args in
           FDesc -> FDesc -> [(FDesc, LExp)] -> LExp
LForeign FDesc
fd FDesc
rd [(FDesc, LExp)]
args'
rename [(Name, Name)]
ns (LCase CaseType
t LExp
e [LAlt]
alts) = let e' :: LExp
e' = [(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns LExp
e
                                 alts' :: [LAlt]
alts' = (LAlt -> LAlt) -> [LAlt] -> [LAlt]
forall a b. (a -> b) -> [a] -> [b]
map ((LExp -> LExp) -> LAlt -> LAlt
forall a b. (a -> b) -> LAlt' a -> LAlt' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Name, Name)] -> LExp -> LExp
rename [(Name, Name)]
ns)) [LAlt]
alts in
                                 CaseType -> LExp -> [LAlt] -> LExp
LCase CaseType
t LExp
e' [LAlt]
alts'
rename [(Name, Name)]
ns LExp
tm = LExp
tm

instance Show LExp where
   show :: LExp -> String
show LExp
e = [String] -> String -> LExp -> String
show' [] String
"" LExp
e where
     show' :: [String] -> String -> LExp -> String
show' [String]
env String
ind (LV Name
n) = Name -> String
forall a. Show a => a -> String
show Name
n

     show' [String]
env String
ind (LLazyApp Name
e [LExp]
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
", " ((LExp -> String) -> [LExp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String -> LExp -> String
show' [String]
env String
ind) [LExp]
args) String -> ShowS
forall a. [a] -> [a] -> [a]
++String
")"

     show' [String]
env String
ind (LApp Bool
_ LExp
e [LExp]
args)
        = [String] -> String -> LExp -> String
show' [String]
env String
ind LExp
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
showSep String
", " ((LExp -> String) -> [LExp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String -> LExp -> String
show' [String]
env String
ind) [LExp]
args) String -> ShowS
forall a. [a] -> [a] -> [a]
++String
")"

     show' [String]
env String
ind (LLazyExp LExp
e) = String
"lazy{ "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String -> LExp -> String
show' [String]
env String
ind LExp
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" }"
     show' [String]
env String
ind (LForce   LExp
e) = String
"force{ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String -> LExp -> String
show' [String]
env String
ind LExp
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" }"
     show' [String]
env String
ind (LLet Name
n LExp
v LExp
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] -> String -> LExp -> String
show' [String]
env String
ind LExp
v
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String -> LExp -> String
show' ([String]
env [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [Name -> String
forall a. Show a => a -> String
show Name
n]) String
ind LExp
e

     show' [String]
env String
ind (LLam [Name]
args LExp
e)
        = 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] -> String -> LExp -> String
show' ([String]
env [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name -> String
forall a. Show a => a -> String
show [Name]
args)) String
ind LExp
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") "

     show' [String]
env String
ind (LProj LExp
t Int
i) = LExp -> String
forall a. Show a => a -> String
show LExp
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 String
ind (LCon Maybe Name
loc Int
i Name
n [LExp]
args)
        = Maybe Name -> String
atloc Maybe Name
loc 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
", " ((LExp -> String) -> [LExp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String -> LExp -> String
show' [String]
env String
ind) [LExp]
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 String
ind (LCase CaseType
up LExp
e [LAlt]
alts)
        = String
"case" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
update String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String -> LExp -> String
show' [String]
env String
ind LExp
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") of \n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [LAlt] -> String
fmt [LAlt]
alts
       where
         update :: String
update = case CaseType
up of
                       CaseType
Shared -> String
" "
                       CaseType
Updatable -> String
"! "
         fmt :: [LAlt] -> String
fmt [] = String
""
         fmt [LAlt
alt]
            = String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ind String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"| " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String -> LAlt -> String
showAlt [String]
env (String
ind String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"    ") LAlt
alt
         fmt (LAlt
alt:[LAlt]
as)
            = String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ind String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"| " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String -> LAlt -> String
showAlt [String]
env (String
ind String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".   ") LAlt
alt
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [LAlt] -> String
fmt [LAlt]
as

     show' [String]
env String
ind (LConst Const
c) = Const -> String
forall a. Show a => a -> String
show Const
c

     show' [String]
env String
ind (LForeign FDesc
ty FDesc
n [(FDesc, LExp)]
args) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"foreign{ "
            ,       FDesc -> String
forall a. Show a => a -> String
show FDesc
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"("
            ,           String -> [String] -> String
showSep String
", " (((FDesc, LExp) -> String) -> [(FDesc, LExp)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(FDesc
ty,LExp
x) -> [String] -> String -> LExp -> String
show' [String]
env String
ind LExp
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FDesc -> String
forall a. Show a => a -> String
show FDesc
ty) [(FDesc, LExp)]
args)
            ,       String
") : "
            ,       FDesc -> String
forall a. Show a => a -> String
show FDesc
ty
            , String
" }"
            ]

     show' [String]
env String
ind (LOp PrimFn
f [LExp]
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
", " ((LExp -> String) -> [LExp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String -> LExp -> String
show' [String]
env String
ind) [LExp]
args) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

     show' [String]
env String
ind (LError String
str) = String
"error " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
str
     show' [String]
env String
ind LExp
LNothing = String
"____"

     showAlt :: [String] -> String -> LAlt -> String
showAlt [String]
env String
ind (LConCase Int
_ Name
n [Name]
args LExp
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] -> String -> LExp -> String
show' [String]
env String
ind LExp
e

     showAlt [String]
env String
ind (LConstCase Const
c LExp
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] -> String -> LExp -> String
show' [String]
env String
ind LExp
e
     showAlt [String]
env String
ind (LDefaultCase LExp
e) = String
"_ => " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String -> LExp -> String
show' [String]
env String
ind LExp
e

occName :: Name -> LExp -> Int
occName :: Name -> LExp -> Int
occName Name
n (LV Name
x) = if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
x then Int
1 else Int
0
occName Name
n (LApp Bool
t LExp
e [LExp]
es) = Name -> LExp -> Int
occName Name
n LExp
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((LExp -> Int) -> [LExp] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> Int
occName Name
n) [LExp]
es)
occName Name
n (LLazyApp Name
x [LExp]
es)
    = if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
x then Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((LExp -> Int) -> [LExp] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> Int
occName Name
n) [LExp]
es)
                else [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((LExp -> Int) -> [LExp] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> Int
occName Name
n) [LExp]
es)
occName Name
n (LForce LExp
e) = Name -> LExp -> Int
occName Name
n LExp
e
occName Name
n (LLet Name
x LExp
v LExp
sc)
    = if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
x then Name -> LExp -> Int
occName Name
n LExp
v
                else Name -> LExp -> Int
occName Name
n LExp
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Name -> LExp -> Int
occName Name
n LExp
sc
occName Name
n (LLam [Name]
ns LExp
sc)
    = if 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 then Int
0 else Name -> LExp -> Int
occName Name
n LExp
sc
occName Name
n (LProj LExp
e Int
i) = Name -> LExp -> Int
occName Name
n LExp
e
occName Name
n (LCon Maybe Name
_ Int
_ Name
_ [LExp]
es) = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((LExp -> Int) -> [LExp] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> Int
occName Name
n) [LExp]
es)
occName Name
n (LCase CaseType
t LExp
e [LAlt]
alts) = Name -> LExp -> Int
occName Name
n LExp
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((LAlt -> Int) -> [LAlt] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map LAlt -> Int
occAlt [LAlt]
alts)
  where
    occAlt :: LAlt -> Int
occAlt (LConCase Int
_ Name
_ [Name]
ns LExp
e)
        = if 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 then Int
0 else Name -> LExp -> Int
occName Name
n LExp
e
    occAlt (LConstCase Const
_ LExp
e) = Name -> LExp -> Int
occName Name
n LExp
e
    occAlt (LDefaultCase LExp
e) = Name -> LExp -> Int
occName Name
n LExp
e
occName Name
n (LForeign FDesc
_ FDesc
_ [(FDesc, LExp)]
es) = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((FDesc, LExp) -> Int) -> [(FDesc, LExp)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> Int
occName Name
n (LExp -> Int) -> ((FDesc, LExp) -> LExp) -> (FDesc, LExp) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FDesc, LExp) -> LExp
forall a b. (a, b) -> b
snd) [(FDesc, LExp)]
es)
occName Name
n (LOp PrimFn
_ [LExp]
es) = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((LExp -> Int) -> [LExp] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> Int
occName Name
n) [LExp]
es)
occName Name
n LExp
_ = Int
0