Commit 39ead6a9 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Refactorings and improved dumps (now with environments)

parent f6dca38a
...@@ -67,7 +67,7 @@ Executable cymake ...@@ -67,7 +67,7 @@ Executable cymake
, Env.Interface , Env.Interface
, Env.ModuleAlias , Env.ModuleAlias
, Env.OpPrec , Env.OpPrec
, Env.TypeConstructors , Env.TypeConstructor
, Env.Value , Env.Value
, Exports , Exports
, Frontend , Frontend
......
...@@ -17,7 +17,7 @@ import Base.Types ...@@ -17,7 +17,7 @@ import Base.Types
import Base.Utils (findMultiples) import Base.Utils (findMultiples)
import Env.ModuleAlias import Env.ModuleAlias
import Env.TypeConstructors import Env.TypeConstructor
import Env.Value import Env.Value
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
......
...@@ -36,7 +36,7 @@ is defined more than once. ...@@ -36,7 +36,7 @@ is defined more than once.
> import Base.TopEnv > import Base.TopEnv
> import Base.Utils (findMultiples) > import Base.Utils (findMultiples)
> import Env.TypeConstructors (TCEnv, tcArity) > import Env.TypeConstructor (TCEnv, tcArity)
\end{verbatim} \end{verbatim}
In order to check type constructor applications, the compiler In order to check type constructor applications, the compiler
......
...@@ -38,7 +38,7 @@ merged into a single definition. ...@@ -38,7 +38,7 @@ merged into a single definition.
> import Base.Types > import Base.Types
> import Base.Utils ((++!), findDouble, findMultiples) > import Base.Utils ((++!), findDouble, findMultiples)
> import Env.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC) > import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTC)
> import Env.Value (ValueEnv, ValueInfo (..)) > import Env.Value (ValueEnv, ValueInfo (..))
> import CompilerOpts > import CompilerOpts
......
...@@ -45,7 +45,7 @@ type annotation is present. ...@@ -45,7 +45,7 @@ type annotation is present.
> import Base.TypeSubst > import Base.TypeSubst
> import Base.Utils (foldr2) > import Base.Utils (foldr2)
> import Env.TypeConstructors (TCEnv, TypeInfo (..), bindTypeInfo > import Env.TypeConstructor (TCEnv, TypeInfo (..), bindTypeInfo
> , qualLookupTC) > , qualLookupTC)
> import Env.Value ( ValueEnv, ValueInfo (..), bindFun, rebindFun > import Env.Value ( ValueEnv, ValueInfo (..), bindFun, rebindFun
> , bindGlobalInfo, bindLabel, lookupValue, qualLookupValue ) > , bindGlobalInfo, bindLabel, lookupValue, qualLookupValue )
......
...@@ -13,13 +13,17 @@ ...@@ -13,13 +13,17 @@
-} -}
module CompilerEnv where module CompilerEnv where
import qualified Data.Map as Map (keys)
import Curry.Base.Ident (ModuleIdent) import Curry.Base.Ident (ModuleIdent)
import Base.TopEnv (localBindings)
import Env.Eval import Env.Eval
import Env.Interface import Env.Interface
import Env.ModuleAlias import Env.ModuleAlias
import Env.OpPrec import Env.OpPrec
import Env.TypeConstructors import Env.TypeConstructor
import Env.Value import Env.Value
-- |A compiler environment contains information about the module currently -- |A compiler environment contains information about the module currently
...@@ -33,7 +37,7 @@ data CompilerEnv = CompilerEnv ...@@ -33,7 +37,7 @@ data CompilerEnv = CompilerEnv
, valueEnv :: ValueEnv -- ^ functions and data constructors , valueEnv :: ValueEnv -- ^ functions and data constructors
, opPrecEnv :: PEnv -- ^ operator precedences , opPrecEnv :: PEnv -- ^ operator precedences
, evalAnnotEnv :: EvalEnv -- ^ evaluation annotations , evalAnnotEnv :: EvalEnv -- ^ evaluation annotations
} deriving Show }
initCompilerEnv :: ModuleIdent -> CompilerEnv initCompilerEnv :: ModuleIdent -> CompilerEnv
initCompilerEnv mid = CompilerEnv initCompilerEnv mid = CompilerEnv
...@@ -45,3 +49,15 @@ initCompilerEnv mid = CompilerEnv ...@@ -45,3 +49,15 @@ initCompilerEnv mid = CompilerEnv
, opPrecEnv = initPEnv , opPrecEnv = initPEnv
, evalAnnotEnv = initEEnv , evalAnnotEnv = initEEnv
} }
showCompilerEnv :: CompilerEnv -> String
showCompilerEnv env = unlines $ concat
[ header "ModuleIdent" $ show $ moduleIdent env
, header "Interfaces" $ show $ Map.keys $ interfaceEnv env
, header "ModuleAliases" $ show $ aliasEnv env
, header "TypeConstructors" $ show $ localBindings $ tyConsEnv env
, header "Values" $ show $ localBindings $ valueEnv env
, header "Precedences" $ show $ localBindings $ opPrecEnv env
, header "Eval Annotations" $ show $ evalAnnotEnv env
]
where header hdr content = [hdr, replicate (length hdr) '=', content]
\ No newline at end of file
...@@ -91,7 +91,6 @@ classifyVerbosity _ v = v ...@@ -91,7 +91,6 @@ classifyVerbosity _ v = v
-- |Data type for representing code dumps -- |Data type for representing code dumps
data DumpLevel data DumpLevel
= DumpRenamed -- ^ dump source after renaming = DumpRenamed -- ^ dump source after renaming
| DumpTypes -- ^ dump types after typechecking
| DumpDesugared -- ^ dump source after desugaring | DumpDesugared -- ^ dump source after desugaring
| DumpSimplified -- ^ dump source after simplification | DumpSimplified -- ^ dump source after simplification
| DumpLifted -- ^ dump source after lambda-lifting | DumpLifted -- ^ dump source after lambda-lifting
...@@ -210,9 +209,6 @@ options = ...@@ -210,9 +209,6 @@ options =
(NoArg (\ opts -> opts { optDumps = (NoArg (\ opts -> opts { optDumps =
nub $ DumpRenamed : optDumps opts })) nub $ DumpRenamed : optDumps opts }))
"dump source code after renaming" "dump source code after renaming"
, Option "" ["dump-types"]
(NoArg (\ opts -> opts { optDumps = nub $ DumpTypes : optDumps opts }))
"dump types after type-checking"
, Option "" ["dump-desugared"] , Option "" ["dump-desugared"]
(NoArg (\ opts -> opts { optDumps = (NoArg (\ opts -> opts { optDumps =
nub $ DumpDesugared : optDumps opts })) nub $ DumpDesugared : optDumps opts }))
......
{- |
Module : $Header$
Description : Environment of Evaluation Annotations
Copyright : (c) 2001-2004, Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
This module computes the evaluation annotation environment. There is no
need to check the annotations because this happens already while checking
the definitions of the module.
-}
module Env.Eval (EvalEnv, initEEnv, evalEnv) where
import qualified Data.Map as Map (Map, empty, insert)
import Curry.Base.Ident (Ident)
import Curry.Syntax
type EvalEnv = Map.Map Ident EvalAnnotation
initEEnv :: EvalEnv
initEEnv = Map.empty
-- |The function 'evalEnv' collects all evaluation annotations of
-- the module by traversing the syntax tree.
evalEnv :: Module -> EvalEnv
evalEnv (Module _ _ _ ds) = foldr annDecl initEEnv ds
annDecl :: Decl -> EvalEnv -> EvalEnv
annDecl (EvalAnnot _ fs ev) env = foldr (`Map.insert` ev) env fs
annDecl (FunctionDecl _ _ eqs) env = foldr annEquation env eqs
annDecl (PatternDecl _ _ rhs) env = annRhs rhs env
annDecl _ env = env
annEquation :: Equation -> EvalEnv -> EvalEnv
annEquation (Equation _ _ rhs) = annRhs rhs
annRhs :: Rhs -> EvalEnv -> EvalEnv
annRhs (SimpleRhs _ e ds) env = annExpr e (foldr annDecl env ds)
annRhs (GuardedRhs es ds) env = foldr annCondExpr (foldr annDecl env ds) es
annCondExpr :: CondExpr -> EvalEnv -> EvalEnv
annCondExpr (CondExpr _ g e) env = annExpr g (annExpr e env)
annExpr :: Expression -> EvalEnv -> EvalEnv
annExpr (Literal _) env = env
annExpr (Variable _) env = env
annExpr (Constructor _) env = env
annExpr (Paren e) env = annExpr e env
annExpr (Typed e _) env = annExpr e env
annExpr (Tuple _ es) env = foldr annExpr env es
annExpr (List _ es) env = foldr annExpr env es
annExpr (ListCompr _ e qs) env = annExpr e (foldr annStatement env qs)
annExpr (EnumFrom e) env = annExpr e env
annExpr (EnumFromThen e1 e2) env = annExpr e1 (annExpr e2 env)
annExpr (EnumFromTo e1 e2) env = annExpr e1 (annExpr e2 env)
annExpr (EnumFromThenTo e1 e2 e3) env = annExpr e1 (annExpr e2 (annExpr e3 env))
annExpr (UnaryMinus _ e) env = annExpr e env
annExpr (Apply e1 e2) env = annExpr e1 (annExpr e2 env)
annExpr (InfixApply e1 _ e2) env = annExpr e1 (annExpr e2 env)
annExpr (LeftSection e _) env = annExpr e env
annExpr (RightSection _ e) env = annExpr e env
annExpr (Lambda _ _ e) env = annExpr e env
annExpr (Let ds e) env = foldr annDecl (annExpr e env) ds
annExpr (Do sts e) env = foldr annStatement (annExpr e env) sts
annExpr (IfThenElse _ e1 e2 e3) env = annExpr e1 (annExpr e2 (annExpr e3 env))
annExpr (Case _ e alts) env = annExpr e (foldr annAlt env alts)
annExpr (RecordConstr fs) env = foldr (annExpr . fieldTerm) env fs
annExpr (RecordSelection e _) env = annExpr e env
annExpr (RecordUpdate fs e) env = foldr (annExpr . fieldTerm) (annExpr e env) fs
annStatement :: Statement -> EvalEnv -> EvalEnv
annStatement (StmtExpr _ e) env = annExpr e env
annStatement (StmtDecl ds) env = foldr annDecl env ds
annStatement (StmtBind _ _ e) env = annExpr e env
annAlt :: Alt -> EvalEnv -> EvalEnv
annAlt (Alt _ _ rhs) = annRhs rhs
% $Id: Eval.lhs,v 1.12 2004/02/08 15:35:12 wlux Exp $
%
% Copyright (c) 2001-2004, Wolfgang Lux
% See LICENSE for the full license.
%
\nwfilename{Eval.lhs}
\section{Collecting Evaluation Annotations}
The module \texttt{Eval} computes the evaluation annotation
environment. There is no need to check the annotations because this
happens already while checking the definitions of the module.
\begin{verbatim}
> module Env.Eval (EvalEnv, initEEnv, evalEnv) where
> import qualified Data.Map as Map
> import Curry.Base.Ident (Ident)
> import Curry.Syntax
> type EvalEnv = Map.Map Ident EvalAnnotation
\end{verbatim}
The function \texttt{evalEnv} collects all evaluation annotations of
the module by traversing the syntax tree.
\begin{verbatim}
> initEEnv :: EvalEnv
> initEEnv = Map.empty
> evalEnv :: Module -> EvalEnv
> evalEnv (Module _ _ _ ds) = foldr collectAnnotsDecl initEEnv ds
> collectAnnotsDecl :: Decl -> EvalEnv -> EvalEnv
> collectAnnotsDecl (EvalAnnot _ fs ev) env = foldr (`Map.insert` ev) env fs
> collectAnnotsDecl (FunctionDecl _ _ eqs) env = foldr collectAnnotsEqn env eqs
> collectAnnotsDecl (PatternDecl _ _ rhs) env = collectAnnotsRhs rhs env
> collectAnnotsDecl _ env = env
> collectAnnotsEqn :: Equation -> EvalEnv -> EvalEnv
> collectAnnotsEqn (Equation _ _ rhs) = collectAnnotsRhs rhs
> collectAnnotsRhs :: Rhs -> EvalEnv -> EvalEnv
> collectAnnotsRhs (SimpleRhs _ e ds) env =
> collectAnnotsExpr e (foldr collectAnnotsDecl env ds)
> collectAnnotsRhs (GuardedRhs es ds) env =
> foldr collectAnnotsCondExpr (foldr collectAnnotsDecl env ds) es
> collectAnnotsCondExpr :: CondExpr -> EvalEnv -> EvalEnv
> collectAnnotsCondExpr (CondExpr _ g e) env =
> collectAnnotsExpr g (collectAnnotsExpr e env)
> collectAnnotsExpr :: Expression -> EvalEnv -> EvalEnv
> collectAnnotsExpr (Literal _) env = env
> collectAnnotsExpr (Variable _) env = env
> collectAnnotsExpr (Constructor _) env = env
> collectAnnotsExpr (Paren e) env = collectAnnotsExpr e env
> collectAnnotsExpr (Typed e _) env = collectAnnotsExpr e env
> collectAnnotsExpr (Tuple _ es) env = foldr collectAnnotsExpr env es
> collectAnnotsExpr (List _ es) env = foldr collectAnnotsExpr env es
> collectAnnotsExpr (ListCompr _ e qs) env =
> collectAnnotsExpr e (foldr collectAnnotsStmt env qs)
> collectAnnotsExpr (EnumFrom e) env = collectAnnotsExpr e env
> collectAnnotsExpr (EnumFromThen e1 e2) env =
> collectAnnotsExpr e1 (collectAnnotsExpr e2 env)
> collectAnnotsExpr (EnumFromTo e1 e2) env =
> collectAnnotsExpr e1 (collectAnnotsExpr e2 env)
> collectAnnotsExpr (EnumFromThenTo e1 e2 e3) env =
> collectAnnotsExpr e1 (collectAnnotsExpr e2 (collectAnnotsExpr e3 env))
> collectAnnotsExpr (UnaryMinus _ e) env = collectAnnotsExpr e env
> collectAnnotsExpr (Apply e1 e2) env =
> collectAnnotsExpr e1 (collectAnnotsExpr e2 env)
> collectAnnotsExpr (InfixApply e1 _ e2) env =
> collectAnnotsExpr e1 (collectAnnotsExpr e2 env)
> collectAnnotsExpr (LeftSection e _) env = collectAnnotsExpr e env
> collectAnnotsExpr (RightSection _ e) env = collectAnnotsExpr e env
> collectAnnotsExpr (Lambda _ _ e) env = collectAnnotsExpr e env
> collectAnnotsExpr (Let ds e) env =
> foldr collectAnnotsDecl (collectAnnotsExpr e env) ds
> collectAnnotsExpr (Do sts e) env =
> foldr collectAnnotsStmt (collectAnnotsExpr e env) sts
> collectAnnotsExpr (IfThenElse _ e1 e2 e3) env =
> collectAnnotsExpr e1 (collectAnnotsExpr e2 (collectAnnotsExpr e3 env))
> collectAnnotsExpr (Case _ e alts) env =
> collectAnnotsExpr e (foldr collectAnnotsAlt env alts)
> collectAnnotsExpr (RecordConstr fs) env =
> foldr (collectAnnotsExpr . fieldTerm) env fs
> collectAnnotsExpr (RecordSelection e _) env = collectAnnotsExpr e env
> collectAnnotsExpr (RecordUpdate fs e) env =
> foldr (collectAnnotsExpr . fieldTerm) (collectAnnotsExpr e env) fs
> collectAnnotsStmt :: Statement -> EvalEnv -> EvalEnv
> collectAnnotsStmt (StmtExpr _ e) env = collectAnnotsExpr e env
> collectAnnotsStmt (StmtDecl ds) env = foldr collectAnnotsDecl env ds
> collectAnnotsStmt (StmtBind _ _ e) env = collectAnnotsExpr e env
> collectAnnotsAlt :: Alt -> EvalEnv -> EvalEnv
> collectAnnotsAlt (Alt _ _ rhs) = collectAnnotsRhs rhs
\end{verbatim}
{- |
Module : $Header$
Description : Environment of Operator precedences
Copyright : (c) 2002-2004, Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
In order to parse infix expressions correctly, the compiler must know
the precedence and fixity of each operator. Operator precedences are
associated with entities and will be checked after renaming was
applied. Nevertheless, we need to save precedences for ambiguous names
in order to handle them correctly while computing the exported
interface of a module.
If no fixity is assigned to an operator, it will be given the default
precedence 9 and assumed to be a left-associative operator.
\em{Note:} this modified version uses Haskell type \texttt{Integer}
for representing the precedence. This change had to be done due to the
introduction of unlimited integer constants in the parser / lexer.
-}
module Env.OpPrec
( PEnv, PrecInfo (..), OpPrec (..), defaultP, bindP, lookupP, qualLookupP
, initPEnv ) where
import Curry.Base.Ident
import Curry.Syntax (Infix (..))
import Base.TopEnv
data OpPrec = OpPrec Infix Integer deriving Eq
instance Show OpPrec where
showsPrec _ (OpPrec fix p) = showString (assoc fix) . shows p
where assoc InfixL = "left "
assoc InfixR = "right "
assoc Infix = "non-assoc "
defaultP :: OpPrec
defaultP = OpPrec InfixL 9
data PrecInfo = PrecInfo QualIdent OpPrec deriving (Eq, Show)
instance Entity PrecInfo where
origName (PrecInfo op _) = op
type PEnv = TopEnv PrecInfo
bindP :: ModuleIdent -> Ident -> OpPrec -> PEnv -> PEnv
bindP m op p
| uniqueId op == 0 = bindTopEnv fun op info . qualBindTopEnv fun qop info
| otherwise = bindTopEnv fun op info
where qop = qualifyWith m op
info = PrecInfo qop p
fun = "Env.OpPrec.bindP"
-- The lookup functions for the environment which maintains the operator
-- precedences are simpler than for the type and value environments
-- because they do not need to handle tuple constructors.
lookupP :: Ident -> PEnv -> [PrecInfo]
lookupP = lookupTopEnv
qualLookupP :: QualIdent -> PEnv -> [PrecInfo]
qualLookupP = qualLookupTopEnv
initPEnv :: PEnv
initPEnv = predefTopEnv qConsId consPrec emptyTopEnv
consPrec :: PrecInfo
consPrec = PrecInfo qConsId (OpPrec InfixR 5)
\paragraph{Operator precedences}
In order to parse infix expressions correctly, the compiler must know
the precedence and fixity of each operator. Operator precedences are
associated with entities and will be checked after renaming was
applied. Nevertheless, we need to save precedences for ambiguous names
in order to handle them correctly while computing the exported
interface of a module.
If no fixity is assigned to an operator, it will be given the default
precedence 9 and assumed to be a left-associative operator.
\em{Note:} this modified version uses Haskell type \texttt{Integer}
for representing the precedence. This change had to be done due to the
introduction of unlimited integer constants in the parser / lexer.
\begin{verbatim}
> module Env.OpPrec
> ( PEnv, PrecInfo (..), OpPrec (..), defaultP, bindP, lookupP, qualLookupP
> , initPEnv ) where
> import Curry.Base.Ident
> import Curry.Syntax (Infix (..))
> import Base.TopEnv
> data OpPrec = OpPrec Infix Integer deriving Eq
> instance Show OpPrec where
> showsPrec _ (OpPrec fix p) = showString (assoc fix) . shows p
> where assoc InfixL = "left "
> assoc InfixR = "right "
> assoc Infix = "non-assoc "
> defaultP :: OpPrec
> defaultP = OpPrec InfixL 9
\end{verbatim}
The lookup functions for the environment which maintains the operator
precedences are simpler than for the type and value environments
because they do not need to handle tuple constructors.
\begin{verbatim}
> data PrecInfo = PrecInfo QualIdent OpPrec deriving (Eq, Show)
> instance Entity PrecInfo where
> origName (PrecInfo op _) = op
> type PEnv = TopEnv PrecInfo
> bindP :: ModuleIdent -> Ident -> OpPrec -> PEnv -> PEnv
> bindP m op p
> | uniqueId op == 0 = bindTopEnv "Base.bindP" op info
> . qualBindTopEnv "Base.bindP" qop info
> | otherwise = bindTopEnv "Base.bindP" op info
> where qop = qualifyWith m op
> info = PrecInfo qop p
> lookupP :: Ident -> PEnv -> [PrecInfo]
> lookupP = lookupTopEnv
> qualLookupP :: QualIdent -> PEnv -> [PrecInfo]
> qualLookupP = qualLookupTopEnv
> initPEnv :: PEnv
> initPEnv =
> predefTopEnv qConsId (PrecInfo qConsId (OpPrec InfixR 5)) emptyTopEnv
\end{verbatim}
{- |
Module : $Header$
Description : Environment of type constructors
Copyright : (c) 2002-2004, Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
For all defined types the compiler must maintain kind information. At
present, Curry does not support type classes. Therefore its type
language is first order and the only information that must be recorded
is the arity of each type. For algebraic data types and renaming types
the compiler also records all data constructors belonging to that
type, for alias types the type expression to be expanded is saved. In
order to manage the import and export of types, the names of the
original definitions are also recorded. On import two types are
considered equal if their original names match.
The information for a data constructor comprises the number of
existentially quantified type variables and the list of the argument
types. Note that renaming type constructors have only one type
argument.
Importing and exporting algebraic data types and renaming types is
complicated by the fact that the constructors of the type may be
(partially) hidden in the interface. This facilitates the definition
of abstract data types. An abstract type is always represented as a
data type without constructors in the interface regardless of whether
it is defined as a data type or as a renaming type. When only some
constructors of a data type are hidden, those constructors are
replaced by underscores in the interface. Furthermore, if the
right-most constructors of a data type are hidden, they are not
exported at all in order to make the interface more stable against
changes which are private to the module.
-}
module Env.TypeConstructor
( TCEnv, TypeInfo (..), tcArity, bindTypeInfo, lookupTC, qualLookupTC
, lookupTupleTC, tupleTCs, tupleData, initTCEnv
) where
import Control.Monad (mplus)
import Curry.Base.Ident
import Base.TopEnv
import Base.Types
import Base.Utils ((++!))
data TypeInfo
= DataType QualIdent Int [Maybe DataConstr]
| RenamingType QualIdent Int DataConstr
| AliasType QualIdent Int Type
deriving Show
instance Entity TypeInfo where
origName (DataType tc _ _) = tc
origName (RenamingType tc _ _) = tc
origName (AliasType tc _ _) = tc
merge (DataType tc n cs) (DataType tc' _ cs')
| tc == tc' = Just $ DataType tc n $ mergeData cs cs'
where mergeData ds [] = ds
mergeData [] ds = ds
mergeData (d : ds) (d' : ds') = d `mplus` d' : mergeData ds ds'
merge (DataType tc n _) (RenamingType tc' _ nc)
| tc == tc' = Just (RenamingType tc n nc)
merge (RenamingType tc n nc) (DataType tc' _ _)
| tc == tc' = Just (RenamingType tc n nc)
merge (RenamingType tc n nc) (RenamingType tc' _ _)
| tc == tc' = Just (RenamingType tc n nc)
merge (AliasType tc n ty) (AliasType tc' _ _)
| tc == tc' = Just (AliasType tc n ty)
merge _ _ = Nothing
tcArity :: TypeInfo -> Int
tcArity (DataType _ n _) = n
tcArity (RenamingType _ n _) = n
tcArity (AliasType _ n _) = n
-- Types can only be defined on the top-level; no nested environments are
-- needed for them. Tuple types must be handled as a special case because
-- there is an infinite number of potential tuple types making it
-- impossible to insert them into the environment in advance.
type TCEnv = TopEnv TypeInfo
bindTypeInfo :: (QualIdent -> Int -> a -> TypeInfo) -> ModuleIdent
-> Ident -> [Ident] -> a -> TCEnv -> TCEnv
bindTypeInfo f m tc tvs x = bindTopEnv fun tc ty . qualBindTopEnv fun qtc ty
where qtc = qualifyWith m tc
ty = f qtc (length tvs) x
fun = "Base.bindTypeInfo"
lookupTC :: Ident -> TCEnv -> [TypeInfo]
lookupTC tc tcEnv = lookupTopEnv tc tcEnv ++! lookupTupleTC tc
qualLookupTC :: QualIdent -> TCEnv -> [TypeInfo]
qualLookupTC tc tcEnv = qualLookupTopEnv tc tcEnv
++! lookupTupleTC (unqualify tc)
lookupTupleTC :: Ident -> [TypeInfo]
lookupTupleTC tc | isTupleId tc = [tupleTCs !! (tupleArity tc - 2)]
| otherwise = []
tupleTCs :: [TypeInfo]
tupleTCs = map typeInfo tupleData
where typeInfo (DataConstr c _ tys) =
DataType (qualifyWith preludeMIdent c) (length tys)
[Just (DataConstr c 0 tys)]
tupleData :: [DataConstr]
tupleData = [DataConstr (tupleId n) 0 (take n tvs) | n <- [2 ..]]
where tvs = map typeVar [0 ..]
initTCEnv :: TCEnv
initTCEnv = foldr (uncurry predefTC) emptyTopEnv predefTypes
where predefTC (TypeConstructor tc tys) =
predefTopEnv (qualify (unqualify tc)) .
DataType tc (length tys) . map Just