{-# LANGUAGE CPP #-}
module Generators.GenTypedFlatCurry (genTypedFlatCurry) 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.Typed.Goodies (typeName)
import Curry.FlatCurry.Typed.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)
genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module
-> TProg
genTypedFlatCurry :: CompilerEnv -> Module Type -> Module -> TProg
genTypedFlatCurry env :: CompilerEnv
env mdl :: Module Type
mdl il :: Module
il = TProg -> TProg
patchPrelude (TProg -> TProg) -> TProg -> TProg
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> Module Type -> FlatState TProg -> TProg
forall a. CompilerEnv -> Module Type -> FlatState a -> a
run CompilerEnv
env Module Type
mdl (Module -> FlatState TProg
trModule Module
il)
patchPrelude :: TProg -> TProg
patchPrelude :: TProg -> TProg
patchPrelude p :: TProg
p@(TProg n :: String
n _ ts :: [TypeDecl]
ts fs :: [TFuncDecl]
fs os :: [OpDecl]
os)
| String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
prelude = String
-> [String] -> [TypeDecl] -> [TFuncDecl] -> [OpDecl] -> TProg
TProg String
n [] [TypeDecl]
ts' [TFuncDecl]
fs [OpDecl]
os
| Bool
otherwise = TProg
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
("GenTypedFlatCurry.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
$ "GenFlatCurry.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 TProg
trModule :: Module -> FlatState TProg
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
[TFuncDecl]
fds <- (Decl -> StateT FlatEnv Identity [TFuncDecl])
-> [Decl] -> StateT FlatEnv Identity [TFuncDecl]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM ([TFuncDecl] -> StateT FlatEnv Identity [TFuncDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TFuncDecl] -> StateT FlatEnv Identity [TFuncDecl])
-> ([TFuncDecl] -> [TFuncDecl])
-> [TFuncDecl]
-> StateT FlatEnv Identity [TFuncDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TFuncDecl -> TFuncDecl) -> [TFuncDecl] -> [TFuncDecl]
forall a b. (a -> b) -> [a] -> [b]
map TFuncDecl -> TFuncDecl
forall a. Normalize a => a -> a
runNormalization ([TFuncDecl] -> StateT FlatEnv Identity [TFuncDecl])
-> (Decl -> StateT FlatEnv Identity [TFuncDecl])
-> Decl
-> StateT FlatEnv Identity [TFuncDecl]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Decl -> StateT FlatEnv Identity [TFuncDecl]
trTFuncDecl) [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
TProg -> FlatState TProg
forall (m :: * -> *) a. Monad m => a -> m a
return (TProg -> FlatState TProg) -> TProg -> FlatState TProg
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> [TypeDecl] -> [TFuncDecl] -> [OpDecl] -> TProg
TProg (ModuleIdent -> String
moduleName ModuleIdent
mid) [String]
is' ([TypeDecl]
sns [TypeDecl] -> [TypeDecl] -> [TypeDecl]
forall a. [a] -> [a] -> [a]
++ [TypeDecl]
tds) [TFuncDecl]
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
trTFuncDecl :: IL.Decl -> FlatState [TFuncDecl]
trTFuncDecl :: Decl -> StateT FlatEnv Identity [TFuncDecl]
trTFuncDecl (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
TRule
r' <- [(Type, Ident)] -> Expression -> FlatState TRule
trTRule [(Type, Ident)]
vs Expression
e
[TFuncDecl] -> StateT FlatEnv Identity [TFuncDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> TVarIndex -> Visibility -> TypeExpr -> TRule -> TFuncDecl
TFunc QName
f' TVarIndex
a Visibility
vis TypeExpr
ty' TRule
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
trTFuncDecl (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
TRule
r' <- Type -> QualIdent -> FlatState TRule
trTExternal Type
ty QualIdent
f
[TFuncDecl] -> StateT FlatEnv Identity [TFuncDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [QName -> TVarIndex -> Visibility -> TypeExpr -> TRule -> TFuncDecl
TFunc QName
f' TVarIndex
a Visibility
vis TypeExpr
ty' TRule
r']
trTFuncDecl _ = [TFuncDecl] -> StateT FlatEnv Identity [TFuncDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []
trTRule :: [(IL.Type, Ident)] -> IL.Expression
-> FlatState TRule
trTRule :: [(Type, Ident)] -> Expression -> FlatState TRule
trTRule vs :: [(Type, Ident)]
vs e :: Expression
e = FlatState TRule -> FlatState TRule
forall a. FlatState a -> FlatState a
withFreshEnv (FlatState TRule -> FlatState TRule)
-> FlatState TRule -> FlatState TRule
forall a b. (a -> b) -> a -> b
$ [(TVarIndex, TypeExpr)] -> TExpr -> TRule
TRule ([(TVarIndex, TypeExpr)] -> TExpr -> TRule)
-> StateT FlatEnv Identity [(TVarIndex, TypeExpr)]
-> StateT FlatEnv Identity (TExpr -> TRule)
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 (TExpr -> TRule)
-> StateT FlatEnv Identity TExpr -> FlatState TRule
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity TExpr
trTExpr Expression
e
trTExternal :: IL.Type -> QualIdent -> FlatState TRule
trTExternal :: Type -> QualIdent -> FlatState TRule
trTExternal ty :: Type
ty f :: QualIdent
f = (TypeExpr -> String -> TRule) -> String -> TypeExpr -> TRule
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeExpr -> String -> TRule
TExternal (QualIdent -> String
qualName QualIdent
f) (TypeExpr -> TRule) -> FlatState TypeExpr -> FlatState TRule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty
trTExpr :: IL.Expression -> FlatState TExpr
trTExpr :: Expression -> StateT FlatEnv Identity TExpr
trTExpr (IL.Literal ty :: Type
ty l :: Literal
l) = TypeExpr -> Literal -> TExpr
TLit (TypeExpr -> Literal -> TExpr)
-> FlatState TypeExpr -> StateT FlatEnv Identity (Literal -> TExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT FlatEnv Identity (Literal -> TExpr)
-> StateT FlatEnv Identity Literal -> StateT FlatEnv Identity TExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Literal -> StateT FlatEnv Identity Literal
trLiteral Literal
l
trTExpr (IL.Variable ty :: Type
ty v :: Ident
v) = TypeExpr -> TVarIndex -> TExpr
TVarE (TypeExpr -> TVarIndex -> TExpr)
-> FlatState TypeExpr
-> StateT FlatEnv Identity (TVarIndex -> TExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT FlatEnv Identity (TVarIndex -> TExpr)
-> FlatState TVarIndex -> StateT FlatEnv Identity TExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ident -> FlatState TVarIndex
getVarIndex Ident
v
trTExpr (IL.Function ty :: Type
ty f :: QualIdent
f _) = Call
-> Type
-> QualIdent
-> [Expression]
-> StateT FlatEnv Identity TExpr
genCall Call
Fun Type
ty QualIdent
f []
trTExpr (IL.Constructor ty :: Type
ty c :: QualIdent
c _) = Call
-> Type
-> QualIdent
-> [Expression]
-> StateT FlatEnv Identity TExpr
genCall Call
Con Type
ty QualIdent
c []
trTExpr (IL.Apply e1 :: Expression
e1 e2 :: Expression
e2) = Expression -> Expression -> StateT FlatEnv Identity TExpr
trApply Expression
e1 Expression
e2
trTExpr (IL.Case t :: Eval
t e :: Expression
e bs :: [Alt]
bs) = CaseType -> TExpr -> [TBranchExpr] -> TExpr
TCase (Eval -> CaseType
cvEval Eval
t) (TExpr -> [TBranchExpr] -> TExpr)
-> StateT FlatEnv Identity TExpr
-> StateT FlatEnv Identity ([TBranchExpr] -> TExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> StateT FlatEnv Identity TExpr
trTExpr Expression
e
StateT FlatEnv Identity ([TBranchExpr] -> TExpr)
-> StateT FlatEnv Identity [TBranchExpr]
-> StateT FlatEnv Identity TExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Alt -> StateT FlatEnv Identity TBranchExpr)
-> [Alt] -> StateT FlatEnv Identity [TBranchExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StateT FlatEnv Identity TBranchExpr
-> StateT FlatEnv Identity TBranchExpr
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity TBranchExpr
-> StateT FlatEnv Identity TBranchExpr)
-> (Alt -> StateT FlatEnv Identity TBranchExpr)
-> Alt
-> StateT FlatEnv Identity TBranchExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt -> StateT FlatEnv Identity TBranchExpr
trAlt) [Alt]
bs
trTExpr (IL.Or e1 :: Expression
e1 e2 :: Expression
e2) = TExpr -> TExpr -> TExpr
TOr (TExpr -> TExpr -> TExpr)
-> StateT FlatEnv Identity TExpr
-> StateT FlatEnv Identity (TExpr -> TExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> StateT FlatEnv Identity TExpr
trTExpr Expression
e1 StateT FlatEnv Identity (TExpr -> TExpr)
-> StateT FlatEnv Identity TExpr -> StateT FlatEnv Identity TExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity TExpr
trTExpr Expression
e2
trTExpr (IL.Exist v :: Ident
v ty :: Type
ty e :: Expression
e) = StateT FlatEnv Identity TExpr -> StateT FlatEnv Identity TExpr
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity TExpr -> StateT FlatEnv Identity TExpr)
-> StateT FlatEnv Identity TExpr -> StateT FlatEnv Identity TExpr
forall a b. (a -> b) -> a -> b
$ do
(TVarIndex, TypeExpr)
v' <- Type -> Ident -> FlatState (TVarIndex, TypeExpr)
newVar Type
ty Ident
v
TExpr
e' <- Expression -> StateT FlatEnv Identity TExpr
trTExpr Expression
e
TExpr -> StateT FlatEnv Identity TExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (TExpr -> StateT FlatEnv Identity TExpr)
-> TExpr -> StateT FlatEnv Identity TExpr
forall a b. (a -> b) -> a -> b
$ case TExpr
e' of TFree vs :: [(TVarIndex, TypeExpr)]
vs e'' :: TExpr
e'' -> [(TVarIndex, TypeExpr)] -> TExpr -> TExpr
TFree ((TVarIndex, TypeExpr)
v' (TVarIndex, TypeExpr)
-> [(TVarIndex, TypeExpr)] -> [(TVarIndex, TypeExpr)]
forall a. a -> [a] -> [a]
: [(TVarIndex, TypeExpr)]
vs) TExpr
e''
_ -> [(TVarIndex, TypeExpr)] -> TExpr -> TExpr
TFree ((TVarIndex, TypeExpr)
v' (TVarIndex, TypeExpr)
-> [(TVarIndex, TypeExpr)] -> [(TVarIndex, TypeExpr)]
forall a. a -> [a] -> [a]
: []) TExpr
e'
trTExpr (IL.Let (IL.Binding v :: Ident
v b :: Expression
b) e :: Expression
e) = StateT FlatEnv Identity TExpr -> StateT FlatEnv Identity TExpr
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity TExpr -> StateT FlatEnv Identity TExpr)
-> StateT FlatEnv Identity TExpr -> StateT FlatEnv Identity TExpr
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
TExpr
b' <- Expression -> StateT FlatEnv Identity TExpr
trTExpr Expression
b
TExpr
e' <- Expression -> StateT FlatEnv Identity TExpr
trTExpr Expression
e
TExpr -> StateT FlatEnv Identity TExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (TExpr -> StateT FlatEnv Identity TExpr)
-> TExpr -> StateT FlatEnv Identity TExpr
forall a b. (a -> b) -> a -> b
$ case TExpr
e' of TLet bs :: [((TVarIndex, TypeExpr), TExpr)]
bs e'' :: TExpr
e'' -> [((TVarIndex, TypeExpr), TExpr)] -> TExpr -> TExpr
TLet (((TVarIndex, TypeExpr)
v', TExpr
b')((TVarIndex, TypeExpr), TExpr)
-> [((TVarIndex, TypeExpr), TExpr)]
-> [((TVarIndex, TypeExpr), TExpr)]
forall a. a -> [a] -> [a]
:[((TVarIndex, TypeExpr), TExpr)]
bs) TExpr
e''
_ -> [((TVarIndex, TypeExpr), TExpr)] -> TExpr -> TExpr
TLet (((TVarIndex, TypeExpr)
v', TExpr
b')((TVarIndex, TypeExpr), TExpr)
-> [((TVarIndex, TypeExpr), TExpr)]
-> [((TVarIndex, TypeExpr), TExpr)]
forall a. a -> [a] -> [a]
:[]) TExpr
e'
trTExpr (IL.Letrec bs :: [Binding]
bs e :: Expression
e) = StateT FlatEnv Identity TExpr -> StateT FlatEnv Identity TExpr
forall a. FlatState a -> FlatState a
inNestedEnv (StateT FlatEnv Identity TExpr -> StateT FlatEnv Identity TExpr)
-> StateT FlatEnv Identity TExpr -> StateT FlatEnv Identity TExpr
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]
[((TVarIndex, TypeExpr), TExpr)] -> TExpr -> TExpr
TLet ([((TVarIndex, TypeExpr), TExpr)] -> TExpr -> TExpr)
-> StateT FlatEnv Identity [((TVarIndex, TypeExpr), TExpr)]
-> StateT FlatEnv Identity (TExpr -> TExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([(TVarIndex, TypeExpr)]
-> [TExpr] -> [((TVarIndex, TypeExpr), TExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([(TVarIndex, TypeExpr)]
-> [TExpr] -> [((TVarIndex, TypeExpr), TExpr)])
-> StateT FlatEnv Identity [(TVarIndex, TypeExpr)]
-> StateT
FlatEnv Identity ([TExpr] -> [((TVarIndex, TypeExpr), TExpr)])
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 ([TExpr] -> [((TVarIndex, TypeExpr), TExpr)])
-> StateT FlatEnv Identity [TExpr]
-> StateT FlatEnv Identity [((TVarIndex, TypeExpr), TExpr)]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Expression -> StateT FlatEnv Identity TExpr)
-> [Expression] -> StateT FlatEnv Identity [TExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expression -> StateT FlatEnv Identity TExpr
trTExpr [Expression]
es)
StateT FlatEnv Identity (TExpr -> TExpr)
-> StateT FlatEnv Identity TExpr -> StateT FlatEnv Identity TExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity TExpr
trTExpr Expression
e
trTExpr (IL.Typed e :: Expression
e _) = TExpr -> TypeExpr -> TExpr
TTyped (TExpr -> TypeExpr -> TExpr)
-> StateT FlatEnv Identity TExpr
-> StateT FlatEnv Identity (TypeExpr -> TExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> StateT FlatEnv Identity TExpr
trTExpr Expression
e StateT FlatEnv Identity (TypeExpr -> TExpr)
-> FlatState TypeExpr -> StateT FlatEnv Identity TExpr
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 TExpr
trApply :: Expression -> Expression -> StateT FlatEnv Identity TExpr
trApply e1 :: Expression
e1 e2 :: Expression
e2 = Expression -> [Expression] -> StateT FlatEnv Identity TExpr
genFlatApplic Expression
e1 [Expression
e2]
where
genFlatApplic :: Expression -> [Expression] -> StateT FlatEnv Identity TExpr
genFlatApplic e :: Expression
e es :: [Expression]
es = case Expression
e of
IL.Apply ea :: Expression
ea eb :: Expression
eb -> Expression -> [Expression] -> StateT FlatEnv Identity TExpr
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 TExpr
genCall Call
Fun Type
ty QualIdent
f [Expression]
es
IL.Constructor ty :: Type
ty c :: QualIdent
c _ -> Call
-> Type
-> QualIdent
-> [Expression]
-> StateT FlatEnv Identity TExpr
genCall Call
Con Type
ty QualIdent
c [Expression]
es
_ -> do
TExpr
expr <- Expression -> StateT FlatEnv Identity TExpr
trTExpr Expression
e
TExpr -> [Expression] -> StateT FlatEnv Identity TExpr
genApply TExpr
expr [Expression]
es
trAlt :: IL.Alt -> FlatState TBranchExpr
trAlt :: Alt -> StateT FlatEnv Identity TBranchExpr
trAlt (IL.Alt p :: ConstrTerm
p e :: Expression
e) = TPattern -> TExpr -> TBranchExpr
TBranch (TPattern -> TExpr -> TBranchExpr)
-> StateT FlatEnv Identity TPattern
-> StateT FlatEnv Identity (TExpr -> TBranchExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstrTerm -> StateT FlatEnv Identity TPattern
trPat ConstrTerm
p StateT FlatEnv Identity (TExpr -> TBranchExpr)
-> StateT FlatEnv Identity TExpr
-> StateT FlatEnv Identity TBranchExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Expression -> StateT FlatEnv Identity TExpr
trTExpr Expression
e
trPat :: IL.ConstrTerm -> FlatState TPattern
trPat :: ConstrTerm -> StateT FlatEnv Identity TPattern
trPat (IL.LiteralPattern ty :: Type
ty l :: Literal
l) = TypeExpr -> Literal -> TPattern
TLPattern (TypeExpr -> Literal -> TPattern)
-> FlatState TypeExpr
-> StateT FlatEnv Identity (Literal -> TPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT FlatEnv Identity (Literal -> TPattern)
-> StateT FlatEnv Identity Literal
-> StateT FlatEnv Identity TPattern
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) =
TypeExpr -> QName -> [(TVarIndex, TypeExpr)] -> TPattern
TPattern (TypeExpr -> QName -> [(TVarIndex, TypeExpr)] -> TPattern)
-> FlatState TypeExpr
-> StateT
FlatEnv Identity (QName -> [(TVarIndex, TypeExpr)] -> TPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> FlatState TypeExpr
trType Type
ty StateT
FlatEnv Identity (QName -> [(TVarIndex, TypeExpr)] -> TPattern)
-> StateT FlatEnv Identity QName
-> StateT FlatEnv Identity ([(TVarIndex, TypeExpr)] -> TPattern)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QualIdent -> StateT FlatEnv Identity QName
trQualIdent QualIdent
c StateT FlatEnv Identity ([(TVarIndex, TypeExpr)] -> TPattern)
-> StateT FlatEnv Identity [(TVarIndex, TypeExpr)]
-> StateT FlatEnv Identity TPattern
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 TPattern
forall a. String -> a
internalError "GenTypedFlatCurry.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 TExpr
genCall :: Call
-> Type
-> QualIdent
-> [Expression]
-> StateT FlatEnv Identity TExpr
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 TExpr
genTComb 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 TExpr
genTComb 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
TExpr
funccall <- Type
-> QName
-> [Expression]
-> CombType
-> StateT FlatEnv Identity TExpr
genTComb Type
ty QName
f' [Expression]
es1 (Call -> CombType
full Call
call)
TExpr -> [Expression] -> StateT FlatEnv Identity TExpr
genApply TExpr
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
genTComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState TExpr
genTComb :: Type
-> QName
-> [Expression]
-> CombType
-> StateT FlatEnv Identity TExpr
genTComb 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 -> [TExpr] -> TExpr
TComb TypeExpr
ty'' CombType
ct QName
qid ([TExpr] -> TExpr)
-> StateT FlatEnv Identity [TExpr] -> StateT FlatEnv Identity TExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expression -> StateT FlatEnv Identity TExpr)
-> [Expression] -> StateT FlatEnv Identity [TExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expression -> StateT FlatEnv Identity TExpr
trTExpr [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 "GenTypedFlatCurry.genTComb.defunc"
genApply :: TExpr -> [IL.Expression] -> FlatState TExpr
genApply :: TExpr -> [Expression] -> StateT FlatEnv Identity TExpr
genApply e :: TExpr
e es :: [Expression]
es = do
QName
ap <- QualIdent -> StateT FlatEnv Identity QName
trQualIdent QualIdent
qApplyId
[TExpr]
es' <- (Expression -> StateT FlatEnv Identity TExpr)
-> [Expression] -> StateT FlatEnv Identity [TExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expression -> StateT FlatEnv Identity TExpr
trTExpr [Expression]
es
TExpr -> StateT FlatEnv Identity TExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (TExpr -> StateT FlatEnv Identity TExpr)
-> TExpr -> StateT FlatEnv Identity TExpr
forall a b. (a -> b) -> a -> b
$ (TExpr -> TExpr -> TExpr) -> TExpr -> [TExpr] -> TExpr
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\e1 :: TExpr
e1 e2 :: TExpr
e2 -> let FuncType _ ty2 :: TypeExpr
ty2 = TExpr -> TypeExpr
forall a. Typeable a => a -> TypeExpr
typeOf TExpr
e1
in TypeExpr -> CombType -> QName -> [TExpr] -> TExpr
TComb TypeExpr
ty2 CombType
FuncCall QName
ap [TExpr
e1, TExpr
e2])
TExpr
e [TExpr]
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 TFuncDecl where
normalize :: TFuncDecl -> NormState TFuncDecl
normalize (TFunc f :: QName
f a :: TVarIndex
a v :: Visibility
v ty :: TypeExpr
ty r :: TRule
r) = QName -> TVarIndex -> Visibility -> TypeExpr -> TRule -> TFuncDecl
TFunc QName
f TVarIndex
a Visibility
v (TypeExpr -> TRule -> TFuncDecl)
-> NormState TypeExpr
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TRule -> TFuncDecl)
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 (TRule -> TFuncDecl)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TRule
-> NormState TFuncDecl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TRule -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TRule
forall a. Normalize a => a -> NormState a
normalize TRule
r
instance Normalize TRule where
normalize :: TRule -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TRule
normalize (TRule vs :: [(TVarIndex, TypeExpr)]
vs e :: TExpr
e) = [(TVarIndex, TypeExpr)] -> TExpr -> TRule
TRule ([(TVarIndex, TypeExpr)] -> TExpr -> TRule)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
[(TVarIndex, TypeExpr)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TExpr -> TRule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((TVarIndex, TypeExpr)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(TVarIndex, TypeExpr))
-> [(TVarIndex, TypeExpr)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
[(TVarIndex, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TVarIndex, TypeExpr)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TVarIndex, TypeExpr)
forall a. Normalize a => a -> NormState a
normalize [(TVarIndex, TypeExpr)]
vs
StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TExpr -> TRule)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TRule
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TExpr -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall a. Normalize a => a -> NormState a
normalize TExpr
e
normalize (TExternal ty :: TypeExpr
ty s :: String
s) = (TypeExpr -> String -> TRule) -> String -> TypeExpr -> TRule
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeExpr -> String -> TRule
TExternal String
s (TypeExpr -> TRule)
-> NormState TypeExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TRule
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
instance Normalize TExpr where
normalize :: TExpr -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
normalize (TVarE ty :: TypeExpr
ty v :: TVarIndex
v) = (TypeExpr -> TVarIndex -> TExpr) -> TVarIndex -> TypeExpr -> TExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeExpr -> TVarIndex -> TExpr
TVarE TVarIndex
v (TypeExpr -> TExpr)
-> NormState TypeExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
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
normalize (TLit ty :: TypeExpr
ty l :: Literal
l) = (TypeExpr -> Literal -> TExpr) -> Literal -> TypeExpr -> TExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeExpr -> Literal -> TExpr
TLit Literal
l (TypeExpr -> TExpr)
-> NormState TypeExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
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
normalize (TComb ty :: TypeExpr
ty ct :: CombType
ct f :: QName
f es :: [TExpr]
es) = (TypeExpr -> CombType -> QName -> [TExpr] -> TExpr)
-> CombType -> TypeExpr -> QName -> [TExpr] -> TExpr
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeExpr -> CombType -> QName -> [TExpr] -> TExpr
TComb CombType
ct (TypeExpr -> QName -> [TExpr] -> TExpr)
-> NormState TypeExpr
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(QName -> [TExpr] -> TExpr)
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
(QName -> [TExpr] -> TExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity QName
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity ([TExpr] -> TExpr)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QName -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity QName
forall (f :: * -> *) a. Applicative f => a -> f a
pure QName
f
StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity ([TExpr] -> TExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity [TExpr]
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr)
-> [TExpr]
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity [TExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TExpr -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall a. Normalize a => a -> NormState a
normalize [TExpr]
es
normalize (TLet ds :: [((TVarIndex, TypeExpr), TExpr)]
ds e :: TExpr
e) = [((TVarIndex, TypeExpr), TExpr)] -> TExpr -> TExpr
TLet ([((TVarIndex, TypeExpr), TExpr)] -> TExpr -> TExpr)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
[((TVarIndex, TypeExpr), TExpr)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TExpr -> TExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((TVarIndex, TypeExpr), TExpr)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
((TVarIndex, TypeExpr), TExpr))
-> [((TVarIndex, TypeExpr), TExpr)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
[((TVarIndex, TypeExpr), TExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TVarIndex, TypeExpr), TExpr)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
((TVarIndex, TypeExpr), TExpr)
forall a a.
(Normalize a, Normalize a) =>
(a, a)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity (a, a)
normalizeBinding [((TVarIndex, TypeExpr), TExpr)]
ds
StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TExpr -> TExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TExpr -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall a. Normalize a => a -> NormState a
normalize TExpr
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 (TOr a :: TExpr
a b :: TExpr
b) = TExpr -> TExpr -> TExpr
TOr (TExpr -> TExpr -> TExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TExpr -> TExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TExpr -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall a. Normalize a => a -> NormState a
normalize TExpr
a
StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TExpr -> TExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TExpr -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall a. Normalize a => a -> NormState a
normalize TExpr
b
normalize (TCase ct :: CaseType
ct e :: TExpr
e bs :: [TBranchExpr]
bs) = CaseType -> TExpr -> [TBranchExpr] -> TExpr
TCase CaseType
ct (TExpr -> [TBranchExpr] -> TExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([TBranchExpr] -> TExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TExpr -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall a. Normalize a => a -> NormState a
normalize TExpr
e
StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([TBranchExpr] -> TExpr)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity [TBranchExpr]
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TBranchExpr
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity TBranchExpr)
-> [TBranchExpr]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity [TBranchExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TBranchExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TBranchExpr
forall a. Normalize a => a -> NormState a
normalize [TBranchExpr]
bs
normalize (TFree vs :: [(TVarIndex, TypeExpr)]
vs e :: TExpr
e) = [(TVarIndex, TypeExpr)] -> TExpr -> TExpr
TFree ([(TVarIndex, TypeExpr)] -> TExpr -> TExpr)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
[(TVarIndex, TypeExpr)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TExpr -> TExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((TVarIndex, TypeExpr)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(TVarIndex, TypeExpr))
-> [(TVarIndex, TypeExpr)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
[(TVarIndex, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TVarIndex, TypeExpr)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TVarIndex, TypeExpr)
forall a. Normalize a => a -> NormState a
normalize [(TVarIndex, TypeExpr)]
vs
StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TExpr -> TExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TExpr -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall a. Normalize a => a -> NormState a
normalize TExpr
e
normalize (TTyped e :: TExpr
e ty' :: TypeExpr
ty') = TExpr -> TypeExpr -> TExpr
TTyped (TExpr -> TypeExpr -> TExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TypeExpr -> TExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TExpr -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall a. Normalize a => a -> NormState a
normalize TExpr
e
StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TypeExpr -> TExpr)
-> NormState TypeExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
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 TBranchExpr where
normalize :: TBranchExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TBranchExpr
normalize (TBranch p :: TPattern
p e :: TExpr
e) = TPattern -> TExpr -> TBranchExpr
TBranch (TPattern -> TExpr -> TBranchExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TPattern
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(TExpr -> TBranchExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TPattern
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TPattern
forall a. Normalize a => a -> NormState a
normalize TPattern
p StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(TExpr -> TBranchExpr)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TBranchExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TExpr -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TExpr
forall a. Normalize a => a -> NormState a
normalize TExpr
e
instance Normalize TPattern where
normalize :: TPattern
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TPattern
normalize (TPattern ty :: TypeExpr
ty c :: QName
c vs :: [(TVarIndex, TypeExpr)]
vs) = TypeExpr -> QName -> [(TVarIndex, TypeExpr)] -> TPattern
TPattern (TypeExpr -> QName -> [(TVarIndex, TypeExpr)] -> TPattern)
-> NormState TypeExpr
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(QName -> [(TVarIndex, TypeExpr)] -> TPattern)
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
(QName -> [(TVarIndex, TypeExpr)] -> TPattern)
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity QName
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([(TVarIndex, TypeExpr)] -> TPattern)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QName -> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity QName
forall (f :: * -> *) a. Applicative f => a -> f a
pure QName
c
StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
([(TVarIndex, TypeExpr)] -> TPattern)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
[(TVarIndex, TypeExpr)]
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TPattern
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((TVarIndex, TypeExpr)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
(TVarIndex, TypeExpr))
-> [(TVarIndex, TypeExpr)]
-> StateT
(TVarIndex, Map TVarIndex TVarIndex)
Identity
[(TVarIndex, TypeExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TVarIndex, TypeExpr)
-> StateT
(TVarIndex, Map TVarIndex TVarIndex) Identity (TVarIndex, TypeExpr)
forall a. Normalize a => a -> NormState a
normalize [(TVarIndex, TypeExpr)]
vs
normalize (TLPattern ty :: TypeExpr
ty l :: Literal
l) = (TypeExpr -> Literal -> TPattern)
-> Literal -> TypeExpr -> TPattern
forall a b c. (a -> b -> c) -> b -> a -> c
flip TypeExpr -> Literal -> TPattern
TLPattern Literal
l (TypeExpr -> TPattern)
-> NormState TypeExpr
-> StateT (TVarIndex, Map TVarIndex TVarIndex) Identity TPattern
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
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