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

Internal errors improved, KindCheck improved

parent 84eccf2a
......@@ -44,7 +44,7 @@ order of type variables in the left hand side of a type declaration.
> toType' tvs (CS.ConstructorType tc tys) =
> TypeConstructor tc (map (toType' tvs) tys)
> toType' tvs (CS.VariableType tv) =
> maybe (internalError $ "toType " ++ show tv) TypeVariable (Map.lookup tv tvs)
> maybe (internalError $ "Base.CurryTypes.toType': " ++ show tv) TypeVariable (Map.lookup tv tvs)
> toType' tvs (CS.TupleType tys)
> | null tys = TypeConstructor (qualify unitId) []
> | otherwise = TypeConstructor (qualify (tupleId (length tys'))) tys'
......@@ -57,7 +57,7 @@ order of type variables in the left hand side of a type declaration.
> (maybe Nothing
> (\ ty -> case toType' tvs ty of
> TypeVariable tv -> Just tv
> _ -> internalError ("toType " ++ show ty))
> _ -> internalError ("Base.CurryTypes.toType' " ++ show ty))
> rty)
> fromQualType :: ModuleIdent -> Type -> CS.TypeExpr
......
......@@ -330,7 +330,7 @@ checker.
> S.modify (bindVar tv (TypeArrow ty1 ty2))
> return (ty1,ty2)
> TypeArrow ty1 ty2 -> return (ty1,ty2)
> ty' -> internalError ("unifyArrow (" ++ show ty' ++ ")")
> ty' -> internalError ("Base.Typing.unifyArrow (" ++ show ty' ++ ")")
> unifyArrow2 :: Type -> TyState (Type,Type,Type)
> unifyArrow2 ty =
......@@ -367,7 +367,7 @@ checker.
> (TypeVariable a2)
> (foldr (unifyTypedLabels fs1) theta fs2)
> unifyTypes ty1 ty2 _ =
> internalError ("unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")")
> internalError ("Base.Typing.unify: (" ++ show ty1 ++ ") (" ++ show ty2 ++ ")")
> unifyTypedLabels :: [(Ident,Type)] -> (Ident,Type) -> TypeSubst -> TypeSubst
> unifyTypedLabels fs1 (l,ty) theta =
......@@ -382,28 +382,24 @@ pattern variables, and variables.
\begin{verbatim}
> constrType :: QualIdent -> ValueEnv -> ExistTypeScheme
> constrType c tyEnv =
> case qualLookupValue c tyEnv of
> constrType c tyEnv = case qualLookupValue c tyEnv of
> [DataConstructor _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma
> _ -> internalError ("constrType " ++ show c)
> _ -> internalError $ "Base.Typing.constrType: " ++ show c
> varType :: Ident -> ValueEnv -> TypeScheme
> varType v tyEnv =
> case lookupValue v tyEnv of
> varType v tyEnv = case lookupValue v tyEnv of
> [Value _ sigma] -> sigma
> _ -> internalError ("varType " ++ show v)
> _ -> internalError $ "Base.Typing.varType: " ++ show v
> funType :: QualIdent -> ValueEnv -> TypeScheme
> funType f tyEnv =
> case qualLookupValue f tyEnv of
> funType f tyEnv = case qualLookupValue f tyEnv of
> [Value _ sigma] -> sigma
> _ -> internalError ("funType " ++ show f)
> _ -> internalError $ "Base.Typing.funType: " ++ show f
> labelType :: Ident -> ValueEnv -> TypeScheme
> labelType l tyEnv =
> case lookupValue l tyEnv of
> labelType l tyEnv = case lookupValue l tyEnv of
> [Label _ _ sigma] -> sigma
> _ -> internalError ("labelType " ++ show l)
> _ -> internalError $ "Base.Typing.labelType: " ++ show l
\end{verbatim}
......@@ -29,31 +29,32 @@ import CompilerOpts
-- |Check the kinds of type definitions and signatures.
-- In addition, nullary type constructors and type variables are dinstiguished
kindCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
kindCheck decls env = (decls', env)
where decls' = KC.kindCheck (moduleIdent env) (tyConsEnv env) decls
kindCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
kindCheck (Module m es is ds) env = (Module m es is ds', env)
where ds' = KC.kindCheck (moduleIdent env) (tyConsEnv env) ds
-- |Apply the precendences of infix operators.
-- This function reanrranges the AST.
precCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
precCheck decls env = (decls', env { opPrecEnv = pEnv' })
where (pEnv', decls') = PC.precCheck (moduleIdent env) (opPrecEnv env) decls
precCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
precCheck (Module m es is ds) env = (Module m es is ds', env { opPrecEnv = pEnv' })
where (pEnv', ds') = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
-- |Apply the syntax check.
syntaxCheck :: Options -> [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
syntaxCheck opts decls env = (decls', env)
where decls' = SC.syntaxCheck withExt (moduleIdent env) (aliasEnv env)
(arityEnv env) (valueEnv env) (tyConsEnv env) decls
syntaxCheck :: Options -> Module -> CompilerEnv -> (Module, CompilerEnv)
syntaxCheck opts (Module m es is ds) env = (Module m es is ds', env)
where ds' = SC.syntaxCheck withExt (moduleIdent env) (aliasEnv env)
(arityEnv env) (valueEnv env) (tyConsEnv env) ds
withExt = BerndExtension `elem` optExtensions opts
-- |Apply the type check.
typeCheck :: [Decl] -> CompilerEnv -> ([Decl], CompilerEnv)
typeCheck decls env = (decls, env { tyConsEnv = tcEnv', valueEnv = tyEnv' })
typeCheck :: Module -> CompilerEnv -> (Module, CompilerEnv)
typeCheck mdl@(Module _ _ _ ds) env = (mdl, env { tyConsEnv = tcEnv', valueEnv = tyEnv' })
where (tcEnv', tyEnv') = TC.typeCheck (moduleIdent env)
(tyConsEnv env) (valueEnv env) decls
(tyConsEnv env) (valueEnv env) ds
-- TODO: Which kind of warnings?
-- |Check for warnings.
warnCheck :: CompilerEnv -> [ImportDecl] -> [Decl] -> [Message]
warnCheck env = WC.warnCheck (moduleIdent env) (valueEnv env)
warnCheck :: Module -> CompilerEnv -> [Message]
warnCheck (Module _ _ is ds) env
= WC.warnCheck (moduleIdent env) (valueEnv env) is ds
This diff is collapsed.
......@@ -38,10 +38,8 @@ imported precedence environment.
\begin{verbatim}
> bindPrecs :: ModuleIdent -> [Decl] -> PEnv -> PEnv
> bindPrecs m ds pEnv =
> case findDouble ops of
> Nothing ->
> case [ op | op <- ops, op `notElem` bvs] of
> bindPrecs m ds pEnv = case findDouble ops of
> Nothing -> case [ op | op <- ops, op `notElem` bvs] of
> [] -> foldr bindPrec pEnv fixDs
> op : _ -> errorAt' (undefinedOperator op)
> Just op -> errorAt' (duplicatePrecedence op)
......@@ -77,11 +75,11 @@ be returned because it is needed for constructing the module's
interface.
\begin{verbatim}
> precCheck :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])
> precCheck :: ModuleIdent -> PEnv -> [Decl] -> (PEnv, [Decl])
> precCheck = checkDecls
> checkDecls :: ModuleIdent -> PEnv -> [Decl] -> (PEnv,[Decl])
> checkDecls m pEnv ds = pEnv' `seq` (pEnv',ds')
> checkDecls :: ModuleIdent -> PEnv -> [Decl] -> (PEnv, [Decl])
> checkDecls m pEnv ds = pEnv' `seq` (pEnv', ds')
> where pEnv' = bindPrecs m ds pEnv
> ds' = map (checkDecl m pEnv') ds
......@@ -430,8 +428,7 @@ an operator definition that shadows an imported definition.
> opPrec op = prec (opName op)
> prec :: QualIdent -> PEnv -> OpPrec
> prec op env =
> case qualLookupP op env of
> prec op env = case qualLookupP op env of
> [] -> defaultP
> PrecInfo _ p : _ -> p
......
......@@ -127,12 +127,12 @@ allow the usage of the qualified list constructor \texttt{(prelude.:)}.
> [ArityInfo _ arity'] -> GlobalVar arity' qid
> rs -> case qualLookupArity qid' aEnv of
> [ArityInfo _ arity''] -> GlobalVar arity'' qid
> _ -> maybe (internalError $ "renameInfo: missing arity for " ++ show qid)
> _ -> maybe (internalError $ "SyntaxCheck.renameInfo: missing arity for " ++ show qid)
> (\ (ArityInfo _ arity'') -> GlobalVar arity'' qid)
> (find (\ (ArityInfo qid'' _) -> qid'' == qid) rs)
> renameInfo tcEnv _ _ (Label _ r _) = case (qualLookupTC r tcEnv) of
> [AliasType _ _ (TypeRecord fs _)] -> RecordLabel r (map fst fs)
> _ -> internalError "renameInfo: no record"
> _ -> internalError "SyntaxCheck.renameInfo: no record"
\end{verbatim}
Since record types are currently translated into data types, it is
......@@ -178,7 +178,7 @@ than once.
> bindFuncDecl :: ModuleIdent -> Decl -> RenameEnv -> RenameEnv
> bindFuncDecl m (FunctionDecl _ ident equs) env
> | null equs = internalError "bindFuncDecl: missing equations"
> | null equs = internalError "SyntaxCheck.bindFuncDecl: missing equations"
> | otherwise = let (_,ts) = getFlatLhs (head equs)
> in bindGlobal m
> ident
......@@ -199,7 +199,7 @@ than once.
> bindVarDecl :: Decl -> RenameEnv -> RenameEnv
> bindVarDecl (FunctionDecl _ ident equs) env
> | null equs
> = internalError "bindFuncDecl: missing equations"
> = internalError "SyntaxCheck.bindFuncDecl: missing equations"
> | otherwise
> = let (_,ts) = getFlatLhs (head equs)
> in bindLocal (unRenameIdent ident) (LocalVar (length ts) ident) env
......@@ -260,7 +260,7 @@ local declarations.
> checkTypeDecl :: Bool -> ModuleIdent -> Decl -> Decl
> checkTypeDecl withExt _ (TypeDecl p r tvs (RecordType fs rty))
> | not withExt = errorAt (positionOfIdent r) noRecordExt
> | isJust rty = internalError "checkTypeDecl - illegal record type"
> | isJust rty = internalError "SyntaxCheck.checkTypeDecl - illegal record type"
> | null fs = errorAt (positionOfIdent r) emptyRecord
> | otherwise = TypeDecl p r tvs (RecordType fs Nothing)
> checkTypeDecl _ _ d = d
......@@ -327,7 +327,7 @@ top-level.
> patDecl t
> | k == globalKey = errorAt p noToplevelPattern
> | otherwise = PatternDecl p' t rhs
> checkEquationLhs _ _ _ _ _ _ = internalError "checkEquationLhs"
> checkEquationLhs _ _ _ _ _ _ = internalError "SyntaxCheck.checkEquationLhs"
> checkEqLhs :: ModuleIdent -> Integer -> RenameEnv -> Position -> Lhs
> -> Either (Ident,Lhs) ConstrTerm
......@@ -648,13 +648,14 @@ top-level.
> checkExpr :: Bool -> Position -> ModuleIdent -> RenameEnv -> Expression
> -> RenameState Expression
> checkExpr _ _ _ _ (Literal l) = liftM Literal (renameLiteral l)
> checkExpr _ _ m env (Variable v) =
> case (qualLookupVar v env) of
> checkExpr _ _ m env var@(Variable v)
> | unqualify v == anonId = return var
> | otherwise = case qualLookupVar v env of
> [] -> errorAt' (undefinedVariable v)
> [Constr _] -> return (Constructor v)
> [GlobalVar _ _] -> return (Variable v)
> [LocalVar _ v'] -> return (Variable (qualify v'))
> rs -> case (qualLookupVar (qualQualify m v) env) of
> rs -> case qualLookupVar (qualQualify m v) env of
> [] -> errorAt' (ambiguousIdent rs v)
> [Constr _] -> return (Constructor v)
> [GlobalVar _ _] -> return (Variable v)
......@@ -922,12 +923,12 @@ the user about the fact that the identifier is ambiguous.
> varIdent :: RenameInfo -> Ident
> varIdent (GlobalVar _ v) = unqualify v
> varIdent (LocalVar _ v) = v
> varIdent _ = internalError "not a variable"
> varIdent _ = internalError "SyntaxCheck.varIdent: not a variable"
> qualVarIdent :: RenameInfo -> QualIdent
> qualVarIdent (GlobalVar _ v) = v
> qualVarIdent (LocalVar _ v) = qualify v
> qualVarIdent _ = internalError "not a qualified variable"
> qualVarIdent _ = internalError "SyntaxCheck.qualVarIdent: not a qualified variable"
> arity :: RenameInfo -> Int
> arity (Constr n) = n
......
......@@ -63,7 +63,7 @@ The type checker returns the resulting type
constructor and type environments.
\begin{verbatim}
> typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv,ValueEnv)
> typeCheck :: ModuleIdent -> TCEnv -> ValueEnv -> [Decl] -> (TCEnv, ValueEnv)
> typeCheck m tcEnv tyEnv ds =
> run (tcDecls m tcEnv' Map.empty vds >>
> S.lift S.get >>= \theta -> S.get >>= \tyEnv' ->
......@@ -143,7 +143,7 @@ and \texttt{expandMonoTypes}, respectively.
> free _ = error "TypeCheck.sortTypeDecls.free: no pattern match"
> typeDecl :: ModuleIdent -> [Decl] -> Decl
> typeDecl _ [] = internalError "typeDecl"
> typeDecl _ [] = internalError "TypeCheck.typeDecl"
> typeDecl _ [d@(DataDecl _ _ _ _)] = d
> typeDecl _ [d@(NewtypeDecl _ _ _ _)] = d
> typeDecl m [d@(TypeDecl _ tc _ ty)]
......@@ -340,7 +340,7 @@ either one of the basic types or \texttt{()}.
> where typeOf f' tcEnv' sigs' =
> case lookupTypeSig f' sigs' of
> Just ty -> return (expandPolyType m tcEnv' ty)
> Nothing -> internalError "tcFlatExternalFunct"
> Nothing -> internalError "TypeCheck.tcFlatExternalFunct"
> tcExtraVar :: ModuleIdent -> TCEnv -> SigEnv -> Ident
> -> TcState ()
......@@ -425,8 +425,7 @@ signature the declared type must be too general.
> tyEnv' = rebindFun m v sigma tyEnv
> sigma = genType poly (subst theta (varType v tyEnv))
> genType poly' (ForAll n ty)
> | n > 0 = internalError ("genVar: " ++ showLine (positionOfIdent v) ++
> show v ++ " :: " ++ show ty)
> | n > 0 = internalError $ "TypeCheck.genVar: " ++ showLine (positionOfIdent v) ++ show v ++ " :: " ++ show ty
> | poly' = gen lvs ty
> | otherwise = monoType ty
> cmpTypes (ForAll _ t1) (ForAll _ t2) = equTypes t1 t2
......@@ -474,7 +473,7 @@ signature the declared type must be too general.
> unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
> m ty1 >>
> unifyArgs doc ts1 ty2
> unifyArgs _ _ _ = internalError "tcConstrTerm"
> unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTerm"
> tcConstrTerm m tcEnv sigs p t@(InfixPattern t1 op t2) =
> do
> tyEnv <- S.get
......@@ -486,7 +485,7 @@ signature the declared type must be too general.
> unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t')
> m ty1 >>
> unifyArgs doc ts' ty2
> unifyArgs _ _ _ = internalError "tcConstrTerm"
> unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTerm"
> tcConstrTerm m tcEnv sigs p (ParenPattern t) = tcConstrTerm m tcEnv sigs p t
> tcConstrTerm m tcEnv sigs p (TuplePattern _ ts)
> | null ts = return unitType
......@@ -525,7 +524,7 @@ signature the declared type must be too general.
> (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
> m ty1 >>
> unifyArgs doc ts1 ty2
> unifyArgs _ _ ty = internalError ("tcConstrTerm: " ++ show ty)
> unifyArgs _ _ ty = internalError $ "TypeCheck.tcConstrTerm: " ++ show ty
> tcConstrTerm m tcEnv sigs p (InfixFuncPattern t1 op t2) =
> tcConstrTerm m tcEnv sigs p (FunctionPattern op [t1,t2])
> tcConstrTerm m tcEnv sigs p r@(RecordPattern fs rt)
......@@ -573,7 +572,7 @@ because of possibly multiple occurrences of variables.
> unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
> m ty1 >>
> unifyArgs doc ts1 ty2
> unifyArgs _ _ _ = internalError "tcConstrTermFP"
> unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTermFP"
> tcConstrTermFP m tcEnv sigs p t@(InfixPattern t1 op t2) =
> do
> tyEnv <- S.get
......@@ -585,7 +584,7 @@ because of possibly multiple occurrences of variables.
> unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t')
> m ty1 >>
> unifyArgs doc ts' ty2
> unifyArgs _ _ _ = internalError "tcConstrTermFP"
> unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTermFP"
> tcConstrTermFP m tcEnv sigs p (ParenPattern t) = tcConstrTermFP m tcEnv sigs p t
> tcConstrTermFP m tcEnv sigs p (TuplePattern _ ts)
> | null ts = return unitType
......@@ -623,7 +622,7 @@ because of possibly multiple occurrences of variables.
> unify p "pattern" (doc $-$ text "Term:" <+> ppConstrTerm 0 t1)
> m ty1 >>
> unifyArgs doc ts1 ty2
> unifyArgs _ _ _ = internalError "tcConstrTermFP"
> unifyArgs _ _ _ = internalError "TypeCheck.tcConstrTermFP"
> tcConstrTermFP m tcEnv sigs p (InfixFuncPattern t1 op t2) =
> tcConstrTermFP m tcEnv sigs p (FunctionPattern op [t1,t2])
> tcConstrTermFP m tcEnv sigs p r@(RecordPattern fs rt)
......@@ -772,7 +771,7 @@ because of possibly multiple occurrences of variables.
> where opType op'
> | op' == minusId = freshConstrained [intType,floatType]
> | op' == fminusId = return floatType
> | otherwise = internalError ("tcExpr unary " ++ name op')
> | otherwise = internalError $ "TypeCheck.tcExpr unary " ++ name op'
> tcExpr m tcEnv sigs p e@(Apply e1 e2) =
> do
> ty1 <- tcExpr m tcEnv sigs p e1
......@@ -1079,7 +1078,7 @@ of~\cite{PeytonJones87:Book}).
> (unifyTypes m ty ty'))
> (lookup l fs2))
> (unifyTypedLabels m fs1 tr)
> unifyTypedLabels _ _ _ = internalError "unifyTypedLabels"
> unifyTypedLabels _ _ _ = internalError "TypeCheck.unifyTypedLabels"
\end{verbatim}
For each declaration group, the type checker has to ensure that no
......@@ -1159,38 +1158,33 @@ unambiguously refers to the local definition.
\begin{verbatim}
> 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
> [NewtypeConstructor _ sigma] -> sigma
> _ -> case (qualLookupValue (qualQualify m c) tyEnv) of
> _ -> case qualLookupValue (qualQualify m c) tyEnv of
> [DataConstructor _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma
> _ -> internalError ("constrType " ++ show c)
> _ -> internalError $ "TypeCheck.constrType " ++ show c
> varType :: Ident -> ValueEnv -> TypeScheme
> varType v tyEnv =
> case lookupValue v tyEnv of
> varType v tyEnv = case lookupValue v tyEnv of
> Value _ sigma : _ -> sigma
> _ -> internalError ("varType " ++ show v)
> _ -> internalError $ "TypeCheck.varType " ++ show v
> 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
> _ -> Nothing
> 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
> _ -> case (qualLookupValue (qualQualify m f) tyEnv) of
> _ -> case qualLookupValue (qualQualify m f) tyEnv of
> [Value _ sigma] -> sigma
> _ -> internalError ("funType " ++ show f)
> _ -> internalError $ "TypeCheck.funType " ++ show f
> sureLabelType :: Ident -> ValueEnv -> Maybe TypeScheme
> sureLabelType l tyEnv =
> case lookupValue l tyEnv of
> sureLabelType l tyEnv = case lookupValue l tyEnv of
> Label _ _ sigma : _ -> Just sigma
> _ -> Nothing
......@@ -1221,7 +1215,7 @@ in which the type was defined.
> [DataType tc' _ _] -> TypeConstructor tc' tys'
> [RenamingType tc' _ _] -> TypeConstructor tc' tys'
> [AliasType _ _ ty] -> expandAliasType tys' ty
> _ -> internalError ("expandType " ++ show tc)
> _ -> internalError $ "TypeCheck.expandType " ++ show tc
> where tys' = map (expandType m tcEnv) tys
> expandType _ _ (TypeVariable tv) = TypeVariable tv
> expandType _ _ (TypeConstrained tys tv) = TypeConstrained tys tv
......
This diff is collapsed.
......@@ -24,8 +24,8 @@ The function \texttt{evalEnv} collects all evaluation annotations of
the module by traversing the syntax tree.
\begin{verbatim}
> evalEnv :: [Decl] -> EvalEnv
> evalEnv = foldr collectAnnotsDecl Map.empty
> evalEnv :: Module -> EvalEnv
> evalEnv (Module _ _ _ ds) = foldr collectAnnotsDecl Map.empty ds
> initEEnv :: EvalEnv
> initEEnv = Map.empty
......
......@@ -41,17 +41,17 @@ imported.
> = GlobalEnv (bindTopEnv "NestEnv.bindNestEnv" x y env)
> bindNestEnv x y (LocalEnv genv env) =
> case Map.lookup x env of
> Just _ -> internalError "bindNestEnv"
> Just _ -> internalError "NestEnv.bindNestEnv"
> Nothing -> LocalEnv genv (Map.insert x y env)
> qualBindNestEnv :: QualIdent -> a -> NestEnv a -> NestEnv a
> qualBindNestEnv x y (GlobalEnv env)
> = GlobalEnv (qualBindTopEnv "NestEnv.qualBindNestEnv" x y env)
> qualBindNestEnv x y (LocalEnv genv env)
> | isQualified x = internalError "qualBindNestEnv"
> | isQualified x = internalError "NestEnv.qualBindNestEnv"
> | otherwise =
> case Map.lookup x' env of
> Just _ -> internalError "qualBindNestEnv"
> Just _ -> internalError "NestEnv.qualBindNestEnv"
> Nothing -> LocalEnv genv (Map.insert x' y env)
> where x' = unqualify x
......
......@@ -71,7 +71,7 @@ imported.
> predefTopEnv :: Entity a => QualIdent -> a -> TopEnv a -> TopEnv a
> predefTopEnv x y (TopEnv env) =
> case Map.lookup x env of
> Just _ -> internalError "predefTopEnv"
> Just _ -> internalError "TopEnv.predefTopEnv"
> Nothing -> TopEnv (Map.insert x [(Import [],y)] env)
> importTopEnv :: Entity a => ModuleIdent -> Ident -> a -> TopEnv a -> TopEnv a
......@@ -101,8 +101,8 @@ imported.
> TopEnv (Map.insert x (bindLocal y (entities x env)) env)
> where bindLocal y' ys
> | null [y'' | (Local,y'') <- ys] = (Local,y') : ys
> | otherwise = internalError ("\"qualBindTopEnv " ++ show x
> ++ "\" failed in function \"" ++ fun ++ "\"")
> | otherwise = internalError $ "\"qualBindTopEnv " ++ show x
> ++ "\" failed in function \"" ++ fun ++ "\""
> rebindTopEnv :: Ident -> a -> TopEnv a -> TopEnv a
> rebindTopEnv = qualRebindTopEnv . qualify
......@@ -110,7 +110,7 @@ imported.
> qualRebindTopEnv :: QualIdent -> a -> TopEnv a -> TopEnv a
> qualRebindTopEnv x y (TopEnv env) =
> TopEnv (Map.insert x (rebindLocal (entities x env)) env)
> where rebindLocal [] = internalError "qualRebindTopEnv"
> where rebindLocal [] = internalError "TopEnv.qualRebindTopEnv"
> rebindLocal ((Local,_) : ys) = (Local,y) : ys
> rebindLocal ((Import ms,y') : ys) = (Import ms,y') : rebindLocal ys
......@@ -118,7 +118,7 @@ imported.
> unbindTopEnv x (TopEnv env) =
> TopEnv (Map.insert x' (unbindLocal (entities x' env)) env)
> where x' = qualify x
> unbindLocal [] = internalError "unbindTopEnv"
> unbindLocal [] = internalError "TopEnv.unbindTopEnv"
> unbindLocal ((Local,_) : ys) = ys
> unbindLocal ((Import ms,y) : ys) = (Import ms,y) : unbindLocal ys
......
......@@ -13,10 +13,14 @@ are considered equal if their original names match.
> module Env.Value
> ( ValueEnv, ValueInfo (..), bindGlobalInfo, bindFun, rebindFun, bindLabel
> , lookupValue, qualLookupValue, qualLookupCons, lookupTuple, tupleDCs
> , initDCEnv ) where
> , initDCEnv, ppTypes ) where
> import Text.PrettyPrint (Doc, vcat)
> import Curry.Base.Ident
> import Curry.Syntax
> import Base.CurryTypes (fromQualType)
> import Base.Types
> import Base.Utils ((++!))
......@@ -124,3 +128,22 @@ TODO: Match other patterns?
> constrType (ForAll n ty) n' = ForAllExist n n' . foldr TypeArrow ty
\end{verbatim}
The function \texttt{ppTypes} is used for pretty-printing the types
from the type environment.
\begin{verbatim}
> ppTypes :: ModuleIdent -> ValueEnv -> Doc
> ppTypes mid valueEnv = ppTypes' mid (localBindings valueEnv)
> where
> ppTypes' :: ModuleIdent -> [(Ident, ValueInfo)] -> Doc
> ppTypes' m = vcat . map (ppIDecl . mkDecl) . filter (isValue . snd)
> where mkDecl (v, Value _ (ForAll _ ty)) =
> IFunctionDecl undefined (qualify v) (arrowArity ty)
> (fromQualType m ty)
> mkDecl _ = error "Modules.ppTypes.mkDecl: no pattern match"
> isValue (DataConstructor _ _) = False
> isValue (NewtypeConstructor _ _) = False
> isValue (Value _ _) = True
> isValue (Label _ _ _) = False
\end{verbatim}
......@@ -181,7 +181,7 @@ identifiers.
> in case lookupValue (head ls) tyEnv of
> [Label _ r' _] -> if r == r' then ExportTypeWith r ls
> else ExportTypeWith r []
> _ -> internalError "exportType"
> _ -> internalError "Exports.exportType"
> | otherwise = ExportTypeWith (origName t) (constrs t)
> exportRecord :: TypeInfo -> [Export]
......@@ -247,7 +247,7 @@ exported function.
> iInfixDecl m pEnv op ds = case qualLookupP op pEnv of
> [] -> ds
> [PrecInfo _ (OpPrec fix pr)] -> IInfixDecl NoPos fix pr (qualUnqualify m op) : ds
> _ -> internalError "infixDecl"
> _ -> internalError "Exports.infixDecl"
> typeDecl :: ModuleIdent -> TCEnv -> Export -> [IDecl] -> [IDecl]
> typeDecl _ _ (Export _) ds = ds
......@@ -266,7 +266,7 @@ exported function.
> let ty' = TypeRecord (filter (\ (l,_) -> elem l cs) fs) Nothing
> in iTypeDecl ITypeDecl m tc' n (fromQualType m ty') : ds
> _ -> iTypeDecl ITypeDecl m tc' n (fromQualType m ty) : ds
> _ -> internalError "typeDecl"
> _ -> internalError "Exports.typeDecl"
> typeDecl _ _ _ _ = error "Exports.typeDecl: no pattern match"
> iTypeDecl :: (Position -> QualIdent -> [Ident] -> a -> IDecl)
......@@ -292,7 +292,7 @@ exported function.
> [Value _ (ForAll _ ty)] ->
> IFunctionDecl NoPos (qualUnqualify m f) (arrowArity ty)
> (fromQualType m ty) : ds
> _ -> internalError $ "funDecl: " ++ show f
> _ -> internalError $ "Exports.funDecl: " ++ show f
> funDecl _ _ (ExportTypeWith _ _) ds = ds
> funDecl _ _ _ _ = error "Exports.funDecl: no pattern match"
......@@ -358,7 +358,7 @@ distinguished from type variables.
> case qualLookupTC (qualQualify m tc) tcEnv of
> [DataType _ n _] -> hidingDataDecl tc n
> [RenamingType _ n _] -> hidingDataDecl tc n
> _ -> internalError "hiddenTypeDecl"
> _ -> internalError "Exports.hiddenTypeDecl"
> where hidingDataDecl tc1 n =
> HidingDataDecl NoPos (unqualify tc1) (take n identSupply)
......
......@@ -26,14 +26,13 @@ import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax (Module (..), Interface, parseModule)
import Env.Interface
import CompilerEnv
import CompilerOpts (Options (..), Verbosity (..), TargetType (..), defaultOptions)
import CurryBuilder (smake)
import CurryDeps (Source (..), flattenDeps, moduleDeps)
import Imports (importModules)
import Interfaces (loadInterfaces)
import Modules (checkModuleHeader, checkModule, simpleCheckModule, compileModule)
import Modules
{- |Return the result of a syntactical analysis of the source program 'src'.
The result is the syntax tree of the program (type 'Module'; see Module
......@@ -69,16 +68,18 @@ genCurrySyntax fn mod1
--
genFullCurrySyntax ::
(Options -> InterfaceEnv -> Module -> (CompilerEnv, Module, Interface, [Message]))
(Options -> CompilerEnv -> Module -> (CompilerEnv, Module, Interface, [Message]))