{-# LANGUAGE CPP #-}
module Generators.GenTypeAnnotatedFlatCurry (genTypeAnnotatedFlatCurry) 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.Base.SpanInfo
import Curry.FlatCurry.Annotated.Goodies (typeName)
import Curry.FlatCurry.Annotated.Type
import qualified Curry.Syntax as CS
import Base.CurryTypes (toType)
import Base.Messages (internalError)
import Base.NestEnv ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv
, nestEnv, unnestEnv )
import Base.TypeExpansion
import Base.Types
import CompilerEnv
import Env.OpPrec (mkPrec)
import Env.TypeConstructor (TCEnv)
import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)
import qualified IL
import Transformations (transType)
genTypeAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> AProg TypeExpr
genTypeAnnotatedFlatCurry :: CompilerEnv -> Module Type -> Module -> AProg TypeExpr
genTypeAnnotatedFlatCurry 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 -> [TVarIndex] -> [ConsDecl] -> TypeDecl
Type QName
arrow Visibility
Public [0, 1] []
, QName -> Visibility -> [TVarIndex] -> [ConsDecl] -> TypeDecl
Type QName
unit Visibility
Public [] [(QName -> TVarIndex -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
unit 0 Visibility
Public [])]
, QName -> Visibility -> [TVarIndex] -> [ConsDecl] -> TypeDecl
Type QName
nil Visibility
Public [0] [ QName -> TVarIndex -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
nil 0 Visibility
Public []
, QName -> TVarIndex -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
cons 2 Visibility
Public [TVarIndex -> TypeExpr
TVar 0, QName -> [TypeExpr] -> TypeExpr
TCons QName
nil [TVarIndex -> TypeExpr
TVar 0]]
]
] [TypeDecl] -> [TypeDecl] -> [TypeDecl]
forall a. [a] -> [a] -> [a]
++ (TVarIndex -> TypeDecl) -> [TVarIndex] -> [TypeDecl]
forall a b. (a -> b) -> [a] -> [b]
map TVarIndex -> TypeDecl
mkTupleType [2 .. TVarIndex
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 :: TVarIndex -> TypeDecl
mkTupleType arity :: TVarIndex
arity = QName -> Visibility -> [TVarIndex] -> [ConsDecl] -> TypeDecl
Type QName
tuple Visibility
Public [0 .. TVarIndex
arity TVarIndex -> TVarIndex -> TVarIndex
forall a. Num a => a -> a -> a
- 1]
[QName -> TVarIndex -> Visibility -> [TypeExpr] -> ConsDecl
Cons QName
tuple TVarIndex
arity Visibility
Public ((TVarIndex -> TypeExpr) -> [TVarIndex] -> [TypeExpr]
forall a b. (a -> b) -> [a] -> [b]
map TVarIndex -> TypeExpr
TVar [0 .. TVarIndex
arity TVarIndex -> TVarIndex -> TVarIndex
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]
: TVarIndex -> Char -> String
forall a. TVarIndex -> a -> [a]
replicate (TVarIndex
arity TVarIndex -> TVarIndex -> TVarIndex
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 :: TVarIndex
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 -> ValueEnv
tyEnv :: ValueEnv
, FlatEnv -> [IDecl]
fixities :: [CS.IDecl]
, FlatEnv -> [Decl Type]
typeSynonyms :: [CS.Decl Type]
, FlatEnv -> [ModuleIdent]
imports :: [ModuleIdent]
, FlatEnv -> TVarIndex
nextVar :: Int
, FlatEnv -> NestEnv TVarIndex
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
-> ValueEnv
-> [IDecl]
-> [Decl Type]
-> [ModuleIdent]
-> TVarIndex
-> NestEnv TVarIndex
-> 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 ]
, tyEnv :: ValueEnv
tyEnv = CompilerEnv -> ValueEnv
valueEnv CompilerEnv
env
, tcEnv :: TCEnv
tcEnv = CompilerEnv -> TCEnv
tyConsEnv CompilerEnv
env
, fixities :: [IDecl]
fixities = [ Position -> Infix -> Precedence -> QualIdent -> IDecl
CS.IInfixDecl (SpanInfo -> Position
forall a. HasSpanInfo a => a -> Position
spanInfo2Pos SpanInfo
p) Infix
fix (Maybe Precedence -> Precedence
mkPrec Maybe Precedence
mPrec) (ModuleIdent -> Ident -> QualIdent
qualifyWith ModuleIdent
mid Ident
o)
| CS.InfixDecl p :: SpanInfo
p fix :: Infix
fix mPrec :: Maybe Precedence
mPrec os :: [Ident]
os <- [Decl Type]
ds, Ident
o <- [Ident]
os
]
, typeSynonyms :: [Decl Type]
typeSynonyms = [ Decl Type
d | d :: Decl Type
d@CS.TypeDecl{} <- [Decl Type]
ds ]
, nextVar :: TVarIndex
nextVar = 0
, varMap :: NestEnv TVarIndex
varMap = NestEnv TVarIndex
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
getArity :: QualIdent -> FlatState Int
getArity :: QualIdent -> FlatState TVarIndex
getArity qid :: QualIdent
qid = (FlatEnv -> ValueEnv) -> StateT FlatEnv Identity ValueEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> ValueEnv
tyEnv StateT FlatEnv Identity ValueEnv
-> (ValueEnv -> FlatState TVarIndex) -> FlatState TVarIndex
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ env :: ValueEnv
env -> TVarIndex -> FlatState TVarIndex
forall (m :: * -> *) a. Monad m => a -> m a
return (TVarIndex -> FlatState TVarIndex)
-> TVarIndex -> FlatState TVarIndex
forall a b. (a -> b) -> a -> b
$ case QualIdent -> ValueEnv -> [ValueInfo]
qualLookupValue QualIdent
qid ValueEnv
env of
[DataConstructor _ a :: TVarIndex
a _ _] -> TVarIndex
a
[NewtypeConstructor _ _ _] -> 1
[Value _ _ a :: TVarIndex
a _] -> TVarIndex
a
[Label _ _ _] -> 1
_ ->
String -> TVarIndex
forall a. String -> a
internalError ("GenTypeAnnotatedFlatCurry.getArity: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualIdent -> String
qualName QualIdent
qid)
getFixities :: FlatState [CS.IDecl]
getFixities :: FlatState [IDecl]
getFixities = (FlatEnv -> [IDecl]) -> FlatState [IDecl]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> [IDecl]
fixities
getTypeSynonyms :: FlatState [CS.Decl Type]
getTypeSynonyms :: FlatState [Decl Type]
getTypeSynonyms = (FlatEnv -> [Decl Type]) -> FlatState [Decl Type]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> [Decl Type]
typeSynonyms
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 :: TVarIndex
nextVar = 0, varMap :: NestEnv TVarIndex
varMap = NestEnv TVarIndex
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 TVarIndex
varMap = NestEnv TVarIndex -> NestEnv TVarIndex
forall a. NestEnv a -> NestEnv a
nestEnv (NestEnv TVarIndex -> NestEnv TVarIndex)
-> NestEnv TVarIndex -> NestEnv TVarIndex
forall a b. (a -> b) -> a -> b
$ FlatEnv -> NestEnv TVarIndex
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 TVarIndex
varMap = NestEnv TVarIndex -> NestEnv TVarIndex
forall a. NestEnv a -> NestEnv a
unnestEnv (NestEnv TVarIndex -> NestEnv TVarIndex)
-> NestEnv TVarIndex -> NestEnv TVarIndex
forall a b. (a -> b) -> a -> b
$ FlatEnv -> NestEnv TVarIndex
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 (TVarIndex, TypeExpr)
newVar ty :: Type
ty i :: Ident
i = do
TVarIndex
idx <- (TVarIndex -> TVarIndex -> TVarIndex
forall a. Num a => a -> a -> a
+1) (TVarIndex -> TVarIndex)
-> FlatState TVarIndex -> FlatState TVarIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FlatEnv -> TVarIndex) -> FlatState TVarIndex
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> TVarIndex
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 :: TVarIndex
nextVar = TVarIndex
idx, varMap :: NestEnv TVarIndex
varMap = Ident -> TVarIndex -> NestEnv TVarIndex -> NestEnv TVarIndex
forall a. Ident -> a -> NestEnv a -> NestEnv a
bindNestEnv Ident
i TVarIndex
idx (FlatEnv -> NestEnv TVarIndex
varMap FlatEnv
s) }
TypeExpr
ty' <- Type -> FlatState TypeExpr
trType Type
ty
(TVarIndex, TypeExpr) -> FlatState (TVarIndex, TypeExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVarIndex
idx, TypeExpr
ty')
getVarIndex :: Ident -> FlatState VarIndex
getVarIndex :: Ident -> FlatState TVarIndex
getVarIndex i :: Ident
i = (FlatEnv -> NestEnv TVarIndex)
-> StateT FlatEnv Identity (NestEnv TVarIndex)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> NestEnv TVarIndex
varMap StateT FlatEnv Identity (NestEnv TVarIndex)
-> (NestEnv TVarIndex -> FlatState TVarIndex)
-> FlatState TVarIndex
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ varEnv :: NestEnv TVarIndex
varEnv -> case Ident -> NestEnv TVarIndex -> [TVarIndex]
forall a. Ident -> NestEnv a -> [a]
lookupNestEnv Ident
i NestEnv TVarIndex
varEnv of
[v :: TVarIndex
v] -> TVarIndex -> FlatState TVarIndex
forall (m :: * -> *) a. Monad m => a -> m a
return TVarIndex
v
_ -> String -> FlatState TVarIndex
forall a. String -> a
internalError (String -> FlatState TVarIndex) -> String -> FlatState TVarIndex
forall a b. (a -> b) -> a -> b
$ "GenTypeAnnotatedFlatCurry.getVarIndex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
escName Ident
i
trIOpDecl :: CS.IDecl -> FlatState [OpDecl]
trIOpDecl :: IDecl -> FlatState [OpDecl]
trIOpDecl (CS.IInfixDecl _ fix :: Infix
fix prec :: Precedence
prec op :: QualIdent
op)
= (\op' :: QName
op' -> [QName -> Fixity -> Precedence -> OpDecl
Op QName
op' (Infix -> Fixity
cvFixity Infix
fix) Precedence
prec]) (QName -> [OpDecl])
-> StateT FlatEnv Identity QName -> FlatState [OpDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT FlatEnv Identity QName
trQualIdent QualIdent
op
trIOpDecl _ = [OpDecl] -> FlatState [OpDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []
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]
sns <- FlatState [Decl Type]
getTypeSynonyms FlatState [Decl Type]
-> ([Decl Type] -> StateT FlatEnv Identity [TypeDecl])
-> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Decl Type -> StateT FlatEnv Identity [TypeDecl])
-> [Decl Type] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM Decl Type -> StateT FlatEnv Identity [TypeDecl]
forall a. Decl a -> StateT FlatEnv Identity [TypeDecl]
trTypeSynonym
[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
[OpDecl]
ops <- FlatState [IDecl]
getFixities FlatState [IDecl]
-> ([IDecl] -> FlatState [OpDecl]) -> FlatState [OpDecl]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IDecl -> FlatState [OpDecl]) -> [IDecl] -> FlatState [OpDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM IDecl -> FlatState [OpDecl]
trIOpDecl
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]
sns [TypeDecl] -> [TypeDecl] -> [TypeDecl]
forall a. [a] -> [a] -> [a]
++ [TypeDecl]
tds) [AFuncDecl TypeExpr]
fds [OpDecl]
ops
trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl]
trTypeSynonym :: Decl a -> StateT FlatEnv Identity [TypeDecl]
trTypeSynonym (CS.TypeDecl _ t :: Ident
t tvs :: [Ident]
tvs ty :: TypeExpr
ty) = do
ModuleIdent
m <- FlatState ModuleIdent
getModuleIdent
QualIdent
qid <- (ModuleIdent -> Ident -> QualIdent)
-> Ident -> ModuleIdent -> QualIdent
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleIdent -> Ident -> QualIdent
qualifyWith Ident
t (ModuleIdent -> QualIdent)
-> FlatState ModuleIdent -> StateT FlatEnv Identity QualIdent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FlatState ModuleIdent
getModuleIdent
QName
t' <- QualIdent -> StateT FlatEnv Identity QName
trQualIdent QualIdent
qid
Visibility
vis <- QualIdent -> FlatState Visibility
getTypeVisibility QualIdent
qid
TCEnv
tEnv <- (FlatEnv -> TCEnv) -> StateT FlatEnv Identity TCEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
S.gets FlatEnv -> TCEnv
tcEnv
TypeExpr
ty' <- Type -> FlatState TypeExpr
trType (Type -> Type
transType (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> TCEnv -> Type -> Type
expandType ModuleIdent
m TCEnv
tEnv (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Ident] -> TypeExpr -> Type
toType [Ident]
tvs TypeExpr
ty)
[TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarIndex] -> TypeExpr -> TypeDecl
TypeSyn QName
t' Visibility
vis [0 .. [Ident] -> TVarIndex
forall (t :: * -> *) a. Foldable t => t a -> TVarIndex
length [Ident]
tvs TVarIndex -> TVarIndex -> TVarIndex
forall a. Num a => a -> a -> a
- 1] TypeExpr
ty']
trTypeSynonym _ = [TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []
trTypeDecl :: IL.Decl -> FlatState [TypeDecl]
trTypeDecl :: Decl -> StateT FlatEnv Identity [TypeDecl]
trTypeDecl (IL.DataDecl qid :: QualIdent
qid a :: TVarIndex
a []) = do
QName
q' <- QualIdent -> StateT FlatEnv Identity QName
trQualIdent QualIdent
qid
Visibility
vis <- QualIdent -> FlatState Visibility
getTypeVisibility QualIdent
qid
QName
c <- QualIdent -> StateT FlatEnv Identity QName
trQualIdent (QualIdent -> StateT FlatEnv Identity QName)
-> QualIdent -> StateT FlatEnv Identity 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 tvs :: [TVarIndex]
tvs = [0 .. TVarIndex
a TVarIndex -> TVarIndex -> TVarIndex
forall a. Num a => a -> a -> a
- 1]
[TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarIndex] -> [ConsDecl] -> TypeDecl
Type QName
q' Visibility
vis [TVarIndex]
tvs [QName -> TVarIndex -> 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
$ (TVarIndex -> TypeExpr) -> [TVarIndex] -> [TypeExpr]
forall a b. (a -> b) -> [a] -> [b]
map TVarIndex -> TypeExpr
TVar [TVarIndex]
tvs]]]
trTypeDecl (IL.DataDecl qid :: QualIdent
qid a :: TVarIndex
a cs :: [ConstrDecl]
cs) = do
QName
q' <- QualIdent -> StateT FlatEnv Identity 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
[TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarIndex] -> [ConsDecl] -> TypeDecl
Type QName
q' Visibility
vis [0 .. TVarIndex
a TVarIndex -> TVarIndex -> TVarIndex
forall a. Num a => a -> a -> a
- 1] [ConsDecl]
cs']
trTypeDecl (IL.ExternalDataDecl qid :: QualIdent
qid a :: TVarIndex
a) = do
QName
q' <- QualIdent -> StateT FlatEnv Identity QName
trQualIdent QualIdent
qid
Visibility
vis <- QualIdent -> FlatState Visibility
getTypeVisibility QualIdent
qid
[TypeDecl] -> StateT FlatEnv Identity [TypeDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> Visibility -> [TVarIndex] -> [ConsDecl] -> TypeDecl
Type QName
q' Visibility
vis [0 .. TVarIndex
a TVarIndex -> TVarIndex -> TVarIndex
forall a. Num a => a -> a -> a
- 1] []]
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 -> TVarIndex -> Visibility -> [TypeExpr] -> ConsDecl)
-> TVarIndex -> QName -> Visibility -> [TypeExpr] -> ConsDecl
forall a b c. (a -> b -> c) -> b -> a -> c
flip QName -> TVarIndex -> Visibility -> [TypeExpr] -> ConsDecl
Cons ([Type] -> TVarIndex
forall (t :: * -> *) a. Foldable t => t a -> TVarIndex
length [Type]
tys)
(QName -> Visibility -> [TypeExpr] -> ConsDecl)
-> StateT FlatEnv Identity QName
-> StateT FlatEnv Identity (Visibility -> [TypeExpr] -> ConsDecl)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT FlatEnv Identity 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
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)
-> StateT FlatEnv Identity QName
-> StateT FlatEnv Identity ([TypeExpr] -> TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT FlatEnv Identity 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 :: TVarIndex
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
$ TVarIndex -> TypeExpr
TVar (TVarIndex -> TypeExpr) -> TVarIndex -> TypeExpr
forall a b. (a -> b) -> a -> b
$ TVarIndex -> TVarIndex
forall a. Num a => a -> a
abs TVarIndex
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 :: [TVarIndex]
idxs ty :: Type
ty) = [TVarIndex] -> TypeExpr -> TypeExpr
ForallType ((TVarIndex -> TVarIndex) -> [TVarIndex] -> [TVarIndex]
forall a b. (a -> b) -> [a] -> [b]
map TVarIndex -> TVarIndex
forall a. Num a => a -> a
abs [TVarIndex]
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
cvFixity :: CS.Infix -> Fixity
cvFixity :: Infix -> Fixity
cvFixity CS.InfixL = Fixity
InfixlOp
cvFixity CS.InfixR = Fixity
InfixrOp
cvFixity CS.Infix = Fixity
InfixOp
trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr]
trAFuncDecl :: Decl -> StateT FlatEnv Identity [AFuncDecl TypeExpr]
trAFuncDecl (IL.FunctionDecl f :: QualIdent
f vs :: [(Type, Ident)]
vs _ e :: Expression
e) = do
QName
f' <- QualIdent -> StateT FlatEnv Identity QName
trQualIdent QualIdent
f
TVarIndex
a <- QualIdent -> FlatState TVarIndex
getArity 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
-> TVarIndex
-> Visibility
-> TypeExpr
-> ARule TypeExpr
-> AFuncDecl TypeExpr
forall a.
QName
-> TVarIndex -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
AFunc QName
f' TVarIndex
a Visibility
vis TypeExpr
ty' ARule TypeExpr
r']
where ty :: Type
ty = (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 (Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
e) ([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
trAFuncDecl (IL.ExternalDecl f :: QualIdent
f ty :: Type
ty) = do
QName
f' <- QualIdent -> StateT FlatEnv Identity QName
trQualIdent QualIdent
f
TVarIndex
a <- QualIdent -> FlatState TVarIndex
getArity 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
-> TVarIndex
-> Visibility
-> TypeExpr
-> ARule TypeExpr
-> AFuncDecl TypeExpr
forall a.
QName
-> TVarIndex -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
AFunc QName
f' TVarIndex
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
-> [(TVarIndex, TypeExpr)] -> AExpr TypeExpr -> ARule TypeExpr
forall a. a -> [(TVarIndex, a)] -> AExpr a -> ARule a
ARule (TypeExpr
-> [(TVarIndex, TypeExpr)] -> AExpr TypeExpr -> ARule TypeExpr)
-> FlatState TypeExpr
-> StateT
FlatEnv
Identity
([(TVarIndex, 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
([(TVarIndex, TypeExpr)] -> AExpr TypeExpr -> ARule TypeExpr)
-> StateT FlatEnv Identity [(TVarIndex, TypeExpr)]
-> StateT FlatEnv Identity (AExpr TypeExpr -> ARule TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Type, Ident) -> FlatState (TVarIndex, TypeExpr))
-> [(Type, Ident)]
-> StateT FlatEnv Identity [(TVarIndex, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Ident -> FlatState (TVarIndex, TypeExpr))
-> (Type, Ident) -> FlatState (TVarIndex, TypeExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> FlatState (TVarIndex, 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 -> TVarIndex -> AExpr TypeExpr
forall a. a -> TVarIndex -> AExpr a
AVar (TypeExpr -> TVarIndex -> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT FlatEnv Identity (TVarIndex -> AExpr TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT FlatEnv Identity (TVarIndex -> AExpr TypeExpr)
-> FlatState TVarIndex -> StateT FlatEnv Identity (AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> FlatState TVarIndex
getVarIndex Ident
v
trAExpr (IL.Function ty :: Type
ty f :: QualIdent
f _) = Call
-> Type
-> QualIdent
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Fun Type
ty QualIdent
f []
trAExpr (IL.Constructor ty :: Type
ty c :: QualIdent
c _) = Call
-> Type
-> QualIdent
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Con Type
ty QualIdent
c []
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
(TVarIndex, TypeExpr)
v' <- Type -> Ident -> FlatState (TVarIndex, 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 :: [(TVarIndex, TypeExpr)]
vs e'' :: AExpr TypeExpr
e'' -> TypeExpr
-> [(TVarIndex, TypeExpr)] -> AExpr TypeExpr -> AExpr TypeExpr
forall a. a -> [(TVarIndex, a)] -> AExpr a -> AExpr a
AFree TypeExpr
ty'' ((TVarIndex, TypeExpr)
v' (TVarIndex, TypeExpr)
-> [(TVarIndex, TypeExpr)] -> [(TVarIndex, TypeExpr)]
forall a. a -> [a] -> [a]
: [(TVarIndex, TypeExpr)]
vs) AExpr TypeExpr
e''
_ -> TypeExpr
-> [(TVarIndex, TypeExpr)] -> AExpr TypeExpr -> AExpr TypeExpr
forall a. a -> [(TVarIndex, a)] -> AExpr a -> AExpr a
AFree TypeExpr
ty' ((TVarIndex, TypeExpr)
v' (TVarIndex, TypeExpr)
-> [(TVarIndex, TypeExpr)] -> [(TVarIndex, 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
(TVarIndex, TypeExpr)
v' <- Type -> Ident -> FlatState (TVarIndex, 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 :: [((TVarIndex, TypeExpr), AExpr TypeExpr)]
bs e'' :: AExpr TypeExpr
e'' -> TypeExpr
-> [((TVarIndex, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr
-> AExpr TypeExpr
forall a. a -> [((TVarIndex, a), AExpr a)] -> AExpr a -> AExpr a
ALet TypeExpr
ty'' (((TVarIndex, TypeExpr)
v', AExpr TypeExpr
b')((TVarIndex, TypeExpr), AExpr TypeExpr)
-> [((TVarIndex, TypeExpr), AExpr TypeExpr)]
-> [((TVarIndex, TypeExpr), AExpr TypeExpr)]
forall a. a -> [a] -> [a]
:[((TVarIndex, TypeExpr), AExpr TypeExpr)]
bs) AExpr TypeExpr
e''
_ -> TypeExpr
-> [((TVarIndex, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr
-> AExpr TypeExpr
forall a. a -> [((TVarIndex, a), AExpr a)] -> AExpr a -> AExpr a
ALet TypeExpr
ty' (((TVarIndex, TypeExpr)
v', AExpr TypeExpr
b')((TVarIndex, TypeExpr), AExpr TypeExpr)
-> [((TVarIndex, TypeExpr), AExpr TypeExpr)]
-> [((TVarIndex, 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
-> [((TVarIndex, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr
-> AExpr TypeExpr
forall a. a -> [((TVarIndex, a), AExpr a)] -> AExpr a -> AExpr a
ALet (TypeExpr
-> [((TVarIndex, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr
-> AExpr TypeExpr)
-> FlatState TypeExpr
-> StateT
FlatEnv
Identity
([((TVarIndex, 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
([((TVarIndex, TypeExpr), AExpr TypeExpr)]
-> AExpr TypeExpr -> AExpr TypeExpr)
-> StateT
FlatEnv Identity [((TVarIndex, TypeExpr), AExpr TypeExpr)]
-> StateT FlatEnv Identity (AExpr TypeExpr -> AExpr TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(TVarIndex, TypeExpr)]
-> [AExpr TypeExpr] -> [((TVarIndex, TypeExpr), AExpr TypeExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([(TVarIndex, TypeExpr)]
-> [AExpr TypeExpr] -> [((TVarIndex, TypeExpr), AExpr TypeExpr)])
-> StateT FlatEnv Identity [(TVarIndex, TypeExpr)]
-> StateT
FlatEnv
Identity
([AExpr TypeExpr] -> [((TVarIndex, TypeExpr), AExpr TypeExpr)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type, Ident) -> FlatState (TVarIndex, TypeExpr))
-> [(Type, Ident)]
-> StateT FlatEnv Identity [(TVarIndex, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Ident -> FlatState (TVarIndex, TypeExpr))
-> (Type, Ident) -> FlatState (TVarIndex, TypeExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> FlatState (TVarIndex, TypeExpr)
newVar) [(Type, Ident)]
vs StateT
FlatEnv
Identity
([AExpr TypeExpr] -> [((TVarIndex, TypeExpr), AExpr TypeExpr)])
-> StateT FlatEnv Identity [AExpr TypeExpr]
-> StateT
FlatEnv Identity [((TVarIndex, 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 _) = 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
$ Expression -> Type
forall a. Typeable a => a -> Type
IL.typeOf Expression
e
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 :: Precedence
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
$ Precedence -> Literal
Intc Precedence
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 _ -> Call
-> Type
-> QualIdent
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Fun Type
ty QualIdent
f [Expression]
es
IL.Constructor ty :: Type
ty c :: QualIdent
c _ -> Call
-> Type
-> QualIdent
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall Call
Con Type
ty QualIdent
c [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)
-> [(TVarIndex, TypeExpr)]
-> APattern TypeExpr
forall a. a -> (QName, a) -> [(TVarIndex, a)] -> APattern a
APattern (TypeExpr
-> (QName, TypeExpr)
-> [(TVarIndex, TypeExpr)]
-> APattern TypeExpr)
-> FlatState TypeExpr
-> StateT
FlatEnv
Identity
((QName, TypeExpr) -> [(TVarIndex, 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) -> [(TVarIndex, TypeExpr)] -> APattern TypeExpr)
-> StateT FlatEnv Identity (QName, TypeExpr)
-> StateT
FlatEnv Identity ([(TVarIndex, 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))
-> StateT FlatEnv Identity QName
-> StateT FlatEnv Identity (QName, TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QualIdent -> StateT FlatEnv Identity QName
trQualIdent QualIdent
c) StateT
FlatEnv Identity ([(TVarIndex, TypeExpr)] -> APattern TypeExpr)
-> StateT FlatEnv Identity [(TVarIndex, TypeExpr)]
-> StateT FlatEnv Identity (APattern TypeExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Type, Ident) -> FlatState (TVarIndex, TypeExpr))
-> [(Type, Ident)]
-> StateT FlatEnv Identity [(TVarIndex, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Ident -> FlatState (TVarIndex, TypeExpr))
-> (Type, Ident) -> FlatState (TVarIndex, TypeExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Type -> Ident -> FlatState (TVarIndex, 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 -> [IL.Expression]
-> FlatState (AExpr TypeExpr)
genCall :: Call
-> Type
-> QualIdent
-> [Expression]
-> StateT FlatEnv Identity (AExpr TypeExpr)
genCall call :: Call
call ty :: Type
ty f :: QualIdent
f es :: [Expression]
es = do
QName
f' <- QualIdent -> StateT FlatEnv Identity QName
trQualIdent QualIdent
f
TVarIndex
arity <- QualIdent -> FlatState TVarIndex
getArity QualIdent
f
case TVarIndex -> TVarIndex -> Ordering
forall a. Ord a => a -> a -> Ordering
compare TVarIndex
supplied TVarIndex
arity of
LT -> Type
-> QName
-> [Expression]
-> CombType
-> StateT FlatEnv Identity (AExpr TypeExpr)
genAComb Type
ty QName
f' [Expression]
es (Call -> TVarIndex -> CombType
part Call
call (TVarIndex
arity TVarIndex -> TVarIndex -> TVarIndex
forall a. Num a => a -> a -> a
- TVarIndex
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) = TVarIndex -> [Expression] -> ([Expression], [Expression])
forall a. TVarIndex -> [a] -> ([a], [a])
splitAt TVarIndex
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 :: TVarIndex
supplied = [Expression] -> TVarIndex
forall (t :: * -> *) a. Foldable t => t a -> TVarIndex
length [Expression]
es
full :: Call -> CombType
full Fun = CombType
FuncCall
full Con = CombType
ConsCall
part :: Call -> TVarIndex -> CombType
part Fun = TVarIndex -> CombType
FuncPartCall
part Con = TVarIndex -> 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 -> TVarIndex -> TypeExpr
forall t. (Eq t, Num t) => TypeExpr -> t -> TypeExpr
defunc TypeExpr
ty' ([Expression] -> TVarIndex
forall (t :: * -> *) a. Foldable t => t a -> TVarIndex
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 -> StateT FlatEnv Identity QName
trQualIdent (QualIdent -> StateT FlatEnv Identity QName)
-> QualIdent -> StateT FlatEnv Identity 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 (TVarIndex, Map TVarIndex TVarIndex) a
-> (TVarIndex, Map TVarIndex TVarIndex) -> a
forall s a. State s a -> s -> a
S.evalState (a -> State (TVarIndex, Map TVarIndex TVarIndex) a
forall a. Normalize a => a -> NormState a
normalize a
x) (0, Map TVarIndex TVarIndex
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 Int where
normalize :: TVarIndex -> NormState TVarIndex
normalize i :: TVarIndex
i = do
(n :: TVarIndex
n, m :: Map TVarIndex TVarIndex
m) <- StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(TVarIndex, Map TVarIndex TVarIndex)
forall s (m :: * -> *). MonadState s m => m s
S.get
case TVarIndex -> Map TVarIndex TVarIndex -> Maybe TVarIndex
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TVarIndex
i Map TVarIndex TVarIndex
m of
Nothing -> do
(TVarIndex, Map TVarIndex TVarIndex)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
S.put (TVarIndex
n TVarIndex -> TVarIndex -> TVarIndex
forall a. Num a => a -> a -> a
+ 1, TVarIndex
-> TVarIndex -> Map TVarIndex TVarIndex -> Map TVarIndex TVarIndex
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TVarIndex
i TVarIndex
n Map TVarIndex TVarIndex
m)
TVarIndex -> NormState TVarIndex
forall (m :: * -> *) a. Monad m => a -> m a
return TVarIndex
n
Just n' :: TVarIndex
n' -> TVarIndex -> NormState TVarIndex
forall (m :: * -> *) a. Monad m => a -> m a
return TVarIndex
n'
instance Normalize TypeExpr where
normalize :: TypeExpr -> NormState TypeExpr
normalize (TVar i :: TVarIndex
i) = TVarIndex -> TypeExpr
TVar (TVarIndex -> TypeExpr)
-> NormState TVarIndex -> NormState TypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVarIndex -> NormState TVarIndex
forall a. Normalize a => a -> NormState a
normalize TVarIndex
i
normalize (TCons q :: QName
q tys :: [TypeExpr]
tys) = QName -> [TypeExpr] -> TypeExpr
TCons QName
q ([TypeExpr] -> TypeExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity [TypeExpr]
-> NormState TypeExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeExpr -> NormState TypeExpr)
-> [TypeExpr]
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity [TypeExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeExpr -> NormState 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
(TVarIndex, Map TVarIndex TVarIndex)
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
(TVarIndex, Map TVarIndex TVarIndex)
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 :: [TVarIndex]
is ty :: TypeExpr
ty) =
[TVarIndex] -> TypeExpr -> TypeExpr
ForallType ([TVarIndex] -> TypeExpr -> TypeExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity [TVarIndex]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(TypeExpr -> TypeExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TVarIndex -> NormState TVarIndex)
-> [TVarIndex]
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity [TVarIndex]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TVarIndex -> NormState TVarIndex
forall a. Normalize a => a -> NormState a
normalize [TVarIndex]
is StateT
(TVarIndex, Map TVarIndex TVarIndex)
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
instance Normalize b => Normalize (a, b) where
normalize :: (a, b) -> NormState (a, b)
normalize (x :: a
x, y :: b
y) = ((,) a
x) (b -> (a, b))
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity b
-> NormState (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity b
forall a. Normalize a => a -> NormState a
normalize b
y
instance Normalize a => Normalize (AFuncDecl a) where
normalize :: AFuncDecl a -> NormState (AFuncDecl a)
normalize (AFunc f :: QName
f a :: TVarIndex
a v :: Visibility
v ty :: TypeExpr
ty r :: ARule a
r) = QName
-> TVarIndex -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
forall a.
QName
-> TVarIndex -> Visibility -> TypeExpr -> ARule a -> AFuncDecl a
AFunc QName
f TVarIndex
a Visibility
v (TypeExpr -> ARule a -> AFuncDecl a)
-> NormState TypeExpr
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
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
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(ARule a -> AFuncDecl a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (ARule a)
-> NormState (AFuncDecl a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ARule a
-> StateT (TVarIndex, Map TVarIndex TVarIndex) 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 :: [(TVarIndex, a)]
vs e :: AExpr a
e) = a -> [(TVarIndex, a)] -> AExpr a -> ARule a
forall a. a -> [(TVarIndex, a)] -> AExpr a -> ARule a
ARule (a -> [(TVarIndex, a)] -> AExpr a -> ARule a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([(TVarIndex, a)] -> AExpr a -> ARule a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([(TVarIndex, a)] -> AExpr a -> ARule a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity [(TVarIndex, a)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (AExpr a -> ARule a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((TVarIndex, a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TVarIndex, a))
-> [(TVarIndex, a)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity [(TVarIndex, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TVarIndex, a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TVarIndex, a)
forall a. Normalize a => a -> NormState a
normalize [(TVarIndex, a)]
vs
StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (AExpr a -> ARule a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (AExpr a)
-> NormState (ARule a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a
-> StateT (TVarIndex, Map TVarIndex TVarIndex) 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 (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> NormState (ARule a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
instance Normalize a => Normalize (AExpr a) where
normalize :: AExpr a -> NormState (AExpr a)
normalize (AVar ty :: a
ty v :: TVarIndex
v) = (a -> TVarIndex -> AExpr a) -> TVarIndex -> a -> AExpr a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> TVarIndex -> AExpr a
forall a. a -> TVarIndex -> AExpr a
AVar TVarIndex
v (a -> AExpr a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> NormState (AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) 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 (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> NormState (AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) 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 (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
((QName, a) -> [AExpr a] -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
((QName, a) -> [AExpr a] -> AExpr a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (QName, a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([AExpr a] -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (QName, a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (QName, a)
forall a. Normalize a => a -> NormState a
normalize (QName, a)
f
StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([AExpr a] -> AExpr a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity [AExpr a]
-> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (AExpr a -> NormState (AExpr a))
-> [AExpr a]
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity [AExpr a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM AExpr a -> NormState (AExpr a)
forall a. Normalize a => a -> NormState a
normalize [AExpr a]
es
normalize (ALet ty :: a
ty ds :: [((TVarIndex, a), AExpr a)]
ds e :: AExpr a
e) = a -> [((TVarIndex, a), AExpr a)] -> AExpr a -> AExpr a
forall a. a -> [((TVarIndex, a), AExpr a)] -> AExpr a -> AExpr a
ALet (a -> [((TVarIndex, a), AExpr a)] -> AExpr a -> AExpr a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([((TVarIndex, a), AExpr a)] -> AExpr a -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([((TVarIndex, a), AExpr a)] -> AExpr a -> AExpr a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
[((TVarIndex, a), AExpr a)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (AExpr a -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (((TVarIndex, a), AExpr a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
((TVarIndex, a), AExpr a))
-> [((TVarIndex, a), AExpr a)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
[((TVarIndex, a), AExpr a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TVarIndex, a), AExpr a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
((TVarIndex, a), AExpr a)
forall a a.
(Normalize a, Normalize a) =>
(a, a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (a, a)
normalizeBinding [((TVarIndex, a), AExpr a)]
ds
StateT
(TVarIndex, Map TVarIndex TVarIndex) 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, a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (a, a)
normalizeBinding (v :: a
v, b :: a
b) = (,) (a -> a -> (a, a))
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (a -> (a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
forall a. Normalize a => a -> NormState a
normalize a
v StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (a -> (a, a))
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (a, a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) 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 (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(AExpr a -> AExpr a -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(AExpr a -> AExpr a -> AExpr a)
-> NormState (AExpr a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) 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
(TVarIndex, Map TVarIndex TVarIndex) 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 (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(AExpr a -> [ABranchExpr a] -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(AExpr a -> [ABranchExpr a] -> AExpr a)
-> NormState (AExpr a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
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
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([ABranchExpr a] -> AExpr a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity [ABranchExpr a]
-> NormState (AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ABranchExpr a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (ABranchExpr a))
-> [ABranchExpr a]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity [ABranchExpr a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ABranchExpr a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (ABranchExpr a)
forall a. Normalize a => a -> NormState a
normalize [ABranchExpr a]
bs
normalize (AFree ty :: a
ty vs :: [(TVarIndex, a)]
vs e :: AExpr a
e) = a -> [(TVarIndex, a)] -> AExpr a -> AExpr a
forall a. a -> [(TVarIndex, a)] -> AExpr a -> AExpr a
AFree (a -> [(TVarIndex, a)] -> AExpr a -> AExpr a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([(TVarIndex, a)] -> AExpr a -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([(TVarIndex, a)] -> AExpr a -> AExpr a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity [(TVarIndex, a)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (AExpr a -> AExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((TVarIndex, a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TVarIndex, a))
-> [(TVarIndex, a)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity [(TVarIndex, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TVarIndex, a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TVarIndex, a)
forall a. Normalize a => a -> NormState a
normalize [(TVarIndex, a)]
vs
StateT
(TVarIndex, Map TVarIndex TVarIndex) 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 (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(AExpr a -> TypeExpr -> AExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(AExpr a -> TypeExpr -> AExpr a)
-> NormState (AExpr a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) 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
(TVarIndex, Map TVarIndex TVarIndex) 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
(TVarIndex, Map TVarIndex TVarIndex) Identity (APattern a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(AExpr a -> ABranchExpr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> APattern a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (APattern a)
forall a. Normalize a => a -> NormState a
normalize APattern a
p StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(AExpr a -> ABranchExpr a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (AExpr a)
-> NormState (ABranchExpr a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AExpr a
-> StateT (TVarIndex, Map TVarIndex TVarIndex) 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 :: [(TVarIndex, a)]
vs) = a -> (QName, a) -> [(TVarIndex, a)] -> APattern a
forall a. a -> (QName, a) -> [(TVarIndex, a)] -> APattern a
APattern (a -> (QName, a) -> [(TVarIndex, a)] -> APattern a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
((QName, a) -> [(TVarIndex, a)] -> APattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
((QName, a) -> [(TVarIndex, a)] -> APattern a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (QName, a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([(TVarIndex, a)] -> APattern a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (QName, a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (QName, a)
forall a. Normalize a => a -> NormState a
normalize (QName, a)
c
StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([(TVarIndex, a)] -> APattern a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity [(TVarIndex, a)]
-> NormState (APattern a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((TVarIndex, a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TVarIndex, a))
-> [(TVarIndex, a)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity [(TVarIndex, a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TVarIndex, a)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TVarIndex, a)
forall a. Normalize a => a -> NormState a
normalize [(TVarIndex, 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 (TVarIndex, Map TVarIndex TVarIndex) Identity a
-> NormState (APattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity a
forall a. Normalize a => a -> NormState a
normalize a
ty
trQualIdent :: QualIdent -> FlatState QName
trQualIdent :: QualIdent -> StateT FlatEnv Identity QName
trQualIdent qid :: QualIdent
qid = do
ModuleIdent
mid <- FlatState ModuleIdent
getModuleIdent
QName -> StateT FlatEnv Identity QName
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> StateT FlatEnv Identity QName)
-> QName -> StateT FlatEnv Identity 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