{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Endianness] -> ShowS
$cshowList :: [Endianness] -> ShowS
show :: Endianness -> String
$cshow :: Endianness -> String
showsPrec :: Int -> Endianness -> ShowS
$cshowsPrec :: Int -> Endianness -> ShowS
Show, Endianness -> Endianness -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Endianness -> Endianness -> Bool
$c/= :: Endianness -> Endianness -> Bool
== :: Endianness -> Endianness -> Bool
$c== :: Endianness -> Endianness -> Bool
Eq)
data LVar = Loc Int | Glob Name
deriving (Int -> LVar -> ShowS
[LVar] -> ShowS
LVar -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LVar] -> ShowS
$cshowList :: [LVar] -> ShowS
show :: LVar -> String
$cshow :: LVar -> String
showsPrec :: Int -> LVar -> ShowS
$cshowsPrec :: Int -> LVar -> ShowS
Show, LVar -> LVar -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LVar -> LVar -> Bool
$c/= :: LVar -> LVar -> Bool
== :: LVar -> LVar -> Bool
$c== :: LVar -> LVar -> Bool
Eq)
data LExp = LV Name
| LApp Bool LExp [LExp]
| LLazyApp Name [LExp]
| LLazyExp LExp
| LForce LExp
| LLet Name LExp LExp
| LLam [Name] LExp
| LProj LExp Int
| LCon (Maybe Name)
Int Name [LExp]
| LCase CaseType LExp [LAlt]
| LConst Const
| LForeign FDesc
FDesc
[(FDesc, LExp)]
| LOp PrimFn [LExp]
| LNothing
| LError String
deriving (LExp -> LExp -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LExp -> LExp -> Bool
$c/= :: LExp -> LExp -> Bool
== :: LExp -> LExp -> Bool
$c== :: LExp -> LExp -> Bool
Eq, Eq 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
min :: LExp -> LExp -> LExp
$cmin :: LExp -> LExp -> LExp
max :: LExp -> LExp -> LExp
$cmax :: LExp -> LExp -> LExp
>= :: LExp -> LExp -> Bool
$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
compare :: LExp -> LExp -> Ordering
$ccompare :: LExp -> LExp -> Ordering
Ord)
data FDesc = FCon Name
| FStr String
| FUnknown
| FIO FDesc
| FApp Name [FDesc]
deriving (Int -> FDesc -> ShowS
[FDesc] -> ShowS
FDesc -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FDesc] -> ShowS
$cshowList :: [FDesc] -> ShowS
show :: FDesc -> String
$cshow :: FDesc -> String
showsPrec :: Int -> FDesc -> ShowS
$cshowsPrec :: Int -> FDesc -> ShowS
Show, FDesc -> FDesc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FDesc -> FDesc -> Bool
$c/= :: FDesc -> FDesc -> Bool
== :: FDesc -> FDesc -> Bool
$c== :: FDesc -> FDesc -> Bool
Eq, Eq 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
min :: FDesc -> FDesc -> FDesc
$cmin :: FDesc -> FDesc -> FDesc
max :: FDesc -> FDesc -> FDesc
$cmax :: FDesc -> FDesc -> FDesc
>= :: FDesc -> FDesc -> Bool
$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
compare :: FDesc -> FDesc -> Ordering
$ccompare :: FDesc -> FDesc -> Ordering
Ord)
data Export = ExportData FDesc
| ExportFun Name
FDesc
FDesc
[FDesc]
deriving (Int -> Export -> ShowS
[Export] -> ShowS
Export -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Export] -> ShowS
$cshowList :: [Export] -> ShowS
show :: Export -> String
$cshow :: Export -> String
showsPrec :: Int -> Export -> ShowS
$cshowsPrec :: Int -> Export -> ShowS
Show, Export -> Export -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Export -> Export -> Bool
$c/= :: Export -> Export -> Bool
== :: Export -> Export -> Bool
$c== :: Export -> Export -> Bool
Eq, Eq 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
min :: Export -> Export -> Export
$cmin :: Export -> Export -> Export
max :: Export -> Export -> Export
$cmax :: Export -> Export -> Export
>= :: Export -> Export -> Bool
$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
compare :: Export -> Export -> Ordering
$ccompare :: Export -> Export -> Ordering
Ord)
data ExportIFace = Export Name
String
[Export]
deriving (Int -> ExportIFace -> ShowS
[ExportIFace] -> ShowS
ExportIFace -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExportIFace] -> ShowS
$cshowList :: [ExportIFace] -> ShowS
show :: ExportIFace -> String
$cshow :: ExportIFace -> String
showsPrec :: Int -> ExportIFace -> ShowS
$cshowsPrec :: Int -> ExportIFace -> ShowS
Show, ExportIFace -> ExportIFace -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExportIFace -> ExportIFace -> Bool
$c/= :: ExportIFace -> ExportIFace -> Bool
== :: ExportIFace -> ExportIFace -> Bool
$c== :: ExportIFace -> ExportIFace -> Bool
Eq, Eq 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
min :: ExportIFace -> ExportIFace -> ExportIFace
$cmin :: ExportIFace -> ExportIFace -> ExportIFace
max :: ExportIFace -> ExportIFace -> ExportIFace
$cmax :: ExportIFace -> ExportIFace -> ExportIFace
>= :: ExportIFace -> ExportIFace -> Bool
$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
compare :: ExportIFace -> ExportIFace -> Ordering
$ccompare :: ExportIFace -> ExportIFace -> Ordering
Ord)
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
| LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan
| LFATan2 | LFSqrt | LFFloor | LFCeil | LFNegate
| LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev | LStrSubstr
| LReadStr | LWriteStr
| LSystemInfo
| LFork
| LPar
| LExternal Name
| LCrash
| LNoOp
deriving (Int -> PrimFn -> ShowS
[PrimFn] -> ShowS
PrimFn -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrimFn] -> ShowS
$cshowList :: [PrimFn] -> ShowS
show :: PrimFn -> String
$cshow :: PrimFn -> String
showsPrec :: Int -> PrimFn -> ShowS
$cshowsPrec :: Int -> PrimFn -> ShowS
Show, PrimFn -> PrimFn -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrimFn -> PrimFn -> Bool
$c/= :: PrimFn -> PrimFn -> Bool
== :: PrimFn -> PrimFn -> Bool
$c== :: PrimFn -> PrimFn -> Bool
Eq, Eq 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
min :: PrimFn -> PrimFn -> PrimFn
$cmin :: PrimFn -> PrimFn -> PrimFn
max :: PrimFn -> PrimFn -> PrimFn
$cmax :: PrimFn -> PrimFn -> PrimFn
>= :: PrimFn -> PrimFn -> Bool
$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
compare :: PrimFn -> PrimFn -> Ordering
$ccompare :: PrimFn -> PrimFn -> Ordering
Ord, 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
$cto :: forall x. Rep PrimFn x -> PrimFn
$cfrom :: forall x. PrimFn -> Rep PrimFn x
Generic)
data FCallType = FStatic | FObject | FConstructor
deriving (Int -> FCallType -> ShowS
[FCallType] -> ShowS
FCallType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FCallType] -> ShowS
$cshowList :: [FCallType] -> ShowS
show :: FCallType -> String
$cshow :: FCallType -> String
showsPrec :: Int -> FCallType -> ShowS
$cshowsPrec :: Int -> FCallType -> ShowS
Show, FCallType -> FCallType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FCallType -> FCallType -> Bool
$c/= :: FCallType -> FCallType -> Bool
== :: FCallType -> FCallType -> Bool
$c== :: FCallType -> FCallType -> Bool
Eq, Eq 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
min :: FCallType -> FCallType -> FCallType
$cmin :: FCallType -> FCallType -> FCallType
max :: FCallType -> FCallType -> FCallType
$cmax :: FCallType -> FCallType -> FCallType
>= :: FCallType -> FCallType -> Bool
$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
compare :: FCallType -> FCallType -> Ordering
$ccompare :: FCallType -> FCallType -> Ordering
Ord)
data FType = FArith ArithTy
| FFunction
| FFunctionIO
| FString
| FUnit
| FPtr
| FManagedPtr
| FCData
| FAny
deriving (Int -> FType -> ShowS
[FType] -> ShowS
FType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FType] -> ShowS
$cshowList :: [FType] -> ShowS
show :: FType -> String
$cshow :: FType -> String
showsPrec :: Int -> FType -> ShowS
$cshowsPrec :: Int -> FType -> ShowS
Show, FType -> FType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FType -> FType -> Bool
$c/= :: FType -> FType -> Bool
== :: FType -> FType -> Bool
$c== :: FType -> FType -> Bool
Eq, Eq 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
min :: FType -> FType -> FType
$cmin :: FType -> FType -> FType
max :: FType -> FType -> FType
$cmax :: FType -> FType -> FType
>= :: FType -> FType -> Bool
$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
compare :: FType -> FType -> Ordering
$ccompare :: FType -> FType -> Ordering
Ord)
data LAlt' e = LConCase Int Name [Name] e
| LConstCase Const e
| LDefaultCase e
deriving (Int -> LAlt' e -> ShowS
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
showList :: [LAlt' e] -> ShowS
$cshowList :: forall e. Show e => [LAlt' e] -> ShowS
show :: LAlt' e -> String
$cshow :: forall e. Show e => LAlt' e -> String
showsPrec :: Int -> LAlt' e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> LAlt' e -> ShowS
Show, LAlt' e -> LAlt' e -> Bool
forall e. Eq e => LAlt' e -> LAlt' e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LAlt' e -> LAlt' e -> Bool
$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
Eq, LAlt' e -> LAlt' e -> Bool
LAlt' e -> LAlt' e -> Ordering
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
min :: LAlt' e -> LAlt' e -> LAlt' e
$cmin :: forall e. Ord e => LAlt' e -> LAlt' e -> LAlt' e
max :: LAlt' e -> LAlt' e -> LAlt' e
$cmax :: forall e. Ord e => LAlt' e -> LAlt' e -> LAlt' e
>= :: 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
$c< :: forall e. Ord e => LAlt' e -> LAlt' e -> Bool
compare :: LAlt' e -> LAlt' e -> Ordering
$ccompare :: forall e. Ord e => LAlt' e -> LAlt' e -> Ordering
Ord, 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
<$ :: forall a b. a -> LAlt' b -> LAlt' a
$c<$ :: forall a b. a -> LAlt' b -> LAlt' a
fmap :: forall a b. (a -> b) -> LAlt' a -> LAlt' b
$cfmap :: forall a b. (a -> b) -> LAlt' a -> LAlt' b
Functor, LAlt' e -> Constr
LAlt' e -> DataType
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 (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))
gmapMo :: 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)
gmapMp :: forall (m :: * -> *).
MonadPlus 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)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
$cgmapM :: forall e (m :: * -> *).
(Data e, Monad m) =>
(forall d. Data d => d -> m d) -> LAlt' e -> m (LAlt' e)
gmapQi :: forall u. Int -> (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
gmapQ :: forall u. (forall d. Data d => d -> u) -> LAlt' e -> [u]
$cgmapQ :: forall e u.
Data e =>
(forall d. Data d => d -> u) -> LAlt' e -> [u]
gmapQr :: 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
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LAlt' e -> r
$cgmapQl :: forall e r r'.
Data e =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LAlt' e -> r
gmapT :: (forall b. Data b => b -> b) -> LAlt' e -> LAlt' e
$cgmapT :: forall e.
Data e =>
(forall b. Data b => b -> b) -> LAlt' e -> LAlt' e
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> 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))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (LAlt' e))
$cdataCast1 :: forall e (t :: * -> *) (c :: * -> *).
(Data e, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (LAlt' e))
dataTypeOf :: LAlt' e -> DataType
$cdataTypeOf :: forall e. Data e => LAlt' e -> DataType
toConstr :: LAlt' e -> Constr
$ctoConstr :: forall e. Data e => LAlt' e -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> 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)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LAlt' e -> 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)
Data, Typeable)
type LAlt = LAlt' LExp
data LDecl = LFun [LOpt] Name [Name] LExp
| LConstructor Name Int Int
deriving (Int -> LDecl -> ShowS
[LDecl] -> ShowS
LDecl -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LDecl] -> ShowS
$cshowList :: [LDecl] -> ShowS
show :: LDecl -> String
$cshow :: LDecl -> String
showsPrec :: Int -> LDecl -> ShowS
$cshowsPrec :: Int -> LDecl -> ShowS
Show, LDecl -> LDecl -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LDecl -> LDecl -> Bool
$c/= :: LDecl -> LDecl -> Bool
== :: LDecl -> LDecl -> Bool
$c== :: LDecl -> LDecl -> Bool
Eq, Eq 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
min :: LDecl -> LDecl -> LDecl
$cmin :: LDecl -> LDecl -> LDecl
max :: LDecl -> LDecl -> LDecl
$cmax :: LDecl -> LDecl -> LDecl
>= :: LDecl -> LDecl -> Bool
$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
compare :: LDecl -> LDecl -> Ordering
$ccompare :: LDecl -> LDecl -> Ordering
Ord)
type LDefs = Ctxt LDecl
data LOpt = Inline | NoInline
deriving (Int -> LOpt -> ShowS
[LOpt] -> ShowS
LOpt -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LOpt] -> ShowS
$cshowList :: [LOpt] -> ShowS
show :: LOpt -> String
$cshow :: LOpt -> String
showsPrec :: Int -> LOpt -> ShowS
$cshowsPrec :: Int -> LOpt -> ShowS
Show, LOpt -> LOpt -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LOpt -> LOpt -> Bool
$c/= :: LOpt -> LOpt -> Bool
== :: LOpt -> LOpt -> Bool
$c== :: LOpt -> LOpt -> Bool
Eq, Eq 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
min :: LOpt -> LOpt -> LOpt
$cmin :: LOpt -> LOpt -> LOpt
max :: LOpt -> LOpt -> LOpt
$cmax :: LOpt -> LOpt -> LOpt
>= :: LOpt -> LOpt -> Bool
$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
compare :: LOpt -> LOpt -> Ordering
$ccompare :: LOpt -> LOpt -> Ordering
Ord)
addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
addTags Int
i [(Name, LDecl)]
ds = 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 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) 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) 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 forall a. a -> [a] -> [a]
: [(a, LDecl)]
acc)
tag Int
i [] [(a, LDecl)]
acc = (Int
i, forall a. [a] -> [a]
reverse [(a, LDecl)]
acc)
data LiftState = LS (Maybe Name) Int [(Name, LDecl)]
(Map.Map ([Name], LExp) Name)
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 <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Maybe Name
-> Int -> [(Name, LDecl)] -> Map ([Name], LExp) Name -> LiftState
LS (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 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 <- 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
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 forall a. Num a => a -> a -> a
+ Int
1) [(Name, LDecl)]
ds Map ([Name], LExp) Name
done)
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 = forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Int -> String -> Name
sMN Int
i String
"lift") [Int
0..]
newargs :: [(Name, Name)]
newargs = forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
args [Name]
newargNames in
(forall a b. (a -> b) -> [a] -> [b]
map 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 <- forall s (m :: * -> *). MonadState s m => m s
get
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) 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 <- forall s (m :: * -> *). MonadState s m => m s
get
case 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 -> 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 <- forall s (m :: * -> *). MonadState s m => m s
get
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 (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))
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
_) = forall s a. State s a -> s -> s
execState (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 forall a. Maybe a
Nothing Int
0 [] 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) = forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> LExp
LV Name
v)
lift [Name]
env (LApp Bool
tc (LV Name
n) [LExp]
args) = do [LExp]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Name] -> LExp -> State LiftState LExp
lift [Name]
env) [LExp]
args
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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Name] -> LExp -> State LiftState LExp
lift [Name]
env) [LExp]
args
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> LExp -> [LExp] -> LExp
LApp Bool
tc (Name -> LExp
LV Name
fn) (forall a b. (a -> b) -> [a] -> [b]
map Name -> LExp
LV [Name]
env forall a. [a] -> [a] -> [a]
++ [LExp]
args'))
lift [Name]
env (LLazyApp Name
n [LExp]
args) = do [LExp]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Name] -> LExp -> State LiftState LExp
lift [Name]
env) [LExp]
args
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [LExp] -> LExp
LLazyApp Name
n [LExp]
args')
lift [Name]
env (LLazyExp (LConst Const
c)) = forall (m :: * -> *) a. Monad m => a -> m a
return (Const -> LExp
LConst Const
c)
lift [Name]
env (LLazyExp LExp
e) = do LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
env LExp
e
let usedArgs :: [Name]
usedArgs = forall a. Eq a => [a] -> [a]
nub 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'
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [LExp] -> LExp
LLazyApp Name
fn (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
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 forall a. [a] -> [a] -> [a]
++ [Name
n]) LExp
e
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 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 forall a. [a] -> [a] -> [a]
++ [Name]
args) LExp
e
let usedArgs :: [Name]
usedArgs = forall a. Eq a => [a] -> [a]
nub 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 forall a. [a] -> [a] -> [a]
++ [Name]
args) LExp
e'
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> LExp -> [LExp] -> LExp
LApp Bool
False (Name -> LExp
LV Name
fn) (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
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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Name] -> LExp -> State LiftState LExp
lift [Name]
env) [LExp]
args
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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LAlt -> StateT LiftState Identity LAlt
liftA [LAlt]
alts
LExp
e' <- [Name] -> LExp -> State LiftState LExp
lift [Name]
env LExp
e
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 forall a. [a] -> [a] -> [a]
++ [Name]
args) LExp
e
forall (m :: * -> *) a. Monad m => a -> m a
return (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
forall (m :: * -> *) a. Monad m => a -> m a
return (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
forall (m :: * -> *) a. Monad m => a -> m a
return (forall e. e -> LAlt' e
LDefaultCase LExp
e')
lift [Name]
env (LConst Const
c) = 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' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {a}.
[Name] -> (a, LExp) -> StateT LiftState Identity (a, LExp)
liftF [Name]
env) [(FDesc, LExp)]
args
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
forall (m :: * -> *) a. Monad m => a -> m a
return (a
t, LExp
e')
lift [Name]
env (LOp PrimFn
f [LExp]
args) = do [LExp]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Name] -> LExp -> State LiftState LExp
lift [Name]
env) [LExp]
args
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimFn -> [LExp] -> LExp
LOp PrimFn
f [LExp]
args')
lift [Name]
env (LError String
str) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> LExp
LError String
str
lift [Name]
env LExp
LNothing = 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' = 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
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) <- forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n LDefs
defs,
Int
ar forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [LExp]
as
= LExp -> State [(Name, Int)] LExp
findUp (Maybe Name -> Int -> Name -> [LExp] -> LExp
LCon forall a. Maybe a
Nothing Int
i Name
n [LExp]
as)
findUp (LV Name
n)
| Just (LConstructor Name
_ Int
i Int
0) <- forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n LDefs
defs
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Name -> Int -> Name -> [LExp] -> LExp
LCon forall a. Maybe a
Nothing Int
i Name
n []
findUp (LApp Bool
t LExp
f [LExp]
as) = Bool -> LExp -> [LExp] -> LExp
LApp Bool
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LExp -> State [(Name, Int)] LExp
findUp [LExp]
as
findUp (LLazyApp Name
n [LExp]
as) = Name -> [LExp] -> LExp
LLazyApp Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LExp -> State [(Name, Int)] LExp
findUp [LExp]
as
findUp (LLazyExp LExp
e) = LExp -> LExp
LLazyExp 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
e
findUp (LLet Name
n LExp
val LExp
sc) = Name -> LExp -> LExp -> LExp
LLet Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
val 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 (forall a. a -> Maybe a
Just Name
l) Int
i Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 <- forall s (m :: * -> *). MonadState s m => m s
get
Maybe Name
v <- forall {m :: * -> *} {t} {a}.
(Eq t, MonadState [(a, t)] m) =>
[(a, t)] -> [(a, t)] -> t -> m (Maybe a)
findVar [] [(Name, Int)]
avail (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (FDesc
t, LExp
e) -> do LExp
e' <- LExp -> State [(Name, Int)] LExp
findUp LExp
e
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM LAlt -> StateT [(Name, Int)] Identity LAlt
findUpAlt [LAlt]
as
findUp LExp
t = 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 <- forall s (m :: * -> *). MonadState s m => m s
get
LExp
rhs' <- LExp -> State [(Name, Int)] LExp
findUp LExp
rhs
forall s (m :: * -> *). MonadState s m => s -> m ()
put [(Name, Int)]
avail
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. Int -> Name -> [Name] -> e -> LAlt' e
LConCase Int
i Name
t [Name]
args LExp
rhs'
findUpAlt (LConstCase Const
i LExp
rhs) = forall e. Const -> e -> LAlt' e
LConstCase Const
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LExp -> State [(Name, Int)] LExp
findUp LExp
rhs
findUpAlt (LDefaultCase LExp
rhs) = forall e. e -> LAlt' e
LDefaultCase 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 <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put ((Name
n, forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
args) forall a. a -> [a] -> [a]
: [(Name, Int)]
avail)
LExp
rhs' <- LExp -> State [(Name, Int)] LExp
findUp LExp
rhs
forall s (m :: * -> *). MonadState s m => s -> m ()
put [(Name, Int)]
avail
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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) = forall e. Const -> e -> LAlt' e
LConstCase Const
i 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) = forall e. e -> LAlt' e
LDefaultCase 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
findVar [(a, t)]
acc ((a
n, t
l) : [(a, t)]
ns) t
i | t
l forall a. Eq a => a -> a -> Bool
== t
i = do forall s (m :: * -> *). MonadState s m => s -> m ()
put (forall a. [a] -> [a]
reverse [(a, t)]
acc forall a. [a] -> [a] -> [a]
++ [(a, t)]
ns)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 forall a. a -> [a] -> [a]
: [(a, t)]
acc) [(a, t)]
ns t
i
usedArg :: t a -> a -> [a]
usedArg t a
env a
n | a
n 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) = 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 forall a. [a] -> [a] -> [a]
++ 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) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Name] -> LExp -> [Name]
usedIn [Name]
env) [LExp]
args forall a. [a] -> [a] -> [a]
++ 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 forall a. [a] -> [a] -> [a]
++ [Name] -> LExp -> [Name]
usedIn ([Name]
env 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 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 = 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 -> forall {t :: * -> *} {a}. (Foldable t, Eq a) => t a -> a -> [a]
usedArg [Name]
env Name
n 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 forall a. [a] -> [a] -> [a]
++ 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) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Name] -> LExp -> [Name]
usedIn [Name]
env) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(FDesc, LExp)]
args)
usedIn [Name]
env (LOp PrimFn
f [LExp]
args) = 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 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' = 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' = 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' = 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' = 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' = 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' = forall a b. (a -> b) -> [a] -> [b]
map (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 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' = 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' = 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' = 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' = 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' = 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' = forall a b. (a -> b) -> [a] -> [b]
map (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) = forall a. Show a => a -> String
show Name
n
show' [String]
env String
ind (LLazyApp Name
e [LExp]
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] -> String -> LExp -> String
show' [String]
env String
ind) [LExp]
args) 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 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] -> String -> LExp -> String
show' [String]
env String
ind) [LExp]
args) forall a. [a] -> [a] -> [a]
++String
")"
show' [String]
env String
ind (LLazyExp LExp
e) = String
"lazy{ " forall a. [a] -> [a] -> [a]
++ [String] -> String -> LExp -> String
show' [String]
env String
ind LExp
e forall a. [a] -> [a] -> [a]
++ String
" }"
show' [String]
env String
ind (LForce LExp
e) = String
"force{ " forall a. [a] -> [a] -> [a]
++ [String] -> String -> LExp -> String
show' [String]
env String
ind LExp
e forall a. [a] -> [a] -> [a]
++ String
" }"
show' [String]
env String
ind (LLet Name
n LExp
v LExp
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] -> String -> LExp -> String
show' [String]
env String
ind LExp
v
forall a. [a] -> [a] -> [a]
++ String
" in " forall a. [a] -> [a] -> [a]
++ [String] -> String -> LExp -> String
show' ([String]
env forall a. [a] -> [a] -> [a]
++ [forall a. Show a => a -> String
show Name
n]) String
ind LExp
e
show' [String]
env String
ind (LLam [Name]
args LExp
e)
= 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] -> String -> LExp -> String
show' ([String]
env forall a. [a] -> [a] -> [a]
++ (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Name]
args)) String
ind LExp
e forall a. [a] -> [a] -> [a]
++ String
") "
show' [String]
env String
ind (LProj LExp
t Int
i) = forall a. Show a => a -> String
show LExp
t forall a. [a] -> [a] -> [a]
++ String
"!" forall a. [a] -> [a] -> [a]
++ 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 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] -> String -> LExp -> String
show' [String]
env String
ind) [LExp]
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 String
ind (LCase CaseType
up LExp
e [LAlt]
alts)
= String
"case" forall a. [a] -> [a] -> [a]
++ String
update forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ [String] -> String -> LExp -> String
show' [String]
env String
ind LExp
e forall a. [a] -> [a] -> [a]
++ String
") of \n" 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" forall a. [a] -> [a] -> [a]
++ String
ind forall a. [a] -> [a] -> [a]
++ String
"| " forall a. [a] -> [a] -> [a]
++ [String] -> String -> LAlt -> String
showAlt [String]
env (String
ind forall a. [a] -> [a] -> [a]
++ String
" ") LAlt
alt
fmt (LAlt
alt:[LAlt]
as)
= String
"\t" forall a. [a] -> [a] -> [a]
++ String
ind forall a. [a] -> [a] -> [a]
++ String
"| " forall a. [a] -> [a] -> [a]
++ [String] -> String -> LAlt -> String
showAlt [String]
env (String
ind forall a. [a] -> [a] -> [a]
++ String
". ") LAlt
alt
forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ [LAlt] -> String
fmt [LAlt]
as
show' [String]
env String
ind (LConst Const
c) = forall a. Show a => a -> String
show Const
c
show' [String]
env String
ind (LForeign FDesc
ty FDesc
n [(FDesc, LExp)]
args) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"foreign{ "
, forall a. Show a => a -> String
show FDesc
n forall a. [a] -> [a] -> [a]
++ String
"("
, String -> [String] -> String
showSep String
", " (forall a b. (a -> b) -> [a] -> [b]
map (\(FDesc
ty,LExp
x) -> [String] -> String -> LExp -> String
show' [String]
env String
ind LExp
x forall a. [a] -> [a] -> [a]
++ String
" : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FDesc
ty) [(FDesc, LExp)]
args)
, String
") : "
, forall a. Show a => a -> String
show FDesc
ty
, String
" }"
]
show' [String]
env String
ind (LOp PrimFn
f [LExp]
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] -> String -> LExp -> String
show' [String]
env String
ind) [LExp]
args) forall a. [a] -> [a] -> [a]
++ String
")"
show' [String]
env String
ind (LError String
str) = String
"error " forall a. [a] -> [a] -> [a]
++ 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)
= 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] -> String -> LExp -> String
show' [String]
env String
ind LExp
e
showAlt [String]
env String
ind (LConstCase Const
c LExp
e) = forall a. Show a => a -> String
show Const
c forall a. [a] -> [a] -> [a]
++ String
" => " 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
"_ => " 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 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 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (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 forall a. Eq a => a -> a -> Bool
== Name
x then Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> Int
occName Name
n) [LExp]
es)
else forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (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 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 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 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) = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (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 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (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 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) = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> Int
occName Name
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(FDesc, LExp)]
es)
occName Name
n (LOp PrimFn
_ [LExp]
es) = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map (Name -> LExp -> Int
occName Name
n) [LExp]
es)
occName Name
n LExp
_ = Int
0