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 ...@@ -62,7 +62,6 @@ Executable cymake
, CompilerOpts , CompilerOpts
, CurryBuilder , CurryBuilder
, CurryDeps , CurryDeps
, Env.Arity
, Env.Eval , Env.Eval
, Env.Interface , Env.Interface
, Env.Label , Env.Label
......
...@@ -36,19 +36,17 @@ This module implements substitutions on types. ...@@ -36,19 +36,17 @@ This module implements substitutions on types.
> instance SubstType Type where > instance SubstType Type where
> subst sigma (TypeConstructor tc tys) = > subst sigma (TypeConstructor tc tys) =
> TypeConstructor tc (map (subst sigma) tys) > TypeConstructor tc (map (subst sigma) tys)
> subst sigma (TypeVariable tv) = substVar sigma tv > subst sigma (TypeVariable tv) = substVar sigma tv
> subst sigma (TypeConstrained tys tv) = > subst sigma (TypeConstrained tys tv) = case substVar sigma tv of
> case substVar sigma tv of > TypeVariable tv' -> TypeConstrained tys tv'
> TypeVariable tv' -> TypeConstrained tys tv' > ty -> ty
> ty -> ty > subst sigma (TypeArrow ty1 ty2) =
> subst sigma (TypeArrow ty1 ty2) =
> TypeArrow (subst sigma ty1) (subst sigma ty2) > TypeArrow (subst sigma ty1) (subst sigma ty2)
> subst _ (TypeSkolem k) = TypeSkolem k > subst _ ts@(TypeSkolem _) = ts
> subst sigma (TypeRecord fs rv) > subst sigma (TypeRecord fs rv)
> | isJust rv = > | isJust rv = case substVar sigma (fromJust rv) of
> case substVar sigma (fromJust rv) of
> TypeVariable tv -> TypeRecord fs' (Just tv) > TypeVariable tv -> TypeRecord fs' (Just tv)
> ty -> ty > ty -> ty
> | otherwise = TypeRecord fs' Nothing > | otherwise = TypeRecord fs' Nothing
> where fs' = map (\ (l,ty) -> (l, subst sigma ty)) fs > where fs' = map (\ (l,ty) -> (l, subst sigma ty)) fs
...@@ -61,10 +59,10 @@ This module implements substitutions on types. ...@@ -61,10 +59,10 @@ This module implements substitutions on types.
> ForAllExist n n' (subst (foldr unbindSubst sigma [0..n+n'-1]) ty) > ForAllExist n n' (subst (foldr unbindSubst sigma [0..n+n'-1]) ty)
> instance SubstType ValueInfo where > instance SubstType ValueInfo where
> subst _ (DataConstructor c ty) = DataConstructor c ty > subst _ dc@(DataConstructor _ _ _) = dc
> subst _ (NewtypeConstructor c ty) = NewtypeConstructor c ty > subst _ nc@(NewtypeConstructor _ _) = nc
> subst theta (Value v ty) = Value v (subst theta ty) > subst theta (Value v a ty) = Value v a (subst theta ty)
> subst theta (Label l r ty) = Label l r (subst theta ty) > subst theta (Label l r ty) = Label l r (subst theta ty)
> instance SubstType a => SubstType (TopEnv a) where > instance SubstType a => SubstType (TopEnv a) where
> subst = fmap . subst > subst = fmap . subst
......
...@@ -124,7 +124,7 @@ environment.} ...@@ -124,7 +124,7 @@ environment.}
> where tvs = filter (>= 0) (typeVars ty) > where tvs = filter (>= 0) (typeVars ty)
> tvs' = map TypeVariable [n - 1,n - 2 ..] > tvs' = map TypeVariable [n - 1,n - 2 ..]
> n = minimum (0 : concatMap typeVars tys) > 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 :: ValueEnv -> Ident -> TyState Type
> identType tyEnv x = instUniv (varType x tyEnv) > identType tyEnv x = instUniv (varType x tyEnv)
...@@ -383,23 +383,23 @@ pattern variables, and variables. ...@@ -383,23 +383,23 @@ pattern variables, and variables.
> constrType :: QualIdent -> ValueEnv -> ExistTypeScheme > constrType :: QualIdent -> ValueEnv -> ExistTypeScheme
> constrType c tyEnv = case qualLookupValue c tyEnv of > constrType c tyEnv = case qualLookupValue c tyEnv of
> [DataConstructor _ sigma] -> sigma > [DataConstructor _ _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma > [NewtypeConstructor _ sigma] -> sigma
> _ -> internalError $ "Base.Typing.constrType: " ++ show c > _ -> internalError $ "Base.Typing.constrType: " ++ show c
> varType :: Ident -> ValueEnv -> TypeScheme > varType :: Ident -> ValueEnv -> TypeScheme
> varType v tyEnv = case lookupValue v tyEnv of > varType v tyEnv = case lookupValue v tyEnv of
> [Value _ sigma] -> sigma > [Value _ _ sigma] -> sigma
> _ -> internalError $ "Base.Typing.varType: " ++ show v > _ -> internalError $ "Base.Typing.varType: " ++ show v
> funType :: QualIdent -> ValueEnv -> TypeScheme > funType :: QualIdent -> ValueEnv -> TypeScheme
> funType f tyEnv = case qualLookupValue f tyEnv of > funType f tyEnv = case qualLookupValue f tyEnv of
> [Value _ sigma] -> sigma > [Value _ _ sigma] -> sigma
> _ -> internalError $ "Base.Typing.funType: " ++ show f > _ -> internalError $ "Base.Typing.funType: " ++ show f
> labelType :: Ident -> ValueEnv -> TypeScheme > labelType :: Ident -> ValueEnv -> TypeScheme
> labelType l tyEnv = case lookupValue l tyEnv of > labelType l tyEnv = case lookupValue l tyEnv of
> [Label _ _ sigma] -> sigma > [Label _ _ sigma] -> sigma
> _ -> internalError $ "Base.Typing.labelType: " ++ show l > _ -> internalError $ "Base.Typing.labelType: " ++ show l
\end{verbatim} \end{verbatim}
...@@ -54,8 +54,8 @@ syntaxCheck :: Options -> CompilerEnv -> Module -> (CompilerEnv, Module) ...@@ -54,8 +54,8 @@ syntaxCheck :: Options -> CompilerEnv -> Module -> (CompilerEnv, Module)
syntaxCheck opts env (Module m es is ds) syntaxCheck opts env (Module m es is ds)
| null msgs = (env, Module m es is ds') | null msgs = (env, Module m es is ds')
| otherwise = errorMessages msgs | otherwise = errorMessages msgs
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env) (aliasEnv env) where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env)
(arityEnv env) (valueEnv env) (tyConsEnv env) ds (valueEnv env) (tyConsEnv env) ds
-- |Check the precedences of infix operators. -- |Check the precedences of infix operators.
-- In addition, the abstract syntax tree is rearranged to reflect the -- In addition, the abstract syntax tree is rearranged to reflect the
......
...@@ -24,7 +24,7 @@ merged into a single definition. ...@@ -24,7 +24,7 @@ merged into a single definition.
> import Control.Monad (liftM, liftM2, liftM3, unless, when) > import Control.Monad (liftM, liftM2, liftM3, unless, when)
> import qualified Control.Monad.State as S (State, runState, gets, modify) > 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 Data.Maybe (fromJust, isJust, isNothing, maybeToList)
> import qualified Data.Set as Set (empty, insert, member) > import qualified Data.Set as Set (empty, insert, member)
...@@ -38,8 +38,6 @@ merged into a single definition. ...@@ -38,8 +38,6 @@ merged into a single definition.
> import Base.Types > import Base.Types
> import Base.Utils ((++!), findDouble, findMultiples) > 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.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
> import Env.Value (ValueEnv, ValueInfo (..)) > import Env.Value (ValueEnv, ValueInfo (..))
...@@ -57,15 +55,15 @@ declarations are checked within the resulting environment. In ...@@ -57,15 +55,15 @@ declarations are checked within the resulting environment. In
addition, this process will also rename the local variables. addition, this process will also rename the local variables.
\begin{verbatim} \begin{verbatim}
> syntaxCheck :: Options -> ModuleIdent -> AliasEnv -> ArityEnv -> ValueEnv > syntaxCheck :: Options -> ModuleIdent -> ValueEnv -> TCEnv -> [Decl]
> -> TCEnv -> [Decl] -> ([Decl], [Message]) > -> ([Decl], [Message])
> syntaxCheck opts m iEnv aEnv tyEnv tcEnv decls = > syntaxCheck opts m tyEnv tcEnv decls =
> case findMultiples $ concatMap constrs tds of > case findMultiples $ concatMap constrs tds of
> [] -> runSC (checkModule decls) initState > [] -> runSC (checkModule decls) initState
> css -> (decls, map errMultipleDataConstructor css) > css -> (decls, map errMultipleDataConstructor css)
> where > where
> tds = filter isTypeDecl decls > 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 [] > initState = SCState (optExtensions opts) m rEnv globalKey []
\end{verbatim} \end{verbatim}
...@@ -148,27 +146,13 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}. ...@@ -148,27 +146,13 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}.
> | LocalVar Int Ident -- arity of local function > | LocalVar Int Ident -- arity of local function
> deriving (Eq, Show) > deriving (Eq, Show)
> renameInfo :: TCEnv -> AliasEnv -> ArityEnv -> ValueInfo -> RenameInfo > renameInfo :: TCEnv -> ValueInfo -> RenameInfo
> renameInfo _ _ _ (DataConstructor _ (ForAllExist _ _ ty)) > renameInfo _ (DataConstructor _ a _) = Constr $ a
> = Constr $ arrowArity ty > renameInfo _ (NewtypeConstructor _ _) = Constr 1
> renameInfo _ _ _ (NewtypeConstructor _ _) > renameInfo _ (Value qid a _) = GlobalVar a qid
> = Constr 1 > renameInfo tcEnv (Label _ r _) = case qualLookupTC r tcEnv of
> renameInfo tcEnv _ _ (Label _ r _) = case qualLookupTC r tcEnv of
> [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r $ map fst fs > [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r $ map fst fs
> _ -> internalError "SyntaxCheck.renameInfo: no unambiguous record" > _ -> 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} \end{verbatim}
Since record types are currently translated into data types, it is 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. ...@@ -212,7 +212,7 @@ have been properly renamed and all type synonyms are already expanded.
> internalError "TypeCheck.bindConstrs: newtype with illegal constructors" > internalError "TypeCheck.bindConstrs: newtype with illegal constructors"
> bindData (AliasType _ _ _) tyEnv' = tyEnv' > bindData (AliasType _ _ _) tyEnv' = tyEnv'
> bindConstr m' n ty (DataConstr c n' tys) = > 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)) > (ForAllExist n n' (foldr TypeArrow ty tys))
> constrType' tc n = TypeConstructor tc $ map TypeVariable [0 .. n - 1] > constrType' tc n = TypeConstructor tc $ map TypeVariable [0 .. n - 1]
...@@ -364,19 +364,23 @@ either one of the basic types or \texttt{()}. ...@@ -364,19 +364,23 @@ either one of the basic types or \texttt{()}.
> -- basicTypeId = [qBoolId,qCharId,qIntId,qFloatId] > -- basicTypeId = [qBoolId,qCharId,qIntId,qFloatId]
> tcExternal :: ModuleIdent -> TCEnv -> Ident -> TypeExpr -> TCM () > tcExternal :: ModuleIdent -> TCEnv -> Ident -> TypeExpr -> TCM ()
> tcExternal m tcEnv f ty = modifyValueEnv $ bindFun m f > tcExternal m tcEnv f ty = modifyValueEnv $ bindFun m f (arrowArity ty') tySc
> $ expandPolyType m tcEnv ty > where tySc@(ForAll _ ty') = expandPolyType m tcEnv ty
> tcFlatExternal :: ModuleIdent -> TCEnv -> SigEnv -> Ident -> TCM () > tcFlatExternal :: ModuleIdent -> TCEnv -> SigEnv -> Ident -> TCM ()
> tcFlatExternal m tcEnv sigs f = case lookupTypeSig f sigs of > tcFlatExternal m tcEnv sigs f = case lookupTypeSig f sigs of
> Nothing -> internalError "TypeCheck.tcFlatExternal" > 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 :: ModuleIdent -> TCEnv -> SigEnv -> Ident -> TCM ()
> tcExtraVar m tcEnv sigs v = case lookupTypeSig v sigs of > 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 > Just ty
> | n == 0 -> modifyValueEnv $ bindFun m v $ monoType ty' > | n == 0 -> modifyValueEnv $ bindFun m v (arrowArity ty') $ monoType ty'
> | otherwise -> errorAt' $ errPolymorphicFreeVar v > | otherwise -> errorAt' $ errPolymorphicFreeVar v
> where ForAll n ty' = expandPolyType m tcEnv ty > where ForAll n ty' = expandPolyType m tcEnv ty
...@@ -446,7 +450,7 @@ signature the declared type must be too general. ...@@ -446,7 +450,7 @@ signature the declared type must be too general.
> (errTypeSigTooGeneral m what sigTy sigma) > (errTypeSigTooGeneral m what sigTy sigma)
> Nothing -> tyEnv' > Nothing -> tyEnv'
> where what = text (if poly then "Function:" else "Variable:") <+> ppIdent v > 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)) > sigma = genType poly (subst theta (varType v tyEnv))
> genType poly' (ForAll n ty) > genType poly' (ForAll n ty)
> | n > 0 = internalError $ "TypeCheck.genVar: " ++ showLine (positionOfIdent v) ++ show v ++ " :: " ++ show 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. ...@@ -467,7 +471,7 @@ signature the declared type must be too general.
> tcLiteral _ (Char _ _) = return charType > tcLiteral _ (Char _ _) = return charType
> tcLiteral m (Int v _) = do --return intType > tcLiteral m (Int v _) = do --return intType
> ty <- freshConstrained [intType, floatType] > ty <- freshConstrained [intType, floatType]
> modifyValueEnv $ bindFun m v $ monoType ty > modifyValueEnv $ bindFun m v (arrowArity ty) $ monoType ty
> return ty > return ty
> tcLiteral _ (Float _ _) = return floatType > tcLiteral _ (Float _ _) = return floatType
> tcLiteral _ (String _ _) = return stringType > tcLiteral _ (String _ _) = return stringType
...@@ -480,7 +484,7 @@ signature the declared type must be too general. ...@@ -480,7 +484,7 @@ signature the declared type must be too general.
> ty <- case lookupTypeSig v sigs of > ty <- case lookupTypeSig v sigs of
> Just t -> inst $ expandPolyType m tcEnv t > Just t -> inst $ expandPolyType m tcEnv t
> Nothing -> freshTypeVar > Nothing -> freshTypeVar
> modifyValueEnv $ bindFun m v $ monoType ty > modifyValueEnv $ bindFun m v (arrowArity ty) $ monoType ty
> return ty > return ty
> tcConstrTerm m tcEnv sigs p t@(ConstructorPattern c ts) = do > tcConstrTerm m tcEnv sigs p t@(ConstructorPattern c ts) = do
> tyEnv <- getValueEnv > tyEnv <- getValueEnv
...@@ -570,7 +574,7 @@ because of possibly multiple occurrences of variables. ...@@ -570,7 +574,7 @@ because of possibly multiple occurrences of variables.
> (inst . expandPolyType m tcEnv) > (inst . expandPolyType m tcEnv)
> (lookupTypeSig v sigs) > (lookupTypeSig v sigs)
> tyEnv <- getValueEnv > 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) > (\ (ForAll _ t) -> return t)
> (sureVarType v tyEnv) > (sureVarType v tyEnv)
> return ty' > return ty'
...@@ -696,7 +700,7 @@ because of possibly multiple occurrences of variables. ...@@ -696,7 +700,7 @@ because of possibly multiple occurrences of variables.
> tcExpr m tcEnv sigs _ (Variable v) > tcExpr m tcEnv sigs _ (Variable v)
> | v' == anonId = do > | v' == anonId = do
> ty <- freshTypeVar > ty <- freshTypeVar
> modifyValueEnv $ bindFun m v' $ monoType ty > modifyValueEnv $ bindFun m v' (arrowArity ty) $ monoType ty
> return ty > return ty
> | otherwise = case qualLookupTypeSig m v sigs of > | otherwise = case qualLookupTypeSig m v sigs of
> Just ty -> inst $ expandPolyType m tcEnv ty > Just ty -> inst $ expandPolyType m tcEnv ty
...@@ -1139,28 +1143,33 @@ unambiguously refers to the local definition. ...@@ -1139,28 +1143,33 @@ unambiguously refers to the local definition.
> constrType :: ModuleIdent -> QualIdent -> ValueEnv -> ExistTypeScheme > constrType :: ModuleIdent -> QualIdent -> ValueEnv -> ExistTypeScheme
> constrType m c tyEnv = case qualLookupValue c tyEnv of > constrType m c tyEnv = case qualLookupValue c tyEnv of
> [DataConstructor _ sigma] -> sigma > [DataConstructor _ _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma > [NewtypeConstructor _ sigma] -> sigma
> _ -> case qualLookupValue (qualQualify m c) tyEnv of > _ -> case qualLookupValue (qualQualify m c) tyEnv of
> [DataConstructor _ sigma] -> sigma > [DataConstructor _ _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma > [NewtypeConstructor _ sigma] -> sigma
> _ -> internalError $ "TypeCheck.constrType " ++ show c > _ -> 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 :: Ident -> ValueEnv -> TypeScheme
> varType v tyEnv = case lookupValue v tyEnv of > varType v tyEnv = case lookupValue v tyEnv of
> Value _ sigma : _ -> sigma > Value _ _ sigma : _ -> sigma
> _ -> internalError $ "TypeCheck.varType " ++ show v > _ -> internalError $ "TypeCheck.varType " ++ show v
> sureVarType :: Ident -> ValueEnv -> Maybe TypeScheme > sureVarType :: Ident -> ValueEnv -> Maybe TypeScheme
> sureVarType v tyEnv = case lookupValue v tyEnv of > sureVarType v tyEnv = case lookupValue v tyEnv of
> Value _ sigma : _ -> Just sigma > Value _ _ sigma : _ -> Just sigma
> _ -> Nothing > _ -> Nothing
> funType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme > funType :: ModuleIdent -> QualIdent -> ValueEnv -> TypeScheme
> funType m f tyEnv = case qualLookupValue f tyEnv of > funType m f tyEnv = case qualLookupValue f tyEnv of
> [Value _ sigma] -> sigma > [Value _ _ sigma] -> sigma
> _ -> case qualLookupValue (qualQualify m f) tyEnv of > _ -> case qualLookupValue (qualQualify m f) tyEnv of
> [Value _ sigma] -> sigma > [Value _ _ sigma] -> sigma
> _ -> internalError $ "TypeCheck.funType " ++ show f > _ -> internalError $ "TypeCheck.funType " ++ show f
> sureLabelType :: Ident -> ValueEnv -> Maybe TypeScheme > sureLabelType :: Ident -> ValueEnv -> Maybe TypeScheme
...@@ -1219,7 +1228,7 @@ know that they are closed. ...@@ -1219,7 +1228,7 @@ know that they are closed.
> fsEnv = Set.unions . map (Set.fromList . typeSkolems) . localTypes > fsEnv = Set.unions . map (Set.fromList . typeSkolems) . localTypes
> localTypes :: ValueEnv -> [Type] > localTypes :: ValueEnv -> [Type]
> localTypes tyEnv = [ty | (_, Value _ (ForAll _ ty)) <- localBindings tyEnv] > localTypes tyEnv = [ty | (_, Value _ _ (ForAll _ ty)) <- localBindings tyEnv]
\end{verbatim} \end{verbatim}
Miscellaneous functions. Miscellaneous functions.
......
...@@ -717,9 +717,9 @@ isCons state qid = maybe (isImportedCons state qid) ...@@ -717,9 +717,9 @@ isCons state qid = maybe (isImportedCons state qid)
where where
isImportedCons state' qid' isImportedCons state' qid'
= case (qualLookupValue qid' (valueEnv state')) of = case (qualLookupValue qid' (valueEnv state')) of
(DataConstructor _ _):_ -> True (DataConstructor _ _ _) : _ -> True
(NewtypeConstructor _ _):_ -> True (NewtypeConstructor _ _) : _ -> True
_ -> False _ -> False
-- --
isAnnonId :: Ident -> Bool isAnnonId :: Ident -> Bool
......
...@@ -18,7 +18,6 @@ module CompilerEnv where ...@@ -18,7 +18,6 @@ module CompilerEnv where
import Curry.Base.Ident (ModuleIdent) import Curry.Base.Ident (ModuleIdent)
import Env.Arity
import Env.Eval import Env.Eval
import Env.Interface import Env.Interface
import Env.Label import Env.Label
...@@ -33,7 +32,6 @@ import Env.Value ...@@ -33,7 +32,6 @@ import Env.Value
data CompilerEnv = CompilerEnv data CompilerEnv = CompilerEnv
{ moduleIdent :: ModuleIdent -- ^ identifier of the module { moduleIdent :: ModuleIdent -- ^ identifier of the module
, aliasEnv :: AliasEnv -- ^ aliases for imported modules , aliasEnv :: AliasEnv -- ^ aliases for imported modules
, arityEnv :: ArityEnv -- ^ arity of functions and data constructors
, evalAnnotEnv :: EvalEnv -- ^ evaluation annotations , evalAnnotEnv :: EvalEnv -- ^ evaluation annotations
, interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces , interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces
, labelEnv :: LabelEnv -- ^ record labels , labelEnv :: LabelEnv -- ^ record labels
...@@ -46,7 +44,6 @@ initCompilerEnv :: ModuleIdent -> CompilerEnv ...@@ -46,7 +44,6 @@ initCompilerEnv :: ModuleIdent -> CompilerEnv
initCompilerEnv mid = CompilerEnv initCompilerEnv mid = CompilerEnv
{ moduleIdent = mid { moduleIdent = mid
, aliasEnv = initAliasEnv , aliasEnv = initAliasEnv
, arityEnv = initAEnv
, evalAnnotEnv = initEEnv , evalAnnotEnv = initEEnv
, interfaceEnv = initInterfaceEnv , interfaceEnv = initInterfaceEnv
, labelEnv = initLabelEnv , 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