{-# LANGUAGE CPP #-}
module Generators.GenAnnotatedFlatCurry (genAnnotatedFlatCurry) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Monad ((<=<))
import Control.Monad.Extra (concatMapM)
import qualified Control.Monad.State as S ( State, evalState, get, gets
, modify, put )
import Data.Function (on)
import Data.List (nub, sortBy)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map (Map, empty, insert, lookup)
import qualified Data.Set as Set (Set, empty, insert, member)
import Curry.Base.Ident
import Curry.FlatCurry.Annotated.Goodies (typeName)
import Curry.FlatCurry.Annotated.Type
import qualified Curry.Syntax as CS
import Base.Messages (internalError)
import Base.NestEnv ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv
, nestEnv, unnestEnv )
import Base.Types
import CompilerEnv
import Env.TypeConstructor (TCEnv)
import qualified IL
genAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> AProg TypeExpr
genAnnotatedFlatCurry :: CompilerEnv -> Module Type -> Module -> AProg TypeExpr
genAnnotatedFlatCurry env :: CompilerEnv
env mdl :: Module Type
mdl il :: Module
il = AProg TypeExpr -> AProg TypeExpr
forall a. AProg a -> AProg a
patchPrelude (AProg TypeExpr -> AProg TypeExpr)
-> AProg TypeExpr -> AProg TypeExpr
forall a b. (a -> b) -> a -> b
$ CompilerEnv
-> Module Type -> FlatState (AProg TypeExpr) -> AProg TypeExpr
forall a. CompilerEnv -> Module Type -> FlatState a -> a
run CompilerEnv
env Module Type
mdl (Module -> FlatState (AProg TypeExpr)
trModule Module
il)
patchPrelude :: AProg a -> AProg a
patchPrelude :: AProg a -> AProg a
patchPrelude p :: AProg a
p@(AProg n :: String
n _ ts :: [TypeDecl]
ts fs :: [AFuncDecl a]
fs os :: [OpDecl]
os)
| String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
prelude = String
-> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> AProg a
forall a.
String
-> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> AProg a
AProg String
n [] [TypeDecl]
ts' [AFuncDecl a]
fs [OpDecl]
os
| Bool
otherwise = AProg a
p
where ts' :: [TypeDecl]
ts' = (TypeDecl -> TypeDecl -> Ordering) -> [TypeDecl] -> [TypeDecl]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (QName -> QName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (QName -> QName -> Ordering)
-> (TypeDecl -> QName) -> TypeDecl -> TypeDecl -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TypeDecl -> QName
typeName) [TypeDecl]
pts
pts :: [TypeDecl]
pts = [TypeDecl]
primTypes [TypeDecl] -> [TypeDecl] -> [TypeDecl]
forall a. [a] -> [a] -> [a]
++ [TypeDecl]
ts
primTypes :: [TypeDecl]
primTypes :: [TypeDecl]
primTypes =
[ QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
arrow Visibility
Public [(0, Kind
KStar), (1, Kind
KStar)] []
, QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
unit Visibility
Public [] [(QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
unit 0 Visibility
Public [])]
, QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
nil Visibility
Public [(0, Kind
KStar)] [ QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
nil 0 Visibility
Public []
, QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
cons 2 Visibility
Public [Int -> TypeExpr
TVar 0, QName -> [TypeExpr] -> TypeExpr
TCons QName
nil [Int -> TypeExpr
TVar 0]]
]
] [TypeDecl] -> [TypeDecl] -> [TypeDecl]
forall a. [a] -> [a] -> [a]
++ (Int -> TypeDecl) -> [Int] -> [TypeDecl]
forall a b. (a -> b) -> [a] -> [b]
map Int -> TypeDecl
mkTupleType [2 .. Int
maxTupleArity]
where arrow :: QName
arrow = String -> QName
mkPreludeQName "(->)"
unit :: QName
unit = String -> QName
mkPreludeQName "()"
nil :: QName
nil = String -> QName
mkPreludeQName "[]"
cons :: QName
cons = String -> QName
mkPreludeQName ":"
mkTupleType :: Int -> TypeDecl
mkTupleType :: Int -> TypeDecl
mkTupleType arity :: Int
arity = QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
tuple Visibility
Public [(Int
i, Kind
KStar) | Int
i <- [0 .. Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]]
[QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
tuple Int
arity Visibility
Public ([TypeExpr] -> ConsDecl) -> [TypeExpr] -> ConsDecl
forall a b. (a -> b) -> a -> b
$ (Int -> TypeExpr) -> [Int] -> [TypeExpr]
forall a b. (a -> b) -> [a] -> [b]
map Int -> TypeExpr
TVar [0 .. Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1]]
where tuple :: QName
tuple = String -> QName
mkPreludeQName (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ '(' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) ',' String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
mkPreludeQName :: String -> QName
mkPreludeQName :: String -> QName
mkPreludeQName n :: String
n = (String
prelude, String
n)
prelude :: String
prelude :: String
prelude = "Prelude"
maxTupleArity :: Int
maxTupleArity :: Int
maxTupleArity = 15
type FlatState a = S.State FlatEnv a
data FlatEnv = FlatEnv
{ FlatEnv -> ModuleIdent
modIdent :: ModuleIdent
, FlatEnv -> Set Ident
tyExports :: Set.Set Ident
, FlatEnv -> Set Ident
valExports :: Set.Set Ident
, FlatEnv -> TCEnv
tcEnv :: TCEnv
, FlatEnv -> [Decl Type]
typeSynonyms :: [CS.Decl Type]
, FlatEnv -> [ModuleIdent]
imports :: [ModuleIdent]
, FlatEnv -> Int
nextVar :: Int
, FlatEnv -> NestEnv Int
varMap :: NestEnv VarIndex
}
run :: CompilerEnv -> CS.Module Type -> FlatState a -> a
run :: CompilerEnv -> Module Type -> FlatState a -> a
run env :: CompilerEnv
env (CS.Module _ _ _ mid :: ModuleIdent
mid es :: Maybe ExportSpec
es is :: [ImportDecl]
is ds :: [Decl Type]
ds) act :: FlatState a
act = FlatState a -> FlatEnv -> a
forall s a. State s a -> s -> a
S.evalState FlatState a
act FlatEnv
env0
where
es' :: [Export]
es' = case Maybe ExportSpec
es of Just (CS.Exporting _ e :: [Export]
e) -> [Export]
e
_ -> []
env0 :: FlatEnv
env0 = FlatEnv :: ModuleIdent
-> Set Ident
-> Set Ident
-> TCEnv
-> [Decl Type]
-> [ModuleIdent]
-> Int
-> NestEnv Int
-> FlatEnv
FlatEnv
{ modIdent :: ModuleIdent
modIdent = ModuleIdent
mid
, tyExports :: Set Ident
tyExports = (Export -> Set Ident -> Set Ident)
-> Set Ident -> [Export] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent -> Export -> Set Ident -> Set Ident
buildTypeExports ModuleIdent
mid) Set Ident
forall a. Set a
Set.empty [Export]
es'
, valExports :: Set Ident
valExports = (Export -> Set Ident -> Set Ident)
-> Set Ident -> [Export] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ModuleIdent -> Export -> Set Ident -> Set Ident
buildValueExports ModuleIdent
mid) Set Ident
forall a. Set a
Set.empty [Export]
es'
, imports :: [ModuleIdent]
imports = [ModuleIdent] -> [ModuleIdent]
forall a. Eq a => [a] -> [a]
nub [ ModuleIdent
m | CS.ImportDecl _ m :: ModuleIdent
m _ _ _ <- [ImportDecl]
is ]
, tcEnv :: TCEnv
tcEnv = CompilerEnv -> TCEnv
tyConsEnv CompilerEnv
env
, typeSynonyms :: [Decl Type]
typeSynonyms = [ Decl Type
d | d :: Decl Type
d@CS.TypeDecl{} <- [Decl Type]
ds ]
, nextVar :: Int
nextVar = 0
, varMap :: NestEnv Int
varMap = NestEnv Int
forall a. NestEnv a
emptyEnv
}
buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident
buildTypeExports :: ModuleIdent -> Export -> Set Ident -> Set Ident
buildTypeExports mid :: ModuleIdent
mid (CS.ExportTypeWith _ tc :: QualIdent
tc _)
| ModuleIdent -> QualIdent -> Bool
isLocalIdent ModuleIdent
mid QualIdent
tc = Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert (QualIdent -> Ident
unqualify QualIdent
tc)
buildTypeExports _ _ = Set Ident -> Set Ident
forall a. a -> a
id
buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident
buildValueExports :: ModuleIdent -> Export -> Set Ident -> Set Ident
buildValueExports mid :: ModuleIdent
mid (CS.Export _ q :: QualIdent
q)
| ModuleIdent -> QualIdent -> Bool
isLocalIdent ModuleIdent
mid QualIdent
q = Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert (QualIdent -> Ident
unqualify QualIdent
q)
buildValueExports mid :: ModuleIdent
mid (CS.ExportTypeWith _ tc :: QualIdent
tc cs :: [Ident]
cs)
| ModuleIdent -> QualIdent -> Bool
isLocalIdent ModuleIdent
mid QualIdent
tc = (Set Ident -> [Ident] -> Set Ident)
-> [Ident] -> Set Ident -> Set Ident
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ident -> Set Ident -> Set Ident)
-> Set Ident -> [Ident] -> Set Ident
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Ident -> Set Ident -> Set Ident
forall a. Ord a => a -> Set a -> Set a
Set.insert) [Ident]
cs
buildValueExports _ _ = Set Ident -> Set Ident
forall a. a -> a
id
getModuleIdent :: FlatState ModuleIdent
getModuleIdent :: FlatState ModuleIdent
getModuleIdent = (FlatEnv -> ModuleIdent) -> FlatState ModuleIdent
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> ModuleIdent
modIdent
getImports :: [ModuleIdent] -> FlatState [String]
getImports :: [ModuleIdent] -> FlatState [String]
getImports imps :: [ModuleIdent]
imps = ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub ([String] -> [String])
-> ([ModuleIdent] -> [String]) -> [ModuleIdent] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleIdent -> String) -> [ModuleIdent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ModuleIdent -> String
moduleName ([ModuleIdent] -> [String])
-> ([ModuleIdent] -> [ModuleIdent]) -> [ModuleIdent] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ModuleIdent]
imps [ModuleIdent] -> [ModuleIdent] -> [ModuleIdent]
forall a. [a] -> [a] -> [a]
++)) ([ModuleIdent] -> [String])
-> StateT FlatEnv Identity [ModuleIdent] -> FlatState [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FlatEnv -> [ModuleIdent]) -> StateT FlatEnv Identity [ModuleIdent]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> [ModuleIdent]
imports
withFreshEnv :: FlatState a -> FlatState a
withFreshEnv :: FlatState a -> FlatState a
withFreshEnv act :: FlatState a
act = (FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify (\ s :: FlatEnv
s -> FlatEnv
s { nextVar :: Int
nextVar = 0, varMap :: NestEnv Int
varMap = NestEnv Int
forall a. NestEnv a
emptyEnv }) StateT FlatEnv Identity () -> FlatState a -> FlatState a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FlatState a
act
inNestedEnv :: FlatState a -> FlatState a
inNestedEnv :: FlatState a -> FlatState a
inNestedEnv act :: FlatState a
act = do
(FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ())
-> (FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall a b. (a -> b) -> a -> b
$ \ s :: FlatEnv
s -> FlatEnv
s { varMap :: NestEnv Int
varMap = NestEnv Int -> NestEnv Int
forall a. NestEnv a -> NestEnv a
nestEnv (NestEnv Int -> NestEnv Int) -> NestEnv Int -> NestEnv Int
forall a b. (a -> b) -> a -> b
$ FlatEnv -> NestEnv Int
varMap FlatEnv
s }
a
res <- FlatState a
act
(FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ())
-> (FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall a b. (a -> b) -> a -> b
$ \ s :: FlatEnv
s -> FlatEnv
s { varMap :: NestEnv Int
varMap = NestEnv Int -> NestEnv Int
forall a. NestEnv a -> NestEnv a
unnestEnv (NestEnv Int -> NestEnv Int) -> NestEnv Int -> NestEnv Int
forall a b. (a -> b) -> a -> b
$ FlatEnv -> NestEnv Int
varMap FlatEnv
s }
a -> FlatState a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
newVar :: IL.Type -> Ident -> FlatState (VarIndex, TypeExpr)
newVar :: Type -> Ident -> FlatState (Int, TypeExpr)
newVar ty :: Type
ty i :: Ident
i = do
Int
idx <- (Int -> Int -> Int
forall a. Num a => a -> a -> a
+1) (Int -> Int)
-> StateT FlatEnv Identity Int -> StateT FlatEnv Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FlatEnv -> Int) -> StateT FlatEnv Identity Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> Int
nextVar
(FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
S.modify ((FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ())
-> (FlatEnv -> FlatEnv) -> StateT FlatEnv Identity ()
forall a b. (a -> b) -> a -> b
$ \ s :: FlatEnv
s -> FlatEnv
s { nextVar :: Int
nextVar = Int
idx, varMap :: NestEnv Int
varMap = Ident -> Int -> NestEnv Int -> NestEnv Int
forall a. Ident -> a -> NestEnv a -> NestEnv a
bindNestEnv Ident
i Int
idx (FlatEnv -> NestEnv Int
varMap FlatEnv
s) }
TypeExpr
ty' <- Type -> FlatState TypeExpr
trType Type
ty
(Int, TypeExpr) -> FlatState (Int, TypeExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
idx, TypeExpr
ty')
getVarIndex :: Ident -> FlatState VarIndex
getVarIndex :: Ident -> StateT FlatEnv Identity Int
getVarIndex i :: Ident
i = (FlatEnv -> NestEnv Int) -> StateT FlatEnv Identity (NestEnv Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> NestEnv Int
varMap StateT FlatEnv Identity (NestEnv Int)
-> (NestEnv Int -> StateT FlatEnv Identity Int)
-> StateT FlatEnv Identity Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ varEnv :: NestEnv Int
varEnv -> case Ident -> NestEnv Int -> [Int]
forall a. Ident -> NestEnv a -> [a]
lookupNestEnv Ident
i NestEnv Int
varEnv of
[v :: Int
v] -> Int -> StateT FlatEnv Identity Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
v
_ -> String -> StateT FlatEnv Identity Int
forall a. String -> a
internalError (String -> StateT FlatEnv Identity Int)
-> String -> StateT FlatEnv Identity Int
forall a b. (a -> b) -> a -> b
$ "GenTypeAnnotatedFlatCurry.getVarIndex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
escName Ident
i
trModule :: IL.Module -> FlatState (AProg TypeExpr)
trModule :: Module -> FlatState (AProg TypeExpr)
trModule (IL.Module mid :: ModuleIdent
mid is :: [ModuleIdent]
is ds :: [Decl]
ds) = do
[String]
is' <- [ModuleIdent] -> FlatState [String]
getImports [ModuleIdent]
is
[TypeDecl]
tds <- (Decl -> StateT FlatEnv Identity [TypeDecl])
-> [Decl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl -> StateT FlatEnv Identity [TypeDecl]
trTypeDecl [Decl]
ds
[AFuncDecl TypeExpr]
fds <- (Decl -> StateT FlatEnv Identity [AFuncDecl TypeExpr])
-> [Decl] -> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ([AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return ([AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr])
-> ([AFuncDecl TypeExpr] -> [AFuncDecl TypeExpr])
-> [AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AFuncDecl TypeExpr -> AFuncDecl TypeExpr)
-> [AFuncDecl TypeExpr] -> [AFuncDecl TypeExpr]
forall a b. (a -> b) -> [a] -> [b]
map AFuncDecl TypeExpr -> AFuncDecl TypeExpr
forall a. Normalize a => a -> a
runNormalization ([AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr])
-> (Decl -> StateT FlatEnv Identity [AFuncDecl TypeExpr])
-> Decl
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Decl -> StateT FlatEnv Identity [AFuncDecl TypeExpr]
trAFuncDecl) [Decl]
ds
AProg TypeExpr -> FlatState (AProg TypeExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AProg TypeExpr -> FlatState (AProg TypeExpr))
-> AProg TypeExpr -> FlatState (AProg TypeExpr)
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> [TypeDecl]
-> [AFuncDecl TypeExpr]
-> [OpDecl]
-> AProg TypeExpr
forall a.
String
-> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> AProg a
AProg (ModuleIdent -> String
moduleName ModuleIdent
mid) [String]
is' [TypeDecl]
tds [AFuncDecl TypeExpr]
fds []
trTypeDecl :: IL.Decl -> FlatState [TypeDecl]
trTypeDecl :: Decl -> StateT FlatEnv Identity [TypeDecl]
trTypeDecl (IL.DataDecl qid :: QualIdent
qid ks :: [Kind]
ks []) = do
QName
q' <- QualIdent -> FlatState QName
trQualIdent QualIdent
qid
Visibility
vis <- QualIdent -> FlatState Visibility
getTypeVisibility QualIdent
qid
QName
c <- QualIdent -> FlatState QName
trQualIdent (QualIdent -> FlatState QName) -> QualIdent -> FlatState QName
forall a b. (a -> b) -> a -> b
$ Ident -> QualIdent
qualify (String -> Ident
mkIdent (String -> Ident) -> String -> Ident
forall a b. (a -> b) -> a -> b
$ "_Constr#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
idName (QualIdent -> Ident
unqualify QualIdent
qid))
let ks' :: [Kind]
ks' = Kind -> Kind
trKind (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
ks
tvs :: [TVarWithKind]
tvs = [Int] -> [Kind] -> [TVarWithKind]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Kind]
ks'
[TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
q' Visibility
vis [TVarWithKind]
tvs [QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
c 1 Visibility
Private [QName -> [TypeExpr] -> TypeExpr
TCons QName
q' ([TypeExpr] -> TypeExpr) -> [TypeExpr] -> TypeExpr
forall a b. (a -> b) -> a -> b
$ Int -> TypeExpr
TVar (Int -> TypeExpr)
-> (TVarWithKind -> Int) -> TVarWithKind -> TypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVarWithKind -> Int
forall a b. (a, b) -> a
fst (TVarWithKind -> TypeExpr) -> [TVarWithKind] -> [TypeExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TVarWithKind]
tvs]]]
trTypeDecl (IL.DataDecl qid :: QualIdent
qid ks :: [Kind]
ks cs :: [ConstrDecl]
cs) = do
QName
q' <- QualIdent -> FlatState QName
trQualIdent QualIdent
qid
Visibility
vis <- QualIdent -> FlatState Visibility
getTypeVisibility QualIdent
qid
[ConsDecl]
cs' <- (ConstrDecl -> StateT FlatEnv Identity ConsDecl)
-> [ConstrDecl] -> StateT FlatEnv Identity [ConsDecl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ConstrDecl -> StateT FlatEnv Identity ConsDecl
trConstrDecl [ConstrDecl]
cs
let ks' :: [Kind]
ks' = Kind -> Kind
trKind (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
ks
tvs :: [TVarWithKind]
tvs = [Int] -> [Kind] -> [TVarWithKind]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Kind]
ks'
[TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
q' Visibility
vis [TVarWithKind]
tvs [ConsDecl]
cs']
trTypeDecl (IL.NewtypeDecl qid :: QualIdent
qid ks :: [Kind]
ks nc :: NewConstrDecl
nc) = do
QName
q' <- QualIdent -> FlatState QName
trQualIdent QualIdent
qid
Visibility
vis <- QualIdent -> FlatState Visibility
getTypeVisibility QualIdent
qid
NewConsDecl
nc' <- NewConstrDecl -> FlatState NewConsDecl
trNewConstrDecl NewConstrDecl
nc
let ks' :: [Kind]
ks' = Kind -> Kind
trKind (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
ks
tvs :: [TVarWithKind]
tvs = [Int] -> [Kind] -> [TVarWithKind]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Kind]
ks'
[TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarWithKind] -> NewConsDecl -> TypeDecl
TypeNew QName
q' Visibility
vis [TVarWithKind]
tvs NewConsDecl
nc']
trTypeDecl (IL.ExternalDataDecl qid :: QualIdent
qid ks :: [Kind]
ks) = do
QName
q' <- QualIdent -> FlatState QName
trQualIdent QualIdent
qid
Visibility
vis <- QualIdent -> FlatState Visibility
getTypeVisibility QualIdent
qid
let ks' :: [Kind]
ks' = Kind -> Kind
trKind (Kind -> Kind) -> [Kind] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Kind]
ks
tvs :: [TVarWithKind]
tvs = [Int] -> [Kind] -> [TVarWithKind]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [Kind]
ks'
[TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarWithKind] -> [ConsDecl] -> TypeDecl
Type QName
q' Visibility
vis [TVarWithKind]
tvs []]
trTypeDecl _ = [TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []
trConstrDecl :: IL.ConstrDecl -> FlatState ConsDecl
trConstrDecl :: ConstrDecl -> StateT FlatEnv Identity ConsDecl
trConstrDecl (IL.ConstrDecl qid :: QualIdent
qid tys :: [Type]
tys) = (QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl)
-> Int -> QName -> Visibility -> [TypeExpr] -> ConsDecl
forall a b c. (a -> b -> c) -> b -> a -> c
flip QName -> Int -> Visibility -> [TypeExpr] -> ConsDecl
Cons ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys)
(QName -> Visibility -> [TypeExpr] -> ConsDecl)
-> FlatState QName
-> StateT FlatEnv Identity (Visibility -> [TypeExpr] -> ConsDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> FlatState QName
trQualIdent QualIdent
qid
StateT FlatEnv Identity (Visibility -> [TypeExpr] -> ConsDecl)
-> FlatState Visibility
-> StateT FlatEnv Identity ([TypeExpr] -> ConsDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QualIdent -> FlatState Visibility
getVisibility QualIdent
qid
StateT FlatEnv Identity ([TypeExpr] -> ConsDecl)
-> StateT FlatEnv Identity [TypeExpr]
-> StateT FlatEnv Identity ConsDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> FlatState TypeExpr)
-> [Type] -> StateT FlatEnv Identity [TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> FlatState TypeExpr
trType [Type]
tys
trNewConstrDecl :: IL.NewConstrDecl -> FlatState NewConsDecl
trNewConstrDecl :: NewConstrDecl -> FlatState NewConsDecl
trNewConstrDecl (IL.NewConstrDecl qid :: QualIdent
qid ty :: Type
ty) = QName -> Visibility -> TypeExpr -> NewConsDecl
NewCons
(QName -> Visibility -> TypeExpr -> NewConsDecl)
-> FlatState QName
-> StateT FlatEnv Identity (Visibility -> TypeExpr -> NewConsDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> FlatState QName
trQualIdent QualIdent
qid
StateT FlatEnv Identity (Visibility -> TypeExpr -> NewConsDecl)
-> FlatState Visibility
-> StateT FlatEnv Identity (TypeExpr -> NewConsDecl)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QualIdent -> FlatState Visibility
getVisibility QualIdent
qid
StateT FlatEnv Identity (TypeExpr -> NewConsDecl)
-> FlatState TypeExpr -> FlatState NewConsDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> FlatState TypeExpr
trType Type
ty
trType :: IL.Type -> FlatState TypeExpr
trType :: Type -> FlatState TypeExpr
trType (IL.TypeConstructor t :: QualIdent
t tys :: [Type]
tys) = QName -> [TypeExpr] -> TypeExpr
TCons (QName -> [TypeExpr] -> TypeExpr)
-> FlatState QName
-> StateT FlatEnv Identity ([TypeExpr] -> TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> FlatState QName
trQualIdent QualIdent
t StateT FlatEnv Identity ([TypeExpr] -> TypeExpr)
-> StateT FlatEnv Identity [TypeExpr] -> FlatState TypeExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> FlatState TypeExpr)
-> [Type] -> StateT FlatEnv Identity [TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> FlatState TypeExpr
trType [Type]
tys
trType (IL.TypeVariable idx :: Int
idx) = TypeExpr -> FlatState TypeExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeExpr -> FlatState TypeExpr) -> TypeExpr -> FlatState TypeExpr
forall a b. (a -> b) -> a -> b
$ Int -> TypeExpr
TVar (Int -> TypeExpr) -> Int -> TypeExpr
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
abs Int
idx
trType (IL.TypeArrow ty1 :: Type
ty1 ty2 :: Type
ty2) = TypeExpr -> TypeExpr -> TypeExpr
FuncType (TypeExpr -> TypeExpr -> TypeExpr)
-> FlatState TypeExpr
-> StateT FlatEnv Identity (TypeExpr -> TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty1 StateT FlatEnv Identity (TypeExpr -> TypeExpr)
-> FlatState TypeExpr -> FlatState TypeExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> FlatState TypeExpr
trType Type
ty2
trType (IL.TypeForall idxs :: [TypeVariableWithKind]
idxs ty :: Type
ty) = [TVarWithKind] -> TypeExpr -> TypeExpr
ForallType ((TypeVariableWithKind -> TVarWithKind)
-> [TypeVariableWithKind] -> [TVarWithKind]
forall a b. (a -> b) -> [a] -> [b]
map TypeVariableWithKind -> TVarWithKind
trTVarWithKind [TypeVariableWithKind]
idxs) (TypeExpr -> TypeExpr) -> FlatState TypeExpr -> FlatState TypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty
trTVarWithKind :: (Int, IL.Kind) -> (Int, Kind)
trTVarWithKind :: TypeVariableWithKind -> TVarWithKind
trTVarWithKind (i :: Int
i, k :: Kind
k) = (Int -> Int
forall a. Num a => a -> a
abs Int
i, Kind -> Kind
trKind Kind
k)
trKind :: IL.Kind -> Kind
trKind :: Kind -> Kind
trKind IL.KindStar = Kind
KStar
trKind (IL.KindVariable _) = Kind
KStar
trKind (IL.KindArrow k1 :: Kind
k1 k2 :: Kind
k2) = Kind -> Kind -> Kind
KArrow (Kind -> Kind
trKind Kind
k1) (Kind -> Kind
trKind Kind
k2)
trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr]
trAFuncDecl :: Decl -> StateT FlatEnv Identity [AFuncDecl TypeExpr]
trAFuncDecl (IL.FunctionDecl f :: QualIdent
f vs :: [(Type, Ident)]
vs ty :: Type
ty e :: Expression
e) = do
QName
f' <- QualIdent -> FlatState QName
trQualIdent QualIdent
f
Visibility
vis <- QualIdent -> FlatState Visibility
getVisibility QualIdent
f
TypeExpr
ty' <- Type -> FlatState TypeExpr
trType Type
ty
ARule TypeExpr
r' <- Type -> [(Type, Ident)] -> Expression -> FlatState (ARule TypeExpr)
trARule Type
ty [(Type, Ident)]
vs Expression
e
[AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName
-> Int
-> Visibility
-> TypeExpr
-> ARule TypeExpr
-> AFuncDecl TypeExpr
forall a.
QName -> Int -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
AFunc QName
f' ([(Type, Ident)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Type, Ident)]
vs) Visibility
vis TypeExpr
ty' ARule TypeExpr
r']
trAFuncDecl (IL.ExternalDecl f :: QualIdent
f a :: Int
a ty :: Type
ty) = do
QName
f' <- QualIdent -> FlatState QName
trQualIdent QualIdent
f
Visibility
vis <- QualIdent -> FlatState Visibility
getVisibility QualIdent
f
TypeExpr
ty' <- Type -> FlatState TypeExpr
trType Type
ty
ARule TypeExpr
r' <- Type -> QualIdent -> FlatState (ARule TypeExpr)
trAExternal Type
ty QualIdent
f
[AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName
-> Int
-> Visibility
-> TypeExpr
-> ARule TypeExpr
-> AFuncDecl TypeExpr
forall a.
QName -> Int -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
AFunc QName
f' Int
a Visibility
vis TypeExpr
ty' ARule TypeExpr
r']
trAFuncDecl _ = [AFuncDecl TypeExpr]
-> StateT FlatEnv Identity [AFuncDecl TypeExpr]
forall (m :: * -> *) a. Monad m => a -> m a
return []
trARule :: IL.Type -> [(IL.Type, Ident)] -> IL.Expression
-> FlatState (ARule TypeExpr)
trARule :: Type -> [(Type, Ident)] -> Expression -> FlatState (ARule TypeExpr)
trARule ty :: Type
ty vs :: [(Type, Ident)]
vs e :: Expression
e = FlatState (ARule TypeExpr) -> FlatState (ARule TypeExpr)
forall a. FlatState a -> FlatState a
withFreshEnv (FlatState (ARule TypeExpr) -> FlatState (ARule TypeExpr))
-> FlatState (ARule TypeExpr) -> FlatState (ARule TypeExpr)
forall a b. (a -> b) -> a -> b
$ TypeExpr -> [(Int, TypeExpr)] -> AExpr TypeExpr -> ARule TypeExpr
forall a. a -> [(Int, a)] -> AExpr a -> ARule a
ARule (TypeExpr -> [(Int, TypeExpr)] -> AExpr TypeExpr -> ARule TypeExpr)
-> FlatState TypeExpr
-> StateT
FlatEnv
Identity
([(Int, TypeExpr)] -> AExpr TypeExpr -> ARule TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty
StateT
FlatEnv
Identity
([(Int, TypeExpr)] -> AExpr TypeExpr -> ARule TypeExpr)
-> StateT FlatEnv Identity [(Int, TypeExpr)]
-> StateT FlatEnv Identity (AExpr TypeExpr -> ARule TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Type, Ident) -> FlatState (Int, TypeExpr))
-> [(Type, Ident)] -> StateT FlatEnv Identity [(Int, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Ident -> FlatState (Int, TypeExpr))
-> (Type, Ident) -> FlatState (Int, TypeExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> FlatState (Int, TypeExpr)
newVar) [(Type, Ident)]
vs
StateT FlatEnv Identity (AExpr TypeExpr -> ARule TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> FlatState (ARule TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr)
trAExternal :: Type -> QualIdent -> FlatState (ARule TypeExpr)
trAExternal ty :: Type
ty f :: QualIdent
f = (TypeExpr -> String -> ARule TypeExpr)
-> String -> TypeExpr -> ARule TypeExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeExpr -> String -> ARule TypeExpr
forall a. a -> String -> ARule a
AExternal (QualIdent -> String
qualName QualIdent
f) (TypeExpr -> ARule TypeExpr)
-> FlatState TypeExpr -> FlatState (ARule TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty
trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr)
trAExpr :: Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr (IL.Literal ty :: Type
ty l :: Literal
l) = TypeExpr -> Literal -> AExpr TypeExpr
forall a. a -> Literal -> AExpr a
ALit (TypeExpr -> Literal -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT FlatEnv Identity (Literal -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT FlatEnv Identity (Literal -> AExpr TypeExpr)
-> StateT FlatEnv Identity Literal
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Literal -> StateT FlatEnv Identity Literal
trLiteral Literal
l
trAExpr (IL.Variable ty :: Type
ty v :: Ident
v) = TypeExpr -> Int -> AExpr TypeExpr
forall a. a -> Int -> AExpr a
AVar (TypeExpr -> Int -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT FlatEnv Identity (Int -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT FlatEnv Identity (Int -> AExpr TypeExpr)
-> StateT FlatEnv Identity Int
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> StateT FlatEnv Identity Int
getVarIndex Ident
v
trAExpr (IL.Function ty :: Type
ty f :: QualIdent
f a :: Int
a) = Call
-> Type
-> QualIdent
-> Int
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Fun Type
ty QualIdent
f Int
a []
trAExpr (IL.Constructor ty :: Type
ty c :: QualIdent
c a :: Int
a) = Call
-> Type
-> QualIdent
-> Int
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Con Type
ty QualIdent
c Int
a []
trAExpr (IL.Apply e1 :: Expression
e1 e2 :: Expression
e2) = Expression
-> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trApply Expression
e1 Expression
e2
trAExpr c :: Expression
c@(IL.Case t :: Eval
t e :: Expression
e bs :: [Alt]
bs) = (TypeExpr
-> CaseType
-> AExpr TypeExpr
-> [ABranchExpr TypeExpr]
-> AExpr TypeExpr)
-> CaseType
-> TypeExpr
-> AExpr TypeExpr
-> [ABranchExpr TypeExpr]
-> AExpr TypeExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeExpr
-> CaseType
-> AExpr TypeExpr
-> [ABranchExpr TypeExpr]
-> AExpr TypeExpr
forall a. a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a
ACase (Eval -> CaseType
cvEval Eval
t) (TypeExpr
-> AExpr TypeExpr -> [ABranchExpr TypeExpr] -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT
FlatEnv
Identity
(AExpr TypeExpr -> [ABranchExpr TypeExpr] -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType (Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
c) StateT
FlatEnv
Identity
(AExpr TypeExpr -> [ABranchExpr TypeExpr] -> AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT
FlatEnv Identity ([ABranchExpr TypeExpr] -> AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
StateT FlatEnv Identity ([ABranchExpr TypeExpr] -> AExpr TypeExpr)
-> StateT FlatEnv Identity [ABranchExpr TypeExpr]
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt -> StateT FlatEnv Identity (ABranchExpr TypeExpr))
-> [Alt] -> StateT FlatEnv Identity [ABranchExpr TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StateT FlatEnv Identity (ABranchExpr TypeExpr)
-> StateT FlatEnv Identity (ABranchExpr TypeExpr)
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity (ABranchExpr TypeExpr)
-> StateT FlatEnv Identity (ABranchExpr TypeExpr))
-> (Alt -> StateT FlatEnv Identity (ABranchExpr TypeExpr))
-> Alt
-> StateT FlatEnv Identity (ABranchExpr TypeExpr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt -> StateT FlatEnv Identity (ABranchExpr TypeExpr)
trAlt) [Alt]
bs
trAExpr (IL.Or e1 :: Expression
e1 e2 :: Expression
e2) = TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr
forall a. a -> AExpr a -> AExpr a -> AExpr a
AOr (TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT
FlatEnv
Identity
(AExpr TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType (Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
e1) StateT
FlatEnv
Identity
(AExpr TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e1 StateT FlatEnv Identity (AExpr TypeExpr -> AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e2
trAExpr (IL.Exist v :: Ident
v ty :: Type
ty e :: Expression
e) = StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr))
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ do
(Int, TypeExpr)
v' <- Type -> Ident -> FlatState (Int, TypeExpr)
newVar Type
ty Ident
v
AExpr TypeExpr
e' <- Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
TypeExpr
ty' <- Type -> FlatState TypeExpr
trType (Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
e)
AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr))
-> AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ case AExpr TypeExpr
e' of AFree ty'' :: TypeExpr
ty'' vs :: [(Int, TypeExpr)]
vs e'' :: AExpr TypeExpr
e'' -> TypeExpr -> [(Int, TypeExpr)] -> AExpr TypeExpr -> AExpr TypeExpr
forall a. a -> [(Int, a)] -> AExpr a -> AExpr a
AFree TypeExpr
ty'' ((Int, TypeExpr)
v' (Int, TypeExpr) -> [(Int, TypeExpr)] -> [(Int, TypeExpr)]
forall a. a -> [a] -> [a]
: [(Int, TypeExpr)]
vs) AExpr TypeExpr
e''
_ -> TypeExpr -> [(Int, TypeExpr)] -> AExpr TypeExpr -> AExpr TypeExpr
forall a. a -> [(Int, a)] -> AExpr a -> AExpr a
AFree TypeExpr
ty' ((Int, TypeExpr)
v' (Int, TypeExpr) -> [(Int, TypeExpr)] -> [(Int, TypeExpr)]
forall a. a -> [a] -> [a]
: []) AExpr TypeExpr
e'
trAExpr (IL.Let (IL.Binding v :: Ident
v b :: Expression
b) e :: Expression
e) = StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr))
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ do
(Int, TypeExpr)
v' <- Type -> Ident -> FlatState (Int, TypeExpr)
newVar (Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
b) Ident
v
AExpr TypeExpr
b' <- Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
b
AExpr TypeExpr
e' <- Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
TypeExpr
ty' <- Type -> FlatState TypeExpr
trType (Type -> FlatState TypeExpr) -> Type -> FlatState TypeExpr
forall a b. (a -> b) -> a -> b
$ Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
e
AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr))
-> AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ case AExpr TypeExpr
e' of ALet ty'' :: TypeExpr
ty'' bs :: [((Int, TypeExpr), AExpr TypeExpr)]
bs e'' :: AExpr TypeExpr
e'' -> TypeExpr
-> [((Int, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr
-> AExpr TypeExpr
forall a. a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a
ALet TypeExpr
ty'' (((Int, TypeExpr)
v', AExpr TypeExpr
b')((Int, TypeExpr), AExpr TypeExpr)
-> [((Int, TypeExpr), AExpr TypeExpr)]
-> [((Int, TypeExpr), AExpr TypeExpr)]
forall a. a -> [a] -> [a]
:[((Int, TypeExpr), AExpr TypeExpr)]
bs) AExpr TypeExpr
e''
_ -> TypeExpr
-> [((Int, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr
-> AExpr TypeExpr
forall a. a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a
ALet TypeExpr
ty' (((Int, TypeExpr)
v', AExpr TypeExpr
b')((Int, TypeExpr), AExpr TypeExpr)
-> [((Int, TypeExpr), AExpr TypeExpr)]
-> [((Int, TypeExpr), AExpr TypeExpr)]
forall a. a -> [a] -> [a]
:[]) AExpr TypeExpr
e'
trAExpr (IL.Letrec bs :: [Binding]
bs e :: Expression
e) = StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr))
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ do
let (vs :: [(Type, Ident)]
vs, es :: [Expression]
es) = [((Type, Ident), Expression)] -> ([(Type, Ident)], [Expression])
forall a b. [(a, b)] -> ([a], [b])
unzip [ ((Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
b, Ident
v), Expression
b) | IL.Binding v :: Ident
v b :: Expression
b <- [Binding]
bs]
TypeExpr
-> [((Int, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr
-> AExpr TypeExpr
forall a. a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a
ALet (TypeExpr
-> [((Int, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr
-> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT
FlatEnv
Identity
([((Int, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType (Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
e)
StateT
FlatEnv
Identity
([((Int, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr -> AExpr TypeExpr)
-> StateT FlatEnv Identity [((Int, TypeExpr), AExpr TypeExpr)]
-> StateT FlatEnv Identity (AExpr TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(Int, TypeExpr)]
-> [AExpr TypeExpr] -> [((Int, TypeExpr), AExpr TypeExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([(Int, TypeExpr)]
-> [AExpr TypeExpr] -> [((Int, TypeExpr), AExpr TypeExpr)])
-> StateT FlatEnv Identity [(Int, TypeExpr)]
-> StateT
FlatEnv
Identity
([AExpr TypeExpr] -> [((Int, TypeExpr), AExpr TypeExpr)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type, Ident) -> FlatState (Int, TypeExpr))
-> [(Type, Ident)] -> StateT FlatEnv Identity [(Int, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Ident -> FlatState (Int, TypeExpr))
-> (Type, Ident) -> FlatState (Int, TypeExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> FlatState (Int, TypeExpr)
newVar) [(Type, Ident)]
vs StateT
FlatEnv
Identity
([AExpr TypeExpr] -> [((Int, TypeExpr), AExpr TypeExpr)])
-> StateT FlatEnv Identity [AExpr TypeExpr]
-> StateT FlatEnv Identity [((Int, TypeExpr), AExpr TypeExpr)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expression -> StateT FlatEnv Identity (AExpr TypeExpr))
-> [Expression] -> StateT FlatEnv Identity [AExpr TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr [Expression]
es)
StateT FlatEnv Identity (AExpr TypeExpr -> AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
trAExpr (IL.Typed e :: Expression
e ty :: Type
ty) = TypeExpr -> AExpr TypeExpr -> TypeExpr -> AExpr TypeExpr
forall a. a -> AExpr a -> TypeExpr -> AExpr a
ATyped (TypeExpr -> AExpr TypeExpr -> TypeExpr -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT
FlatEnv Identity (AExpr TypeExpr -> TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FlatState TypeExpr
ty' StateT
FlatEnv Identity (AExpr TypeExpr -> TypeExpr -> AExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e StateT FlatEnv Identity (TypeExpr -> AExpr TypeExpr)
-> FlatState TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FlatState TypeExpr
ty'
where ty' :: FlatState TypeExpr
ty' = Type -> FlatState TypeExpr
trType (Type -> FlatState TypeExpr) -> Type -> FlatState TypeExpr
forall a b. (a -> b) -> a -> b
$ Type
ty
trLiteral :: IL.Literal -> FlatState Literal
trLiteral :: Literal -> StateT FlatEnv Identity Literal
trLiteral (IL.Char c :: Char
c) = Literal -> StateT FlatEnv Identity Literal
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> StateT FlatEnv Identity Literal)
-> Literal -> StateT FlatEnv Identity Literal
forall a b. (a -> b) -> a -> b
$ Char -> Literal
Charc Char
c
trLiteral (IL.Int i :: Integer
i) = Literal -> StateT FlatEnv Identity Literal
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> StateT FlatEnv Identity Literal)
-> Literal -> StateT FlatEnv Identity Literal
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
Intc Integer
i
trLiteral (IL.Float f :: Double
f) = Literal -> StateT FlatEnv Identity Literal
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> StateT FlatEnv Identity Literal)
-> Literal -> StateT FlatEnv Identity Literal
forall a b. (a -> b) -> a -> b
$ Double -> Literal
Floatc Double
f
trApply :: IL.Expression -> IL.Expression -> FlatState (AExpr TypeExpr)
trApply :: Expression
-> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trApply e1 :: Expression
e1 e2 :: Expression
e2 = Expression
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genFlatApplic Expression
e1 [Expression
e2]
where
genFlatApplic :: Expression
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genFlatApplic e :: Expression
e es :: [Expression]
es = case Expression
e of
IL.Apply ea :: Expression
ea eb :: Expression
eb -> Expression
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genFlatApplic Expression
ea (Expression
ebExpression -> [Expression] -> [Expression]
forall a. a -> [a] -> [a]
:[Expression]
es)
IL.Function ty :: Type
ty f :: QualIdent
f a :: Int
a -> Call
-> Type
-> QualIdent
-> Int
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Fun Type
ty QualIdent
f Int
a [Expression]
es
IL.Constructor ty :: Type
ty c :: QualIdent
c a :: Int
a -> Call
-> Type
-> QualIdent
-> Int
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Con Type
ty QualIdent
c Int
a [Expression]
es
_ -> do
AExpr TypeExpr
expr <- Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
AExpr TypeExpr
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genApply AExpr TypeExpr
expr [Expression]
es
trAlt :: IL.Alt -> FlatState (ABranchExpr TypeExpr)
trAlt :: Alt -> StateT FlatEnv Identity (ABranchExpr TypeExpr)
trAlt (IL.Alt p :: ConstrTerm
p e :: Expression
e) = APattern TypeExpr -> AExpr TypeExpr -> ABranchExpr TypeExpr
forall a. APattern a -> AExpr a -> ABranchExpr a
ABranch (APattern TypeExpr -> AExpr TypeExpr -> ABranchExpr TypeExpr)
-> StateT FlatEnv Identity (APattern TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr -> ABranchExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstrTerm -> StateT FlatEnv Identity (APattern TypeExpr)
trPat ConstrTerm
p StateT FlatEnv Identity (AExpr TypeExpr -> ABranchExpr TypeExpr)
-> StateT FlatEnv Identity (AExpr TypeExpr)
-> StateT FlatEnv Identity (ABranchExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr Expression
e
trPat :: IL.ConstrTerm -> FlatState (APattern TypeExpr)
trPat :: ConstrTerm -> StateT FlatEnv Identity (APattern TypeExpr)
trPat (IL.LiteralPattern ty :: Type
ty l :: Literal
l) = TypeExpr -> Literal -> APattern TypeExpr
forall a. a -> Literal -> APattern a
ALPattern (TypeExpr -> Literal -> APattern TypeExpr)
-> FlatState TypeExpr
-> StateT FlatEnv Identity (Literal -> APattern TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT FlatEnv Identity (Literal -> APattern TypeExpr)
-> StateT FlatEnv Identity Literal
-> StateT FlatEnv Identity (APattern TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Literal -> StateT FlatEnv Identity Literal
trLiteral Literal
l
trPat (IL.ConstructorPattern ty :: Type
ty c :: QualIdent
c vs :: [(Type, Ident)]
vs) = do
TypeExpr
qty <- Type -> FlatState TypeExpr
trType (Type -> FlatState TypeExpr) -> Type -> FlatState TypeExpr
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Type -> Type -> Type
IL.TypeArrow Type
ty ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ ((Type, Ident) -> Type) -> [(Type, Ident)] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Ident) -> Type
forall a b. (a, b) -> a
fst [(Type, Ident)]
vs
TypeExpr
-> (QName, TypeExpr) -> [(Int, TypeExpr)] -> APattern TypeExpr
forall a. a -> (QName, a) -> [(Int, a)] -> APattern a
APattern (TypeExpr
-> (QName, TypeExpr) -> [(Int, TypeExpr)] -> APattern TypeExpr)
-> FlatState TypeExpr
-> StateT
FlatEnv
Identity
((QName, TypeExpr) -> [(Int, TypeExpr)] -> APattern TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT
FlatEnv
Identity
((QName, TypeExpr) -> [(Int, TypeExpr)] -> APattern TypeExpr)
-> StateT FlatEnv Identity (QName, TypeExpr)
-> StateT FlatEnv Identity ([(Int, TypeExpr)] -> APattern TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((\q :: QName
q -> (QName
q, TypeExpr
qty)) (QName -> (QName, TypeExpr))
-> FlatState QName -> StateT FlatEnv Identity (QName, TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> FlatState QName
trQualIdent QualIdent
c) StateT FlatEnv Identity ([(Int, TypeExpr)] -> APattern TypeExpr)
-> StateT FlatEnv Identity [(Int, TypeExpr)]
-> StateT FlatEnv Identity (APattern TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Type, Ident) -> FlatState (Int, TypeExpr))
-> [(Type, Ident)] -> StateT FlatEnv Identity [(Int, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Ident -> FlatState (Int, TypeExpr))
-> (Type, Ident) -> FlatState (Int, TypeExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> FlatState (Int, TypeExpr)
newVar) [(Type, Ident)]
vs
trPat (IL.VariablePattern _ _) = String -> StateT FlatEnv Identity (APattern TypeExpr)
forall a. String -> a
internalError "GenTypeAnnotatedFlatCurry.trPat"
cvEval :: IL.Eval -> CaseType
cvEval :: Eval -> CaseType
cvEval IL.Rigid = CaseType
Rigid
cvEval IL.Flex = CaseType
Flex
data Call = Fun | Con
genCall :: Call -> IL.Type -> QualIdent -> Int -> [IL.Expression]
-> FlatState (AExpr TypeExpr)
genCall :: Call
-> Type
-> QualIdent
-> Int
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall call :: Call
call ty :: Type
ty f :: QualIdent
f arity :: Int
arity es :: [Expression]
es = do
QName
f' <- QualIdent -> FlatState QName
trQualIdent QualIdent
f
case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
supplied Int
arity of
LT -> Type
-> QName
-> [Expression]
-> CombType
-> StateT FlatEnv Identity (AExpr TypeExpr)
genAComb Type
ty QName
f' [Expression]
es (Call -> Int -> CombType
part Call
call (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
supplied))
EQ -> Type
-> QName
-> [Expression]
-> CombType
-> StateT FlatEnv Identity (AExpr TypeExpr)
genAComb Type
ty QName
f' [Expression]
es (Call -> CombType
full Call
call)
GT -> do
let (es1 :: [Expression]
es1, es2 :: [Expression]
es2) = Int -> [Expression] -> ([Expression], [Expression])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
arity [Expression]
es
AExpr TypeExpr
funccall <- Type
-> QName
-> [Expression]
-> CombType
-> StateT FlatEnv Identity (AExpr TypeExpr)
genAComb Type
ty QName
f' [Expression]
es1 (Call -> CombType
full Call
call)
AExpr TypeExpr
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genApply AExpr TypeExpr
funccall [Expression]
es2
where
supplied :: Int
supplied = [Expression] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression]
es
full :: Call -> CombType
full Fun = CombType
FuncCall
full Con = CombType
ConsCall
part :: Call -> Int -> CombType
part Fun = Int -> CombType
FuncPartCall
part Con = Int -> CombType
ConsPartCall
genAComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState (AExpr TypeExpr)
genAComb :: Type
-> QName
-> [Expression]
-> CombType
-> StateT FlatEnv Identity (AExpr TypeExpr)
genAComb ty :: Type
ty qid :: QName
qid es :: [Expression]
es ct :: CombType
ct = do
TypeExpr
ty' <- Type -> FlatState TypeExpr
trType Type
ty
let ty'' :: TypeExpr
ty'' = TypeExpr -> Int -> TypeExpr
forall t. (Eq t, Num t) => TypeExpr -> t -> TypeExpr
defunc TypeExpr
ty' ([Expression] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression]
es)
TypeExpr
-> CombType
-> (QName, TypeExpr)
-> [AExpr TypeExpr]
-> AExpr TypeExpr
forall a. a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a
AComb TypeExpr
ty'' CombType
ct (QName
qid, TypeExpr
ty') ([AExpr TypeExpr] -> AExpr TypeExpr)
-> StateT FlatEnv Identity [AExpr TypeExpr]
-> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression -> StateT FlatEnv Identity (AExpr TypeExpr))
-> [Expression] -> StateT FlatEnv Identity [AExpr TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr [Expression]
es
where
defunc :: TypeExpr -> t -> TypeExpr
defunc t :: TypeExpr
t 0 = TypeExpr
t
defunc (FuncType _ t2 :: TypeExpr
t2) n :: t
n = TypeExpr -> t -> TypeExpr
defunc TypeExpr
t2 (t
n t -> t -> t
forall a. Num a => a -> a -> a
- 1)
defunc _ _ = String -> TypeExpr
forall a. String -> a
internalError "GenTypeAnnotatedFlatCurry.genAComb.defunc"
genApply :: AExpr TypeExpr -> [IL.Expression] -> FlatState (AExpr TypeExpr)
genApply :: AExpr TypeExpr
-> [Expression] -> StateT FlatEnv Identity (AExpr TypeExpr)
genApply e :: AExpr TypeExpr
e es :: [Expression]
es = do
QName
ap <- QualIdent -> FlatState QName
trQualIdent (QualIdent -> FlatState QName) -> QualIdent -> FlatState QName
forall a b. (a -> b) -> a -> b
$ QualIdent
qApplyId
[AExpr TypeExpr]
es' <- (Expression -> StateT FlatEnv Identity (AExpr TypeExpr))
-> [Expression] -> StateT FlatEnv Identity [AExpr TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expression -> StateT FlatEnv Identity (AExpr TypeExpr)
trAExpr [Expression]
es
AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr))
-> AExpr TypeExpr -> StateT FlatEnv Identity (AExpr TypeExpr)
forall a b. (a -> b) -> a -> b
$ (AExpr TypeExpr -> AExpr TypeExpr -> AExpr TypeExpr)
-> AExpr TypeExpr -> [AExpr TypeExpr] -> AExpr TypeExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\e1 :: AExpr TypeExpr
e1 e2 :: AExpr TypeExpr
e2 -> let FuncType ty1 :: TypeExpr
ty1 ty2 :: TypeExpr
ty2 = AExpr TypeExpr -> TypeExpr
forall a. Typeable a => a -> TypeExpr
typeOf AExpr TypeExpr
e1 in TypeExpr
-> CombType
-> (QName, TypeExpr)
-> [AExpr TypeExpr]
-> AExpr TypeExpr
forall a. a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a
AComb TypeExpr
ty2 CombType
FuncCall (QName
ap, TypeExpr -> TypeExpr -> TypeExpr
FuncType (TypeExpr -> TypeExpr -> TypeExpr
FuncType TypeExpr
ty1 TypeExpr
ty2) (TypeExpr -> TypeExpr -> TypeExpr
FuncType TypeExpr
ty1 TypeExpr
ty2)) [AExpr TypeExpr
e1, AExpr TypeExpr
e2]) AExpr TypeExpr
e [AExpr TypeExpr]
es'
runNormalization :: Normalize a => a -> a
runNormalization :: a -> a
runNormalization x :: a
x = State (Int, Map Int Int) a -> (Int, Map Int Int) -> a
forall s a. State s a -> s -> a
S.evalState (a -> State (Int, Map Int Int) a
forall a. Normalize a => a -> NormState a
normalize a
x) (0, Map Int Int
forall k a. Map k a
Map.empty)
type NormState a = S.State (Int, Map.Map Int Int) a
class Normalize a where
normalize :: a -> NormState a
instance Normalize a => Normalize [a] where
normalize :: [a] -> NormState [a]
normalize = (a -> StateT (Int, Map Int Int) Identity a) -> [a] -> NormState [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize
instance Normalize Int where
normalize :: Int -> NormState Int
normalize i :: Int
i = do
(n :: Int
n, m :: Map Int Int
m) <- StateT (Int, Map Int Int) Identity (Int, Map Int Int)
forall s (m :: * -> *). MonadState s m => m s
S.get
case Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
i Map Int Int
m of
Nothing -> do
(Int, Map Int Int) -> StateT (Int, Map Int Int) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
i Int
n Map Int Int
m)
Int -> NormState Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
Just n' :: Int
n' -> Int -> NormState Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'
instance Normalize TypeExpr where
normalize :: TypeExpr -> NormState TypeExpr
normalize (TVar i :: Int
i) = Int -> TypeExpr
TVar (Int -> TypeExpr) -> NormState Int -> NormState TypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> NormState Int
forall a. Normalize a => a -> NormState a
normalize Int
i
normalize (TCons q :: QName
q tys :: [TypeExpr]
tys) = QName -> [TypeExpr] -> TypeExpr
TCons QName
q ([TypeExpr] -> TypeExpr)
-> StateT (Int, Map Int Int) Identity [TypeExpr]
-> NormState TypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeExpr] -> StateT (Int, Map Int Int) Identity [TypeExpr]
forall a. Normalize a => a -> NormState a
normalize [TypeExpr]
tys
normalize (FuncType ty1 :: TypeExpr
ty1 ty2 :: TypeExpr
ty2) = TypeExpr -> TypeExpr -> TypeExpr
FuncType (TypeExpr -> TypeExpr -> TypeExpr)
-> NormState TypeExpr
-> StateT (Int, Map Int Int) Identity (TypeExpr -> TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExpr -> NormState TypeExpr
forall a. Normalize a => a -> NormState a
normalize TypeExpr
ty1 StateT (Int, Map Int Int) Identity (TypeExpr -> TypeExpr)
-> NormState TypeExpr -> NormState TypeExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> NormState TypeExpr
forall a. Normalize a => a -> NormState a
normalize TypeExpr
ty2
normalize (ForallType is :: [TVarWithKind]
is ty :: TypeExpr
ty) = [TVarWithKind] -> TypeExpr -> TypeExpr
ForallType ([TVarWithKind] -> TypeExpr -> TypeExpr)
-> StateT (Int, Map Int Int) Identity [TVarWithKind]
-> StateT (Int, Map Int Int) Identity (TypeExpr -> TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVarWithKind -> StateT (Int, Map Int Int) Identity TVarWithKind)
-> [TVarWithKind]
-> StateT (Int, Map Int Int) Identity [TVarWithKind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TVarWithKind -> StateT (Int, Map Int Int) Identity TVarWithKind
forall a a.
Normalize a =>
(a, a) -> StateT (Int, Map Int Int) Identity (a, a)
normalizeTypeVar [TVarWithKind]
is
StateT (Int, Map Int Int) Identity (TypeExpr -> TypeExpr)
-> NormState TypeExpr -> NormState TypeExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> NormState TypeExpr
forall a. Normalize a => a -> NormState a
normalize TypeExpr
ty
where normalizeTypeVar :: (a, a) -> StateT (Int, Map Int Int) Identity (a, a)
normalizeTypeVar (tv :: a
tv, k :: a
k) = (,) (a -> a -> (a, a))
-> StateT (Int, Map Int Int) Identity a
-> StateT (Int, Map Int Int) Identity (a -> (a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
tv StateT (Int, Map Int Int) Identity (a -> (a, a))
-> StateT (Int, Map Int Int) Identity a
-> StateT (Int, Map Int Int) Identity (a, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> StateT (Int, Map Int Int) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
k
instance Normalize a => Normalize (AFuncDecl a) where
normalize :: AFuncDecl a -> NormState (AFuncDecl a)
normalize (AFunc f :: QName
f a :: Int
a v :: Visibility
v ty :: TypeExpr
ty r :: ARule a
r) = QName -> Int -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
forall a.
QName -> Int -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
AFunc QName
f Int
a Visibility
v (TypeExpr -> ARule a -> AFuncDecl a)
-> NormState TypeExpr
-> StateT (Int, Map Int Int) Identity (ARule a -> AFuncDecl a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeExpr -> NormState TypeExpr
forall a. Normalize a => a -> NormState a
normalize TypeExpr
ty StateT (Int, Map Int Int) Identity (ARule a -> AFuncDecl a)
-> StateT (Int, Map Int Int) Identity (ARule a)
-> NormState (AFuncDecl a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ARule a -> StateT (Int, Map Int Int) Identity (ARule a)
forall a. Normalize a => a -> NormState a
normalize ARule a
r
instance Normalize a => Normalize (ARule a) where
normalize :: ARule a -> NormState (ARule a)
normalize (ARule ty :: a
ty vs :: [(Int, a)]
vs e :: AExpr a
e) = a -> [(Int, a)] -> AExpr a -> ARule a
forall a. a -> [(Int, a)] -> AExpr a -> ARule a
ARule (a -> [(Int, a)] -> AExpr a -> ARule a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
(Int, Map Int Int) Identity ([(Int, a)] -> AExpr a -> ARule a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
StateT
(Int, Map Int Int) Identity ([(Int, a)] -> AExpr a -> ARule a)
-> StateT (Int, Map Int Int) Identity [(Int, a)]
-> StateT (Int, Map Int Int) Identity (AExpr a -> ARule a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Int, a) -> StateT (Int, Map Int Int) Identity (Int, a))
-> [(Int, a)] -> StateT (Int, Map Int Int) Identity [(Int, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, a) -> StateT (Int, Map Int Int) Identity (Int, a)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple [(Int, a)]
vs
StateT (Int, Map Int Int) Identity (AExpr a -> ARule a)
-> StateT (Int, Map Int Int) Identity (AExpr a)
-> NormState (ARule a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> StateT (Int, Map Int Int) Identity (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e
normalize (AExternal ty :: a
ty s :: String
s) = (a -> String -> ARule a) -> String -> a -> ARule a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> String -> ARule a
forall a. a -> String -> ARule a
AExternal String
s (a -> ARule a)
-> StateT (Int, Map Int Int) Identity a -> NormState (ARule a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
normalizeTuple :: Normalize b => (a, b) -> NormState (a, b)
normalizeTuple :: (a, b) -> NormState (a, b)
normalizeTuple (a :: a
a, b :: b
b) = (,) (a -> b -> (a, b))
-> StateT (Int, Map Int Int) Identity a
-> StateT (Int, Map Int Int) Identity (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a StateT (Int, Map Int Int) Identity (b -> (a, b))
-> StateT (Int, Map Int Int) Identity b -> NormState (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> StateT (Int, Map Int Int) Identity b
forall a. Normalize a => a -> NormState a
normalize b
b
instance Normalize a => Normalize (AExpr a) where
normalize :: AExpr a -> NormState (AExpr a)
normalize (AVar ty :: a
ty v :: Int
v) = (a -> Int -> AExpr a) -> Int -> a -> AExpr a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Int -> AExpr a
forall a. a -> Int -> AExpr a
AVar Int
v (a -> AExpr a)
-> StateT (Int, Map Int Int) Identity a -> NormState (AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
normalize (ALit ty :: a
ty l :: Literal
l) = (a -> Literal -> AExpr a) -> Literal -> a -> AExpr a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Literal -> AExpr a
forall a. a -> Literal -> AExpr a
ALit Literal
l (a -> AExpr a)
-> StateT (Int, Map Int Int) Identity a -> NormState (AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
normalize (AComb ty :: a
ty ct :: CombType
ct f :: (QName, a)
f es :: [AExpr a]
es) = (a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a)
-> CombType -> a -> (QName, a) -> [AExpr a] -> AExpr a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a
forall a. a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a
AComb CombType
ct (a -> (QName, a) -> [AExpr a] -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
(Int, Map Int Int) Identity ((QName, a) -> [AExpr a] -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
StateT
(Int, Map Int Int) Identity ((QName, a) -> [AExpr a] -> AExpr a)
-> StateT (Int, Map Int Int) Identity (QName, a)
-> StateT (Int, Map Int Int) Identity ([AExpr a] -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (QName, a) -> StateT (Int, Map Int Int) Identity (QName, a)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple (QName, a)
f
StateT (Int, Map Int Int) Identity ([AExpr a] -> AExpr a)
-> StateT (Int, Map Int Int) Identity [AExpr a]
-> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [AExpr a] -> StateT (Int, Map Int Int) Identity [AExpr a]
forall a. Normalize a => a -> NormState a
normalize [AExpr a]
es
normalize (ALet ty :: a
ty ds :: [((Int, a), AExpr a)]
ds e :: AExpr a
e) = a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a
forall a. a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a
ALet (a -> [((Int, a), AExpr a)] -> AExpr a -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
(Int, Map Int Int)
Identity
([((Int, a), AExpr a)] -> AExpr a -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
StateT
(Int, Map Int Int)
Identity
([((Int, a), AExpr a)] -> AExpr a -> AExpr a)
-> StateT (Int, Map Int Int) Identity [((Int, a), AExpr a)]
-> StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (((Int, a), AExpr a)
-> StateT (Int, Map Int Int) Identity ((Int, a), AExpr a))
-> [((Int, a), AExpr a)]
-> StateT (Int, Map Int Int) Identity [((Int, a), AExpr a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Int, a), AExpr a)
-> StateT (Int, Map Int Int) Identity ((Int, a), AExpr a)
forall b a a.
(Normalize b, Normalize a) =>
((a, b), a) -> StateT (Int, Map Int Int) Identity ((a, b), a)
normalizeBinding [((Int, a), AExpr a)]
ds
StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
-> NormState (AExpr a) -> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e
where normalizeBinding :: ((a, b), a) -> StateT (Int, Map Int Int) Identity ((a, b), a)
normalizeBinding (v :: (a, b)
v, b :: a
b) = (,) ((a, b) -> a -> ((a, b), a))
-> StateT (Int, Map Int Int) Identity (a, b)
-> StateT (Int, Map Int Int) Identity (a -> ((a, b), a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, b) -> StateT (Int, Map Int Int) Identity (a, b)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple (a, b)
v StateT (Int, Map Int Int) Identity (a -> ((a, b), a))
-> StateT (Int, Map Int Int) Identity a
-> StateT (Int, Map Int Int) Identity ((a, b), a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
b
normalize (AOr ty :: a
ty a :: AExpr a
a b :: AExpr a
b) = a -> AExpr a -> AExpr a -> AExpr a
forall a. a -> AExpr a -> AExpr a -> AExpr a
AOr (a -> AExpr a -> AExpr a -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
(Int, Map Int Int) Identity (AExpr a -> AExpr a -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a -> AExpr a)
-> NormState (AExpr a)
-> StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
a
StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
-> NormState (AExpr a) -> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
b
normalize (ACase ty :: a
ty ct :: CaseType
ct e :: AExpr a
e bs :: [ABranchExpr a]
bs) = (a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a)
-> CaseType -> a -> AExpr a -> [ABranchExpr a] -> AExpr a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a
forall a. a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a
ACase CaseType
ct (a -> AExpr a -> [ABranchExpr a] -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
(Int, Map Int Int) Identity (AExpr a -> [ABranchExpr a] -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty StateT
(Int, Map Int Int) Identity (AExpr a -> [ABranchExpr a] -> AExpr a)
-> NormState (AExpr a)
-> StateT (Int, Map Int Int) Identity ([ABranchExpr a] -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e
StateT (Int, Map Int Int) Identity ([ABranchExpr a] -> AExpr a)
-> StateT (Int, Map Int Int) Identity [ABranchExpr a]
-> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [ABranchExpr a]
-> StateT (Int, Map Int Int) Identity [ABranchExpr a]
forall a. Normalize a => a -> NormState a
normalize [ABranchExpr a]
bs
normalize (AFree ty :: a
ty vs :: [(Int, a)]
vs e :: AExpr a
e) = a -> [(Int, a)] -> AExpr a -> AExpr a
forall a. a -> [(Int, a)] -> AExpr a -> AExpr a
AFree (a -> [(Int, a)] -> AExpr a -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
(Int, Map Int Int) Identity ([(Int, a)] -> AExpr a -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
StateT
(Int, Map Int Int) Identity ([(Int, a)] -> AExpr a -> AExpr a)
-> StateT (Int, Map Int Int) Identity [(Int, a)]
-> StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Int, a) -> StateT (Int, Map Int Int) Identity (Int, a))
-> [(Int, a)] -> StateT (Int, Map Int Int) Identity [(Int, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, a) -> StateT (Int, Map Int Int) Identity (Int, a)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple [(Int, a)]
vs
StateT (Int, Map Int Int) Identity (AExpr a -> AExpr a)
-> NormState (AExpr a) -> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e
normalize (ATyped ty :: a
ty e :: AExpr a
e ty' :: TypeExpr
ty') = a -> AExpr a -> TypeExpr -> AExpr a
forall a. a -> AExpr a -> TypeExpr -> AExpr a
ATyped (a -> AExpr a -> TypeExpr -> AExpr a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
(Int, Map Int Int) Identity (AExpr a -> TypeExpr -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty StateT (Int, Map Int Int) Identity (AExpr a -> TypeExpr -> AExpr a)
-> NormState (AExpr a)
-> StateT (Int, Map Int Int) Identity (TypeExpr -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e
StateT (Int, Map Int Int) Identity (TypeExpr -> AExpr a)
-> NormState TypeExpr -> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeExpr -> NormState TypeExpr
forall a. Normalize a => a -> NormState a
normalize TypeExpr
ty'
instance Normalize a => Normalize (ABranchExpr a) where
normalize :: ABranchExpr a -> NormState (ABranchExpr a)
normalize (ABranch p :: APattern a
p e :: AExpr a
e) = APattern a -> AExpr a -> ABranchExpr a
forall a. APattern a -> AExpr a -> ABranchExpr a
ABranch (APattern a -> AExpr a -> ABranchExpr a)
-> StateT (Int, Map Int Int) Identity (APattern a)
-> StateT (Int, Map Int Int) Identity (AExpr a -> ABranchExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> APattern a -> StateT (Int, Map Int Int) Identity (APattern a)
forall a. Normalize a => a -> NormState a
normalize APattern a
p StateT (Int, Map Int Int) Identity (AExpr a -> ABranchExpr a)
-> StateT (Int, Map Int Int) Identity (AExpr a)
-> NormState (ABranchExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a -> StateT (Int, Map Int Int) Identity (AExpr a)
forall a. Normalize a => a -> NormState a
normalize AExpr a
e
instance Normalize a => Normalize (APattern a) where
normalize :: APattern a -> NormState (APattern a)
normalize (APattern ty :: a
ty c :: (QName, a)
c vs :: [(Int, a)]
vs) = a -> (QName, a) -> [(Int, a)] -> APattern a
forall a. a -> (QName, a) -> [(Int, a)] -> APattern a
APattern (a -> (QName, a) -> [(Int, a)] -> APattern a)
-> StateT (Int, Map Int Int) Identity a
-> StateT
(Int, Map Int Int)
Identity
((QName, a) -> [(Int, a)] -> APattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
StateT
(Int, Map Int Int)
Identity
((QName, a) -> [(Int, a)] -> APattern a)
-> StateT (Int, Map Int Int) Identity (QName, a)
-> StateT (Int, Map Int Int) Identity ([(Int, a)] -> APattern a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (QName, a) -> StateT (Int, Map Int Int) Identity (QName, a)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple (QName, a)
c
StateT (Int, Map Int Int) Identity ([(Int, a)] -> APattern a)
-> StateT (Int, Map Int Int) Identity [(Int, a)]
-> NormState (APattern a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Int, a) -> StateT (Int, Map Int Int) Identity (Int, a))
-> [(Int, a)] -> StateT (Int, Map Int Int) Identity [(Int, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, a) -> StateT (Int, Map Int Int) Identity (Int, a)
forall b a. Normalize b => (a, b) -> NormState (a, b)
normalizeTuple [(Int, a)]
vs
normalize (ALPattern ty :: a
ty l :: Literal
l) = (a -> Literal -> APattern a) -> Literal -> a -> APattern a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Literal -> APattern a
forall a. a -> Literal -> APattern a
ALPattern Literal
l (a -> APattern a)
-> StateT (Int, Map Int Int) Identity a -> NormState (APattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (Int, Map Int Int) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
trQualIdent :: QualIdent -> FlatState QName
trQualIdent :: QualIdent -> FlatState QName
trQualIdent qid :: QualIdent
qid = do
ModuleIdent
mid <- FlatState ModuleIdent
getModuleIdent
QName -> FlatState QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> FlatState QName) -> QName -> FlatState QName
forall a b. (a -> b) -> a -> b
$ (ModuleIdent -> String
moduleName (ModuleIdent -> String) -> ModuleIdent -> String
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> Maybe ModuleIdent -> ModuleIdent
forall a. a -> Maybe a -> a
fromMaybe ModuleIdent
mid Maybe ModuleIdent
mid', Ident -> String
idName Ident
i)
where
mid' :: Maybe ModuleIdent
mid' | Ident
i Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ident
listId, Ident
consId, Ident
nilId, Ident
unitId] Bool -> Bool -> Bool
|| Ident -> Bool
isTupleId Ident
i
= ModuleIdent -> Maybe ModuleIdent
forall a. a -> Maybe a
Just ModuleIdent
preludeMIdent
| Bool
otherwise
= QualIdent -> Maybe ModuleIdent
qidModule QualIdent
qid
i :: Ident
i = QualIdent -> Ident
qidIdent QualIdent
qid
getTypeVisibility :: QualIdent -> FlatState Visibility
getTypeVisibility :: QualIdent -> FlatState Visibility
getTypeVisibility i :: QualIdent
i = (FlatEnv -> Visibility) -> FlatState Visibility
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ((FlatEnv -> Visibility) -> FlatState Visibility)
-> (FlatEnv -> Visibility) -> FlatState Visibility
forall a b. (a -> b) -> a -> b
$ \s :: FlatEnv
s ->
if Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (QualIdent -> Ident
unqualify QualIdent
i) (FlatEnv -> Set Ident
tyExports FlatEnv
s) then Visibility
Public else Visibility
Private
getVisibility :: QualIdent -> FlatState Visibility
getVisibility :: QualIdent -> FlatState Visibility
getVisibility i :: QualIdent
i = (FlatEnv -> Visibility) -> FlatState Visibility
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets ((FlatEnv -> Visibility) -> FlatState Visibility)
-> (FlatEnv -> Visibility) -> FlatState Visibility
forall a b. (a -> b) -> a -> b
$ \s :: FlatEnv
s ->
if Ident -> Set Ident -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (QualIdent -> Ident
unqualify QualIdent
i) (FlatEnv -> Set Ident
valExports FlatEnv
s) then Visibility
Public else Visibility
Private