Skip to content

GitLab

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

Internal errors improved, KindCheck improved

parent 84eccf2a
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 849 additions and 735 deletions
src/Base/CurryTypes.lhs
View file @ 6081fb44
......@@ -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
......
src/Base/Typing.lhs
View file @ 6081fb44
......@@ -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}
src/Checks.hs
View file @ 6081fb44
......@@ -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
src/Checks/KindCheck.lhs
View file @ 6081fb44
This diff is collapsed.
src/Checks/PrecCheck.lhs
View file @ 6081fb44
......@@ -38,13 +38,11 @@ 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
> [] -> foldr bindPrec pEnv fixDs
> op : _ -> errorAt' (undefinedOperator op)
> Just op -> errorAt' (duplicatePrecedence op)
> 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)
> where (fixDs,nonFixDs) = partition isInfixDecl ds
> bvs = concatMap boundValues nonFixDs
> ops = [ op | InfixDecl _ _ _ ops' <- fixDs, op <- ops']
......@@ -56,8 +54,8 @@ imported precedence environment.
> boundValues :: Decl -> [Ident]
> boundValues (DataDecl _ _ _ cs) = map constr cs
> where constr (ConstrDecl _ _ c _) = c
> constr (ConOpDecl _ _ _ op _) = op
> where constr (ConstrDecl _ _ c _) = c
> constr (ConOpDecl _ _ _ op _) = op
> boundValues (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]
> boundValues (FunctionDecl _ f _) = [f]
> boundValues (ExternalDecl _ _ _ f _) = [f]
......@@ -77,13 +75,13 @@ 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
> ds' = map (checkDecl m pEnv') ds
> checkDecl :: ModuleIdent -> PEnv -> Decl -> Decl
> checkDecl m pEnv (FunctionDecl p f eqs) =
......@@ -430,10 +428,9 @@ 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
> [] -> defaultP
> PrecInfo _ p : _ -> p
> prec op env = case qualLookupP op env of
> [] -> defaultP
> PrecInfo _ p : _ -> p
\end{verbatim}
Error messages.
......
src/Checks/SyntaxCheck.lhs
View file @ 6081fb44
......@@ -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
> [] -> 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
> 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
> [] -> 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
......
src/Checks/TypeCheck.lhs
View file @ 6081fb44
......@@ -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)
......@@ -689,7 +688,7 @@ because of possibly multiple occurrences of variables.
> tcExpr :: ModuleIdent -> TCEnv -> SigEnv -> Position -> Expression
> -> TcState Type
> tcExpr m _ _ _ (Literal l) = tcLiteral m l
> tcExpr m _ _ _ (Literal l) = tcLiteral m l
> tcExpr m tcEnv sigs _ (Variable v) =
> case qualLookupTypeSig m v sigs of
> Just ty -> inst (expandPolyType m tcEnv ty)
......@@ -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,40 +1158,35 @@ unambiguously refers to the local definition.
\begin{verbatim}
> constrType :: ModuleIdent -> QualIdent -> ValueEnv -> ExistTypeScheme
> constrType m c tyEnv =
> case qualLookupValue c tyEnv of
> [DataConstructor _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma
> _ -> case (qualLookupValue (qualQualify m c) tyEnv) of
> [DataConstructor _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma
> _ -> internalError ("constrType " ++ show c)
> constrType m c tyEnv = case qualLookupValue c tyEnv of
> [DataConstructor _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma
> _ -> case qualLookupValue (qualQualify m c) tyEnv of
> [DataConstructor _ sigma] -> sigma
> [NewtypeConstructor _ sigma] -> sigma
> _ -> internalError $ "TypeCheck.constrType " ++ show c
> varType :: Ident -> ValueEnv -> TypeScheme
> varType v tyEnv =
> case lookupValue v tyEnv of
> Value _ sigma : _ -> sigma
> _ -> internalError ("varType " ++ show v)
> varType v tyEnv = case lookupValue v tyEnv of
> 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
> _ -> Nothing
> 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
> [Value _ sigma] -> sigma
> _ -> case (qualLookupValue (qualQualify m f) tyEnv) of
> [Value _ sigma] -> sigma
> _ -> internalError ("funType " ++ show f)
> funType m f tyEnv = case qualLookupValue f tyEnv of
> [Value _ sigma] -> sigma
> _ -> case qualLookupValue (qualQualify m f) tyEnv of
> [Value _ sigma] -> sigma
> _ -> internalError $ "TypeCheck.funType " ++ show f
> sureLabelType :: Ident -> ValueEnv -> Maybe TypeScheme
> sureLabelType l tyEnv =
> case lookupValue l tyEnv of
> Label _ _ sigma : _ -> Just sigma
> _ -> Nothing
> sureLabelType l tyEnv = case lookupValue l tyEnv of
> Label _ _ sigma : _ -> Just sigma
> _ -> Nothing
\end{verbatim}
......@@ -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
......
src/Checks/WarnCheck.hs
View file @ 6081fb44
This diff is collapsed.
src/Env/Eval.lhs
View file @ 6081fb44
......@@ -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
......
src/Env/NestEnv.lhs
View file @ 6081fb44
......@@ -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
......
src/Env/TopEnv.lhs
View file @ 6081fb44
......@@ -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
......
src/Env/Value.lhs
View file @ 6081fb44
......@@ -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}
src/Exports.lhs
View file @ 6081fb44
......@@ -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