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

Integrated Env.Arity into Env.Value to resolve re-exporting bug

parent f148a9d0
......@@ -62,7 +62,6 @@ Executable cymake
, CompilerOpts
, CurryBuilder
, CurryDeps
, Env.Arity
, Env.Eval
, Env.Interface
, Env.Label
......
......@@ -37,16 +37,14 @@ This module implements substitutions on types.
> subst sigma (TypeConstructor tc tys) =
> TypeConstructor tc (map (subst sigma) tys)
> subst sigma (TypeVariable tv) = substVar sigma tv
> subst sigma (TypeConstrained tys tv) =
> case substVar sigma tv of
> subst sigma (TypeConstrained tys tv) = case substVar sigma tv of
> TypeVariable tv' -> TypeConstrained tys tv'
> ty -> ty
> subst sigma (TypeArrow ty1 ty2) =
> TypeArrow (subst sigma ty1) (subst sigma ty2)
> subst _ (TypeSkolem k) = TypeSkolem k
> subst _ ts@(TypeSkolem _) = ts
> subst sigma (TypeRecord fs rv)
> | isJust rv =
> case substVar sigma (fromJust rv) of
> | isJust rv = case substVar sigma (fromJust rv) of
> TypeVariable tv -> TypeRecord fs' (Just tv)
> ty -> ty
> | otherwise = TypeRecord fs' Nothing
......@@ -61,9 +59,9 @@ This module implements substitutions on types.
> ForAllExist n n' (subst (foldr unbindSubst sigma [0..n+n'-1]) ty)
> instance SubstType ValueInfo where
> subst _ (DataConstructor c ty) = DataConstructor c ty
> subst _ (NewtypeConstructor c ty) = NewtypeConstructor c ty
> subst theta (Value v ty) = Value v (subst theta ty)
> subst _ dc@(DataConstructor _ _ _) = dc
> subst _ nc@(NewtypeConstructor _ _) = nc
> subst theta (Value v a ty) = Value v a (subst theta ty)
> subst theta (Label l r ty) = Label l r (subst theta ty)
> instance SubstType a => SubstType (TopEnv a) where
......
......@@ -124,7 +124,7 @@ environment.}
> where tvs = filter (>= 0) (typeVars ty)
> tvs' = map TypeVariable [n - 1,n - 2 ..]
> n = minimum (0 : concatMap typeVars tys)
> tys = [ty1 | (_,Value _ (ForAll _ ty1)) <- localBindings tyEnv]
> tys = [ty1 | (_,Value _ _ (ForAll _ ty1)) <- localBindings tyEnv]
> identType :: ValueEnv -> Ident -> TyState Type
> identType tyEnv x = instUniv (varType x tyEnv)
......@@ -383,18 +383,18 @@ pattern variables, and variables.
> constrType :: QualIdent -> ValueEnv -> ExistTypeScheme
> constrType c tyEnv = case qualLookupValue c tyEnv of
> [DataConstructor _ sigma] -> sigma
> [DataConstructor _ _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma
> _ -> internalError $ "Base.Typing.constrType: " ++ show c
> varType :: Ident -> ValueEnv -> TypeScheme
> varType v tyEnv = case lookupValue v tyEnv of
> [Value _ sigma] -> sigma
> [Value _ _ sigma] -> sigma
> _ -> internalError $ "Base.Typing.varType: " ++ show v
> funType :: QualIdent -> ValueEnv -> TypeScheme
> funType f tyEnv = case qualLookupValue f tyEnv of
> [Value _ sigma] -> sigma
> [Value _ _ sigma] -> sigma
> _ -> internalError $ "Base.Typing.funType: " ++ show f
> labelType :: Ident -> ValueEnv -> TypeScheme
......
......@@ -54,8 +54,8 @@ syntaxCheck :: Options -> CompilerEnv -> Module -> (CompilerEnv, Module)
syntaxCheck opts env (Module m es is ds)
| null msgs = (env, Module m es is ds')
| otherwise = errorMessages msgs
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env) (aliasEnv env)
(arityEnv env) (valueEnv env) (tyConsEnv env) ds
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env)
(valueEnv env) (tyConsEnv env) ds
-- |Check the precedences of infix operators.
-- In addition, the abstract syntax tree is rearranged to reflect the
......
......@@ -24,7 +24,7 @@ merged into a single definition.
> import Control.Monad (liftM, liftM2, liftM3, unless, when)
> import qualified Control.Monad.State as S (State, runState, gets, modify)
> import Data.List ((\\), find, insertBy, partition)
> import Data.List ((\\), insertBy, partition)
> import Data.Maybe (fromJust, isJust, isNothing, maybeToList)
> import qualified Data.Set as Set (empty, insert, member)
......@@ -38,8 +38,6 @@ merged into a single definition.
> import Base.Types
> import Base.Utils ((++!), findDouble, findMultiples)
> import Env.Arity (ArityEnv, ArityInfo (..), lookupArity, qualLookupArity)
> import Env.ModuleAlias (AliasEnv, lookupAlias)
> import Env.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
> import Env.Value (ValueEnv, ValueInfo (..))
......@@ -57,15 +55,15 @@ declarations are checked within the resulting environment. In
addition, this process will also rename the local variables.
\begin{verbatim}
> syntaxCheck :: Options -> ModuleIdent -> AliasEnv -> ArityEnv -> ValueEnv
> -> TCEnv -> [Decl] -> ([Decl], [Message])
> syntaxCheck opts m iEnv aEnv tyEnv tcEnv decls =
> syntaxCheck :: Options -> ModuleIdent -> ValueEnv -> TCEnv -> [Decl]
> -> ([Decl], [Message])
> syntaxCheck opts m tyEnv tcEnv decls =
> case findMultiples $ concatMap constrs tds of
> [] -> runSC (checkModule decls) initState
> css -> (decls, map errMultipleDataConstructor css)
> where
> tds = filter isTypeDecl decls
> rEnv = globalEnv $ fmap (renameInfo tcEnv iEnv aEnv) tyEnv
> rEnv = globalEnv $ fmap (renameInfo tcEnv) tyEnv
> initState = SCState (optExtensions opts) m rEnv globalKey []
\end{verbatim}
......@@ -148,27 +146,13 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}.
> | LocalVar Int Ident -- arity of local function
> deriving (Eq, Show)
> renameInfo :: TCEnv -> AliasEnv -> ArityEnv -> ValueInfo -> RenameInfo
> renameInfo _ _ _ (DataConstructor _ (ForAllExist _ _ ty))
> = Constr $ arrowArity ty
> renameInfo _ _ _ (NewtypeConstructor _ _)
> = Constr 1
> renameInfo tcEnv _ _ (Label _ r _) = case qualLookupTC r tcEnv of
> renameInfo :: TCEnv -> ValueInfo -> RenameInfo
> renameInfo _ (DataConstructor _ a _) = Constr $ a
> renameInfo _ (NewtypeConstructor _ _) = Constr 1
> renameInfo _ (Value qid a _) = GlobalVar a qid
> renameInfo tcEnv (Label _ r _) = case qualLookupTC r tcEnv of
> [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r $ map fst fs
> _ -> internalError "SyntaxCheck.renameInfo: no unambiguous record"
> renameInfo _ iEnv aEnv (Value qid _) = case lookupArity ident aEnv of
> [ArityInfo _ arty] -> GlobalVar arty qid
> rs -> case qualLookupArity aliasedQid aEnv of
> [ArityInfo _ arty] -> GlobalVar arty qid
> _ -> case find (\ (ArityInfo qid2 _) -> qid2 == qid) rs of
> Just (ArityInfo _ arty) -> GlobalVar arty qid
> Nothing -> internalError $
> "SyntaxCheck.renameInfo: missing arity for " ++ show qid
> where ident = qualidId qid
> -- apply module alias
> aliasedQid = case qualidMod qid >>= flip lookupAlias iEnv of
> Nothing -> qid
> Just mid' -> qualifyWith mid' ident
\end{verbatim}
Since record types are currently translated into data types, it is
......
......@@ -212,7 +212,7 @@ have been properly renamed and all type synonyms are already expanded.
> internalError "TypeCheck.bindConstrs: newtype with illegal constructors"
> bindData (AliasType _ _ _) tyEnv' = tyEnv'
> bindConstr m' n ty (DataConstr c n' tys) =
> bindGlobalInfo DataConstructor m' c
> bindGlobalInfo (flip DataConstructor (length tys)) m' c
> (ForAllExist n n' (foldr TypeArrow ty tys))
> constrType' tc n = TypeConstructor tc $ map TypeVariable [0 .. n - 1]
......@@ -364,19 +364,23 @@ either one of the basic types or \texttt{()}.
> -- basicTypeId = [qBoolId,qCharId,qIntId,qFloatId]
> tcExternal :: ModuleIdent -> TCEnv -> Ident -> TypeExpr -> TCM ()
> tcExternal m tcEnv f ty = modifyValueEnv $ bindFun m f
> $ expandPolyType m tcEnv ty
> tcExternal m tcEnv f ty = modifyValueEnv $ bindFun m f (arrowArity ty') tySc
> where tySc@(ForAll _ ty') = expandPolyType m tcEnv ty
> tcFlatExternal :: ModuleIdent -> TCEnv -> SigEnv -> Ident -> TCM ()
> tcFlatExternal m tcEnv sigs f = case lookupTypeSig f sigs of
> Nothing -> internalError "TypeCheck.tcFlatExternal"
> Just ty -> modifyValueEnv $ bindFun m f $ expandPolyType m tcEnv ty
> Just ty -> do
> let tySc@(ForAll _ ty') = expandPolyType m tcEnv ty
> modifyValueEnv $ bindFun m f (arrowArity ty') tySc
> tcExtraVar :: ModuleIdent -> TCEnv -> SigEnv -> Ident -> TCM ()
> tcExtraVar m tcEnv sigs v = case lookupTypeSig v sigs of
> Nothing -> freshTypeVar >>= modifyValueEnv . bindFun m v . monoType
> Nothing -> do
> ty <- freshTypeVar
> modifyValueEnv $ bindFun m v (arrowArity ty) $ monoType ty
> Just ty
> | n == 0 -> modifyValueEnv $ bindFun m v $ monoType ty'
> | n == 0 -> modifyValueEnv $ bindFun m v (arrowArity ty') $ monoType ty'
> | otherwise -> errorAt' $ errPolymorphicFreeVar v
> where ForAll n ty' = expandPolyType m tcEnv ty
......@@ -446,7 +450,7 @@ signature the declared type must be too general.
> (errTypeSigTooGeneral m what sigTy sigma)
> Nothing -> tyEnv'
> where what = text (if poly then "Function:" else "Variable:") <+> ppIdent v
> tyEnv' = rebindFun m v sigma tyEnv
> tyEnv' = rebindFun m v (varArity v tyEnv) sigma tyEnv
> sigma = genType poly (subst theta (varType v tyEnv))
> genType poly' (ForAll n ty)
> | n > 0 = internalError $ "TypeCheck.genVar: " ++ showLine (positionOfIdent v) ++ show v ++ " :: " ++ show ty
......@@ -467,7 +471,7 @@ signature the declared type must be too general.
> tcLiteral _ (Char _ _) = return charType
> tcLiteral m (Int v _) = do --return intType
> ty <- freshConstrained [intType, floatType]
> modifyValueEnv $ bindFun m v $ monoType ty
> modifyValueEnv $ bindFun m v (arrowArity ty) $ monoType ty
> return ty
> tcLiteral _ (Float _ _) = return floatType
> tcLiteral _ (String _ _) = return stringType
......@@ -480,7 +484,7 @@ signature the declared type must be too general.
> ty <- case lookupTypeSig v sigs of
> Just t -> inst $ expandPolyType m tcEnv t
> Nothing -> freshTypeVar
> modifyValueEnv $ bindFun m v $ monoType ty
> modifyValueEnv $ bindFun m v (arrowArity ty) $ monoType ty
> return ty
> tcConstrTerm m tcEnv sigs p t@(ConstructorPattern c ts) = do
> tyEnv <- getValueEnv
......@@ -570,7 +574,7 @@ because of possibly multiple occurrences of variables.
> (inst . expandPolyType m tcEnv)
> (lookupTypeSig v sigs)
> tyEnv <- getValueEnv
> ty' <- maybe (modifyValueEnv (bindFun m v (monoType ty)) >> return ty)
> ty' <- maybe (modifyValueEnv (bindFun m v (arrowArity ty) (monoType ty)) >> return ty)
> (\ (ForAll _ t) -> return t)
> (sureVarType v tyEnv)
> return ty'
......@@ -696,7 +700,7 @@ because of possibly multiple occurrences of variables.
> tcExpr m tcEnv sigs _ (Variable v)
> | v' == anonId = do
> ty <- freshTypeVar
> modifyValueEnv $ bindFun m v' $ monoType ty
> modifyValueEnv $ bindFun m v' (arrowArity ty) $ monoType ty
> return ty
> | otherwise = case qualLookupTypeSig m v sigs of
> Just ty -> inst $ expandPolyType m tcEnv ty
......@@ -1139,28 +1143,33 @@ unambiguously refers to the local definition.
> constrType :: ModuleIdent -> QualIdent -> ValueEnv -> ExistTypeScheme
> constrType m c tyEnv = case qualLookupValue c tyEnv of
> [DataConstructor _ sigma] -> sigma
> [DataConstructor _ _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma
> _ -> case qualLookupValue (qualQualify m c) tyEnv of
> [DataConstructor _ sigma] -> sigma
> [DataConstructor _ _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma
> _ -> internalError $ "TypeCheck.constrType " ++ show c
> varArity :: Ident -> ValueEnv -> Int
> varArity v tyEnv = case lookupValue v tyEnv of
> Value _ a _ : _ -> a
> _ -> internalError $ "TypeCheck.varArity " ++ show v
> varType :: Ident -> ValueEnv -> TypeScheme
> varType v tyEnv = case lookupValue v tyEnv of
> Value _ sigma : _ -> sigma
> Value _ _ sigma : _ -> sigma
> _ -> internalError $ "TypeCheck.varType " ++ show v
> sureVarType :: Ident -> ValueEnv -> Maybe TypeScheme
> sureVarType v tyEnv = case lookupValue v tyEnv of
> Value _ sigma : _ -> Just sigma
> Value _ _ sigma : _ -> Just sigma
> _ -> Nothing
> funType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
> funType m f tyEnv = case qualLookupValue f tyEnv of
> [Value _ sigma] -> sigma
> [Value _ _ sigma] -> sigma
> _ -> case qualLookupValue (qualQualify m f) tyEnv of
> [Value _ sigma] -> sigma
> [Value _ _ sigma] -> sigma
> _ -> internalError $ "TypeCheck.funType " ++ show f
> sureLabelType :: Ident -> ValueEnv -> Maybe TypeScheme
......@@ -1219,7 +1228,7 @@ know that they are closed.
> fsEnv = Set.unions . map (Set.fromList . typeSkolems) . localTypes
> localTypes :: ValueEnv -> [Type]
> localTypes tyEnv = [ty | (_, Value _ (ForAll _ ty)) <- localBindings tyEnv]
> localTypes tyEnv = [ty | (_, Value _ _ (ForAll _ ty)) <- localBindings tyEnv]
\end{verbatim}
Miscellaneous functions.
......
......@@ -717,8 +717,8 @@ isCons state qid = maybe (isImportedCons state qid)
where
isImportedCons state' qid'
= case (qualLookupValue qid' (valueEnv state')) of
(DataConstructor _ _):_ -> True
(NewtypeConstructor _ _):_ -> True
(DataConstructor _ _ _) : _ -> True
(NewtypeConstructor _ _) : _ -> True
_ -> False
--
......
......@@ -18,7 +18,6 @@ module CompilerEnv where
import Curry.Base.Ident (ModuleIdent)
import Env.Arity
import Env.Eval
import Env.Interface
import Env.Label
......@@ -33,7 +32,6 @@ import Env.Value
data CompilerEnv = CompilerEnv
{ moduleIdent :: ModuleIdent -- ^ identifier of the module
, aliasEnv :: AliasEnv -- ^ aliases for imported modules
, arityEnv :: ArityEnv -- ^ arity of functions and data constructors
, evalAnnotEnv :: EvalEnv -- ^ evaluation annotations
, interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces
, labelEnv :: LabelEnv -- ^ record labels
......@@ -46,7 +44,6 @@ initCompilerEnv :: ModuleIdent -> CompilerEnv
initCompilerEnv mid = CompilerEnv
{ moduleIdent = mid
, aliasEnv = initAliasEnv
, arityEnv = initAEnv
, evalAnnotEnv = initEEnv
, interfaceEnv = initInterfaceEnv
, labelEnv = initLabelEnv
......
{- |
Module : $Header$
Description : Environment of function and constructor arities
Copyright : (c) 2005, Martin Engelke (men@informatik.uni-kiel.de)
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 generate correct FlatCurry applications it is necessary
to define the number of arguments as the arity value (instead of
using the arity computed from the type). For this reason the compiler
needs a table containing the information for all known functions
and constructors.
-}
module Env.Arity
( ArityEnv, ArityInfo (..), bindArity, lookupArity, qualLookupArity
, qualLookupConsArity, lookupTupleArity, bindArities, initAEnv
) where
import Curry.Base.Ident
import Curry.Syntax
import Base.TopEnv
import Base.Types (DataConstr (..), predefTypes)
import Base.Utils ((++!))
data ArityInfo = ArityInfo QualIdent Int deriving Show
instance Entity ArityInfo where
origName (ArityInfo orgName _) = orgName
type ArityEnv = TopEnv ArityInfo
initAEnv :: ArityEnv
initAEnv = foldr bindPredefArity emptyTopEnv $ concatMap snd predefTypes
where bindPredefArity (DataConstr ident _ ts) =
bindArity preludeMIdent ident (length ts)
bindArity :: ModuleIdent -> Ident -> Int -> ArityEnv -> ArityEnv
bindArity mid ident arity aEnv
| uniqueId ident == 0 = bindTopEnv "Base.bindArity" ident arityInfo
$ qualBindTopEnv "Base.bindArity" qid arityInfo aEnv
| otherwise = bindTopEnv "Base.bindArity" ident arityInfo aEnv
where
qid = qualifyWith mid ident
arityInfo = ArityInfo qid arity
lookupArity :: Ident -> ArityEnv -> [ArityInfo]
lookupArity ident aEnv = lookupTopEnv ident aEnv ++! lookupTupleArity ident
qualLookupArity :: QualIdent -> ArityEnv -> [ArityInfo]
qualLookupArity qid aEnv = qualLookupTopEnv qid aEnv
++! qualLookupConsArity qid aEnv
++! lookupTupleArity (unqualify qid)
qualLookupConsArity :: QualIdent -> ArityEnv -> [ArityInfo]
qualLookupConsArity qid aEnv
| maybe False (== preludeMIdent) mmid && ident == consId
= qualLookupTopEnv (qualify ident) aEnv
| otherwise
= []
where (mmid, ident) = (qualidMod qid, qualidId qid)
lookupTupleArity :: Ident -> [ArityInfo]
lookupTupleArity ident
| isTupleId ident
= [ArityInfo (qualifyWith preludeMIdent ident) (tupleArity ident)]
| otherwise
= []
{- |Expand the arity envorinment with (global / local) function arities and
constructor arities.
-}
bindArities :: ArityEnv -> Module -> ArityEnv
bindArities aEnv (Module mid _ _ decls) = foldl (visitDecl mid) aEnv decls
visitDecl :: ModuleIdent -> ArityEnv -> Decl -> ArityEnv
visitDecl mid aEnv (DataDecl _ _ _ cdecls)
= foldl (visitConstrDecl mid) aEnv cdecls
visitDecl mid aEnv (ExternalDecl _ _ _ ident texpr)
= bindArity mid ident (typeArity texpr) aEnv
visitDecl mid aEnv (FunctionDecl _ ident equs)
= let (Equation _ lhs rhs) = head equs
in visitRhs mid (visitLhs mid ident aEnv lhs) rhs
visitDecl _ aEnv _ = aEnv
visitConstrDecl :: ModuleIdent -> ArityEnv -> ConstrDecl -> ArityEnv
visitConstrDecl mid aEnv (ConstrDecl _ _ ident texprs)
= bindArity mid ident (length texprs) aEnv
visitConstrDecl mid aEnv (ConOpDecl _ _ _ ident _)
= bindArity mid ident 2 aEnv
visitLhs :: ModuleIdent -> Ident -> ArityEnv -> Lhs -> ArityEnv
visitLhs mid _ aEnv (FunLhs ident params)
= bindArity mid ident (length params) aEnv
visitLhs mid ident aEnv (OpLhs _ _ _)
= bindArity mid ident 2 aEnv
visitLhs _ _ aEnv _ = aEnv
visitRhs :: ModuleIdent -> ArityEnv -> Rhs -> ArityEnv
visitRhs mid aEnv (SimpleRhs _ expr decls)
= foldl (visitDecl mid) (visitExpr mid aEnv expr) decls
visitRhs mid aEnv (GuardedRhs cexprs decls)
= foldl (visitDecl mid) (foldl (visitCondExpr mid) aEnv cexprs) decls
visitCondExpr :: ModuleIdent -> ArityEnv -> CondExpr -> ArityEnv
visitCondExpr mid aEnv (CondExpr _ cond expr)
= visitExpr mid (visitExpr mid aEnv expr) cond
visitExpr :: ModuleIdent -> ArityEnv -> Expression -> ArityEnv
visitExpr mid aEnv (Paren expr)
= visitExpr mid aEnv expr
visitExpr mid aEnv (Typed expr _)
= visitExpr mid aEnv expr
visitExpr mid aEnv (Tuple _ exprs)
= foldl (visitExpr mid) aEnv exprs
visitExpr mid aEnv (List _ exprs)
= foldl (visitExpr mid) aEnv exprs
visitExpr mid aEnv (ListCompr _ expr stmts)
= foldl (visitStatement mid) (visitExpr mid aEnv expr) stmts
visitExpr mid aEnv (EnumFrom expr)
= visitExpr mid aEnv expr
visitExpr mid aEnv (EnumFromThen expr1 expr2)
= foldl (visitExpr mid) aEnv [expr1, expr2]
visitExpr mid aEnv (EnumFromTo expr1 expr2)
= foldl (visitExpr mid) aEnv [expr1, expr2]
visitExpr mid aEnv (EnumFromThenTo expr1 expr2 expr3)
= foldl (visitExpr mid) aEnv [expr1, expr2, expr3]
visitExpr mid aEnv (UnaryMinus _ expr)
= visitExpr mid aEnv expr
visitExpr mid aEnv (Apply expr1 expr2)
= foldl (visitExpr mid) aEnv [expr1, expr2]
visitExpr mid aEnv (InfixApply expr1 _ expr2)
= foldl (visitExpr mid) aEnv [expr1, expr2]
visitExpr mid aEnv (LeftSection expr _)
= visitExpr mid aEnv expr
visitExpr mid aEnv (RightSection _ expr)
= visitExpr mid aEnv expr
visitExpr mid aEnv (Lambda _ _ expr)
= visitExpr mid aEnv expr
visitExpr mid aEnv (Let decls expr)
= foldl (visitDecl mid) (visitExpr mid aEnv expr) decls
visitExpr mid aEnv (Do stmts expr)
= foldl (visitStatement mid) (visitExpr mid aEnv expr) stmts
visitExpr mid aEnv (IfThenElse _ expr1 expr2 expr3)
= foldl (visitExpr mid) aEnv [expr1, expr2, expr3]
visitExpr mid aEnv (Case _ expr alts)
= visitExpr mid (foldl (visitAlt mid) aEnv alts) expr
visitExpr _ aEnv _ = aEnv
visitStatement :: ModuleIdent -> ArityEnv -> Statement -> ArityEnv
visitStatement mid aEnv (StmtExpr _ expr)
= visitExpr mid aEnv expr
visitStatement mid aEnv (StmtDecl decls)
= foldl (visitDecl mid) aEnv decls
visitStatement mid aEnv (StmtBind _ _ expr)
= visitExpr mid aEnv expr
visitAlt :: ModuleIdent -> ArityEnv -> Alt -> ArityEnv
visitAlt mid aEnv (Alt _ _ rhs) = visitRhs mid aEnv rhs
-- |Compute the function arity of a type expression
typeArity :: TypeExpr -> Int
typeArity (ArrowType _ t2) = 1 + typeArity t2
typeArity _ = 0
......@@ -18,9 +18,11 @@ are considered equal if their original names match.
> import Text.PrettyPrint (Doc, vcat)
> import Curry.Base.Ident
> import Curry.Base.Position
> import Curry.Syntax
> import Base.CurryTypes (fromQualType)
> import Base.Messages (internalError)
> import Base.TopEnv
> import Base.Types
> import Base.Utils ((++!))
......@@ -28,26 +30,29 @@ are considered equal if their original names match.
> import Env.TypeConstructors (TypeInfo (..), tupleTCs)
> data ValueInfo
> = DataConstructor QualIdent ExistTypeScheme
> -- |Data constructor with original name, arity and type
> = DataConstructor QualIdent Int ExistTypeScheme
> -- |Newtype constructor with original name and type (arity is always 1)
> | NewtypeConstructor QualIdent ExistTypeScheme
> | Value QualIdent TypeScheme
> | Label QualIdent QualIdent TypeScheme -- Label <label name> <record name> <type>
> -- |Value with original name, arity and type
> | Value QualIdent Int TypeScheme
> -- |Record label with original name, record name and type
> | Label QualIdent QualIdent TypeScheme
> deriving Show
> instance Entity ValueInfo where
> origName (DataConstructor orgName _) = orgName
> origName (DataConstructor orgName _ _) = orgName
> origName (NewtypeConstructor orgName _) = orgName
> origName (Value orgName _) = orgName
> origName (Value orgName _ _) = orgName
> origName (Label orgName _ _) = orgName
>
> merge (Label l r ty) (Label l' r' _)
> | l == l' && r == r' = Just (Label l r ty)
> | l == l' && r == r' = Just $ Label l r ty
> | otherwise = Nothing
> merge x y
> | origName x == origName y = Just x
> | otherwise = Nothing
\end{verbatim}
Even though value declarations may be nested, the compiler uses only
flat environments for saving type information. This is possible
......@@ -62,26 +67,26 @@ allow the usage of the qualified list constructor \texttt{(Prelude.:)}.
> bindGlobalInfo :: (QualIdent -> a -> ValueInfo) -> ModuleIdent -> Ident -> a
> -> ValueEnv -> ValueEnv
> bindGlobalInfo f m c ty
> = bindTopEnv "Base.bindGlobalInfo" c v
> . qualBindTopEnv "Base.bindGlobalInfo" c' v
> where c' = qualifyWith m c
> v = f c' ty
> bindFun :: ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv
> bindFun m f ty tyEnv
> | uniqueId f == 0
> = bindTopEnv "Base.bindFun" f v (qualBindTopEnv "Base.bindFun" f' v tyEnv)
> | otherwise = bindTopEnv "Base.bindFun" f v tyEnv
> where f' = qualifyWith m f
> v = Value f' ty
> rebindFun :: ModuleIdent -> Ident -> TypeScheme -> ValueEnv -> ValueEnv
> rebindFun m f ty
> | uniqueId f == 0 = rebindTopEnv f v . qualRebindTopEnv f' v
> bindGlobalInfo f m c ty = bindTopEnv fun c v . qualBindTopEnv fun qc v
> where qc = qualifyWith m c
> v = f qc ty
> fun = "Base.bindGlobalInfo"
> bindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv
> bindFun m f a ty
> | uniqueId f == 0 = bindTopEnv fun f v . qualBindTopEnv fun qf v
> | otherwise = bindTopEnv fun f v
> where qf = qualifyWith m f
> v = Value qf a ty
> fun = "Base.bindFun"
> rebindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv
> -> ValueEnv
> rebindFun m f a ty
> | uniqueId f == 0 = rebindTopEnv f v . qualRebindTopEnv qf v
> | otherwise = rebindTopEnv f v
> where f' = qualifyWith m f
> v = Value f' ty
> where qf = qualifyWith m f
> v = Value qf a ty