{- |
    Module      :  $Header$
    Description :  Generation of typed FlatCurry program terms
    Copyright   :  (c) 2017        Finn Teegen
                       2018        Kai-Oliver Prott
    License     :  BSD-3-clause

    Maintainer  :  fte@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module contains the generation of a typed 'FlatCurry' program term
    for a given module in the intermediate language.
-}
{-# 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)

-- transforms intermediate language code (IL) to typed FlatCurry code
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)

-- -----------------------------------------------------------------------------
-- Addition of primitive types for lists and tuples to the Prelude
-- -----------------------------------------------------------------------------

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"

-- |Maximal arity of tuples
maxTupleArity :: Int
maxTupleArity :: TVarIndex
maxTupleArity = 15

-- -----------------------------------------------------------------------------

-- The environment 'FlatEnv' is embedded in the monadic representation
-- 'FlatState' which allows the usage of 'do' expressions.
type FlatState a = S.State FlatEnv a

-- Data type for representing an environment which contains information needed
-- for generating FlatCurry code.
data FlatEnv = FlatEnv
  { FlatEnv -> ModuleIdent
modIdent     :: ModuleIdent      -- current module
  -- for visibility calculation
  , FlatEnv -> Set Ident
tyExports    :: Set.Set Ident    -- exported types
  , FlatEnv -> Set Ident
valExports   :: Set.Set Ident    -- exported values (functions + constructors)
  , FlatEnv -> TCEnv
tcEnv        :: TCEnv            -- type constructor environment
  , FlatEnv -> ValueEnv
tyEnv        :: ValueEnv         -- type environment
  , FlatEnv -> [IDecl]
fixities     :: [CS.IDecl]       -- fixity declarations
  , FlatEnv -> [Decl Type]
typeSynonyms :: [CS.Decl Type]   -- type synonyms
  , FlatEnv -> [ModuleIdent]
imports      :: [ModuleIdent]    -- module imports
  -- state for mapping identifiers to indexes
  , FlatEnv -> TVarIndex
nextVar      :: Int              -- fresh variable index counter
  , FlatEnv -> NestEnv TVarIndex
varMap       :: NestEnv VarIndex -- map of identifier to variable index
  }

-- Runs a 'FlatState' action and returns the result
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
     -- for visibility calculation
    , 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'
    -- This includes *all* imports, even unused ones
    , imports :: [ModuleIdent]
imports      = [ModuleIdent] -> [ModuleIdent]
forall a. Eq a => [a] -> [a]
nub [ ModuleIdent
m | CS.ImportDecl _ m :: ModuleIdent
m _ _ _ <- [ImportDecl]
is ]
    -- Environment to retrieve the type of identifiers
    , tyEnv :: ValueEnv
tyEnv        = CompilerEnv -> ValueEnv
valueEnv CompilerEnv
env
    , tcEnv :: TCEnv
tcEnv        = CompilerEnv -> TCEnv
tyConsEnv CompilerEnv
env
    -- Fixity declarations
    , 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
                     ]
    -- Type synonyms in the module
    , 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
    }

-- Builds a table containing all exported identifiers from a module.
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

-- Builds a table containing all exported identifiers from a module.
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

-- The function 'typeSynonyms' returns the list of type synonyms.
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

-- Retrieve imports
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

-- -----------------------------------------------------------------------------
-- Stateful part, used for translation of rules and expressions
-- -----------------------------------------------------------------------------

-- resets var index and environment
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

-- Execute an action in a nested variable mapping
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

-- Generates a new variable index for an identifier
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')

-- Retrieve the variable index assigned to an identifier
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

-- -----------------------------------------------------------------------------
-- Translation of an interface
-- -----------------------------------------------------------------------------

-- Translate an operator declaration
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 []

-- -----------------------------------------------------------------------------
-- Translation of a module
-- -----------------------------------------------------------------------------

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

-- Translate a type synonym
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 []

-- Translate a data declaration
-- For empty data declarations, an additional constructor is generated. This
-- is due to the fact that external data declarations are translated into data
-- declarations with zero constructors and without the additional constructor
-- empty data declarations could not be distinguished from external ones.
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 []

-- Translate a constructor declaration
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

-- Translate a type expression
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

-- Convert a fixity
cvFixity :: CS.Infix -> Fixity
cvFixity :: Infix -> Fixity
cvFixity CS.InfixL = Fixity
InfixlOp
cvFixity CS.InfixR = Fixity
InfixrOp
cvFixity CS.Infix  = Fixity
InfixOp

-- -----------------------------------------------------------------------------
-- Function declarations
-- -----------------------------------------------------------------------------

-- Translate a function declaration
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 []

-- Translate a function rule.
-- Resets variable index so that for every rule variables start with index 1
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

-- Translate an expression
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

-- Translate a literal
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

-- Translate a higher-order application
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

-- Translate an alternative
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

-- Translate a pattern
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"

-- Convert a case type
cvEval :: IL.Eval -> CaseType
cvEval :: Eval -> CaseType
cvEval IL.Rigid = CaseType
Rigid
cvEval IL.Flex  = CaseType
Flex

data Call = Fun | Con

-- Generate a function or constructor call
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'

-- -----------------------------------------------------------------------------
-- Normalization
-- -----------------------------------------------------------------------------

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

-- -----------------------------------------------------------------------------
-- Helper functions
-- -----------------------------------------------------------------------------

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