curry-frontend 1.0.1 → 1.0.2
raw patch · 50 files changed
+3173/−2323 lines, 50 filesdep ~curry-base
Dependency ranges changed: curry-base
Files
- CHANGELOG.md +11/−1
- curry-frontend.cabal +5/−4
- src/Base/AnnotExpr.hs +43/−42
- src/Base/CurryTypes.hs +43/−32
- src/Base/Expr.hs +78/−77
- src/Base/PrettyTypes.hs +5/−1
- src/Base/Typing.hs +52/−52
- src/Checks.hs +9/−9
- src/Checks/DeriveCheck.hs +1/−1
- src/Checks/ExportCheck.hs +50/−38
- src/Checks/ExtensionCheck.hs +2/−2
- src/Checks/ImportSyntaxCheck.hs +27/−26
- src/Checks/InstanceCheck.hs +17/−9
- src/Checks/InterfaceCheck.hs +15/−12
- src/Checks/InterfaceSyntaxCheck.hs +43/−39
- src/Checks/KindCheck.hs +105/−100
- src/Checks/PrecCheck.hs +141/−126
- src/Checks/SyntaxCheck.hs +241/−223
- src/Checks/TypeCheck.hs +173/−165
- src/Checks/TypeSyntaxCheck.hs +143/−130
- src/Checks/WarnCheck.hs +210/−195
- src/CompilerOpts.hs +24/−11
- src/CurryBuilder.hs +15/−9
- src/CurryDeps.hs +10/−6
- src/Env/TypeConstructor.hs +5/−1
- src/Env/Value.hs +5/−1
- src/Exports.hs +44/−39
- src/Generators.hs +21/−12
- src/Generators/GenAbstractCurry.hs +96/−85
- src/Generators/GenFlatCurry.hs +20/−20
- src/Generators/GenTypeAnnotatedFlatCurry.hs +517/−0
- src/Generators/GenTypedFlatCurry.hs +100/−103
- src/Html/SyntaxColoring.hs +68/−83
- src/IL/Pretty.hs +6/−2
- src/IL/ShowModule.hs +7/−6
- src/IL/Type.hs +2/−2
- src/IL/Typing.hs +1/−1
- src/Imports.hs +13/−11
- src/Interfaces.hs +15/−7
- src/Modules.hs +61/−23
- src/TokenStream.hs +31/−5
- src/Transformations/CaseCompletion.hs +4/−4
- src/Transformations/CurryToIL.hs +21/−21
- src/Transformations/Derive.hs +82/−62
- src/Transformations/Desugar.hs +265/−237
- src/Transformations/Dictionary.hs +121/−104
- src/Transformations/Lift.hs +51/−45
- src/Transformations/Newtypes.hs +20/−20
- src/Transformations/Qual.hs +87/−75
- src/Transformations/Simplify.hs +47/−44
CHANGELOG.md view
@@ -1,7 +1,17 @@ Change log for curry-frontend ============================= -Under development (1.0.1)+Version 1.0.2+=============++ * Added 'short-ast' and 'ast' as new compilation targets+ * Fixed bug with wrong type of free variables in the intermediate language.+ * Fixed bug with generated default implementations of nullary class methods.+ * Fixed bug in desugaring of record patterns.+ * Fixed bug that external data declarations weren't considered when+ AbstractCurry was generated++Version 1.0.1 ============= * Fixed bug with wrong order of super classes in selector functions
curry-frontend.cabal view
@@ -1,5 +1,5 @@ Name: curry-frontend-Version: 1.0.1+Version: 1.0.2 Cabal-Version: >= 1.10 Synopsis: Compile the functional logic language Curry to several intermediate formats@@ -43,7 +43,7 @@ Build-Depends: base == 4.* , containers- , curry-base == 1.0.0+ , curry-base == 1.1.0 , directory , extra >= 1.4.6 , filepath@@ -108,6 +108,7 @@ , Generators.GenAbstractCurry , Generators.GenFlatCurry , Generators.GenTypedFlatCurry+ , Generators.GenTypeAnnotatedFlatCurry , Html.CurryHtml , Html.SyntaxColoring , IL@@ -140,7 +141,7 @@ Build-Depends: base == 4.* , containers- , curry-base == 1.0.0+ , curry-base == 1.1.0 , curry-frontend , directory , extra >= 1.4.6@@ -161,5 +162,5 @@ hs-source-dirs: test default-language: Haskell2010 test-module: TestFrontend- build-depends: base == 4.*, Cabal >= 1.20, curry-base == 1.0.0+ build-depends: base == 4.*, Cabal >= 1.20, curry-base == 1.1.0 , curry-frontend, filepath
src/Base/AnnotExpr.hs view
@@ -15,6 +15,7 @@ import qualified Data.Set as Set (fromList, notMember) import Curry.Base.Ident+import Curry.Base.SpanInfo import Curry.Syntax import Base.Expr@@ -46,39 +47,39 @@ instance QualAnnotExpr Rhs where qafv m (SimpleRhs _ e ds) = filterBv ds $ qafv m e ++ concatMap (qafv m) ds- qafv m (GuardedRhs es ds) =+ qafv m (GuardedRhs _ es ds) = filterBv ds $ concatMap (qafv m) es ++ concatMap (qafv m) ds instance QualAnnotExpr CondExpr where qafv m (CondExpr _ g e) = qafv m g ++ qafv m e instance QualAnnotExpr Expression where- qafv _ (Literal _ _) = []- qafv m (Variable ty v) =+ qafv _ (Literal _ _ _) = []+ qafv m (Variable _ ty v) = maybe [] (return . (\v' -> (ty, v'))) $ localIdent m v- qafv _ (Constructor _ _) = []- qafv m (Paren e) = qafv m e- qafv m (Typed e _) = qafv m e- qafv m (Record _ _ fs) = concatMap (qafvField m) fs- qafv m (RecordUpdate e fs) = qafv m e ++ concatMap (qafvField m) fs- qafv m (Tuple es) = concatMap (qafv m) es- qafv m (List _ es) = concatMap (qafv m) es- qafv m (ListCompr e qs) = foldr (qafvStmt m) (qafv m e) qs- qafv m (EnumFrom e) = qafv m e- qafv m (EnumFromThen e1 e2) = qafv m e1 ++ qafv m e2- qafv m (EnumFromTo e1 e2) = qafv m e1 ++ qafv m e2- qafv m (EnumFromThenTo e1 e2 e3) = qafv m e1 ++ qafv m e2 ++ qafv m e3- qafv m (UnaryMinus e) = qafv m e- qafv m (Apply e1 e2) = qafv m e1 ++ qafv m e2- qafv m (InfixApply e1 op e2) = qafv m op ++ qafv m e1 ++ qafv m e2- qafv m (LeftSection e op) = qafv m op ++ qafv m e- qafv m (RightSection op e) = qafv m op ++ qafv m e- qafv m (Lambda ts e) = filterBv ts $ qafv m e- qafv m (Let ds e) =+ qafv _ (Constructor _ _ _) = []+ qafv m (Paren _ e) = qafv m e+ qafv m (Typed _ e _) = qafv m e+ qafv m (Record _ _ _ fs) = concatMap (qafvField m) fs+ qafv m (RecordUpdate _ e fs) = qafv m e ++ concatMap (qafvField m) fs+ qafv m (Tuple _ es) = concatMap (qafv m) es+ qafv m (List _ _ es) = concatMap (qafv m) es+ qafv m (ListCompr _ e qs) = foldr (qafvStmt m) (qafv m e) qs+ qafv m (EnumFrom _ e) = qafv m e+ qafv m (EnumFromThen _ e1 e2) = qafv m e1 ++ qafv m e2+ qafv m (EnumFromTo _ e1 e2) = qafv m e1 ++ qafv m e2+ qafv m (EnumFromThenTo _ e1 e2 e3) = qafv m e1 ++ qafv m e2 ++ qafv m e3+ qafv m (UnaryMinus _ e) = qafv m e+ qafv m (Apply _ e1 e2) = qafv m e1 ++ qafv m e2+ qafv m (InfixApply _ e1 op e2) = qafv m op ++ qafv m e1 ++ qafv m e2+ qafv m (LeftSection _ e op) = qafv m op ++ qafv m e+ qafv m (RightSection _ op e) = qafv m op ++ qafv m e+ qafv m (Lambda _ ts e) = filterBv ts $ qafv m e+ qafv m (Let _ ds e) = filterBv ds $ concatMap (qafv m) ds ++ qafv m e- qafv m (Do sts e) = foldr (qafvStmt m) (qafv m e) sts- qafv m (IfThenElse e1 e2 e3) = qafv m e1 ++ qafv m e2 ++ qafv m e3- qafv m (Case _ e alts) = qafv m e ++ concatMap (qafv m) alts+ qafv m (Do _ sts e) = foldr (qafvStmt m) (qafv m e) sts+ qafv m (IfThenElse _ e1 e2 e3) = qafv m e1 ++ qafv m e2 ++ qafv m e3+ qafv m (Case _ _ e alts) = qafv m e ++ concatMap (qafv m) alts qafvField :: QualAnnotExpr e => ModuleIdent -> Field (e Type) -> [(Type, Ident)] qafvField m (Field _ _ t) = qafv m t@@ -87,34 +88,34 @@ qafvStmt m st fvs = qafv m st ++ filterBv st fvs instance QualAnnotExpr Statement where- qafv m (StmtExpr e) = qafv m e- qafv m (StmtDecl ds) = filterBv ds $ concatMap (qafv m) ds- qafv m (StmtBind _ e) = qafv m e+ qafv m (StmtExpr _ e) = qafv m e+ qafv m (StmtDecl _ ds) = filterBv ds $ concatMap (qafv m) ds+ qafv m (StmtBind _ _ e) = qafv m e instance QualAnnotExpr Alt where qafv m (Alt _ t rhs) = filterBv t $ qafv m rhs instance QualAnnotExpr InfixOp where- qafv m (InfixOp ty op) = qafv m $ Variable ty op+ qafv m (InfixOp ty op) = qafv m $ Variable NoSpanInfo ty op qafv _ (InfixConstr _ _ ) = [] instance QualAnnotExpr Pattern where- qafv _ (LiteralPattern _ _) = []- qafv _ (NegativePattern _ _) = []- qafv _ (VariablePattern _ _) = []- qafv m (ConstructorPattern _ _ ts) = concatMap (qafv m) ts- qafv m (InfixPattern _ t1 _ t2) = qafv m t1 ++ qafv m t2- qafv m (ParenPattern t) = qafv m t- qafv m (RecordPattern _ _ fs) = concatMap (qafvField m) fs- qafv m (TuplePattern ts) = concatMap (qafv m) ts- qafv m (ListPattern _ ts) = concatMap (qafv m) ts- qafv m (AsPattern _ t) = qafv m t- qafv m (LazyPattern t) = qafv m t- qafv m (FunctionPattern ty f ts) =+ qafv _ (LiteralPattern _ _ _) = []+ qafv _ (NegativePattern _ _ _) = []+ qafv _ (VariablePattern _ _ _) = []+ qafv m (ConstructorPattern _ _ _ ts) = concatMap (qafv m) ts+ qafv m (InfixPattern _ _ t1 _ t2) = qafv m t1 ++ qafv m t2+ qafv m (ParenPattern _ t) = qafv m t+ qafv m (RecordPattern _ _ _ fs) = concatMap (qafvField m) fs+ qafv m (TuplePattern _ ts) = concatMap (qafv m) ts+ qafv m (ListPattern _ _ ts) = concatMap (qafv m) ts+ qafv m (AsPattern _ _ t) = qafv m t+ qafv m (LazyPattern _ t) = qafv m t+ qafv m (FunctionPattern _ ty f ts) = maybe [] (return . (\f' -> (ty', f'))) (localIdent m f) ++ concatMap (qafv m) ts where ty' = foldr TypeArrow ty $ map typeOf ts- qafv m (InfixFuncPattern ty t1 op t2) =+ qafv m (InfixFuncPattern _ ty t1 op t2) = maybe [] (return . (\op' -> (ty', op'))) (localIdent m op) ++ concatMap (qafv m) [t1, t2] where ty' = foldr TypeArrow ty $ map typeOf [t1, t2]
src/Base/CurryTypes.hs view
@@ -39,6 +39,7 @@ import Curry.Base.Ident import Curry.Base.Pretty (Doc)+import Curry.Base.SpanInfo import qualified Curry.Syntax as CS import Curry.Syntax.Pretty (ppConstraint, ppTypeExpr, ppQualTypeExpr) @@ -59,25 +60,26 @@ toTypes tvs tys = map ((flip (toType' (enumTypeVars tvs tys))) []) tys toType' :: Map.Map Ident Int -> CS.TypeExpr -> [Type] -> Type-toType' _ (CS.ConstructorType tc) tys = applyType (TypeConstructor tc) tys-toType' tvs (CS.ApplyType ty1 ty2) tys =+toType' _ (CS.ConstructorType _ tc) tys = applyType (TypeConstructor tc) tys+toType' tvs (CS.ApplyType _ ty1 ty2) tys = toType' tvs ty1 (toType' tvs ty2 [] : tys)-toType' tvs (CS.VariableType tv) tys =+toType' tvs (CS.VariableType _ tv) tys = applyType (TypeVariable (toVar tvs tv)) tys-toType' tvs (CS.TupleType tys) tys'+toType' tvs (CS.TupleType _ tys) tys' | null tys = internalError "Base.CurryTypes.toType': zero-element tuple" | null tys' = tupleType $ map ((flip $ toType' tvs) []) tys | otherwise = internalError "Base.CurryTypes.toType': tuple type application"-toType' tvs (CS.ListType ty) tys+toType' tvs (CS.ListType _ ty) tys | null tys = listType $ toType' tvs ty [] | otherwise = internalError "Base.CurryTypes.toType': list type application"-toType' tvs (CS.ArrowType ty1 ty2) tys+toType' tvs (CS.ArrowType _ ty1 ty2) tys | null tys = TypeArrow (toType' tvs ty1 []) (toType' tvs ty2 []) | otherwise = internalError "Base.CurryTypes.toType': arrow type application"-toType' tvs (CS.ParenType ty) tys = toType' tvs ty tys-toType' tvs (CS.ForallType tvs' ty) tys+toType' tvs (CS.ParenType _ ty) tys = toType' tvs ty tys+toType' tvs (CS.ForallType _ tvs' ty) tys | null tvs' = toType' tvs ty tys- | otherwise = applyType (TypeForall (map (toVar tvs) tvs') (toType' tvs ty []))+ | otherwise = applyType (TypeForall (map (toVar tvs) tvs')+ (toType' tvs ty [])) tys toVar :: Map.Map Ident Int -> Ident -> Int@@ -95,7 +97,7 @@ toPred tvs c = toPred' (enumTypeVars tvs c) c toPred' :: Map.Map Ident Int -> CS.Constraint -> Pred-toPred' tvs (CS.Constraint qcls ty) = Pred qcls (toType' tvs ty [])+toPred' tvs (CS.Constraint _ qcls ty) = Pred qcls (toType' tvs ty []) toQualPred :: ModuleIdent -> [Ident] -> CS.Constraint -> Pred toQualPred m tvs = qualifyPred m . toPred tvs@@ -113,7 +115,7 @@ toPredType tvs qty = toPredType' (enumTypeVars tvs qty) qty toPredType' :: Map.Map Ident Int -> CS.QualTypeExpr -> PredType-toPredType' tvs (CS.QualTypeExpr cx ty) =+toPredType' tvs (CS.QualTypeExpr _ cx ty) = PredType (toPredSet' tvs cx) (toType' tvs ty []) toQualPredType :: ModuleIdent -> [Ident] -> CS.QualTypeExpr -> PredType@@ -124,19 +126,21 @@ -- which are free in the argument types. toConstrType :: QualIdent -> [Ident] -> CS.Context -> [CS.TypeExpr] -> PredType-toConstrType tc tvs cx tys = toPredType tvs $ CS.QualTypeExpr cx' ty'+toConstrType tc tvs cx tys = toPredType tvs $+ CS.QualTypeExpr NoSpanInfo cx' ty' where tvs' = nub (fv tys) cx' = restrictContext tvs' cx- ty' = foldr CS.ArrowType ty0 tys- ty0 = foldl CS.ApplyType- (CS.ConstructorType tc)- (map CS.VariableType tvs)+ ty' = foldr (CS.ArrowType NoSpanInfo) ty0 tys+ ty0 = foldl (CS.ApplyType NoSpanInfo)+ (CS.ConstructorType NoSpanInfo tc)+ (map (CS.VariableType NoSpanInfo) tvs) restrictContext :: [Ident] -> CS.Context -> CS.Context restrictContext tvs cx =- [CS.Constraint cls ty | CS.Constraint cls ty <- cx, classVar ty `elem` tvs]- where classVar (CS.VariableType tv) = tv- classVar (CS.ApplyType ty _) = classVar ty+ [CS.Constraint spi cls ty+ | CS.Constraint spi cls ty <- cx, classVar ty `elem` tvs]+ where classVar (CS.VariableType _ tv) = tv+ classVar (CS.ApplyType _ ty _) = classVar ty classVar _ = internalError "Base.CurryTypes.restrictContext.classVar" -- The function 'toMethodType' returns the type of a type class method.@@ -144,32 +148,39 @@ -- and ensures that the class' type variable is always assigned index 0. toMethodType :: QualIdent -> Ident -> CS.QualTypeExpr -> PredType-toMethodType qcls clsvar (CS.QualTypeExpr cx ty) =- toPredType [clsvar] (CS.QualTypeExpr cx' ty)- where cx' = CS.Constraint qcls (CS.VariableType clsvar) : cx+toMethodType qcls clsvar (CS.QualTypeExpr spi cx ty) =+ toPredType [clsvar] (CS.QualTypeExpr spi cx' ty)+ where cx' = CS.Constraint NoSpanInfo qcls+ (CS.VariableType NoSpanInfo clsvar) : cx fromType :: [Ident] -> Type -> CS.TypeExpr fromType tvs ty = fromType' tvs ty [] fromType' :: [Ident] -> Type -> [CS.TypeExpr] -> CS.TypeExpr fromType' _ (TypeConstructor tc) tys- | isQTupleId tc && qTupleArity tc == length tys = CS.TupleType tys- | tc == qListId && length tys == 1 = CS.ListType (head tys)+ | isQTupleId tc && qTupleArity tc == length tys+ = CS.TupleType NoSpanInfo tys+ | tc == qListId && length tys == 1+ = CS.ListType NoSpanInfo (head tys) | otherwise- = foldl CS.ApplyType (CS.ConstructorType tc) tys+ = foldl (CS.ApplyType NoSpanInfo) (CS.ConstructorType NoSpanInfo tc) tys fromType' tvs (TypeApply ty1 ty2) tys = fromType' tvs ty1 (fromType tvs ty2 : tys) fromType' tvs (TypeVariable tv) tys =- foldl CS.ApplyType (CS.VariableType (fromVar tvs tv)) tys+ foldl (CS.ApplyType NoSpanInfo) (CS.VariableType NoSpanInfo (fromVar tvs tv))+ tys fromType' tvs (TypeArrow ty1 ty2) tys =- foldl CS.ApplyType (CS.ArrowType (fromType tvs ty1) (fromType tvs ty2)) tys+ foldl (CS.ApplyType NoSpanInfo)+ (CS.ArrowType NoSpanInfo (fromType tvs ty1) (fromType tvs ty2)) tys fromType' tvs (TypeConstrained tys _) tys' = fromType' tvs (head tys) tys' fromType' _ (TypeSkolem k) tys =- foldl CS.ApplyType (CS.VariableType $ mkIdent $ "_?" ++ show k) tys+ foldl (CS.ApplyType NoSpanInfo)+ (CS.VariableType NoSpanInfo $ mkIdent $ "_?" ++ show k) tys fromType' tvs (TypeForall tvs' ty) tys | null tvs' = fromType' tvs ty tys- | otherwise = foldl CS.ApplyType- (CS.ForallType (map (fromVar tvs) tvs') (fromType tvs ty))+ | otherwise = foldl (CS.ApplyType NoSpanInfo)+ (CS.ForallType NoSpanInfo (map (fromVar tvs) tvs')+ (fromType tvs ty)) tys fromVar :: [Ident] -> Int -> Ident@@ -179,7 +190,7 @@ fromQualType m tvs = fromType tvs . unqualifyType m fromPred :: [Ident] -> Pred -> CS.Constraint-fromPred tvs (Pred qcls ty) = CS.Constraint qcls (fromType tvs ty)+fromPred tvs (Pred qcls ty) = CS.Constraint NoSpanInfo qcls (fromType tvs ty) fromQualPred :: ModuleIdent -> [Ident] -> Pred -> CS.Constraint fromQualPred m tvs = fromPred tvs . unqualifyPred m@@ -195,7 +206,7 @@ fromPredType :: [Ident] -> PredType -> CS.QualTypeExpr fromPredType tvs (PredType ps ty) =- CS.QualTypeExpr (fromPredSet tvs ps) (fromType tvs ty)+ CS.QualTypeExpr NoSpanInfo (fromPredSet tvs ps) (fromType tvs ty) fromQualPredType :: ModuleIdent -> [Ident] -> PredType -> CS.QualTypeExpr fromQualPredType m tvs = fromPredType tvs . unqualifyPredType m
src/Base/Expr.hs view
@@ -27,6 +27,7 @@ import qualified Data.Set as Set (fromList, notMember) import Curry.Base.Ident+import Curry.Base.SpanInfo import Curry.Syntax class Expr e where@@ -83,44 +84,44 @@ instance QualExpr (Rhs a) where qfv m (SimpleRhs _ e ds) = filterBv ds $ qfv m e ++ qfv m ds- qfv m (GuardedRhs es ds) = filterBv ds $ qfv m es ++ qfv m ds+ qfv m (GuardedRhs _ es ds) = filterBv ds $ qfv m es ++ qfv m ds instance QualExpr (CondExpr a) where qfv m (CondExpr _ g e) = qfv m g ++ qfv m e instance QualExpr (Expression a) where- qfv _ (Literal _ _) = []- qfv m (Variable _ v) = maybe [] return $ localIdent m v- qfv _ (Constructor _ _) = []- qfv m (Paren e) = qfv m e- qfv m (Typed e _) = qfv m e- qfv m (Record _ _ fs) = qfv m fs- qfv m (RecordUpdate e fs) = qfv m e ++ qfv m fs- qfv m (Tuple es) = qfv m es- qfv m (List _ es) = qfv m es- qfv m (ListCompr e qs) = foldr (qfvStmt m) (qfv m e) qs- qfv m (EnumFrom e) = qfv m e- qfv m (EnumFromThen e1 e2) = qfv m e1 ++ qfv m e2- qfv m (EnumFromTo e1 e2) = qfv m e1 ++ qfv m e2- qfv m (EnumFromThenTo e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3- qfv m (UnaryMinus e) = qfv m e- qfv m (Apply e1 e2) = qfv m e1 ++ qfv m e2- qfv m (InfixApply e1 op e2) = qfv m op ++ qfv m e1 ++ qfv m e2- qfv m (LeftSection e op) = qfv m op ++ qfv m e- qfv m (RightSection op e) = qfv m op ++ qfv m e- qfv m (Lambda ts e) = filterBv ts $ qfv m e- qfv m (Let ds e) = filterBv ds $ qfv m ds ++ qfv m e- qfv m (Do sts e) = foldr (qfvStmt m) (qfv m e) sts- qfv m (IfThenElse e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3- qfv m (Case _ e alts) = qfv m e ++ qfv m alts+ qfv _ (Literal _ _ _) = []+ qfv m (Variable _ _ v) = maybe [] return $ localIdent m v+ qfv _ (Constructor _ _ _) = []+ qfv m (Paren _ e) = qfv m e+ qfv m (Typed _ e _) = qfv m e+ qfv m (Record _ _ _ fs) = qfv m fs+ qfv m (RecordUpdate _ e fs) = qfv m e ++ qfv m fs+ qfv m (Tuple _ es) = qfv m es+ qfv m (List _ _ es) = qfv m es+ qfv m (ListCompr _ e qs) = foldr (qfvStmt m) (qfv m e) qs+ qfv m (EnumFrom _ e) = qfv m e+ qfv m (EnumFromThen _ e1 e2) = qfv m e1 ++ qfv m e2+ qfv m (EnumFromTo _ e1 e2) = qfv m e1 ++ qfv m e2+ qfv m (EnumFromThenTo _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3+ qfv m (UnaryMinus _ e) = qfv m e+ qfv m (Apply _ e1 e2) = qfv m e1 ++ qfv m e2+ qfv m (InfixApply _ e1 op e2) = qfv m op ++ qfv m e1 ++ qfv m e2+ qfv m (LeftSection _ e op) = qfv m op ++ qfv m e+ qfv m (RightSection _ op e) = qfv m op ++ qfv m e+ qfv m (Lambda _ ts e) = filterBv ts $ qfv m e+ qfv m (Let _ ds e) = filterBv ds $ qfv m ds ++ qfv m e+ qfv m (Do _ sts e) = foldr (qfvStmt m) (qfv m e) sts+ qfv m (IfThenElse _ e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3+ qfv m (Case _ _ e alts) = qfv m e ++ qfv m alts qfvStmt :: ModuleIdent -> (Statement a) -> [Ident] -> [Ident] qfvStmt m st fvs = qfv m st ++ filterBv st fvs instance QualExpr (Statement a) where- qfv m (StmtExpr e) = qfv m e- qfv m (StmtDecl ds) = filterBv ds $ qfv m ds- qfv m (StmtBind _ e) = qfv m e+ qfv m (StmtExpr _ e) = qfv m e+ qfv m (StmtDecl _ ds) = filterBv ds $ qfv m ds+ qfv m (StmtBind _ _ e) = qfv m e instance QualExpr (Alt a) where qfv m (Alt _ t rhs) = filterBv t $ qfv m rhs@@ -135,77 +136,77 @@ qfv m (Field _ _ t) = qfv m t instance QuantExpr (Statement a) where- bv (StmtExpr _) = []- bv (StmtBind t _) = bv t- bv (StmtDecl ds) = bv ds+ bv (StmtExpr _ _) = []+ bv (StmtBind _ t _) = bv t+ bv (StmtDecl _ ds) = bv ds instance QualExpr (InfixOp a) where- qfv m (InfixOp a op) = qfv m $ Variable a op+ qfv m (InfixOp a op) = qfv m $ Variable NoSpanInfo a op qfv _ (InfixConstr _ _ ) = [] instance QuantExpr (Pattern a) where- bv (LiteralPattern _ _) = []- bv (NegativePattern _ _) = []- bv (VariablePattern _ v) = [v]- bv (ConstructorPattern _ _ ts) = bv ts- bv (InfixPattern _ t1 _ t2) = bv t1 ++ bv t2- bv (ParenPattern t) = bv t- bv (RecordPattern _ _ fs) = bv fs- bv (TuplePattern ts) = bv ts- bv (ListPattern _ ts) = bv ts- bv (AsPattern v t) = v : bv t- bv (LazyPattern t) = bv t- bv (FunctionPattern _ _ ts) = nub $ bv ts- bv (InfixFuncPattern _ t1 _ t2) = nub $ bv t1 ++ bv t2+ bv (LiteralPattern _ _ _) = []+ bv (NegativePattern _ _ _) = []+ bv (VariablePattern _ _ v) = [v]+ bv (ConstructorPattern _ _ _ ts) = bv ts+ bv (InfixPattern _ _ t1 _ t2) = bv t1 ++ bv t2+ bv (ParenPattern _ t) = bv t+ bv (RecordPattern _ _ _ fs) = bv fs+ bv (TuplePattern _ ts) = bv ts+ bv (ListPattern _ _ ts) = bv ts+ bv (AsPattern _ v t) = v : bv t+ bv (LazyPattern _ t) = bv t+ bv (FunctionPattern _ _ _ ts) = nub $ bv ts+ bv (InfixFuncPattern _ _ t1 _ t2) = nub $ bv t1 ++ bv t2 instance QualExpr (Pattern a) where- qfv _ (LiteralPattern _ _) = []- qfv _ (NegativePattern _ _) = []- qfv _ (VariablePattern _ _) = []- qfv m (ConstructorPattern _ _ ts) = qfv m ts- qfv m (InfixPattern _ t1 _ t2) = qfv m [t1, t2]- qfv m (ParenPattern t) = qfv m t- qfv m (RecordPattern _ _ fs) = qfv m fs- qfv m (TuplePattern ts) = qfv m ts- qfv m (ListPattern _ ts) = qfv m ts- qfv m (AsPattern _ ts) = qfv m ts- qfv m (LazyPattern t) = qfv m t- qfv m (FunctionPattern _ f ts)+ qfv _ (LiteralPattern _ _ _) = []+ qfv _ (NegativePattern _ _ _) = []+ qfv _ (VariablePattern _ _ _) = []+ qfv m (ConstructorPattern _ _ _ ts) = qfv m ts+ qfv m (InfixPattern _ _ t1 _ t2) = qfv m [t1, t2]+ qfv m (ParenPattern _ t) = qfv m t+ qfv m (RecordPattern _ _ _ fs) = qfv m fs+ qfv m (TuplePattern _ ts) = qfv m ts+ qfv m (ListPattern _ _ ts) = qfv m ts+ qfv m (AsPattern _ _ ts) = qfv m ts+ qfv m (LazyPattern _ t) = qfv m t+ qfv m (FunctionPattern _ _ f ts) = maybe [] return (localIdent m f) ++ qfv m ts- qfv m (InfixFuncPattern _ t1 op t2)+ qfv m (InfixFuncPattern _ _ t1 op t2) = maybe [] return (localIdent m op) ++ qfv m [t1, t2] instance Expr Constraint where- fv (Constraint _ ty) = fv ty+ fv (Constraint _ _ ty) = fv ty instance QuantExpr Constraint where bv _ = [] instance Expr QualTypeExpr where- fv (QualTypeExpr _ ty) = fv ty+ fv (QualTypeExpr _ _ ty) = fv ty instance QuantExpr QualTypeExpr where- bv (QualTypeExpr _ ty) = bv ty+ bv (QualTypeExpr _ _ ty) = bv ty instance Expr TypeExpr where- fv (ConstructorType _) = []- fv (ApplyType ty1 ty2) = fv ty1 ++ fv ty2- fv (VariableType tv) = [tv]- fv (TupleType tys) = fv tys- fv (ListType ty) = fv ty- fv (ArrowType ty1 ty2) = fv ty1 ++ fv ty2- fv (ParenType ty) = fv ty- fv (ForallType vs ty) = filter (`notElem` vs) $ fv ty+ fv (ConstructorType _ _) = []+ fv (ApplyType _ ty1 ty2) = fv ty1 ++ fv ty2+ fv (VariableType _ tv) = [tv]+ fv (TupleType _ tys) = fv tys+ fv (ListType _ ty) = fv ty+ fv (ArrowType _ ty1 ty2) = fv ty1 ++ fv ty2+ fv (ParenType _ ty) = fv ty+ fv (ForallType _ vs ty) = filter (`notElem` vs) $ fv ty instance QuantExpr TypeExpr where- bv (ConstructorType _) = []- bv (ApplyType ty1 ty2) = bv ty1 ++ bv ty2- bv (VariableType _) = []- bv (TupleType tys) = bv tys- bv (ListType ty) = bv ty- bv (ArrowType ty1 ty2) = bv ty1 ++ bv ty2- bv (ParenType ty) = bv ty- bv (ForallType tvs ty) = tvs ++ bv ty+ bv (ConstructorType _ _) = []+ bv (ApplyType _ ty1 ty2) = bv ty1 ++ bv ty2+ bv (VariableType _ _) = []+ bv (TupleType _ tys) = bv tys+ bv (ListType _ ty) = bv ty+ bv (ArrowType _ ty1 ty2) = bv ty1 ++ bv ty2+ bv (ParenType _ ty) = bv ty+ bv (ForallType _ tvs ty) = tvs ++ bv ty filterBv :: QuantExpr e => e -> [Ident] -> [Ident] filterBv e = filter (`Set.notMember` Set.fromList (bv e))
src/Base/PrettyTypes.hs view
@@ -10,8 +10,12 @@ TODO -}-+{-# LANGUAGE CPP #-} module Base.PrettyTypes where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif import Data.Maybe (fromMaybe) import qualified Data.Set as Set (Set, toAscList)
src/Base/Typing.hs view
@@ -46,57 +46,57 @@ typeOf = unpredType instance Typeable a => Typeable (Rhs a) where- typeOf (SimpleRhs _ e _) = typeOf e- typeOf (GuardedRhs es _) = head [typeOf e | CondExpr _ _ e <- es]+ typeOf (SimpleRhs _ e _ ) = typeOf e+ typeOf (GuardedRhs _ es _) = head [typeOf e | CondExpr _ _ e <- es] instance Typeable a => Typeable (Pattern a) where- typeOf (LiteralPattern a _) = typeOf a- typeOf (NegativePattern a _) = typeOf a- typeOf (VariablePattern a _) = typeOf a- typeOf (ConstructorPattern a _ _) = typeOf a- typeOf (InfixPattern a _ _ _) = typeOf a- typeOf (ParenPattern t) = typeOf t- typeOf (RecordPattern a _ _) = typeOf a- typeOf (TuplePattern ts) = tupleType $ map typeOf ts- typeOf (ListPattern a _) = typeOf a- typeOf (AsPattern _ t) = typeOf t- typeOf (LazyPattern t) = typeOf t- typeOf (FunctionPattern a _ _) = typeOf a- typeOf (InfixFuncPattern a _ _ _) = typeOf a+ typeOf (LiteralPattern _ a _) = typeOf a+ typeOf (NegativePattern _ a _) = typeOf a+ typeOf (VariablePattern _ a _) = typeOf a+ typeOf (ConstructorPattern _ a _ _) = typeOf a+ typeOf (InfixPattern _ a _ _ _) = typeOf a+ typeOf (ParenPattern _ t) = typeOf t+ typeOf (RecordPattern _ a _ _) = typeOf a+ typeOf (TuplePattern _ ts) = tupleType $ map typeOf ts+ typeOf (ListPattern _ a _) = typeOf a+ typeOf (AsPattern _ _ t) = typeOf t+ typeOf (LazyPattern _ t) = typeOf t+ typeOf (FunctionPattern _ a _ _) = typeOf a+ typeOf (InfixFuncPattern _ a _ _ _) = typeOf a instance Typeable a => Typeable (Expression a) where- typeOf (Literal a _) = typeOf a- typeOf (Variable a _) = typeOf a- typeOf (Constructor a _) = typeOf a- typeOf (Paren e) = typeOf e- typeOf (Typed e _) = typeOf e- typeOf (Record a _ _) = typeOf a- typeOf (RecordUpdate e _) = typeOf e- typeOf (Tuple es) = tupleType (map typeOf es)- typeOf (List a _) = typeOf a- typeOf (ListCompr e _) = listType (typeOf e)- typeOf (EnumFrom e) = listType (typeOf e)- typeOf (EnumFromThen e _) = listType (typeOf e)- typeOf (EnumFromTo e _) = listType (typeOf e)- typeOf (EnumFromThenTo e _ _) = listType (typeOf e)- typeOf (UnaryMinus e) = typeOf e- typeOf (Apply e _) = case typeOf e of+ typeOf (Literal _ a _) = typeOf a+ typeOf (Variable _ a _) = typeOf a+ typeOf (Constructor _ a _) = typeOf a+ typeOf (Paren _ e) = typeOf e+ typeOf (Typed _ e _) = typeOf e+ typeOf (Record _ a _ _) = typeOf a+ typeOf (RecordUpdate _ e _) = typeOf e+ typeOf (Tuple _ es) = tupleType (map typeOf es)+ typeOf (List _ a _) = typeOf a+ typeOf (ListCompr _ e _) = listType (typeOf e)+ typeOf (EnumFrom _ e) = listType (typeOf e)+ typeOf (EnumFromThen _ e _) = listType (typeOf e)+ typeOf (EnumFromTo _ e _) = listType (typeOf e)+ typeOf (EnumFromThenTo _ e _ _) = listType (typeOf e)+ typeOf (UnaryMinus _ e) = typeOf e+ typeOf (Apply _ e _) = case typeOf e of TypeArrow _ ty -> ty _ -> internalError "Base.Typing.typeOf: application"- typeOf (InfixApply _ op _) = case typeOf (infixOp op) of+ typeOf (InfixApply _ _ op _) = case typeOf (infixOp op) of TypeArrow _ (TypeArrow _ ty) -> ty _ -> internalError "Base.Typing.typeOf: infix application"- typeOf (LeftSection _ op) = case typeOf (infixOp op) of+ typeOf (LeftSection _ _ op) = case typeOf (infixOp op) of TypeArrow _ ty -> ty _ -> internalError "Base.Typing.typeOf: left section"- typeOf (RightSection op _) = case typeOf (infixOp op) of+ typeOf (RightSection _ op _) = case typeOf (infixOp op) of TypeArrow ty1 (TypeArrow _ ty2) -> TypeArrow ty1 ty2 _ -> internalError "Base.Typing.typeOf: right section"- typeOf (Lambda ts e) = foldr (TypeArrow . typeOf) (typeOf e) ts- typeOf (Let _ e) = typeOf e- typeOf (Do _ e) = typeOf e- typeOf (IfThenElse _ e _) = typeOf e- typeOf (Case _ _ as) = typeOf $ head as+ typeOf (Lambda _ ts e) = foldr (TypeArrow . typeOf) (typeOf e) ts+ typeOf (Let _ _ e) = typeOf e+ typeOf (Do _ _ e) = typeOf e+ typeOf (IfThenElse _ _ e _) = typeOf e+ typeOf (Case _ _ _ as) = typeOf $ head as instance Typeable a => Typeable (Alt a) where typeOf (Alt _ _ rhs) = typeOf rhs@@ -174,19 +174,19 @@ declVars _ = internalError "Base.Typing.declVars" patternVars :: (Eq t, Typeable t, ValueType t) => Pattern t -> [(Ident, Int, t)]-patternVars (LiteralPattern _ _) = []-patternVars (NegativePattern _ _) = []-patternVars (VariablePattern ty v) = [(v, 0, ty)]-patternVars (ConstructorPattern _ _ ts) = concatMap patternVars ts-patternVars (InfixPattern _ t1 _ t2) = patternVars t1 ++ patternVars t2-patternVars (ParenPattern t) = patternVars t-patternVars (RecordPattern _ _ fs) =+patternVars (LiteralPattern _ _ _) = []+patternVars (NegativePattern _ _ _) = []+patternVars (VariablePattern _ ty v) = [(v, 0, ty)]+patternVars (ConstructorPattern _ _ _ ts) = concatMap patternVars ts+patternVars (InfixPattern _ _ t1 _ t2) = patternVars t1 ++ patternVars t2+patternVars (ParenPattern _ t) = patternVars t+patternVars (RecordPattern _ _ _ fs) = concat [patternVars t | Field _ _ t <- fs]-patternVars (TuplePattern ts) = concatMap patternVars ts-patternVars (ListPattern _ ts) = concatMap patternVars ts-patternVars (AsPattern v t) =+patternVars (TuplePattern _ ts) = concatMap patternVars ts+patternVars (ListPattern _ _ ts) = concatMap patternVars ts+patternVars (AsPattern _ v t) = (v, 0, toValueType $ typeOf t) : patternVars t-patternVars (LazyPattern t) = patternVars t-patternVars (FunctionPattern _ _ ts) = nub $ concatMap patternVars ts-patternVars (InfixFuncPattern _ t1 _ t2) =+patternVars (LazyPattern _ t) = patternVars t+patternVars (FunctionPattern _ _ _ ts) = nub $ concatMap patternVars ts+patternVars (InfixFuncPattern _ _ t1 _ t2) = nub $ patternVars t1 ++ patternVars t2
src/Checks.hs view
@@ -103,8 +103,8 @@ -- precedences -- * Environment: The operator precedence environment is updated precCheck :: Monad m => Check m (Module a)-precCheck _ (env, Module ps m es is ds)- | null msgs = ok (env { opPrecEnv = pEnv' }, Module ps m es is ds')+precCheck _ (env, Module spi ps m es is ds)+ | null msgs = ok (env { opPrecEnv = pEnv' }, Module spi ps m es is ds') | otherwise = failMessages msgs where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds @@ -122,8 +122,8 @@ -- * Declarations: remain unchanged -- * Environment: The instance environment is updated instanceCheck :: Monad m => Check m (Module a)-instanceCheck _ (env, Module ps m es is ds)- | null msgs = ok (env { instEnv = inEnv' }, Module ps m es is ds)+instanceCheck _ (env, Module spi ps m es is ds)+ | null msgs = ok (env { instEnv = inEnv' }, Module spi ps m es is ds) | otherwise = failMessages msgs where (inEnv', msgs) = INC.instanceCheck (moduleIdent env) (tyConsEnv env) (classEnv env) (instEnv env) ds@@ -134,8 +134,8 @@ -- * Environment: The value environment is updated. typeCheck :: Monad m => Options -> CompEnv (Module a) -> CYT m (CompEnv (Module PredType))-typeCheck _ (env, Module ps m es is ds)- | null msgs = ok (env { valueEnv = vEnv' }, Module ps m es is ds')+typeCheck _ (env, Module spi ps m es is ds)+ | null msgs = ok (env { valueEnv = vEnv' }, Module spi ps m es is ds') | otherwise = failMessages msgs where (ds', vEnv', msgs) = TC.typeCheck (moduleIdent env) (tyConsEnv env) (valueEnv env) (classEnv env)@@ -143,7 +143,7 @@ -- |Check the export specification exportCheck :: Monad m => Check m (Module a)-exportCheck _ (env, mdl@(Module _ _ es _ _))+exportCheck _ (env, mdl@(Module _ _ _ es _ _)) | null msgs = ok (env, mdl) | otherwise = failMessages msgs where msgs = EC.exportCheck (moduleIdent env) (aliasEnv env)@@ -151,8 +151,8 @@ -- |Check the export specification expandExports :: Monad m => Options -> CompEnv (Module a) -> m (CompEnv (Module a))-expandExports _ (env, Module ps m es is ds)- = return (env, Module ps m (Just es') is ds)+expandExports _ (env, Module spi ps m es is ds)+ = return (env, Module spi ps m (Just es') is ds) where es' = EC.expandExports (moduleIdent env) (aliasEnv env) (tyConsEnv env) (valueEnv env) es
src/Checks/DeriveCheck.hs view
@@ -24,7 +24,7 @@ import Env.TypeConstructor deriveCheck :: TCEnv -> Module a -> [Message]-deriveCheck tcEnv (Module _ m _ _ ds) = concatMap (checkDecl m tcEnv) ds+deriveCheck tcEnv (Module _ _ m _ _ ds) = concatMap (checkDecl m tcEnv) ds -- No instances can be derived for abstract data types as well as for -- existential data types.
src/Checks/ExportCheck.hs view
@@ -26,6 +26,10 @@ {-# LANGUAGE CPP #-} module Checks.ExportCheck (exportCheck, expandExports) where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif@@ -40,6 +44,7 @@ import Curry.Base.Ident import Curry.Base.Position+import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax @@ -64,10 +69,10 @@ expandExports :: ModuleIdent -> AliasEnv -> TCEnv -> ValueEnv -> Maybe ExportSpec -> ExportSpec-expandExports m aEnv tcEnv tyEnv spec = Exporting (exportPos spec) es+expandExports m aEnv tcEnv tyEnv spec = Exporting (exportSpan spec) es where- exportPos (Just (Exporting p _)) = p- exportPos Nothing = NoPos+ exportSpan (Just (Exporting spi _)) = spi+ exportSpan Nothing = NoSpanInfo es = expand m aEnv tcEnv tyEnv spec @@ -131,10 +136,10 @@ -- |Check single export. checkExport :: Export -> ECM ()-checkExport (Export x ) = checkThing x-checkExport (ExportTypeWith tc cs) = checkTypeWith tc cs-checkExport (ExportTypeAll tc ) = checkTypeAll tc-checkExport (ExportModule em ) = checkModule em+checkExport (Export _ x ) = checkThing x+checkExport (ExportTypeWith _ tc cs) = checkTypeWith tc cs+checkExport (ExportTypeAll _ tc ) = checkTypeAll tc+checkExport (ExportModule _ em ) = checkModule em -- |Check export of type constructor / function checkThing :: QualIdent -> ECM ()@@ -143,7 +148,7 @@ tcEnv <- getTyConsEnv case qualLookupTypeInfoUnique m tc tcEnv of [] -> checkThing' tc Nothing- [t] -> checkThing' tc (Just [ExportTypeWith (origName t) []])+ [t] -> checkThing' tc (Just [ExportTypeWith NoSpanInfo (origName t) []]) ts -> report (errAmbiguousType tc ts) -- |Expand export of data cons / function@@ -226,9 +231,9 @@ checkNonUniqueness es = map errMultipleType (findMultiples types ) ++ map errMultipleName (findMultiples values) where- types = [ unqualify tc | ExportTypeWith tc _ <- es ]- values = [ c | ExportTypeWith _ cs <- es, c <- cs ]- ++ [ unqualify f | Export f <- es ]+ types = [ unqualify tc | ExportTypeWith _ tc _ <- es ]+ values = [ c | ExportTypeWith _ _ cs <- es, c <- cs ]+ ++ [ unqualify f | Export _ f <- es ] -- ----------------------------------------------------------------------------- -- Expansion@@ -262,10 +267,10 @@ -- |Expand single export expandExport :: Export -> ECM [Export]-expandExport (Export x) = expandThing x-expandExport (ExportTypeWith tc cs) = expandTypeWith tc cs-expandExport (ExportTypeAll tc) = expandTypeAll tc-expandExport (ExportModule em) = expandModule em+expandExport (Export _ x) = expandThing x+expandExport (ExportTypeWith _ tc cs) = expandTypeWith tc cs+expandExport (ExportTypeAll _ tc) = expandTypeAll tc+expandExport (ExportModule _ em) = expandModule em -- |Expand export of type constructor / function expandThing :: QualIdent -> ECM [Export]@@ -274,7 +279,8 @@ tcEnv <- getTyConsEnv case qualLookupTypeInfoUnique m tc tcEnv of [] -> expandThing' tc Nothing- [t] -> expandThing' tc (Just [ExportTypeWith (origName t @> tc) []])+ [t] -> expandThing' tc+ (Just [ExportTypeWith NoSpanInfo (origName t @> tc) []]) err -> internalError $ currentModuleName ++ ".expandThing: " ++ show err -- |Expand export of data cons / function@@ -283,8 +289,10 @@ m <- getModuleIdent tyEnv <- getValueEnv case qualLookupValueUnique m f tyEnv of- [Value f' _ _ _] -> return $ Export (f' @> f) : fromMaybe [] tcExport- _ -> return $ fromMaybe [] tcExport+ [Value f' _ _ _]+ -> return $ Export NoSpanInfo (f' @> f) : fromMaybe [] tcExport+ _+ -> return $ fromMaybe [] tcExport -- |Expand type constructor with explicit data constructors and record labels expandTypeWith :: QualIdent -> [Ident] -> ECM [Export]@@ -292,7 +300,7 @@ m <- getModuleIdent tcEnv <- getTyConsEnv case qualLookupTypeInfoUnique m tc tcEnv of- [t] -> return [ExportTypeWith (origName t @> tc) $ nub xs]+ [t] -> return [ExportTypeWith NoSpanInfo (origName t @> tc) $ nub xs] err -> internalError $ currentModuleName ++ ".expandTypeWith: " ++ show err -- |Expand type constructor with all data constructors and record labels@@ -318,8 +326,10 @@ tyEnv <- getValueEnv return $ [ exportType t | (_, t) <- localBindings tcEnv ]- ++ [ Export f' | (f, Value f' _ _ _) <- localBindings tyEnv, hasGlobalScope f ]- ++ [ Export l' | (l, Label l' _ _) <- localBindings tyEnv, hasGlobalScope l ]+ ++ [ Export NoSpanInfo f'+ | (f, Value f' _ _ _) <- localBindings tyEnv, hasGlobalScope f ]+ ++ [ Export NoSpanInfo l'+ | (l, Label l' _ _) <- localBindings tyEnv, hasGlobalScope l ] -- |Expand a module export expandImportedModule :: ModuleIdent -> ECM [Export]@@ -327,11 +337,11 @@ tcEnv <- getTyConsEnv tyEnv <- getValueEnv return $ [exportType t | (_, t) <- moduleImports m tcEnv]- ++ [Export f | (_, Value f _ _ _) <- moduleImports m tyEnv]- ++ [Export l | (_, Label l _ _) <- moduleImports m tyEnv]+ ++ [Export NoSpanInfo f | (_, Value f _ _ _) <- moduleImports m tyEnv]+ ++ [Export NoSpanInfo l | (_, Label l _ _) <- moduleImports m tyEnv] exportType :: TypeInfo -> Export-exportType t = ExportTypeWith tc xs+exportType t = ExportTypeWith NoSpanInfo tc xs where tc = origName t xs = elements t @@ -353,21 +363,23 @@ canonExports tcEnv es = map (canonExport (canonLabels tcEnv es)) es canonExport :: Map.Map QualIdent Export -> Export -> Export-canonExport ls (Export x) = fromMaybe (Export x) (Map.lookup x ls)-canonExport _ (ExportTypeWith tc xs) = ExportTypeWith tc xs-canonExport _ e = internalError $+canonExport ls (Export spi x) =+ fromMaybe (Export spi x) (Map.lookup x ls)+canonExport _ (ExportTypeWith spi tc xs) = ExportTypeWith spi tc xs+canonExport _ e = internalError $ currentModuleName ++ ".canonExport: " ++ show e canonLabels :: TCEnv -> [Export] -> Map.Map QualIdent Export canonLabels tcEnv es = foldr bindLabels Map.empty (allEntities tcEnv) where- tcs = [tc | ExportTypeWith tc _ <- es]+ tcs = [tc | ExportTypeWith _ tc _ <- es] bindLabels t ls | tc' `elem` tcs = foldr (bindLabel tc') ls (elements t) | otherwise = ls where tc' = origName t- bindLabel tc x = Map.insert (qualifyLike tc x) (ExportTypeWith tc [x])+ bindLabel tc x =+ Map.insert (qualifyLike tc x) (ExportTypeWith NoSpanInfo tc [x]) -- The expanded list of exported entities may contain duplicates. These -- are removed by the function joinExports. In particular, this@@ -375,21 +387,21 @@ -- which are also exported along with their types. joinExports :: [Export] -> [Export]-joinExports es = [ExportTypeWith tc cs | (tc, cs) <- joinedTypes]- ++ [Export f | f <- joinedFuncs]+joinExports es = [ExportTypeWith NoSpanInfo tc cs | (tc, cs) <- joinedTypes]+ ++ [Export NoSpanInfo f | f <- joinedFuncs] where joinedTypes = Map.toList $ foldr joinType Map.empty es joinedFuncs = Set.toList $ foldr joinFun Set.empty es joinType :: Export -> Map.Map QualIdent [Ident] -> Map.Map QualIdent [Ident]-joinType (Export _) tcs = tcs-joinType (ExportTypeWith tc cs) tcs = Map.insertWith union tc cs tcs-joinType export _ = internalError $+joinType (Export _ _) tcs = tcs+joinType (ExportTypeWith _ tc cs) tcs = Map.insertWith union tc cs tcs+joinType export _ = internalError $ currentModuleName ++ ".joinType: " ++ show export joinFun :: Export -> Set.Set QualIdent -> Set.Set QualIdent-joinFun (Export f) fs = f `Set.insert` fs-joinFun (ExportTypeWith _ _) fs = fs-joinFun export _ = internalError $+joinFun (Export _ f) fs = f `Set.insert` fs+joinFun (ExportTypeWith _ _ _) fs = fs+joinFun export _ = internalError $ currentModuleName ++ ".joinFun: " ++ show export -- ---------------------------------------------------------------------------@@ -444,7 +456,7 @@ errMultiple what (i:is) = posMessage i $ text "Multiple exports of" <+> text what <+> text (escName i) <+> text "at:" $+$ nest 2 (vcat (map showPos (i:is)))- where showPos = text . showLine . idPosition+ where showPos = text . showLine . getPosition errNonDataTypeOrTypeClass :: QualIdent -> Message errNonDataTypeOrTypeClass tc = posMessage tc $ hsep $ map text
src/Checks/ExtensionCheck.hs view
@@ -50,10 +50,10 @@ -- The extension check iterates over all given pragmas in the module and -- gathers all extensions mentioned in a language pragma. An error is reported--- if an extension is unkown.+-- if an extension is unknown. checkModule :: Module a -> EXCM ()-checkModule (Module ps _ _ _ _) = mapM_ checkPragma ps+checkModule (Module _ ps _ _ _ _) = mapM_ checkPragma ps checkPragma :: ModulePragma -> EXCM () checkPragma (LanguagePragma _ exts) = mapM_ checkExtension exts
src/Checks/ImportSyntaxCheck.hs view
@@ -22,6 +22,7 @@ import Curry.Base.Ident import Curry.Base.Pretty+import Curry.Base.SpanInfo import Curry.Syntax hiding (Var (..)) import Base.Messages@@ -174,26 +175,26 @@ expandSpecs (Just (Hiding p is)) = (Just . Hiding p . concat) `liftM` mapM expandHiding is expandImport :: Import -> ExpandM [Import]-expandImport (Import x) = expandThing x-expandImport (ImportTypeWith tc cs) = (:[]) `liftM` expandTypeWith tc cs-expandImport (ImportTypeAll tc) = (:[]) `liftM` expandTypeAll tc+expandImport (Import spi x ) = expandThing spi x+expandImport (ImportTypeWith spi tc cs) = (:[]) `liftM` expandTypeWith spi tc cs+expandImport (ImportTypeAll spi tc ) = (:[]) `liftM` expandTypeAll spi tc expandHiding :: Import -> ExpandM [Import]-expandHiding (Import x) = expandHide x-expandHiding (ImportTypeWith tc cs) = (:[]) `liftM` expandTypeWith tc cs-expandHiding (ImportTypeAll tc) = (:[]) `liftM` expandTypeAll tc+expandHiding (Import spi x ) = expandHide spi x+expandHiding (ImportTypeWith spi tc cs) = (:[]) `liftM` expandTypeWith spi tc cs+expandHiding (ImportTypeAll spi tc ) = (:[]) `liftM` expandTypeAll spi tc -- try to expand as type constructor-expandThing :: Ident -> ExpandM [Import]-expandThing tc = do+expandThing :: SpanInfo -> Ident -> ExpandM [Import]+expandThing spi tc = do tcEnv <- getTyConsEnv case Map.lookup tc tcEnv of- Just _ -> expandThing' tc $ Just [ImportTypeWith tc []]- Nothing -> expandThing' tc Nothing+ Just _ -> expandThing' spi tc $ Just [ImportTypeWith spi tc []]+ Nothing -> expandThing' spi tc Nothing -- try to expand as function / data constructor-expandThing' :: Ident -> Maybe [Import] -> ExpandM [Import]-expandThing' f tcImport = do+expandThing' :: SpanInfo -> Ident -> Maybe [Import] -> ExpandM [Import]+expandThing' spi f tcImport = do m <- getModuleIdent tyEnv <- getValueEnv expand m f (Map.lookup f tyEnv) tcImport@@ -206,35 +207,35 @@ | isConstr v = case maybeTc of Nothing -> report (errImportDataConstr m e) >> return [] Just tc -> return tc- | otherwise = return [Import e]+ | otherwise = return [Import spi e] isConstr (Constr _) = True isConstr (Var _ _) = False -- try to hide as type constructor-expandHide :: Ident -> ExpandM [Import]-expandHide tc = do+expandHide :: SpanInfo -> Ident -> ExpandM [Import]+expandHide spi tc = do tcEnv <- getTyConsEnv case Map.lookup tc tcEnv of- Just _ -> expandHide' tc $ Just [ImportTypeWith tc []]- Nothing -> expandHide' tc Nothing+ Just _ -> expandHide' spi tc $ Just [ImportTypeWith spi tc []]+ Nothing -> expandHide' spi tc Nothing -- try to hide as function / data constructor-expandHide' :: Ident -> Maybe [Import] -> ExpandM [Import]-expandHide' f tcImport = do+expandHide' :: SpanInfo -> Ident -> Maybe [Import] -> ExpandM [Import]+expandHide' spi f tcImport = do m <- getModuleIdent tyEnv <- getValueEnv case Map.lookup f tyEnv of- Just _ -> return $ Import f : fromMaybe [] tcImport+ Just _ -> return $ Import spi f : fromMaybe [] tcImport Nothing -> case tcImport of Nothing -> report (errUndefinedEntity m f) >> return [] Just tc -> return tc -expandTypeWith :: Ident -> [Ident] -> ExpandM Import-expandTypeWith tc cs = do+expandTypeWith :: SpanInfo -> Ident -> [Ident] -> ExpandM Import+expandTypeWith spi tc cs = do m <- getModuleIdent tcEnv <- getTyConsEnv- ImportTypeWith tc `liftM` case Map.lookup tc tcEnv of+ ImportTypeWith spi tc `liftM` case Map.lookup tc tcEnv of Just (Data _ xs) -> mapM (checkElement errUndefinedElement xs) cs Just (Class _ xs) -> mapM (checkElement errUndefinedMethod xs) cs Just (Alias _) -> report (errNonDataTypeOrTypeClass tc) >> return []@@ -245,11 +246,11 @@ unless (c `elem` cs') $ report $ err tc c return c -expandTypeAll :: Ident -> ExpandM Import-expandTypeAll tc = do+expandTypeAll :: SpanInfo -> Ident -> ExpandM Import+expandTypeAll spi tc = do m <- getModuleIdent tcEnv <- getTyConsEnv- ImportTypeWith tc `liftM` case Map.lookup tc tcEnv of+ ImportTypeWith spi tc `liftM` case Map.lookup tc tcEnv of Just (Data _ xs) -> return xs Just (Class _ xs) -> return xs Just (Alias _) -> report (errNonDataTypeOrTypeClass tc) >> return []
src/Checks/InstanceCheck.hs view
@@ -28,6 +28,7 @@ import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty+import Curry.Base.SpanInfo import Curry.Syntax hiding (impls) import Curry.Syntax.Pretty @@ -108,7 +109,8 @@ bindInstance :: TCEnv -> ClassEnv -> Decl a -> INCM () bindInstance tcEnv clsEnv (InstanceDecl _ cx qcls inst ds) = do m <- getModuleIdent- let PredType ps _ = expandPolyType m tcEnv clsEnv $ QualTypeExpr cx inst+ let PredType ps _ = expandPolyType m tcEnv clsEnv $+ QualTypeExpr NoSpanInfo cx inst modifyInstEnv $ bindInstInfo (genInstIdent m tcEnv qcls inst) (m, ps, impls [] ds) where impls is [] = is@@ -149,15 +151,16 @@ declDeriveInfo _ _ _ = internalError "InstanceCheck.declDeriveInfo: no data or newtype declaration" -mkDeriveInfo :: TCEnv -> ClassEnv -> Position -> Ident -> [Ident] -> Context+mkDeriveInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident] -> Context -> [TypeExpr] -> [QualIdent] -> INCM DeriveInfo-mkDeriveInfo tcEnv clsEnv p tc tvs cx tys clss = do+mkDeriveInfo tcEnv clsEnv spi tc tvs cx tys clss = do m <- getModuleIdent let otc = qualifyWith m tc oclss = map (flip (getOrigName m) tcEnv) clss PredType ps ty = expandConstrType m tcEnv clsEnv otc tvs cx tys (tys', ty') = arrowUnapply ty return $ DeriveInfo p otc (PredType ps ty') tys' $ sortClasses clsEnv oclss+ where p = spanInfo2Pos spi sortClasses :: ClassEnv -> [QualIdent] -> [QualIdent] sortClasses clsEnv clss = map fst $ sortBy compareDepth $ map adjoinDepth clss@@ -248,9 +251,10 @@ -- satisfied by cx. checkInstance :: TCEnv -> ClassEnv -> Decl a -> INCM ()-checkInstance tcEnv clsEnv (InstanceDecl p cx cls inst _) = do+checkInstance tcEnv clsEnv (InstanceDecl spi cx cls inst _) = do m <- getModuleIdent- let PredType ps ty = expandPolyType m tcEnv clsEnv $ QualTypeExpr cx inst+ let PredType ps ty = expandPolyType m tcEnv clsEnv $+ QualTypeExpr NoSpanInfo cx inst ocls = getOrigName m cls tcEnv ps' = Set.fromList [ Pred scls ty | scls <- superClasses ocls clsEnv ] doc = ppPred m $ Pred cls ty@@ -258,6 +262,7 @@ ps'' <- reducePredSet p what doc clsEnv ps' Set.mapM_ (report . errMissingInstance m p what doc) $ ps'' `Set.difference` (maxPredSet clsEnv ps)+ where p = spanInfo2Pos spi checkInstance _ _ _ = ok -- All types specified in the optional default declaration of a module@@ -267,13 +272,14 @@ checkDefault :: TCEnv -> ClassEnv -> Decl a -> INCM () checkDefault tcEnv clsEnv (DefaultDecl p tys) =- mapM_ (checkDefaultType p tcEnv clsEnv) tys+ mapM_ (checkDefaultType (spanInfo2Pos p) tcEnv clsEnv) tys checkDefault _ _ _ = ok checkDefaultType :: Position -> TCEnv -> ClassEnv -> TypeExpr -> INCM () checkDefaultType p tcEnv clsEnv ty = do m <- getModuleIdent- let PredType _ ty' = expandPolyType m tcEnv clsEnv $ QualTypeExpr [] ty+ let PredType _ ty' = expandPolyType m tcEnv clsEnv $+ QualTypeExpr NoSpanInfo [] ty ps <- reducePredSet p what empty clsEnv (Set.singleton $ Pred qNumId ty') Set.mapM_ (report . errMissingInstance m p what empty) ps where what = "default declaration"@@ -312,9 +318,11 @@ genInstIdents :: ModuleIdent -> TCEnv -> Decl a -> [InstIdent] genInstIdents m tcEnv (DataDecl _ tc _ _ qclss) =- map (flip (genInstIdent m tcEnv) $ ConstructorType $ qualify tc) qclss+ map (flip (genInstIdent m tcEnv) $ ConstructorType NoSpanInfo $ qualify tc)+ qclss genInstIdents m tcEnv (NewtypeDecl _ tc _ _ qclss) =- map (flip (genInstIdent m tcEnv) $ ConstructorType $ qualify tc) qclss+ map (flip (genInstIdent m tcEnv) $ ConstructorType NoSpanInfo $ qualify tc)+ qclss genInstIdents m tcEnv (InstanceDecl _ _ qcls ty _) = [genInstIdent m tcEnv qcls ty] genInstIdents _ _ _ = []
src/Checks/InterfaceCheck.hs view
@@ -55,6 +55,7 @@ import Curry.Base.Ident import Curry.Base.Position+import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax @@ -150,20 +151,20 @@ checkImport (IFunctionDecl p f (Just tv) n ty) = do m <- getModuleIdent let check (Value f' cm' n' (ForAll _ ty')) =- f == f' && True == cm' && n' == n && toQualPredType m [tv] ty == ty'+ f == f' && cm' && n' == n && toQualPredType m [tv] ty == ty' check _ = False checkValueInfo "method" check p f checkImport (IFunctionDecl p f Nothing n ty) = do m <- getModuleIdent let check (Value f' cm' n' (ForAll _ ty')) =- f == f' && False == cm' && n' == n && toQualPredType m [] ty == ty'+ f == f' && not cm' && n' == n && toQualPredType m [] ty == ty' check _ = False checkValueInfo "function" check p f checkImport (HidingClassDecl p cx cls k _) = do clsEnv <- getClassEnv let check (TypeClass cls' k' _) | cls == cls' && toKind' k 0 == k' &&- [cls'' | Constraint cls'' _ <- cx] == superClasses cls' clsEnv+ [cls'' | Constraint _ cls'' _ <- cx] == superClasses cls' clsEnv = Just ok check _ = Nothing checkTypeInfo "hidden type class" check p cls@@ -171,15 +172,15 @@ clsEnv <- getClassEnv let check (TypeClass cls' k' fs) | cls == cls' && toKind' k 0 == k' &&- [cls'' | Constraint cls'' _ <- cx] == superClasses cls' clsEnv &&+ [cls'' | Constraint _ cls'' _ <- cx] == superClasses cls' clsEnv && map (\m -> (imethod m, imethodArity m)) ms == map (\f -> (methodName f, methodArity f)) fs = Just $ mapM_ (checkMethodImport cls clsvar) ms check _ = Nothing checkTypeInfo "type class" check p cls-checkImport (IInstanceDecl p cx cls ty is m) = do+checkImport (IInstanceDecl p cx cls ty is m) = checkInstInfo check p (cls, typeConstr ty) m- where PredType ps _ = toPredType [] $ QualTypeExpr cx ty+ where PredType ps _ = toPredType [] $ QualTypeExpr NoSpanInfo cx ty check ps' is' = ps == ps' && sort is == sort is' checkConstrImport :: QualIdent -> [Ident] -> ConstrDecl -> IC ()@@ -231,7 +232,7 @@ checkValueInfo "method" check p qf where qf = qualifyLike qcls f check (Value f' cm' _ (ForAll _ pty)) =- qf == f' && cm' == True && toMethodType qcls clsvar qty == pty+ qf == f' && cm' && toMethodType qcls clsvar qty == pty check _ = False checkPrecInfo :: (PrecInfo -> Bool) -> Position -> QualIdent -> IC ()@@ -266,19 +267,21 @@ Nothing -> report $ errNoInstance p m i checkImported checkInfo (maybe qualify qualifyWith mm anonId) -checkValueInfo :: String -> (ValueInfo -> Bool) -> Position+checkValueInfo :: HasPosition a => String -> (ValueInfo -> Bool) -> a -> QualIdent -> IC () checkValueInfo what check p x = do tyEnv <- getValueEnv let checkInfo m x' = case qualLookupTopEnv x tyEnv of- [] -> report $ errNotExported p what m x'- [vi] -> unless (check vi) (report $ errImportConflict p what m x')+ [] -> report $ errNotExported p' what m x'+ [vi] -> unless (check vi)+ (report $ errImportConflict p' what m x') _ -> internalError "checkValueInfo" checkImported checkInfo x+ where p' = getPosition p checkImported :: (ModuleIdent -> Ident -> IC ()) -> QualIdent -> IC ()-checkImported _ (QualIdent Nothing _) = ok-checkImported f (QualIdent (Just m) x) = f m x+checkImported _ (QualIdent _ Nothing _) = ok+checkImported f (QualIdent _ (Just m) x) = f m x -- --------------------------------------------------------------------------- -- Error messages
src/Checks/InterfaceSyntaxCheck.hs view
@@ -38,6 +38,7 @@ import Curry.Base.Ident import Curry.Base.Position+import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax import Curry.Syntax.Pretty@@ -121,7 +122,7 @@ return $ IClassDecl p cx' qcls k clsvar ms' hs checkIDecl (IInstanceDecl p cx qcls inst is m) = do checkClass qcls- QualTypeExpr cx' inst' <- checkQualType $ QualTypeExpr cx inst+ QualTypeExpr _ cx' inst' <- checkQualType $ QualTypeExpr NoSpanInfo cx inst checkSimpleContext cx' checkInstanceType p inst' mapM_ (report . errMultipleImplementation . head) $ findMultiples $ map fst is@@ -183,14 +184,14 @@ checkSimpleContext = mapM_ checkSimpleConstraint checkSimpleConstraint :: Constraint -> ISC ()-checkSimpleConstraint c@(Constraint _ ty) =+checkSimpleConstraint c@(Constraint _ _ ty) = unless (isVariableType ty) $ report $ errIllegalSimpleConstraint c checkIMethodDecl :: Ident -> IMethodDecl -> ISC IMethodDecl checkIMethodDecl tv (IMethodDecl p f a qty) = do qty' <- checkQualType qty unless (tv `elem` fv qty') $ report $ errAmbiguousType p tv- let QualTypeExpr cx _ = qty'+ let QualTypeExpr _ cx _ = qty' when (tv `elem` fv cx) $ report $ errConstrainedClassVariable p tv return $ IMethodDecl p f a qty' @@ -204,24 +205,24 @@ report $ errIllegalInstanceType p inst checkQualType :: QualTypeExpr -> ISC QualTypeExpr-checkQualType (QualTypeExpr cx ty) = do+checkQualType (QualTypeExpr spi cx ty) = do ty' <- checkType ty cx' <- checkClosedContext (fv ty') cx- return $ QualTypeExpr cx' ty'+ return $ QualTypeExpr spi cx' ty' checkClosedContext :: [Ident] -> Context -> ISC Context checkClosedContext tvs cx = do cx' <- checkContext cx- mapM_ (\(Constraint _ ty) -> checkClosed tvs ty) cx'+ mapM_ (\(Constraint _ _ ty) -> checkClosed tvs ty) cx' return cx' checkContext :: Context -> ISC Context checkContext = mapM checkConstraint checkConstraint :: Constraint -> ISC Constraint-checkConstraint (Constraint qcls ty) = do+checkConstraint (Constraint spi qcls ty) = do checkClass qcls- Constraint qcls `liftM` checkType ty+ Constraint spi qcls `liftM` checkType ty checkClass :: QualIdent -> ISC () checkClass qcls = do@@ -240,38 +241,41 @@ return ty' checkType :: TypeExpr -> ISC TypeExpr-checkType (ConstructorType tc) = checkTypeConstructor tc-checkType (ApplyType ty1 ty2) = liftM2 ApplyType (checkType ty1) (checkType ty2)-checkType (VariableType tv) = checkType $ ConstructorType (qualify tv)-checkType (TupleType tys) = liftM TupleType (mapM checkType tys)-checkType (ListType ty) = liftM ListType (checkType ty)-checkType (ArrowType ty1 ty2) = liftM2 ArrowType (checkType ty1) (checkType ty2)-checkType (ParenType ty) = liftM ParenType (checkType ty)-checkType (ForallType vs ty) = liftM (ForallType vs) (checkType ty)+checkType (ConstructorType spi tc) = checkTypeConstructor spi tc+checkType (ApplyType spi ty1 ty2) =+ liftM2 (ApplyType spi) (checkType ty1) (checkType ty2)+checkType (VariableType spi tv) =+ checkType $ ConstructorType spi (qualify tv)+checkType (TupleType spi tys) = liftM (TupleType spi) (mapM checkType tys)+checkType (ListType spi ty) = liftM (ListType spi) (checkType ty)+checkType (ArrowType spi ty1 ty2) =+ liftM2 (ArrowType spi) (checkType ty1) (checkType ty2)+checkType (ParenType spi ty) = liftM (ParenType spi) (checkType ty)+checkType (ForallType spi vs ty) = liftM (ForallType spi vs) (checkType ty) checkClosed :: [Ident] -> TypeExpr -> ISC ()-checkClosed _ (ConstructorType _) = return ()-checkClosed tvs (ApplyType ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2]-checkClosed tvs (VariableType tv) =+checkClosed _ (ConstructorType _ _) = return ()+checkClosed tvs (ApplyType _ ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2]+checkClosed tvs (VariableType _ tv) = when (isAnonId tv || tv `notElem` tvs) $ report $ errUnboundVariable tv-checkClosed tvs (TupleType tys) = mapM_ (checkClosed tvs) tys-checkClosed tvs (ListType ty) = checkClosed tvs ty-checkClosed tvs (ArrowType ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2]-checkClosed tvs (ParenType ty) = checkClosed tvs ty-checkClosed tvs (ForallType vs ty) = checkClosed (tvs ++ vs) ty+checkClosed tvs (TupleType _ tys) = mapM_ (checkClosed tvs) tys+checkClosed tvs (ListType _ ty) = checkClosed tvs ty+checkClosed tvs (ArrowType _ ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2]+checkClosed tvs (ParenType _ ty) = checkClosed tvs ty+checkClosed tvs (ForallType _ vs ty) = checkClosed (tvs ++ vs) ty -checkTypeConstructor :: QualIdent -> ISC TypeExpr-checkTypeConstructor tc = do+checkTypeConstructor :: SpanInfo -> QualIdent -> ISC TypeExpr+checkTypeConstructor spi tc = do tyEnv <- getTypeEnv case qualLookupTypeKind tc tyEnv of- [] | not (isQualified tc) -> return $ VariableType $ unqualify tc+ [] | not (isQualified tc) -> return $ VariableType spi $ unqualify tc | otherwise -> do report $ errUndefinedType tc- return $ ConstructorType tc- [Data _ _] -> return $ ConstructorType tc+ return $ ConstructorType spi tc+ [Data _ _] -> return $ ConstructorType spi tc [Alias _] -> do report $ errBadTypeSynonym tc- return $ ConstructorType tc+ return $ ConstructorType spi tc _ -> internalError "Checks.InterfaceSyntaxCheck.checkTypeConstructor" @@ -280,14 +284,14 @@ -- --------------------------------------------------------------------------- typeVars :: TypeExpr -> [Ident]-typeVars (ConstructorType _) = []-typeVars (ApplyType ty1 ty2) = typeVars ty1 ++ typeVars ty2-typeVars (VariableType tv) = [tv]-typeVars (TupleType tys) = concatMap typeVars tys-typeVars (ListType ty) = typeVars ty-typeVars (ArrowType ty1 ty2) = typeVars ty1 ++ typeVars ty2-typeVars (ParenType ty) = typeVars ty-typeVars (ForallType vs ty) = vs ++ typeVars ty+typeVars (ConstructorType _ _) = []+typeVars (ApplyType _ ty1 ty2) = typeVars ty1 ++ typeVars ty2+typeVars (VariableType _ tv) = [tv]+typeVars (TupleType _ tys) = concatMap typeVars tys+typeVars (ListType _ ty) = typeVars ty+typeVars (ArrowType _ ty1 ty2) = typeVars ty1 ++ typeVars ty2+typeVars (ParenType _ ty) = typeVars ty+typeVars (ForallType _ vs ty) = vs ++ typeVars ty isTypeSyn :: QualIdent -> TypeEnv -> Bool isTypeSyn tc tEnv = case qualLookupTypeKind tc tEnv of@@ -341,7 +345,7 @@ [ "Hidden", what, escName x, "is not defined for", for, qualName tc ] errIllegalSimpleConstraint :: Constraint -> Message-errIllegalSimpleConstraint c@(Constraint qcls _) = posMessage qcls $ vcat+errIllegalSimpleConstraint c@(Constraint _ qcls _) = posMessage qcls $ vcat [ text "Illegal class constraint" <+> ppConstraint c , text "Constraints in class and instance declarations must be of" , text "the form C u, where C is a type class and u is a type variable."
src/Checks/KindCheck.hs view
@@ -16,6 +16,10 @@ {-# LANGUAGE CPP #-} module Checks.KindCheck (kindCheck) where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif@@ -26,6 +30,7 @@ import Curry.Base.Ident import Curry.Base.Position+import Curry.Base.SpanInfo () import Curry.Base.Pretty import Curry.Syntax import Curry.Syntax.Pretty@@ -53,7 +58,7 @@ -- synonyms into the type constructor environment. kindCheck :: TCEnv -> ClassEnv -> Module a -> ((TCEnv, ClassEnv), [Message])-kindCheck tcEnv clsEnv (Module _ m _ _ ds) = runKCM check initState+kindCheck tcEnv clsEnv (Module _ _ m _ _ ds) = runKCM check initState where check = do checkNonRecursiveTypes tds &&> checkAcyclicSuperClasses cds@@ -84,7 +89,7 @@ (&&>) :: KCM () -> KCM () -> KCM () pre &&> suf = do errs <- pre >> S.gets errors- if null errs then suf else return ()+ when (null errs) suf runKCM :: KCM a -> KCState -> (a, [Message]) runKCM kcm s = let (a, s') = S.runState kcm s in (a, reverse $ errors s')@@ -162,61 +167,61 @@ fts m (NewRecordDecl _ _ (_, ty)) = fts m ty instance HasType Constraint where- fts m (Constraint qcls _) = fts m qcls+ fts m (Constraint _ qcls _) = fts m qcls instance HasType QualTypeExpr where- fts m (QualTypeExpr cx ty) = fts m cx . fts m ty+ fts m (QualTypeExpr _ cx ty) = fts m cx . fts m ty instance HasType TypeExpr where- fts m (ConstructorType tc) = fts m tc- fts m (ApplyType ty1 ty2) = fts m ty1 . fts m ty2- fts _ (VariableType _) = id- fts m (TupleType tys) = (tupleId (length tys) :) . fts m tys- fts m (ListType ty) = (listId :) . fts m ty- fts m (ArrowType ty1 ty2) = (arrowId :) . fts m ty1 . fts m ty2- fts m (ParenType ty) = fts m ty- fts m (ForallType _ ty) = fts m ty+ fts m (ConstructorType _ tc) = fts m tc+ fts m (ApplyType _ ty1 ty2) = fts m ty1 . fts m ty2+ fts _ (VariableType _ _) = id+ fts m (TupleType _ tys) = (tupleId (length tys) :) . fts m tys+ fts m (ListType _ ty) = (listId :) . fts m ty+ fts m (ArrowType _ ty1 ty2) = (arrowId :) . fts m ty1 . fts m ty2+ fts m (ParenType _ ty) = fts m ty+ fts m (ForallType _ _ ty) = fts m ty instance HasType (Equation a) where fts m (Equation _ _ rhs) = fts m rhs instance HasType (Rhs a) where- fts m (SimpleRhs _ e ds) = fts m e . fts m ds- fts m (GuardedRhs es ds) = fts m es . fts m ds+ fts m (SimpleRhs _ e ds) = fts m e . fts m ds+ fts m (GuardedRhs _ es ds) = fts m es . fts m ds instance HasType (CondExpr a) where fts m (CondExpr _ g e) = fts m g . fts m e instance HasType (Expression a) where- fts _ (Literal _ _) = id- fts _ (Variable _ _) = id- fts _ (Constructor _ _) = id- fts m (Paren e) = fts m e- fts m (Typed e ty) = fts m e . fts m ty- fts m (Record _ _ fs) = fts m fs- fts m (RecordUpdate e fs) = fts m e . fts m fs- fts m (Tuple es) = fts m es- fts m (List _ es) = fts m es- fts m (ListCompr e stms) = fts m e . fts m stms- fts m (EnumFrom e) = fts m e- fts m (EnumFromThen e1 e2) = fts m e1 . fts m e2- fts m (EnumFromTo e1 e2) = fts m e1 . fts m e2- fts m (EnumFromThenTo e1 e2 e3) = fts m e1 . fts m e2 . fts m e3- fts m (UnaryMinus e) = fts m e- fts m (Apply e1 e2) = fts m e1 . fts m e2- fts m (InfixApply e1 _ e2) = fts m e1 . fts m e2- fts m (LeftSection e _) = fts m e- fts m (RightSection _ e) = fts m e- fts m (Lambda _ e) = fts m e- fts m (Let ds e) = fts m ds . fts m e- fts m (Do stms e) = fts m stms . fts m e- fts m (IfThenElse e1 e2 e3) = fts m e1 . fts m e2 . fts m e3- fts m (Case _ e as) = fts m e . fts m as+ fts _ (Literal _ _ _) = id+ fts _ (Variable _ _ _) = id+ fts _ (Constructor _ _ _) = id+ fts m (Paren _ e) = fts m e+ fts m (Typed _ e ty) = fts m e . fts m ty+ fts m (Record _ _ _ fs) = fts m fs+ fts m (RecordUpdate _ e fs) = fts m e . fts m fs+ fts m (Tuple _ es) = fts m es+ fts m (List _ _ es) = fts m es+ fts m (ListCompr _ e stms) = fts m e . fts m stms+ fts m (EnumFrom _ e) = fts m e+ fts m (EnumFromThen _ e1 e2) = fts m e1 . fts m e2+ fts m (EnumFromTo _ e1 e2) = fts m e1 . fts m e2+ fts m (EnumFromThenTo _ e1 e2 e3) = fts m e1 . fts m e2 . fts m e3+ fts m (UnaryMinus _ e) = fts m e+ fts m (Apply _ e1 e2) = fts m e1 . fts m e2+ fts m (InfixApply _ e1 _ e2) = fts m e1 . fts m e2+ fts m (LeftSection _ e _) = fts m e+ fts m (RightSection _ _ e) = fts m e+ fts m (Lambda _ _ e) = fts m e+ fts m (Let _ ds e) = fts m ds . fts m e+ fts m (Do _ stms e) = fts m stms . fts m e+ fts m (IfThenElse _ e1 e2 e3) = fts m e1 . fts m e2 . fts m e3+ fts m (Case _ _ e as) = fts m e . fts m as instance HasType (Statement a) where- fts m (StmtExpr e) = fts m e- fts m (StmtDecl ds) = fts m ds- fts m (StmtBind _ e) = fts m e+ fts m (StmtExpr _ e) = fts m e+ fts m (StmtDecl _ ds) = fts m ds+ fts m (StmtBind _ _ e) = fts m e instance HasType (Alt a) where fts m (Alt _ _ rhs) = fts m rhs@@ -267,7 +272,7 @@ fc :: ModuleIdent -> Context -> [Ident] fc m = foldr fc' [] where- fc' (Constraint qcls _) = maybe id (:) (localIdent m qcls)+ fc' (Constraint _ qcls _) = maybe id (:) (localIdent m qcls) checkAcyclicSuperClasses :: [Decl a] -> KCM () checkAcyclicSuperClasses ds = do@@ -306,7 +311,7 @@ -- from the 'MonadFix' type class. bindKind :: ModuleIdent -> TCEnv -> ClassEnv -> TCEnv -> Decl a -> KCM TCEnv-bindKind m tcEnv' clsEnv tcEnv (DataDecl _ tc tvs cs _) = do+bindKind m tcEnv' clsEnv tcEnv (DataDecl _ tc tvs cs _) = bindTypeConstructor DataType tc tvs (Just KindStar) (map mkData cs) tcEnv where mkData (ConstrDecl _ evs cx c tys) = mkData' evs cx c tys@@ -325,7 +330,7 @@ tvs' = tvs ++ evs PredType ps ty = expandConstrType m tcEnv' clsEnv qtc tvs' cx tys tys' = arrowArgs ty-bindKind _ _ _ tcEnv (ExternalDataDecl _ tc tvs) = do+bindKind _ _ _ tcEnv (ExternalDataDecl _ tc tvs) = bindTypeConstructor DataType tc tvs (Just KindStar) [] tcEnv bindKind m tcEnv' _ tcEnv (NewtypeDecl _ tc tvs nc _) = bindTypeConstructor RenamingType tc tvs (Just KindStar) (mkData nc) tcEnv@@ -392,7 +397,7 @@ where qcls = qualifyWith m cls ms = map (\f -> (f, f `elem` fs)) $ concatMap methods ds fs = concatMap impls ds- sclss = nub $ map (\(Constraint cls' _) -> getOrigName m cls' tcEnv) cx+ sclss = nub $ map (\(Constraint _ cls' _) -> getOrigName m cls' tcEnv) cx bindClass _ _ clsEnv _ = clsEnv instantiateWithDefaultKind :: TypeInfo -> TypeInfo@@ -503,88 +508,88 @@ kcRhs tcEnv (SimpleRhs p e ds) = do kcExpr tcEnv p e mapM_ (kcDecl tcEnv) ds-kcRhs tcEnv (GuardedRhs es ds) = do+kcRhs tcEnv (GuardedRhs _ es ds) = do mapM_ (kcCondExpr tcEnv) es mapM_ (kcDecl tcEnv) ds kcCondExpr :: TCEnv -> CondExpr a -> KCM () kcCondExpr tcEnv (CondExpr p g e) = kcExpr tcEnv p g >> kcExpr tcEnv p e -kcExpr :: TCEnv -> Position -> Expression a -> KCM ()-kcExpr _ _ (Literal _ _) = ok-kcExpr _ _ (Variable _ _) = ok-kcExpr _ _ (Constructor _ _) = ok-kcExpr tcEnv p (Paren e) = kcExpr tcEnv p e-kcExpr tcEnv p (Typed e qty) = do+kcExpr :: HasPosition p => TCEnv -> p -> Expression a -> KCM ()+kcExpr _ _ (Literal _ _ _) = ok+kcExpr _ _ (Variable _ _ _) = ok+kcExpr _ _ (Constructor _ _ _) = ok+kcExpr tcEnv p (Paren _ e) = kcExpr tcEnv p e+kcExpr tcEnv p (Typed _ e qty) = do kcExpr tcEnv p e kcTypeSig tcEnv p qty-kcExpr tcEnv p (Record _ _ fs) = mapM_ (kcField tcEnv p) fs-kcExpr tcEnv p (RecordUpdate e fs) = do+kcExpr tcEnv p (Record _ _ _ fs) = mapM_ (kcField tcEnv p) fs+kcExpr tcEnv p (RecordUpdate _ e fs) = do kcExpr tcEnv p e mapM_ (kcField tcEnv p) fs-kcExpr tcEnv p (Tuple es) = mapM_ (kcExpr tcEnv p) es-kcExpr tcEnv p (List _ es) = mapM_ (kcExpr tcEnv p) es-kcExpr tcEnv p (ListCompr e stms) = do+kcExpr tcEnv p (Tuple _ es) = mapM_ (kcExpr tcEnv p) es+kcExpr tcEnv p (List _ _ es) = mapM_ (kcExpr tcEnv p) es+kcExpr tcEnv p (ListCompr _ e stms) = do kcExpr tcEnv p e mapM_ (kcStmt tcEnv p) stms-kcExpr tcEnv p (EnumFrom e) = kcExpr tcEnv p e-kcExpr tcEnv p (EnumFromThen e1 e2) = do+kcExpr tcEnv p (EnumFrom _ e) = kcExpr tcEnv p e+kcExpr tcEnv p (EnumFromThen _ e1 e2) = do kcExpr tcEnv p e1 kcExpr tcEnv p e2-kcExpr tcEnv p (EnumFromTo e1 e2) = do+kcExpr tcEnv p (EnumFromTo _ e1 e2) = do kcExpr tcEnv p e1 kcExpr tcEnv p e2-kcExpr tcEnv p (EnumFromThenTo e1 e2 e3) = do+kcExpr tcEnv p (EnumFromThenTo _ e1 e2 e3) = do kcExpr tcEnv p e1 kcExpr tcEnv p e2 kcExpr tcEnv p e3-kcExpr tcEnv p (UnaryMinus e) = kcExpr tcEnv p e-kcExpr tcEnv p (Apply e1 e2) = do+kcExpr tcEnv p (UnaryMinus _ e) = kcExpr tcEnv p e+kcExpr tcEnv p (Apply _ e1 e2) = do kcExpr tcEnv p e1 kcExpr tcEnv p e2-kcExpr tcEnv p (InfixApply e1 _ e2) = do+kcExpr tcEnv p (InfixApply _ e1 _ e2) = do kcExpr tcEnv p e1 kcExpr tcEnv p e2-kcExpr tcEnv p (LeftSection e _) = kcExpr tcEnv p e-kcExpr tcEnv p (RightSection _ e) = kcExpr tcEnv p e-kcExpr tcEnv p (Lambda _ e) = kcExpr tcEnv p e-kcExpr tcEnv p (Let ds e) = do+kcExpr tcEnv p (LeftSection _ e _) = kcExpr tcEnv p e+kcExpr tcEnv p (RightSection _ _ e) = kcExpr tcEnv p e+kcExpr tcEnv p (Lambda _ _ e) = kcExpr tcEnv p e+kcExpr tcEnv p (Let _ ds e) = do mapM_ (kcDecl tcEnv) ds kcExpr tcEnv p e-kcExpr tcEnv p (Do stms e) = do+kcExpr tcEnv p (Do _ stms e) = do mapM_ (kcStmt tcEnv p) stms kcExpr tcEnv p e-kcExpr tcEnv p (IfThenElse e1 e2 e3) = do+kcExpr tcEnv p (IfThenElse _ e1 e2 e3) = do kcExpr tcEnv p e1 kcExpr tcEnv p e2 kcExpr tcEnv p e3-kcExpr tcEnv p (Case _ e alts) = do+kcExpr tcEnv p (Case _ _ e alts) = do kcExpr tcEnv p e mapM_ (kcAlt tcEnv) alts -kcStmt :: TCEnv -> Position -> Statement a -> KCM ()-kcStmt tcEnv p (StmtExpr e) = kcExpr tcEnv p e-kcStmt tcEnv _ (StmtDecl ds) = mapM_ (kcDecl tcEnv) ds-kcStmt tcEnv p (StmtBind _ e) = kcExpr tcEnv p e+kcStmt :: HasPosition p => TCEnv -> p -> Statement a -> KCM ()+kcStmt tcEnv p (StmtExpr _ e) = kcExpr tcEnv p e+kcStmt tcEnv _ (StmtDecl _ ds) = mapM_ (kcDecl tcEnv) ds+kcStmt tcEnv p (StmtBind _ _ e) = kcExpr tcEnv p e kcAlt :: TCEnv -> Alt a -> KCM () kcAlt tcEnv (Alt _ _ rhs) = kcRhs tcEnv rhs -kcField :: TCEnv -> Position -> Field (Expression a) -> KCM ()+kcField :: HasPosition p => TCEnv -> p -> Field (Expression a) -> KCM () kcField tcEnv p (Field _ _ e) = kcExpr tcEnv p e -kcContext :: TCEnv -> Position -> Context -> KCM ()+kcContext :: HasPosition p => TCEnv -> p -> Context -> KCM () kcContext tcEnv p = mapM_ (kcConstraint tcEnv p) -kcConstraint :: TCEnv -> Position -> Constraint -> KCM ()-kcConstraint tcEnv p sc@(Constraint qcls ty) = do+kcConstraint :: HasPosition p => TCEnv -> p -> Constraint -> KCM ()+kcConstraint tcEnv p sc@(Constraint _ qcls ty) = do m <- getModuleIdent kcType tcEnv p "class constraint" doc (clsKind m qcls tcEnv) ty where doc = ppConstraint sc -kcTypeSig :: TCEnv -> Position -> QualTypeExpr -> KCM ()-kcTypeSig tcEnv p (QualTypeExpr cx ty) = do+kcTypeSig :: HasPosition p => TCEnv -> p -> QualTypeExpr -> KCM ()+kcTypeSig tcEnv p (QualTypeExpr _ cx ty) = do tcEnv' <- foldM bindFreshKind tcEnv free kcContext tcEnv' p cx kcValueType tcEnv' p "type signature" doc ty@@ -592,18 +597,18 @@ free = filter (null . flip lookupTypeInfo tcEnv) $ nub $ fv ty doc = ppTypeExpr 0 ty -kcValueType :: TCEnv -> Position -> String -> Doc -> TypeExpr -> KCM ()+kcValueType :: HasPosition p => TCEnv -> p -> String -> Doc -> TypeExpr -> KCM () kcValueType tcEnv p what doc = kcType tcEnv p what doc KindStar -kcType :: TCEnv -> Position -> String -> Doc -> Kind -> TypeExpr -> KCM ()+kcType :: HasPosition p => TCEnv -> p -> String -> Doc -> Kind -> TypeExpr -> KCM () kcType tcEnv p what doc k ty = do k' <- kcTypeExpr tcEnv p "type expression" doc' 0 ty unify p what (doc $-$ text "Type:" <+> doc') k k' where doc' = ppTypeExpr 0 ty -kcTypeExpr :: TCEnv -> Position -> String -> Doc -> Int -> TypeExpr -> KCM Kind-kcTypeExpr tcEnv p _ _ n (ConstructorType tc) = do+kcTypeExpr :: HasPosition p => TCEnv -> p -> String -> Doc -> Int -> TypeExpr -> KCM Kind+kcTypeExpr tcEnv p _ _ n (ConstructorType _ tc) = do m <- getModuleIdent case qualLookupTypeInfo tc tcEnv of [AliasType _ _ n' _] -> case n >= n' of@@ -612,29 +617,29 @@ report $ errPartialAlias p tc n' n freshKindVar _ -> return $ tcKind m tc tcEnv-kcTypeExpr tcEnv p what doc n (ApplyType ty1 ty2) = do+kcTypeExpr tcEnv p what doc n (ApplyType _ ty1 ty2) = do (alpha, beta) <- kcTypeExpr tcEnv p what doc (n + 1) ty1 >>= kcArrow p what (doc $-$ text "Type:" <+> ppTypeExpr 0 ty1) kcTypeExpr tcEnv p what doc 0 ty2 >>= unify p what (doc $-$ text "Type:" <+> ppTypeExpr 0 ty2) alpha return beta-kcTypeExpr tcEnv _ _ _ _ (VariableType tv) = return (varKind tv tcEnv)-kcTypeExpr tcEnv p what doc _ (TupleType tys) = do+kcTypeExpr tcEnv _ _ _ _ (VariableType _ tv) = return (varKind tv tcEnv)+kcTypeExpr tcEnv p what doc _ (TupleType _ tys) = do mapM_ (kcValueType tcEnv p what doc) tys return KindStar-kcTypeExpr tcEnv p what doc _ (ListType ty) = do+kcTypeExpr tcEnv p what doc _ (ListType _ ty) = do kcValueType tcEnv p what doc ty return KindStar-kcTypeExpr tcEnv p what doc _ (ArrowType ty1 ty2) = do+kcTypeExpr tcEnv p what doc _ (ArrowType _ ty1 ty2) = do kcValueType tcEnv p what doc ty1 kcValueType tcEnv p what doc ty2 return KindStar-kcTypeExpr tcEnv p what doc n (ParenType ty) = kcTypeExpr tcEnv p what doc n ty-kcTypeExpr tcEnv p what doc n (ForallType vs ty) = do- tcEnv' <- foldM bindFreshKind tcEnv $ vs+kcTypeExpr tcEnv p what doc n (ParenType _ ty) = kcTypeExpr tcEnv p what doc n ty+kcTypeExpr tcEnv p what doc n (ForallType _ vs ty) = do+ tcEnv' <- foldM bindFreshKind tcEnv vs kcTypeExpr tcEnv' p what doc n ty -kcArrow :: Position -> String -> Doc -> Kind -> KCM (Kind, Kind)+kcArrow :: HasPosition p => p -> String -> Doc -> Kind -> KCM (Kind, Kind) kcArrow p what doc k = do theta <- getKindSubst case subst theta k of@@ -653,7 +658,7 @@ -- --------------------------------------------------------------------------- -- The unification uses Robinson's algorithm.-unify :: Position -> String -> Doc -> Kind -> Kind -> KCM ()+unify :: HasPosition p => p -> String -> Doc -> Kind -> Kind -> KCM () unify p what doc k1 k2 = do theta <- getKindSubst let k1' = subst theta k1@@ -723,7 +728,7 @@ types del [tc'] = del <> space <> text "and" <+> typePos tc' types _ (tc':tcs') = comma <+> typePos tc' <> types comma tcs' typePos tc' =- text (idName tc') <+> parens (text $ showLine $ idPosition tc')+ text (idName tc') <+> parens (text $ showLine $ getPosition tc') errRecursiveClasses :: [Ident] -> Message errRecursiveClasses [] = internalError@@ -738,16 +743,16 @@ classes del [cls'] = del <> space <> text "and" <+> classPos cls' classes _ (cls':clss') = comma <+> classPos cls' <> classes comma clss' classPos cls' =- text (idName cls') <+> parens (text $ showLine $ idPosition cls')+ text (idName cls') <+> parens (text $ showLine $ getPosition cls') -errNonArrowKind :: Position -> String -> Doc -> Kind -> Message+errNonArrowKind :: HasPosition p => p -> String -> Doc -> Kind -> Message errNonArrowKind p what doc k = posMessage p $ vcat [ text "Kind error in" <+> text what, doc , text "Kind:" <+> ppKind k , text "Cannot be applied" ] -errPartialAlias :: Position -> QualIdent -> Int -> Int -> Message+errPartialAlias :: HasPosition p => p -> QualIdent -> Int -> Int -> Message errPartialAlias p tc arity argc = posMessage p $ hsep [ text "Type synonym", ppQIdent tc , text "requires at least"@@ -757,7 +762,7 @@ where plural n x = if n == 1 then x else x ++ "s" -errKindMismatch :: Position -> String -> Doc -> Kind -> Kind -> Message+errKindMismatch :: HasPosition p => p -> String -> Doc -> Kind -> Kind -> Message errKindMismatch p what doc k1 k2 = posMessage p $ vcat [ text "Kind error in" <+> text what, doc , text "Inferred kind:" <+> ppKind k2
src/Checks/PrecCheck.hs view
@@ -31,6 +31,8 @@ import Curry.Base.Ident import Curry.Base.Position+import Curry.Base.SpanInfo+import Curry.Base.Span import Curry.Base.Pretty import Curry.Syntax @@ -145,95 +147,99 @@ Equation p <$> checkLhs lhs <*> checkRhs rhs checkLhs :: Lhs a -> PCM (Lhs a)-checkLhs (FunLhs f ts) = FunLhs f <$> mapM checkPattern ts-checkLhs (OpLhs t1 op t2) =- flip OpLhs op <$> (checkPattern t1 >>= checkOpL op)- <*> (checkPattern t2 >>= checkOpR op)-checkLhs (ApLhs lhs ts) =- ApLhs <$> checkLhs lhs <*> mapM checkPattern ts+checkLhs (FunLhs spi f ts) = FunLhs spi f <$> mapM checkPattern ts+checkLhs (OpLhs spi t1 op t2) =+ flip (OpLhs spi) op <$> (checkPattern t1 >>= checkOpL op)+ <*> (checkPattern t2 >>= checkOpR op)+checkLhs (ApLhs spi lhs ts) =+ ApLhs spi <$> checkLhs lhs <*> mapM checkPattern ts checkPattern :: Pattern a -> PCM (Pattern a)-checkPattern l@(LiteralPattern _ _) = return l-checkPattern n@(NegativePattern _ _) = return n-checkPattern v@(VariablePattern _ _) = return v-checkPattern (ConstructorPattern a c ts) =- ConstructorPattern a c <$> mapM checkPattern ts-checkPattern (InfixPattern a t1 op t2) = do+checkPattern l@(LiteralPattern _ _ _) = return l+checkPattern n@(NegativePattern _ _ _) = return n+checkPattern v@(VariablePattern _ _ _) = return v+checkPattern (ConstructorPattern spi a c ts) =+ ConstructorPattern spi a c <$> mapM checkPattern ts+checkPattern (InfixPattern _ a t1 op t2) = do t1' <- checkPattern t1 t2' <- checkPattern t2- fixPrecT (InfixPattern a) t1' op t2'-checkPattern (ParenPattern t) =- ParenPattern <$> checkPattern t-checkPattern (TuplePattern ts) =- TuplePattern <$> mapM checkPattern ts-checkPattern (ListPattern a ts) =- ListPattern a <$> mapM checkPattern ts-checkPattern (AsPattern v t) =- AsPattern v <$> checkPattern t-checkPattern (LazyPattern t) =- LazyPattern <$> checkPattern t-checkPattern (FunctionPattern a f ts) =- FunctionPattern a f <$> mapM checkPattern ts-checkPattern (InfixFuncPattern a t1 op t2) = do+ fixPrecT mkInfixPattern t1' op t2'+ where mkInfixPattern t1'' op'' t2'' =+ InfixPattern (t1'' @+@ t2'') a t1'' op'' t2''+checkPattern (ParenPattern spi t) =+ ParenPattern spi <$> checkPattern t+checkPattern (TuplePattern spi ts) =+ TuplePattern spi <$> mapM checkPattern ts+checkPattern (ListPattern spi a ts) =+ ListPattern spi a <$> mapM checkPattern ts+checkPattern (AsPattern spi v t) =+ AsPattern spi v <$> checkPattern t+checkPattern (LazyPattern spi t) =+ LazyPattern spi <$> checkPattern t+checkPattern (FunctionPattern spi a f ts) =+ FunctionPattern spi a f <$> mapM checkPattern ts+checkPattern (InfixFuncPattern _ a t1 op t2) = do t1' <- checkPattern t1 t2' <- checkPattern t2- fixPrecT (InfixFuncPattern a) t1' op t2'-checkPattern (RecordPattern a c fs) =- RecordPattern a c <$> mapM (checkField checkPattern) fs+ fixPrecT mkInfixFuncPattern t1' op t2'+ where mkInfixFuncPattern t1'' op'' t2'' =+ InfixFuncPattern (t1'' @+@ t2'') a t1'' op'' t2''+checkPattern (RecordPattern spi a c fs) =+ RecordPattern spi a c <$> mapM (checkField checkPattern) fs checkRhs :: Rhs a -> PCM (Rhs a)-checkRhs (SimpleRhs p e ds) = withLocalPrecEnv $- flip (SimpleRhs p) <$> checkDecls ds <*> checkExpr e-checkRhs (GuardedRhs es ds) = withLocalPrecEnv $- (flip GuardedRhs) <$> checkDecls ds <*> mapM checkCondExpr es+checkRhs (SimpleRhs spi e ds) = withLocalPrecEnv $+ flip (SimpleRhs spi) <$> checkDecls ds <*> checkExpr e+checkRhs (GuardedRhs spi es ds) = withLocalPrecEnv $+ flip (GuardedRhs spi) <$> checkDecls ds <*> mapM checkCondExpr es checkCondExpr :: CondExpr a -> PCM (CondExpr a) checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr g <*> checkExpr e checkExpr :: Expression a -> PCM (Expression a)-checkExpr l@(Literal _ _) = return l-checkExpr v@(Variable _ _) = return v-checkExpr c@(Constructor _ _) = return c-checkExpr (Paren e) = Paren <$> checkExpr e-checkExpr (Typed e ty) = flip Typed ty <$> checkExpr e-checkExpr (Record a c fs) = Record a c <$> mapM (checkField checkExpr) fs-checkExpr (RecordUpdate e fs) = RecordUpdate <$> (checkExpr e)- <*> mapM (checkField checkExpr) fs-checkExpr (Tuple es) = Tuple <$> mapM checkExpr es-checkExpr (List a es) = List a <$> mapM checkExpr es-checkExpr (ListCompr e qs) = withLocalPrecEnv $- flip ListCompr <$> mapM checkStmt qs <*> checkExpr e-checkExpr (EnumFrom e) = EnumFrom <$> checkExpr e-checkExpr (EnumFromThen e1 e2) =- EnumFromThen <$> checkExpr e1 <*> checkExpr e2-checkExpr (EnumFromTo e1 e2) =- EnumFromTo <$> checkExpr e1 <*> checkExpr e2-checkExpr (EnumFromThenTo e1 e2 e3) =- EnumFromThenTo <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3-checkExpr (UnaryMinus e) = UnaryMinus <$> checkExpr e-checkExpr (Apply e1 e2) =- Apply <$> checkExpr e1 <*> checkExpr e2-checkExpr (InfixApply e1 op e2) = do+checkExpr l@(Literal _ _ _) = return l+checkExpr v@(Variable _ _ _) = return v+checkExpr c@(Constructor _ _ _) = return c+checkExpr (Paren spi e) = Paren spi <$> checkExpr e+checkExpr (Typed spi e ty) = flip (Typed spi) ty <$> checkExpr e+checkExpr (Record spi a c fs) = Record spi a c <$> mapM (checkField checkExpr) fs+checkExpr (RecordUpdate spi e fs) = RecordUpdate spi <$> checkExpr e+ <*> mapM (checkField checkExpr) fs+checkExpr (Tuple spi es) = Tuple spi <$> mapM checkExpr es+checkExpr (List spi a es) = List spi a <$> mapM checkExpr es+checkExpr (ListCompr spi e qs) = withLocalPrecEnv $+ flip (ListCompr spi) <$> mapM checkStmt qs <*> checkExpr e+checkExpr (EnumFrom spi e) = EnumFrom spi <$> checkExpr e+checkExpr (EnumFromThen spi e1 e2) =+ EnumFromThen spi <$> checkExpr e1 <*> checkExpr e2+checkExpr (EnumFromTo spi e1 e2) =+ EnumFromTo spi <$> checkExpr e1 <*> checkExpr e2+checkExpr (EnumFromThenTo spi e1 e2 e3) =+ EnumFromThenTo spi <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3+checkExpr (UnaryMinus spi e) = UnaryMinus spi <$> checkExpr e+checkExpr (Apply spi e1 e2) =+ Apply spi <$> checkExpr e1 <*> checkExpr e2+checkExpr (InfixApply spi e1 op e2) = do e1' <- checkExpr e1 e2' <- checkExpr e2- fixPrec e1' op e2'-checkExpr (LeftSection e op) = checkExpr e >>= checkLSection op-checkExpr (RightSection op e) = checkExpr e >>= checkRSection op-checkExpr (Lambda ts e) =- Lambda <$> mapM checkPattern ts <*> checkExpr e-checkExpr (Let ds e) = withLocalPrecEnv $- Let <$> checkDecls ds <*> checkExpr e-checkExpr (Do sts e) = withLocalPrecEnv $- Do <$> mapM checkStmt sts <*> checkExpr e-checkExpr (IfThenElse e1 e2 e3) =- IfThenElse <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3-checkExpr (Case ct e alts) =- Case ct <$> checkExpr e <*> mapM checkAlt alts+ fixPrec spi e1' op e2'+checkExpr (LeftSection spi e op) = checkExpr e >>= checkLSection spi op+checkExpr (RightSection spi op e) = checkExpr e >>= checkRSection spi op+checkExpr (Lambda spi ts e) =+ Lambda spi <$> mapM checkPattern ts <*> checkExpr e+checkExpr (Let spi ds e) = withLocalPrecEnv $+ Let spi <$> checkDecls ds <*> checkExpr e+checkExpr (Do spi sts e) = withLocalPrecEnv $+ Do spi <$> mapM checkStmt sts <*> checkExpr e+checkExpr (IfThenElse spi e1 e2 e3) =+ IfThenElse spi <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3+checkExpr (Case spi ct e alts) =+ Case spi ct <$> checkExpr e <*> mapM checkAlt alts checkStmt :: Statement a -> PCM (Statement a)-checkStmt (StmtExpr e) = StmtExpr <$> checkExpr e-checkStmt (StmtDecl ds) = StmtDecl <$> checkDecls ds-checkStmt (StmtBind t e) = StmtBind <$> checkPattern t <*> checkExpr e+checkStmt (StmtExpr spi e) = StmtExpr spi <$> checkExpr e+checkStmt (StmtDecl spi ds) = StmtDecl spi <$> checkDecls ds+checkStmt (StmtBind spi t e) = StmtBind spi <$> checkPattern t <*> checkExpr e checkAlt :: Alt a -> PCM (Alt a) checkAlt (Alt p t rhs) = Alt p <$> checkPattern t <*> checkRhs rhs@@ -259,56 +265,59 @@ -- Note that both arguments already have been checked before 'fixPrec' -- is called. -fixPrec :: Expression a -> InfixOp a -> Expression a -> PCM (Expression a)-fixPrec (UnaryMinus e1) op e2 = do+fixPrec :: SpanInfo -> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)+fixPrec spi (UnaryMinus spi' e1) op e2 = do OpPrec fix pr <- getOpPrec op if pr < 6 || pr == 6 && fix == InfixL- then fixRPrec (UnaryMinus e1) op e2+ then fixRPrec spi (UnaryMinus spi' e1) op e2 else if pr > 6- then fixUPrec e1 op e2+ then fixUPrec spi' e1 op e2 else do report $ errAmbiguousParse "unary" (qualify minusId) (opName op)- return $ InfixApply (UnaryMinus e1) op e2-fixPrec e1 op e2 = fixRPrec e1 op e2+ return $ InfixApply spi (UnaryMinus spi' e1) op e2+fixPrec spi e1 op e2 = fixRPrec spi e1 op e2 -fixUPrec :: Expression a -> InfixOp a -> Expression a+fixUPrec :: SpanInfo -> Expression a -> InfixOp a -> Expression a -> PCM (Expression a)-fixUPrec e1 op e2@(UnaryMinus _) = do+fixUPrec spi e1 op e2@(UnaryMinus spi' _) = do report $ errAmbiguousParse "operator" (opName op) (qualify minusId)- return $ UnaryMinus (InfixApply e1 op e2)-fixUPrec e1 op1 e'@(InfixApply e2 op2 e3) = do+ return $ UnaryMinus spi' (InfixApply spi e1 op e2)+fixUPrec spi e1 op1 e'@(InfixApply spi' e2 op2 e3) = do OpPrec fix2 pr2 <- getOpPrec op2 if pr2 < 6 || pr2 == 6 && fix2 == InfixL then do- left <- fixUPrec e1 op1 e2- return $ InfixApply left op2 e3+ left <- fixUPrec spi e1 op1 e2+ return $ InfixApply (left @+@ e3) left op2 e3 else if pr2 > 6 then do- op <- fixRPrec e1 op1 $ InfixApply e2 op2 e3- return $ UnaryMinus op+ op <- fixRPrec spi e1 op1 $ InfixApply spi' e2 op2 e3+ return $ updateEndPos $ UnaryMinus spi' op else do report $ errAmbiguousParse "unary" (qualify minusId) (opName op2)- return $ InfixApply (UnaryMinus e1) op1 e'-fixUPrec e1 op e2 = return $ UnaryMinus (InfixApply e1 op e2)+ let left = updateEndPos (UnaryMinus spi' e1)+ return $ InfixApply (left @+@ e') left op1 e'+fixUPrec spi e1 op e2 = return $ updateEndPos $ UnaryMinus spi+ (InfixApply (e1 @+@ e2) e1 op e2) -fixRPrec :: Expression a -> InfixOp a -> Expression a -> PCM (Expression a)-fixRPrec e1 op (UnaryMinus e2) = do+fixRPrec :: SpanInfo -> Expression a -> InfixOp a -> Expression a+ -> PCM (Expression a)+fixRPrec spi e1 op (UnaryMinus spi' e2) = do OpPrec _ pr <- getOpPrec op unless (pr < 6) $ report $ errAmbiguousParse "operator" (opName op) (qualify minusId)- return $ InfixApply e1 op $ UnaryMinus e2-fixRPrec e1 op1 (InfixApply e2 op2 e3) = do+ return $ InfixApply spi e1 op $ UnaryMinus spi' e2+fixRPrec spi e1 op1 (InfixApply spi' e2 op2 e3) = do OpPrec fix1 pr1 <- getOpPrec op1 OpPrec fix2 pr2 <- getOpPrec op2 if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR- then return $ InfixApply e1 op1 $ InfixApply e2 op2 e3+ then return $ InfixApply spi e1 op1 $ InfixApply spi' e2 op2 e3 else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL then do- left <- fixPrec e1 op1 e2- return $ InfixApply left op2 e3+ left <- fixPrec (e1 @+@ e2) e1 op1 e2+ return $ InfixApply (left @+@ e3) left op2 e3 else do report $ errAmbiguousParse "operator" (opName op1) (opName op2)- return $ InfixApply e1 op1 $ InfixApply e2 op2 e3-fixRPrec e1 op e2 = return $ InfixApply e1 op e2+ return $ InfixApply spi e1 op1 $ InfixApply spi' e2 op2 e3+fixRPrec spi e1 op e2 = return $ InfixApply spi e1 op e2 -- The functions 'checkLSection' and 'checkRSection' are used for handling -- the precedences inside left and right sections.@@ -318,32 +327,32 @@ -- associative for a left section and right associative for a right -- section, respectively. -checkLSection :: InfixOp a -> Expression a -> PCM (Expression a)-checkLSection op e@(UnaryMinus _) = do+checkLSection :: SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)+checkLSection spi op e@(UnaryMinus _ _) = do OpPrec fix pr <- getOpPrec op unless (pr < 6 || pr == 6 && fix == InfixL) $ report $ errAmbiguousParse "unary" (qualify minusId) (opName op)- return $ LeftSection e op-checkLSection op1 e@(InfixApply _ op2 _) = do+ return $ LeftSection spi e op+checkLSection spi op1 e@(InfixApply _ _ op2 _) = do OpPrec fix1 pr1 <- getOpPrec op1 OpPrec fix2 pr2 <- getOpPrec op2 unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL) $ report $ errAmbiguousParse "operator" (opName op1) (opName op2)- return $ LeftSection e op1-checkLSection op e = return $ LeftSection e op+ return $ LeftSection spi e op1+checkLSection spi op e = return $ LeftSection spi e op -checkRSection :: InfixOp a -> Expression a -> PCM (Expression a)-checkRSection op e@(UnaryMinus _) = do+checkRSection :: SpanInfo -> InfixOp a -> Expression a -> PCM (Expression a)+checkRSection spi op e@(UnaryMinus _ _) = do OpPrec _ pr <- getOpPrec op unless (pr < 6) $ report $ errAmbiguousParse "unary" (qualify minusId) (opName op)- return $ RightSection op e-checkRSection op1 e@(InfixApply _ op2 _) = do+ return $ RightSection spi op e+checkRSection spi op1 e@(InfixApply _ _ op2 _) = do OpPrec fix1 pr1 <- getOpPrec op1 OpPrec fix2 pr2 <- getOpPrec op2 unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR) $ report $ errAmbiguousParse "operator" (opName op1) (opName op2)- return $ RightSection op1 e-checkRSection op e = return $ RightSection op e+ return $ RightSection spi op1 e+checkRSection spi op e = return $ RightSection spi op e -- The functions 'fixPrecT' and 'fixRPrecT' check the relative precedences -- of adjacent infix operators in patterns. The patterns will be reordered@@ -357,7 +366,7 @@ fixPrecT :: (Pattern a -> QualIdent -> Pattern a -> Pattern a) -> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)-fixPrecT infixpatt t1@(NegativePattern _ _) op t2 = do+fixPrecT infixpatt t1@(NegativePattern _ _ _) op t2 = do OpPrec fix pr <- prec op <$> getPrecEnv unless (pr < 6 || pr == 6 && fix == InfixL) $ report $ errInvalidParse "unary operator" minusId op@@ -366,34 +375,34 @@ fixRPrecT :: (Pattern a -> QualIdent -> Pattern a -> Pattern a) -> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)-fixRPrecT infixpatt t1 op t2@(NegativePattern _ _) = do+fixRPrecT infixpatt t1 op t2@(NegativePattern _ _ _) = do OpPrec _ pr <- prec op <$> getPrecEnv unless (pr < 6) $ report $ errInvalidParse "unary operator" minusId op return $ infixpatt t1 op t2-fixRPrecT infixpatt t1 op1 (InfixPattern a t2 op2 t3) = do+fixRPrecT infixpatt t1 op1 (InfixPattern spi a t2 op2 t3) = do OpPrec fix1 pr1 <- prec op1 <$> getPrecEnv OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR- then return $ infixpatt t1 op1 (InfixPattern a t2 op2 t3)+ then return $ infixpatt t1 op1 (InfixPattern spi a t2 op2 t3) else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL then do left <- fixPrecT infixpatt t1 op1 t2- return $ InfixPattern a left op2 t3+ return $ InfixPattern (left @+@ t3) a left op2 t3 else do report $ errAmbiguousParse "operator" op1 op2- return $ infixpatt t1 op1 (InfixPattern a t2 op2 t3)-fixRPrecT infixpatt t1 op1 (InfixFuncPattern a t2 op2 t3) = do+ return $ infixpatt t1 op1 (InfixPattern spi a t2 op2 t3)+fixRPrecT infixpatt t1 op1 (InfixFuncPattern spi a t2 op2 t3) = do OpPrec fix1 pr1 <- prec op1 <$> getPrecEnv OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR- then return $ infixpatt t1 op1 (InfixFuncPattern a t2 op2 t3)+ then return $ infixpatt t1 op1 (InfixFuncPattern spi a t2 op2 t3) else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL then do left <- fixPrecT infixpatt t1 op1 t2- return $ InfixFuncPattern a left op2 t3+ return $ InfixFuncPattern (left @+@ t3) a left op2 t3 else do report $ errAmbiguousParse "operator" op1 op2- return $ infixpatt t1 op1 (InfixFuncPattern a t2 op2 t3)+ return $ infixpatt t1 op1 (InfixFuncPattern spi a t2 op2 t3) fixRPrecT infixpatt t1 op t2 = return $ infixpatt t1 op t2 {-fixPrecT :: Position -> OpPrecEnv -> Pattern -> QualIdent -> Pattern@@ -426,12 +435,12 @@ -- declaration is invalid. checkOpL :: Ident -> Pattern a -> PCM (Pattern a)-checkOpL op t@(NegativePattern _ _) = do+checkOpL op t@(NegativePattern _ _ _) = do OpPrec fix pr <- prec (qualify op) <$> getPrecEnv unless (pr < 6 || pr == 6 && fix == InfixL) $ report $ errInvalidParse "unary operator" minusId (qualify op) return t-checkOpL op1 t@(InfixPattern _ _ op2 _) = do+checkOpL op1 t@(InfixPattern _ _ _ op2 _) = do OpPrec fix1 pr1 <- prec (qualify op1) <$> getPrecEnv OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL) $@@ -440,11 +449,11 @@ checkOpL _ t = return t checkOpR :: Ident -> Pattern a -> PCM (Pattern a)-checkOpR op t@(NegativePattern _ _) = do+checkOpR op t@(NegativePattern _ _ _) = do OpPrec _ pr <- prec (qualify op) <$> getPrecEnv when (pr >= 6) $ report $ errInvalidParse "unary operator" minusId (qualify op) return t-checkOpR op1 t@(InfixPattern _ _ op2 _) = do+checkOpR op1 t@(InfixPattern _ _ _ op2 _) = do OpPrec fix1 pr1 <- prec (qualify op1) <$> getPrecEnv OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR) $@@ -454,7 +463,7 @@ -- The functions 'opPrec' and 'prec' return the fixity and operator precedence -- of an entity. Even though precedence checking is performed after the--- renaming phase, we have to be prepared to see ambiguous identifiers here.+-- renaming phase, we have to be prepared to see ambiguoeus identifiers here. -- This may happen while checking the root of an operator definition that -- shadows an imported definition. @@ -469,6 +478,11 @@ [] -> defaultP PrecInfo _ p : _ -> p ++-- Combine two entities with SpanInfo to a new SpanInfo (discarding info points)+(@+@) :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo+a @+@ b = fromSrcSpan (combineSpans (getSrcSpan a) (getSrcSpan b))+ -- --------------------------------------------------------------------------- -- Error messages -- ---------------------------------------------------------------------------@@ -487,11 +501,12 @@ errInvalidParse :: String -> Ident -> QualIdent -> Message errInvalidParse what op1 op2 = posMessage op1 $ hsep $ map text [ "Invalid use of", what, escName op1, "with", escQualName op2, "in"- , showLine $ qidPosition op2]+ , showLine $ getPosition op2] -- FIXME: Messages may have missing positions for minus operators+-- TODO: Is this still true after span update for parser? errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message errAmbiguousParse what op1 op2 = posMessage op1 $ hsep $ map text ["Ambiguous use of", what, escQualName op1, "with", escQualName op2, "in"- , showLine $ qidPosition op2]+ , showLine $ getPosition op2]
src/Checks/SyntaxCheck.hs view
@@ -26,10 +26,14 @@ {-# LANGUAGE CPP #-} module Checks.SyntaxCheck (syntaxCheck) where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif--- <<<<<<< HEAD+ import Control.Monad (unless, when) import qualified Control.Monad.State as S ( State, runState, gets, modify , withState )@@ -44,6 +48,8 @@ import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty+import Curry.Base.Span+import Curry.Base.SpanInfo import Curry.Syntax import Curry.Syntax.Pretty (ppPattern) @@ -67,11 +73,13 @@ -- resulting environment. In addition, this process will also rename the -- local variables. +-- TODO: use SpanInfos for errors and then stop passing down SpanInfo from the decls to the checks+ syntaxCheck :: [KnownExtension] -> TCEnv -> ValueEnv -> Module () -> ((Module (), [KnownExtension]), [Message])-syntaxCheck exts tcEnv vEnv mdl@(Module _ m _ _ ds) =- case findMultiples $ concatMap constrs tds of- [] -> case findMultiples (ls ++ fs ++ cs) of+syntaxCheck exts tcEnv vEnv mdl@(Module _ _ m _ _ ds) =+ case findMultiples cons of+ [] -> case findMultiples (ls ++ fs ++ cons ++ cs) of [] -> runSC (checkModule mdl) state iss -> ((mdl, exts), map (errMultipleDeclarations m) iss) css -> ((mdl, exts), map errMultipleDataConstructor css)@@ -79,9 +87,10 @@ tds = filter isTypeDecl ds vds = filter isValueDecl ds cds = filter isClassDecl ds+ cons = concatMap constrs tds ls = nub $ concatMap recLabels tds fs = nub $ concatMap vars vds- cs = concatMap (concatMap methods) $ [ds' | ClassDecl _ _ _ _ ds' <- cds]+ cs = concatMap (concatMap methods) [ds' | ClassDecl _ _ _ _ ds' <- cds] rEnv = globalEnv $ fmap renameInfo vEnv state = initState exts m tcEnv rEnv @@ -240,7 +249,7 @@ case maybeF of Nothing -> internalError "SyntaxCheck.addFuncPat: no global function set" Just f -> modifyFuncDeps $ \ fd -> fd- { globalDeps = Map.insertWith (Set.union) f+ { globalDeps = Map.insertWith Set.union f (Set.singleton dep) (globalDeps fd) } -- |Add a functional pattern to `curGlobalFunction'@@ -366,7 +375,7 @@ bindFuncDecl tcc m (FunctionDecl _ _ f (eq:_)) env = let arty = length $ snd $ getFlatLhs eq in bindGlobal tcc m f (GlobalVar (qualifyWith m f) arty) env-bindFuncDecl tcc m (TypeSig _ fs (QualTypeExpr _ ty)) env+bindFuncDecl tcc m (TypeSig _ fs (QualTypeExpr _ _ ty)) env = foldr bindTS env $ map (qualifyWith m) fs where bindTS qf env'@@ -438,7 +447,7 @@ -- declaration are allowed to be declared). checkModule :: Module () -> SCM (Module (), [KnownExtension])-checkModule (Module ps m es is ds) = do+checkModule (Module spi ps m es is ds) = do mapM_ bindTypeDecl tds mapM_ bindClassDecl cds ds' <- checkTopDecls ds@@ -447,7 +456,7 @@ let ds'' = updateClassAndInstanceDecls cds' ids' ds' checkFuncPatDeps exts <- getExtensions- return (Module ps m es is ds'', exts)+ return (Module spi ps m es is ds'', exts) where tds = filter isTypeDecl ds cds = filter isClassDecl ds ids = filter isInstanceDecl ds@@ -542,10 +551,11 @@ FreeDecl p <$> mapM (checkVar' "free variables declaration") vs checkDeclLhs d = return d -checkPrecedence :: Position -> Maybe Precedence -> SCM (Maybe Precedence)+checkPrecedence :: SpanInfo -> Maybe Precedence -> SCM (Maybe Precedence) checkPrecedence _ Nothing = return Nothing checkPrecedence p (Just i) = do- unless (0 <= i && i <= 9) $ report $ errPrecedenceOutOfRange p i+ unless (0 <= i && i <= 9) $ report+ $ errPrecedenceOutOfRange (spanInfo2Pos p) i return $ Just i checkVar' :: String -> Var a -> SCM (Var a)@@ -560,26 +570,22 @@ renameVar :: Ident -> SCM Ident renameVar v = renameIdent v <$> getScopeId -checkEquationsLhs :: Position -> [Equation ()] -> SCM (Decl ())+checkEquationsLhs :: SpanInfo -> [Equation ()] -> SCM (Decl ()) checkEquationsLhs p [Equation p' lhs rhs] = do lhs' <- checkEqLhs p' lhs case lhs' of Left l -> return $ funDecl' l- Right r -> patDecl' r >>= checkDeclLhs+ Right r -> checkDeclLhs (PatternDecl p' r rhs) where funDecl' (f, lhs') = FunctionDecl p () f [Equation p' lhs' rhs]- patDecl' t = do- k <- getScopeId- when (k == globalScopeId) $ report $ errToplevelPattern p- return $ PatternDecl p' t rhs checkEquationsLhs _ _ = internalError "SyntaxCheck.checkEquationsLhs" -checkEqLhs :: Position -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))-checkEqLhs p toplhs = do+checkEqLhs :: SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))+checkEqLhs pspi toplhs = do m <- getModuleIdent k <- getScopeId env <- getRenameEnv case toplhs of- FunLhs f ts+ FunLhs spi f ts | not $ isDataConstr f env -> return left | k /= globalScopeId -> return right | null infos -> return left@@ -587,9 +593,10 @@ return right where f' = renameIdent f k infos = qualLookupVar (qualifyWith m f) env- left = Left (f', FunLhs f' ts)- right = Right $ ConstructorPattern () (qualify f) ts- OpLhs t1 op t2+ left = Left (f', FunLhs spi f' ts)+ right = Right $ -- use start from the parsed FunLhs and compute end+ updateEndPos $ ConstructorPattern spi () (qualify f) ts+ OpLhs spi t1 op t2 | not $ isDataConstr op env -> return left | k /= globalScopeId -> return right | null infos -> return left@@ -597,28 +604,34 @@ return right where op' = renameIdent op k infos = qualLookupVar (qualifyWith m op) env- left = Left (op', OpLhs t1 op' t2)+ left = Left (op', OpLhs spi t1 op' t2) right = checkOpLhs k env (infixPattern t1 (qualify op)) t2- infixPattern (InfixPattern a' t1' op1 t2') op2 t3 =- InfixPattern a' t1' op1 (infixPattern t2' op2 t3)- infixPattern t1' op1 t2' = InfixPattern () t1' op1 t2'- ApLhs lhs ts -> do- checked <- checkEqLhs p lhs+ infixPattern (InfixPattern _ a' t1' op1 t2') op2 t3 =+ let t2'' = infixPattern t2' op2 t3+ sp = combineSpans (getSrcSpan t1') (getSrcSpan t2'')+ in InfixPattern (fromSrcSpan sp) a' t1' op1 t2''+ infixPattern t1' op1 t2' =+ let sp = combineSpans (getSrcSpan t1') (getSrcSpan t2')+ in InfixPattern (fromSrcSpan sp) () t1' op1 t2'+ ApLhs spi lhs ts -> do+ checked <- checkEqLhs pspi lhs case checked of- Left (f', lhs') -> return $ Left (f', ApLhs lhs' ts)+ Left (f', lhs') -> return $ Left (f', updateEndPos $ ApLhs spi lhs' ts) r -> do report $ errNonVariable "curried definition" f return $ r where (f, _) = flatLhs lhs+ where p = spanInfo2Pos pspi checkOpLhs :: Integer -> RenameEnv -> (Pattern a -> Pattern a) -> Pattern a -> Either (Ident, Lhs a) (Pattern a)-checkOpLhs k env f (InfixPattern a t1 op t2)+checkOpLhs k env f (InfixPattern spi a t1 op t2) | isJust m || isDataConstr op' env- = checkOpLhs k env (f . InfixPattern a t1 op) t2+ = checkOpLhs k env (f . InfixPattern spi a t1 op) t2 | otherwise- = Left (op'', OpLhs (f t1) op'' t2)+ = Left (op'', OpLhs (getSpanInfo t1') t1' op'' t2) where (m,op') = (qidModule op, qidIdent op) op'' = renameIdent op' k+ t1' = f t1 checkOpLhs _ _ f t = Right (f t) -- -- ---------------------------------------------------------------------------@@ -628,7 +641,7 @@ joinEquations (FunctionDecl a p f eqs : FunctionDecl _ _ f' [eq] : ds) | f == f' = do when (getArity (head eqs) /= getArity eq) $ report $ errDifferentArity [f, f']- joinEquations (FunctionDecl a p f (eqs ++ [eq]) : ds)+ joinEquations (updateEndPos (FunctionDecl a p f (eqs ++ [eq])) : ds) where getArity = length . snd . getFlatLhs joinEquations (d : ds) = (d :) <$> joinEquations ds @@ -686,82 +699,82 @@ rhs' <- checkRhs rhs return $ Equation p lhs' rhs' -checkLhs :: Position -> Lhs () -> SCM (Lhs ())-checkLhs p (FunLhs f ts) = FunLhs f <$> mapM (checkPattern p) ts-checkLhs p (OpLhs t1 op t2) = do+checkLhs :: SpanInfo -> Lhs () -> SCM (Lhs ())+checkLhs p (FunLhs spi f ts) = FunLhs spi f <$> mapM (checkPattern p) ts+checkLhs p (OpLhs spi t1 op t2) = do let wrongCalls = concatMap (checkParenPattern (Just $ qualify op)) [t1,t2] unless (null wrongCalls) $ report $ errInfixWithoutParens- (idPosition op) wrongCalls- flip OpLhs op <$> checkPattern p t1 <*> checkPattern p t2-checkLhs p (ApLhs lhs ts) =- ApLhs <$> checkLhs p lhs <*> mapM (checkPattern p) ts+ (getPosition op) wrongCalls+ flip (OpLhs spi) op <$> checkPattern p t1 <*> checkPattern p t2+checkLhs p (ApLhs spi lhs ts) =+ ApLhs spi <$> checkLhs p lhs <*> mapM (checkPattern p) ts -- checkParen -- @param Aufrufende InfixFunktion -- @param Pattern -- @return Liste mit fehlerhaften Funktionsaufrufen -checkParenPattern :: (Maybe QualIdent) -> Pattern a -> [(QualIdent, QualIdent)]-checkParenPattern _ (LiteralPattern _ _) = []-checkParenPattern _ (NegativePattern _ _) = []-checkParenPattern _ (VariablePattern _ _) = []-checkParenPattern _ (ConstructorPattern _ _ cs) =+checkParenPattern :: Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]+checkParenPattern _ (LiteralPattern _ _ _) = []+checkParenPattern _ (NegativePattern _ _ _) = []+checkParenPattern _ (VariablePattern _ _ _) = []+checkParenPattern _ (ConstructorPattern _ _ _ cs) = concatMap (checkParenPattern Nothing) cs-checkParenPattern o (InfixPattern _ t1 op t2) =+checkParenPattern o (InfixPattern _ _ t1 op t2) = maybe [] (\c -> [(c, op)]) o ++ checkParenPattern Nothing t1 ++ checkParenPattern Nothing t2-checkParenPattern _ (ParenPattern t) =+checkParenPattern _ (ParenPattern _ t) = checkParenPattern Nothing t-checkParenPattern _ (RecordPattern _ _ fs) =+checkParenPattern _ (RecordPattern _ _ _ fs) = concatMap (\(Field _ _ t) -> checkParenPattern Nothing t) fs-checkParenPattern _ (TuplePattern ts) =+checkParenPattern _ (TuplePattern _ ts) = concatMap (checkParenPattern Nothing) ts-checkParenPattern _ (ListPattern _ ts) =+checkParenPattern _ (ListPattern _ _ ts) = concatMap (checkParenPattern Nothing) ts-checkParenPattern o (AsPattern _ t) =+checkParenPattern o (AsPattern _ _ t) = checkParenPattern o t-checkParenPattern o (LazyPattern t) =+checkParenPattern o (LazyPattern _ t) = checkParenPattern o t-checkParenPattern _ (FunctionPattern _ _ ts) =+checkParenPattern _ (FunctionPattern _ _ _ ts) = concatMap (checkParenPattern Nothing) ts-checkParenPattern o (InfixFuncPattern _ t1 op t2) =+checkParenPattern o (InfixFuncPattern _ _ t1 op t2) = maybe [] (\c -> [(c, op)]) o ++ checkParenPattern Nothing t1 ++ checkParenPattern Nothing t2 -checkPattern :: Position -> Pattern () -> SCM (Pattern ())-checkPattern _ (LiteralPattern a l) =- return $ LiteralPattern a l-checkPattern _ (NegativePattern a l) =- return $ NegativePattern a l-checkPattern p (VariablePattern a v)- | isAnonId v = (VariablePattern a . renameIdent v) <$> newId- | otherwise = checkConstructorPattern p (qualify v) []-checkPattern p (ConstructorPattern _ c ts) =- checkConstructorPattern p c ts-checkPattern p (InfixPattern _ t1 op t2) =- checkInfixPattern p t1 op t2-checkPattern p (ParenPattern t) =- ParenPattern <$> checkPattern p t-checkPattern p (RecordPattern _ c fs) =- checkRecordPattern p c fs-checkPattern p (TuplePattern ts) =- TuplePattern <$> mapM (checkPattern p) ts-checkPattern p (ListPattern a ts) =- ListPattern a <$> mapM (checkPattern p) ts-checkPattern p (AsPattern v t) = do- AsPattern <$> checkVar "@ pattern" v <*> checkPattern p t-checkPattern p (LazyPattern t) = do+checkPattern :: SpanInfo -> Pattern () -> SCM (Pattern ())+checkPattern _ (LiteralPattern spi a l) =+ return $ LiteralPattern spi a l+checkPattern _ (NegativePattern spi a l) =+ return $ NegativePattern spi a l+checkPattern p (VariablePattern spi a v)+ | isAnonId v = (VariablePattern spi a . renameIdent v) <$> newId+ | otherwise = checkConstructorPattern p spi (qualify v) []+checkPattern p (ConstructorPattern spi _ c ts) =+ checkConstructorPattern p spi c ts+checkPattern p (InfixPattern spi _ t1 op t2) =+ checkInfixPattern p spi t1 op t2+checkPattern p (ParenPattern spi t) =+ ParenPattern spi <$> checkPattern p t+checkPattern p (RecordPattern spi _ c fs) =+ checkRecordPattern p spi c fs+checkPattern p (TuplePattern spi ts) =+ TuplePattern spi <$> mapM (checkPattern p) ts+checkPattern p (ListPattern spi a ts) =+ ListPattern spi a <$> mapM (checkPattern p) ts+checkPattern p (AsPattern spi v t) =+ AsPattern spi <$> checkVar "@ pattern" v <*> checkPattern p t+checkPattern p (LazyPattern spi t) = do t' <- checkPattern p t banFPTerm "lazy pattern" p t'- return (LazyPattern t')-checkPattern _ (FunctionPattern _ _ _) = internalError $+ return (LazyPattern spi t')+checkPattern _ (FunctionPattern _ _ _ _) = internalError $ "SyntaxCheck.checkPattern: function pattern not defined"-checkPattern _ (InfixFuncPattern _ _ _ _) = internalError $+checkPattern _ (InfixFuncPattern _ _ _ _ _) = internalError $ "SyntaxCheck.checkPattern: infix function pattern not defined" -checkConstructorPattern :: Position -> QualIdent -> [Pattern ()]+checkConstructorPattern :: SpanInfo -> SpanInfo -> QualIdent -> [Pattern ()] -> SCM (Pattern ())-checkConstructorPattern p c ts = do+checkConstructorPattern p spi c ts = do env <- getRenameEnv m <- getModuleIdent k <- getScopeId@@ -773,37 +786,37 @@ [r] -> processVarFun r k [] | null ts && not (isQualified c) ->- return $ VariablePattern () $ renameIdent (unqualify c) k+ return $ VariablePattern spi () $ renameIdent (unqualify c) k | null rs -> do ts' <- mapM (checkPattern p) ts report $ errUndefinedData c- return $ ConstructorPattern () c ts'+ return $ ConstructorPattern spi () c ts' _ -> do ts' <- mapM (checkPattern p) ts report $ errAmbiguousData rs c- return $ ConstructorPattern () c ts'+ return $ ConstructorPattern spi () c ts' where n' = length ts processCons qc n = do when (n /= n') $ report $ errWrongArity c n n'- ConstructorPattern () qc <$> mapM (checkPattern p) ts+ ConstructorPattern spi () qc <$> mapM (checkPattern p) ts processVarFun r k | null ts && not (isQualified c)- = return $ VariablePattern () $ renameIdent (unqualify c) k -- (varIdent r) k+ = return $ VariablePattern spi () $ renameIdent (unqualify c) k -- (varIdent r) k | otherwise = do let n = arity r- checkFuncPatsExtension p+ checkFuncPatsExtension (spanInfo2Pos p) checkFuncPatCall r c ts' <- mapM (checkPattern p) ts mapM_ (checkFPTerm p) ts' return $ if n' > n then let (ts1, ts2) = splitAt n ts' in genFuncPattAppl- (FunctionPattern () (qualVarIdent r) ts1) ts2- else FunctionPattern () (qualVarIdent r) ts'+ (FunctionPattern spi () (qualVarIdent r) ts1) ts2+ else FunctionPattern spi () (qualVarIdent r) ts' -checkInfixPattern :: Position -> Pattern () -> QualIdent -> Pattern ()+checkInfixPattern :: SpanInfo -> SpanInfo -> Pattern () -> QualIdent -> Pattern () -> SCM (Pattern ())-checkInfixPattern p t1 op t2 = do+checkInfixPattern p spi t1 op t2 = do m <- getModuleIdent env <- getRenameEnv case qualLookupVar op env of@@ -812,32 +825,32 @@ rs -> case qualLookupVar (qualQualify m op) env of [Constr _ n] -> infixPattern (qualQualify m op) n [r] -> funcPattern r (qualQualify m op)- rs' -> do if (null rs && null rs')+ rs' -> do if null rs && null rs' then report $ errUndefinedData op else report $ errAmbiguousData rs op- flip (InfixPattern ()) op <$> checkPattern p t1+ flip (InfixPattern spi ()) op <$> checkPattern p t1 <*> checkPattern p t2 where infixPattern qop n = do when (n /= 2) $ report $ errWrongArity op n 2- flip (InfixPattern ()) qop <$> checkPattern p t1 <*> checkPattern p t2+ flip (InfixPattern spi ()) qop <$> checkPattern p t1 <*> checkPattern p t2 funcPattern r qop = do- checkFuncPatsExtension p+ checkFuncPatsExtension (spanInfo2Pos p) checkFuncPatCall r qop ts'@[t1',t2'] <- mapM (checkPattern p) [t1,t2] mapM_ (checkFPTerm p) ts'- return $ InfixFuncPattern () t1' qop t2'+ return $ InfixFuncPattern spi () t1' qop t2' -checkRecordPattern :: Position -> QualIdent -> [Field (Pattern ())]+checkRecordPattern :: SpanInfo -> SpanInfo -> QualIdent -> [Field (Pattern ())] -> SCM (Pattern ())-checkRecordPattern p c fs = do+checkRecordPattern p spi c fs = do env <- getRenameEnv m <- getModuleIdent case qualLookupVar c env of [Constr c' _] -> processRecPat (Just c') fs rs -> case qualLookupVar (qualQualify m c) env of [Constr c' _] -> processRecPat (Just c') fs- rs' -> if (null rs && null rs')+ rs' -> if null rs && null rs' then do report $ errUndefinedData c processRecPat Nothing fs else do report $ errAmbiguousData rs c@@ -846,7 +859,7 @@ processRecPat mcon fields = do fs' <- mapM (checkField (checkPattern p)) fields checkFieldLabels "pattern" p mcon fs'- return $ RecordPattern () c fs'+ return $ RecordPattern spi () c fs' checkFuncPatCall :: RenameInfo -> QualIdent -> SCM () checkFuncPatCall r f = case r of@@ -857,156 +870,159 @@ -- Note: process decls first checkRhs :: Rhs () -> SCM (Rhs ())-checkRhs (SimpleRhs p e ds) = inNestedScope $- flip (SimpleRhs p) <$> checkDeclGroup bindVarDecl ds <*> checkExpr p e-checkRhs (GuardedRhs es ds) = inNestedScope $- flip GuardedRhs <$> checkDeclGroup bindVarDecl ds <*> mapM checkCondExpr es+checkRhs (SimpleRhs spi e ds) = inNestedScope $+ flip (SimpleRhs spi) <$> checkDeclGroup bindVarDecl ds <*> checkExpr spi e+checkRhs (GuardedRhs spi es ds) = inNestedScope $+ flip (GuardedRhs spi) <$> checkDeclGroup bindVarDecl ds <*> mapM checkCondExpr es checkCondExpr :: CondExpr () -> SCM (CondExpr ())-checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr p g <*> checkExpr p e+checkCondExpr (CondExpr spi g e) = CondExpr spi <$> checkExpr spi g <*> checkExpr spi e -checkExpr :: Position -> Expression () -> SCM (Expression ())-checkExpr _ (Literal a l) = return $ Literal a l-checkExpr _ (Variable a v) = checkVariable a v-checkExpr _ (Constructor a c) = checkVariable a c-checkExpr p (Paren e) = Paren <$> checkExpr p e-checkExpr p (Typed e ty) = flip Typed ty <$> checkExpr p e-checkExpr p (Record _ c fs) = checkRecordExpr p c fs-checkExpr p (RecordUpdate e fs) = checkRecordUpdExpr p e fs-checkExpr p (Tuple es) = Tuple <$> mapM (checkExpr p) es-checkExpr p (List a es) = List a <$> mapM (checkExpr p) es-checkExpr p (ListCompr e qs) = withLocalEnv $ flip ListCompr <$>+checkExpr :: SpanInfo -> Expression () -> SCM (Expression ())+checkExpr _ (Literal spi a l) = return $ Literal spi a l+checkExpr _ (Variable spi a v) = checkVariable spi a v+checkExpr _ (Constructor spi a c) = checkVariable spi a c+checkExpr p (Paren spi e) = Paren spi <$> checkExpr p e+checkExpr p (Typed spi e ty) = flip (Typed spi) ty <$> checkExpr p e+checkExpr p (Record spi _ c fs) = checkRecordExpr p spi c fs+checkExpr p (RecordUpdate spi e fs) = checkRecordUpdExpr p spi e fs+checkExpr p (Tuple spi es) = Tuple spi <$> mapM (checkExpr p) es+checkExpr p (List spi a es) = List spi a <$> mapM (checkExpr p) es+checkExpr p (ListCompr spi e qs) = withLocalEnv $ flip (ListCompr spi) <$> -- Note: must be flipped to insert qs into RenameEnv first mapM (checkStatement "list comprehension" p) qs <*> checkExpr p e-checkExpr p (EnumFrom e) = EnumFrom <$> checkExpr p e-checkExpr p (EnumFromThen e1 e2) =- EnumFromThen <$> checkExpr p e1 <*> checkExpr p e2-checkExpr p (EnumFromTo e1 e2) =- EnumFromTo <$> checkExpr p e1 <*> checkExpr p e2-checkExpr p (EnumFromThenTo e1 e2 e3) =- EnumFromThenTo <$> checkExpr p e1 <*> checkExpr p e2 <*> checkExpr p e3-checkExpr p (UnaryMinus e) = UnaryMinus <$> checkExpr p e-checkExpr p (Apply e1 e2) =- Apply <$> checkExpr p e1 <*> checkExpr p e2-checkExpr p (InfixApply e1 op e2) =- InfixApply <$> checkExpr p e1 <*> checkOp op <*> checkExpr p e2-checkExpr p (LeftSection e op) =- LeftSection <$> checkExpr p e <*> checkOp op-checkExpr p (RightSection op e) =- RightSection <$> checkOp op <*> checkExpr p e-checkExpr p (Lambda ts e) = inNestedScope $ checkLambda p ts e-checkExpr p (Let ds e) = inNestedScope $- Let <$> checkDeclGroup bindVarDecl ds <*> checkExpr p e-checkExpr p (Do sts e) = withLocalEnv $- Do <$> mapM (checkStatement "do sequence" p) sts <*> checkExpr p e-checkExpr p (IfThenElse e1 e2 e3) =- IfThenElse <$> checkExpr p e1 <*> checkExpr p e2 <*> checkExpr p e3-checkExpr p (Case ct e alts) =- Case ct <$> checkExpr p e <*> mapM checkAlt alts+checkExpr p (EnumFrom spi e) = EnumFrom spi <$> checkExpr p e+checkExpr p (EnumFromThen spi e1 e2) =+ EnumFromThen spi <$> checkExpr p e1 <*> checkExpr p e2+checkExpr p (EnumFromTo spi e1 e2) =+ EnumFromTo spi <$> checkExpr p e1 <*> checkExpr p e2+checkExpr p (EnumFromThenTo spi e1 e2 e3) =+ EnumFromThenTo spi <$> checkExpr p e1 <*> checkExpr p e2 <*> checkExpr p e3+checkExpr p (UnaryMinus spi e) = UnaryMinus spi <$> checkExpr p e+checkExpr p (Apply spi e1 e2) =+ Apply spi <$> checkExpr p e1 <*> checkExpr p e2+checkExpr p (InfixApply spi e1 op e2) =+ InfixApply spi <$> checkExpr p e1 <*> checkOp op <*> checkExpr p e2+checkExpr p (LeftSection spi e op) =+ LeftSection spi <$> checkExpr p e <*> checkOp op+checkExpr p (RightSection spi op e) =+ RightSection spi <$> checkOp op <*> checkExpr p e+checkExpr p (Lambda spi ts e) = inNestedScope $ checkLambda p spi ts e+checkExpr p (Let spi ds e) = inNestedScope $+ Let spi <$> checkDeclGroup bindVarDecl ds <*> checkExpr p e+checkExpr p (Do spi sts e) = withLocalEnv $+ Do spi <$> mapM (checkStatement "do sequence" p) sts <*> checkExpr p e+checkExpr p (IfThenElse spi e1 e2 e3) =+ IfThenElse spi <$> checkExpr p e1 <*> checkExpr p e2 <*> checkExpr p e3+checkExpr p (Case spi ct e alts) =+ Case spi ct <$> checkExpr p e <*> mapM checkAlt alts -checkLambda :: Position -> [Pattern ()] -> Expression () -> SCM (Expression ())-checkLambda p ts e = case findMultiples (bvNoAnon ts) of+checkLambda :: SpanInfo -> SpanInfo -> [Pattern ()] -> Expression ()+ -> SCM (Expression ())+checkLambda p spi ts e = case findMultiples (bvNoAnon ts) of [] -> do ts' <- mapM (bindPattern "lambda expression" p) ts- Lambda ts' <$> checkExpr p e+ Lambda spi ts' <$> checkExpr p e errVars -> do mapM_ (report . errDuplicateVariables) errVars let nubTs = nubBy (\t1 t2 -> (not . null) (on intersect bvNoAnon t1 t2)) ts mapM_ (bindPattern "lambda expression" p) nubTs- Lambda ts <$> checkExpr p e+ Lambda spi ts <$> checkExpr p e where bvNoAnon t = filter (not . isAnonId) $ bv t -checkVariable :: a -> QualIdent -> SCM (Expression a)-checkVariable a v+checkVariable :: SpanInfo -> a -> QualIdent -> SCM (Expression a)+checkVariable spi a v -- anonymous free variable | isAnonId (unqualify v) = do- checkAnonFreeVarsExtension $ qidPosition v- (\n -> Variable a $ updQualIdent id (flip renameIdent n) v) <$> newId+ checkAnonFreeVarsExtension $ getPosition v+ (\n -> Variable spi a $ updQualIdent id (flip renameIdent n) v) <$> newId -- return $ Variable v -- normal variable | otherwise = do env <- getRenameEnv case qualLookupVar v env of [] -> do report $ errUndefinedVariable v- return $ Variable a v- [Constr _ _] -> return $ Constructor a v- [GlobalVar f _] -> addGlobalDep f >> return (Variable a v)- [LocalVar v' _] -> return $ Variable a $ qualify v' @> v- [RecordLabel _ _] -> return $ Variable a v+ return $ Variable spi a v+ [Constr _ _] -> return $ Constructor spi a v+ [GlobalVar f _] -> addGlobalDep f >> return (Variable spi a v)+ [LocalVar v' _] -> return $ Variable spi a $ qualify v' @> v+ [RecordLabel _ _] -> return $ Variable spi a v rs -> do m <- getModuleIdent case qualLookupVar (qualQualify m v) env of [] -> do report $ errAmbiguousIdent rs v- return $ Variable a v- [Constr _ _] -> return $ Constructor a v- [GlobalVar f _] -> addGlobalDep f >> return (Variable a v)- [LocalVar v' _] -> return $ Variable a $ qualify v' @> v- [RecordLabel _ _] -> return $ Variable a v+ return $ Variable spi a v+ [Constr _ _] -> return $ Constructor spi a v+ [GlobalVar f _] -> addGlobalDep f >> return (Variable spi a v)+ [LocalVar v' _] -> return $ Variable spi a $ qualify v' @> v+ [RecordLabel _ _] -> return $ Variable spi a v rs' -> do report $ errAmbiguousIdent rs' v- return $ Variable a v+ return $ Variable spi a v -checkRecordExpr :: Position -> QualIdent -> [Field (Expression ())]+checkRecordExpr :: SpanInfo -> SpanInfo -> QualIdent -> [Field (Expression ())] -> SCM (Expression ())-checkRecordExpr _ c [] = do+checkRecordExpr _ spi c [] = do m <- getModuleIdent env <- getRenameEnv case qualLookupVar c env of- [Constr _ _] -> return $ Record () c []+ [Constr _ _] -> return $ Record spi () c [] rs -> case qualLookupVar (qualQualify m c) env of- [Constr _ _] -> return $ Record () c []- rs' -> if (null rs && null rs')+ [Constr _ _] -> return $ Record spi () c []+ rs' -> if null rs && null rs' then do report $ errUndefinedData c- return $ Record () c []+ return $ Record spi () c [] else do report $ errAmbiguousData rs c- return $ Record () c []-checkRecordExpr p c fs = checkExpr p (RecordUpdate (Constructor () c) fs)+ return $ Record spi () c []+checkRecordExpr p spi c fs =+ checkExpr p (RecordUpdate spi (Constructor (getSpanInfo c) () c)+ fs) -checkRecordUpdExpr :: Position -> Expression () -> [Field (Expression ())]- -> SCM (Expression ())-checkRecordUpdExpr p e fs = do+checkRecordUpdExpr :: SpanInfo -> SpanInfo -> Expression ()+ -> [Field (Expression ())] -> SCM (Expression ())+checkRecordUpdExpr p spi e fs = do e' <- checkExpr p e fs' <- mapM (checkField (checkExpr p)) fs case e' of- Constructor a c -> do checkFieldLabels "construction" p (Just c) fs'- return $ Record a c fs'- _ -> do checkFieldLabels "update" p Nothing fs'- return $ RecordUpdate e' fs'+ Constructor _ a c -> do checkFieldLabels "construction" p (Just c) fs'+ return $ Record spi a c fs'+ _ -> do checkFieldLabels "update" p Nothing fs'+ return $ RecordUpdate spi e' fs' -- * Because patterns or decls eventually introduce new variables, the -- scope has to be nested one level. -- * Because statements are processed list-wise, inNestedEnv can not be -- used as this nesting must be visible to following statements.-checkStatement :: String -> Position -> Statement () -> SCM (Statement ())-checkStatement _ p (StmtExpr e) = StmtExpr <$> checkExpr p e-checkStatement s p (StmtBind t e) =- flip StmtBind <$> checkExpr p e <*> (incNesting >> bindPattern s p t)-checkStatement _ _ (StmtDecl ds) =- StmtDecl <$> (incNesting >> checkDeclGroup bindVarDecl ds)+checkStatement :: String -> SpanInfo -> Statement () -> SCM (Statement ())+checkStatement _ p (StmtExpr spi e) = StmtExpr spi <$> checkExpr p e+checkStatement s p (StmtBind spi t e) =+ flip (StmtBind spi) <$> checkExpr p e <*> (incNesting >> bindPattern s p t)+checkStatement _ _ (StmtDecl spi ds) =+ StmtDecl spi <$> (incNesting >> checkDeclGroup bindVarDecl ds) -bindPattern :: String -> Position -> Pattern () -> SCM (Pattern ())+bindPattern :: String -> SpanInfo -> Pattern () -> SCM (Pattern ()) bindPattern s p t = do t' <- checkPattern p t banFPTerm s p t' addBoundVariables True t' -banFPTerm :: String -> Position -> Pattern a -> SCM ()-banFPTerm _ _ (LiteralPattern _ _) = ok-banFPTerm _ _ (NegativePattern _ _) = ok-banFPTerm _ _ (VariablePattern _ _) = ok-banFPTerm s p (ConstructorPattern _ _ ts) = mapM_ (banFPTerm s p) ts-banFPTerm s p (InfixPattern _ t1 _ t2) = mapM_ (banFPTerm s p) [t1, t2]-banFPTerm s p (ParenPattern t) = banFPTerm s p t-banFPTerm s p (RecordPattern _ _ fs) = mapM_ banFPTermField fs+banFPTerm :: String -> SpanInfo -> Pattern a -> SCM ()+banFPTerm _ _ (LiteralPattern _ _ _) = ok+banFPTerm _ _ (NegativePattern _ _ _) = ok+banFPTerm _ _ (VariablePattern _ _ _) = ok+banFPTerm s p (ConstructorPattern _ _ _ ts) = mapM_ (banFPTerm s p) ts+banFPTerm s p (InfixPattern _ _ t1 _ t2) = mapM_ (banFPTerm s p) [t1, t2]+banFPTerm s p (ParenPattern _ t) = banFPTerm s p t+banFPTerm s p (RecordPattern _ _ _ fs) = mapM_ banFPTermField fs where banFPTermField (Field _ _ x) = banFPTerm s p x-banFPTerm s p (TuplePattern ts) = mapM_ (banFPTerm s p) ts-banFPTerm s p (ListPattern _ ts) = mapM_ (banFPTerm s p) ts-banFPTerm s p (AsPattern _ t) = banFPTerm s p t-banFPTerm s p (LazyPattern t) = banFPTerm s p t-banFPTerm s p pat@(FunctionPattern _ _ _)- = report $ errUnsupportedFuncPattern s p pat-banFPTerm s p pat@(InfixFuncPattern _ _ _ _)- = report $ errUnsupportedFuncPattern s p pat+banFPTerm s p (TuplePattern _ ts) = mapM_ (banFPTerm s p) ts+banFPTerm s p (ListPattern _ _ ts) = mapM_ (banFPTerm s p) ts+banFPTerm s p (AsPattern _ _ t) = banFPTerm s p t+banFPTerm s p (LazyPattern _ t) = banFPTerm s p t+banFPTerm s p pat@(FunctionPattern _ _ _ _)+ = report $ errUnsupportedFuncPattern s (spanInfo2Pos p) pat+banFPTerm s p pat@(InfixFuncPattern _ _ _ _ _)+ = report $ errUnsupportedFuncPattern s (spanInfo2Pos p) pat checkOp :: InfixOp a -> SCM (InfixOp a) checkOp op = do@@ -1028,8 +1044,8 @@ a = opAnnotation op checkAlt :: Alt () -> SCM (Alt ())-checkAlt (Alt p t rhs) = inNestedScope $- Alt p <$> bindPattern "case expression" p t <*> checkRhs rhs+checkAlt (Alt spi t rhs) = inNestedScope $+ Alt spi <$> bindPattern "case expression" spi t <*> checkRhs rhs addBoundVariables :: (QuantExpr t) => Bool -> t -> SCM t addBoundVariables checkDuplicates ts = do@@ -1048,7 +1064,7 @@ -- shadowed by local variables (cf.\ Sect.~3.15.1 of the revised -- Haskell'98 report~\cite{PeytonJones03:Haskell}). -checkFieldLabels :: String -> Position -> Maybe QualIdent -> [Field a] -> SCM ()+checkFieldLabels :: String -> SpanInfo -> Maybe QualIdent -> [Field a] -> SCM () checkFieldLabels what p c fs = do mapM checkFieldLabel ls' >>= checkLabels p c ls' onJust (report . errDuplicateLabel what) (findDouble ls)@@ -1075,7 +1091,7 @@ when (null cs') $ report $ errUndefinedLabel l return cs' -checkLabels :: Position -> Maybe QualIdent -> [QualIdent] -> [[QualIdent]]+checkLabels :: SpanInfo -> Maybe QualIdent -> [QualIdent] -> [[QualIdent]] -> SCM () checkLabels _ (Just c) ls css = do env <- getRenameEnv@@ -1085,7 +1101,8 @@ _ -> internalError $ "Checks.SyntaxCheck.checkLabels: " ++ show c checkLabels p Nothing ls css =- when (null (foldr1 intersect css)) $ report $ errNoCommonCons p ls+ when (null (foldr1 intersect css))+ $ report $ errNoCommonCons (spanInfo2Pos p) ls checkField :: (a -> SCM a) -> Field a -> SCM (Field a) checkField check (Field p l x) = Field p l <$> check x@@ -1188,23 +1205,24 @@ genFuncPattAppl :: Pattern () -> [Pattern ()] -> Pattern () genFuncPattAppl term [] = term genFuncPattAppl term (t:ts)- = FunctionPattern () qApplyId [genFuncPattAppl term ts, t]+ = FunctionPattern NoSpanInfo () qApplyId [genFuncPattAppl term ts, t] -- TODO FIXME major problem -checkFPTerm :: Position -> Pattern a -> SCM ()-checkFPTerm _ (LiteralPattern _ _) = ok-checkFPTerm _ (NegativePattern _ _) = ok-checkFPTerm _ (VariablePattern _ _) = ok-checkFPTerm p (ConstructorPattern _ _ ts) = mapM_ (checkFPTerm p) ts-checkFPTerm p (InfixPattern _ t1 _ t2) = mapM_ (checkFPTerm p) [t1, t2]-checkFPTerm p (ParenPattern t) = checkFPTerm p t-checkFPTerm p (TuplePattern ts) = mapM_ (checkFPTerm p) ts-checkFPTerm p (ListPattern _ ts) = mapM_ (checkFPTerm p) ts-checkFPTerm p (AsPattern _ t) = checkFPTerm p t-checkFPTerm p t@(LazyPattern _) = report $ errUnsupportedFPTerm "Lazy" p t-checkFPTerm p (RecordPattern _ _ fs) = mapM_ (checkFPTerm p)+checkFPTerm :: SpanInfo -> Pattern a -> SCM ()+checkFPTerm _ (LiteralPattern _ _ _) = ok+checkFPTerm _ (NegativePattern _ _ _) = ok+checkFPTerm _ (VariablePattern _ _ _) = ok+checkFPTerm p (ConstructorPattern _ _ _ ts) = mapM_ (checkFPTerm p) ts+checkFPTerm p (InfixPattern _ _ t1 _ t2) = mapM_ (checkFPTerm p) [t1, t2]+checkFPTerm p (ParenPattern _ t) = checkFPTerm p t+checkFPTerm p (TuplePattern _ ts) = mapM_ (checkFPTerm p) ts+checkFPTerm p (ListPattern _ _ ts) = mapM_ (checkFPTerm p) ts+checkFPTerm p (AsPattern _ _ t) = checkFPTerm p t+checkFPTerm p t@(LazyPattern _ _) =+ report $ errUnsupportedFPTerm "Lazy" (spanInfo2Pos p) t+checkFPTerm p (RecordPattern _ _ _ fs) = mapM_ (checkFPTerm p) [ t | Field _ _ t <- fs ]-checkFPTerm _ (FunctionPattern _ _ _) = ok -- do not check again-checkFPTerm _ (InfixFuncPattern _ _ _ _) = ok -- do not check again+checkFPTerm _ (FunctionPattern _ _ _ _) = ok -- do not check again+checkFPTerm _ (InfixFuncPattern _ _ _ _ _) = ok -- do not check again -- --------------------------------------------------------------------------- -- Miscellaneous functions@@ -1226,8 +1244,8 @@ enableExtension ext -- to avoid multiple warnings typeArity :: TypeExpr -> Int-typeArity (ArrowType _ t2) = 1 + typeArity t2-typeArity _ = 0+typeArity (ArrowType _ _ t2) = 1 + typeArity t2+typeArity _ = 0 getFlatLhs :: Equation a -> (Ident, [Pattern a]) getFlatLhs (Equation _ lhs _) = flatLhs lhs@@ -1388,4 +1406,4 @@ where showCall (q1, q2) = showWithPos q1 <+> text "calls" <+> showWithPos q2 showWithPos q = text (qualName q)- <+> parens (text $ showLine $ qidPosition q)+ <+> parens (text $ showLine $ getPosition q)
src/Checks/TypeCheck.hs view
@@ -36,6 +36,10 @@ {-# LANGUAGE CPP #-} module Checks.TypeCheck (typeCheck) where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif@@ -55,6 +59,7 @@ import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty+import Curry.Base.SpanInfo import Curry.Syntax import Curry.Syntax.Pretty @@ -295,8 +300,8 @@ ok checkFieldLabel _ = ok -tcFieldLabel :: [Ident] -> (Ident, Position, TypeExpr)- -> TCM (Ident, Position, Type)+tcFieldLabel :: HasPosition p => [Ident] -> (Ident, p, TypeExpr)+ -> TCM (Ident, p, Type) tcFieldLabel tvs (l, p, ty) = do m <- getModuleIdent tcEnv <- getTyConsEnv@@ -310,9 +315,9 @@ (x, y, z : map thd3 xyzs') : groupLabels xyzs'' where (xyzs', xyzs'') = partition ((x ==) . fst3) xyzs -tcFieldLabels :: (Ident, Position, [Type]) -> TCM ()+tcFieldLabels :: HasPosition p => (Ident, p, [Type]) -> TCM () tcFieldLabels (_, _, []) = return ()-tcFieldLabels (l, p, ty:tys) = unless (null (filter (ty /=) tys)) $ do+tcFieldLabels (l, p, ty:tys) = unless (not (any (ty /=) tys)) $ do m <- getModuleIdent report $ errIncompatibleLabelTypes p m l ty (head tys) @@ -385,7 +390,8 @@ setDefaults (DefaultDecl _ tys) = mapM toDefaultType tys >>= setDefaultTypes where toDefaultType =- liftM snd . (inst =<<) . liftM typeScheme . expandPoly . QualTypeExpr []+ liftM snd . (inst =<<) . liftM typeScheme+ . expandPoly . QualTypeExpr NoSpanInfo [] setDefaults _ = ok -- Type Signatures:@@ -472,7 +478,7 @@ where implicit pd ~(impPds, expPds) = (pd : impPds, expPds) explicit pd qty ~(impPds, expPds) = (impPds, (qty, pd) : expPds) typeSig (FunctionDecl _ _ f _) = lookupTypeSig f sigs- typeSig (PatternDecl _ (VariablePattern _ v) _) = lookupTypeSig v sigs+ typeSig (PatternDecl _ (VariablePattern _ _ v) _) = lookupTypeSig v sigs typeSig _ = Nothing bindVars :: ModuleIdent -> ValueEnv -> [(Ident, Int, TypeScheme)] -> ValueEnv@@ -493,7 +499,7 @@ tys <- replicateM (n + 1) freshTypeVar return [(f, n, monoType $ foldr1 TypeArrow tys)] tcDeclVars (PatternDecl _ t _) = case t of- VariablePattern _ v -> return <$> tcDeclVar True v+ VariablePattern _ _ v -> return <$> tcDeclVar True v _ -> mapM (tcDeclVar False) (bv t) tcDeclVars _ = internalError "TypeCheck.tcDeclVars" @@ -525,7 +531,7 @@ -- signature. This prevents missing instance errors when the inferred type -- of a function is less general than the declared type. -tcFunctionPDecl :: Int -> PredSet -> TypeScheme -> Position -> Ident+tcFunctionPDecl :: Int -> PredSet -> TypeScheme -> SpanInfo -> Ident -> [Equation a] -> TCM (PredSet, (Type, PDecl PredType)) tcFunctionPDecl i ps tySc@(ForAll _ pty) p f eqs = do (_, ty) <- inst tySc@@ -538,7 +544,7 @@ tcEquation fs ty ps eqn@(Equation p lhs rhs) = tcEqn fs p lhs rhs >>- unifyDecl p "equation" (ppEquation eqn) ps ty -tcEqn :: Set.Set Int -> Position -> Lhs a -> Rhs a+tcEqn :: Set.Set Int -> SpanInfo -> Lhs a -> Rhs a -> TCM (PredSet, Type, Equation PredType) tcEqn fs p lhs rhs = do (ps, tys, lhs', ps', ty, rhs') <- withLocalValueEnv $ do@@ -561,7 +567,7 @@ ty <- freshTypeVar return (v, 0, monoType ty) -unifyDecl :: Position -> String -> Doc -> PredSet -> Type -> PredSet -> Type+unifyDecl :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet -> Type -> TCM PredSet unifyDecl p what doc psLhs tyLhs psRhs tyRhs = do ps <- unify p what doc psLhs tyLhs psRhs tyRhs@@ -579,12 +585,12 @@ defaultPDecl fvs ps ty (_, FunctionDecl p _ f _) = applyDefaultsDecl p ("function " ++ escName f) empty fvs ps ty defaultPDecl fvs ps ty (_, PatternDecl p t _) = case t of- VariablePattern _ v ->+ VariablePattern _ _ v -> applyDefaultsDecl p ("variable " ++ escName v) empty fvs ps ty _ -> return ps defaultPDecl _ _ _ _ = internalError "TypeCheck.defaultPDecl" -applyDefaultsDecl :: Position -> String -> Doc -> Set.Set Int -> PredSet -> Type+applyDefaultsDecl :: HasPosition p => p -> String -> Doc -> Set.Set Int -> PredSet -> Type -> TCM PredSet applyDefaultsDecl p what doc fvs ps ty = do theta <- getTypeSubst@@ -602,14 +608,15 @@ fixType ~(ForAll _ pty) (i, FunctionDecl p _ f eqs) = (i, FunctionDecl p pty f eqs) fixType ~(ForAll _ pty) pd@(i, PatternDecl p t rhs) = case t of- VariablePattern _ v -> (i, PatternDecl p (VariablePattern pty v) rhs)+ VariablePattern spi _ v+ -> (i, PatternDecl p (VariablePattern spi pty v) rhs) _ -> pd fixType _ _ = internalError "TypeCheck.fixType" declVars :: Decl PredType -> [(Ident, Int, TypeScheme)] declVars (FunctionDecl _ pty f eqs) = [(f, eqnArity $ head eqs, typeScheme pty)] declVars (PatternDecl _ t _) = case t of- VariablePattern pty v -> [(v, 0, typeScheme pty)]+ VariablePattern _ pty v -> [(v, 0, typeScheme pty)] _ -> [] declVars _ = internalError "TypeCheck.declVars" @@ -642,12 +649,12 @@ m <- getModuleIdent report $ errTypeSigTooGeneral p m (text "Function:" <+> ppIdent f) qty tySc return (ps, (i, FunctionDecl p pty f eqs))-checkPDeclType qty ps tySc (i, PatternDecl p (VariablePattern _ v) rhs) = do+checkPDeclType qty ps tySc (i, PatternDecl p (VariablePattern spi _ v) rhs) = do pty <- expandPoly qty unlessM (checkTypeSig pty tySc) $ do m <- getModuleIdent report $ errTypeSigTooGeneral p m (text "Variable:" <+> ppIdent v) qty tySc- return (ps, (i, PatternDecl p (VariablePattern pty v) rhs))+ return (ps, (i, PatternDecl p (VariablePattern spi pty v) rhs)) checkPDeclType _ _ _ _ = internalError "TypeCheck.checkPDeclType" checkTypeSig :: PredType -> TypeScheme -> TCM Bool@@ -744,7 +751,7 @@ sigs <- getSigEnv modifyValueEnv $ flip (foldr (bindDeclArity m tcEnv clsEnv sigs)) ds isNonExpansive e &&^ isNonExpansive ds- isNonExpansive (GuardedRhs _ _) = return False+ isNonExpansive (GuardedRhs _ _ _) = return False -- A record construction is non-expansive only if all field labels are present. @@ -752,8 +759,8 @@ isNonExpansive = isNonExpansive' 0 isNonExpansive' :: Int -> Expression a -> TCM Bool-isNonExpansive' _ (Literal _ _) = return True-isNonExpansive' n (Variable _ v)+isNonExpansive' _ (Literal _ _ _) = return True+isNonExpansive' n (Variable _ _ v) | v' == anonId = return False | isRenamed v' = do vEnv <- getValueEnv@@ -762,27 +769,27 @@ vEnv <- getValueEnv return $ n < varArity v vEnv where v' = unqualify v-isNonExpansive' _ (Constructor _ _) = return True-isNonExpansive' n (Paren e) = isNonExpansive' n e-isNonExpansive' n (Typed e _) = isNonExpansive' n e-isNonExpansive' _ (Record _ c fs) = do+isNonExpansive' _ (Constructor _ _ _) = return True+isNonExpansive' n (Paren _ e) = isNonExpansive' n e+isNonExpansive' n (Typed _ e _) = isNonExpansive' n e+isNonExpansive' _ (Record _ _ c fs) = do m <- getModuleIdent vEnv <- getValueEnv liftM ((length (constrLabels m c vEnv) == length fs) &&) (isNonExpansive fs)-isNonExpansive' _ (Tuple es) = isNonExpansive es-isNonExpansive' _ (List _ es) = isNonExpansive es-isNonExpansive' n (Apply f e) =+isNonExpansive' _ (Tuple _ es) = isNonExpansive es+isNonExpansive' _ (List _ _ es) = isNonExpansive es+isNonExpansive' n (Apply _ f e) = isNonExpansive' (n + 1) f &&^ isNonExpansive e-isNonExpansive' n (InfixApply e1 op e2) =+isNonExpansive' n (InfixApply _ e1 op e2) = isNonExpansive' (n + 2) (infixOp op) &&^ isNonExpansive e1 &&^ isNonExpansive e2-isNonExpansive' n (LeftSection e op) =+isNonExpansive' n (LeftSection _ e op) = isNonExpansive' (n + 1) (infixOp op) &&^ isNonExpansive e-isNonExpansive' n (Lambda ts e) = withLocalValueEnv $ do+isNonExpansive' n (Lambda _ ts e) = withLocalValueEnv $ do modifyValueEnv $ flip (foldr bindVarArity) (bv ts) liftM ((n < length ts) ||) (liftM ((all isVariablePattern ts) &&) (isNonExpansive' (n - length ts) e))-isNonExpansive' n (Let ds e) = withLocalValueEnv $ do+isNonExpansive' n (Let _ ds e) = withLocalValueEnv $ do m <- getModuleIdent tcEnv <- getTyConsEnv clsEnv <- getClassEnv@@ -858,7 +865,7 @@ tcTopPDecl (i, InstanceDecl p cx qcls ty ds) = do tcEnv <- getTyConsEnv let ocls = origName $ head $ qualLookupTypeInfo qcls tcEnv- pty <- expandPoly $ QualTypeExpr cx ty+ pty <- expandPoly $ QualTypeExpr NoSpanInfo cx ty vpds' <- mapM (tcInstanceMethodPDecl ocls pty) vpds return (i, InstanceDecl p cx qcls ty $ fromPDecls $ map untyped opds ++ vpds') where (vpds, opds) = partition (isValueDecl . snd) $ toPDecls ds@@ -869,8 +876,9 @@ methTy <- classMethodType qualify f (tySc, pd') <- tcMethodPDecl methTy pd sigs <- getSigEnv- let QualTypeExpr cx ty = fromJust $ lookupTypeSig f sigs- qty = QualTypeExpr (Constraint qcls (VariableType tv) : cx) ty+ let QualTypeExpr spi cx ty = fromJust $ lookupTypeSig f sigs+ qty = QualTypeExpr spi+ (Constraint NoSpanInfo qcls (VariableType NoSpanInfo tv) : cx) ty checkClassMethodType qty tySc pd' tcClassMethodPDecl _ _ _ = internalError "TypeCheck.tcClassMethodPDecl" @@ -933,9 +941,9 @@ sigs <- getSigEnv case lookupTypeSig f sigs of Nothing -> internalError "TypeCheck.tcExternal: type signature not found"- Just (QualTypeExpr _ ty) -> do+ Just (QualTypeExpr _ _ ty) -> do m <- getModuleIdent- PredType _ ty' <- expandPoly $ QualTypeExpr [] ty+ PredType _ ty' <- expandPoly $ QualTypeExpr NoSpanInfo [] ty modifyValueEnv $ bindFun m f False (arrowArity ty') (polyType ty') return ty' @@ -955,18 +963,18 @@ | otherwise = liftM ((,) emptyPredSet) (freshConstrained fractionalTypes) tcLiteral _ (String _) = return (emptyPredSet, stringType) -tcLhs :: Position -> Lhs a -> TCM (PredSet, [Type], Lhs PredType)-tcLhs p (FunLhs f ts) = do+tcLhs :: HasPosition p => p -> Lhs a -> TCM (PredSet, [Type], Lhs PredType)+tcLhs p (FunLhs spi f ts) = do (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts- return (Set.unions pss, tys, FunLhs f ts')-tcLhs p (OpLhs t1 op t2) = do+ return (Set.unions pss, tys, FunLhs spi f ts')+tcLhs p (OpLhs spi t1 op t2) = do (ps1, ty1, t1') <- tcPattern p t1 (ps2, ty2, t2') <- tcPattern p t2- return (ps1 `Set.union` ps2, [ty1, ty2], OpLhs t1' op t2')-tcLhs p (ApLhs lhs ts) = do+ return (ps1 `Set.union` ps2, [ty1, ty2], OpLhs spi t1' op t2')+tcLhs p (ApLhs spi lhs ts) = do (ps, tys1, lhs') <- tcLhs p lhs (pss, tys2, ts') <- liftM unzip3 $ mapM (tcPattern p) ts- return (Set.unions (ps:pss), tys1 ++ tys2, ApLhs lhs' ts')+ return (Set.unions (ps:pss), tys1 ++ tys2, ApLhs spi lhs' ts') -- When computing the type of a variable in a pattern, we ignore the -- predicate set of the variable's type (which can only be due to a type@@ -975,76 +983,76 @@ -- checked as constructor and functional patterns, respectively, resulting -- in slighty misleading error messages if the type check fails. -tcPattern :: Position -> Pattern a -> TCM (PredSet, Type, Pattern PredType)-tcPattern _ (LiteralPattern _ l) = do+tcPattern :: HasPosition p => p -> Pattern a -> TCM (PredSet, Type, Pattern PredType)+tcPattern _ (LiteralPattern spi _ l) = do (ps, ty) <- tcLiteral False l- return (ps, ty, LiteralPattern (predType ty) l)-tcPattern _ (NegativePattern _ l) = do+ return (ps, ty, LiteralPattern spi (predType ty) l)+tcPattern _ (NegativePattern spi _ l) = do (ps, ty) <- tcLiteral False l- return (ps, ty, NegativePattern (predType ty) l)-tcPattern _ (VariablePattern _ v) = do+ return (ps, ty, NegativePattern spi (predType ty) l)+tcPattern _ (VariablePattern spi _ v) = do vEnv <- getValueEnv (_, ty) <- inst (varType v vEnv)- return (emptyPredSet, ty, VariablePattern (predType ty) v)-tcPattern p t@(ConstructorPattern _ c ts) = do+ return (emptyPredSet, ty, VariablePattern spi (predType ty) v)+tcPattern p t@(ConstructorPattern spi _ c ts) = do m <- getModuleIdent vEnv <- getValueEnv (ps, (tys, ty')) <- liftM (fmap arrowUnapply) (skol (constrType m c vEnv)) (ps', ts') <- mapAccumM (uncurry . tcPatternArg p "pattern" (ppPattern 0 t)) ps (zip tys ts)- return (ps', ty', ConstructorPattern (predType ty') c ts')-tcPattern p (InfixPattern a t1 op t2) = do- (ps, ty, ConstructorPattern a' op' [t1', t2']) <-- tcPattern p (ConstructorPattern a op [t1, t2])- return (ps, ty, InfixPattern a' t1' op' t2')-tcPattern p (ParenPattern t) = do+ return (ps', ty', ConstructorPattern spi (predType ty') c ts')+tcPattern p (InfixPattern spi a t1 op t2) = do+ (ps, ty, ConstructorPattern _ a' op' [t1', t2']) <-+ tcPattern p (ConstructorPattern NoSpanInfo a op [t1, t2])+ return (ps, ty, InfixPattern spi a' t1' op' t2')+tcPattern p (ParenPattern spi t) = do (ps, ty, t') <- tcPattern p t- return (ps, ty, ParenPattern t')-tcPattern _ t@(RecordPattern _ c fs) = do+ return (ps, ty, ParenPattern spi t')+tcPattern _ t@(RecordPattern spi _ c fs) = do m <- getModuleIdent vEnv <- getValueEnv (ps, ty) <- liftM (fmap arrowBase) (skol (constrType m c vEnv)) (ps', fs') <- mapAccumM (tcField tcPattern "pattern" (\t' -> ppPattern 0 t $-$ text "Term:" <+> ppPattern 0 t') ty) ps fs- return (ps', ty, RecordPattern (predType ty) c fs')-tcPattern p (TuplePattern ts) = do+ return (ps', ty, RecordPattern spi (predType ty) c fs')+tcPattern p (TuplePattern spi ts) = do (pss, tys, ts') <- liftM unzip3 $ mapM (tcPattern p) ts- return (Set.unions pss, tupleType tys, TuplePattern ts')-tcPattern p t@(ListPattern _ ts) = do+ return (Set.unions pss, tupleType tys, TuplePattern spi ts')+tcPattern p t@(ListPattern spi _ ts) = do ty <- freshTypeVar (ps, ts') <- mapAccumM (flip (tcPatternArg p "pattern" (ppPattern 0 t)) ty) emptyPredSet ts- return (ps, listType ty, ListPattern (predType $ listType ty) ts')-tcPattern p t@(AsPattern v t') = do+ return (ps, listType ty, ListPattern spi (predType $ listType ty) ts')+tcPattern p t@(AsPattern spi v t') = do vEnv <- getValueEnv (_, ty) <- inst (varType v vEnv) (ps, t'') <- tcPattern p t' >>- unify p "pattern" (ppPattern 0 t) emptyPredSet ty- return (ps, ty, AsPattern v t'')-tcPattern p (LazyPattern t) = do+ return (ps, ty, AsPattern spi v t'')+tcPattern p (LazyPattern spi t) = do (ps, ty, t') <- tcPattern p t- return (ps, ty, LazyPattern t')-tcPattern p t@(FunctionPattern _ f ts) = do+ return (ps, ty, LazyPattern spi t')+tcPattern p t@(FunctionPattern spi _ f ts) = do m <- getModuleIdent vEnv <- getValueEnv (ps, ty) <- inst (funType m f vEnv)- tcFuncPattern p (ppPattern 0 t) f id ps ty ts-tcPattern p (InfixFuncPattern a t1 op t2) = do- (ps, ty, FunctionPattern a' op' [t1', t2']) <-- tcPattern p (FunctionPattern a op [t1, t2])- return (ps, ty, InfixFuncPattern a' t1' op' t2')+ tcFuncPattern p spi (ppPattern 0 t) f id ps ty ts+tcPattern p (InfixFuncPattern spi a t1 op t2) = do+ (ps, ty, FunctionPattern _ a' op' [t1', t2']) <-+ tcPattern p (FunctionPattern spi a op [t1, t2])+ return (ps, ty, InfixFuncPattern spi a' t1' op' t2') -tcFuncPattern :: Position -> Doc -> QualIdent+tcFuncPattern :: HasPosition p => p -> SpanInfo -> Doc -> QualIdent -> ([Pattern PredType] -> [Pattern PredType]) -> PredSet -> Type -> [Pattern a] -> TCM (PredSet, Type, Pattern PredType)-tcFuncPattern _ _ f ts ps ty [] =- return (ps, ty, FunctionPattern (predType ty) f (ts []))-tcFuncPattern p doc f ts ps ty (t':ts') = do+tcFuncPattern _ spi _ f ts ps ty [] =+ return (ps, ty, FunctionPattern spi (predType ty) f (ts []))+tcFuncPattern p spi doc f ts ps ty (t':ts') = do (alpha, beta) <- tcArrow p "functional pattern" (doc $-$ text "Term:" <+> ppPattern 0 t) ty (ps', t'') <- tcPatternArg p "functional pattern" doc ps alpha t'- tcFuncPattern p doc f (ts . (t'' :)) ps' beta ts'- where t = FunctionPattern (predType ty) f (ts [])+ tcFuncPattern p spi doc f (ts . (t'' :)) ps' beta ts'+ where t = FunctionPattern spi (predType ty) f (ts []) -tcPatternArg :: Position -> String -> Doc -> PredSet -> Type+tcPatternArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> Pattern a -> TCM (PredSet, Pattern PredType) tcPatternArg p what doc ps ty t = tcPattern p t >>-@@ -1058,11 +1066,11 @@ return (ps, ds', ps', ty, e') ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps') return (ps'', ty, SimpleRhs p e' ds')-tcRhs (GuardedRhs es ds) = withLocalValueEnv $ do+tcRhs (GuardedRhs spi es ds) = withLocalValueEnv $ do (ps, ds') <- tcDecls ds ty <- freshTypeVar (ps', es') <- mapAccumM (tcCondExpr ty) ps es- return (ps', ty, GuardedRhs es' ds')+ return (ps', ty, GuardedRhs spi es' ds') tcCondExpr :: Type -> PredSet -> CondExpr a -> TCM (PredSet, CondExpr PredType) tcCondExpr ty ps (CondExpr p g e) = do@@ -1070,25 +1078,25 @@ (ps'', e') <- tcExpr p e >>- unify p "guarded expression" (ppExpr 0 e) ps' ty return (ps'', CondExpr p g' e') -tcExpr :: Position -> Expression a -> TCM (PredSet, Type, Expression PredType)-tcExpr _ (Literal _ l) = do+tcExpr :: HasPosition p => p -> Expression a -> TCM (PredSet, Type, Expression PredType)+tcExpr _ (Literal spi _ l) = do (ps, ty) <- tcLiteral True l- return (ps, ty, Literal (predType ty) l)-tcExpr _ (Variable _ v) = do+ return (ps, ty, Literal spi (predType ty) l)+tcExpr _ (Variable spi _ v) = do m <- getModuleIdent vEnv <- getValueEnv (ps, ty) <- if isAnonId (unqualify v) then freshPredType [] else inst (funType m v vEnv)- return (ps, ty, Variable (predType ty) v)-tcExpr _ (Constructor _ c) = do+ return (ps, ty, Variable spi (predType ty) v)+tcExpr _ (Constructor spi _ c) = do m <- getModuleIdent vEnv <- getValueEnv (ps, ty) <- instExist (constrType m c vEnv)- return (ps, ty, Constructor (predType ty) c)-tcExpr p (Paren e) = do+ return (ps, ty, Constructor spi (predType ty) c)+tcExpr p (Paren spi e) = do (ps, ty, e') <- tcExpr p e- return (ps, ty, Paren e')-tcExpr p (Typed e qty) = do+ return (ps, ty, Paren spi e')+tcExpr p (Typed spi e qty) = do pty <- expandPoly qty (ps, ty) <- inst (typeScheme pty) (ps', e') <- tcExpr p e >>-@@ -1101,26 +1109,26 @@ m <- getModuleIdent report $ errTypeSigTooGeneral p m (text "Expression:" <+> ppExpr 0 e) qty tySc- return (ps `Set.union` gps, ty, Typed e' qty)-tcExpr _ e@(Record _ c fs) = do+ return (ps `Set.union` gps, ty, Typed spi e' qty)+tcExpr _ e@(Record spi _ c fs) = do m <- getModuleIdent vEnv <- getValueEnv (ps, ty) <- liftM (fmap arrowBase) (instExist (constrType m c vEnv)) (ps', fs') <- mapAccumM (tcField tcExpr "construction" (\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs- return (ps', ty, Record (predType ty) c fs')-tcExpr p e@(RecordUpdate e1 fs) = do+ return (ps', ty, Record spi (predType ty) c fs')+tcExpr p e@(RecordUpdate spi e1 fs) = do (ps, ty, e1') <- tcExpr p e1 (ps', fs') <- mapAccumM (tcField tcExpr "update" (\e' -> ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e') ty) ps fs- return (ps', ty, RecordUpdate e1' fs')-tcExpr p (Tuple es) = do+ return (ps', ty, RecordUpdate spi e1' fs')+tcExpr p (Tuple spi es) = do (pss, tys, es') <- liftM unzip3 $ mapM (tcExpr p) es- return (Set.unions pss, tupleType tys, Tuple es')-tcExpr p e@(List _ es) = do+ return (Set.unions pss, tupleType tys, Tuple spi es')+tcExpr p e@(List spi _ es) = do ty <- freshTypeVar (ps, es') <- mapAccumM (flip (tcArg p "expression" (ppExpr 0 e)) ty) emptyPredSet es- return (ps, listType ty, List (predType $ listType ty) es')-tcExpr p (ListCompr e qs) = do+ return (ps, listType ty, List spi (predType $ listType ty) es')+tcExpr p (ListCompr spi e qs) = do fs <- computeFsEnv (ps, qs', ps', ty, e') <- withLocalValueEnv $ do (ps, qs') <- mapAccumM (tcQual p) emptyPredSet qs@@ -1128,53 +1136,53 @@ return (ps, qs', ps', ty, e') ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps') checkSkolems p "Expression" (ppExpr 0) fs ps'' (listType ty)- (ListCompr e' qs')-tcExpr p e@(EnumFrom e1) = do+ (ListCompr spi e' qs')+tcExpr p e@(EnumFrom spi e1) = do (ps, ty) <- freshEnumType (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1- return (ps', listType ty, EnumFrom e1')-tcExpr p e@(EnumFromThen e1 e2) = do+ return (ps', listType ty, EnumFrom spi e1')+tcExpr p e@(EnumFromThen spi e1 e2) = do (ps, ty) <- freshEnumType (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1 (ps'', e2') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps' ty e2- return (ps'', listType ty, EnumFromThen e1' e2')-tcExpr p e@(EnumFromTo e1 e2) = do+ return (ps'', listType ty, EnumFromThen spi e1' e2')+tcExpr p e@(EnumFromTo spi e1 e2) = do (ps, ty) <- freshEnumType (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1 (ps'', e2') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps' ty e2- return (ps'', listType ty, EnumFromTo e1' e2')-tcExpr p e@(EnumFromThenTo e1 e2 e3) = do+ return (ps'', listType ty, EnumFromTo spi e1' e2')+tcExpr p e@(EnumFromThenTo spi e1 e2 e3) = do (ps, ty) <- freshEnumType (ps', e1') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps ty e1 (ps'', e2') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps' ty e2 (ps''', e3') <- tcArg p "arithmetic sequence" (ppExpr 0 e) ps'' ty e3- return (ps''', listType ty, EnumFromThenTo e1' e2' e3')-tcExpr p e@(UnaryMinus e1) = do+ return (ps''', listType ty, EnumFromThenTo spi e1' e2' e3')+tcExpr p e@(UnaryMinus spi e1) = do (ps, ty) <- freshNumType (ps', e1') <- tcArg p "unary negation" (ppExpr 0 e) ps ty e1- return (ps', ty, UnaryMinus e1')-tcExpr p e@(Apply e1 e2) = do+ return (ps', ty, UnaryMinus spi e1')+tcExpr p e@(Apply spi e1 e2) = do (ps, (alpha, beta), e1') <- tcExpr p e1 >>=- tcArrow p "application" (ppExpr 0 e $-$ text "Term:" <+> ppExpr 0 e1) (ps', e2') <- tcArg p "application" (ppExpr 0 e) ps alpha e2- return (ps', beta, Apply e1' e2')-tcExpr p e@(InfixApply e1 op e2) = do+ return (ps', beta, Apply spi e1' e2')+tcExpr p e@(InfixApply spi e1 op e2) = do (ps, (alpha, beta, gamma), op') <- tcInfixOp op >>=- tcBinary p "infix application" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) (ps', e1') <- tcArg p "infix application" (ppExpr 0 e) ps alpha e1 (ps'', e2') <- tcArg p "infix application" (ppExpr 0 e) ps' beta e2- return (ps'', gamma, InfixApply e1' op' e2')-tcExpr p e@(LeftSection e1 op) = do+ return (ps'', gamma, InfixApply spi e1' op' e2')+tcExpr p e@(LeftSection spi e1 op) = do (ps, (alpha, beta), op') <- tcInfixOp op >>=- tcArrow p "left section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) (ps', e1') <- tcArg p "left section" (ppExpr 0 e) ps alpha e1- return (ps', beta, LeftSection e1' op')-tcExpr p e@(RightSection op e1) = do+ return (ps', beta, LeftSection spi e1' op')+tcExpr p e@(RightSection spi op e1) = do (ps, (alpha, beta, gamma), op') <- tcInfixOp op >>=- tcBinary p "right section" (ppExpr 0 e $-$ text "Operator:" <+> ppOp op) (ps', e1') <- tcArg p "right section" (ppExpr 0 e) ps beta e1- return (ps', TypeArrow alpha gamma, RightSection op' e1')-tcExpr p (Lambda ts e) = do+ return (ps', TypeArrow alpha gamma, RightSection spi op' e1')+tcExpr p (Lambda spi ts e) = do fs <- computeFsEnv (pss, tys, ts', ps, ty, e')<- withLocalValueEnv $ do bindLambdaVars ts@@ -1183,16 +1191,16 @@ return (pss, tys, ts', ps, ty, e') ps' <- reducePredSet p "expression" (ppExpr 0 e') (Set.unions $ ps : pss) checkSkolems p "Expression" (ppExpr 0) fs ps' (foldr TypeArrow ty tys)- (Lambda ts' e')-tcExpr p (Let ds e) = do+ (Lambda spi ts' e')+tcExpr p (Let spi ds e) = do fs <- computeFsEnv (ps, ds', ps', ty, e') <- withLocalValueEnv $ do (ps, ds') <- tcDecls ds (ps', ty, e') <- tcExpr p e return (ps, ds', ps', ty, e') ps'' <- reducePredSet p "expression" (ppExpr 0 e') (ps `Set.union` ps')- checkSkolems p "Expression" (ppExpr 0) fs ps'' ty (Let ds' e')-tcExpr p (Do sts e) = do+ checkSkolems p "Expression" (ppExpr 0) fs ps'' ty (Let spi ds' e')+tcExpr p (Do spi sts e) = do fs <- computeFsEnv (sts', ty, ps', e') <- withLocalValueEnv $ do ((ps, mTy), sts') <-@@ -1200,20 +1208,20 @@ ty <- liftM (maybe id TypeApply mTy) freshTypeVar (ps', e') <- tcExpr p e >>- unify p "statement" (ppExpr 0 e) ps ty return (sts', ty, ps', e')- checkSkolems p "Expression" (ppExpr 0) fs ps' ty (Do sts' e')-tcExpr p e@(IfThenElse e1 e2 e3) = do+ checkSkolems p "Expression" (ppExpr 0) fs ps' ty (Do spi sts' e')+tcExpr p e@(IfThenElse spi e1 e2 e3) = do (ps, e1') <- tcArg p "expression" (ppExpr 0 e) emptyPredSet boolType e1 (ps', ty, e2') <- tcExpr p e2 (ps'', e3') <- tcArg p "expression" (ppExpr 0 e) (ps `Set.union` ps') ty e3- return (ps'', ty, IfThenElse e1' e2' e3')-tcExpr p (Case ct e as) = do+ return (ps'', ty, IfThenElse spi e1' e2' e3')+tcExpr p (Case spi ct e as) = do (ps, tyLhs, e') <- tcExpr p e tyRhs <- freshTypeVar fs <- computeFsEnv (ps', as') <- mapAccumM (tcAlt fs tyLhs tyRhs) ps as- return (ps', tyRhs, Case ct e' as')+ return (ps', tyRhs, Case spi ct e' as') -tcArg :: Position -> String -> Doc -> PredSet -> Type -> Expression a+tcArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> Expression a -> TCM (PredSet, Expression PredType) tcArg p what doc ps ty e = tcExpr p e >>- unify p what (doc $-$ text "Term:" <+> ppExpr 0 e) ps ty@@ -1224,7 +1232,7 @@ tcAltern fs tyLhs p t rhs >>- unify p "case alternative" (ppAlt a) ps tyRhs -tcAltern :: Set.Set Int -> Type -> Position -> Pattern a+tcAltern :: Set.Set Int -> Type -> SpanInfo -> Pattern a -> Rhs a -> TCM (PredSet, Type, Alt PredType) tcAltern fs tyLhs p t rhs = do (ps, t', ps', ty', rhs') <- withLocalValueEnv $ do@@ -1236,40 +1244,40 @@ ps'' <- reducePredSet p "alternative" (ppAlt (Alt p t' rhs')) (ps `Set.union` ps') checkSkolems p "Alternative" ppAlt fs ps'' ty' (Alt p t' rhs') -tcQual :: Position -> PredSet -> Statement a+tcQual :: HasPosition p => p -> PredSet -> Statement a -> TCM (PredSet, Statement PredType)-tcQual p ps (StmtExpr e) = do+tcQual p ps (StmtExpr spi e) = do (ps', e') <- tcExpr p e >>- unify p "guard" (ppExpr 0 e) ps boolType- return (ps', StmtExpr e')-tcQual _ ps (StmtDecl ds) = do+ return (ps', StmtExpr spi e')+tcQual _ ps (StmtDecl spi ds) = do (ps', ds') <- tcDecls ds- return (ps `Set.union` ps', StmtDecl ds')-tcQual p ps q@(StmtBind t e) = do+ return (ps `Set.union` ps', StmtDecl spi ds')+tcQual p ps q@(StmtBind spi t e) = do alpha <- freshTypeVar (ps', e') <- tcArg p "generator" (ppStmt q) ps (listType alpha) e bindLambdaVars t (ps'', t') <- tcPatternArg p "generator" (ppStmt q) ps' alpha t- return (ps'', StmtBind t' e')+ return (ps'', StmtBind spi t' e') -tcStmt :: Position -> PredSet -> Maybe Type -> Statement a+tcStmt :: HasPosition p => p -> PredSet -> Maybe Type -> Statement a -> TCM ((PredSet, Maybe Type), Statement PredType)-tcStmt p ps mTy (StmtExpr e) = do+tcStmt p ps mTy (StmtExpr spi e) = do (ps', ty) <- maybe freshMonadType (return . (,) emptyPredSet) mTy alpha <- freshTypeVar (ps'', e') <- tcExpr p e >>- unify p "statement" (ppExpr 0 e) (ps `Set.union` ps') (applyType ty [alpha])- return ((ps'', Just ty), StmtExpr e')-tcStmt _ ps mTy (StmtDecl ds) = do+ return ((ps'', Just ty), StmtExpr spi e')+tcStmt _ ps mTy (StmtDecl spi ds) = do (ps', ds') <- tcDecls ds- return ((ps `Set.union` ps', mTy), StmtDecl ds')-tcStmt p ps mTy st@(StmtBind t e) = do+ return ((ps `Set.union` ps', mTy), StmtDecl spi ds')+tcStmt p ps mTy st@(StmtBind spi t e) = do (ps', ty) <- maybe freshMonadType (return . (,) emptyPredSet) mTy alpha <- freshTypeVar (ps'', e') <- tcArg p "statement" (ppStmt st) (ps `Set.union` ps') (applyType ty [alpha]) e bindLambdaVars t (ps''', t') <- tcPatternArg p "statement" (ppStmt st) ps'' alpha t- return ((ps''', Just ty), StmtBind t' e')+ return ((ps''', Just ty), StmtBind spi t' e') tcInfixOp :: InfixOp a -> TCM (PredSet, Type, InfixOp PredType) tcInfixOp (InfixOp _ op) = do@@ -1294,14 +1302,14 @@ vEnv <- getValueEnv (ps', TypeArrow ty1 ty2) <- inst (labelType m l vEnv) _ <- unify p "field label" empty emptyPredSet ty emptyPredSet ty1- (ps'', x') <- check p x >>-+ (ps'', x') <- check (spanInfo2Pos p) x >>- unify p ("record " ++ what) (doc x) (ps `Set.union` ps') ty2 return (ps'', Field p l x') -- The function 'tcArrow' checks that its argument can be used as -- an arrow type a -> b and returns the pair (a,b). -tcArrow :: Position -> String -> Doc -> Type -> TCM (Type, Type)+tcArrow :: HasPosition p => p -> String -> Doc -> Type -> TCM (Type, Type) tcArrow p what doc ty = do theta <- getTypeSubst unaryArrow (subst theta ty)@@ -1320,7 +1328,7 @@ -- The function 'tcBinary' checks that its argument can be used as an arrow type -- a -> b -> c and returns the triple (a,b,c). -tcBinary :: Position -> String -> Doc -> Type -> TCM (Type, Type, Type)+tcBinary :: HasPosition p => p -> String -> Doc -> Type -> TCM (Type, Type, Type) tcBinary p what doc ty = tcArrow p what doc ty >>= uncurry binaryArrow where binaryArrow ty1 (TypeArrow ty2 ty3) = return (ty1, ty2, ty3)@@ -1336,7 +1344,7 @@ -- Unification: The unification uses Robinson's algorithm. -unify :: Position -> String -> Doc -> PredSet -> Type -> PredSet -> Type+unify :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet -> Type -> TCM PredSet unify p what doc ps1 ty1 ps2 ty2 = do theta <- getTypeSubst@@ -1408,7 +1416,7 @@ -- restricted by the current predicate set after the reduction and thus -- may cause a further extension of the current type substitution. -reducePredSet :: Position -> String -> Doc -> PredSet -> TCM PredSet+reducePredSet :: HasPosition p => p -> String -> Doc -> PredSet -> TCM PredSet reducePredSet p what doc ps = do m <- getModuleIdent clsEnv <- getClassEnv@@ -1433,7 +1441,7 @@ fmap (expandAliasType tys . snd3) (lookupInstInfo (qcls, tc) $ fst inEnv) _ -> Nothing -reportMissingInstance :: ModuleIdent -> Position -> String -> Doc -> InstEnv'+reportMissingInstance :: HasPosition p => ModuleIdent -> p -> String -> Doc -> InstEnv' -> TypeSubst -> Pred -> TCM TypeSubst reportMissingInstance m p what doc inEnv theta (Pred qcls ty) = case subst theta ty of@@ -1476,7 +1484,7 @@ -- types that satisfies all constraints for the ambiguous type variable. An -- error is reported if no such type exists. -applyDefaults :: Position -> String -> Doc -> Set.Set Int -> PredSet -> Type+applyDefaults :: HasPosition p => p -> String -> Doc -> Set.Set Int -> PredSet -> Type -> TCM PredSet applyDefaults p what doc fvs ps ty = do m <- getModuleIdent@@ -1521,7 +1529,7 @@ -- a skolem constant escapes in the (result) type of 'f' and in the type of the -- environment variable 'x' for the fcase expression in the definition of 'g'. -checkSkolems :: Position -> String -> (a -> Doc) -> Set.Set Int -> PredSet+checkSkolems :: HasPosition p => p -> String -> (a -> Doc) -> Set.Set Int -> PredSet -> Type -> a -> TCM (PredSet, Type, a) checkSkolems p what pp fs ps ty x = do m <- getModuleIdent@@ -1723,7 +1731,7 @@ errPolymorphicVar v = posMessage v $ hsep $ map text ["Variable", idName v, "has a polymorphic type"] -errTypeSigTooGeneral :: Position -> ModuleIdent -> Doc -> QualTypeExpr+errTypeSigTooGeneral :: HasPosition a => a -> ModuleIdent -> Doc -> QualTypeExpr -> TypeScheme -> Message errTypeSigTooGeneral p m what qty tySc = posMessage p $ vcat [ text "Type signature too general", what@@ -1731,7 +1739,7 @@ , text "Type signature:" <+> ppQualTypeExpr qty ] -errMethodTypeTooSpecific :: Position -> ModuleIdent -> Doc -> PredType+errMethodTypeTooSpecific :: HasPosition a => a -> ModuleIdent -> Doc -> PredType -> TypeScheme -> Message errMethodTypeTooSpecific p m what pty tySc = posMessage p $ vcat [ text "Method type too specific", what@@ -1739,7 +1747,7 @@ , text "Expected type:" <+> ppPredType m pty ] -errNonFunctionType :: Position -> String -> Doc -> ModuleIdent -> Type+errNonFunctionType :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type -> Message errNonFunctionType p what doc m ty = posMessage p $ vcat [ text "Type error in" <+> text what, doc@@ -1747,14 +1755,14 @@ , text "Cannot be applied" ] -errNonBinaryOp :: Position -> String -> Doc -> ModuleIdent -> Type -> Message+errNonBinaryOp :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type -> Message errNonBinaryOp p what doc m ty = posMessage p $ vcat [ text "Type error in" <+> text what, doc , text "Type:" <+> ppType m ty , text "Cannot be used as binary operator" ] -errTypeMismatch :: Position -> String -> Doc -> ModuleIdent -> Type -> Type+errTypeMismatch :: HasPosition a => a -> String -> Doc -> ModuleIdent -> Type -> Type -> Doc -> Message errTypeMismatch p what doc m ty1 ty2 reason = posMessage p $ vcat [ text "Type error in" <+> text what, doc@@ -1763,11 +1771,11 @@ , reason ] -errSkolemFieldLabel :: Position -> Ident -> Message+errSkolemFieldLabel :: HasPosition a => a -> Ident -> Message errSkolemFieldLabel p l = posMessage p $ hsep $ map text ["Existential type escapes with type of record selector", escName l] -errSkolemEscapingScope :: Position -> ModuleIdent -> String -> Doc+errSkolemEscapingScope :: HasPosition a => a -> ModuleIdent -> String -> Doc -> (Doc, PredType) -> Message errSkolemEscapingScope p m what doc (whence, pty) = posMessage p $ vcat [ text "Existential type escapes out of its scope"@@ -1785,7 +1793,7 @@ , text "are incompatible" ] -errIncompatibleLabelTypes :: Position -> ModuleIdent -> Ident -> Type -> Type+errIncompatibleLabelTypes :: HasPosition a => a -> ModuleIdent -> Ident -> Type -> Type -> Message errIncompatibleLabelTypes p m l ty1 ty2 = posMessage p $ sep [ text "Labeled types" <+> ppIdent l <+> text "::" <+> ppType m ty1@@ -1793,7 +1801,7 @@ , text "are incompatible" ] -errMissingInstance :: ModuleIdent -> Position -> String -> Doc -> Pred+errMissingInstance :: HasPosition a => ModuleIdent -> a -> String -> Doc -> Pred -> Message errMissingInstance m p what doc pr = posMessage p $ vcat [ text "Missing instance for" <+> ppPred m pr@@ -1801,7 +1809,7 @@ , doc ] -errAmbiguousTypeVariable :: ModuleIdent -> Position -> String -> Doc -> PredSet+errAmbiguousTypeVariable :: HasPosition a => ModuleIdent -> a -> String -> Doc -> PredSet -> Type -> Int -> Message errAmbiguousTypeVariable m p what doc ps ty tv = posMessage p $ vcat [ text "Ambiguous type variable" <+> ppType m (TypeVariable tv)
src/Checks/TypeSyntaxCheck.hs view
@@ -31,6 +31,7 @@ import Curry.Base.Ident import Curry.Base.Position+import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Syntax import Curry.Syntax.Pretty@@ -43,6 +44,8 @@ import Env.TypeConstructor (TCEnv) import Env.Type +-- TODO Use span info for err messages+ -- In order to check type constructor applications, the compiler -- maintains an environment containing all known type constructors and -- type classes. The function 'typeSyntaxCheck' expects a type constructor@@ -54,7 +57,7 @@ typeSyntaxCheck :: [KnownExtension] -> TCEnv -> Module a -> ((Module a, [KnownExtension]), [Message])-typeSyntaxCheck exts tcEnv mdl@(Module _ m _ _ ds) =+typeSyntaxCheck exts tcEnv mdl@(Module _ _ m _ _ ds) = case findMultiples $ map getIdent tcds of [] -> if length dfds <= 1 then runTSCM (checkModule mdl) state@@ -63,7 +66,7 @@ where tcds = filter isTypeOrClassDecl ds dfds = filter isDefaultDecl ds- dfps = map (\(DefaultDecl p _) -> p) dfds+ dfps = map (\(DefaultDecl p _) -> spanInfo2Pos p) dfds tEnv = foldr (bindType m) (fmap toTypeKind tcEnv) tcds state = TSCState m tEnv exts Map.empty 1 [] @@ -221,71 +224,72 @@ rename (NewRecordDecl p c (l, ty)) = NewRecordDecl p c . (,) l <$> rename ty instance Rename Constraint where- rename (Constraint cls ty) = Constraint cls <$> rename ty+ rename (Constraint spi cls ty) = Constraint spi cls <$> rename ty instance Rename QualTypeExpr where- rename (QualTypeExpr cx ty) = QualTypeExpr <$> rename cx <*> rename ty+ rename (QualTypeExpr spi cx ty) = QualTypeExpr spi <$> rename cx <*> rename ty instance Rename TypeExpr where- rename (ConstructorType tc) = return $ ConstructorType tc- rename (ApplyType ty1 ty2) = ApplyType <$> rename ty1 <*> rename ty2- rename (VariableType tv) = VariableType <$> rename tv- rename (TupleType tys) = TupleType <$> rename tys- rename (ListType ty) = ListType <$> rename ty- rename (ArrowType ty1 ty2) = ArrowType <$> rename ty1 <*> rename ty2- rename (ParenType ty) = ParenType <$> rename ty- rename (ForallType vs ty) = do+ rename (ConstructorType spi tc) = return $ ConstructorType spi tc+ rename (ApplyType spi ty1 ty2) = ApplyType spi <$> rename ty1 <*> rename ty2+ rename (VariableType spi tv) = VariableType spi <$> rename tv+ rename (TupleType spi tys) = TupleType spi <$> rename tys+ rename (ListType spi ty) = ListType spi <$> rename ty+ rename (ArrowType spi ty1 ty2) = ArrowType spi <$> rename ty1 <*> rename ty2+ rename (ParenType spi ty) = ParenType spi <$> rename ty+ rename (ForallType spi vs ty) = do bindVars vs- ForallType <$> mapM rename vs <*> rename ty+ ForallType spi <$> mapM rename vs <*> rename ty instance Rename (Equation a) where rename (Equation p lhs rhs) = Equation p lhs <$> rename rhs instance Rename (Rhs a) where- rename (SimpleRhs p e ds) = SimpleRhs p <$> rename e <*> rename ds- rename (GuardedRhs es ds) = GuardedRhs <$> rename es <*> rename ds+ rename (SimpleRhs spi e ds) = SimpleRhs spi <$> rename e <*> rename ds+ rename (GuardedRhs spi es ds) = GuardedRhs spi <$> rename es <*> rename ds instance Rename (CondExpr a) where- rename (CondExpr p c e) = CondExpr p <$> rename c <*> rename e+ rename (CondExpr spi c e) = CondExpr spi <$> rename c <*> rename e instance Rename (Expression a) where- rename (Literal a l) = return $ Literal a l- rename (Variable a v) = return $ Variable a v- rename (Constructor a c) = return $ Constructor a c- rename (Paren e) = Paren <$> rename e- rename (Typed e qty) = Typed <$> rename e <*> renameTypeSig qty- rename (Record a c fs) = Record a c <$> rename fs- rename (RecordUpdate e fs) = RecordUpdate <$> rename e <*> rename fs- rename (Tuple es) = Tuple <$> rename es- rename (List a es) = List a <$> rename es- rename (ListCompr e stmts) = ListCompr <$> rename e <*> rename stmts- rename (EnumFrom e) = EnumFrom <$> rename e- rename (EnumFromThen e1 e2) = EnumFromThen <$> rename e1 <*> rename e2- rename (EnumFromTo e1 e2) = EnumFromTo <$> rename e1 <*> rename e2- rename (EnumFromThenTo e1 e2 e3) =- EnumFromThenTo <$> rename e1 <*> rename e2 <*> rename e3- rename (UnaryMinus e) = UnaryMinus <$> rename e- rename (Apply e1 e2) = Apply <$> rename e1 <*> rename e2- rename (InfixApply e1 op e2) = flip InfixApply op <$> rename e1 <*> rename e2- rename (LeftSection e op) = flip LeftSection op <$> rename e- rename (RightSection op e) = RightSection op <$> rename e- rename (Lambda ts e) = Lambda ts <$> rename e- rename (Let ds e) = Let <$> rename ds <*> rename e- rename (Do stmts e) = Do <$> rename stmts <*> rename e- rename (IfThenElse c e1 e2) =- IfThenElse <$> rename c <*> rename e1 <*> rename e2- rename (Case ct e alts) = Case ct <$> rename e <*> rename alts+ rename (Literal spi a l) = return $ Literal spi a l+ rename (Variable spi a v) = return $ Variable spi a v+ rename (Constructor spi a c) = return $ Constructor spi a c+ rename (Paren spi e) = Paren spi <$> rename e+ rename (Typed spi e qty) = Typed spi <$> rename e <*> renameTypeSig qty+ rename (Record spi a c fs) = Record spi a c <$> rename fs+ rename (RecordUpdate spi e fs) = RecordUpdate spi <$> rename e <*> rename fs+ rename (Tuple spi es) = Tuple spi <$> rename es+ rename (List spi a es) = List spi a <$> rename es+ rename (ListCompr spi e stmts) = ListCompr spi <$> rename e <*> rename stmts+ rename (EnumFrom spi e) = EnumFrom spi <$> rename e+ rename (EnumFromThen spi e1 e2) = EnumFromThen spi <$> rename e1 <*> rename e2+ rename (EnumFromTo spi e1 e2) = EnumFromTo spi <$> rename e1 <*> rename e2+ rename (EnumFromThenTo spi e1 e2 e3) =+ EnumFromThenTo spi <$> rename e1 <*> rename e2 <*> rename e3+ rename (UnaryMinus spi e) = UnaryMinus spi <$> rename e+ rename (Apply spi e1 e2) = Apply spi <$> rename e1 <*> rename e2+ rename (InfixApply spi e1 op e2) =+ flip (InfixApply spi) op <$> rename e1 <*> rename e2+ rename (LeftSection spi e op) = flip (LeftSection spi) op <$> rename e+ rename (RightSection spi op e) = RightSection spi op <$> rename e+ rename (Lambda spi ts e) = Lambda spi ts <$> rename e+ rename (Let spi ds e) = Let spi <$> rename ds <*> rename e+ rename (Do spi stmts e) = Do spi <$> rename stmts <*> rename e+ rename (IfThenElse spi c e1 e2) =+ IfThenElse spi <$> rename c <*> rename e1 <*> rename e2+ rename (Case spi ct e alts) = Case spi ct <$> rename e <*> rename alts instance Rename (Statement a) where- rename (StmtExpr e) = StmtExpr <$> rename e- rename (StmtDecl ds) = StmtDecl <$> rename ds- rename (StmtBind t e) = StmtBind t <$> rename e+ rename (StmtExpr spi e) = StmtExpr spi <$> rename e+ rename (StmtDecl spi ds) = StmtDecl spi <$> rename ds+ rename (StmtBind spi t e) = StmtBind spi t <$> rename e instance Rename (Alt a) where- rename (Alt p t rhs) = Alt p t <$> rename rhs+ rename (Alt spi t rhs) = Alt spi t <$> rename rhs instance Rename a => Rename (Field a) where- rename (Field p l x) = Field p l <$> rename x+ rename (Field spi l x) = Field spi l <$> rename x instance Rename Ident where rename tv | isAnonId tv = renameIdent tv <$> newId@@ -310,11 +314,11 @@ -- traversed because they can contain local type signatures. checkModule :: Module a -> TSCM (Module a, [KnownExtension])-checkModule (Module ps m es is ds) = do+checkModule (Module spi ps m es is ds) = do ds' <- mapM checkDecl ds ds'' <- rename ds' exts <- getExtensions- return (Module ps m es is ds'', exts)+ return (Module spi ps m es is ds'', exts) checkDecl :: Decl a -> TSCM (Decl a) checkDecl (DataDecl p tc tvs cs clss) = do@@ -347,7 +351,7 @@ return $ ClassDecl p cx' cls clsvar ds' checkDecl (InstanceDecl p cx qcls inst ds) = do checkClass qcls- QualTypeExpr cx' inst' <- checkQualType $ QualTypeExpr cx inst+ QualTypeExpr _ cx' inst' <- checkQualType $ QualTypeExpr NoSpanInfo cx inst checkSimpleContext cx' checkInstanceType p inst' InstanceDecl p cx' qcls inst' <$> mapM checkDecl ds@@ -386,7 +390,7 @@ checkSimpleContext = mapM_ checkSimpleConstraint checkSimpleConstraint :: Constraint -> TSCM ()-checkSimpleConstraint c@(Constraint _ ty) =+checkSimpleConstraint c@(Constraint _ _ ty) = unless (isVariableType ty) $ report $ errIllegalSimpleConstraint c -- Class method's type signatures have to obey a few additional restrictions.@@ -394,27 +398,28 @@ -- context must not contain any additional constraints for that class variable. checkClassMethod :: Ident -> Decl a -> TSCM ()-checkClassMethod tv (TypeSig p _ qty) = do+checkClassMethod tv (TypeSig spi _ qty) = do unless (tv `elem` fv qty) $ report $ errAmbiguousType p tv- let QualTypeExpr cx _ = qty+ let QualTypeExpr _ cx _ = qty when (tv `elem` fv cx) $ report $ errConstrainedClassVariable p tv+ where p = spanInfo2Pos spi checkClassMethod _ _ = ok -checkInstanceType :: Position -> InstanceType -> TSCM ()+checkInstanceType :: SpanInfo -> InstanceType -> TSCM () checkInstanceType p inst = do tEnv <- getTypeEnv unless (isSimpleType inst && not (isTypeSyn (typeConstr inst) tEnv) &&- null (filter isAnonId $ typeVariables inst) &&+ not (any isAnonId $ typeVariables inst) && isNothing (findDouble $ fv inst)) $- report $ errIllegalInstanceType p inst+ report $ errIllegalInstanceType (spanInfo2Pos p) inst checkTypeLhs :: [Ident] -> TSCM () checkTypeLhs = checkTypeVars "left hand side of type declaration" checkExistVars :: [Ident] -> TSCM () checkExistVars evs = do- unless (null evs) $ checkUsedExtension (idPosition $ head evs)+ unless (null evs) $ checkUsedExtension (getPosition $ head evs) "Existentially quantified types" ExistentialQuantification checkTypeVars "list of existentially quantified type variables" evs @@ -439,61 +444,67 @@ checkEquation (Equation p lhs rhs) = Equation p lhs <$> checkRhs rhs checkRhs :: Rhs a -> TSCM (Rhs a)-checkRhs (SimpleRhs p e ds) = SimpleRhs p <$> checkExpr e <*> mapM checkDecl ds-checkRhs (GuardedRhs es ds) = GuardedRhs <$> mapM checkCondExpr es- <*> mapM checkDecl ds+checkRhs (SimpleRhs spi e ds) = SimpleRhs spi <$> checkExpr e+ <*> mapM checkDecl ds+checkRhs (GuardedRhs spi es ds) = GuardedRhs spi <$> mapM checkCondExpr es+ <*> mapM checkDecl ds checkCondExpr :: CondExpr a -> TSCM (CondExpr a)-checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr g <*> checkExpr e+checkCondExpr (CondExpr spi g e) = CondExpr spi <$> checkExpr g <*> checkExpr e checkExpr :: Expression a -> TSCM (Expression a)-checkExpr l@(Literal _ _) = return l-checkExpr v@(Variable _ _) = return v-checkExpr c@(Constructor _ _) = return c-checkExpr (Paren e) = Paren <$> checkExpr e-checkExpr (Typed e qty) = Typed <$> checkExpr e- <*> checkQualType qty-checkExpr (Record a c fs) = Record a c <$> mapM checkFieldExpr fs-checkExpr (RecordUpdate e fs) = RecordUpdate <$> checkExpr e- <*> mapM checkFieldExpr fs-checkExpr (Tuple es) = Tuple <$> mapM checkExpr es-checkExpr (List a es) = List a <$> mapM checkExpr es-checkExpr (ListCompr e qs) = ListCompr <$> checkExpr e- <*> mapM checkStmt qs-checkExpr (EnumFrom e) = EnumFrom <$> checkExpr e-checkExpr (EnumFromThen e1 e2) = EnumFromThen <$> checkExpr e1- <*> checkExpr e2-checkExpr (EnumFromTo e1 e2) = EnumFromTo <$> checkExpr e1- <*> checkExpr e2-checkExpr (EnumFromThenTo e1 e2 e3) = EnumFromThenTo <$> checkExpr e1- <*> checkExpr e2- <*> checkExpr e3-checkExpr (UnaryMinus e) = UnaryMinus <$> checkExpr e-checkExpr (Apply e1 e2) = Apply <$> checkExpr e1 <*> checkExpr e2-checkExpr (InfixApply e1 op e2) = InfixApply <$> checkExpr e1- <*> return op- <*> checkExpr e2-checkExpr (LeftSection e op) = flip LeftSection op <$> checkExpr e-checkExpr (RightSection op e) = RightSection op <$> checkExpr e-checkExpr (Lambda ts e) = Lambda ts <$> checkExpr e-checkExpr (Let ds e) = Let <$> mapM checkDecl ds <*> checkExpr e-checkExpr (Do sts e) = Do <$> mapM checkStmt sts <*> checkExpr e-checkExpr (IfThenElse e1 e2 e3) = IfThenElse <$> checkExpr e1- <*> checkExpr e2- <*> checkExpr e3-checkExpr (Case ct e alts) = Case ct <$> checkExpr e- <*> mapM checkAlt alts+checkExpr l@(Literal _ _ _) = return l+checkExpr v@(Variable _ _ _) = return v+checkExpr c@(Constructor _ _ _) = return c+checkExpr (Paren spi e) = Paren spi <$> checkExpr e+checkExpr (Typed spi e qty) = Typed spi <$> checkExpr e+ <*> checkQualType qty+checkExpr (Record spi a c fs) =+ Record spi a c <$> mapM checkFieldExpr fs+checkExpr (RecordUpdate spi e fs) =+ RecordUpdate spi <$> checkExpr e <*> mapM checkFieldExpr fs+checkExpr (Tuple spi es) = Tuple spi <$> mapM checkExpr es+checkExpr (List spi a es) = List spi a <$> mapM checkExpr es+checkExpr (ListCompr spi e qs) = ListCompr spi <$> checkExpr e+ <*> mapM checkStmt qs+checkExpr (EnumFrom spi e) = EnumFrom spi <$> checkExpr e+checkExpr (EnumFromThen spi e1 e2) = EnumFromThen spi <$> checkExpr e1+ <*> checkExpr e2+checkExpr (EnumFromTo spi e1 e2) = EnumFromTo spi <$> checkExpr e1+ <*> checkExpr e2+checkExpr (EnumFromThenTo spi e1 e2 e3) = EnumFromThenTo spi <$> checkExpr e1+ <*> checkExpr e2+ <*> checkExpr e3+checkExpr (UnaryMinus spi e) = UnaryMinus spi <$> checkExpr e+checkExpr (Apply spi e1 e2) = Apply spi <$> checkExpr e1+ <*> checkExpr e2+checkExpr (InfixApply spi e1 op e2) = InfixApply spi <$> checkExpr e1+ <*> return op+ <*> checkExpr e2+checkExpr (LeftSection spi e op) =+ flip (LeftSection spi) op <$> checkExpr e+checkExpr (RightSection spi op e) = RightSection spi op <$> checkExpr e+checkExpr (Lambda spi ts e) = Lambda spi ts <$> checkExpr e+checkExpr (Let spi ds e) = Let spi <$> mapM checkDecl ds+ <*> checkExpr e+checkExpr (Do spi sts e) = Do spi <$> mapM checkStmt sts+ <*> checkExpr e+checkExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> checkExpr e1+ <*> checkExpr e2+ <*> checkExpr e3+checkExpr (Case spi ct e alts) = Case spi ct <$> checkExpr e+ <*> mapM checkAlt alts checkStmt :: Statement a -> TSCM (Statement a)-checkStmt (StmtExpr e) = StmtExpr <$> checkExpr e-checkStmt (StmtBind t e) = StmtBind t <$> checkExpr e-checkStmt (StmtDecl ds) = StmtDecl <$> mapM checkDecl ds+checkStmt (StmtExpr spi e) = StmtExpr spi <$> checkExpr e+checkStmt (StmtBind spi t e) = StmtBind spi t <$> checkExpr e+checkStmt (StmtDecl spi ds) = StmtDecl spi <$> mapM checkDecl ds checkAlt :: Alt a -> TSCM (Alt a)-checkAlt (Alt p t rhs) = Alt p t <$> checkRhs rhs+checkAlt (Alt spi t rhs) = Alt spi t <$> checkRhs rhs checkFieldExpr :: Field (Expression a) -> TSCM (Field (Expression a))-checkFieldExpr (Field p l e) = Field p l <$> checkExpr e+checkFieldExpr (Field spi l e) = Field spi l <$> checkExpr e -- The parser cannot distinguish unqualified nullary type constructors -- and type variables. Therefore, if the compiler finds an unbound@@ -501,29 +512,29 @@ -- interpret the identifier as such. checkQualType :: QualTypeExpr -> TSCM QualTypeExpr-checkQualType (QualTypeExpr cx ty) = do+checkQualType (QualTypeExpr spi cx ty) = do ty' <- checkType ty cx' <- checkClosedContext (fv ty') cx- return $ QualTypeExpr cx' ty'+ return $ QualTypeExpr spi cx' ty' checkClosedContext :: [Ident] -> Context -> TSCM Context checkClosedContext tvs cx = do cx' <- checkContext cx- mapM_ (\(Constraint _ ty) -> checkClosed tvs ty) cx'+ mapM_ (\(Constraint _ _ ty) -> checkClosed tvs ty) cx' return cx' checkContext :: Context -> TSCM Context checkContext = mapM checkConstraint checkConstraint :: Constraint -> TSCM Constraint-checkConstraint c@(Constraint qcls ty) = do+checkConstraint c@(Constraint spi qcls ty) = do checkClass qcls ty' <- checkType ty unless (isVariableType $ rootType ty') $ report $ errIllegalConstraint c- return $ Constraint qcls ty'+ return $ Constraint spi qcls ty' where- rootType (ApplyType ty' _) = ty'- rootType ty' = ty'+ rootType (ApplyType _ ty' _) = ty'+ rootType ty' = ty' checkClass :: QualIdent -> TSCM () checkClass qcls = do@@ -545,13 +556,13 @@ return ty' checkType :: TypeExpr -> TSCM TypeExpr-checkType c@(ConstructorType tc) = do+checkType c@(ConstructorType spi tc) = do m <- getModuleIdent tEnv <- getTypeEnv case qualLookupTypeKind tc tEnv of [] | isQTupleId tc -> return c- | not (isQualified tc) -> return $ VariableType $ unqualify tc+ | not (isQualified tc) -> return $ VariableType spi $ unqualify tc | otherwise -> report (errUndefinedType tc) >> return c [Class _ _] -> report (errUndefinedType tc) >> return c [_] -> return c@@ -559,26 +570,28 @@ [Class _ _] -> report (errUndefinedType tc) >> return c [_] -> return c _ -> report (errAmbiguousIdent tc $ map origName tks) >> return c-checkType (ApplyType ty1 ty2) = ApplyType <$> checkType ty1 <*> checkType ty2-checkType v@(VariableType tv)+checkType (ApplyType spi ty1 ty2) = ApplyType spi <$> checkType ty1+ <*> checkType ty2+checkType v@(VariableType spi tv) | isAnonId tv = return v- | otherwise = checkType $ ConstructorType (qualify tv)-checkType (TupleType tys) = TupleType <$> mapM checkType tys-checkType (ListType ty) = ListType <$> checkType ty-checkType (ArrowType ty1 ty2) = ArrowType <$> checkType ty1 <*> checkType ty2-checkType (ParenType ty) = ParenType <$> checkType ty-checkType (ForallType vs ty) = ForallType vs <$> checkType ty+ | otherwise = checkType $ ConstructorType spi (qualify tv)+checkType (TupleType spi tys) = TupleType spi <$> mapM checkType tys+checkType (ListType spi ty) = ListType spi <$> checkType ty+checkType (ArrowType spi ty1 ty2) = ArrowType spi <$> checkType ty1+ <*> checkType ty2+checkType (ParenType spi ty) = ParenType spi <$> checkType ty+checkType (ForallType spi vs ty) = ForallType spi vs <$> checkType ty checkClosed :: [Ident] -> TypeExpr -> TSCM ()-checkClosed _ (ConstructorType _) = ok-checkClosed tvs (ApplyType ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2]-checkClosed tvs (VariableType tv) =+checkClosed _ (ConstructorType _ _) = ok+checkClosed tvs (ApplyType _ ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2]+checkClosed tvs (VariableType _ tv) = when (isAnonId tv || tv `notElem` tvs) $ report $ errUnboundVariable tv-checkClosed tvs (TupleType tys) = mapM_ (checkClosed tvs) tys-checkClosed tvs (ListType ty) = checkClosed tvs ty-checkClosed tvs (ArrowType ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2]-checkClosed tvs (ParenType ty) = checkClosed tvs ty-checkClosed tvs (ForallType vs ty) = checkClosed (tvs ++ vs) ty+checkClosed tvs (TupleType _ tys) = mapM_ (checkClosed tvs) tys+checkClosed tvs (ListType _ ty) = checkClosed tvs ty+checkClosed tvs (ArrowType _ ty1 ty2) = mapM_ (checkClosed tvs) [ty1, ty2]+checkClosed tvs (ParenType _ ty) = checkClosed tvs ty+checkClosed tvs (ForallType _ vs ty) = checkClosed (tvs ++ vs) ty checkUsedExtension :: Position -> String -> KnownExtension -> TSCM () checkUsedExtension pos msg ext = do@@ -620,7 +633,7 @@ text "Multiple declarations of" <+> text (escName i) <+> text "at:" $+$ nest 2 (vcat $ map showPos is) where i = head is- showPos = text . showLine . idPosition+ showPos = text . showLine . getPosition errMissingLanguageExtension :: Position -> String -> KnownExtension -> Message errMissingLanguageExtension p what ext = posMessage p $@@ -664,14 +677,14 @@ [ "Unbound type variable", idName tv ] errIllegalConstraint :: Constraint -> Message-errIllegalConstraint c@(Constraint qcls _) = posMessage qcls $ vcat+errIllegalConstraint c@(Constraint _ qcls _) = posMessage qcls $ vcat [ text "Illegal class constraint" <+> ppConstraint c , text "Constraints must be of the form C u or C (u t1 ... tn)," , text "where C is a type class, u is a type variable and t1, ..., tn are types." ] errIllegalSimpleConstraint :: Constraint -> Message-errIllegalSimpleConstraint c@(Constraint qcls _) = posMessage qcls $ vcat+errIllegalSimpleConstraint c@(Constraint _ qcls _) = posMessage qcls $ vcat [ text "Illegal class constraint" <+> ppConstraint c , text "Constraints in class and instance declarations must be of" , text "the form C u, where C is a type class and u is a type variable."
src/Checks/WarnCheck.hs view
@@ -14,8 +14,13 @@ This module searches for potentially irregular code and generates warning messages. -}+{-# LANGUAGE CPP #-} module Checks.WarnCheck (warnCheck) where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ import Control.Monad (filterM, foldM_, guard, liftM, liftM2, when, unless) import Control.Monad.State.Strict (State, execState, gets, modify)@@ -32,6 +37,7 @@ import Curry.Base.Ident import Curry.Base.Position import Curry.Base.Pretty+import Curry.Base.SpanInfo import Curry.Syntax import Curry.Syntax.Pretty (ppDecl, ppPattern, ppExpr, ppIdent) @@ -70,7 +76,7 @@ checkMissingTypeSignatures ds checkModuleAlias is checkCaseMode ds- where Module _ mid es is ds = fmap (const ()) mdl+ where Module _ _ mid es is ds = fmap (const ()) mdl type ScopeEnv = NestEnv IdInfo @@ -136,8 +142,8 @@ mapM_ visitExport exports reportUnusedGlobalVars where- visitExport (Export qid) = visitQId qid- visitExport _ = ok+ visitExport (Export _ qid) = visitQId qid+ visitExport _ = ok -- --------------------------------------------------------------------------- -- checkImports@@ -181,13 +187,13 @@ setImportSpec env mid ishs = return $ Map.insert mid ishs env - cmpImport (ImportTypeWith id1 cs1) (ImportTypeWith id2 cs2)+ cmpImport (ImportTypeWith _ id1 cs1) (ImportTypeWith _ id2 cs2) = id1 == id2 && null (intersect cs1 cs2) cmpImport i1 i2 = (impName i1) == (impName i2) - impName (Import v) = v- impName (ImportTypeAll t) = t- impName (ImportTypeWith t _) = t+ impName (Import _ v) = v+ impName (ImportTypeAll _ t) = t+ impName (ImportTypeWith _ t _) = t warnMultiplyImportedModule :: ModuleIdent -> Message warnMultiplyImportedModule mid = posMessage mid $ hsep $ map text@@ -233,7 +239,7 @@ else case Map.lookup f env of Nothing -> return (f, Map.insert f p env) Just p' -> do- report $ warnDisjoinedFunctionRules f p'+ report $ warnDisjoinedFunctionRules f (spanInfo2Pos p') return (f, env) check (_ , env) _ = return (mkIdent "", env) @@ -297,14 +303,14 @@ checkTypeExpr ty checkTypeExpr :: TypeExpr -> WCM ()-checkTypeExpr (ConstructorType qid) = visitQTypeId qid-checkTypeExpr (ApplyType ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2]-checkTypeExpr (VariableType v) = visitTypeId v-checkTypeExpr (TupleType tys) = mapM_ checkTypeExpr tys-checkTypeExpr (ListType ty) = checkTypeExpr ty-checkTypeExpr (ArrowType ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2]-checkTypeExpr (ParenType ty) = checkTypeExpr ty-checkTypeExpr (ForallType vs ty) = do+checkTypeExpr (ConstructorType _ qid) = visitQTypeId qid+checkTypeExpr (ApplyType _ ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2]+checkTypeExpr (VariableType _ v) = visitTypeId v+checkTypeExpr (TupleType _ tys) = mapM_ checkTypeExpr tys+checkTypeExpr (ListType _ ty) = checkTypeExpr ty+checkTypeExpr (ArrowType _ ty1 ty2) = mapM_ checkTypeExpr [ty1, ty2]+checkTypeExpr (ParenType _ ty) = checkTypeExpr ty+checkTypeExpr (ForallType _ vs ty) = do mapM_ insertTypeVar vs checkTypeExpr ty @@ -316,20 +322,21 @@ checkLocalDecl (PatternDecl _ p _) = checkPattern p checkLocalDecl _ = ok -checkFunctionDecl :: Position -> Ident -> [Equation ()] -> WCM ()+checkFunctionDecl :: SpanInfo -> Ident -> [Equation ()] -> WCM () checkFunctionDecl _ _ [] = ok checkFunctionDecl p f eqs = inNestedScope $ do mapM_ checkEquation eqs checkFunctionPatternMatch p f eqs -checkFunctionPatternMatch :: Position -> Ident -> [Equation ()] -> WCM ()-checkFunctionPatternMatch p f eqs = do+checkFunctionPatternMatch :: SpanInfo -> Ident -> [Equation ()] -> WCM ()+checkFunctionPatternMatch spi f eqs = do let pats = map (\(Equation _ lhs _) -> snd (flatLhs lhs)) eqs (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats unless (null nonExhaustive) $ warnFor WarnIncompletePatterns $ report $ warnMissingPattern p ("an equation for " ++ escName f) nonExhaustive when (nondet || not (null overlapped)) $ warnFor WarnOverlapping $ report $ warnNondetOverlapping p ("Function " ++ escName f)+ where p = spanInfo2Pos spi -- Check an equation for warnings. -- This is done in a seperate scope as the left-hand-side may introduce@@ -341,29 +348,29 @@ reportUnusedVars checkLhs :: Lhs a -> WCM ()-checkLhs (FunLhs _ ts) = do+checkLhs (FunLhs _ _ ts) = do mapM_ checkPattern ts mapM_ (insertPattern False) ts-checkLhs (OpLhs t1 op t2) = checkLhs (FunLhs op [t1, t2])-checkLhs (ApLhs lhs ts) = do+checkLhs (OpLhs spi t1 op t2) = checkLhs (FunLhs spi op [t1, t2])+checkLhs (ApLhs _ lhs ts) = do checkLhs lhs mapM_ checkPattern ts mapM_ (insertPattern False) ts checkPattern :: Pattern a -> WCM ()-checkPattern (VariablePattern _ v) = checkShadowing v-checkPattern (ConstructorPattern _ _ ps) = mapM_ checkPattern ps-checkPattern (InfixPattern a p1 f p2) = checkPattern- (ConstructorPattern a f [p1, p2])-checkPattern (ParenPattern p) = checkPattern p-checkPattern (RecordPattern _ _ fs) = mapM_ (checkField checkPattern) fs-checkPattern (TuplePattern ps) = mapM_ checkPattern ps-checkPattern (ListPattern _ ps) = mapM_ checkPattern ps-checkPattern (AsPattern v p) = checkShadowing v >> checkPattern p-checkPattern (LazyPattern p) = checkPattern p-checkPattern (FunctionPattern _ _ ps) = mapM_ checkPattern ps-checkPattern (InfixFuncPattern a p1 f p2) = checkPattern- (FunctionPattern a f [p1, p2])+checkPattern (VariablePattern _ _ v) = checkShadowing v+checkPattern (ConstructorPattern _ _ _ ps) = mapM_ checkPattern ps+checkPattern (InfixPattern spi a p1 f p2) =+ checkPattern (ConstructorPattern spi a f [p1, p2])+checkPattern (ParenPattern _ p) = checkPattern p+checkPattern (RecordPattern _ _ _ fs) = mapM_ (checkField checkPattern) fs+checkPattern (TuplePattern _ ps) = mapM_ checkPattern ps+checkPattern (ListPattern _ _ ps) = mapM_ checkPattern ps+checkPattern (AsPattern _ v p) = checkShadowing v >> checkPattern p+checkPattern (LazyPattern _ p) = checkPattern p+checkPattern (FunctionPattern _ _ _ ps) = mapM_ checkPattern ps+checkPattern (InfixFuncPattern spi a p1 f p2) =+ checkPattern (FunctionPattern spi a f [p1, p2]) checkPattern _ = ok -- Check the right-hand-side of an equation.@@ -374,7 +381,7 @@ checkLocalDeclGroup ds checkExpr e reportUnusedVars-checkRhs (GuardedRhs ce ds) = inNestedScope $ do+checkRhs (GuardedRhs _ ce ds) = inNestedScope $ do checkLocalDeclGroup ds mapM_ checkCondExpr ce reportUnusedVars@@ -383,39 +390,39 @@ checkCondExpr (CondExpr _ c e) = checkExpr c >> checkExpr e checkExpr :: Expression () -> WCM ()-checkExpr (Variable _ v) = visitQId v-checkExpr (Paren e) = checkExpr e-checkExpr (Typed e _) = checkExpr e-checkExpr (Record _ _ fs) = mapM_ (checkField checkExpr) fs-checkExpr (RecordUpdate e fs) = do+checkExpr (Variable _ _ v) = visitQId v+checkExpr (Paren _ e) = checkExpr e+checkExpr (Typed _ e _) = checkExpr e+checkExpr (Record _ _ _ fs) = mapM_ (checkField checkExpr) fs+checkExpr (RecordUpdate _ e fs) = do checkExpr e mapM_ (checkField checkExpr) fs-checkExpr (Tuple es) = mapM_ checkExpr es-checkExpr (List _ es) = mapM_ checkExpr es-checkExpr (ListCompr e sts) = checkStatements sts e-checkExpr (EnumFrom e) = checkExpr e-checkExpr (EnumFromThen e1 e2) = mapM_ checkExpr [e1, e2]-checkExpr (EnumFromTo e1 e2) = mapM_ checkExpr [e1, e2]-checkExpr (EnumFromThenTo e1 e2 e3) = mapM_ checkExpr [e1, e2, e3]-checkExpr (UnaryMinus e) = checkExpr e-checkExpr (Apply e1 e2) = mapM_ checkExpr [e1, e2]-checkExpr (InfixApply e1 op e2) = do+checkExpr (Tuple _ es) = mapM_ checkExpr es+checkExpr (List _ _ es) = mapM_ checkExpr es+checkExpr (ListCompr _ e sts) = checkStatements sts e+checkExpr (EnumFrom _ e) = checkExpr e+checkExpr (EnumFromThen _ e1 e2) = mapM_ checkExpr [e1, e2]+checkExpr (EnumFromTo _ e1 e2) = mapM_ checkExpr [e1, e2]+checkExpr (EnumFromThenTo _ e1 e2 e3) = mapM_ checkExpr [e1, e2, e3]+checkExpr (UnaryMinus _ e) = checkExpr e+checkExpr (Apply _ e1 e2) = mapM_ checkExpr [e1, e2]+checkExpr (InfixApply _ e1 op e2) = do visitQId (opName op) mapM_ checkExpr [e1, e2]-checkExpr (LeftSection e _) = checkExpr e-checkExpr (RightSection _ e) = checkExpr e-checkExpr (Lambda ps e) = inNestedScope $ do+checkExpr (LeftSection _ e _) = checkExpr e+checkExpr (RightSection _ _ e) = checkExpr e+checkExpr (Lambda _ ps e) = inNestedScope $ do mapM_ checkPattern ps mapM_ (insertPattern False) ps checkExpr e reportUnusedVars-checkExpr (Let ds e) = inNestedScope $ do+checkExpr (Let _ ds e) = inNestedScope $ do checkLocalDeclGroup ds checkExpr e reportUnusedVars-checkExpr (Do sts e) = checkStatements sts e-checkExpr (IfThenElse e1 e2 e3) = mapM_ checkExpr [e1, e2, e3]-checkExpr (Case ct e alts) = do+checkExpr (Do _ sts e) = checkStatements sts e+checkExpr (IfThenElse _ e1 e2 e3) = mapM_ checkExpr [e1, e2, e3]+checkExpr (Case _ ct e alts) = do checkExpr e mapM_ checkAlt alts checkCaseAlts ct alts@@ -428,9 +435,9 @@ reportUnusedVars checkStatement :: Statement () -> WCM ()-checkStatement (StmtExpr e) = checkExpr e-checkStatement (StmtDecl ds) = checkLocalDeclGroup ds-checkStatement (StmtBind p e) = do+checkStatement (StmtExpr _ e) = checkExpr e+checkStatement (StmtDecl _ ds) = checkLocalDeclGroup ds+checkStatement (StmtBind _ p e) = do checkPattern p >> insertPattern False p checkExpr e @@ -447,14 +454,14 @@ -- Check for orphan instances -- ----------------------------------------------------------------------------- -checkOrphanInstance :: Position -> Context -> QualIdent -> TypeExpr -> WCM ()+checkOrphanInstance :: SpanInfo -> Context -> QualIdent -> TypeExpr -> WCM () checkOrphanInstance p cx cls ty = warnFor WarnOrphanInstances $ do m <- getModuleIdent tcEnv <- gets tyConsEnv let ocls = getOrigName m cls tcEnv otc = getOrigName m tc tcEnv unless (isLocalIdent m ocls || isLocalIdent m otc) $ report $- warnOrphanInstance p $ ppDecl $ InstanceDecl p cx cls ty []+ warnOrphanInstance (spanInfo2Pos p) $ ppDecl $ InstanceDecl p cx cls ty [] where tc = typeConstr ty warnOrphanInstance :: Position -> Doc -> Message@@ -464,14 +471,14 @@ -- Check for missing method implementations -- ----------------------------------------------------------------------------- -checkMissingMethodImplementations :: Position -> QualIdent -> [Decl a] -> WCM ()+checkMissingMethodImplementations :: SpanInfo -> QualIdent -> [Decl a] -> WCM () checkMissingMethodImplementations p cls ds = warnFor WarnMissingMethods $ do m <- getModuleIdent tcEnv <- gets tyConsEnv clsEnv <- gets classEnv let ocls = getOrigName m cls tcEnv ms = classMethods ocls clsEnv- mapM_ (report . warnMissingMethodImplementation p) $+ mapM_ (report . warnMissingMethodImplementation (spanInfo2Pos p)) $ filter ((null fs ||) . not . flip (hasDefaultImpl ocls) clsEnv) $ ms \\ fs where fs = map unRenameIdent $ concatMap impls ds @@ -535,8 +542,8 @@ "WarnCheck.warnAliasNameClash: empty list" warnAliasNameClash mids = posMessage (head mids) $ text "Overlapping module aliases" $+$ nest 2 (vcat (map myppAlias mids))- where myppAlias mid@(ModuleIdent pos _) =- ppLine pos <> text ":" <+> text (escModuleName mid)+ where myppAlias mid =+ ppLine (getPosition mid) <> text ":" <+> text (escModuleName mid) -- ----------------------------------------------------------------------------- -- Check for overlapping/unreachable and non-exhaustive case alternatives@@ -544,7 +551,7 @@ checkCaseAlts :: CaseType -> [Alt ()] -> WCM () checkCaseAlts _ [] = ok-checkCaseAlts ct alts@(Alt p _ _ : _) = do+checkCaseAlts ct alts@(Alt spi _ _ : _) = do let pats = map (\(Alt _ pat _) -> [pat]) alts (nonExhaustive, overlapped, nondet) <- checkPatternMatching pats case ct of@@ -558,6 +565,7 @@ warnMissingPattern p "a case alternative" nonExhaustive unless (null overlapped) $ warnFor WarnOverlapping $ report $ warnUnreachablePattern p overlapped+ where p = spanInfo2Pos spi -- ----------------------------------------------------------------------------- -- Check for non-exhaustive and overlapping patterns.@@ -595,35 +603,37 @@ -- * Constructors -- All other patterns like as-patterns, list patterns and alike are desugared. simplifyPat :: Pattern () -> WCM (Pattern ())-simplifyPat p@(LiteralPattern _ l) = return $ case l of- String s -> simplifyListPattern $ map (LiteralPattern () . Char) s+simplifyPat p@(LiteralPattern _ _ l) = return $ case l of+ String s -> simplifyListPattern $ map (LiteralPattern NoSpanInfo () . Char) s _ -> p-simplifyPat (NegativePattern a l) = return $ LiteralPattern a (negateLit l)+simplifyPat (NegativePattern spi a l) =+ return $ LiteralPattern spi a (negateLit l) where negateLit (Int n) = Int (-n) negateLit (Float d) = Float (-d) negateLit x = x-simplifyPat v@(VariablePattern _ _) = return v-simplifyPat (ConstructorPattern a c ps) =- ConstructorPattern a c `liftM` mapM simplifyPat ps-simplifyPat (InfixPattern a p1 c p2) =- ConstructorPattern a c `liftM` mapM simplifyPat [p1, p2]-simplifyPat (ParenPattern p) = simplifyPat p-simplifyPat (RecordPattern _ c fs) = do+simplifyPat v@(VariablePattern _ _ _) = return v+simplifyPat (ConstructorPattern spi a c ps) =+ ConstructorPattern spi a c `liftM` mapM simplifyPat ps+simplifyPat (InfixPattern spi a p1 c p2) =+ ConstructorPattern spi a c `liftM` mapM simplifyPat [p1, p2]+simplifyPat (ParenPattern _ p) = simplifyPat p+simplifyPat (RecordPattern _ _ c fs) = do (_, ls) <- getAllLabels c let ps = map (getPattern (map field2Tuple fs)) ls- simplifyPat (ConstructorPattern () c ps)+ simplifyPat (ConstructorPattern NoSpanInfo () c ps) where getPattern fs' l' = fromMaybe wildPat (lookup l' [(unqualify l, p) | (l, p) <- fs'])-simplifyPat (TuplePattern ps) =- ConstructorPattern () (qTupleId (length ps)) `liftM` mapM simplifyPat ps-simplifyPat (ListPattern _ ps) =+simplifyPat (TuplePattern _ ps) =+ ConstructorPattern NoSpanInfo () (qTupleId (length ps))+ `liftM` mapM simplifyPat ps+simplifyPat (ListPattern _ _ ps) = simplifyListPattern `liftM` mapM simplifyPat ps-simplifyPat (AsPattern _ p) = simplifyPat p-simplifyPat (LazyPattern _) = return wildPat-simplifyPat (FunctionPattern _ _ _) = return wildPat-simplifyPat (InfixFuncPattern _ _ _ _) = return wildPat+simplifyPat (AsPattern _ _ p) = simplifyPat p+simplifyPat (LazyPattern _ _) = return wildPat+simplifyPat (FunctionPattern _ _ _ _) = return wildPat+simplifyPat (InfixFuncPattern _ _ _ _ _) = return wildPat getAllLabels :: QualIdent -> WCM (QualIdent, [Ident]) getAllLabels c = do@@ -635,8 +645,9 @@ -- |Create a simplified list pattern by applying @:@ and @[]@. simplifyListPattern :: [Pattern ()] -> Pattern ()-simplifyListPattern = foldr (\p1 p2 -> ConstructorPattern () qConsId [p1, p2])- (ConstructorPattern () qNilId [])+simplifyListPattern =+ foldr (\p1 p2 -> ConstructorPattern NoSpanInfo () qConsId [p1, p2])+ (ConstructorPattern NoSpanInfo () qNilId []) -- |'ExhaustivePats' describes those pattern missing for an exhaustive -- pattern matching, where a value can be thought of as a missing equation.@@ -685,7 +696,7 @@ -- default alternatives (variable pattern) defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ] -- Pattern for all non-matched literals- defaultPat = ( VariablePattern () newVar :+ defaultPat = ( VariablePattern NoSpanInfo () newVar : replicate (length (snd q) - 1) wildPat , [(newVar, usedLits)] )@@ -702,7 +713,8 @@ let qs' = [shiftPat q | q <- qs, isVarLit lit (firstPat q)] ovlp = length qs' > 1 (missing, used, nd) <- processEqs qs'- return ( map (\(xs, ys) -> (LiteralPattern () lit : xs, ys)) missing+ return ( map (\(xs, ys) -> (LiteralPattern NoSpanInfo () lit : xs, ys))+ missing , used , nd && ovlp )@@ -733,7 +745,7 @@ defaults = [ shiftPat q' | q' <- qs, isVarPat (firstPat q') ] -- Pattern for a non-matched constructors defaultPat c = (mkPattern c : replicate (length (snd q) - 1) wildPat, [])- mkPattern c = ConstructorPattern ()+ mkPattern c = ConstructorPattern NoSpanInfo () (qualifyLike (fst $ head used_cons) (constrIdent c)) (replicate (length $ constrTypes c) wildPat) @@ -751,7 +763,7 @@ return (map (\(xs, ys) -> (makeCon c a xs, ys)) missing, used, nd && ovlp) makeCon c a ps = let (args, rest) = splitAt a ps- in ConstructorPattern () c args : rest+ in ConstructorPattern NoSpanInfo () c args : rest removeFirstCon c a (n, p:ps) | isVarPat p = (n, replicate a wildPat ++ ps)@@ -810,29 +822,30 @@ -- * Convert a list constructor pattern representing a finite list -- into a list pattern tidyPat :: Pattern () -> WCM (Pattern ())-tidyPat p@(LiteralPattern _ _) = return p-tidyPat p@(VariablePattern _ _) = return p-tidyPat p@(ConstructorPattern _ c ps)+tidyPat p@(LiteralPattern _ _ _) = return p+tidyPat p@(VariablePattern _ _ _) = return p+tidyPat p@(ConstructorPattern _ _ c ps) | isQTupleId c =- TuplePattern `liftM` mapM tidyPat ps+ TuplePattern NoSpanInfo `liftM` mapM tidyPat ps | c == qConsId && isFiniteList p =- ListPattern () `liftM` mapM tidyPat (unwrapFinite p)+ ListPattern NoSpanInfo () `liftM` mapM tidyPat (unwrapFinite p) | c == qConsId = unwrapInfinite p | otherwise =- ConstructorPattern () c `liftM` mapM tidyPat ps+ ConstructorPattern NoSpanInfo () c `liftM` mapM tidyPat ps where- isFiniteList (ConstructorPattern _ d [] ) = d == qNilId- isFiniteList (ConstructorPattern _ d [_, e2]) | d == qConsId = isFiniteList e2- isFiniteList _ = False+ isFiniteList (ConstructorPattern _ _ d [] ) = d == qNilId+ isFiniteList (ConstructorPattern _ _ d [_, e2])+ | d == qConsId = isFiniteList e2+ isFiniteList _ = False - unwrapFinite (ConstructorPattern _ _ [] ) = []- unwrapFinite (ConstructorPattern _ _ [p1,p2]) = p1 : unwrapFinite p2+ unwrapFinite (ConstructorPattern _ _ _ [] ) = []+ unwrapFinite (ConstructorPattern _ _ _ [p1,p2]) = p1 : unwrapFinite p2 unwrapFinite pat = internalError $ "WarnCheck.tidyPat.unwrapFinite: " ++ show pat - unwrapInfinite (ConstructorPattern a d [p1,p2]) =- liftM2 (flip (InfixPattern a) d) (tidyPat p1) (unwrapInfinite p2)- unwrapInfinite p0 = return p0+ unwrapInfinite (ConstructorPattern _ a d [p1,p2]) =+ liftM2 (flip (InfixPattern NoSpanInfo a) d) (tidyPat p1) (unwrapInfinite p2)+ unwrapInfinite p0 = return p0 tidyPat p = internalError $ "Checks.WarnCheck.tidyPat: " ++ show p @@ -848,17 +861,17 @@ -- |Wildcard pattern. wildPat :: Pattern ()-wildPat = VariablePattern () anonId+wildPat = VariablePattern NoSpanInfo () anonId -- |Retrieve any literal out of a pattern. getLit :: Pattern a -> [Literal]-getLit (LiteralPattern _ l) = [l]-getLit _ = []+getLit (LiteralPattern _ _ l) = [l]+getLit _ = [] -- |Retrieve the constructor name and its arity for a pattern. getCon :: Pattern a -> [(QualIdent, Int)]-getCon (ConstructorPattern _ c ps) = [(c, length ps)]-getCon _ = []+getCon (ConstructorPattern _ _ c ps) = [(c, length ps)]+getCon _ = [] -- |Is a pattern a variable or literal pattern? isVarLit :: Literal -> Pattern a -> Bool@@ -870,33 +883,33 @@ -- |Is a pattern a pattern matching for the given constructor? isCon :: QualIdent -> Pattern a -> Bool-isCon c (ConstructorPattern _ d _) = c == d-isCon _ _ = False+isCon c (ConstructorPattern _ _ d _) = c == d+isCon _ _ = False -- |Is a pattern a pattern matching for the given literal? isLit :: Literal -> Pattern a -> Bool-isLit l (LiteralPattern _ m) = l == m-isLit _ _ = False+isLit l (LiteralPattern _ _ m) = l == m+isLit _ _ = False -- |Is a pattern a literal pattern? isLitPat :: Pattern a -> Bool-isLitPat (LiteralPattern _ _) = True-isLitPat _ = False+isLitPat (LiteralPattern _ _ _) = True+isLitPat _ = False -- |Is a pattern a variable pattern? isVarPat :: Pattern a -> Bool-isVarPat (VariablePattern _ _) = True-isVarPat _ = False+isVarPat (VariablePattern _ _ _) = True+isVarPat _ = False -- |Is a pattern a constructor pattern? isConPat :: Pattern a -> Bool-isConPat (ConstructorPattern _ _ _) = True-isConPat _ = False+isConPat (ConstructorPattern _ _ _ _) = True+isConPat _ = False -- |Retrieve the arguments of a pattern. patArgs :: Pattern a -> [Pattern a]-patArgs (ConstructorPattern _ _ ps) = ps-patArgs _ = []+patArgs (ConstructorPattern _ _ _ ps) = ps+patArgs _ = [] -- |Warning message for non-exhaustive patterns. -- To shorten the output only the first 'maxPattern' are printed,@@ -916,7 +929,7 @@ | otherwise = ppPats <+> text "with" <+> hsep (map ppCons cs) where ppPats = hsep (map (ppPattern 2) ps) ppCons (i, lits) = ppIdent i <+> text "`notElem`"- <+> ppExpr 0 (List () (map (Literal ()) lits))+ <+> ppExpr 0 (List NoSpanInfo () (map (Literal NoSpanInfo ()) lits)) -- |Warning message for unreachable patterns. -- To shorten the output only the first 'maxPattern' are printed,@@ -995,14 +1008,14 @@ insertDecl _ = ok insertTypeExpr :: TypeExpr -> WCM ()-insertTypeExpr (VariableType _) = ok-insertTypeExpr (ConstructorType _) = ok-insertTypeExpr (ApplyType ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2]-insertTypeExpr (TupleType tys) = mapM_ insertTypeExpr tys-insertTypeExpr (ListType ty) = insertTypeExpr ty-insertTypeExpr (ArrowType ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2]-insertTypeExpr (ParenType ty) = insertTypeExpr ty-insertTypeExpr (ForallType _ ty) = insertTypeExpr ty+insertTypeExpr (VariableType _ _) = ok+insertTypeExpr (ConstructorType _ _) = ok+insertTypeExpr (ApplyType _ ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2]+insertTypeExpr (TupleType _ tys) = mapM_ insertTypeExpr tys+insertTypeExpr (ListType _ ty) = insertTypeExpr ty+insertTypeExpr (ArrowType _ ty1 ty2) = mapM_ insertTypeExpr [ty1,ty2]+insertTypeExpr (ParenType _ ty) = insertTypeExpr ty+insertTypeExpr (ForallType _ _ ty) = insertTypeExpr ty insertConstrDecl :: ConstrDecl -> WCM () insertConstrDecl (ConstrDecl _ _ _ c _) = insertConsId c@@ -1019,27 +1032,27 @@ -- necessary to determine whether a constructor pattern represents a -- constructor or a function. insertPattern :: Bool -> Pattern a -> WCM ()-insertPattern fp (VariablePattern _ v) = do+insertPattern fp (VariablePattern _ _ v) = do cons <- isConsId v unless cons $ do var <- isVarId v if and [fp, var, not (isAnonId v)] then visitId v else insertVar v-insertPattern fp (ConstructorPattern _ c ps) = do+insertPattern fp (ConstructorPattern _ _ c ps) = do cons <- isQualConsId c mapM_ (insertPattern (not cons || fp)) ps-insertPattern fp (InfixPattern a p1 c p2)- = insertPattern fp (ConstructorPattern a c [p1, p2])-insertPattern fp (ParenPattern p) = insertPattern fp p-insertPattern fp (RecordPattern _ _ fs) = mapM_ (insertFieldPattern fp) fs-insertPattern fp (TuplePattern ps) = mapM_ (insertPattern fp) ps-insertPattern fp (ListPattern _ ps) = mapM_ (insertPattern fp) ps-insertPattern fp (AsPattern v p) = insertVar v >> insertPattern fp p-insertPattern fp (LazyPattern p) = insertPattern fp p-insertPattern _ (FunctionPattern _ f ps) = do+insertPattern fp (InfixPattern spi a p1 c p2)+ = insertPattern fp (ConstructorPattern spi a c [p1, p2])+insertPattern fp (ParenPattern _ p) = insertPattern fp p+insertPattern fp (RecordPattern _ _ _ fs) = mapM_ (insertFieldPattern fp) fs+insertPattern fp (TuplePattern _ ps) = mapM_ (insertPattern fp) ps+insertPattern fp (ListPattern _ _ ps) = mapM_ (insertPattern fp) ps+insertPattern fp (AsPattern _ v p) = insertVar v >> insertPattern fp p+insertPattern fp (LazyPattern _ p) = insertPattern fp p+insertPattern _ (FunctionPattern _ _ f ps) = do visitQId f mapM_ (insertPattern True) ps-insertPattern _ (InfixFuncPattern a p1 f p2)- = insertPattern True (FunctionPattern a f [p1, p2])+insertPattern _ (InfixFuncPattern spi a p1 f p2)+ = insertPattern True (FunctionPattern spi a f [p1, p2]) insertPattern _ _ = ok insertFieldPattern :: Bool -> Field (Pattern a) -> WCM ()@@ -1272,26 +1285,26 @@ checkCaseModeContext = mapM_ checkCaseModeConstraint checkCaseModeConstraint :: Constraint -> WCM ()-checkCaseModeConstraint (Constraint _ ty) = checkCaseModeTypeExpr ty+checkCaseModeConstraint (Constraint _ _ ty) = checkCaseModeTypeExpr ty checkCaseModeTypeExpr :: TypeExpr -> WCM ()-checkCaseModeTypeExpr (ApplyType ty1 ty2) = do+checkCaseModeTypeExpr (ApplyType _ ty1 ty2) = do checkCaseModeTypeExpr ty1 checkCaseModeTypeExpr ty2-checkCaseModeTypeExpr (VariableType tv) = checkCaseModeID isVarName tv-checkCaseModeTypeExpr (TupleType tys) = mapM_ checkCaseModeTypeExpr tys-checkCaseModeTypeExpr (ListType ty) = checkCaseModeTypeExpr ty-checkCaseModeTypeExpr (ArrowType ty1 ty2) = do+checkCaseModeTypeExpr (VariableType _ tv) = checkCaseModeID isVarName tv+checkCaseModeTypeExpr (TupleType _ tys) = mapM_ checkCaseModeTypeExpr tys+checkCaseModeTypeExpr (ListType _ ty) = checkCaseModeTypeExpr ty+checkCaseModeTypeExpr (ArrowType _ ty1 ty2) = do checkCaseModeTypeExpr ty1 checkCaseModeTypeExpr ty2-checkCaseModeTypeExpr (ParenType ty) = checkCaseModeTypeExpr ty-checkCaseModeTypeExpr (ForallType tvs ty) = do+checkCaseModeTypeExpr (ParenType _ ty) = checkCaseModeTypeExpr ty+checkCaseModeTypeExpr (ForallType _ tvs ty) = do mapM_ (checkCaseModeID isVarName) tvs checkCaseModeTypeExpr ty checkCaseModeTypeExpr _ = ok checkCaseModeQualTypeExpr :: QualTypeExpr -> WCM ()-checkCaseModeQualTypeExpr (QualTypeExpr cx ty) = do+checkCaseModeQualTypeExpr (QualTypeExpr _ cx ty) = do checkCaseModeContext cx checkCaseModeTypeExpr ty @@ -1301,14 +1314,14 @@ checkCaseModeRhs rhs checkCaseModeLhs :: Lhs a -> WCM ()-checkCaseModeLhs (FunLhs f ts) = do+checkCaseModeLhs (FunLhs _ f ts) = do checkCaseModeID isFuncName f mapM_ checkCaseModePattern ts-checkCaseModeLhs (OpLhs t1 f t2) = do+checkCaseModeLhs (OpLhs _ t1 f t2) = do checkCaseModePattern t1 checkCaseModeID isFuncName f checkCaseModePattern t2-checkCaseModeLhs (ApLhs lhs ts) = do+checkCaseModeLhs (ApLhs _ lhs ts) = do checkCaseModeLhs lhs mapM_ checkCaseModePattern ts @@ -1316,7 +1329,7 @@ checkCaseModeRhs (SimpleRhs _ e ds) = do checkCaseModeExpr e mapM_ checkCaseModeDecl ds-checkCaseModeRhs (GuardedRhs es ds) = do+checkCaseModeRhs (GuardedRhs _ es ds) = do mapM_ checkCaseModeCondExpr es mapM_ checkCaseModeDecl ds @@ -1326,81 +1339,83 @@ checkCaseModeExpr e checkCaseModePattern :: Pattern a -> WCM ()-checkCaseModePattern (VariablePattern _ v) = checkCaseModeID isVarName v-checkCaseModePattern (ConstructorPattern _ _ ts) = mapM_ checkCaseModePattern ts-checkCaseModePattern (InfixPattern _ t1 _ t2) = do+checkCaseModePattern (VariablePattern _ _ v) = checkCaseModeID isVarName v+checkCaseModePattern (ConstructorPattern _ _ _ ts) =+ mapM_ checkCaseModePattern ts+checkCaseModePattern (InfixPattern _ _ t1 _ t2) = do checkCaseModePattern t1 checkCaseModePattern t2-checkCaseModePattern (ParenPattern t) = checkCaseModePattern t-checkCaseModePattern (RecordPattern _ _ fs) = mapM_ checkCaseModeFieldPattern fs-checkCaseModePattern (TuplePattern ts) = mapM_ checkCaseModePattern ts-checkCaseModePattern (ListPattern _ ts) = mapM_ checkCaseModePattern ts-checkCaseModePattern (AsPattern v t) = do+checkCaseModePattern (ParenPattern _ t) = checkCaseModePattern t+checkCaseModePattern (RecordPattern _ _ _ fs) =+ mapM_ checkCaseModeFieldPattern fs+checkCaseModePattern (TuplePattern _ ts) = mapM_ checkCaseModePattern ts+checkCaseModePattern (ListPattern _ _ ts) = mapM_ checkCaseModePattern ts+checkCaseModePattern (AsPattern _ v t) = do checkCaseModeID isVarName v checkCaseModePattern t-checkCaseModePattern (LazyPattern t) = checkCaseModePattern t-checkCaseModePattern (FunctionPattern _ _ ts) = mapM_ checkCaseModePattern ts-checkCaseModePattern (InfixFuncPattern _ t1 _ t2) = do+checkCaseModePattern (LazyPattern _ t) = checkCaseModePattern t+checkCaseModePattern (FunctionPattern _ _ _ ts) = mapM_ checkCaseModePattern ts+checkCaseModePattern (InfixFuncPattern _ _ t1 _ t2) = do checkCaseModePattern t1 checkCaseModePattern t2 checkCaseModePattern _ = ok checkCaseModeExpr :: Expression a -> WCM ()-checkCaseModeExpr (Paren e) = checkCaseModeExpr e-checkCaseModeExpr (Typed e qty) = do+checkCaseModeExpr (Paren _ e) = checkCaseModeExpr e+checkCaseModeExpr (Typed _ e qty) = do checkCaseModeExpr e checkCaseModeQualTypeExpr qty-checkCaseModeExpr (Record _ _ fs) = mapM_ checkCaseModeFieldExpr fs-checkCaseModeExpr (RecordUpdate e fs) = do+checkCaseModeExpr (Record _ _ _ fs) = mapM_ checkCaseModeFieldExpr fs+checkCaseModeExpr (RecordUpdate _ e fs) = do checkCaseModeExpr e mapM_ checkCaseModeFieldExpr fs-checkCaseModeExpr (Tuple es) = mapM_ checkCaseModeExpr es-checkCaseModeExpr (List _ es) = mapM_ checkCaseModeExpr es-checkCaseModeExpr (ListCompr e stms) = do+checkCaseModeExpr (Tuple _ es) = mapM_ checkCaseModeExpr es+checkCaseModeExpr (List _ _ es) = mapM_ checkCaseModeExpr es+checkCaseModeExpr (ListCompr _ e stms) = do checkCaseModeExpr e mapM_ checkCaseModeStatement stms-checkCaseModeExpr (EnumFrom e) = checkCaseModeExpr e-checkCaseModeExpr (EnumFromThen e1 e2) = do+checkCaseModeExpr (EnumFrom _ e) = checkCaseModeExpr e+checkCaseModeExpr (EnumFromThen _ e1 e2) = do checkCaseModeExpr e1 checkCaseModeExpr e2-checkCaseModeExpr (EnumFromTo e1 e2) = do+checkCaseModeExpr (EnumFromTo _ e1 e2) = do checkCaseModeExpr e1 checkCaseModeExpr e2-checkCaseModeExpr (EnumFromThenTo e1 e2 e3) = do+checkCaseModeExpr (EnumFromThenTo _ e1 e2 e3) = do checkCaseModeExpr e1 checkCaseModeExpr e2 checkCaseModeExpr e3-checkCaseModeExpr (UnaryMinus e) = checkCaseModeExpr e-checkCaseModeExpr (Apply e1 e2) = do+checkCaseModeExpr (UnaryMinus _ e) = checkCaseModeExpr e+checkCaseModeExpr (Apply _ e1 e2) = do checkCaseModeExpr e1 checkCaseModeExpr e2-checkCaseModeExpr (InfixApply e1 _ e2) = do+checkCaseModeExpr (InfixApply _ e1 _ e2) = do checkCaseModeExpr e1 checkCaseModeExpr e2-checkCaseModeExpr (LeftSection e _) = checkCaseModeExpr e-checkCaseModeExpr (RightSection _ e) = checkCaseModeExpr e-checkCaseModeExpr (Lambda ts e) = do+checkCaseModeExpr (LeftSection _ e _) = checkCaseModeExpr e+checkCaseModeExpr (RightSection _ _ e) = checkCaseModeExpr e+checkCaseModeExpr (Lambda _ ts e) = do mapM_ checkCaseModePattern ts checkCaseModeExpr e-checkCaseModeExpr (Let ds e) = do+checkCaseModeExpr (Let _ ds e) = do mapM_ checkCaseModeDecl ds checkCaseModeExpr e-checkCaseModeExpr (Do stms e) = do+checkCaseModeExpr (Do _ stms e) = do mapM_ checkCaseModeStatement stms checkCaseModeExpr e-checkCaseModeExpr (IfThenElse e1 e2 e3) = do+checkCaseModeExpr (IfThenElse _ e1 e2 e3) = do checkCaseModeExpr e1 checkCaseModeExpr e2 checkCaseModeExpr e3-checkCaseModeExpr (Case _ e as) = do+checkCaseModeExpr (Case _ _ e as) = do mapM_ checkCaseModeAlt as checkCaseModeExpr e checkCaseModeExpr _ = ok checkCaseModeStatement :: Statement a -> WCM ()-checkCaseModeStatement (StmtExpr e) = checkCaseModeExpr e-checkCaseModeStatement (StmtDecl ds) = mapM_ checkCaseModeDecl ds-checkCaseModeStatement (StmtBind t e) = do+checkCaseModeStatement (StmtExpr _ e) = checkCaseModeExpr e+checkCaseModeStatement (StmtDecl _ ds) = mapM_ checkCaseModeDecl ds+checkCaseModeStatement (StmtBind _ t e) = do checkCaseModePattern t checkCaseModeExpr e @@ -1453,8 +1468,8 @@ text "try renaming to" <+> text (caseSuggestion name) <+> text "instead" caseSuggestion :: String -> String-caseSuggestion (x:xs) | isLower x = (toUpper x : xs)- | isUpper x = (toLower x : xs)+caseSuggestion (x:xs) | isLower x = toUpper x : xs+ | isUpper x = toLower x : xs caseSuggestion _ = internalError "Checks.WarnCheck.caseSuggestion: Identifier starts with illegal Symbol"
src/CompilerOpts.hs view
@@ -5,9 +5,10 @@ 2007 Sebastian Fischer 2011 - 2016 Björn Peemöller 2016 - 2017 Finn Teegen+ 2018 Kai-Oliver Prott License : BSD-3-clause - Maintainer : bjp@informatik.uni-kiel.de+ Maintainer : fte@informatik.uni-kiel.de Stability : experimental Portability : portable @@ -175,12 +176,16 @@ -- |Type of the target file data TargetType = Tokens -- ^ Source code tokens+ | Comments -- ^ Source code comments | Parsed -- ^ Parsed source code | FlatCurry -- ^ FlatCurry | TypedFlatCurry -- ^ Typed FlatCurry- | AbstractCurry -- ^ AbstractCurry- | UntypedAbstractCurry -- ^ Untyped AbstractCurry- | Html -- ^ HTML documentation+ | TypeAnnotatedFlatCurry -- ^ Type-annotated FlatCurry+ | AbstractCurry -- ^ AbstractCurry+ | UntypedAbstractCurry -- ^ Untyped AbstractCurry+ | Html -- ^ HTML documentation+ | AST -- ^ Abstract-Syntax-Tree after checks+ | ShortAST -- ^ Abstract-Syntax-Tree with shortened decls deriving (Eq, Show) -- |Warnings flags@@ -421,20 +426,28 @@ addFlag WarnOverlapping (wnWarnFlags opts) })) "do not print warnings for overlapping rules" -- target types- , targetOption Tokens "tokens"+ , targetOption Tokens "tokens" "generate token stream"- , targetOption Parsed "parse-only"+ , targetOption Comments "comments"+ "generate comments stream"+ , targetOption Parsed "parse-only" "generate source representation"- , targetOption FlatCurry "flat"+ , targetOption FlatCurry "flat" "generate FlatCurry code"- , targetOption TypedFlatCurry "typed-flat"+ , targetOption TypedFlatCurry "typed-flat" "generate typed FlatCurry code"- , targetOption AbstractCurry "acy"+ , targetOption TypeAnnotatedFlatCurry "type-annotated-flat"+ "generate type-annotated FlatCurry code"+ , targetOption AbstractCurry "acy" "generate typed AbstractCurry"- , targetOption UntypedAbstractCurry "uacy"+ , targetOption UntypedAbstractCurry "uacy" "generate untyped AbstractCurry"- , targetOption Html "html"+ , targetOption Html "html" "generate html documentation"+ , targetOption AST "ast"+ "generate abstract syntax tree"+ , targetOption ShortAST "short-ast"+ "generate shortened abstract syntax tree for documentation" , Option "F" [] (NoArg (onPrepOpts $ \ opts -> opts { ppPreprocess = True })) "use custom preprocessor"
src/CurryBuilder.hs view
@@ -4,9 +4,10 @@ Copyright : (c) 2005 Martin Engelke 2007 Sebastian Fischer 2011 - 2015 Björn Peemöller+ 2018 Kai-Oliver Prott License : BSD-3-clause - Maintainer : bjp@informatik.uni-kiel.de+ Maintainer : fte@informatik.uni-kiel.de Stability : experimental Portability : portable @@ -23,6 +24,7 @@ import Curry.Base.Ident import Curry.Base.Monad import Curry.Base.Position (Position)+import Curry.Base.SpanInfo (spanInfo2Pos) import Curry.Base.Pretty import Curry.Files.Filenames import Curry.Files.PathUtils@@ -112,8 +114,8 @@ let opts1 = foldl processLanguagePragma opts0 [ e | LanguagePragma _ es <- ps, KnownExtension _ e <- es ] foldM processOptionPragma opts1 $- [ (p, s) | OptionsPragma p (Just FRONTEND) s <- ps ] ++- [ (p, s) | OptionsPragma p (Just CYMAKE) s <- ps ]+ [ (spanInfo2Pos p, s) | OptionsPragma p (Just FRONTEND) s <- ps ] +++ [ (spanInfo2Pos p, s) | OptionsPragma p (Just CYMAKE) s <- ps ] where processLanguagePragma opts CPP = opts { optCppOpts = (optCppOpts opts) { cppRun = True } }@@ -165,12 +167,16 @@ destFiles = [ gen fn | (t, gen) <- nameGens, t `elem` optTargetTypes opts] nameGens =- [ (Tokens , tgtDir . tokensName )- , (Parsed , tgtDir . sourceRepName)- , (FlatCurry , tgtDir . flatName )- , (TypedFlatCurry , tgtDir . typedFlatName)- , (AbstractCurry , tgtDir . acyName )- , (UntypedAbstractCurry, tgtDir . uacyName )+ [ (Tokens , tgtDir . tokensName )+ , (Comments , tgtDir . commentsName)+ , (Parsed , tgtDir . sourceRepName )+ , (FlatCurry , tgtDir . flatName )+ , (TypedFlatCurry , tgtDir . typedFlatName )+ , (TypeAnnotatedFlatCurry, tgtDir . typeAnnFlatName)+ , (AbstractCurry , tgtDir . acyName )+ , (UntypedAbstractCurry, tgtDir . uacyName )+ , (AST , tgtDir . astName )+ , (ShortAST , tgtDir . shortASTName ) , (Html , const (fromMaybe "." (optHtmlDir opts) </> htmlName m)) ]
src/CurryDeps.hs view
@@ -16,10 +16,14 @@ information between Curry modules. This is used to create Makefile dependencies and to update programs composed of multiple modules. -}-+{-# LANGUAGE CPP #-} module CurryDeps ( Source (..), flatDeps, deps, flattenDeps, sourceDeps, moduleDeps ) where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ import Control.Monad (foldM) import Data.List (isSuffixOf, nub) import qualified Data.Map as Map (Map, empty, insert, lookup, toList)@@ -96,7 +100,7 @@ -- |Retrieve the dependencies of a given module moduleDeps :: Options -> SourceEnv -> FilePath -> Module a -> CYIO SourceEnv-moduleDeps opts sEnv fn mdl@(Module ps m _ _ _) = case Map.lookup m sEnv of+moduleDeps opts sEnv fn mdl@(Module _ ps m _ _ _) = case Map.lookup m sEnv of Just _ -> return sEnv Nothing -> do let imps = imports opts mdl@@ -106,7 +110,7 @@ -- |Retrieve the imported modules and add the import of the Prelude -- according to the compiler options. imports :: Options -> Module a -> [ModuleIdent]-imports opts mdl@(Module _ m _ is _) = nub $+imports opts mdl@(Module _ _ m _ is _) = nub $ [preludeMIdent | m /= preludeMIdent && not noImplicitPrelude] ++ [m' | ImportDecl _ m' _ _ _ <- is] where noImplicitPrelude = NoImplicitPrelude `elem` optExtensions opts@@ -125,9 +129,9 @@ | icurryExt `isSuffixOf` fn -> return $ Map.insert m (Interface fn) sEnv | otherwise -> do- hdr@(Module _ m' _ _ _) <- readHeader opts fn- if (m == m') then moduleDeps opts sEnv fn hdr- else failMessages [errWrongModule m m']+ hdr@(Module _ _ m' _ _ _) <- readHeader opts fn+ if m == m' then moduleDeps opts sEnv fn hdr+ else failMessages [errWrongModule m m'] readHeader :: Options -> FilePath -> CYIO (Module ()) readHeader opts fn = do
src/Env/TypeConstructor.hs view
@@ -45,13 +45,17 @@ exported at all in order to make the interface more stable against changes which are private to the module. -}-+{-# LANGUAGE CPP #-} module Env.TypeConstructor ( TypeInfo (..), tcKind, clsKind, varKind, clsMethods , TCEnv, initTCEnv, bindTypeInfo, rebindTypeInfo , lookupTypeInfo, qualLookupTypeInfo, qualLookupTypeInfoUnique , getOrigName, reverseLookupByOrigName ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif import Curry.Base.Ident import Curry.Base.Pretty (Pretty(..), blankLine)
src/Env/Value.hs view
@@ -22,7 +22,7 @@ information. On import two values are considered equal if their original names match. -}-+{-# LANGUAGE CPP #-} module Env.Value ( ValueEnv, ValueInfo (..) , bindGlobalInfo, bindFun, qualBindFun, rebindFun, unbindFun@@ -30,6 +30,10 @@ , initDCEnv , ValueType (..), bindLocalVars, bindLocalVar ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif import Curry.Base.Ident import Curry.Base.Pretty (Pretty(..))
src/Exports.hs view
@@ -21,11 +21,12 @@ import Data.List (nub) import qualified Data.Map as Map (foldrWithKey, toList)-import Data.Maybe (catMaybes)+import Data.Maybe (mapMaybe) import qualified Data.Set as Set ( Set, empty, insert, deleteMin, fromList , member, toList ) import Curry.Base.Position+import Curry.Base.SpanInfo import Curry.Base.Ident import Curry.Syntax @@ -62,10 +63,10 @@ -- exported function. exportInterface :: CompilerEnv -> Module a -> Interface-exportInterface env (Module _ m (Just (Exporting _ es)) _ _) =+exportInterface env (Module _ _ m (Just (Exporting _ es)) _ _) = exportInterface' m es (opPrecEnv env) (tyConsEnv env) (valueEnv env) (classEnv env) (instEnv env)-exportInterface _ (Module _ _ Nothing _ _) =+exportInterface _ (Module _ _ _ Nothing _ _) = internalError "Exports.exportInterface: no export specification" exportInterface' :: ModuleIdent -> [Export] -> OpPrecEnv -> TCEnv -> ValueEnv@@ -73,7 +74,7 @@ exportInterface' m es pEnv tcEnv vEnv clsEnv inEnv = Interface m imports decls' where tvs = filter (`notElem` tcs) identSupply- tcs = catMaybes $ map (localIdent m) $ definedTypes decls'+ tcs = mapMaybe (localIdent m) $ definedTypes decls' imports = map (IImportDecl NoPos) $ usedModules decls' precs = foldr (infixDecl m pEnv) [] es types = foldr (typeDecl m tcEnv clsEnv tvs) [] es@@ -83,8 +84,8 @@ decls' = closeInterface m tcEnv clsEnv inEnv tvs Set.empty decls infixDecl :: ModuleIdent -> OpPrecEnv -> Export -> [IDecl] -> [IDecl]-infixDecl m pEnv (Export f) ds = iInfixDecl m pEnv f ds-infixDecl m pEnv (ExportTypeWith tc cs) ds =+infixDecl m pEnv (Export _ f) ds = iInfixDecl m pEnv f ds+infixDecl m pEnv (ExportTypeWith _ tc cs) ds = foldr (iInfixDecl m pEnv . qualifyLike tc) ds cs infixDecl _ _ _ _ = internalError "Exports.infixDecl: no pattern match" @@ -103,8 +104,8 @@ typeDecl :: ModuleIdent -> TCEnv -> ClassEnv -> [Ident] -> Export -> [IDecl] -> [IDecl]-typeDecl _ _ _ _ (Export _) ds = ds-typeDecl m tcEnv clsEnv tvs (ExportTypeWith tc xs) ds =+typeDecl _ _ _ _ (Export _ _) ds = ds+typeDecl m tcEnv clsEnv tvs (ExportTypeWith _ tc xs) ds = case qualLookupTypeInfo tc tcEnv of [DataType tc' k cs] | null xs -> iTypeDecl IDataDecl m tvs tc' k [] [] : ds@@ -128,7 +129,8 @@ ty' = fromQualType m tvs' ty [TypeClass qcls k ms] -> IClassDecl NoPos cx qcls' k' tv ms' hs : ds where qcls' = qualUnqualify m qcls- cx = [ Constraint (qualUnqualify m scls) (VariableType tv)+ cx = [ Constraint NoSpanInfo (qualUnqualify m scls)+ (VariableType NoSpanInfo tv) | scls <- superClasses qcls clsEnv ] k' = fromKind' k 0 tv = head tvs@@ -146,26 +148,28 @@ constrDecl :: ModuleIdent -> Int -> [Ident] -> DataConstr -> ConstrDecl constrDecl m n tvs (DataConstr c n' ps [ty1, ty2])- | isInfixOp c = ConOpDecl NoPos evs cx ty1' c ty2'+ | isInfixOp c = ConOpDecl NoSpanInfo evs cx ty1' c ty2' where evs = take n' $ drop n tvs cx = fromQualPredSet m tvs ps [ty1', ty2'] = map (fromQualType m tvs) [ty1, ty2]-constrDecl m n tvs (DataConstr c n' ps tys) = ConstrDecl NoPos evs cx c tys'+constrDecl m n tvs (DataConstr c n' ps tys) =+ ConstrDecl NoSpanInfo evs cx c tys' where evs = take n' $ drop n tvs cx = fromQualPredSet m tvs ps tys' = map (fromQualType m tvs) tys-constrDecl m n tvs (RecordConstr c n' ps ls tys) = RecordDecl NoPos evs cx c fs+constrDecl m n tvs (RecordConstr c n' ps ls tys) =+ RecordDecl NoSpanInfo evs cx c fs where evs = take n' $ drop n tvs cx = fromQualPredSet m tvs ps tys' = map (fromQualType m tvs) tys- fs = zipWith (FieldDecl NoPos . return) ls tys'+ fs = zipWith (FieldDecl NoSpanInfo . return) ls tys' newConstrDecl :: ModuleIdent -> [Ident] -> DataConstr -> NewConstrDecl newConstrDecl m tvs (DataConstr c _ _ tys)- = NewConstrDecl NoPos c (fromQualType m tvs (head tys))+ = NewConstrDecl NoSpanInfo c (fromQualType m tvs (head tys)) newConstrDecl m tvs (RecordConstr c _ _ ls tys)- = NewRecordDecl NoPos c (head ls, fromQualType m tvs (head tys))+ = NewRecordDecl NoSpanInfo c (head ls, fromQualType m tvs (head tys)) -- When exporting a class method, we have to remove the implicit class context. -- Due to the sorting of the predicate set, this is fortunatly very easy. The@@ -177,12 +181,12 @@ fromQualPredType m tvs $ PredType (Set.deleteMin ps) ty valueDecl :: ModuleIdent -> ValueEnv -> [Ident] -> Export -> [IDecl] -> [IDecl]-valueDecl m vEnv tvs (Export f) ds = case qualLookupValue f vEnv of+valueDecl m vEnv tvs (Export _ f) ds = case qualLookupValue f vEnv of [Value _ cm a (ForAll _ pty)] -> IFunctionDecl NoPos (qualUnqualify m f) (if cm then Just (head tvs) else Nothing) a (fromQualPredType m tvs pty) : ds _ -> internalError $ "Exports.valueDecl: " ++ show f-valueDecl _ _ _ (ExportTypeWith _ _) ds = ds+valueDecl _ _ _ (ExportTypeWith _ _ _) ds = ds valueDecl _ _ _ _ _ = internalError "Exports.valueDecl: no pattern match" instDecl :: ModuleIdent -> TCEnv -> [Ident] -> InstIdent -> InstInfo -> [IDecl]@@ -197,7 +201,7 @@ IInstanceDecl NoPos cx (qualUnqualify m cls) ty is mm where pty = PredType ps $ applyType (TypeConstructor tc) $ map TypeVariable [0 .. n-1]- QualTypeExpr cx ty = fromQualPredType m tvs pty+ QualTypeExpr _ cx ty = fromQualPredType m tvs pty n = kindArity (tcKind m tc tcEnv) - kindArity (clsKind m cls tcEnv) mm = if m == m' then Nothing else Just m' @@ -261,20 +265,20 @@ modules (IMethodDecl _ _ _ qty) = modules qty instance HasModule Constraint where- modules (Constraint cls ty) = modules cls . modules ty+ modules (Constraint _ cls ty) = modules cls . modules ty instance HasModule TypeExpr where- modules (ConstructorType tc) = modules tc- modules (ApplyType ty1 ty2) = modules ty1 . modules ty2- modules (VariableType _) = id- modules (TupleType tys) = modules tys- modules (ListType ty) = modules ty- modules (ArrowType ty1 ty2) = modules ty1 . modules ty2- modules (ParenType ty) = modules ty- modules (ForallType _ ty) = modules ty+ modules (ConstructorType _ tc) = modules tc+ modules (ApplyType _ ty1 ty2) = modules ty1 . modules ty2+ modules (VariableType _ _) = id+ modules (TupleType _ tys) = modules tys+ modules (ListType _ ty) = modules ty+ modules (ArrowType _ ty1 ty2) = modules ty1 . modules ty2+ modules (ParenType _ ty) = modules ty+ modules (ForallType _ _ ty) = modules ty instance HasModule QualTypeExpr where- modules (QualTypeExpr cx ty) = modules cx . modules ty+ modules (QualTypeExpr _ cx ty) = modules cx . modules ty instance HasModule QualIdent where modules = modules . qidModule@@ -334,7 +338,8 @@ k' = fromKind' k n in HidingDataDecl NoPos tc k' $ take n tvs hidingClassDecl k sclss =- let cx = [ Constraint (qualUnqualify m scls) (VariableType tv)+ let cx = [ Constraint NoSpanInfo (qualUnqualify m scls)+ (VariableType NoSpanInfo tv) | scls <- sclss ] tv = head tvs k' = fromKind' k 0@@ -409,17 +414,17 @@ usedTypes (IMethodDecl _ _ _ qty) = usedTypes qty instance HasType Constraint where- usedTypes (Constraint cls ty) = (cls :) . usedTypes ty+ usedTypes (Constraint _ cls ty) = (cls :) . usedTypes ty instance HasType TypeExpr where- usedTypes (ConstructorType tc) = (tc :)- usedTypes (ApplyType ty1 ty2) = usedTypes ty1 . usedTypes ty2- usedTypes (VariableType _) = id- usedTypes (TupleType tys) = usedTypes tys- usedTypes (ListType ty) = usedTypes ty- usedTypes (ArrowType ty1 ty2) = usedTypes ty1 . usedTypes ty2- usedTypes (ParenType ty) = usedTypes ty- usedTypes (ForallType _ ty) = usedTypes ty+ usedTypes (ConstructorType _ tc) = (tc :)+ usedTypes (ApplyType _ ty1 ty2) = usedTypes ty1 . usedTypes ty2+ usedTypes (VariableType _ _) = id+ usedTypes (TupleType _ tys) = usedTypes tys+ usedTypes (ListType _ ty) = usedTypes ty+ usedTypes (ArrowType _ ty1 ty2) = usedTypes ty1 . usedTypes ty2+ usedTypes (ParenType _ ty) = usedTypes ty+ usedTypes (ForallType _ _ ty) = usedTypes ty instance HasType QualTypeExpr where- usedTypes (QualTypeExpr cx ty) = usedTypes cx . usedTypes ty+ usedTypes (QualTypeExpr _ cx ty) = usedTypes cx . usedTypes ty
src/Generators.hs view
@@ -3,9 +3,10 @@ Description : Code generators Copyright : (c) 2011 Björn Peemöller 2017 Finn Teegen+ 2018 Kai-Oliver Prott License : BSD-3-clause - Maintainer : bjp@informatik.uni-kiel.de+ Maintainer : fte@informatik.uni-kiel.de Stability : experimental Portability : portable @@ -13,16 +14,19 @@ -} module Generators where -import qualified Curry.AbstractCurry as AC (CurryProg)-import qualified Curry.FlatCurry.Type as FC (Prog)-import qualified Curry.FlatCurry.Annotated.Type as AFC (AProg, TypeExpr)-import qualified Curry.Syntax as CS (Module)+import qualified Curry.AbstractCurry as AC (CurryProg)+import qualified Curry.FlatCurry.Type as FC (Prog, TypeExpr)+import qualified Curry.FlatCurry.Annotated.Type as AFC (AProg)+import qualified Curry.FlatCurry.Typed.Type as TFC (TProg)+import qualified Curry.Syntax as CS (Module) -import qualified Generators.GenAbstractCurry as GAC (genAbstractCurry)-import qualified Generators.GenFlatCurry as GFC ( genFlatCurry- , genFlatInterface- )-import qualified Generators.GenTypedFlatCurry as GTFC (genTypedFlatCurry)+import qualified Generators.GenAbstractCurry as GAC (genAbstractCurry)+import qualified Generators.GenFlatCurry as GFC ( genFlatCurry+ , genFlatInterface+ )+import qualified Generators.GenTypeAnnotatedFlatCurry+ as GTAFC (genTypeAnnotatedFlatCurry)+import qualified Generators.GenTypedFlatCurry as GTFC (genTypedFlatCurry) import Base.Types (Type, PredType) @@ -39,11 +43,16 @@ -- |Generate typed FlatCurry genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module- -> AFC.AProg AFC.TypeExpr+ -> TFC.TProg genTypedFlatCurry = GTFC.genTypedFlatCurry +-- |Generate type-annotated FlatCurry+genTypeAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module+ -> AFC.AProg FC.TypeExpr+genTypeAnnotatedFlatCurry = GTAFC.genTypeAnnotatedFlatCurry+ -- |Generate FlatCurry-genFlatCurry :: AFC.AProg a -> FC.Prog+genFlatCurry :: TFC.TProg -> FC.Prog genFlatCurry = GFC.genFlatCurry -- |Generate a FlatCurry interface
src/Generators/GenAbstractCurry.hs view
@@ -31,6 +31,7 @@ import Curry.AbstractCurry import Curry.Base.Ident+import Curry.Base.SpanInfo import Curry.Syntax import Base.CurryTypes (fromPredType, toType, toPredType)@@ -62,7 +63,7 @@ -- --------------------------------------------------------------------------- trModule :: Module PredType -> GAC CurryProg-trModule (Module _ mid _ is ds) = do+trModule (Module _ _ mid _ is ds) = CurryProg mid' is' <$> dflt' <*> cds' <*> ids' <*> ts' <*> fs' <*> os' where mid' = moduleName mid@@ -83,7 +84,7 @@ trDefaultDecl _ = return [] trClassDecl :: Decl PredType -> GAC [CClassDecl]-trClassDecl (ClassDecl _ cx cls tv ds) = do+trClassDecl (ClassDecl _ cx cls tv ds) = (\cls' v' cx' tv' ds' -> [CClass cls' v' cx' tv' ds']) <$> trGlobalIdent cls <*> getTypeVisibility cls <*> trContext cx <*> getTVarIndex tv <*> concatMapM (trClassMethodDecl sigs fs) ds@@ -99,7 +100,7 @@ -> GAC [CFuncDecl] trClassMethodDecl sigs fs (TypeSig p [f] _) | f `notElem` fs = trClassMethodDecl sigs fs $ FunctionDecl p undefined f []-trClassMethodDecl sigs fs (TypeSig p (f:f':fs') qty) = do+trClassMethodDecl sigs fs (TypeSig p (f:f':fs') qty) = liftM2 (++) (trClassMethodDecl sigs fs $ TypeSig p [f] qty) (trClassMethodDecl sigs fs $ TypeSig p (f':fs') qty) trClassMethodDecl sigs _ (FunctionDecl _ _ f eqs) =@@ -121,7 +122,8 @@ trInstanceMethodDecl qcls ty (FunctionDecl _ _ f eqs) = do uacy <- S.gets untypedAcy qty <- if uacy- then return $ QualTypeExpr [] $ ConstructorType prelUntyped+ then return $ QualTypeExpr NoSpanInfo [] $+ ConstructorType NoSpanInfo prelUntyped else getQualType' (qualifyLike qcls $ unRenameIdent f) CFunc <$> trLocalIdent f <*> pure (eqnArity $ head eqs) <*> pure Public <*> trInstanceMethodType ty qty <*> mapM trEquation eqs@@ -131,10 +133,10 @@ -- the class variable with the given instance type. The implicit class context -- is dropped in doing so. trInstanceMethodType :: TypeExpr -> QualTypeExpr -> GAC CQualTypeExpr-trInstanceMethodType ity (QualTypeExpr cx ty) =+trInstanceMethodType ity (QualTypeExpr _ cx ty) = trQualTypeExpr $ fromPredType identSupply $ subst (bindSubst 0 (toType [] ity) idSubst) $- toPredType (take 1 identSupply) $ QualTypeExpr (drop 1 cx) ty+ toPredType (take 1 identSupply) $ QualTypeExpr NoSpanInfo (drop 1 cx) ty trTypeDecl :: Decl a -> GAC [CTypeDecl] trTypeDecl (DataDecl _ t vs cs clss) =@@ -150,6 +152,9 @@ <$> trGlobalIdent t <*> getTypeVisibility t <*> mapM genTVarIndex vs <*> trNewConsDecl nc <*> mapM trQual clss+trTypeDecl (ExternalDataDecl _ t vs) =+ (\t' v vs' -> [CType t' v vs' [] []])+ <$> trGlobalIdent t <*> getTypeVisibility t <*> mapM genTVarIndex vs trTypeDecl _ = return [] trConsDecl :: ConstrDecl -> GAC CConsDecl@@ -173,25 +178,26 @@ <$> trGlobalIdent nc <*> getVisibility nc <*> trFieldDecl (FieldDecl p [l] ty) trTypeExpr :: TypeExpr -> GAC CTypeExpr-trTypeExpr (ConstructorType q) = CTCons <$> trQual q-trTypeExpr (ApplyType ty1 ty2) = CTApply <$> trTypeExpr ty1 <*> trTypeExpr ty2-trTypeExpr (VariableType v) = CTVar <$> getTVarIndex v-trTypeExpr (TupleType tys) =- trTypeExpr $ foldl ApplyType (ConstructorType $ qTupleId $ length tys) tys-trTypeExpr (ListType ty) =- trTypeExpr $ ApplyType (ConstructorType qListId) ty-trTypeExpr (ArrowType ty1 ty2) = CFuncType <$> trTypeExpr ty1 <*> trTypeExpr ty2-trTypeExpr (ParenType ty) = trTypeExpr ty-trTypeExpr (ForallType _ _) = internalError "GenAbstractCurry.trTypeExpr"+trTypeExpr (ConstructorType _ q) = CTCons <$> trQual q+trTypeExpr (ApplyType _ ty1 ty2) = CTApply <$> trTypeExpr ty1 <*> trTypeExpr ty2+trTypeExpr (VariableType _ v) = CTVar <$> getTVarIndex v+trTypeExpr (TupleType _ tys) =+ trTypeExpr $ foldl (ApplyType NoSpanInfo)+ (ConstructorType NoSpanInfo $ qTupleId $ length tys) tys+trTypeExpr (ListType _ ty) =+ trTypeExpr $ ApplyType NoSpanInfo (ConstructorType NoSpanInfo qListId) ty+trTypeExpr (ArrowType _ ty1 ty2) = CFuncType <$> trTypeExpr ty1 <*> trTypeExpr ty2+trTypeExpr (ParenType _ ty) = trTypeExpr ty+trTypeExpr (ForallType _ _ _) = internalError "GenAbstractCurry.trTypeExpr" trConstraint :: Constraint -> GAC CConstraint-trConstraint (Constraint q ty) = (,) <$> trQual q <*> trTypeExpr ty+trConstraint (Constraint _ q ty) = (,) <$> trQual q <*> trTypeExpr ty trContext :: Context -> GAC CContext trContext cx = CContext <$> mapM trConstraint cx trQualTypeExpr :: QualTypeExpr -> GAC CQualTypeExpr-trQualTypeExpr (QualTypeExpr cx ty) =+trQualTypeExpr (QualTypeExpr _ cx ty) = CQualType <$> trContext cx <*> trTypeExpr ty trInfixDecl :: Decl a -> GAC [COpDecl]@@ -229,7 +235,7 @@ trRhs (SimpleRhs _ e ds) = inNestedScope $ do mapM_ insertDeclLhs ds CSimpleRhs <$> trExpr e <*> concatMapM trLocalDecl ds-trRhs (GuardedRhs gs ds) = inNestedScope $ do+trRhs (GuardedRhs _ gs ds) = inNestedScope $ do mapM_ insertDeclLhs ds CGuardedRhs <$> mapM trCondExpr gs <*> concatMapM trLocalDecl ds @@ -267,85 +273,89 @@ insertSig _ = return () trExpr :: Expression PredType -> GAC CExpr-trExpr (Literal _ l) = return (CLit $ cvLiteral l)-trExpr (Variable _ v)+trExpr (Literal _ _ l) = return (CLit $ cvLiteral l)+trExpr (Variable _ _ v) | isQualified v = CSymbol <$> trQual v | otherwise = lookupVarIndex (unqualify v) >>= \mvi -> case mvi of Just vi -> return (CVar vi) _ -> CSymbol <$> trQual v-trExpr (Constructor _ c) = CSymbol <$> trQual c-trExpr (Paren e) = trExpr e-trExpr (Typed e qty) = CTyped <$> trExpr e <*> trQualTypeExpr qty-trExpr (Record _ c fs) = CRecConstr <$> trQual c- <*> mapM (trField trExpr) fs-trExpr (RecordUpdate e fs) = CRecUpdate <$> trExpr e- <*> mapM (trField trExpr) fs-trExpr (Tuple es) =- trExpr $ apply (Variable undefined $ qTupleId $ length es) es-trExpr (List _ es) =- trExpr $ foldr (Apply . Apply (Constructor undefined qConsId))- (Constructor undefined qNilId)+trExpr (Constructor _ _ c) = CSymbol <$> trQual c+trExpr (Paren _ e) = trExpr e+trExpr (Typed _ e qty) = CTyped <$> trExpr e <*> trQualTypeExpr qty+trExpr (Record _ _ c fs) = CRecConstr <$> trQual c+ <*> mapM (trField trExpr) fs+trExpr (RecordUpdate _ e fs) = CRecUpdate <$> trExpr e+ <*> mapM (trField trExpr) fs+trExpr (Tuple _ es) =+ trExpr $ apply (Variable NoSpanInfo undefined $ qTupleId $ length es) es+trExpr (List _ _ es) =+ trExpr $ foldr (Apply NoSpanInfo . Apply NoSpanInfo+ (Constructor NoSpanInfo undefined qConsId))+ (Constructor NoSpanInfo undefined qNilId) es-trExpr (ListCompr e ds) = inNestedScope $ flip CListComp- <$> mapM trStatement ds <*> trExpr e-trExpr (EnumFrom e) =- trExpr $ apply (Variable undefined qEnumFromId) [e]-trExpr (EnumFromThen e1 e2) =- trExpr $ apply (Variable undefined qEnumFromThenId) [e1, e2]-trExpr (EnumFromTo e1 e2) =- trExpr $ apply (Variable undefined qEnumFromToId) [e1, e2]-trExpr (EnumFromThenTo e1 e2 e3) =- trExpr $ apply (Variable undefined qEnumFromThenToId) [e1, e2, e3]-trExpr (UnaryMinus e) =- trExpr $ apply (Variable undefined qNegateId) [e]-trExpr (Apply e1 e2) = CApply <$> trExpr e1 <*> trExpr e2-trExpr (InfixApply e1 op e2) = trExpr $ apply (infixOp op) [e1, e2]-trExpr (LeftSection e op) = trExpr $ apply (infixOp op) [e]-trExpr (RightSection op e) =- trExpr $ apply (Variable undefined qFlip) [infixOp op, e]-trExpr (Lambda ps e) = inNestedScope $- CLambda <$> mapM trPat ps <*> trExpr e-trExpr (Let ds e) = inNestedScope $- CLetDecl <$> trLocalDecls ds <*> trExpr e-trExpr (Do ss e) = inNestedScope $- (\ss' e' -> CDoExpr (ss' ++ [CSExpr e']))- <$> mapM trStatement ss <*> trExpr e-trExpr (IfThenElse e1 e2 e3) =- trExpr $ apply (Variable undefined qIfThenElseId) [e1, e2, e3]-trExpr (Case ct e bs) = CCase (cvCaseType ct)- <$> trExpr e <*> mapM trAlt bs+trExpr (ListCompr _ e ds) = inNestedScope $ flip CListComp+ <$> mapM trStatement ds <*> trExpr e+trExpr (EnumFrom _ e) =+ trExpr $ apply (Variable NoSpanInfo undefined qEnumFromId) [e]+trExpr (EnumFromThen _ e1 e2) =+ trExpr $ apply (Variable NoSpanInfo undefined qEnumFromThenId) [e1, e2]+trExpr (EnumFromTo _ e1 e2) =+ trExpr $ apply (Variable NoSpanInfo undefined qEnumFromToId) [e1, e2]+trExpr (EnumFromThenTo _ e1 e2 e3) =+ trExpr $ apply (Variable NoSpanInfo undefined qEnumFromThenToId) [e1, e2, e3]+trExpr (UnaryMinus _ e) =+ trExpr $ apply (Variable NoSpanInfo undefined qNegateId) [e]+trExpr (Apply _ e1 e2) = CApply <$> trExpr e1 <*> trExpr e2+trExpr (InfixApply _ e1 op e2) = trExpr $ apply (infixOp op) [e1, e2]+trExpr (LeftSection _ e op) = trExpr $ apply (infixOp op) [e]+trExpr (RightSection _ op e) =+ trExpr $ apply (Variable NoSpanInfo undefined qFlip) [infixOp op, e]+trExpr (Lambda _ ps e) = inNestedScope $+ CLambda <$> mapM trPat ps <*> trExpr e+trExpr (Let _ ds e) = inNestedScope $+ CLetDecl <$> trLocalDecls ds <*> trExpr e+trExpr (Do _ ss e) = inNestedScope $+ (\ss' e' -> CDoExpr (ss' ++ [CSExpr e']))+ <$> mapM trStatement ss <*> trExpr e+trExpr (IfThenElse _ e1 e2 e3) =+ trExpr $ apply (Variable NoSpanInfo undefined qIfThenElseId) [e1, e2, e3]+trExpr (Case _ ct e bs) = CCase (cvCaseType ct)+ <$> trExpr e <*> mapM trAlt bs cvCaseType :: CaseType -> CCaseType cvCaseType Flex = CFlex cvCaseType Rigid = CRigid trStatement :: Statement PredType -> GAC CStatement-trStatement (StmtExpr e) = CSExpr <$> trExpr e-trStatement (StmtDecl ds) = CSLet <$> trLocalDecls ds-trStatement (StmtBind p e) = flip CSPat <$> trExpr e <*> trPat p+trStatement (StmtExpr _ e) = CSExpr <$> trExpr e+trStatement (StmtDecl _ ds) = CSLet <$> trLocalDecls ds+trStatement (StmtBind _ p e) = flip CSPat <$> trExpr e <*> trPat p trAlt :: Alt PredType -> GAC (CPattern, CRhs) trAlt (Alt _ p rhs) = inNestedScope $ (,) <$> trPat p <*> trRhs rhs trPat :: Pattern a -> GAC CPattern-trPat (LiteralPattern _ l) = return (CPLit $ cvLiteral l)-trPat (VariablePattern _ v) = CPVar <$> getVarIndex v-trPat (ConstructorPattern _ c ps) = CPComb <$> trQual c <*> mapM trPat ps-trPat (InfixPattern a p1 op p2) = trPat $ ConstructorPattern a op [p1, p2]-trPat (ParenPattern p) = trPat p-trPat (RecordPattern _ c fs) = CPRecord <$> trQual c+trPat (LiteralPattern _ _ l) = return (CPLit $ cvLiteral l)+trPat (VariablePattern _ _ v) = CPVar <$> getVarIndex v+trPat (ConstructorPattern _ _ c ps) = CPComb <$> trQual c <*> mapM trPat ps+trPat (InfixPattern _ a p1 op p2) =+ trPat $ ConstructorPattern NoSpanInfo a op [p1, p2]+trPat (ParenPattern _ p) = trPat p+trPat (RecordPattern _ _ c fs) = CPRecord <$> trQual c <*> mapM (trField trPat) fs-trPat (TuplePattern ps) =- trPat $ ConstructorPattern undefined (qTupleId $ length ps) ps-trPat (ListPattern _ ps) = trPat $- foldr (\x1 x2 -> ConstructorPattern undefined qConsId [x1, x2])- (ConstructorPattern undefined qNilId [])+trPat (TuplePattern _ ps) =+ trPat $ ConstructorPattern NoSpanInfo undefined (qTupleId $ length ps) ps+trPat (ListPattern _ _ ps) = trPat $+ foldr (\x1 x2 -> ConstructorPattern NoSpanInfo undefined qConsId [x1, x2])+ (ConstructorPattern NoSpanInfo undefined qNilId []) ps-trPat (NegativePattern a l) = trPat $ LiteralPattern a $ negateLiteral l-trPat (AsPattern v p) = CPAs <$> getVarIndex v<*> trPat p-trPat (LazyPattern p) = CPLazy <$> trPat p-trPat (FunctionPattern _ f ps) = CPFuncComb <$> trQual f <*> mapM trPat ps-trPat (InfixFuncPattern a p1 f p2) = trPat (FunctionPattern a f [p1, p2])+trPat (NegativePattern _ a l) =+ trPat $ LiteralPattern NoSpanInfo a $ negateLiteral l+trPat (AsPattern _ v p) = CPAs <$> getVarIndex v<*> trPat p+trPat (LazyPattern _ p) = CPLazy <$> trPat p+trPat (FunctionPattern _ _ f ps) = CPFuncComb <$> trQual f <*> mapM trPat ps+trPat (InfixFuncPattern _ a p1 f p2) =+ trPat (FunctionPattern NoSpanInfo a f [p1, p2]) trField :: (a -> GAC b) -> Field a -> GAC (CField b) trField act (Field _ l x) = (,) <$> trQual l <*> act x@@ -408,7 +418,7 @@ -- |Initialize the AbstractCurry generator environment abstractEnv :: Bool -> CompilerEnv -> Module a -> AbstractEnv-abstractEnv uacy env (Module _ mid es _ ds) = AbstractEnv+abstractEnv uacy env (Module _ _ mid es _ ds) = AbstractEnv { moduleId = mid , typeEnv = valueEnv env , tyExports = foldr (buildTypeExports mid) Set.empty es'@@ -428,15 +438,15 @@ -- Builds a table containing all exported identifiers from a module. buildTypeExports :: ModuleIdent -> Export -> Set.Set Ident -> Set.Set Ident-buildTypeExports mid (ExportTypeWith tc _)+buildTypeExports mid (ExportTypeWith _ tc _) | isLocalIdent mid tc = Set.insert (unqualify tc) buildTypeExports _ _ = id -- Builds a table containing all exported identifiers from a module. buildValueExports :: ModuleIdent -> Export -> Set.Set Ident -> Set.Set Ident-buildValueExports mid (Export q)+buildValueExports mid (Export _ q) | isLocalIdent mid q = Set.insert (unqualify q)-buildValueExports mid (ExportTypeWith tc cs)+buildValueExports mid (ExportTypeWith _ tc cs) | isLocalIdent mid tc = flip (foldr Set.insert) cs buildValueExports _ _ = id @@ -505,7 +515,8 @@ uacy <- S.gets untypedAcy sigs <- S.gets typeSigs trQualTypeExpr $ case uacy of- True -> Maybe.fromMaybe (QualTypeExpr [] $ ConstructorType prelUntyped)+ True -> Maybe.fromMaybe (QualTypeExpr NoSpanInfo [] $+ ConstructorType NoSpanInfo prelUntyped) (Map.lookup f sigs) False -> fromPredType identSupply pty
src/Generators/GenFlatCurry.hs view
@@ -15,39 +15,39 @@ import Curry.FlatCurry.Goodies import Curry.FlatCurry.Type-import Curry.FlatCurry.Annotated.Goodies-import Curry.FlatCurry.Annotated.Type+import Curry.FlatCurry.Typed.Goodies+import Curry.FlatCurry.Typed.Type -- transforms annotated FlatCurry code to FlatCurry code-genFlatCurry :: AProg a -> Prog-genFlatCurry = trAProg+genFlatCurry :: TProg -> Prog+genFlatCurry = trTProg (\name imps types funcs ops -> Prog name imps types (map genFlatFuncDecl funcs) ops) -genFlatFuncDecl :: AFuncDecl a -> FuncDecl-genFlatFuncDecl = trAFunc+genFlatFuncDecl :: TFuncDecl -> FuncDecl+genFlatFuncDecl = trTFunc (\name arity vis ty rule -> Func name arity vis ty $ genFlatRule rule) -genFlatRule :: ARule a -> Rule-genFlatRule = trARule- (\_ args e -> Rule (map fst args) $ genFlatExpr e)+genFlatRule :: TRule -> Rule+genFlatRule = trTRule+ (\args e -> Rule (map fst args) $ genFlatExpr e) (const External) -genFlatExpr :: AExpr a -> Expr-genFlatExpr = trAExpr+genFlatExpr :: TExpr -> Expr+genFlatExpr = trTExpr (const Var) (const Lit)- (\_ ct name args -> Comb ct (fst name) args)- (\_ bs e -> Let (map (\(v, e') -> (fst v, e')) bs) e)- (\_ vs e -> Free (map fst vs) e)- (\_ e1 e2 -> Or e1 e2)- (\_ ct e bs -> Case ct e bs)+ (\_ ct name args -> Comb ct name args)+ (\bs e -> Let (map (\(v, e') -> (fst v, e')) bs) e)+ (\vs e -> Free (map fst vs) e)+ Or+ Case (\pat e -> Branch (genFlatPattern pat) e)- (\_ e ty -> Typed e ty)+ Typed -genFlatPattern :: APattern a -> Pattern-genFlatPattern = trAPattern- (\_ name args -> Pattern (fst name) $ map fst args)+genFlatPattern :: TPattern -> Pattern+genFlatPattern = trTPattern+ (\_ name args -> Pattern name $ map fst args) (const LPattern) -- transforms a FlatCurry module to a FlatCurry interface
+ src/Generators/GenTypeAnnotatedFlatCurry.hs view
@@ -0,0 +1,517 @@+{- |+ Module : $Header$+ Description : Generation of typed FlatCurry program terms+ Copyright : (c) 2017 Finn Teegen+ 2018 Kai-Oliver Prott+ License : BSD-3-clause++ Maintainer : fte@informatik.uni-kiel.de+ Stability : experimental+ Portability : portable++ This module contains the generation of a type-annotated 'FlatCurry'+ program term for a given module in the intermediate language.+-}+{-# LANGUAGE CPP #-}+module Generators.GenTypeAnnotatedFlatCurry (genTypeAnnotatedFlatCurry) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>), (<*>))+#endif+import Control.Monad ((<=<))+import Control.Monad.Extra (concatMapM)+import qualified Control.Monad.State as S ( State, evalState, get, gets+ , modify, put )+import Data.Function (on)+import Data.List (nub, sortBy)+import Data.Maybe (fromMaybe)+import qualified Data.Map as Map (Map, empty, insert, lookup)+import qualified Data.Set as Set (Set, empty, insert, member)++import Curry.Base.Ident+import Curry.Base.SpanInfo+import Curry.FlatCurry.Annotated.Goodies (typeName)+import Curry.FlatCurry.Annotated.Type+import qualified Curry.Syntax as CS++import Base.CurryTypes (toType)+import Base.Messages (internalError)+import Base.NestEnv ( NestEnv, emptyEnv, bindNestEnv, lookupNestEnv+ , nestEnv, unnestEnv )+import Base.TypeExpansion+import Base.Types++import CompilerEnv+import Env.OpPrec (mkPrec)+import Env.TypeConstructor (TCEnv)+import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue)++import qualified IL+import Transformations (transType)++-- TODO: Translate from TypedFlatCurry+-- transforms intermediate language code (IL) to type-annotated FlatCurry code+genTypeAnnotatedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module+ -> AProg TypeExpr+genTypeAnnotatedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il)++-- -----------------------------------------------------------------------------+-- Addition of primitive types for lists and tuples to the Prelude+-- -----------------------------------------------------------------------------++patchPrelude :: AProg a -> AProg a+patchPrelude p@(AProg n _ ts fs os)+ | n == prelude = AProg n [] ts' fs os+ | otherwise = p+ where ts' = sortBy (compare `on` typeName) pts+ pts = primTypes ++ ts++primTypes :: [TypeDecl]+primTypes =+ [ Type arrow Public [0, 1] []+ , Type unit Public [] [(Cons unit 0 Public [])]+ , Type nil Public [0] [ Cons nil 0 Public []+ , Cons cons 2 Public [TVar 0, TCons nil [TVar 0]]+ ]+ ] ++ map mkTupleType [2 .. maxTupleArity]+ where arrow = mkPreludeQName "(->)"+ unit = mkPreludeQName "()"+ nil = mkPreludeQName "[]"+ cons = mkPreludeQName ":"++mkTupleType :: Int -> TypeDecl+mkTupleType arity = Type tuple Public [0 .. arity - 1]+ [Cons tuple arity Public (map TVar [0 .. arity - 1])]+ where tuple = mkPreludeQName $ '(' : replicate (arity - 1) ',' ++ ")"++mkPreludeQName :: String -> QName+mkPreludeQName n = (prelude, n)++prelude :: String+prelude = "Prelude"++-- |Maximal arity of tuples+maxTupleArity :: Int+maxTupleArity = 15++-- -----------------------------------------------------------------------------++-- The environment 'FlatEnv' is embedded in the monadic representation+-- 'FlatState' which allows the usage of 'do' expressions.+type FlatState a = S.State FlatEnv a++-- Data type for representing an environment which contains information needed+-- for generating FlatCurry code.+data FlatEnv = FlatEnv+ { modIdent :: ModuleIdent -- current module+ -- for visibility calculation+ , tyExports :: Set.Set Ident -- exported types+ , valExports :: Set.Set Ident -- exported values (functions + constructors)+ , tcEnv :: TCEnv -- type constructor environment+ , tyEnv :: ValueEnv -- type environment+ , fixities :: [CS.IDecl] -- fixity declarations+ , typeSynonyms :: [CS.Decl Type] -- type synonyms+ , imports :: [ModuleIdent] -- module imports+ -- state for mapping identifiers to indexes+ , nextVar :: Int -- fresh variable index counter+ , varMap :: NestEnv VarIndex -- map of identifier to variable index+ }++-- Runs a 'FlatState' action and returns the result+run :: CompilerEnv -> CS.Module Type -> FlatState a -> a+run env (CS.Module _ _ mid es is ds) act = S.evalState act env0+ where+ es' = case es of Just (CS.Exporting _ e) -> e+ _ -> []+ env0 = FlatEnv+ { modIdent = mid+ -- for visibility calculation+ , tyExports = foldr (buildTypeExports mid) Set.empty es'+ , valExports = foldr (buildValueExports mid) Set.empty es'+ -- This includes *all* imports, even unused ones+ , imports = nub [ m | CS.ImportDecl _ m _ _ _ <- is ]+ -- Environment to retrieve the type of identifiers+ , tyEnv = valueEnv env+ , tcEnv = tyConsEnv env+ -- Fixity declarations+ , fixities = [ CS.IInfixDecl (spanInfo2Pos p) fix (mkPrec mPrec) (qualifyWith mid o)+ | CS.InfixDecl p fix mPrec os <- ds, o <- os+ ]+ -- Type synonyms in the module+ , typeSynonyms = [ d | d@CS.TypeDecl{} <- ds ]+ , nextVar = 0+ , varMap = emptyEnv+ }++-- Builds a table containing all exported identifiers from a module.+buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident+buildTypeExports mid (CS.ExportTypeWith _ tc _)+ | isLocalIdent mid tc = Set.insert (unqualify tc)+buildTypeExports _ _ = id++-- Builds a table containing all exported identifiers from a module.+buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident+buildValueExports mid (CS.Export _ q)+ | isLocalIdent mid q = Set.insert (unqualify q)+buildValueExports mid (CS.ExportTypeWith _ tc cs)+ | isLocalIdent mid tc = flip (foldr Set.insert) cs+buildValueExports _ _ = id++getModuleIdent :: FlatState ModuleIdent+getModuleIdent = S.gets modIdent++getArity :: QualIdent -> FlatState Int+getArity qid = S.gets tyEnv >>= \ env -> return $ case qualLookupValue qid env of+ [DataConstructor _ a _ _] -> a+ [NewtypeConstructor _ _ _] -> 1+ [Value _ _ a _] -> a+ [Label _ _ _] -> 1+ _ ->+ internalError ("GenTypeAnnotatedFlatCurry.getArity: " ++ qualName qid)++getFixities :: FlatState [CS.IDecl]+getFixities = S.gets fixities++-- The function 'typeSynonyms' returns the list of type synonyms.+getTypeSynonyms :: FlatState [CS.Decl Type]+getTypeSynonyms = S.gets typeSynonyms++-- Retrieve imports+getImports :: [ModuleIdent] -> FlatState [String]+getImports imps = (nub . map moduleName . (imps ++)) <$> S.gets imports++-- -----------------------------------------------------------------------------+-- Stateful part, used for translation of rules and expressions+-- -----------------------------------------------------------------------------++-- resets var index and environment+withFreshEnv :: FlatState a -> FlatState a+withFreshEnv act = S.modify (\ s -> s { nextVar = 0, varMap = emptyEnv }) >> act++-- Execute an action in a nested variable mapping+inNestedEnv :: FlatState a -> FlatState a+inNestedEnv act = do+ S.modify $ \ s -> s { varMap = nestEnv $ varMap s }+ res <- act+ S.modify $ \ s -> s { varMap = unnestEnv $ varMap s }+ return res++-- Generates a new variable index for an identifier+newVar :: IL.Type -> Ident -> FlatState (VarIndex, TypeExpr)+newVar ty i = do+ idx <- (+1) <$> S.gets nextVar+ S.modify $ \ s -> s { nextVar = idx, varMap = bindNestEnv i idx (varMap s) }+ ty' <- trType ty+ return (idx, ty')++-- Retrieve the variable index assigned to an identifier+getVarIndex :: Ident -> FlatState VarIndex+getVarIndex i = S.gets varMap >>= \ varEnv -> case lookupNestEnv i varEnv of+ [v] -> return v+ _ -> internalError $ "GenTypeAnnotatedFlatCurry.getVarIndex: " ++ escName i++-- -----------------------------------------------------------------------------+-- Translation of an interface+-- -----------------------------------------------------------------------------++-- Translate an operator declaration+trIOpDecl :: CS.IDecl -> FlatState [OpDecl]+trIOpDecl (CS.IInfixDecl _ fix prec op)+ = (\op' -> [Op op' (cvFixity fix) prec]) <$> trQualIdent op+trIOpDecl _ = return []++-- -----------------------------------------------------------------------------+-- Translation of a module+-- -----------------------------------------------------------------------------++trModule :: IL.Module -> FlatState (AProg TypeExpr)+trModule (IL.Module mid is ds) = do+ is' <- getImports is+ sns <- getTypeSynonyms >>= concatMapM trTypeSynonym+ tds <- concatMapM trTypeDecl ds+ fds <- concatMapM (return . map runNormalization <=< trAFuncDecl) ds+ ops <- getFixities >>= concatMapM trIOpDecl+ return $ AProg (moduleName mid) is' (sns ++ tds) fds ops++-- Translate a type synonym+trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl]+trTypeSynonym (CS.TypeDecl _ t tvs ty) = do+ m <- getModuleIdent+ qid <- flip qualifyWith t <$> getModuleIdent+ t' <- trQualIdent qid+ vis <- getTypeVisibility qid+ tEnv <- S.gets tcEnv+ ty' <- trType (transType $ expandType m tEnv $ toType tvs ty)+ return [TypeSyn t' vis [0 .. length tvs - 1] ty']+trTypeSynonym _ = return []++-- Translate a data declaration+-- For empty data declarations, an additional constructor is generated. This+-- is due to the fact that external data declarations are translated into data+-- declarations with zero constructors and without the additional constructor+-- empty data declarations could not be distinguished from external ones.+trTypeDecl :: IL.Decl -> FlatState [TypeDecl]+trTypeDecl (IL.DataDecl qid a []) = do+ q' <- trQualIdent qid+ vis <- getTypeVisibility qid+ c <- trQualIdent $ qualify (mkIdent $ "_Constr#" ++ idName (unqualify qid))+ let tvs = [0 .. a - 1]+ return [Type q' vis tvs [Cons c 1 Private [TCons q' $ map TVar tvs]]]+trTypeDecl (IL.DataDecl qid a cs) = do+ q' <- trQualIdent qid+ vis <- getTypeVisibility qid+ cs' <- mapM trConstrDecl cs+ return [Type q' vis [0 .. a - 1] cs']+trTypeDecl (IL.ExternalDataDecl qid a) = do+ q' <- trQualIdent qid+ vis <- getTypeVisibility qid+ return [Type q' vis [0 .. a - 1] []]+trTypeDecl _ = return []++-- Translate a constructor declaration+trConstrDecl :: IL.ConstrDecl -> FlatState ConsDecl+trConstrDecl (IL.ConstrDecl qid tys) = flip Cons (length tys)+ <$> trQualIdent qid+ <*> getVisibility qid+ <*> mapM trType tys++-- Translate a type expression+trType :: IL.Type -> FlatState TypeExpr+trType (IL.TypeConstructor t tys) = TCons <$> trQualIdent t <*> mapM trType tys+trType (IL.TypeVariable idx) = return $ TVar $ abs idx+trType (IL.TypeArrow ty1 ty2) = FuncType <$> trType ty1 <*> trType ty2+trType (IL.TypeForall idxs ty) = ForallType (map abs idxs) <$> trType ty++-- Convert a fixity+cvFixity :: CS.Infix -> Fixity+cvFixity CS.InfixL = InfixlOp+cvFixity CS.InfixR = InfixrOp+cvFixity CS.Infix = InfixOp++-- -----------------------------------------------------------------------------+-- Function declarations+-- -----------------------------------------------------------------------------++-- Translate a function declaration+trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr]+trAFuncDecl (IL.FunctionDecl f vs _ e) = do+ f' <- trQualIdent f+ a <- getArity f+ vis <- getVisibility f+ ty' <- trType ty+ r' <- trARule ty vs e+ return [AFunc f' a vis ty' r']+ where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs+trAFuncDecl (IL.ExternalDecl f ty) = do+ f' <- trQualIdent f+ a <- getArity f+ vis <- getVisibility f+ ty' <- trType ty+ r' <- trAExternal ty f+ return [AFunc f' a vis ty' r']+trAFuncDecl _ = return []++-- Translate a function rule.+-- Resets variable index so that for every rule variables start with index 1+trARule :: IL.Type -> [(IL.Type, Ident)] -> IL.Expression+ -> FlatState (ARule TypeExpr)+trARule ty vs e = withFreshEnv $ ARule <$> trType ty+ <*> mapM (uncurry newVar) vs+ <*> trAExpr e++trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr)+trAExternal ty f = flip AExternal (qualName f) <$> trType ty++-- Translate an expression+trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr)+trAExpr (IL.Literal ty l) = ALit <$> trType ty <*> trLiteral l+trAExpr (IL.Variable ty v) = AVar <$> trType ty <*> getVarIndex v+trAExpr (IL.Function ty f _) = genCall Fun ty f []+trAExpr (IL.Constructor ty c _) = genCall Con ty c []+trAExpr (IL.Apply e1 e2) = trApply e1 e2+trAExpr c@(IL.Case t e bs) = flip ACase (cvEval t) <$> trType (IL.typeOf c) <*> trAExpr e+ <*> mapM (inNestedEnv . trAlt) bs+trAExpr (IL.Or e1 e2) = AOr <$> trType (IL.typeOf e1) <*> trAExpr e1 <*> trAExpr e2+trAExpr (IL.Exist v ty e) = inNestedEnv $ do+ v' <- newVar ty v+ e' <- trAExpr e+ ty' <- trType (IL.typeOf e)+ return $ case e' of AFree ty'' vs e'' -> AFree ty'' (v' : vs) e''+ _ -> AFree ty' (v' : []) e'+trAExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do+ v' <- newVar (IL.typeOf b) v+ b' <- trAExpr b+ e' <- trAExpr e+ ty' <- trType $ IL.typeOf e+ return $ case e' of ALet ty'' bs e'' -> ALet ty'' ((v', b'):bs) e''+ _ -> ALet ty' ((v', b'):[]) e'+trAExpr (IL.Letrec bs e) = inNestedEnv $ do+ let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs]+ ALet <$> trType (IL.typeOf e)+ <*> (zip <$> mapM (uncurry newVar) vs <*> mapM trAExpr es)+ <*> trAExpr e+trAExpr (IL.Typed e _) = ATyped <$> ty' <*> trAExpr e <*> ty'+ where ty' = trType $ IL.typeOf e++-- Translate a literal+trLiteral :: IL.Literal -> FlatState Literal+trLiteral (IL.Char c) = return $ Charc c+trLiteral (IL.Int i) = return $ Intc i+trLiteral (IL.Float f) = return $ Floatc f++-- Translate a higher-order application+trApply :: IL.Expression -> IL.Expression -> FlatState (AExpr TypeExpr)+trApply e1 e2 = genFlatApplic e1 [e2]+ where+ genFlatApplic e es = case e of+ IL.Apply ea eb -> genFlatApplic ea (eb:es)+ IL.Function ty f _ -> genCall Fun ty f es+ IL.Constructor ty c _ -> genCall Con ty c es+ _ -> do+ expr <- trAExpr e+ genApply expr es++-- Translate an alternative+trAlt :: IL.Alt -> FlatState (ABranchExpr TypeExpr)+trAlt (IL.Alt p e) = ABranch <$> trPat p <*> trAExpr e++-- Translate a pattern+trPat :: IL.ConstrTerm -> FlatState (APattern TypeExpr)+trPat (IL.LiteralPattern ty l) = ALPattern <$> trType ty <*> trLiteral l+trPat (IL.ConstructorPattern ty c vs) = do+ qty <- trType $ foldr IL.TypeArrow ty $ map fst vs+ APattern <$> trType ty <*> ((\q -> (q, qty)) <$> trQualIdent c) <*> mapM (uncurry newVar) vs+trPat (IL.VariablePattern _ _) = internalError "GenTypeAnnotatedFlatCurry.trPat"++-- Convert a case type+cvEval :: IL.Eval -> CaseType+cvEval IL.Rigid = Rigid+cvEval IL.Flex = Flex++data Call = Fun | Con++-- Generate a function or constructor call+genCall :: Call -> IL.Type -> QualIdent -> [IL.Expression]+ -> FlatState (AExpr TypeExpr)+genCall call ty f es = do+ f' <- trQualIdent f+ arity <- getArity f+ case compare supplied arity of+ LT -> genAComb ty f' es (part call (arity - supplied))+ EQ -> genAComb ty f' es (full call)+ GT -> do+ let (es1, es2) = splitAt arity es+ funccall <- genAComb ty f' es1 (full call)+ genApply funccall es2+ where+ supplied = length es+ full Fun = FuncCall+ full Con = ConsCall+ part Fun = FuncPartCall+ part Con = ConsPartCall++genAComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState (AExpr TypeExpr)+genAComb ty qid es ct = do+ ty' <- trType ty+ let ty'' = defunc ty' (length es)+ AComb ty'' ct (qid, ty') <$> mapM trAExpr es+ where+ defunc t 0 = t+ defunc (FuncType _ t2) n = defunc t2 (n - 1)+ defunc _ _ = internalError "GenTypeAnnotatedFlatCurry.genAComb.defunc"++genApply :: AExpr TypeExpr -> [IL.Expression] -> FlatState (AExpr TypeExpr)+genApply e es = do+ ap <- trQualIdent $ qApplyId+ es' <- mapM trAExpr es+ return $ foldl (\e1 e2 -> let FuncType ty1 ty2 = typeOf e1 in AComb ty2 FuncCall (ap, FuncType (FuncType ty1 ty2) (FuncType ty1 ty2)) [e1, e2]) e es'++-- -----------------------------------------------------------------------------+-- Normalization+-- -----------------------------------------------------------------------------++runNormalization :: Normalize a => a -> a+runNormalization x = S.evalState (normalize x) (0, Map.empty)++type NormState a = S.State (Int, Map.Map Int Int) a++class Normalize a where+ normalize :: a -> NormState a++instance Normalize Int where+ normalize i = do+ (n, m) <- S.get+ case Map.lookup i m of+ Nothing -> do+ S.put (n + 1, Map.insert i n m)+ return n+ Just n' -> return n'++instance Normalize TypeExpr where+ normalize (TVar i) = TVar <$> normalize i+ normalize (TCons q tys) = TCons q <$> mapM normalize tys+ normalize (FuncType ty1 ty2) = FuncType <$> normalize ty1 <*> normalize ty2+ normalize (ForallType is ty) =+ ForallType <$> mapM normalize is <*> normalize ty++instance Normalize b => Normalize (a, b) where+ normalize (x, y) = ((,) x) <$> normalize y++instance Normalize a => Normalize (AFuncDecl a) where+ normalize (AFunc f a v ty r) = AFunc f a v <$> normalize ty <*> normalize r++instance Normalize a => Normalize (ARule a) where+ normalize (ARule ty vs e) = ARule <$> normalize ty+ <*> mapM normalize vs+ <*> normalize e+ normalize (AExternal ty s) = flip AExternal s <$> normalize ty++instance Normalize a => Normalize (AExpr a) where+ normalize (AVar ty v) = flip AVar v <$> normalize ty+ normalize (ALit ty l) = flip ALit l <$> normalize ty+ normalize (AComb ty ct f es) = flip AComb ct <$> normalize ty+ <*> normalize f+ <*> mapM normalize es+ normalize (ALet ty ds e) = ALet <$> normalize ty+ <*> mapM normalizeBinding ds+ <*> normalize e+ where normalizeBinding (v, b) = (,) <$> normalize v <*> normalize b+ normalize (AOr ty a b) = AOr <$> normalize ty <*> normalize a+ <*> normalize b+ normalize (ACase ty ct e bs) = flip ACase ct <$> normalize ty <*> normalize e+ <*> mapM normalize bs+ normalize (AFree ty vs e) = AFree <$> normalize ty <*> mapM normalize vs+ <*> normalize e+ normalize (ATyped ty e ty') = ATyped <$> normalize ty <*> normalize e+ <*> normalize ty'++instance Normalize a => Normalize (ABranchExpr a) where+ normalize (ABranch p e) = ABranch <$> normalize p <*> normalize e++instance Normalize a => Normalize (APattern a) where+ normalize (APattern ty c vs) = APattern <$> normalize ty <*> normalize c+ <*> mapM normalize vs+ normalize (ALPattern ty l) = flip ALPattern l <$> normalize ty++-- -----------------------------------------------------------------------------+-- Helper functions+-- -----------------------------------------------------------------------------++trQualIdent :: QualIdent -> FlatState QName+trQualIdent qid = do+ mid <- getModuleIdent+ return $ (moduleName $ fromMaybe mid mid', idName i)+ where+ mid' | i `elem` [listId, consId, nilId, unitId] || isTupleId i+ = Just preludeMIdent+ | otherwise+ = qidModule qid+ i = qidIdent qid++getTypeVisibility :: QualIdent -> FlatState Visibility+getTypeVisibility i = S.gets $ \s ->+ if Set.member (unqualify i) (tyExports s) then Public else Private++getVisibility :: QualIdent -> FlatState Visibility+getVisibility i = S.gets $ \s ->+ if Set.member (unqualify i) (valExports s) then Public else Private
src/Generators/GenTypedFlatCurry.hs view
@@ -2,9 +2,10 @@ Module : $Header$ Description : Generation of typed FlatCurry program terms Copyright : (c) 2017 Finn Teegen+ 2018 Kai-Oliver Prott License : BSD-3-clause - Maintainer : bjp@informatik.uni-kiel.de+ Maintainer : fte@informatik.uni-kiel.de Stability : experimental Portability : portable @@ -28,9 +29,9 @@ import qualified Data.Set as Set (Set, empty, insert, member) import Curry.Base.Ident-import Curry.FlatCurry.Annotated.Goodies (typeName)-import Curry.FlatCurry.Annotated.Type-import Curry.FlatCurry.Annotated.Typing+import Curry.Base.SpanInfo+import Curry.FlatCurry.Typed.Goodies (typeName)+import Curry.FlatCurry.Typed.Type import qualified Curry.Syntax as CS import Base.CurryTypes (toType)@@ -45,21 +46,21 @@ import Env.TypeConstructor (TCEnv) import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) -import qualified IL as IL+import qualified IL import Transformations (transType) -- transforms intermediate language code (IL) to typed FlatCurry code genTypedFlatCurry :: CompilerEnv -> CS.Module Type -> IL.Module- -> AProg TypeExpr+ -> TProg genTypedFlatCurry env mdl il = patchPrelude $ run env mdl (trModule il) -- ----------------------------------------------------------------------------- -- Addition of primitive types for lists and tuples to the Prelude -- ----------------------------------------------------------------------------- -patchPrelude :: AProg a -> AProg a-patchPrelude p@(AProg n _ ts fs os)- | n == prelude = AProg n [] ts' fs os+patchPrelude :: TProg -> TProg+patchPrelude p@(TProg n _ ts fs os)+ | n == prelude = TProg n [] ts' fs os | otherwise = p where ts' = sortBy (compare `on` typeName) pts pts = primTypes ++ ts@@ -117,7 +118,7 @@ -- Runs a 'FlatState' action and returns the result run :: CompilerEnv -> CS.Module Type -> FlatState a -> a-run env (CS.Module _ mid es is ds) act = S.evalState act env0+run env (CS.Module _ _ mid es is ds) act = S.evalState act env0 where es' = case es of Just (CS.Exporting _ e) -> e _ -> []@@ -132,7 +133,7 @@ , tyEnv = valueEnv env , tcEnv = tyConsEnv env -- Fixity declarations- , fixities = [ CS.IInfixDecl p fix (mkPrec mPrec) (qualifyWith mid o)+ , fixities = [ CS.IInfixDecl (spanInfo2Pos p) fix (mkPrec mPrec) (qualifyWith mid o) | CS.InfixDecl p fix mPrec os <- ds, o <- os ] -- Type synonyms in the module@@ -143,15 +144,15 @@ -- Builds a table containing all exported identifiers from a module. buildTypeExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident-buildTypeExports mid (CS.ExportTypeWith tc _)+buildTypeExports mid (CS.ExportTypeWith _ tc _) | isLocalIdent mid tc = Set.insert (unqualify tc) buildTypeExports _ _ = id -- Builds a table containing all exported identifiers from a module. buildValueExports :: ModuleIdent -> CS.Export -> Set.Set Ident -> Set.Set Ident-buildValueExports mid (CS.Export q)+buildValueExports mid (CS.Export _ q) | isLocalIdent mid q = Set.insert (unqualify q)-buildValueExports mid (CS.ExportTypeWith tc cs)+buildValueExports mid (CS.ExportTypeWith _ tc cs) | isLocalIdent mid tc = flip (foldr Set.insert) cs buildValueExports _ _ = id @@ -222,14 +223,14 @@ -- Translation of a module -- ----------------------------------------------------------------------------- -trModule :: IL.Module -> FlatState (AProg TypeExpr)+trModule :: IL.Module -> FlatState TProg trModule (IL.Module mid is ds) = do is' <- getImports is sns <- getTypeSynonyms >>= concatMapM trTypeSynonym tds <- concatMapM trTypeDecl ds- fds <- concatMapM (return . map runNormalization <=< trAFuncDecl) ds+ fds <- concatMapM (return . map runNormalization <=< trTFuncDecl) ds ops <- getFixities >>= concatMapM trIOpDecl- return $ AProg (moduleName mid) is' (sns ++ tds) fds ops+ return $ TProg (moduleName mid) is' (sns ++ tds) fds ops -- Translate a type synonym trTypeSynonym :: CS.Decl a -> FlatState [TypeDecl]@@ -291,64 +292,60 @@ -- ----------------------------------------------------------------------------- -- Translate a function declaration-trAFuncDecl :: IL.Decl -> FlatState [AFuncDecl TypeExpr]-trAFuncDecl (IL.FunctionDecl f vs _ e) = do+trTFuncDecl :: IL.Decl -> FlatState [TFuncDecl]+trTFuncDecl (IL.FunctionDecl f vs _ e) = do f' <- trQualIdent f a <- getArity f vis <- getVisibility f ty' <- trType ty- r' <- trARule ty vs e- return [AFunc f' a vis ty' r']+ r' <- trTRule vs e+ return [TFunc f' a vis ty' r'] where ty = foldr IL.TypeArrow (IL.typeOf e) $ map fst vs-trAFuncDecl (IL.ExternalDecl f ty) = do+trTFuncDecl (IL.ExternalDecl f ty) = do f' <- trQualIdent f a <- getArity f vis <- getVisibility f ty' <- trType ty- r' <- trAExternal ty f- return [AFunc f' a vis ty' r']-trAFuncDecl _ = return []+ r' <- trTExternal ty f+ return [TFunc f' a vis ty' r']+trTFuncDecl _ = return [] -- Translate a function rule. -- Resets variable index so that for every rule variables start with index 1-trARule :: IL.Type -> [(IL.Type, Ident)] -> IL.Expression- -> FlatState (ARule TypeExpr)-trARule ty vs e = withFreshEnv $ ARule <$> trType ty- <*> mapM (uncurry newVar) vs- <*> trAExpr e+trTRule :: [(IL.Type, Ident)] -> IL.Expression+ -> FlatState TRule+trTRule vs e = withFreshEnv $ TRule <$> mapM (uncurry newVar) vs+ <*> trTExpr e -trAExternal :: IL.Type -> QualIdent -> FlatState (ARule TypeExpr)-trAExternal ty f = flip AExternal (qualName f) <$> trType ty+trTExternal :: IL.Type -> QualIdent -> FlatState TRule+trTExternal ty f = flip TExternal (qualName f) <$> trType ty -- Translate an expression-trAExpr :: IL.Expression -> FlatState (AExpr TypeExpr)-trAExpr (IL.Literal ty l) = ALit <$> trType ty <*> trLiteral l-trAExpr (IL.Variable ty v) = AVar <$> trType ty <*> getVarIndex v-trAExpr (IL.Function ty f _) = genCall Fun ty f []-trAExpr (IL.Constructor ty c _) = genCall Con ty c []-trAExpr (IL.Apply e1 e2) = trApply e1 e2-trAExpr c@(IL.Case t e bs) = flip ACase (cvEval t) <$> trType (IL.typeOf c) <*> trAExpr e+trTExpr :: IL.Expression -> FlatState TExpr+trTExpr (IL.Literal ty l) = TLit <$> trType ty <*> trLiteral l+trTExpr (IL.Variable ty v) = TVarE <$> trType ty <*> getVarIndex v+trTExpr (IL.Function ty f _) = genCall Fun ty f []+trTExpr (IL.Constructor ty c _) = genCall Con ty c []+trTExpr (IL.Apply e1 e2) = trApply e1 e2+trTExpr (IL.Case t e bs) = TCase (cvEval t) <$> trTExpr e <*> mapM (inNestedEnv . trAlt) bs-trAExpr (IL.Or e1 e2) = AOr <$> trType (IL.typeOf e1) <*> trAExpr e1 <*> trAExpr e2-trAExpr (IL.Exist v e) = inNestedEnv $ do- v' <- newVar (IL.typeOf e) v- e' <- trAExpr e- ty' <- trType (IL.typeOf e)- return $ case e' of AFree ty'' vs e'' -> AFree ty'' (v' : vs) e''- _ -> AFree ty' (v' : []) e'-trAExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do+trTExpr (IL.Or e1 e2) = TOr <$> trTExpr e1 <*> trTExpr e2+trTExpr (IL.Exist v ty e) = inNestedEnv $ do+ v' <- newVar ty v+ e' <- trTExpr e+ return $ case e' of TFree vs e'' -> TFree (v' : vs) e''+ _ -> TFree (v' : []) e'+trTExpr (IL.Let (IL.Binding v b) e) = inNestedEnv $ do v' <- newVar (IL.typeOf b) v- b' <- trAExpr b- e' <- trAExpr e- ty' <- trType $ IL.typeOf e- return $ case e' of ALet ty'' bs e'' -> ALet ty'' ((v', b'):bs) e''- _ -> ALet ty' ((v', b'):[]) e'-trAExpr (IL.Letrec bs e) = inNestedEnv $ do+ b' <- trTExpr b+ e' <- trTExpr e+ return $ case e' of TLet bs e'' -> TLet ((v', b'):bs) e''+ _ -> TLet ((v', b'):[]) e'+trTExpr (IL.Letrec bs e) = inNestedEnv $ do let (vs, es) = unzip [ ((IL.typeOf b, v), b) | IL.Binding v b <- bs]- ALet <$> trType (IL.typeOf e)- <*> (zip <$> mapM (uncurry newVar) vs <*> mapM trAExpr es)- <*> trAExpr e-trAExpr (IL.Typed e _) = ATyped <$> ty' <*> trAExpr e <*> ty'+ TLet <$> (zip <$> mapM (uncurry newVar) vs <*> mapM trTExpr es)+ <*> trTExpr e+trTExpr (IL.Typed e _) = TTyped <$> trTExpr e <*> ty' where ty' = trType $ IL.typeOf e -- Translate a literal@@ -358,7 +355,7 @@ trLiteral (IL.Float f) = return $ Floatc f -- Translate a higher-order application-trApply :: IL.Expression -> IL.Expression -> FlatState (AExpr TypeExpr)+trApply :: IL.Expression -> IL.Expression -> FlatState TExpr trApply e1 e2 = genFlatApplic e1 [e2] where genFlatApplic e es = case e of@@ -366,19 +363,18 @@ IL.Function ty f _ -> genCall Fun ty f es IL.Constructor ty c _ -> genCall Con ty c es _ -> do- expr <- trAExpr e+ expr <- trTExpr e genApply expr es -- Translate an alternative-trAlt :: IL.Alt -> FlatState (ABranchExpr TypeExpr)-trAlt (IL.Alt p e) = ABranch <$> trPat p <*> trAExpr e+trAlt :: IL.Alt -> FlatState TBranchExpr+trAlt (IL.Alt p e) = TBranch <$> trPat p <*> trTExpr e -- Translate a pattern-trPat :: IL.ConstrTerm -> FlatState (APattern TypeExpr)-trPat (IL.LiteralPattern ty l) = ALPattern <$> trType ty <*> trLiteral l-trPat (IL.ConstructorPattern ty c vs) = do- qty <- trType $ foldr IL.TypeArrow ty $ map fst vs- APattern <$> trType ty <*> ((\q -> (q, qty)) <$> trQualIdent c) <*> mapM (uncurry newVar) vs+trPat :: IL.ConstrTerm -> FlatState TPattern+trPat (IL.LiteralPattern ty l) = TLPattern <$> trType ty <*> trLiteral l+trPat (IL.ConstructorPattern ty c vs) =+ TPattern <$> trType ty <*> trQualIdent c <*> mapM (uncurry newVar) vs trPat (IL.VariablePattern _ _) = internalError "GenTypedFlatCurry.trPat" -- Convert a case type@@ -390,16 +386,16 @@ -- Generate a function or constructor call genCall :: Call -> IL.Type -> QualIdent -> [IL.Expression]- -> FlatState (AExpr TypeExpr)+ -> FlatState TExpr genCall call ty f es = do f' <- trQualIdent f arity <- getArity f case compare supplied arity of- LT -> genAComb ty f' es (part call (arity - supplied))- EQ -> genAComb ty f' es (full call)+ LT -> genTComb ty f' es (part call (arity - supplied))+ EQ -> genTComb ty f' es (full call) GT -> do let (es1, es2) = splitAt arity es- funccall <- genAComb ty f' es1 (full call)+ funccall <- genTComb ty f' es1 (full call) genApply funccall es2 where supplied = length es@@ -408,21 +404,23 @@ part Fun = FuncPartCall part Con = ConsPartCall -genAComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState (AExpr TypeExpr)-genAComb ty qid es ct = do+genTComb :: IL.Type -> QName -> [IL.Expression] -> CombType -> FlatState TExpr+genTComb ty qid es ct = do ty' <- trType ty let ty'' = defunc ty' (length es)- AComb ty'' ct (qid, ty') <$> mapM trAExpr es+ TComb ty'' ct qid <$> mapM trTExpr es where defunc t 0 = t defunc (FuncType _ t2) n = defunc t2 (n - 1)- defunc _ _ = internalError "GenTypedFlatCurry.genAComb.defunc"+ defunc _ _ = internalError "GenTypedFlatCurry.genTComb.defunc" -genApply :: AExpr TypeExpr -> [IL.Expression] -> FlatState (AExpr TypeExpr)+genApply :: TExpr -> [IL.Expression] -> FlatState TExpr genApply e es = do- ap <- trQualIdent $ qApplyId- es' <- mapM trAExpr es- return $ foldl (\e1 e2 -> let FuncType ty1 ty2 = typeOf e1 in AComb ty2 FuncCall (ap, FuncType (FuncType ty1 ty2) (FuncType ty1 ty2)) [e1, e2]) e es'+ ap <- trQualIdent qApplyId+ es' <- mapM trTExpr es+ return $ foldl (\e1 e2 -> let FuncType _ ty2 = typeOf e1+ in TComb ty2 FuncCall ap [e1, e2])+ e es' -- ----------------------------------------------------------------------------- -- Normalization@@ -453,43 +451,42 @@ ForallType <$> mapM normalize is <*> normalize ty instance Normalize b => Normalize (a, b) where- normalize (x, y) = ((,) x) <$> normalize y+ normalize (x, y) = (,) x <$> normalize y -instance Normalize a => Normalize (AFuncDecl a) where- normalize (AFunc f a v ty r) = AFunc f a v <$> normalize ty <*> normalize r+instance Normalize TFuncDecl where+ normalize (TFunc f a v ty r) = TFunc f a v <$> normalize ty <*> normalize r -instance Normalize a => Normalize (ARule a) where- normalize (ARule ty vs e) = ARule <$> normalize ty- <*> mapM normalize vs+instance Normalize TRule where+ normalize (TRule vs e) = TRule <$> mapM normalize vs <*> normalize e- normalize (AExternal ty s) = flip AExternal s <$> normalize ty+ normalize (TExternal ty s) = flip TExternal s <$> normalize ty -instance Normalize a => Normalize (AExpr a) where- normalize (AVar ty v) = flip AVar v <$> normalize ty- normalize (ALit ty l) = flip ALit l <$> normalize ty- normalize (AComb ty ct f es) = flip AComb ct <$> normalize ty- <*> normalize f- <*> mapM normalize es- normalize (ALet ty ds e) = ALet <$> normalize ty- <*> mapM normalizeBinding ds+instance Normalize TExpr where+ normalize (TVarE ty v) = flip TVarE v <$> normalize ty+ normalize (TLit ty l) = flip TLit l <$> normalize ty+ normalize (TComb ty ct f es) = flip TComb ct <$> normalize ty+ <*> pure f+ <*> mapM normalize es+ normalize (TLet ds e) = TLet <$> mapM normalizeBinding ds <*> normalize e where normalizeBinding (v, b) = (,) <$> normalize v <*> normalize b- normalize (AOr ty a b) = AOr <$> normalize ty <*> normalize a+ normalize (TOr a b) = TOr <$> normalize a <*> normalize b- normalize (ACase ty ct e bs) = flip ACase ct <$> normalize ty <*> normalize e- <*> mapM normalize bs- normalize (AFree ty vs e) = AFree <$> normalize ty <*> mapM normalize vs+ normalize (TCase ct e bs) = TCase ct <$> normalize e+ <*> mapM normalize bs+ normalize (TFree vs e) = TFree <$> mapM normalize vs <*> normalize e- normalize (ATyped ty e ty') = ATyped <$> normalize ty <*> normalize e+ normalize (TTyped e ty') = TTyped <$> normalize e <*> normalize ty' -instance Normalize a => Normalize (ABranchExpr a) where- normalize (ABranch p e) = ABranch <$> normalize p <*> normalize e+instance Normalize TBranchExpr where+ normalize (TBranch p e) = TBranch <$> normalize p <*> normalize e -instance Normalize a => Normalize (APattern a) where- normalize (APattern ty c vs) = APattern <$> normalize ty <*> normalize c+instance Normalize TPattern where+ normalize (TPattern ty c vs) = TPattern <$> normalize ty+ <*> pure c <*> mapM normalize vs- normalize (ALPattern ty l) = flip ALPattern l <$> normalize ty+ normalize (TLPattern ty l) = flip TLPattern l <$> normalize ty -- ----------------------------------------------------------------------------- -- Helper functions
src/Html/SyntaxColoring.hs view
@@ -40,6 +40,7 @@ import Curry.Base.Ident import Curry.Base.Position+import Curry.Base.SpanInfo () import Curry.Syntax import Base.Messages@@ -242,28 +243,11 @@ pragmaCategories :: [Category] pragmaCategories = [PragmaLanguage, PragmaOptions, PragmaEnd] --- DECL Position--declPos :: Decl a -> Position-declPos (InfixDecl p _ _ _ ) = p-declPos (DataDecl p _ _ _ _ ) = p-declPos (ExternalDataDecl p _ _ ) = p-declPos (NewtypeDecl p _ _ _ _ ) = p-declPos (TypeDecl p _ _ _ ) = p-declPos (TypeSig p _ _ ) = p-declPos (FunctionDecl p _ _ _ ) = p-declPos (ExternalDecl p _ ) = p-declPos (PatternDecl p _ _ ) = p-declPos (FreeDecl p _ ) = p-declPos (DefaultDecl p _ ) = p-declPos (ClassDecl p _ _ _ _ ) = p-declPos (InstanceDecl p _ _ _ _ ) = p- cmpDecl :: Decl a -> Decl a -> Ordering-cmpDecl = compare `on` declPos+cmpDecl = compare `on` getPosition cmpImportDecl :: ImportDecl -> ImportDecl -> Ordering-cmpImportDecl = compare `on` (\ (ImportDecl p _ _ _ _) -> p)+cmpImportDecl = compare `on` getPosition -- ----------------------------------------------------------------------------- -- Extract all identifiers mentioned in the source code as a Code entity@@ -273,7 +257,7 @@ -- ----------------------------------------------------------------------------- idsModule :: Module a -> [Code]-idsModule (Module _ mid es is ds) =+idsModule (Module _ _ mid es is ds) = let hdrCodes = ModuleName mid : idsExportSpec es impCodes = concatMap idsImportDecl (sortBy cmpImportDecl is) dclCodes = concatMap idsDecl (sortBy cmpDecl ds)@@ -286,11 +270,11 @@ idsExportSpec (Just (Exporting _ es)) = concatMap idsExport es idsExport :: Export -> [Code]-idsExport (Export qid) = [Function FuncExport False qid]-idsExport (ExportTypeWith qid cs) = TypeCons TypeExport False qid :+idsExport (Export _ qid) = [Function FuncExport False qid]+idsExport (ExportTypeWith _ qid cs) = TypeCons TypeExport False qid : map (DataCons ConsExport False . qualify) cs-idsExport (ExportTypeAll qid) = [TypeCons TypeExport False qid]-idsExport (ExportModule mid) = [ModuleName mid]+idsExport (ExportTypeAll _ qid) = [TypeCons TypeExport False qid]+idsExport (ExportModule _ mid) = [ModuleName mid] -- Imports @@ -304,12 +288,12 @@ idsImportSpec mid (Hiding _ is) = concatMap (idsImport mid) is idsImport :: ModuleIdent -> Import -> [Code]-idsImport mid (Import i) =+idsImport mid (Import _ i) = [Function FuncImport False $ qualifyWith mid i]-idsImport mid (ImportTypeWith t cs) =+idsImport mid (ImportTypeWith _ t cs) = TypeCons TypeImport False (qualifyWith mid t) : map (DataCons ConsImport False . qualifyWith mid) cs-idsImport mid (ImportTypeAll t) =+idsImport mid (ImportTypeAll _ t) = [TypeCons TypeImport False $ qualifyWith mid t] -- Declarations@@ -377,24 +361,24 @@ internalError "SyntaxColoring.idsInstanceDecl" idsQualTypeExpr :: QualTypeExpr -> [Code]-idsQualTypeExpr (QualTypeExpr cx ty) = idsContext cx ++ idsTypeExpr ty+idsQualTypeExpr (QualTypeExpr _ cx ty) = idsContext cx ++ idsTypeExpr ty idsContext :: Context -> [Code] idsContext = concatMap idsConstraint idsConstraint :: Constraint -> [Code]-idsConstraint (Constraint qcls ty) =+idsConstraint (Constraint _ qcls ty) = TypeCons TypeRefer False qcls : idsTypeExpr ty idsTypeExpr :: TypeExpr -> [Code]-idsTypeExpr (ConstructorType qid) = [TypeCons TypeRefer False qid]-idsTypeExpr (ApplyType ty1 ty2) = concatMap idsTypeExpr [ty1, ty2]-idsTypeExpr (VariableType v) = [Identifier IdRefer False (qualify v)]-idsTypeExpr (TupleType tys) = concatMap idsTypeExpr tys-idsTypeExpr (ListType ty) = idsTypeExpr ty-idsTypeExpr (ArrowType ty1 ty2) = concatMap idsTypeExpr [ty1, ty2]-idsTypeExpr (ParenType ty) = idsTypeExpr ty-idsTypeExpr (ForallType vs ty) =+idsTypeExpr (ConstructorType _ qid) = [TypeCons TypeRefer False qid]+idsTypeExpr (ApplyType _ ty1 ty2) = concatMap idsTypeExpr [ty1, ty2]+idsTypeExpr (VariableType _ v) = [Identifier IdRefer False (qualify v)]+idsTypeExpr (TupleType _ tys) = concatMap idsTypeExpr tys+idsTypeExpr (ListType _ ty) = idsTypeExpr ty+idsTypeExpr (ArrowType _ ty1 ty2) = concatMap idsTypeExpr [ty1, ty2]+idsTypeExpr (ParenType _ ty) = idsTypeExpr ty+idsTypeExpr (ForallType _ vs ty) = map (Identifier IdDeclare False . qualify) vs ++ idsTypeExpr ty idsFieldDecl :: FieldDecl -> [Code]@@ -405,69 +389,70 @@ idsEquation (Equation _ lhs rhs) = idsLhs lhs ++ idsRhs rhs idsLhs :: Lhs a -> [Code]-idsLhs (FunLhs f ps) = Function FuncDeclare False (qualify f) : concatMap idsPat ps-idsLhs (OpLhs p1 op p2) = idsPat p1 ++ [Function FuncDeclare False $ qualify op]- ++ idsPat p2-idsLhs (ApLhs lhs ps) = idsLhs lhs ++ concatMap idsPat ps+idsLhs (FunLhs _ f ps) =+ Function FuncDeclare False (qualify f) : concatMap idsPat ps+idsLhs (OpLhs _ p1 op p2) =+ idsPat p1 ++ [Function FuncDeclare False $ qualify op] ++ idsPat p2+idsLhs (ApLhs _ lhs ps) = idsLhs lhs ++ concatMap idsPat ps idsRhs :: Rhs a -> [Code]-idsRhs (SimpleRhs _ e ds) = idsExpr e ++ concatMap idsDecl ds-idsRhs (GuardedRhs ce ds) = concatMap idsCondExpr ce ++ concatMap idsDecl ds+idsRhs (SimpleRhs _ e ds) = idsExpr e ++ concatMap idsDecl ds+idsRhs (GuardedRhs _ ce ds) = concatMap idsCondExpr ce ++ concatMap idsDecl ds idsCondExpr :: CondExpr a -> [Code] idsCondExpr (CondExpr _ e1 e2) = idsExpr e1 ++ idsExpr e2 idsPat :: Pattern a -> [Code]-idsPat (LiteralPattern _ _) = []-idsPat (NegativePattern _ _) = []-idsPat (VariablePattern _ v) = [Identifier IdDeclare False (qualify v)]-idsPat (ConstructorPattern _ qid ps) =+idsPat (LiteralPattern _ _ _) = []+idsPat (NegativePattern _ _ _) = []+idsPat (VariablePattern _ _ v) = [Identifier IdDeclare False (qualify v)]+idsPat (ConstructorPattern _ _ qid ps) = DataCons ConsPattern False qid : concatMap idsPat ps-idsPat (InfixPattern _ p1 qid p2) =+idsPat (InfixPattern _ _ p1 qid p2) = idsPat p1 ++ DataCons ConsPattern False qid : idsPat p2-idsPat (ParenPattern p) = idsPat p-idsPat (RecordPattern _ qid fs) =+idsPat (ParenPattern _ p) = idsPat p+idsPat (RecordPattern _ _ qid fs) = DataCons ConsPattern False qid : concatMap (idsField idsPat) fs-idsPat (TuplePattern ps) = concatMap idsPat ps-idsPat (ListPattern _ ps) = concatMap idsPat ps-idsPat (AsPattern v p) =+idsPat (TuplePattern _ ps) = concatMap idsPat ps+idsPat (ListPattern _ _ ps) = concatMap idsPat ps+idsPat (AsPattern _ v p) = Identifier IdDeclare False (qualify v) : idsPat p-idsPat (LazyPattern p) = idsPat p-idsPat (FunctionPattern _ qid ps) =+idsPat (LazyPattern _ p) = idsPat p+idsPat (FunctionPattern _ _ qid ps) = Function FuncCall False qid : concatMap idsPat ps-idsPat (InfixFuncPattern _ p1 f p2) =+idsPat (InfixFuncPattern _ _ p1 f p2) = idsPat p1 ++ Function FuncInfix False f : idsPat p2 idsExpr :: Expression a -> [Code]-idsExpr (Literal _ _) = []-idsExpr (Variable _ qid)+idsExpr (Literal _ _ _) = []+idsExpr (Variable _ _ qid) | isQualified qid = [Function FuncCall False qid] | hasGlobalScope (unqualify qid) = [Function FuncCall False qid] | otherwise = [Identifier IdRefer False qid]-idsExpr (Constructor _ qid) = [DataCons ConsCall False qid]-idsExpr (Paren e) = idsExpr e-idsExpr (Typed e qty) = idsExpr e ++ idsQualTypeExpr qty-idsExpr (Record _ qid fs) =+idsExpr (Constructor _ _ qid) = [DataCons ConsCall False qid]+idsExpr (Paren _ e) = idsExpr e+idsExpr (Typed _ e qty) = idsExpr e ++ idsQualTypeExpr qty+idsExpr (Record _ _ qid fs) = DataCons ConsCall False qid : concatMap (idsField idsExpr) fs-idsExpr (RecordUpdate e fs) =+idsExpr (RecordUpdate _ e fs) = idsExpr e ++ concatMap (idsField idsExpr) fs-idsExpr (Tuple es) = concatMap idsExpr es-idsExpr (List _ es) = concatMap idsExpr es-idsExpr (ListCompr e stmts) = idsExpr e ++ concatMap idsStmt stmts-idsExpr (EnumFrom e) = idsExpr e-idsExpr (EnumFromThen e1 e2) = concatMap idsExpr [e1, e2]-idsExpr (EnumFromTo e1 e2) = concatMap idsExpr [e1, e2]-idsExpr (EnumFromThenTo e1 e2 e3) = concatMap idsExpr [e1, e2, e3]-idsExpr (UnaryMinus e) = Symbol "-" : idsExpr e-idsExpr (Apply e1 e2) = idsExpr e1 ++ idsExpr e2-idsExpr (InfixApply e1 op e2) = idsExpr e1 ++ idsInfix op ++ idsExpr e2-idsExpr (LeftSection e op) = idsExpr e ++ idsInfix op-idsExpr (RightSection op e) = idsInfix op ++ idsExpr e-idsExpr (Lambda ps e) = concatMap idsPat ps ++ idsExpr e-idsExpr (Let ds e) = concatMap idsDecl ds ++ idsExpr e-idsExpr (Do stmts e) = concatMap idsStmt stmts ++ idsExpr e-idsExpr (IfThenElse e1 e2 e3) = concatMap idsExpr [e1, e2, e3]-idsExpr (Case _ e alts) = idsExpr e ++ concatMap idsAlt alts+idsExpr (Tuple _ es) = concatMap idsExpr es+idsExpr (List _ _ es) = concatMap idsExpr es+idsExpr (ListCompr _ e stmts) = idsExpr e ++ concatMap idsStmt stmts+idsExpr (EnumFrom _ e) = idsExpr e+idsExpr (EnumFromThen _ e1 e2) = concatMap idsExpr [e1, e2]+idsExpr (EnumFromTo _ e1 e2) = concatMap idsExpr [e1, e2]+idsExpr (EnumFromThenTo _ e1 e2 e3) = concatMap idsExpr [e1, e2, e3]+idsExpr (UnaryMinus _ e) = Symbol "-" : idsExpr e+idsExpr (Apply _ e1 e2) = idsExpr e1 ++ idsExpr e2+idsExpr (InfixApply _ e1 op e2) = idsExpr e1 ++ idsInfix op ++ idsExpr e2+idsExpr (LeftSection _ e op) = idsExpr e ++ idsInfix op+idsExpr (RightSection _ op e) = idsInfix op ++ idsExpr e+idsExpr (Lambda _ ps e) = concatMap idsPat ps ++ idsExpr e+idsExpr (Let _ ds e) = concatMap idsDecl ds ++ idsExpr e+idsExpr (Do _ stmts e) = concatMap idsStmt stmts ++ idsExpr e+idsExpr (IfThenElse _ e1 e2 e3) = concatMap idsExpr [e1, e2, e3]+idsExpr (Case _ _ e alts) = idsExpr e ++ concatMap idsAlt alts idsField :: (a -> [Code]) -> Field a -> [Code] idsField f (Field _ l x) = Function FuncCall False l : f x@@ -477,9 +462,9 @@ idsInfix (InfixConstr _ qid) = [DataCons ConsInfix False qid] idsStmt :: Statement a -> [Code]-idsStmt (StmtExpr e) = idsExpr e-idsStmt (StmtDecl ds) = concatMap idsDecl ds-idsStmt (StmtBind p e) = idsPat p ++ idsExpr e+idsStmt (StmtExpr _ e) = idsExpr e+idsStmt (StmtDecl _ ds) = concatMap idsDecl ds+idsStmt (StmtBind _ p e) = idsPat p ++ idsExpr e idsAlt :: Alt a -> [Code] idsAlt (Alt _ p rhs) = idsPat p ++ idsRhs rhs
src/IL/Pretty.hs view
@@ -16,9 +16,13 @@ printer which, in turn, is based on Simon Marlow's pretty printer for Haskell. -}-+{-# LANGUAGE CPP #-} module IL.Pretty (ppModule) where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ import Curry.Base.Ident import Curry.Base.Pretty import IL.Type@@ -139,7 +143,7 @@ ppEval Flex = text "flex" ppExpr p (Or e1 e2) = parenIf (p > 0) $ sep [nest orIndent (ppExpr 0 e1), char '|', nest orIndent (ppExpr 0 e2)]-ppExpr p (Exist v e) = parenIf (p > 0) $ sep+ppExpr p (Exist v _ e) = parenIf (p > 0) $ sep [text "let" <+> ppIdent v <+> text "free" <+> text "in", ppExpr 0 e] ppExpr p (Let b e) = parenIf (p > 0) $ sep [text "let" <+> ppBinding b <+> text "in",ppExpr 0 e]
src/IL/ShowModule.hs view
@@ -156,9 +156,10 @@ . showsExpression exp1 . space . showsExpression exp2 . showsString ")"-showsExpression (Exist ident expr)+showsExpression (Exist ident ty expr) = showsString "(Exist " . showsIdent ident . space+ . showsType ty . space . showsExpression expr . showsString ")" showsExpression (Let bind expr)@@ -224,12 +225,12 @@ = showsString "(" . sa a . showsString "," . sb b . showsString ")" showsIdent :: Ident -> ShowS-showsIdent (Ident p x n)- = showsString "(Ident " . showsPosition p . space+showsIdent (Ident spi x n)+ = showsString "(Ident " . showsPosition (getPosition spi) . space . shows x . space . shows n . showsString ")" showsQualIdent :: QualIdent -> ShowS-showsQualIdent (QualIdent mident ident)+showsQualIdent (QualIdent _ mident ident) = showsString "(QualIdent " . showsMaybe showsModuleIdent mident . space@@ -237,9 +238,9 @@ . showsString ")" showsModuleIdent :: ModuleIdent -> ShowS-showsModuleIdent (ModuleIdent pos ss)+showsModuleIdent (ModuleIdent spi ss) = showsString "(ModuleIdent "- . showsPosition pos . space+ . showsPosition (getPosition spi) . space . showsList (showsQuotes showsString) ss . showsString ")"
src/IL/Type.hs view
@@ -102,7 +102,7 @@ -- |non-deterministic or | Or Expression Expression -- |exist binding (introduction of a free variable)- | Exist Ident Expression+ | Exist Ident Type Expression -- |let binding | Let Binding Expression -- |letrec binding@@ -127,7 +127,7 @@ fv (Apply e1 e2) = fv e1 ++ fv e2 fv (Case _ e alts) = fv e ++ fv alts fv (Or e1 e2) = fv e1 ++ fv e2- fv (Exist v e) = filter (/= v) (fv e)+ fv (Exist v _ e) = filter (/= v) (fv e) fv (Let (Binding v e1) e2) = fv e1 ++ filter (/= v) (fv e2) fv (Letrec bds e) = filter (`notElem` vs) (fv es ++ fv e) where (vs, es) = unzip [(v, e') | Binding v e' <- bds]
src/IL/Typing.hs view
@@ -35,7 +35,7 @@ _ -> internalError "IL.Typing.typeOf: application" typeOf (Case _ _ as) = typeOf $ head as typeOf (Or e _) = typeOf e- typeOf (Exist _ e) = typeOf e+ typeOf (Exist _ _ e) = typeOf e typeOf (Let _ e) = typeOf e typeOf (Letrec _ e) = typeOf e typeOf (Typed e _) = typeOf e
src/Imports.hs view
@@ -23,6 +23,7 @@ import qualified Data.Set as Set import Curry.Base.Ident+import Curry.Base.SpanInfo import Curry.Base.Monad import Curry.Syntax @@ -48,7 +49,7 @@ importModules :: Monad m => Module a -> InterfaceEnv -> [ImportDecl] -> CYT m CompilerEnv-importModules mdl@(Module _ mid _ _ _) iEnv expImps+importModules mdl@(Module _ _ mid _ _ _) iEnv expImps = ok $ foldl importModule initEnv expImps where initEnv = (initCompilerEnv mid)@@ -113,14 +114,14 @@ vs = isVisible addValue is addType :: Import -> [Ident] -> [Ident]-addType (Import _) tcs = tcs-addType (ImportTypeWith tc _) tcs = tc : tcs-addType (ImportTypeAll _) _ = internalError "Imports.addType"+addType (Import _ _) tcs = tcs+addType (ImportTypeWith _ tc _) tcs = tc : tcs+addType (ImportTypeAll _ _) _ = internalError "Imports.addType" addValue :: Import -> [Ident] -> [Ident]-addValue (Import f) fs = f : fs-addValue (ImportTypeWith _ cs) fs = cs ++ fs-addValue (ImportTypeAll _) _ = internalError "Imports.addValue"+addValue (Import _ f) fs = f : fs+addValue (ImportTypeWith _ _ cs) fs = cs ++ fs+addValue (ImportTypeAll _ _) _ = internalError "Imports.addValue" isVisible :: (Import -> [Ident] -> [Ident]) -> Maybe ImportSpec -> Ident -> Bool@@ -165,7 +166,7 @@ bindClass m (IClassDecl p cx cls k tv [] []) bindClass m (IClassDecl _ cx cls _ _ ds _) = bindClassInfo (qualQualify m cls) (sclss, ms)- where sclss = map (\(Constraint scls _) -> qualQualify m scls) cx+ where sclss = map (\(Constraint _ scls _) -> qualQualify m scls) cx ms = map (\d -> (imethod d, isJust $ imethodArity d)) ds bindClass _ _ = id @@ -175,7 +176,7 @@ bindInstance :: ModuleIdent -> IDecl -> InstEnv -> InstEnv bindInstance m (IInstanceDecl _ cx qcls ty is mm) = bindInstInfo (qualQualify m qcls, qualifyTC m $ typeConstr ty) (fromMaybe m mm, ps, is)- where PredType ps _ = toQualPredType m [] $ QualTypeExpr cx ty+ where PredType ps _ = toQualPredType m [] $ QualTypeExpr NoSpanInfo cx ty bindInstance _ _ = id -- ---------------------------------------------------------------------------@@ -305,7 +306,7 @@ recLabel m tc tvs ty0 (l, cs, lty) = Label ql qcs tySc where ql = qualifyLike tc l qcs = map (qualifyLike tc) cs- tySc = polyType (toQualType m tvs (ArrowType ty0 lty))+ tySc = polyType (toQualType m tvs (ArrowType NoSpanInfo ty0 lty)) constrType' :: ModuleIdent -> QualIdent -> [Ident] -> [Ident] -> Context -> [TypeExpr] -> ExistTypeScheme@@ -314,7 +315,8 @@ pty = qualifyPredType m $ toConstrType tc tvs' cx tys constrType :: QualIdent -> [Ident] -> TypeExpr-constrType tc tvs = foldl ApplyType (ConstructorType tc) $ map VariableType tvs+constrType tc tvs = foldl (ApplyType NoSpanInfo) (ConstructorType NoSpanInfo tc)+ $ map (VariableType NoSpanInfo) tvs -- We always enter class methods with an arity of 0 into the value environment -- because there may be different implementations with different arities.
src/Interfaces.hs view
@@ -22,8 +22,13 @@ Interface files are updated by the Curry builder when necessary, see module "CurryBuilder". -}+{-# LANGUAGE CPP #-} module Interfaces (loadInterfaces) where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ import Control.Monad (unless) import qualified Control.Monad.State as S (StateT, execStateT, gets, modify) import qualified Data.Map as M (insert, member)@@ -31,6 +36,7 @@ import Curry.Base.Ident import Curry.Base.Monad import Curry.Base.Position+import Curry.Base.SpanInfo () import Curry.Base.Pretty import Curry.Files.PathUtils import Curry.Syntax@@ -71,7 +77,7 @@ loadInterfaces :: [FilePath] -- ^ 'FilePath's to search in for interfaces -> Module a -- ^ 'Module' header with import declarations -> CYIO InterfaceEnv-loadInterfaces paths (Module _ m _ is _) = do+loadInterfaces paths (Module _ _ m _ is _) = do res <- liftIO $ S.execStateT load (LoaderState initInterfaceEnv paths []) if null (errs res) then ok (iEnv res) else failMessages (reverse $ errs res) where load = mapM_ (loadInterface [m]) [(p, m') | ImportDecl p m' _ _ _ <- is]@@ -85,8 +91,9 @@ -- Otherwise, the compiler checks whether the module has already been imported. -- If so, nothing needs to be done, otherwise the interface will be searched -- for in the import paths and compiled.-loadInterface :: [ModuleIdent] -> (Position, ModuleIdent) -> IntfLoader ()-loadInterface ctxt imp@(p, m)+loadInterface :: HasPosition a => [ModuleIdent] -> (a, ModuleIdent)+ -> IntfLoader ()+loadInterface ctxt imp@(pp, m) | m `elem` ctxt = report [errCyclicImport p (m : takeWhile (/= m) ctxt)] | otherwise = do isLoaded <- loaded m@@ -96,12 +103,13 @@ case mbIntf of Nothing -> report [errInterfaceNotFound p m] Just fn -> compileInterface ctxt imp fn+ where p = getPosition pp -- |Compile an interface by recursively loading its dependencies. -- -- After reading an interface, all imported interfaces are recursively -- loaded and inserted into the interface's environment.-compileInterface :: [ModuleIdent] -> (Position, ModuleIdent) -> FilePath+compileInterface :: HasPosition p => [ModuleIdent] -> (p, ModuleIdent) -> FilePath -> IntfLoader () compileInterface ctxt (p, m) fn = do mbSrc <- liftIO $ readModule fn@@ -119,18 +127,18 @@ addInterface m intf' -- Error message for required interface that could not be found.-errInterfaceNotFound :: Position -> ModuleIdent -> Message+errInterfaceNotFound :: HasPosition p => p -> ModuleIdent -> Message errInterfaceNotFound p m = posMessage p $ text "Interface for module" <+> text (moduleName m) <+> text "not found" -- Error message for an unexpected interface.-errWrongInterface :: Position -> ModuleIdent -> ModuleIdent -> Message+errWrongInterface :: HasPosition p => p -> ModuleIdent -> ModuleIdent -> Message errWrongInterface p m n = posMessage p $ text "Expected interface for" <+> text (moduleName m) <> comma <+> text "but found" <+> text (moduleName n) -- Error message for a cyclic import.-errCyclicImport :: Position -> [ModuleIdent] -> Message+errCyclicImport :: HasPosition p => p -> [ModuleIdent] -> Message errCyclicImport _ [] = internalError "Interfaces.errCyclicImport: empty list" errCyclicImport p [m] = posMessage p $ text "Recursive import for module" <+> text (moduleName m)
src/Modules.hs view
@@ -7,9 +7,10 @@ 2011 - 2015 Björn Peemöller 2016 Jan Tikovsky 2016 - 2017 Finn Teegen+ 2018 Kai-Oliver Prott License : BSD-3-clause - Maintainer : bjp@informatik.uni-kiel.de+ Maintainer : fte@informatik.uni-kiel.de Stability : experimental Portability : portable @@ -36,13 +37,15 @@ import Curry.Base.Ident import Curry.Base.Monad-import Curry.Base.Position+import Curry.Base.SpanInfo import Curry.Base.Pretty import Curry.Base.Span import Curry.FlatCurry.InterfaceEquivalence (eqInterface) import Curry.Files.Filenames import Curry.Files.PathUtils import Curry.Syntax.InterfaceEquivalence+import Curry.Syntax.Utils (shortenModuleAST)+import Curry.Syntax.Lexer (Token(..), Category(..)) import Base.Messages import Base.Types@@ -64,7 +67,7 @@ import Html.CurryHtml (source2html) import Imports import Interfaces (loadInterfaces)-import TokenStream (showTokenStream)+import TokenStream (showTokenStream, showCommentTokenStream) import Transformations -- The function 'compileModule' is the main entry-point of this@@ -86,17 +89,22 @@ compileModule :: Options -> ModuleIdent -> FilePath -> CYIO () compileModule opts m fn = do mdl <- loadAndCheckModule opts m fn- writeTokens opts (fst mdl)- writeParsed opts mdl- writeHtml opts (qual mdl)+ writeTokens opts (fst mdl)+ writeComments opts (fst mdl)+ writeParsed opts mdl+ let qmdl = qual mdl+ writeHtml opts qmdl+ let umdl = (fst qmdl, fmap (const ()) (snd qmdl))+ writeAST opts umdl+ writeShortAST opts umdl mdl' <- expandExports opts mdl- qmdl <- dumpWith opts CS.showModule CS.ppModule DumpQualified $ qual mdl'- writeAbstractCurry opts qmdl+ qmdl' <- dumpWith opts CS.showModule CS.ppModule DumpQualified $ qual mdl'+ writeAbstractCurry opts qmdl' -- generate interface file- let intf = uncurry exportInterface qmdl+ let intf = uncurry exportInterface qmdl' writeInterface opts (fst mdl') intf when withFlat $ do- ((env, il), mdl'') <- transModule opts qmdl+ ((env, il), mdl'') <- transModule opts qmdl' writeFlat opts env (snd mdl'') il where withFlat = any (`elem` optTargetTypes opts) [TypedFlatCurry, FlatCurry]@@ -180,7 +188,7 @@ -- |Check whether the 'ModuleIdent' and the 'FilePath' fit together checkModuleId :: Monad m => ModuleIdent -> CS.Module () -> CYT m (CS.Module ())-checkModuleId mid m@(CS.Module _ mid' _ _ _)+checkModuleId mid m@(CS.Module _ _ mid' _ _ _) | mid == mid' = ok m | otherwise = failMessages [errModuleFileMismatch mid'] @@ -190,7 +198,7 @@ -- the prelude is imported unqualified, otherwise a qualified import is added. importPrelude :: Options -> CS.Module () -> CS.Module ()-importPrelude opts m@(CS.Module ps mid es is ds)+importPrelude opts m@(CS.Module spi ps mid es is ds) -- the Prelude itself | mid == preludeMIdent = m -- disabled by compiler option@@ -198,11 +206,11 @@ -- already imported | preludeMIdent `elem` imported = m -- let's add it!- | otherwise = CS.Module ps mid es (preludeImp : is) ds+ | otherwise = CS.Module spi ps mid es (preludeImp : is) ds where noImpPrelude = NoImplicitPrelude `elem` optExtensions opts || m `CS.hasLanguageExtension` NoImplicitPrelude- preludeImp = CS.ImportDecl NoPos preludeMIdent+ preludeImp = CS.ImportDecl NoSpanInfo preludeMIdent False -- qualified? Nothing -- no alias Nothing -- no selection of types, functions, etc.@@ -216,7 +224,7 @@ interfaceCheck opts (env, intf) importSyntaxCheck :: Monad m => InterfaceEnv -> CS.Module a -> CYT m [CS.ImportDecl]-importSyntaxCheck iEnv (CS.Module _ _ _ imps _) = mapM checkImportDecl imps+importSyntaxCheck iEnv (CS.Module _ _ _ _ imps _) = mapM checkImportDecl imps where checkImportDecl (CS.ImportDecl p m q asM is) = case Map.lookup m iEnv of Just intf -> CS.ImportDecl p m q asM `liftM` importCheck intf is@@ -288,6 +296,14 @@ tokTarget = Tokens `elem` optTargetTypes opts useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) +writeComments :: Options -> CompilerEnv -> CYIO ()+writeComments opts env = when tokTarget $ liftIO $+ writeModule (useSubDir $ commentsName (filePath env))+ (showCommentTokenStream $ tokens env)+ where+ tokTarget = Comments `elem` optTargetTypes opts+ useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+ -- |Output the parsed 'Module' on request writeParsed :: Show a => Options -> CompEnv (CS.Module a) -> CYIO () writeParsed opts (env, mdl) = when srcTarget $ liftIO $@@ -328,19 +344,23 @@ writeFlat :: Options -> CompilerEnv -> CS.Module Type -> IL.Module -> CYIO () writeFlat opts env mdl il = do (_, tfc) <- dumpWith opts show (FC.ppProg . genFlatCurry) DumpTypedFlatCurry (env, tfcyProg)- when tfcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName) tfc+ when tfcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tfcyName) tafcyProg+ when tafcyTarget $ liftIO $ FC.writeFlatCurry (useSubDir tafcyName) tfc when fcyTarget $ do (_, fc) <- dumpWith opts show FC.ppProg DumpFlatCurry (env, fcyProg) liftIO $ FC.writeFlatCurry (useSubDir fcyName) fc writeFlatIntf opts env fcyProg where- tfcyName = typedFlatName (filePath env)- tfcyProg = genTypedFlatCurry env mdl il- tfcyTarget = TypedFlatCurry `elem` optTargetTypes opts- fcyName = flatName (filePath env)- fcyProg = genFlatCurry tfcyProg- fcyTarget = FlatCurry `elem` optTargetTypes opts- useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+ tfcyName = typedFlatName (filePath env)+ tfcyProg = genTypedFlatCurry env mdl il+ tfcyTarget = TypedFlatCurry `elem` optTargetTypes opts+ tafcyName = typeAnnFlatName (filePath env)+ tafcyProg = genTypeAnnotatedFlatCurry env mdl il+ tafcyTarget = TypeAnnotatedFlatCurry `elem` optTargetTypes opts+ fcyName = flatName (filePath env)+ fcyProg = genFlatCurry tfcyProg+ fcyTarget = FlatCurry `elem` optTargetTypes opts+ useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env) writeFlatIntf :: Options -> CompilerEnv -> FC.Prog -> CYIO () writeFlatIntf opts env prog@@ -370,6 +390,24 @@ acyTarget = AbstractCurry `elem` optTargetTypes opts uacyTarget = UntypedAbstractCurry `elem` optTargetTypes opts useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+++writeAST :: Options -> CompEnv (CS.Module ()) -> CYIO ()+writeAST opts (env, mdl) = when astTarget $ liftIO $+ writeModule (useSubDir $ astName (filePath env)) (CS.showModule mdl)+ where+ astTarget = AST `elem` optTargetTypes opts+ useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+++writeShortAST :: Options -> CompEnv (CS.Module ()) -> CYIO ()+writeShortAST opts (env, mdl) = when astTarget $ liftIO $+ writeModule (useSubDir $ shortASTName (filePath env))+ (CS.showModule $ shortenModuleAST mdl)+ where+ astTarget = ShortAST `elem` optTargetTypes opts+ useSubDir = addCurrySubdirModule (optUseSubdir opts) (moduleIdent env)+ type Dump = (DumpLevel, CompilerEnv, String)
src/TokenStream.hs view
@@ -9,7 +9,7 @@ and spans of a Curry source module into a separate file. -} -module TokenStream (showTokenStream) where+module TokenStream (showTokenStream, showCommentTokenStream) where import Data.List (intercalate) @@ -21,20 +21,46 @@ -- The list is split into one tuple on each line to increase readability. showTokenStream :: [(Span, Token)] -> String showTokenStream [] = "[]\n"-showTokenStream ts = "[ " ++ intercalate "\n, " (map showST filteredTs) ++ "\n]\n"+showTokenStream ts =+ "[ " ++ intercalate "\n, " (map showST filteredTs) ++ "\n]\n" where filteredTs = filter (not . isVirtual) ts+ showST (sp, t) = "(" ++ showSpanAsPair sp ++ ", " ++ showToken t ++ ")"++-- |Show a list of 'Span' and 'Token' tuples filtered by CommentTokens.+-- The list is split into one tuple on each line to increase readability.+showCommentTokenStream :: [(Span, Token)] -> String+showCommentTokenStream [] = "[]\n"+showCommentTokenStream ts =+ "[ " ++ intercalate "\n, " (map showST filteredTs) ++ "\n]\n"+ where filteredTs = filter isComment ts showST (sp, t) = "(" ++ showSpan sp ++ ", " ++ showToken t ++ ")" isVirtual :: (Span, Token) -> Bool isVirtual (_, Token cat _) = cat `elem` [EOF, VRightBrace, VSemicolon] +isComment :: (Span, Token) -> Bool+isComment (_, Token cat _) = cat `elem` [LineComment, NestedComment]+ -- show 'span' as "((startLine, startColumn), (endLine, endColumn))"+showSpanAsPair :: Span -> String+showSpanAsPair sp =+ "(" ++ showPosAsPair (start sp) ++ ", " ++ showPos (end sp) ++ ")"++-- show 'span' as "(Span startPos endPos)" showSpan :: Span -> String-showSpan sp = "(" ++ showPos (start sp) ++ ", " ++ showPos (end sp) ++ ")"+showSpan NoSpan = "NoSpan"+showSpan Span { start = s, end = e } =+ "(Span " ++ showPos s ++ " " ++ showPos e ++ ")" --- show 'Position' as "(line, column)"+-- show 'position' as "(Position line column)" showPos :: Position -> String-showPos p = "(" ++ show (line p) ++ ", " ++ show (column p) ++ ")"+showPos NoPos = "NoPos"+showPos Position { line = l, column = c } =+ "(Position " ++ show l++ " " ++ show c ++ ")"++-- show 'Position' as "(line, column)"+showPosAsPair :: Position -> String+showPosAsPair p = "(" ++ show (line p) ++ ", " ++ show (column p) ++ ")" -- |Show tokens and their value if needed showToken :: Token -> String
src/Transformations/CaseCompletion.hs view
@@ -109,7 +109,7 @@ bs' <- mapM ccAlt bs ccCase ea e' bs' ccExpr (Or e1 e2) = Or <$> ccExpr e1 <*> ccExpr e2-ccExpr (Exist v e) = Exist v <$> ccExpr e+ccExpr (Exist v ty e) = Exist v ty <$> ccExpr e ccExpr (Let b e) = Let <$> ccBinding b <*> ccExpr e ccExpr (Letrec bs e) = Letrec <$> mapM ccBinding bs <*> ccExpr e ccExpr (Typed e ty) = flip Typed ty <$> ccExpr e@@ -278,9 +278,9 @@ = Case ev (replaceVar v e e') (map (replaceVarInAlt v e) bs) replaceVar v e (Or e1 e2) = Or (replaceVar v e e1) (replaceVar v e e2)-replaceVar v e (Exist w e')- | v == w = Exist w e'- | otherwise = Exist w (replaceVar v e e')+replaceVar v e (Exist w ty e')+ | v == w = Exist w ty e'+ | otherwise = Exist w ty (replaceVar v e e') replaceVar v e (Let b e') | v `occursInBinding` b = Let b e' | otherwise = Let (replaceVarInBinding v e b)
src/Transformations/CurryToIL.hs view
@@ -49,7 +49,7 @@ import qualified IL as IL ilTrans :: ValueEnv -> Module Type -> IL.Module-ilTrans vEnv (Module _ m _ _ ds) = IL.Module m (imports m ds') ds'+ilTrans vEnv (Module _ _ m _ _ ds) = IL.Module m (imports m ds') ds' where ds' = R.runReader (concatMapM trDecl ds) (TransEnv m vEnv) -- -----------------------------------------------------------------------------@@ -85,7 +85,7 @@ mdlsPattern (IL.ConstructorPattern _ c _) = modules c mdlsPattern _ = id mdlsExpr (IL.Or e1 e2) ms = mdlsExpr e1 (mdlsExpr e2 ms)-mdlsExpr (IL.Exist _ e) ms = mdlsExpr e ms+mdlsExpr (IL.Exist _ _ e) ms = mdlsExpr e ms mdlsExpr (IL.Let b e) ms = mdlsBinding b (mdlsExpr e ms) mdlsExpr (IL.Letrec bs e) ms = foldr mdlsBinding (mdlsExpr e ms) bs mdlsExpr _ ms = ms@@ -235,7 +235,7 @@ -> [Ident] -- infinite list of additional identifiers -> Equation Type -- equation to be translated -> TransM Match -- nested constructor terms + translated RHS-trEquation vs vs' (Equation _ (FunLhs _ ts) rhs) = do+trEquation vs vs' (Equation _ (FunLhs _ _ ts) rhs) = do -- construct renaming of variables inside constructor terms let patternRenaming = foldr2 bindRenameEnv Map.empty vs ts -- translate right-hand-side@@ -249,18 +249,18 @@ -- Construct a renaming of all variables inside the pattern to fresh identifiers bindRenameEnv :: Ident -> Pattern a -> RenameEnv -> RenameEnv-bindRenameEnv _ (LiteralPattern _ _) env = env-bindRenameEnv v (VariablePattern _ v') env = Map.insert v' v env-bindRenameEnv v (ConstructorPattern _ _ ts) env+bindRenameEnv _ (LiteralPattern _ _ _) env = env+bindRenameEnv v (VariablePattern _ _ v') env = Map.insert v' v env+bindRenameEnv v (ConstructorPattern _ _ _ ts) env = foldr2 bindRenameEnv env (argNames v) ts-bindRenameEnv v (AsPattern v' t) env+bindRenameEnv v (AsPattern _ v' t) env = Map.insert v' v (bindRenameEnv v t env) bindRenameEnv _ _ _ = internalError "CurryToIL.bindRenameEnv" trRhs :: [Ident] -> RenameEnv -> Rhs Type -> TransM IL.Expression trRhs vs env (SimpleRhs _ e _) = trExpr vs env e-trRhs _ _ (GuardedRhs _ _) = internalError "CurryToIL.trRhs: GuardedRhs"+trRhs _ _ (GuardedRhs _ _ _) = internalError "CurryToIL.trRhs: GuardedRhs" -- Note that the case matching algorithm assumes that the matched -- expression is accessible through a variable. The translation of case@@ -271,32 +271,32 @@ -- instance, if one of the alternatives contains an as-pattern. trExpr :: [Ident] -> RenameEnv -> Expression Type -> TransM IL.Expression-trExpr _ _ (Literal ty l) = return $ IL.Literal (transType ty) (trLiteral l)-trExpr _ env (Variable ty v)+trExpr _ _ (Literal _ ty l) = return $ IL.Literal (transType ty) (trLiteral l)+trExpr _ env (Variable _ ty v) | isQualified v = fun | otherwise = case Map.lookup (unqualify v) env of Nothing -> fun Just v' -> return $ IL.Variable (transType ty) v' -- apply renaming where fun = (IL.Function (transType ty) v . arrowArity) <$> varType v-trExpr _ _ (Constructor ty c)+trExpr _ _ (Constructor _ ty c) = (IL.Constructor (transType ty) c . arrowArity) <$> constrType c-trExpr vs env (Apply e1 e2)+trExpr vs env (Apply _ e1 e2) = IL.Apply <$> trExpr vs env e1 <*> trExpr vs env e2-trExpr vs env (Let ds e) = do+trExpr vs env (Let _ ds e) = do e' <- trExpr vs env' e case ds of [FreeDecl _ vs']- -> return $ foldr IL.Exist e' $ map varIdent vs'+ -> return $ foldr (\ (Var ty v) -> IL.Exist v (transType ty)) e' vs' [d] | all (`notElem` bv d) (qfv emptyMIdent d) -> flip IL.Let e' <$> trBinding d _ -> flip IL.Letrec e' <$> mapM trBinding ds where env' = foldr2 Map.insert env bvs bvs bvs = bv ds- trBinding (PatternDecl _ (VariablePattern _ v) rhs)+ trBinding (PatternDecl _ (VariablePattern _ _ v) rhs) = IL.Binding v <$> trRhs vs env' rhs trBinding p = error $ "unexpected binding: " ++ show p-trExpr (v:vs) env (Case ct e alts) = do+trExpr (v:vs) env (Case _ ct e alts) = do -- the ident v is used for the case expression subject, as this could -- be referenced in the case alternatives by a variable pattern e' <- trExpr vs env e@@ -311,7 +311,7 @@ -- subject is referenced -> introduce binding for v as subject | v `elem` fv expr -> IL.Let (IL.Binding v e') expr | otherwise -> expr-trExpr vs env (Typed e (QualTypeExpr _ ty)) =+trExpr vs env (Typed _ e (QualTypeExpr _ _ ty)) = flip IL.Typed ty' <$> trExpr vs env e where ty' = transType (toType [] ty) trExpr _ _ _ = internalError "CurryToIL.trExpr"@@ -340,16 +340,16 @@ arguments (NestedTerm _ ts) = ts trPattern :: Ident -> Pattern Type -> NestedTerm-trPattern _ (LiteralPattern ty l)+trPattern _ (LiteralPattern _ ty l) = NestedTerm (IL.LiteralPattern (transType ty) $ trLiteral l) []-trPattern v (VariablePattern ty _)+trPattern v (VariablePattern _ ty _) = NestedTerm (IL.VariablePattern (transType ty) v) []-trPattern v (ConstructorPattern ty c ts)+trPattern v (ConstructorPattern _ ty c ts) = NestedTerm (IL.ConstructorPattern (transType ty) c vs') (zipWith trPattern vs ts) where vs = argNames v vs' = zip (map (transType . typeOf) ts) vs-trPattern v (AsPattern _ t) = trPattern v t+trPattern v (AsPattern _ _ t) = trPattern v t trPattern _ _ = internalError "CurryToIL.trPattern" argNames :: Ident -> [Ident]
src/Transformations/Derive.hs view
@@ -22,7 +22,7 @@ import qualified Data.Set as Set (deleteMin, union) import Curry.Base.Ident-import Curry.Base.Position+import Curry.Base.SpanInfo import Curry.Syntax import Base.CurryTypes (fromPredType)@@ -50,7 +50,7 @@ derive :: TCEnv -> ValueEnv -> InstEnv -> OpPrecEnv -> Module PredType -> Module PredType-derive tcEnv vEnv inEnv pEnv (Module ps m es is ds) = Module ps m es is $+derive tcEnv vEnv inEnv pEnv (Module spi ps m es is ds) = Module spi ps m es is $ ds ++ concat (S.evalState (mapM deriveInstances tds) initState) where tds = filter isTypeDecl ds initState = DVState m tcEnv vEnv inEnv pEnv 1@@ -101,9 +101,9 @@ let ps = snd3 $ fromJust $ lookupInstInfo (cls, tc) inEnv ty = applyType (TypeConstructor tc) $ take (length tvs) $ map TypeVariable [0 ..]- QualTypeExpr cx inst = fromPredType tvs $ PredType ps ty+ QualTypeExpr _ cx inst = fromPredType tvs $ PredType ps ty ds <- deriveMethods cls ty cis ps- return $ InstanceDecl NoPos cx cls inst ds+ return $ InstanceDecl NoSpanInfo cx cls inst ds -- Note: The methods and arities of the generated instance declarations have to -- correspond to the methods and arities entered previously into the instance@@ -133,7 +133,7 @@ deriveBinOp cls op expr ty cis ps = do pty <- getInstMethodType ps cls ty op eqs <- mapM (deriveBinOpEquation op expr ty) $ sequence [cis, cis]- return $ FunctionDecl NoPos pty op eqs+ return $ FunctionDecl NoSpanInfo pty op eqs deriveBinOpEquation :: Ident -> BinOpExpr -> Type -> [ConstrInfo] -> DVM (Equation PredType)@@ -144,7 +144,7 @@ pat2 = constrPattern pty c2 vs2 es1 = map (uncurry mkVar) vs1 es2 = map (uncurry mkVar) vs2- return $ mkEquation NoPos op [pat1, pat2] $ expr i1 es1 i2 es2+ return $ mkEquation NoSpanInfo op [pat1, pat2] $ expr i1 es1 i2 es2 where pty = predType $ instType ty deriveBinOpEquation _ _ _ _ = internalError "Derive.deriveBinOpEquation" @@ -194,7 +194,7 @@ -> DVM (Decl PredType) deriveSuccOrPred f ty cis1 cis2 ps = do pty <- getInstMethodType ps qEnumId ty f- FunctionDecl NoPos pty f <$> if null eqs+ FunctionDecl NoSpanInfo pty f <$> if null eqs then do v <- freshArgument $ instType ty return [failedEquation f ty v]@@ -204,63 +204,70 @@ succOrPredEquation :: Ident -> Type -> ConstrInfo -> ConstrInfo -> Equation PredType succOrPredEquation f ty (_, c1, _, _) (_, c2, _, _) =- mkEquation NoPos f [ConstructorPattern pty c1 []] $ Constructor pty c2+ mkEquation NoSpanInfo f [ConstructorPattern NoSpanInfo pty c1 []] $+ Constructor NoSpanInfo pty c2 where pty = predType $ instType ty failedEquation :: Ident -> Type -> (PredType, Ident) -> Equation PredType failedEquation f ty v =- mkEquation NoPos f [uncurry VariablePattern v] $ preludeFailed $ instType ty+ mkEquation NoSpanInfo f [uncurry (VariablePattern NoSpanInfo) v] $+ preludeFailed $ instType ty deriveToEnum :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType) deriveToEnum ty cis ps = do pty <- getInstMethodType ps qEnumId ty toEnumId- return $ FunctionDecl NoPos pty toEnumId eqs+ return $ FunctionDecl NoSpanInfo pty toEnumId eqs where eqs = zipWith (toEnumEquation ty) [0 ..] cis toEnumEquation :: Type -> Integer -> ConstrInfo -> Equation PredType toEnumEquation ty i (_, c, _, _) =- mkEquation NoPos toEnumId [LiteralPattern (predType intType) (Int i)] $- Constructor (predType $ instType ty) c+ mkEquation NoSpanInfo toEnumId+ [LiteralPattern NoSpanInfo (predType intType) (Int i)] $+ Constructor NoSpanInfo (predType $ instType ty) c deriveFromEnum :: Type -> [ConstrInfo] -> PredSet -> DVM (Decl PredType) deriveFromEnum ty cis ps = do pty <- getInstMethodType ps qEnumId ty fromEnumId- return $ FunctionDecl NoPos pty fromEnumId eqs+ return $ FunctionDecl NoSpanInfo pty fromEnumId eqs where eqs = zipWith (fromEnumEquation ty) cis [0 ..] fromEnumEquation :: Type -> ConstrInfo -> Integer -> Equation PredType fromEnumEquation ty (_, c, _, _) i =- mkEquation NoPos fromEnumId [ConstructorPattern pty c []] $- Literal (predType intType) $ Int i+ mkEquation NoSpanInfo fromEnumId [ConstructorPattern NoSpanInfo pty c []] $+ Literal NoSpanInfo (predType intType) $ Int i where pty = predType $ instType ty deriveEnumFrom :: Type -> ConstrInfo -> PredSet -> DVM (Decl PredType) deriveEnumFrom ty (_, c, _, _) ps = do pty <- getInstMethodType ps qEnumId ty enumFromId v <- freshArgument $ instType ty- return $ funDecl NoPos pty enumFromId [uncurry VariablePattern v] $+ return $ funDecl NoSpanInfo pty enumFromId+ [uncurry (VariablePattern NoSpanInfo) v] $ enumFromExpr v c enumFromExpr :: (PredType, Ident) -> QualIdent -> Expression PredType-enumFromExpr v c = prelEnumFromTo (uncurry mkVar v) $ Constructor (fst v) c+enumFromExpr v c = prelEnumFromTo (uncurry mkVar v) $+ Constructor NoSpanInfo (fst v) c deriveEnumFromThen :: Type -> ConstrInfo -> ConstrInfo -> PredSet -> DVM (Decl PredType) deriveEnumFromThen ty (_, c1, _, _) (_, c2, _, _) ps = do pty <- getInstMethodType ps qEnumId ty enumFromId vs@[v1, v2] <- mapM (freshArgument . instType) $ replicate 2 ty- return $ funDecl NoPos pty enumFromThenId (map (uncurry VariablePattern) vs) $+ return $ funDecl NoSpanInfo pty enumFromThenId+ (map (uncurry (VariablePattern NoSpanInfo)) vs) $ enumFromThenExpr v1 v2 c1 c2 enumFromThenExpr :: (PredType, Ident) -> (PredType, Ident) -> QualIdent -> QualIdent -> Expression PredType enumFromThenExpr v1 v2 c1 c2 = prelEnumFromThenTo (uncurry mkVar v1) (uncurry mkVar v2) $ boundedExpr- where boundedExpr = IfThenElse (prelLeq+ where boundedExpr = IfThenElse NoSpanInfo+ (prelLeq (prelFromEnum $ uncurry mkVar v1) (prelFromEnum $ uncurry mkVar v2))- (Constructor (fst v1) c2)- (Constructor (fst v1) c1)+ (Constructor NoSpanInfo (fst v1) c2)+ (Constructor NoSpanInfo (fst v1) c1) -- Upper and Lower Bounds: @@ -274,12 +281,13 @@ -> DVM (Decl PredType) deriveMaxOrMinBound f ty (_, c, _, tys) ps = do pty <- getInstMethodType ps qBoundedId ty $ unqualify f- return $ funDecl NoPos pty (unqualify f) [] $ maxOrMinBoundExpr f c ty tys+ return $ funDecl NoSpanInfo pty (unqualify f) [] $ maxOrMinBoundExpr f c ty tys maxOrMinBoundExpr :: QualIdent -> QualIdent -> Type -> [Type] -> Expression PredType maxOrMinBoundExpr f c ty tys =- apply (Constructor pty c) $ map (flip Variable f . predType) instTys+ apply (Constructor NoSpanInfo pty c) $+ map (flip (Variable NoSpanInfo) f . predType) instTys where instTy:instTys = map instType $ ty : tys pty = predType $ foldr TypeArrow instTy instTys @@ -293,15 +301,15 @@ pty <- getInstMethodType ps qReadId ty $ readsPrecId d <- freshArgument intType r <- freshArgument stringType- let pats = map (uncurry VariablePattern) [d, r]- funDecl NoPos pty readsPrecId pats <$>+ let pats = map (uncurry (VariablePattern NoSpanInfo)) [d, r]+ funDecl NoSpanInfo pty readsPrecId pats <$> deriveReadsPrecExpr ty cis (uncurry mkVar d) (uncurry mkVar r) deriveReadsPrecExpr :: Type -> [ConstrInfo] -> Expression PredType -> Expression PredType -> DVM (Expression PredType) deriveReadsPrecExpr ty cis d r = do es <- mapM (deriveReadsPrecReadParenExpr ty d) cis- return $ foldr1 prelAppend $ map (flip Apply r) $ es+ return $ foldr1 prelAppend $ map (flip (Apply NoSpanInfo) r) $ es deriveReadsPrecReadParenExpr :: Type -> Expression PredType -> ConstrInfo -> DVM (Expression PredType)@@ -316,9 +324,9 @@ readsPrecReadParenCondExpr (_, c, _, tys) d p | null tys = prelFalse | isQInfixOp c && length tys == 2 =- prelLt (Literal predIntType $ Int p) d+ prelLt (Literal NoSpanInfo predIntType $ Int p) d | otherwise =- prelLt (Literal predIntType $ Int 10) d+ prelLt (Literal NoSpanInfo predIntType $ Int 10) d deriveReadsPrecLambdaExpr :: Type -> ConstrInfo -> Precedence -> DVM (Expression PredType)@@ -326,10 +334,12 @@ r <- freshArgument stringType (stmts, vs, s) <- deriveReadsPrecStmts (unqualify c) (p + 1) r ls tys let pty = predType $ foldr TypeArrow (instType ty) $ map instType tys- e = Tuple [ apply (Constructor pty c) $ map (uncurry mkVar) vs+ e = Tuple NoSpanInfo+ [ apply (Constructor NoSpanInfo pty c) $ map (uncurry mkVar) vs , uncurry mkVar s ]- return $ Lambda [uncurry VariablePattern r] $ ListCompr e stmts+ return $ Lambda NoSpanInfo [uncurry (VariablePattern NoSpanInfo) r]+ $ ListCompr NoSpanInfo e stmts deriveReadsPrecStmts :: Ident -> Precedence -> (PredType, Ident) -> Maybe [Ident] -> [Type]@@ -391,11 +401,11 @@ -> DVM ((PredType, Ident), Statement PredType) deriveReadsPrecLexStmt str r = do s <- freshArgument $ stringType- let pat = TuplePattern- [ LiteralPattern predStringType $ String str- , uncurry VariablePattern s+ let pat = TuplePattern NoSpanInfo+ [ LiteralPattern NoSpanInfo predStringType $ String str+ , uncurry (VariablePattern NoSpanInfo) s ]- stmt = StmtBind pat $ preludeLex $ uncurry mkVar r+ stmt = StmtBind NoSpanInfo pat $ preludeLex $ uncurry mkVar r return (s, stmt) deriveReadsPrecReadsPrecStmt :: Precedence -> (PredType, Ident) -> Type@@ -403,8 +413,9 @@ deriveReadsPrecReadsPrecStmt p r ty = do v <- freshArgument $ instType ty s <- freshArgument $ stringType- let pat = TuplePattern $ map (uncurry VariablePattern) [v, s]- stmt = StmtBind pat $ preludeReadsPrec (instType ty) p $+ let pat = TuplePattern NoSpanInfo $+ map (uncurry (VariablePattern NoSpanInfo)) [v, s]+ stmt = StmtBind NoSpanInfo pat $ preludeReadsPrec (instType ty) p $ uncurry mkVar r return (s, (stmt, v)) @@ -417,15 +428,15 @@ deriveShowsPrec ty cis ps = do pty <- getInstMethodType ps qShowId ty $ showsPrecId eqs <- mapM (deriveShowsPrecEquation ty) cis- return $ FunctionDecl NoPos pty showsPrecId eqs+ return $ FunctionDecl NoSpanInfo pty showsPrecId eqs deriveShowsPrecEquation :: Type -> ConstrInfo -> DVM (Equation PredType) deriveShowsPrecEquation ty (_, c, ls, tys) = do d <- freshArgument intType vs <- mapM (freshArgument . instType) tys- let pats = [uncurry VariablePattern d, constrPattern pty c vs]+ let pats = [uncurry (VariablePattern NoSpanInfo) d, constrPattern pty c vs] pEnv <- getPrecEnv- return $ mkEquation NoPos showsPrecId pats $ showsPrecExpr (unqualify c)+ return $ mkEquation NoSpanInfo showsPrecId pats $ showsPrecExpr (unqualify c) (precedence c pEnv) ls (uncurry mkVar d) $ map (uncurry mkVar) vs where pty = predType $ instType ty @@ -446,7 +457,7 @@ showsPrecShowParenExpr :: Expression PredType -> Precedence -> Expression PredType -> Expression PredType showsPrecShowParenExpr d p =- prelShowParen $ prelLt (Literal predIntType $ Int p) d+ prelShowParen $ prelLt (Literal NoSpanInfo predIntType $ Int p) d showsPrecRecordConstrExpr :: Ident -> [Ident] -> [Expression PredType] -> Expression PredType@@ -537,84 +548,92 @@ -- ----------------------------------------------------------------------------- prelTrue :: Expression PredType-prelTrue = Constructor predBoolType qTrueId+prelTrue = Constructor NoSpanInfo predBoolType qTrueId prelFalse :: Expression PredType-prelFalse = Constructor predBoolType qFalseId+prelFalse = Constructor NoSpanInfo predBoolType qFalseId prelAppend :: Expression PredType -> Expression PredType -> Expression PredType-prelAppend e1 e2 = foldl1 Apply [Variable pty qAppendOpId, e1, e2]+prelAppend e1 e2 = foldl1 (Apply NoSpanInfo)+ [Variable NoSpanInfo pty qAppendOpId, e1, e2] where pty = predType $ foldr1 TypeArrow $ replicate 3 $ typeOf e1 prelDot :: Expression PredType -> Expression PredType -> Expression PredType-prelDot e1 e2 = foldl1 Apply [Variable pty qDotOpId, e1, e2]+prelDot e1 e2 = foldl1 (Apply NoSpanInfo)+ [Variable NoSpanInfo pty qDotOpId, e1, e2] where ty1@(TypeArrow _ ty12) = typeOf e1 ty2@(TypeArrow ty21 _ ) = typeOf e2 pty = predType $ foldr1 TypeArrow [ty1, ty2, ty21, ty12] prelAnd :: Expression PredType -> Expression PredType -> Expression PredType-prelAnd e1 e2 = foldl1 Apply [Variable pty qAndOpId, e1, e2]+prelAnd e1 e2 = foldl1 (Apply NoSpanInfo)+ [Variable NoSpanInfo pty qAndOpId, e1, e2] where pty = predType $ foldr1 TypeArrow $ replicate 3 boolType prelEq :: Expression PredType -> Expression PredType -> Expression PredType-prelEq e1 e2 = foldl1 Apply [Variable pty qEqOpId, e1, e2]+prelEq e1 e2 = foldl1 (Apply NoSpanInfo)+ [Variable NoSpanInfo pty qEqOpId, e1, e2] where ty = typeOf e1 pty = predType $ foldr1 TypeArrow [ty, ty, boolType] prelLeq :: Expression PredType -> Expression PredType -> Expression PredType-prelLeq e1 e2 = foldl1 Apply [Variable pty qLeqOpId, e1, e2]+prelLeq e1 e2 = foldl1 (Apply NoSpanInfo)+ [Variable NoSpanInfo pty qLeqOpId, e1, e2] where ty = typeOf e1 pty = predType $ foldr1 TypeArrow [ty, ty, boolType] prelLt :: Expression PredType -> Expression PredType -> Expression PredType-prelLt e1 e2 = foldl1 Apply [Variable pty qLtOpId, e1, e2]+prelLt e1 e2 = foldl1 (Apply NoSpanInfo)+ [Variable NoSpanInfo pty qLtOpId, e1, e2] where ty = typeOf e1 pty = predType $ foldr1 TypeArrow [ty, ty, boolType] prelOr :: Expression PredType -> Expression PredType -> Expression PredType-prelOr e1 e2 = foldl1 Apply [Variable pty qOrOpId, e1, e2]+prelOr e1 e2 = foldl1 (Apply NoSpanInfo)+ [Variable NoSpanInfo pty qOrOpId, e1, e2] where pty = predType $ foldr1 TypeArrow $ replicate 3 boolType prelFromEnum :: Expression PredType -> Expression PredType-prelFromEnum e = Apply (Variable pty qFromEnumId) e+prelFromEnum e = Apply NoSpanInfo (Variable NoSpanInfo pty qFromEnumId) e where pty = predType $ TypeArrow (typeOf e) intType prelEnumFromTo :: Expression PredType -> Expression PredType -> Expression PredType-prelEnumFromTo e1 e2 = apply (Variable pty qEnumFromToId) [e1, e2]+prelEnumFromTo e1 e2 = apply (Variable NoSpanInfo pty qEnumFromToId) [e1, e2] where ty = typeOf e1 pty = predType $ foldr1 TypeArrow [ty, ty, listType ty] prelEnumFromThenTo :: Expression PredType -> Expression PredType -> Expression PredType -> Expression PredType prelEnumFromThenTo e1 e2 e3 =- apply (Variable pty qEnumFromThenToId) [e1, e2, e3]+ apply (Variable NoSpanInfo pty qEnumFromThenToId) [e1, e2, e3] where ty = typeOf e1 pty = predType $ foldr1 TypeArrow [ty, ty, ty, listType ty] prelReadParen :: Expression PredType -> Expression PredType -> Expression PredType-prelReadParen e1 e2 = apply (Variable pty qReadParenId) [e1, e2]+prelReadParen e1 e2 = apply (Variable NoSpanInfo pty qReadParenId) [e1, e2] where ty = typeOf e2 pty = predType $ foldr1 TypeArrow [boolType, ty, ty] prelShowParen :: Expression PredType -> Expression PredType -> Expression PredType-prelShowParen e1 e2 = apply (Variable pty qShowParenId) [e1, e2]+prelShowParen e1 e2 = apply (Variable NoSpanInfo pty qShowParenId) [e1, e2] where pty = predType $ foldr1 TypeArrow [ boolType , TypeArrow stringType stringType , stringType, stringType ] preludeLex :: Expression PredType -> Expression PredType-preludeLex e = Apply (Variable pty qLexId) e+preludeLex e = Apply NoSpanInfo (Variable NoSpanInfo pty qLexId) e where pty = predType $ TypeArrow stringType $ listType $ tupleType [stringType, stringType] preludeReadsPrec :: Type -> Integer -> Expression PredType -> Expression PredType-preludeReadsPrec ty p e = flip Apply e $- Apply (Variable pty qReadsPrecId) $ Literal predIntType $ Int p+preludeReadsPrec ty p e = flip (Apply NoSpanInfo) e $+ Apply NoSpanInfo (Variable NoSpanInfo pty qReadsPrecId) $+ Literal NoSpanInfo predIntType $ Int p where pty = predType $ foldr1 TypeArrow [ intType, stringType , listType $ tupleType [ ty , stringType@@ -622,16 +641,17 @@ ] preludeShowsPrec :: Integer -> Expression PredType -> Expression PredType-preludeShowsPrec p e = flip Apply e $- Apply (Variable pty qShowsPrecId) $ Literal predIntType $ Int p+preludeShowsPrec p e = flip (Apply NoSpanInfo) e $+ Apply NoSpanInfo (Variable NoSpanInfo pty qShowsPrecId) $+ Literal NoSpanInfo predIntType $ Int p where pty = predType $ foldr1 TypeArrow [ intType, typeOf e , stringType, stringType ] preludeShowString :: String -> Expression PredType-preludeShowString s = Apply (Variable pty qShowStringId) $- Literal predStringType $ String s+preludeShowString s = Apply NoSpanInfo (Variable NoSpanInfo pty qShowStringId) $+ Literal NoSpanInfo predStringType $ String s where pty = predType $ foldr1 TypeArrow $ replicate 3 stringType preludeFailed :: Type -> Expression PredType-preludeFailed ty = Variable (predType ty) qFailedId+preludeFailed ty = Variable NoSpanInfo (predType ty) qFailedId
src/Transformations/Desugar.hs view
@@ -69,7 +69,7 @@ import qualified Data.Set as Set (Set, empty, member, insert) import Curry.Base.Ident-import Curry.Base.Position hiding (first)+import Curry.Base.SpanInfo import Curry.Syntax import Base.Expr@@ -84,6 +84,8 @@ import Env.TypeConstructor (TCEnv, TypeInfo (..), qualLookupTypeInfo) import Env.Value (ValueEnv, ValueInfo (..), qualLookupValue) +-- TODO: some types keep their spanInfo, some don't. Probably none of them are needed+ -- The desugaring phase keeps only the type, function, and value -- declarations of the module, i.e., type signatures are discarded. -- While record declarations are transformed into ordinary data/newtype@@ -94,8 +96,8 @@ desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module PredType -> (Module PredType, ValueEnv)-desugar xs vEnv tcEnv (Module ps m es is ds)- = (Module ps m es is ds', valueEnv s')+desugar xs vEnv tcEnv (Module spi ps m es is ds)+ = (Module spi ps m es is ds', valueEnv s') where (ds', s') = S.runState (desugarModuleDecls ds) (DesugarState m xs tcEnv vEnv 1) @@ -197,7 +199,7 @@ dsRecordDecl d = return [d] -- Generate a selector function for a single record label-genSelFun :: Position -> [QualIdent] -> Ident -> DsM (Decl PredType)+genSelFun :: SpanInfo -> [QualIdent] -> Ident -> DsM (Decl PredType) genSelFun p qcs l = do m <- getModuleIdent vEnv <- getValueEnv@@ -206,7 +208,7 @@ -- Generate a selector equation for a label and a constructor if the label -- is applicable, otherwise the empty list is returned.-genSelEqn :: Position -> Ident -> QualIdent -> DsM [Equation PredType]+genSelEqn :: SpanInfo -> Ident -> QualIdent -> DsM [Equation PredType] genSelEqn p l qc = do vEnv <- getValueEnv let (ls, ty) = conType qc vEnv@@ -261,7 +263,7 @@ dsDeclRhs :: Decl PredType -> DsM (Decl PredType) dsDeclRhs (FunctionDecl p pty f eqs) = FunctionDecl p pty f <$> mapM dsEquation eqs-dsDeclRhs (PatternDecl p t rhs) = PatternDecl p t <$> dsRhs p id rhs+dsDeclRhs (PatternDecl p t rhs) = PatternDecl p t <$> dsRhs id rhs dsDeclRhs d@(FreeDecl _ _) = return d dsDeclRhs d@(ExternalDecl _ _) = return d dsDeclRhs _ =@@ -273,9 +275,9 @@ ( cs1, ts1) <- dsNonLinearity ts (ds1, cs2, ts2) <- dsFunctionalPatterns p ts1 (ds2, ts3) <- mapAccumM (dsPat p) [] ts2- rhs' <- dsRhs p (constrain cs2 . constrain cs1)- (addDecls (ds1 ++ ds2) rhs)- return $ Equation p (FunLhs f ts3) rhs'+ rhs' <- dsRhs (constrain cs2 . constrain cs1)+ (addDecls (ds1 ++ ds2) rhs)+ return $ Equation p (FunLhs NoSpanInfo f ts3) rhs' where (f, ts) = flatLhs lhs -- Constrain an expression by a list of constraints.@@ -296,25 +298,24 @@ -- type 'Bool' of the guard because the guard's type defaults to -- 'Success' if it is not restricted by the guard expression. -dsRhs :: Position -> (Expression PredType -> Expression PredType)+dsRhs :: (Expression PredType -> Expression PredType) -> Rhs PredType -> DsM (Rhs PredType)-dsRhs p f rhs = expandRhs (prelFailed (typeOf rhs)) f rhs- >>= dsExpr pRhs- >>= return . simpleRhs pRhs- where- pRhs = fromMaybe p (getRhsPosition rhs)+dsRhs f rhs = expandRhs (prelFailed (typeOf rhs)) f rhs+ >>= dsExpr (getSpanInfo rhs)+ >>= return . simpleRhs (getSpanInfo rhs) expandRhs :: Expression PredType -> (Expression PredType -> Expression PredType) -> Rhs PredType -> DsM (Expression PredType)-expandRhs _ f (SimpleRhs _ e ds) = return $ Let ds (f e)-expandRhs e0 f (GuardedRhs es ds) = (Let ds . f) <$> expandGuards e0 es+expandRhs _ f (SimpleRhs _ e ds) = return $ Let NoSpanInfo ds (f e)+expandRhs e0 f (GuardedRhs _ es ds) = (Let NoSpanInfo ds . f)+ <$> expandGuards e0 es expandGuards :: Expression PredType -> [CondExpr PredType] -> DsM (Expression PredType) expandGuards e0 es = return $ if boolGuards es then foldr mkIfThenElse e0 es else mkCond es where- mkIfThenElse (CondExpr _ g e) = IfThenElse g e+ mkIfThenElse (CondExpr _ g e) = IfThenElse NoSpanInfo g e mkCond [CondExpr _ g e] = g &> e mkCond _ = error "Desugar.expandGuards.mkCond: non-unary list" @@ -325,11 +326,7 @@ -- Add additional declarations to a right-hand side addDecls :: [Decl PredType] -> Rhs PredType -> Rhs PredType addDecls ds (SimpleRhs p e ds') = SimpleRhs p e (ds ++ ds')-addDecls ds (GuardedRhs es ds') = GuardedRhs es (ds ++ ds')--getRhsPosition :: Rhs a -> Maybe Position-getRhsPosition (SimpleRhs p _ _) = Just p-getRhsPosition (GuardedRhs _ _) = Nothing+addDecls ds (GuardedRhs spi es ds') = GuardedRhs spi es (ds ++ ds') -- ----------------------------------------------------------------------------- -- Desugaring of non-linear patterns@@ -351,45 +348,48 @@ dsNonLinear :: NonLinearEnv -> Pattern PredType -> DsM (NonLinearEnv, Pattern PredType)-dsNonLinear env l@(LiteralPattern _ _) = return (env, l)-dsNonLinear env n@(NegativePattern _ _) = return (env, n)-dsNonLinear env t@(VariablePattern _ v)+dsNonLinear env l@(LiteralPattern _ _ _) = return (env, l)+dsNonLinear env n@(NegativePattern _ _ _) = return (env, n)+dsNonLinear env t@(VariablePattern _ _ v) | isAnonId v = return (env, t) | v `Set.member` vis = do v' <- freshVar "_#nonlinear" t- return ((vis, mkStrictEquality v v' : eqs), uncurry VariablePattern v')+ return ((vis, mkStrictEquality v v' : eqs),+ uncurry (VariablePattern NoSpanInfo) v') | otherwise = return ((Set.insert v vis, eqs), t) where (vis, eqs) = env-dsNonLinear env (ConstructorPattern pty c ts) = second (ConstructorPattern pty c)- <$> mapAccumM dsNonLinear env ts-dsNonLinear env (InfixPattern pty t1 op t2) = do+dsNonLinear env (ConstructorPattern _ pty c ts)+ = second (ConstructorPattern NoSpanInfo pty c) <$> mapAccumM dsNonLinear env ts+dsNonLinear env (InfixPattern _ pty t1 op t2) = do (env1, t1') <- dsNonLinear env t1 (env2, t2') <- dsNonLinear env1 t2- return (env2, InfixPattern pty t1' op t2')-dsNonLinear env (ParenPattern t) = second ParenPattern- <$> dsNonLinear env t-dsNonLinear env (RecordPattern pty c fs) =- second (RecordPattern pty c) <$> mapAccumM (dsField dsNonLinear) env fs-dsNonLinear env (TuplePattern ts) = second TuplePattern- <$> mapAccumM dsNonLinear env ts-dsNonLinear env (ListPattern pty ts) = second (ListPattern pty)- <$> mapAccumM dsNonLinear env ts-dsNonLinear env (AsPattern v t) = do+ return (env2, InfixPattern NoSpanInfo pty t1' op t2')+dsNonLinear env (ParenPattern _ t) =+ second (ParenPattern NoSpanInfo) <$> dsNonLinear env t+dsNonLinear env (RecordPattern _ pty c fs) =+ second (RecordPattern NoSpanInfo pty c)+ <$> mapAccumM (dsField dsNonLinear) env fs+dsNonLinear env (TuplePattern _ ts) =+ second (TuplePattern NoSpanInfo) <$> mapAccumM dsNonLinear env ts+dsNonLinear env (ListPattern _ pty ts) =+ second (ListPattern NoSpanInfo pty) <$> mapAccumM dsNonLinear env ts+dsNonLinear env (AsPattern _ v t) = do let pty = predType $ typeOf t- (env1, VariablePattern _ v') <- dsNonLinear env (VariablePattern pty v)+ (env1, VariablePattern _ _ v') <-+ dsNonLinear env (VariablePattern NoSpanInfo pty v) (env2, t') <- dsNonLinear env1 t- return (env2, AsPattern v' t')-dsNonLinear env (LazyPattern t) = second LazyPattern- <$> dsNonLinear env t-dsNonLinear env fp@(FunctionPattern _ _ _) = dsNonLinearFuncPat env fp-dsNonLinear env fp@(InfixFuncPattern _ _ _ _) = dsNonLinearFuncPat env fp+ return (env2, AsPattern NoSpanInfo v' t')+dsNonLinear env (LazyPattern _ t) =+ second (LazyPattern NoSpanInfo) <$> dsNonLinear env t+dsNonLinear env fp@(FunctionPattern _ _ _ _) = dsNonLinearFuncPat env fp+dsNonLinear env fp@(InfixFuncPattern _ _ _ _ _) = dsNonLinearFuncPat env fp dsNonLinearFuncPat :: NonLinearEnv -> Pattern PredType -> DsM (NonLinearEnv, Pattern PredType) dsNonLinearFuncPat (vis, eqs) fp = do let fpVars = map (\(v, _, pty) -> (pty, v)) $ patternVars fp vs = filter ((`Set.member` vis) . snd) fpVars- vs' <- mapM (freshVar "_#nonlinear" . uncurry VariablePattern) vs+ vs' <- mapM (freshVar "_#nonlinear" . uncurry (VariablePattern NoSpanInfo)) vs let vis' = foldr (Set.insert . snd) vis fpVars fp' = substPat (zip (map snd vs) (map snd vs')) fp return ((vis', zipWith mkStrictEquality (map snd vs) vs' ++ eqs), fp')@@ -398,28 +398,32 @@ mkStrictEquality x (pty, y) = mkVar pty x =:= mkVar pty y substPat :: [(Ident, Ident)] -> Pattern a -> Pattern a-substPat _ l@(LiteralPattern _ _) = l-substPat _ n@(NegativePattern _ _) = n-substPat s (VariablePattern a v) = VariablePattern a- $ fromMaybe v (lookup v s)-substPat s (ConstructorPattern a c ps) = ConstructorPattern a c- $ map (substPat s) ps-substPat s (InfixPattern a p1 op p2) = InfixPattern a (substPat s p1) op- (substPat s p2)-substPat s (ParenPattern p) = ParenPattern (substPat s p)-substPat s (RecordPattern a c fs) = RecordPattern a c (map substField fs)+substPat _ l@(LiteralPattern _ _ _) = l+substPat _ n@(NegativePattern _ _ _) = n+substPat s (VariablePattern _ a v) =+ VariablePattern NoSpanInfo a $ fromMaybe v (lookup v s)++substPat s (ConstructorPattern _ a c ps) =+ ConstructorPattern NoSpanInfo a c $ map (substPat s) ps+substPat s (InfixPattern _ a p1 op p2) =+ InfixPattern NoSpanInfo a (substPat s p1) op (substPat s p2)+substPat s (ParenPattern _ p) =+ ParenPattern NoSpanInfo (substPat s p)+substPat s (RecordPattern _ a c fs) =+ RecordPattern NoSpanInfo a c (map substField fs) where substField (Field pos l pat) = Field pos l (substPat s pat)-substPat s (TuplePattern ps) = TuplePattern- $ map (substPat s) ps-substPat s (ListPattern a ps) = ListPattern a- $ map (substPat s) ps-substPat s (AsPattern v p) = AsPattern (fromMaybe v (lookup v s))- (substPat s p)-substPat s (LazyPattern p) = LazyPattern (substPat s p)-substPat s (FunctionPattern a f ps) = FunctionPattern a f- $ map (substPat s) ps-substPat s (InfixFuncPattern a p1 op p2) = InfixFuncPattern a (substPat s p1) op- (substPat s p2)+substPat s (TuplePattern _ ps) =+ TuplePattern NoSpanInfo $ map (substPat s) ps+substPat s (ListPattern _ a ps) =+ ListPattern NoSpanInfo a $ map (substPat s) ps+substPat s (AsPattern _ v p) =+ AsPattern NoSpanInfo (fromMaybe v (lookup v s)) (substPat s p)+substPat s (LazyPattern _ p) =+ LazyPattern NoSpanInfo (substPat s p)+substPat s (FunctionPattern _ a f ps) =+ FunctionPattern NoSpanInfo a f $ map (substPat s) ps+substPat s (InfixFuncPattern _ a p1 op p2) =+ InfixFuncPattern NoSpanInfo a (substPat s p1) op (substPat s p2) -- ----------------------------------------------------------------------------- -- Desugaring of functional patterns@@ -440,7 +444,7 @@ -- such that the patterns are evaluated from left to right. dsFunctionalPatterns- :: Position -> [Pattern PredType]+ :: SpanInfo -> [Pattern PredType] -> DsM ([Decl PredType], [Expression PredType], [Pattern PredType]) dsFunctionalPatterns p ts = do -- extract functional patterns@@ -454,32 +458,35 @@ elimFP :: [LazyBinding] -> Pattern PredType -> DsM ([LazyBinding], Pattern PredType)-elimFP bs p@(LiteralPattern _ _) = return (bs, p)-elimFP bs p@(NegativePattern _ _) = return (bs, p)-elimFP bs p@(VariablePattern _ _) = return (bs, p)-elimFP bs (ConstructorPattern pty c ts) = second (ConstructorPattern pty c)- <$> mapAccumM elimFP bs ts-elimFP bs (InfixPattern pty t1 op t2) = do+elimFP bs p@(LiteralPattern _ _ _) = return (bs, p)+elimFP bs p@(NegativePattern _ _ _) = return (bs, p)+elimFP bs p@(VariablePattern _ _ _) = return (bs, p)+elimFP bs (ConstructorPattern _ pty c ts) =+ second (ConstructorPattern NoSpanInfo pty c) <$> mapAccumM elimFP bs ts+elimFP bs (InfixPattern _ pty t1 op t2) = do (bs1, t1') <- elimFP bs t1 (bs2, t2') <- elimFP bs1 t2- return (bs2, InfixPattern pty t1' op t2')-elimFP bs (ParenPattern t) = second ParenPattern <$> elimFP bs t-elimFP bs (RecordPattern pty c fs) = second (RecordPattern pty c)- <$> mapAccumM (dsField elimFP) bs fs-elimFP bs (TuplePattern ts) = second TuplePattern- <$> mapAccumM elimFP bs ts-elimFP bs (ListPattern pty ts) = second (ListPattern pty)- <$> mapAccumM elimFP bs ts-elimFP bs (AsPattern v t) = second (AsPattern v) <$> elimFP bs t-elimFP bs (LazyPattern t) = second LazyPattern <$> elimFP bs t-elimFP bs p@(FunctionPattern _ _ _) = do+ return (bs2, InfixPattern NoSpanInfo pty t1' op t2')+elimFP bs (ParenPattern _ t) =+ second (ParenPattern NoSpanInfo) <$> elimFP bs t+elimFP bs (RecordPattern _ pty c fs) =+ second (RecordPattern NoSpanInfo pty c) <$> mapAccumM (dsField elimFP) bs fs+elimFP bs (TuplePattern _ ts) =+ second (TuplePattern NoSpanInfo) <$> mapAccumM elimFP bs ts+elimFP bs (ListPattern _ pty ts) =+ second (ListPattern NoSpanInfo pty) <$> mapAccumM elimFP bs ts+elimFP bs (AsPattern _ v t) =+ second (AsPattern NoSpanInfo v) <$> elimFP bs t+elimFP bs (LazyPattern _ t) =+ second (LazyPattern NoSpanInfo) <$> elimFP bs t+elimFP bs p@(FunctionPattern _ _ _ _) = do (pty, v) <- freshVar "_#funpatt" p- return ((p, (pty, v)) : bs, VariablePattern pty v)-elimFP bs p@(InfixFuncPattern _ _ _ _) = do+ return ((p, (pty, v)) : bs, VariablePattern NoSpanInfo pty v)+elimFP bs p@(InfixFuncPattern _ _ _ _ _) = do (pty, v) <- freshVar "_#funpatt" p- return ((p, (pty, v)) : bs, VariablePattern pty v)+ return ((p, (pty, v)) : bs, VariablePattern NoSpanInfo pty v) -genFPExpr :: Position -> [(Ident, Int, PredType)] -> [LazyBinding]+genFPExpr :: SpanInfo -> [(Ident, Int, PredType)] -> [LazyBinding] -> ([Decl PredType], [Expression PredType]) genFPExpr p vs bs | null bs = ([] , [])@@ -493,42 +500,43 @@ concatMap patternVars (map fst bs) \\ vs fp2Expr :: Pattern PredType -> (Expression PredType, [Expression PredType])-fp2Expr (LiteralPattern pty l) = (Literal pty l, [])-fp2Expr (NegativePattern pty l) = (Literal pty (negateLiteral l), [])-fp2Expr (VariablePattern pty v) = (mkVar pty v, [])-fp2Expr (ConstructorPattern pty c ts) =+fp2Expr (LiteralPattern _ pty l) = (Literal NoSpanInfo pty l, [])+fp2Expr (NegativePattern _ pty l) =+ (Literal NoSpanInfo pty (negateLiteral l), [])+fp2Expr (VariablePattern _ pty v) = (mkVar pty v, [])+fp2Expr (ConstructorPattern _ pty c ts) = let (ts', ess) = unzip $ map fp2Expr ts pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf ts- in (apply (Constructor pty' c) ts', concat ess)-fp2Expr (InfixPattern pty t1 op t2) =+ in (apply (Constructor NoSpanInfo pty' c) ts', concat ess)+fp2Expr (InfixPattern _ pty t1 op t2) = let (t1', es1) = fp2Expr t1 (t2', es2) = fp2Expr t2 pty' = predType $ foldr TypeArrow (unpredType pty) [typeOf t1, typeOf t2]- in (InfixApply t1' (InfixConstr pty' op) t2', es1 ++ es2)-fp2Expr (ParenPattern t) = first Paren (fp2Expr t)-fp2Expr (TuplePattern ts) =+ in (InfixApply NoSpanInfo t1' (InfixConstr pty' op) t2', es1 ++ es2)+fp2Expr (ParenPattern _ t) = first (Paren NoSpanInfo) (fp2Expr t)+fp2Expr (TuplePattern _ ts) = let (ts', ess) = unzip $ map fp2Expr ts- in (Tuple ts', concat ess)-fp2Expr (ListPattern pty ts) =+ in (Tuple NoSpanInfo ts', concat ess)+fp2Expr (ListPattern _ pty ts) = let (ts', ess) = unzip $ map fp2Expr ts- in (List pty ts', concat ess)-fp2Expr (FunctionPattern pty f ts) =+ in (List NoSpanInfo pty ts', concat ess)+fp2Expr (FunctionPattern _ pty f ts) = let (ts', ess) = unzip $ map fp2Expr ts pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf ts- in (apply (Variable pty' f) ts', concat ess)-fp2Expr (InfixFuncPattern pty t1 op t2) =+ in (apply (Variable NoSpanInfo pty' f) ts', concat ess)+fp2Expr (InfixFuncPattern _ pty t1 op t2) = let (t1', es1) = fp2Expr t1 (t2', es2) = fp2Expr t2 pty' = predType $ foldr TypeArrow (unpredType pty) $ map typeOf [t1, t2]- in (InfixApply t1' (InfixOp pty' op) t2', es1 ++ es2)-fp2Expr (AsPattern v t) =+ in (InfixApply NoSpanInfo t1' (InfixOp pty' op) t2', es1 ++ es2)+fp2Expr (AsPattern _ v t) = let (t', es) = fp2Expr t pty = predType $ typeOf t in (mkVar pty v, (t' =:<= mkVar pty v) : es)-fp2Expr (RecordPattern pty c fs) =+fp2Expr (RecordPattern _ pty c fs) = let (fs', ess) = unzip [ (Field p f e, es) | Field p f t <- fs , let (e, es) = fp2Expr t]- in (Record pty c fs', concat ess)+ in (Record NoSpanInfo pty c fs', concat ess) fp2Expr t = internalError $ "Desugar.fp2Expr: Unexpected constructor term: " ++ show t @@ -558,71 +566,74 @@ dsLiteralPat :: PredType -> Literal -> Either (Pattern PredType) (Pattern PredType)-dsLiteralPat pty c@(Char _) = Right (LiteralPattern pty c)+dsLiteralPat pty c@(Char _) = Right (LiteralPattern NoSpanInfo pty c) dsLiteralPat pty (Int i) =- Right (LiteralPattern pty (fixLiteral (unpredType pty)))+ Right (LiteralPattern NoSpanInfo pty (fixLiteral (unpredType pty))) where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys) fixLiteral ty | ty == floatType = Float $ fromInteger i | otherwise = Int i-dsLiteralPat pty f@(Float _) = Right (LiteralPattern pty f)+dsLiteralPat pty f@(Float _) = Right (LiteralPattern NoSpanInfo pty f) dsLiteralPat pty (String cs) =- Left $ ListPattern pty $ map (LiteralPattern pty' . Char) cs+ Left $ ListPattern NoSpanInfo pty $+ map (LiteralPattern NoSpanInfo pty' . Char) cs where pty' = predType $ elemType $ unpredType pty -dsPat :: Position -> [Decl PredType] -> Pattern PredType+dsPat :: SpanInfo -> [Decl PredType] -> Pattern PredType -> DsM ([Decl PredType], Pattern PredType)-dsPat _ ds v@(VariablePattern _ _) = return (ds, v)-dsPat p ds (LiteralPattern pty l) =+dsPat _ ds v@(VariablePattern _ _ _) = return (ds, v)+dsPat p ds (LiteralPattern _ pty l) = either (dsPat p ds) (return . (,) ds) (dsLiteralPat pty l)-dsPat p ds (NegativePattern pty l) =- dsPat p ds (LiteralPattern pty (negateLiteral l))-dsPat p ds (ConstructorPattern pty c ts) =- second (ConstructorPattern pty c) <$> mapAccumM (dsPat p) ds ts-dsPat p ds (InfixPattern pty t1 op t2) =- dsPat p ds (ConstructorPattern pty op [t1, t2])-dsPat p ds (ParenPattern t) = dsPat p ds t-dsPat p ds (RecordPattern pty c fs) = do+dsPat p ds (NegativePattern _ pty l) =+ dsPat p ds (LiteralPattern NoSpanInfo pty (negateLiteral l))+dsPat p ds (ConstructorPattern _ pty c ts) =+ second (ConstructorPattern NoSpanInfo pty c) <$> mapAccumM (dsPat p) ds ts+dsPat p ds (InfixPattern _ pty t1 op t2) =+ dsPat p ds (ConstructorPattern NoSpanInfo pty op [t1, t2])+dsPat p ds (ParenPattern _ t) = dsPat p ds t+dsPat p ds (RecordPattern _ pty c fs) = do vEnv <- getValueEnv --TODO: Rework let (ls, tys) = argumentTypes (unpredType pty) c vEnv tsMap = map field2Tuple fs- anonTs = map (flip VariablePattern anonId . predType) tys- maybeTs = map (flip lookup tsMap) ls+ anonTs <- mapM ((uncurry (VariablePattern NoSpanInfo) <$>) .+ freshVar "_#recpat") tys+ let maybeTs = map (flip lookup tsMap) ls ts = zipWith fromMaybe anonTs maybeTs- dsPat p ds (ConstructorPattern pty c ts)-dsPat p ds (TuplePattern ts) =- dsPat p ds (ConstructorPattern pty (qTupleId $ length ts) ts)+ dsPat p ds (ConstructorPattern NoSpanInfo pty c ts)+dsPat p ds (TuplePattern _ ts) =+ dsPat p ds (ConstructorPattern NoSpanInfo pty (qTupleId $ length ts) ts) where pty = predType (tupleType (map typeOf ts))-dsPat p ds (ListPattern pty ts) =+dsPat p ds (ListPattern _ pty ts) = second (dsList cons nil) <$> mapAccumM (dsPat p) ds ts- where nil = ConstructorPattern pty qNilId []- cons t ts' = ConstructorPattern pty qConsId [t, ts']-dsPat p ds (AsPattern v t) = dsAs p v <$> dsPat p ds t-dsPat p ds (LazyPattern t) = dsLazy p ds t-dsPat p ds (FunctionPattern pty f ts) = second (FunctionPattern pty f)- <$> mapAccumM (dsPat p) ds ts-dsPat p ds (InfixFuncPattern pty t1 f t2) =- dsPat p ds (FunctionPattern pty f [t1, t2])+ where nil = ConstructorPattern NoSpanInfo pty qNilId []+ cons t ts' = ConstructorPattern NoSpanInfo pty qConsId [t, ts']+dsPat p ds (AsPattern _ v t) = dsAs p v <$> dsPat p ds t+dsPat p ds (LazyPattern _ t) = dsLazy p ds t+dsPat p ds (FunctionPattern _ pty f ts) =+ second (FunctionPattern NoSpanInfo pty f) <$> mapAccumM (dsPat p) ds ts+dsPat p ds (InfixFuncPattern _ pty t1 f t2) =+ dsPat p ds (FunctionPattern NoSpanInfo pty f [t1, t2]) -dsAs :: Position -> Ident -> ([Decl PredType], Pattern PredType)+dsAs :: SpanInfo -> Ident -> ([Decl PredType], Pattern PredType) -> ([Decl PredType], Pattern PredType) dsAs p v (ds, t) = case t of- VariablePattern pty v' -> (varDecl p pty v (mkVar pty v') : ds, t)- AsPattern v' t' -> (varDecl p pty' v (mkVar pty' v') : ds, t)+ VariablePattern _ pty v' -> (varDecl p pty v (mkVar pty v') : ds,t)+ AsPattern _ v' t' -> (varDecl p pty' v (mkVar pty' v') : ds,t) where pty' = predType $ typeOf t'- _ -> (ds, AsPattern v t)+ _ -> (ds, AsPattern NoSpanInfo v t) -dsLazy :: Position -> [Decl PredType] -> Pattern PredType+dsLazy :: SpanInfo -> [Decl PredType] -> Pattern PredType -> DsM ([Decl PredType], Pattern PredType) dsLazy p ds t = case t of- VariablePattern _ _ -> return (ds, t)- ParenPattern t' -> dsLazy p ds t'- AsPattern v t' -> dsAs p v <$> dsLazy p ds t'- LazyPattern t' -> dsLazy p ds t'+ VariablePattern _ _ _ -> return (ds, t)+ ParenPattern _ t' -> dsLazy p ds t'+ AsPattern _ v t' -> dsAs p v <$> dsLazy p ds t'+ LazyPattern _ t' -> dsLazy p ds t' _ -> do (pty, v') <- freshVar "_#lazy" t- return (patDecl p t (mkVar pty v') : ds, VariablePattern pty v')+ return (patDecl NoSpanInfo t (mkVar pty v') : ds,+ VariablePattern NoSpanInfo pty v') {- -- -----------------------------------------------------------------------------@@ -641,16 +652,17 @@ -- field labels @l_1,...,l_k@. In contrast to Haskell, we do not report -- an error if this is not the case, but call failed instead. -}-dsExpr :: Position -> Expression PredType -> DsM (Expression PredType)-dsExpr p (Literal pty l) =+dsExpr :: SpanInfo -> Expression PredType -> DsM (Expression PredType)+dsExpr p (Literal _ pty l) = either (dsExpr p) return (dsLiteral pty l)-dsExpr _ var@(Variable pty v)+dsExpr _ var@(Variable _ pty v) | isAnonId (unqualify v) = return $ prelUnknown $ unpredType pty | otherwise = return var-dsExpr _ c@(Constructor _ _) = return c-dsExpr p (Paren e) = dsExpr p e-dsExpr p (Typed e qty) = Typed <$> dsExpr p e <*> dsQualTypeExpr qty-dsExpr p (Record pty c fs) = do+dsExpr _ c@(Constructor _ _ _) = return c+dsExpr p (Paren _ e) = dsExpr p e+dsExpr p (Typed _ e qty) = Typed NoSpanInfo+ <$> dsExpr p e <*> dsQualTypeExpr qty+dsExpr p (Record _ pty c fs) = do vEnv <- getValueEnv --TODO: Rework let (ls, tys) = argumentTypes (unpredType pty) c vEnv@@ -659,9 +671,9 @@ maybeEs = map (flip lookup esMap) ls es = zipWith fromMaybe unknownEs maybeEs dsExpr p (applyConstr pty c tys es)-dsExpr p (RecordUpdate e fs) = do+dsExpr p (RecordUpdate _ e fs) = do alts <- constructors tc >>= concatMapM updateAlt- dsExpr p $ Case Flex e (map (uncurry (caseAlt p)) alts)+ dsExpr p $ Case NoSpanInfo Flex e (map (uncurry (caseAlt p)) alts) where ty = typeOf e pty = predType ty tc = rootOfType (arrowBase ty)@@ -679,53 +691,61 @@ return [(pat, applyConstr pty qc tys es)] where qls2 = map (qualifyLike tc) ls updateAlt _ = return []-dsExpr p (Tuple es) = apply (Constructor pty $ qTupleId $ length es) <$> mapM (dsExpr p) es+dsExpr p (Tuple _ es) =+ apply (Constructor NoSpanInfo pty $ qTupleId $ length es)+ <$> mapM (dsExpr p) es where pty = predType (foldr TypeArrow (tupleType tys) tys) tys = map typeOf es-dsExpr p (List pty es) = dsList cons nil <$> mapM (dsExpr p) es- where nil = Constructor pty qNilId- cons = Apply . Apply (Constructor (predType $ consType $ elemType $ unpredType pty) qConsId)-dsExpr p (ListCompr e qs) = dsListComp p e qs-dsExpr p (EnumFrom e) = Apply (prelEnumFrom (typeOf e))- <$> dsExpr p e-dsExpr p (EnumFromThen e1 e2) = apply (prelEnumFromThen (typeOf e1))- <$> mapM (dsExpr p) [e1, e2]-dsExpr p (EnumFromTo e1 e2) = apply (prelEnumFromTo (typeOf e1))- <$> mapM (dsExpr p) [e1, e2]-dsExpr p (EnumFromThenTo e1 e2 e3) = apply (prelEnumFromThenTo (typeOf e1))- <$> mapM (dsExpr p) [e1, e2, e3]-dsExpr p (UnaryMinus e) = do+dsExpr p (List _ pty es) = dsList cons nil <$> mapM (dsExpr p) es+ where nil = Constructor NoSpanInfo pty qNilId+ cons = (Apply NoSpanInfo) . (Apply NoSpanInfo)+ (Constructor NoSpanInfo+ (predType $ consType $ elemType $ unpredType pty) qConsId)+dsExpr p (ListCompr _ e qs) = dsListComp p e qs+dsExpr p (EnumFrom _ e) =+ Apply NoSpanInfo (prelEnumFrom (typeOf e)) <$> dsExpr p e+dsExpr p (EnumFromThen _ e1 e2) =+ apply (prelEnumFromThen (typeOf e1)) <$> mapM (dsExpr p) [e1, e2]+dsExpr p (EnumFromTo _ e1 e2) = apply (prelEnumFromTo (typeOf e1))+ <$> mapM (dsExpr p) [e1, e2]+dsExpr p (EnumFromThenTo _ e1 e2 e3) = apply (prelEnumFromThenTo (typeOf e1))+ <$> mapM (dsExpr p) [e1, e2, e3]+dsExpr p (UnaryMinus _ e) = do e' <- dsExpr p e negativeLitsEnabled <- checkNegativeLitsExtension return $ case e' of- Literal pty l | negativeLitsEnabled -> Literal pty $ negateLiteral l- _ -> Apply (prelNegate $ typeOf e') e'-dsExpr p (Apply e1 e2) = Apply <$> dsExpr p e1 <*> dsExpr p e2-dsExpr p (InfixApply e1 op e2) = do+ Literal _ pty l | negativeLitsEnabled ->+ Literal NoSpanInfo pty $ negateLiteral l+ _ ->+ Apply NoSpanInfo (prelNegate $ typeOf e') e'+dsExpr p (Apply _ e1 e2) = Apply NoSpanInfo <$> dsExpr p e1 <*> dsExpr p e2+dsExpr p (InfixApply _ e1 op e2) = do op' <- dsExpr p (infixOp op) e1' <- dsExpr p e1 e2' <- dsExpr p e2 return $ apply op' [e1', e2']-dsExpr p (LeftSection e op) = Apply <$> dsExpr p (infixOp op) <*> dsExpr p e-dsExpr p (RightSection op e) = do+dsExpr p (LeftSection _ e op) =+ Apply NoSpanInfo <$> dsExpr p (infixOp op) <*> dsExpr p e+dsExpr p (RightSection _ op e) = do op' <- dsExpr p (infixOp op) e' <- dsExpr p e return $ apply (prelFlip ty1 ty2 ty3) [op', e'] where TypeArrow ty1 (TypeArrow ty2 ty3) = typeOf (infixOp op)-dsExpr p expr@(Lambda ts e) = do+dsExpr p expr@(Lambda _ ts e) = do (pty, f) <- freshVar "_#lambda" expr- dsExpr p $ Let [funDecl NoPos pty f ts e] $ mkVar pty f-dsExpr p (Let ds e) = do+ dsExpr p $ Let NoSpanInfo [funDecl p pty f ts e] $ mkVar pty f+dsExpr p (Let _ ds e) = do ds' <- dsDeclGroup ds e' <- dsExpr p e- return (if null ds' then e' else Let ds' e')-dsExpr p (Do sts e) = dsDo sts e >>= dsExpr p-dsExpr p (IfThenElse e1 e2 e3) = do+ return (if null ds' then e' else Let NoSpanInfo ds' e')+dsExpr p (Do _ sts e) = dsDo sts e >>= dsExpr p+dsExpr p (IfThenElse _ e1 e2 e3) = do e1' <- dsExpr p e1 e2' <- dsExpr p e2 e3' <- dsExpr p e3- return $ Case Rigid e1' [caseAlt p truePat e2', caseAlt p falsePat e3']-dsExpr p (Case ct e alts) = dsCase p ct e alts+ return $ Case NoSpanInfo Rigid e1'+ [caseAlt p truePat e2', caseAlt p falsePat e3']+dsExpr p (Case _ ct e alts) = dsCase p ct e alts -- We ignore the context in the type signature of a typed expression, since -- there should be no possibility to provide an non-empty context without@@ -733,7 +753,8 @@ -- TODO: Verify dsQualTypeExpr :: QualTypeExpr -> DsM QualTypeExpr-dsQualTypeExpr (QualTypeExpr cx ty) = QualTypeExpr cx <$> dsTypeExpr ty+dsQualTypeExpr (QualTypeExpr _ cx ty) =+ QualTypeExpr NoSpanInfo cx <$> dsTypeExpr ty dsTypeExpr :: TypeExpr -> DsM TypeExpr dsTypeExpr ty = do@@ -753,7 +774,7 @@ -- such that it evaluates a case expression with the remaining cases that -- are compatible with the matched pattern when the guards fail. -dsCase :: Position -> CaseType -> Expression PredType -> [Alt PredType]+dsCase :: SpanInfo -> CaseType -> Expression PredType -> [Alt PredType] -> DsM (Expression PredType) dsCase p ct e alts | null alts = internalError "Desugar.dsCase: empty list of alternatives"@@ -766,8 +787,9 @@ return (mkCase m v e' alts'') where mkCase m (pty, v) e' bs- | v `elem` qfv m bs = Let [varDecl p pty v e'] (Case ct (mkVar pty v) bs)- | otherwise = Case ct e' bs+ | v `elem` qfv m bs = Let NoSpanInfo [varDecl p pty v e']+ (Case NoSpanInfo ct (mkVar pty v) bs)+ | otherwise = Case NoSpanInfo ct e' bs dsAltLhs :: Alt PredType -> DsM (Alt PredType) dsAltLhs (Alt p t rhs) = do@@ -775,7 +797,7 @@ return $ Alt p t' (addDecls ds' rhs) dsAltRhs :: Alt PredType -> DsM (Alt PredType)-dsAltRhs (Alt p t rhs) = Alt p t <$> dsRhs p id rhs+dsAltRhs (Alt p t rhs) = Alt p t <$> dsRhs id rhs expandAlt :: (PredType, Ident) -> CaseType -> [Alt PredType] -> DsM (Alt PredType)@@ -783,18 +805,18 @@ expandAlt v ct (Alt p t rhs : alts) = caseAlt p t <$> expandRhs e0 id rhs where e0 | ct == Flex || null compAlts = prelFailed (typeOf rhs)- | otherwise = Case ct (uncurry mkVar v) compAlts+ | otherwise = Case NoSpanInfo ct (uncurry mkVar v) compAlts compAlts = filter (isCompatible t . altPattern) alts altPattern (Alt _ t1 _) = t1 isCompatible :: Pattern a -> Pattern a -> Bool-isCompatible (VariablePattern _ _) _ = True-isCompatible _ (VariablePattern _ _) = True-isCompatible (AsPattern _ t1) t2 = isCompatible t1 t2-isCompatible t1 (AsPattern _ t2) = isCompatible t1 t2-isCompatible (ConstructorPattern _ c1 ts1) (ConstructorPattern _ c2 ts2)+isCompatible (VariablePattern _ _ _) _ = True+isCompatible _ (VariablePattern _ _ _) = True+isCompatible (AsPattern _ _ t1) t2 = isCompatible t1 t2+isCompatible t1 (AsPattern _ _ t2) = isCompatible t1 t2+isCompatible (ConstructorPattern _ _ c1 ts1) (ConstructorPattern _ _ c2 ts2) = and ((c1 == c2) : zipWith isCompatible ts1 ts2)-isCompatible (LiteralPattern _ l1) (LiteralPattern _ l2) = l1 == l2+isCompatible (LiteralPattern _ _ l1) (LiteralPattern _ _ l2) = l1 == l2 isCompatible _ _ = False -- -----------------------------------------------------------------------------@@ -813,21 +835,21 @@ dsDo sts e = foldrM dsStmt e sts dsStmt :: Statement PredType -> Expression PredType -> DsM (Expression PredType)-dsStmt (StmtExpr e1) e' =+dsStmt (StmtExpr _ e1) e' = return $ apply (prelBind_ (typeOf e1) (typeOf e')) [e1, e']-dsStmt (StmtBind t e1) e' = do+dsStmt (StmtBind _ t e1) e' = do v <- freshVar "_#var" t- let func = Lambda [uncurry VariablePattern v] $- Case Rigid (uncurry mkVar v)- [ caseAlt NoPos t e'- , caseAlt NoPos (uncurry VariablePattern v)+ let func = Lambda NoSpanInfo [uncurry (VariablePattern NoSpanInfo) v] $+ Case NoSpanInfo Rigid (uncurry mkVar v)+ [ caseAlt NoSpanInfo t e'+ , caseAlt NoSpanInfo (uncurry (VariablePattern NoSpanInfo) v) (failedPatternMatch $ typeOf e') ] return $ apply (prelBind (typeOf e1) (typeOf t) (typeOf e')) [e1, func] where failedPatternMatch ty = apply (prelFail ty)- [Literal predStringType $ String "Pattern match failed!"]-dsStmt (StmtDecl ds) e' = return $ Let ds e'+ [Literal NoSpanInfo predStringType $ String "Pattern match failed!"]+dsStmt (StmtDecl _ ds) e' = return $ Let NoSpanInfo ds e' -- ----------------------------------------------------------------------------- -- Desugaring of List Comprehensions@@ -859,38 +881,42 @@ -- avoid the construction of the singleton list by calling '(:)' -- instead of '(++)' and 'map' in place of 'concatMap', respectively. -dsListComp :: Position -> Expression PredType -> [Statement PredType]+dsListComp :: SpanInfo -> Expression PredType -> [Statement PredType] -> DsM (Expression PredType) dsListComp p e [] =- dsExpr p (List (predType $ listType $ typeOf e) [e])-dsListComp p e (q:qs) = dsQual p q (ListCompr e qs)+ dsExpr p (List NoSpanInfo (predType $ listType $ typeOf e) [e])+dsListComp p e (q:qs) = dsQual p q (ListCompr NoSpanInfo e qs) -dsQual :: Position -> Statement PredType -> Expression PredType+dsQual :: SpanInfo -> Statement PredType -> Expression PredType -> DsM (Expression PredType)-dsQual p (StmtExpr b) e =- dsExpr p (IfThenElse b e (List (predType $ typeOf e) []))-dsQual p (StmtDecl ds) e = dsExpr p (Let ds e)-dsQual p (StmtBind t l) e+dsQual p (StmtExpr _ b) e =+ dsExpr p (IfThenElse NoSpanInfo b e (List NoSpanInfo (predType $ typeOf e) []))+dsQual p (StmtDecl _ ds) e = dsExpr p (Let NoSpanInfo ds e)+dsQual p (StmtBind _ t l) e | isVariablePattern t = dsExpr p (qualExpr t e l) | otherwise = do v <- freshVar "_#var" t l' <- freshVar "_#var" e dsExpr p (apply (prelFoldr (typeOf t) (typeOf e))- [foldFunct v l' e, List (predType $ typeOf e) [], l])+ [foldFunct v l' e, List NoSpanInfo (predType $ typeOf e) [], l]) where- qualExpr v (ListCompr e1 []) l1- = apply (prelMap (typeOf v) (typeOf e1)) [Lambda [v] e1, l1]+ qualExpr v (ListCompr NoSpanInfo e1 []) l1+ = apply (prelMap (typeOf v) (typeOf e1)) [Lambda NoSpanInfo [v] e1, l1] qualExpr v e1 l1- = apply (prelConcatMap (typeOf v) (elemType $ typeOf e1)) [Lambda [v] e1, l1]+ = apply (prelConcatMap (typeOf v) (elemType $ typeOf e1))+ [Lambda NoSpanInfo [v] e1, l1] foldFunct v l1 e1- = Lambda (map (uncurry VariablePattern) [v, l1])- (Case Rigid (uncurry mkVar v)+ = Lambda NoSpanInfo (map (uncurry (VariablePattern NoSpanInfo)) [v, l1])+ (Case NoSpanInfo Rigid (uncurry mkVar v) [ caseAlt p t (append e1 (uncurry mkVar l1))- , caseAlt p (uncurry VariablePattern v) (uncurry mkVar l1)])+ , caseAlt p (uncurry (VariablePattern NoSpanInfo) v)+ (uncurry mkVar l1)]) - append (ListCompr e1 []) l1 = apply (prelCons (typeOf e1)) [e1, l1]- append e1 l1 = apply (prelAppend (elemType $ typeOf e1)) [e1, l1]- prelCons ty = Constructor (predType $ consType ty) $ qConsId+ append (ListCompr _ e1 []) l1 = apply (prelCons (typeOf e1)) [e1, l1]+ append e1 l1 =+ apply (prelAppend (elemType $ typeOf e1)) [e1, l1]+ prelCons ty =+ Constructor NoSpanInfo (predType $ consType ty) $ qConsId -- ----------------------------------------------------------------------------- -- Desugaring of Lists, labels, fields, and literals@@ -903,26 +929,26 @@ --dsLabel def fs l = fromMaybe def (lookup l fs) dsField :: (a -> b -> DsM (a, b)) -> a -> Field b -> DsM (a, Field b)-dsField ds z (Field p l x) = second (Field p l) <$> (ds z x)+dsField ds z (Field p l x) = second (Field p l) <$> ds z x dsLiteral :: PredType -> Literal -> Either (Expression PredType) (Expression PredType)-dsLiteral pty (Char c) = Right $ Literal pty $ Char c+dsLiteral pty (Char c) = Right $ Literal NoSpanInfo pty $ Char c dsLiteral pty (Int i) = Right $ fixLiteral (unpredType pty) where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys) fixLiteral ty- | ty == intType = Literal pty $ Int i- | ty == floatType = Literal pty $ Float $ fromInteger i- | otherwise = Apply (prelFromInt $ unpredType pty) $- Literal predIntType $ Int i+ | ty == intType = Literal NoSpanInfo pty $ Int i+ | ty == floatType = Literal NoSpanInfo pty $ Float $ fromInteger i+ | otherwise = Apply NoSpanInfo (prelFromInt $ unpredType pty) $+ Literal NoSpanInfo predIntType $ Int i dsLiteral pty f@(Float _) = Right $ fixLiteral (unpredType pty) where fixLiteral (TypeConstrained tys _) = fixLiteral (head tys) fixLiteral ty- | ty == floatType = Literal pty f- | otherwise = Apply (prelFromFloat $ unpredType pty) $- Literal predFloatType f+ | ty == floatType = Literal NoSpanInfo pty f+ | otherwise = Apply NoSpanInfo (prelFromFloat $ unpredType pty) $+ Literal NoSpanInfo predFloatType f dsLiteral pty (String cs) =- Left $ List pty $ map (Literal pty' . Char) cs+ Left $ List NoSpanInfo pty $ map (Literal NoSpanInfo pty' . Char) cs where pty' = predType $ elemType $ unpredType pty negateLiteral :: Literal -> Literal@@ -935,7 +961,8 @@ -- --------------------------------------------------------------------------- preludeFun :: [Type] -> Type -> String -> Expression PredType-preludeFun tys ty = Variable (predType $ foldr TypeArrow ty tys) . preludeIdent+preludeFun tys ty = Variable NoSpanInfo (predType $ foldr TypeArrow ty tys)+ . preludeIdent preludeIdent :: String -> QualIdent preludeIdent = qualifyWith preludeMIdent . mkIdent@@ -1006,10 +1033,10 @@ e1 & e2 = apply (preludeFun [boolType, boolType] boolType "&") [e1, e2] truePat :: Pattern PredType-truePat = ConstructorPattern predBoolType qTrueId []+truePat = ConstructorPattern NoSpanInfo predBoolType qTrueId [] falsePat :: Pattern PredType-falsePat = ConstructorPattern predBoolType qFalseId []+falsePat = ConstructorPattern NoSpanInfo predBoolType qFalseId [] -- --------------------------------------------------------------------------- -- Auxiliary definitions@@ -1034,7 +1061,8 @@ applyConstr :: PredType -> QualIdent -> [Type] -> [Expression PredType] -> Expression PredType applyConstr pty c tys =- apply (Constructor (predType (foldr TypeArrow (unpredType pty) tys)) c)+ apply (Constructor NoSpanInfo+ (predType (foldr TypeArrow (unpredType pty) tys)) c) -- The function 'instType' instantiates the universally quantified -- type variables of a type scheme with fresh type variables. Since this
src/Transformations/Dictionary.hs view
@@ -36,6 +36,7 @@ import Curry.Base.Ident import Curry.Base.Position+import Curry.Base.SpanInfo import Curry.Syntax import Base.CurryTypes@@ -72,7 +73,7 @@ insertDicts :: InterfaceEnv -> TCEnv -> ValueEnv -> ClassEnv -> InstEnv -> OpPrecEnv -> Module PredType -> (Module Type, InterfaceEnv, TCEnv, ValueEnv, OpPrecEnv)-insertDicts intfEnv tcEnv vEnv clsEnv inEnv pEnv mdl@(Module _ m _ _ _) =+insertDicts intfEnv tcEnv vEnv clsEnv inEnv pEnv mdl@(Module _ _ m _ _ _) = (mdl', intfEnv', tcEnv', vEnv', pEnv') where initState = DTState m tcEnv vEnv clsEnv inEnv pEnv emptyAugEnv emptyDictEnv emptySpEnv 1@@ -212,13 +213,13 @@ augment :: a PredType -> DTM (a PredType) instance Augment Module where- augment (Module ps m es is ds) = do+ augment (Module spi ps m es is ds) = do augEnv <- initAugEnv <$> getValueEnv setAugEnv augEnv modifyValueEnv $ augmentValues modifyTyConsEnv $ augmentTypes modifyInstEnv $ augmentInstances augEnv- Module ps m es is <$> mapM (augmentDecl Nothing) ds+ Module spi ps m es is <$> mapM (augmentDecl Nothing) ds -- The first parameter of the functions 'augmentDecl', 'augmentEquation' and -- 'augmentLhs' determines whether we have to unrename the function identifiers@@ -263,11 +264,12 @@ Equation p <$> augmentLhs mm lhs <*> augment rhs augmentLhs :: Maybe ModuleIdent -> Lhs PredType -> DTM (Lhs PredType)-augmentLhs mm lhs@(FunLhs f ts) = do+augmentLhs mm lhs@(FunLhs spi f ts) = do m <- maybe getModuleIdent return mm augEnv <- getAugEnv if isAugmented augEnv (qualifyWith m $ unRenameIdentIf (isJust mm) f)- then return $ FunLhs f $ ConstructorPattern predUnitType qUnitId [] : ts+ then return $ FunLhs spi f+ $ ConstructorPattern NoSpanInfo predUnitType qUnitId [] : ts else return lhs augmentLhs _ lhs = internalError $ "Dictionary.augmentLhs" ++ show lhs@@ -278,21 +280,23 @@ internalError $ "Dictionary.augment: " ++ show rhs instance Augment Expression where- augment l@(Literal _ _) = return l- augment v@(Variable pty v') = do+ augment l@(Literal _ _ _) = return l+ augment v@(Variable _ pty v') = do augEnv <- getAugEnv return $ if isAugmented augEnv v'- then apply (Variable (augmentPredType pty) v')- [Constructor predUnitType qUnitId]+ then apply (Variable NoSpanInfo (augmentPredType pty) v')+ [Constructor NoSpanInfo predUnitType qUnitId] else v- augment c@(Constructor _ _) = return c- augment (Typed e qty) = flip Typed qty <$> augment e- augment (Apply e1 e2) = Apply <$> augment e1 <*> augment e2- augment (Lambda ts e) = Lambda ts <$> augment e- augment (Let ds e) =- Let <$> mapM (augmentDecl Nothing) ds <*> augment e- augment (Case ct e as) = Case ct <$> augment e <*> mapM augment as- augment e = internalError $ "Dictionary.augment: " ++ show e+ augment c@(Constructor _ _ _) = return c+ augment (Typed spi e qty) = flip (Typed spi) qty <$> augment e+ augment (Apply spi e1 e2) = Apply spi <$> augment e1 <*> augment e2+ augment (Lambda spi ts e) = Lambda spi ts <$> augment e+ augment (Let spi ds e) =+ Let spi <$> mapM (augmentDecl Nothing) ds <*> augment e+ augment (Case spi ct e as) =+ Case spi ct <$> augment e <*> mapM augment as+ augment e =+ internalError $ "Dictionary.augment: " ++ show e instance Augment Alt where augment (Alt p t rhs) = Alt p t <$> augment rhs@@ -304,10 +308,11 @@ augmentType = TypeArrow unitType augmentQualTypeExpr :: QualTypeExpr -> QualTypeExpr-augmentQualTypeExpr (QualTypeExpr cx ty) = QualTypeExpr cx $ augmentTypeExpr ty+augmentQualTypeExpr (QualTypeExpr spi cx ty) =+ QualTypeExpr spi cx $ augmentTypeExpr ty augmentTypeExpr :: TypeExpr -> TypeExpr-augmentTypeExpr = ArrowType $ ConstructorType qUnitId+augmentTypeExpr = ArrowType NoSpanInfo $ ConstructorType NoSpanInfo qUnitId -- ----------------------------------------------------------------------------- -- Lifting class and instance declarations@@ -324,7 +329,7 @@ liftClassDecls (qualifyWith m cls) tv ds liftDecls (InstanceDecl _ cx cls ty ds) = do clsEnv <- getClassEnv- let PredType ps ty' = toPredType [] $ QualTypeExpr cx ty+ let PredType ps ty' = toPredType [] $ QualTypeExpr NoSpanInfo cx ty ps' = minPredSet clsEnv ps liftInstanceDecls ps' cls ty' ds liftDecls d = return [d]@@ -364,17 +369,18 @@ createClassDictDecl :: QualIdent -> Ident -> [Decl a] -> DTM (Decl a) createClassDictDecl cls tv ds = do c <- createClassDictConstrDecl cls tv ds- return $ DataDecl NoPos (dictTypeId cls) [tv] [c] []+ return $ DataDecl NoSpanInfo (dictTypeId cls) [tv] [c] [] createClassDictConstrDecl :: QualIdent -> Ident -> [Decl a] -> DTM ConstrDecl createClassDictConstrDecl cls tv ds = do clsEnv <- getClassEnv let sclss = superClasses cls clsEnv- cx = [Constraint scls (VariableType tv) | scls <- sclss]- tvs = tv : filter (unRenameIdent tv /=) identSupply- mtys = map (fromType tvs . generalizeMethodType . transformMethodPredType)- [toMethodType cls tv qty | TypeSig _ fs qty <- ds, _ <- fs]- return $ ConstrDecl NoPos [] cx (dictConstrId cls) mtys+ cx = [Constraint NoSpanInfo scls (VariableType NoSpanInfo tv)+ | scls <- sclss]+ tvs = tv : filter (unRenameIdent tv /=) identSupply+ mtys = map (fromType tvs . generalizeMethodType . transformMethodPredType)+ [toMethodType cls tv qty | TypeSig _ fs qty <- ds, _ <- fs]+ return $ ConstrDecl NoSpanInfo [] cx (dictConstrId cls) mtys classDictConstrPredType :: ValueEnv -> ClassEnv -> QualIdent -> PredType classDictConstrPredType vEnv clsEnv cls = PredType ps $ foldr TypeArrow ty mtys@@ -388,7 +394,7 @@ createInstDictDecl :: PredSet -> QualIdent -> Type -> DTM (Decl PredType) createInstDictDecl ps cls ty = do pty <- PredType ps . arrowBase <$> getInstDictConstrType cls ty- funDecl NoPos pty (instFunId cls ty) [] <$> createInstDictExpr cls ty+ funDecl NoSpanInfo pty (instFunId cls ty) [] <$> createInstDictExpr cls ty createInstDictExpr :: QualIdent -> Type -> DTM (Expression PredType) createInstDictExpr cls ty = do@@ -396,8 +402,8 @@ m <- getModuleIdent clsEnv <- getClassEnv let fs = map (qImplMethodId m cls ty) $ classMethods cls clsEnv- return $ apply (Constructor (predType ty') (qDictConstrId cls))- (zipWith (Variable . predType) (arrowArgs ty') fs)+ return $ apply (Constructor NoSpanInfo (predType ty') (qDictConstrId cls))+ (zipWith (Variable NoSpanInfo . predType) (arrowArgs ty') fs) getInstDictConstrType :: QualIdent -> Type -> DTM Type getInstDictConstrType cls ty = do@@ -413,10 +419,12 @@ defaultClassMethodDecl cls f = do pty@(PredType _ ty) <- getClassMethodType cls f augEnv <- getAugEnv- let pats = if isAugmented augEnv (qualifyLike cls f)- then [ConstructorPattern predUnitType qUnitId []]+ let augmented = isAugmented augEnv (qualifyLike cls f)+ pats = if augmented+ then [ConstructorPattern NoSpanInfo predUnitType qUnitId []] else []- return $ funDecl NoPos pty f pats $ preludeError (instType ty) $+ ty' = if augmented then arrowBase ty else ty+ return $ funDecl NoSpanInfo pty f pats $ preludeError (instType ty') $ "No instance or default method for class operation " ++ escName f getClassMethodType :: QualIdent -> Ident -> DTM PredType@@ -438,8 +446,8 @@ defaultInstMethodDecl ps cls ty f = do vEnv <- getValueEnv let pty@(PredType _ ty') = instMethodType vEnv ps cls ty f- return $ funDecl NoPos pty f [] $- Variable (predType $ instType ty') (qDefaultMethodId cls f)+ return $ funDecl NoSpanInfo pty f [] $+ Variable NoSpanInfo (predType $ instType ty') (qDefaultMethodId cls f) -- Returns the type for a given instance's method of a given class. To this -- end, the class method's type is stripped of its first predicate (which is@@ -463,7 +471,7 @@ renameDecl :: Ident -> Decl a -> Decl a renameDecl f (FunctionDecl p a _ eqs) = FunctionDecl p a f $ map renameEq eqs where renameEq (Equation p' lhs rhs) = Equation p' (renameLhs lhs) rhs- renameLhs (FunLhs _ ts) = FunLhs f ts+ renameLhs (FunLhs _ _ ts) = FunLhs NoSpanInfo f ts renameLhs _ = internalError "Dictionary.renameDecl.renameLhs" renameDecl _ _ = internalError "Dictionary.renameDecl" @@ -528,12 +536,13 @@ createStubDecl :: Pattern a -> a -> Ident -> (a, Ident) -> [(a, Ident)] -> Decl a-createStubDecl t a f v us = FunctionDecl NoPos a f [createStubEquation t f v us]+createStubDecl t a f v us =+ FunctionDecl NoSpanInfo a f [createStubEquation t f v us] createStubEquation :: Pattern a -> Ident -> (a, Ident) -> [(a, Ident)] -> Equation a createStubEquation t f v us =- mkEquation NoPos f (t : map (uncurry VariablePattern) us) $+ mkEquation NoSpanInfo f (t : map (uncurry (VariablePattern NoSpanInfo)) us) $ apply (uncurry mkVar v) (map (uncurry mkVar) us) superDictStubType :: QualIdent -> QualIdent -> Type -> Type@@ -719,15 +728,15 @@ classExports :: ModuleIdent -> ClassEnv -> Ident -> [Export] classExports m clsEnv cls =- ExportTypeWith (qDictTypeId qcls) [dictConstrId qcls] :- map (Export . qSuperDictStubId qcls) (superClasses qcls clsEnv) ++- map (Export . qDefaultMethodId qcls) (classMethods qcls clsEnv)+ ExportTypeWith NoSpanInfo (qDictTypeId qcls) [dictConstrId qcls] :+ map (Export NoSpanInfo . qSuperDictStubId qcls) (superClasses qcls clsEnv) +++ map (Export NoSpanInfo . qDefaultMethodId qcls) (classMethods qcls clsEnv) where qcls = qualifyWith m cls instExports :: ModuleIdent -> ClassEnv -> QualIdent -> Type -> [Export] instExports m clsEnv cls ty =- Export (qInstFunId m cls ty) :- map (Export . qImplMethodId m cls ty) (classMethods cls clsEnv)+ Export NoSpanInfo (qInstFunId m cls ty) :+ map (Export NoSpanInfo . qImplMethodId m cls ty) (classMethods cls clsEnv) -- ----------------------------------------------------------------------------- -- Transforming the module@@ -742,7 +751,7 @@ dictTrans :: a PredType -> DTM (a Type) instance DictTrans Module where- dictTrans (Module ps m es is ds) = do+ dictTrans (Module spi ps m es is ds) = do liftedDs <- concatMapM liftDecls ds stubDs <- concatMapM createStubs ds tcEnv <- getTyConsEnv@@ -755,7 +764,7 @@ modifyValueEnv $ dictTransValues modifyTyConsEnv $ dictTransTypes dictEs <- addExports es <$> concatMapM dictExports ds- return $ Module ps m dictEs is $ transDs ++ stubDs+ return $ Module spi ps m dictEs is $ transDs ++ stubDs -- We use and transform the type from the type constructor environment for -- transforming a constructor declaration as it contains the reduced and@@ -780,8 +789,8 @@ dictTrans (FunctionDecl p pty f eqs) = FunctionDecl p (transformPredType pty) f <$> mapM dictTrans eqs dictTrans (PatternDecl p t rhs) = case t of- VariablePattern pty@(PredType ps _) v | not (Set.null ps) ->- dictTrans $ FunctionDecl p pty v [Equation p (FunLhs v []) rhs]+ VariablePattern _ pty@(PredType ps _) v | not (Set.null ps) ->+ dictTrans $ FunctionDecl p pty v [Equation p (FunLhs NoSpanInfo v []) rhs] _ -> withLocalDictEnv $ PatternDecl p <$> dictTrans t <*> dictTrans rhs dictTrans d@(FreeDecl _ _) = return $ fmap unpredType d dictTrans d@(ExternalDecl _ _) = return $ fmap unpredType d@@ -798,13 +807,13 @@ dictTransConstrDecl _ d _ = internalError $ "Dictionary.dictTrans: " ++ show d instance DictTrans Equation where- dictTrans (Equation p (FunLhs f ts) rhs) = withLocalValueEnv $ do+ dictTrans (Equation p (FunLhs _ f ts) rhs) = withLocalValueEnv $ do m <- getModuleIdent pls <- matchPredList (varType m f) $ foldr (TypeArrow . typeOf) (typeOf rhs) ts ts' <- addDictArgs pls ts modifyValueEnv $ bindPatterns ts'- Equation p (FunLhs f ts') <$> dictTrans rhs+ Equation p (FunLhs NoSpanInfo f ts') <$> dictTrans rhs dictTrans eq = internalError $ "Dictionary.dictTrans: " ++ show eq @@ -814,43 +823,45 @@ internalError $ "Dictionary.dictTrans: " ++ show rhs instance DictTrans Pattern where- dictTrans (LiteralPattern pty l) =- return $ LiteralPattern (unpredType pty) l- dictTrans (VariablePattern pty v) =- return $ VariablePattern (unpredType pty) v- dictTrans (ConstructorPattern pty c ts) = do+ dictTrans (LiteralPattern _ pty l) =+ return $ LiteralPattern NoSpanInfo (unpredType pty) l+ dictTrans (VariablePattern _ pty v) =+ return $ VariablePattern NoSpanInfo (unpredType pty) v+ dictTrans (ConstructorPattern _ pty c ts) = do pls <- matchPredList (conType c) $ foldr (TypeArrow . typeOf) (unpredType pty) ts- ConstructorPattern (unpredType pty) c <$> addDictArgs pls ts- dictTrans (AsPattern v t) = AsPattern v <$> dictTrans t- dictTrans t =+ ConstructorPattern NoSpanInfo (unpredType pty) c <$> addDictArgs pls ts+ dictTrans (AsPattern _ v t) =+ AsPattern NoSpanInfo v <$> dictTrans t+ dictTrans t = internalError $ "Dictionary.dictTrans: " ++ show t instance DictTrans Expression where- dictTrans (Literal pty l) = return $ Literal (unpredType pty) l- dictTrans (Variable pty v) = do+ dictTrans (Literal _ pty l) =+ return $ Literal NoSpanInfo (unpredType pty) l+ dictTrans (Variable _ pty v) = do pls <- matchPredList (funType v) (unpredType pty) es <- mapM dictArg pls let ty = foldr (TypeArrow . typeOf) (unpredType pty) es- return $ apply (Variable ty v) es- dictTrans (Constructor pty c) = do+ return $ apply (Variable NoSpanInfo ty v) es+ dictTrans (Constructor _ pty c) = do pls <- matchPredList (conType c) (unpredType pty) es <- mapM dictArg pls let ty = foldr (TypeArrow . typeOf) (unpredType pty) es- return $ apply (Constructor ty c) es- dictTrans (Apply e1 e2) =- Apply <$> dictTrans e1 <*> dictTrans e2- dictTrans (Typed e qty) =- Typed <$> dictTrans e <*> dictTransQualTypeExpr qty- dictTrans (Lambda ts e) = withLocalValueEnv $ withLocalDictEnv $ do+ return $ apply (Constructor NoSpanInfo ty c) es+ dictTrans (Apply _ e1 e2) =+ Apply NoSpanInfo <$> dictTrans e1 <*> dictTrans e2+ dictTrans (Typed _ e qty) =+ Typed NoSpanInfo <$> dictTrans e <*> dictTransQualTypeExpr qty+ dictTrans (Lambda _ ts e) = withLocalValueEnv $ withLocalDictEnv $ do ts' <- mapM dictTrans ts modifyValueEnv $ bindPatterns ts'- Lambda ts' <$> dictTrans e- dictTrans (Let ds e) = withLocalValueEnv $ do+ Lambda NoSpanInfo ts' <$> dictTrans e+ dictTrans (Let _ ds e) = withLocalValueEnv $ do modifyValueEnv $ bindDecls ds- Let <$> mapM dictTrans ds <*> dictTrans e- dictTrans (Case ct e as) =- Case ct <$> dictTrans e <*> mapM dictTrans as+ Let NoSpanInfo <$> mapM dictTrans ds <*> dictTrans e+ dictTrans (Case _ ct e as) =+ Case NoSpanInfo ct <$> dictTrans e <*> mapM dictTrans as dictTrans e = internalError $ "Dictionary.dictTrans: " ++ show e @@ -860,7 +871,7 @@ -- TODO: Verify dictTransQualTypeExpr :: QualTypeExpr -> DTM QualTypeExpr-dictTransQualTypeExpr (QualTypeExpr _ ty) = return $ QualTypeExpr [] ty+dictTransQualTypeExpr (QualTypeExpr spi _ ty) = return $ QualTypeExpr spi [] ty instance DictTrans Alt where dictTrans (Alt p t rhs) = withLocalValueEnv $ withLocalDictEnv $ do@@ -873,16 +884,18 @@ dictVars <- mapM (freshVar "_#dict" . dictType) pls clsEnv <- getClassEnv modifyDictEnv $ (++) $ dicts clsEnv $ zip pls (map (uncurry mkVar) dictVars)- (++) (map (uncurry VariablePattern) dictVars) <$> mapM dictTrans ts+ (++) (map (uncurry (VariablePattern NoSpanInfo )) dictVars)+ <$> mapM dictTrans ts where dicts clsEnv vs | null vs = vs | otherwise = vs ++ dicts clsEnv (concatMap (superDicts clsEnv) vs) superDicts clsEnv (Pred cls ty, e) = map (superDict cls ty e) (superClasses cls clsEnv) superDict cls ty e scls =- (Pred scls ty, Apply (superDictExpr cls scls ty) e)+ (Pred scls ty, Apply NoSpanInfo (superDictExpr cls scls ty) e) superDictExpr cls scls ty =- Variable (superDictStubType cls scls ty) (qSuperDictStubId cls scls)+ Variable NoSpanInfo (superDictStubType cls scls ty)+ (qSuperDictStubId cls scls) -- The function 'dictArg' constructs the dictionary argument for a predicate -- from the predicates of a class method or an overloaded function. It checks@@ -901,7 +914,8 @@ instDict p = instPredList p >>= flip (uncurry instFunApp) p instFunApp :: ModuleIdent -> [Pred] -> Pred -> DTM (Expression Type)-instFunApp m pls p@(Pred cls ty) = apply (Variable ty' f) <$> mapM dictArg pls+instFunApp m pls p@(Pred cls ty) = apply (Variable NoSpanInfo ty' f)+ <$> mapM dictArg pls where f = qInstFunId m cls ty ty' = foldr1 TypeArrow $ map dictType $ pls ++ [p] @@ -978,11 +992,11 @@ specialize :: a Type -> DTM (a Type) instance Specialize Module where- specialize (Module ps m es is ds) = do+ specialize (Module spi ps m es is ds) = do clsEnv <- getClassEnv inEnv <- getInstEnv setSpEnv $ initSpEnv clsEnv inEnv- Module ps m es is <$> mapM specialize ds+ Module spi ps m es is <$> mapM specialize ds instance Specialize Decl where specialize (FunctionDecl p ty f eqs) =@@ -1002,33 +1016,33 @@ specialize e = specialize' e [] specialize' :: Expression Type -> [Expression Type] -> DTM (Expression Type)-specialize' l@(Literal _ _) es = return $ apply l es-specialize' v@(Variable _ v') es = do+specialize' l@(Literal _ _ _) es = return $ apply l es+specialize' v@(Variable _ _ v') es = do spEnv <- getSpEnv return $ case Map.lookup (v', f) spEnv of- Just f' -> apply (Variable ty' f') $ es'' ++ es'+ Just f' -> apply (Variable NoSpanInfo ty' f') $ es'' ++ es' Nothing -> apply v es where d:es' = es- (Variable _ f, es'') = unapply d []- ty' = foldr (TypeArrow . typeOf) (typeOf $ Apply v d) es''-specialize' c@(Constructor _ _) es = return $ apply c es-specialize' (Typed e qty) es = do+ (Variable _ _ f, es'') = unapply d []+ ty' = foldr (TypeArrow . typeOf) (typeOf $ Apply NoSpanInfo v d) es''+specialize' c@(Constructor _ _ _) es = return $ apply c es+specialize' (Typed _ e qty) es = do e' <- specialize e- return $ apply (Typed e' qty) es-specialize' (Apply e1 e2) es = do+ return $ apply (Typed NoSpanInfo e' qty) es+specialize' (Apply _ e1 e2) es = do e2' <- specialize e2 specialize' e1 $ e2' : es-specialize' (Lambda ts e) es = do+specialize' (Lambda _ ts e) es = do e' <- specialize e- return $ apply (Lambda ts e') es-specialize' (Let ds e) es = do+ return $ apply (Lambda NoSpanInfo ts e') es+specialize' (Let _ ds e) es = do ds' <- mapM specialize ds e' <- specialize e- return $ apply (Let ds' e') es-specialize' (Case ct e as) es = do+ return $ apply (Let NoSpanInfo ds' e') es+specialize' (Case _ ct e as) es = do e' <- specialize e as' <- mapM specialize as- return $ apply (Case ct e' as') es+ return $ apply (Case NoSpanInfo ct e' as') es specialize' e _ = internalError $ "Dictionary.specialize': " ++ show e @@ -1047,22 +1061,22 @@ -- transformation. cleanup :: Module a -> DTM (Module a)-cleanup (Module ps m es is ds) = do+cleanup (Module spi ps m es is ds) = do cleanedEs <- traverse cleanupExportSpec es cleanedDs <- concatMapM cleanupInfixDecl ds cleanupTyConsEnv cleanupPrecEnv- return $ Module ps m cleanedEs is cleanedDs+ return $ Module spi ps m cleanedEs is cleanedDs cleanupExportSpec :: ExportSpec -> DTM ExportSpec cleanupExportSpec (Exporting p es) = Exporting p <$> concatMapM cleanupExport es cleanupExport :: Export -> DTM [Export]-cleanupExport e@(Export _) = return [e]-cleanupExport e@(ExportTypeWith tc cs) = do+cleanupExport e@(Export _ _) = return [e]+cleanupExport e@(ExportTypeWith spi tc cs) = do tcEnv <- getTyConsEnv case qualLookupTypeInfo tc tcEnv of- [TypeClass _ _ _] -> return $ map (Export . qualifyLike tc) cs+ [TypeClass _ _ _] -> return $ map (Export spi . qualifyLike tc) cs _ -> return [e] cleanupExport e = internalError $ "Dictionary.cleanupExport: " ++ show e@@ -1153,7 +1167,7 @@ dictTransIConstrDecl m tvs (RecordDecl p evs cx c fs) = RecordDecl p evs [] c $ map toFieldDecl (transformIContext m (tvs ++ evs) cx) ++ fs- where toFieldDecl = FieldDecl NoPos [anonId]+ where toFieldDecl = FieldDecl NoSpanInfo [anonId] transformIContext :: ModuleIdent -> [Ident] -> Context -> [TypeExpr] transformIContext m tvs cx =@@ -1170,7 +1184,7 @@ -> ConstrDecl iConstrDeclFromDataConstructor m vEnv c = case qualLookupValue c vEnv of [DataConstructor _ _ _ (ForAllExist n n' pty)] ->- ConstrDecl NoPos evs [] (unqualify c) tys+ ConstrDecl NoSpanInfo evs [] (unqualify c) tys where evs = take n' $ drop n identSupply tys = map (fromQualType m identSupply) $ arrowArgs $ unpredType pty _ -> internalError $ "Dictionary.iConstrDeclFromDataConstructor: " ++ show c@@ -1281,13 +1295,16 @@ preludeError :: Type -> String -> Expression PredType preludeError a =- Apply (Variable (predType (TypeArrow stringType a)) qErrorId) . stringExpr+ Apply NoSpanInfo (Variable NoSpanInfo+ (predType (TypeArrow stringType a)) qErrorId) . stringExpr stringExpr :: String -> Expression PredType-stringExpr = foldr (consExpr . Literal (predType charType) . Char) nilExpr+stringExpr = foldr (consExpr . Literal NoSpanInfo (predType charType) . Char)+ nilExpr where- nilExpr = Constructor (predType stringType) qNilId- consExpr = Apply . Apply (Constructor (predType $ consType charType) qConsId)+ nilExpr = Constructor NoSpanInfo (predType stringType) qNilId+ consExpr = (Apply NoSpanInfo) . (Apply NoSpanInfo)+ (Constructor NoSpanInfo (predType $ consType charType) qConsId) -- The function 'varType' is able to lookup both local and global identifiers. -- Since the environments have been qualified before, global declarations are
src/Transformations/Lift.hs view
@@ -28,9 +28,11 @@ import qualified Control.Monad.State as S (State, runState, gets, modify) import Data.List import qualified Data.Map as Map (Map, empty, insert, lookup)-import Data.Maybe (catMaybes, fromJust)+import Data.Maybe (mapMaybe, fromJust) import qualified Data.Set as Set (fromList, toList, unions)+ import Curry.Base.Ident+import Curry.Base.SpanInfo import Curry.Syntax import Base.AnnotExpr@@ -45,11 +47,11 @@ import Env.Value lift :: ValueEnv -> Module Type -> (Module Type, ValueEnv)-lift vEnv (Module ps m es is ds) = (lifted, valueEnv s')+lift vEnv (Module spi ps m es is ds) = (lifted, valueEnv s') where (ds', s') = S.runState (mapM (absDecl "" []) ds) initState initState = LiftState m vEnv Map.empty- lifted = Module ps m es is $ concatMap liftFunDecl ds'+ lifted = Module spi ps m es is $ concatMap liftFunDecl ds' -- ----------------------------------------------------------------------------- -- Abstraction@@ -105,7 +107,7 @@ absDecl _ _ d = return d absEquation :: [Ident] -> Equation Type -> LiftM (Equation Type)-absEquation lvs (Equation p lhs@(FunLhs f ts) rhs) =+absEquation lvs (Equation p lhs@(FunLhs _ f ts) rhs) = Equation p lhs <$> absRhs (idName f ++ ".") lvs' rhs where lvs' = lvs ++ bv ts absEquation _ _ = error "Lift.absEquation: no pattern match"@@ -176,7 +178,7 @@ absFunDecls pre lvs [] vds e = do vds' <- mapM (absDecl pre lvs) vds e' <- absExpr pre lvs e- return (Let vds' e')+ return (Let NoSpanInfo vds' e') absFunDecls pre lvs (fds:fdss) vds e = do m <- getModuleIdent env <- getAbstractEnv@@ -185,9 +187,9 @@ fs = bv fds -- function types ftys = map extractFty fds- extractFty (FunctionDecl _ _ f ((Equation _ (FunLhs _ ts) rhs):_)) =+ extractFty (FunctionDecl _ _ f (Equation _ (FunLhs _ _ ts) rhs : _)) = (f, foldr TypeArrow (typeOf rhs) $ map typeOf ts)- extractFty _ =+ extractFty _ = internalError "Lift.absFunDecls.extractFty" -- typed free variables on the right-hand sides fvsRhs = Set.unions@@ -234,7 +236,7 @@ fds' <- mapM (absFunDecl pre fvs lvs) [d | d <- fds, any (`elem` fs') (bv d)] -- abstract remaining declarations e' <- absFunDecls pre lvs fdss vds e- return (Let fds' e')+ return (Let NoSpanInfo fds' e') -- When the free variables of a function are abstracted, the type of the -- function must be changed as well.@@ -249,14 +251,15 @@ return $ FunctionDecl p ty'' f' eqs'' where f' = liftIdent pre f ty' = foldr TypeArrow (typeOf rhs') (map typeOf ts')- where Equation _ (FunLhs _ ts') rhs' = head eqs'+ where Equation _ (FunLhs _ _ ts') rhs' = head eqs' ty'' = genType ty' eqs' = map addVars eqs genType ty''' = subst (foldr2 bindSubst idSubst tvs tvs') ty''' where tvs = nub (typeVars ty''') tvs' = map TypeVariable [0 ..]- addVars (Equation p' (FunLhs _ ts) rhs) =- Equation p' (FunLhs f' (map (uncurry VariablePattern) fvs ++ ts)) rhs+ addVars (Equation p' (FunLhs _ _ ts) rhs) =+ Equation p' (FunLhs NoSpanInfo+ f' (map (uncurry (VariablePattern NoSpanInfo)) fvs ++ ts)) rhs addVars _ = error "Lift.absFunDecl.addVars: no pattern match" absFunDecl pre _ _ (ExternalDecl p vs) = ExternalDecl p <$> mapM (absVar pre) vs absFunDecl _ _ _ _ = error "Lift.absFunDecl: no pattern match"@@ -270,8 +273,8 @@ where f' = liftIdent pre f absExpr :: String -> [Ident] -> Expression Type -> LiftM (Expression Type)-absExpr _ _ l@(Literal _ _) = return l-absExpr pre lvs var@(Variable ty v)+absExpr _ _ l@(Literal _ _ _) = return l+absExpr pre lvs var@(Variable _ ty v) | isQualified v = return var | otherwise = do getAbstractEnv >>= \env -> case Map.lookup (unqualify v) env of@@ -285,17 +288,18 @@ -- !!! to obtain a type substitution that can then be applied to !!! -- !!! the type annotations in the replacement expression. !!! -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!- absType ty' (Variable _ v') = Variable ty' v'- absType ty' (Apply e1 e2) =- Apply (absType (TypeArrow (typeOf e2) ty') e1) e2+ absType ty' (Variable spi _ v') = Variable spi ty' v'+ absType ty' (Apply spi e1 e2) =+ Apply spi (absType (TypeArrow (typeOf e2) ty') e1) e2 absType _ _ = internalError "Lift.absExpr.absType"-absExpr _ _ c@(Constructor _ _) = return c-absExpr pre lvs (Apply e1 e2) = Apply <$> absExpr pre lvs e1+absExpr _ _ c@(Constructor _ _ _) = return c+absExpr pre lvs (Apply spi e1 e2) = Apply spi <$> absExpr pre lvs e1 <*> absExpr pre lvs e2-absExpr pre lvs (Let ds e) = absDeclGroup pre lvs ds e-absExpr pre lvs (Case ct e bs) = Case ct <$> absExpr pre lvs e- <*> mapM (absAlt pre lvs) bs-absExpr pre lvs (Typed e ty) = flip Typed ty <$> absExpr pre lvs e+absExpr pre lvs (Let _ ds e) = absDeclGroup pre lvs ds e+absExpr pre lvs (Case spi ct e bs) =+ Case spi ct <$> absExpr pre lvs e <*> mapM (absAlt pre lvs) bs+absExpr pre lvs (Typed spi e ty) =+ flip (Typed spi) ty <$> absExpr pre lvs e absExpr _ _ e = internalError $ "Lift.absExpr: " ++ show e absAlt :: String -> [Ident] -> Alt Type -> LiftM (Alt Type)@@ -335,19 +339,20 @@ (vds', dss') = unzip $ map liftVarDecl vds liftExpr :: Eq a => Expression a -> (Expression a, [Decl a])-liftExpr l@(Literal _ _) = (l, [])-liftExpr v@(Variable _ _) = (v, [])-liftExpr c@(Constructor _ _) = (c, [])-liftExpr (Apply e1 e2) = (Apply e1' e2', ds1 ++ ds2)+liftExpr l@(Literal _ _ _) = (l, [])+liftExpr v@(Variable _ _ _) = (v, [])+liftExpr c@(Constructor _ _ _) = (c, [])+liftExpr (Apply spi e1 e2) = (Apply spi e1' e2', ds1 ++ ds2) where (e1', ds1) = liftExpr e1 (e2', ds2) = liftExpr e2-liftExpr (Let ds e) = (mkLet ds' e', ds1 ++ ds2)+liftExpr (Let _ ds e) = (mkLet ds' e', ds1 ++ ds2) where (ds', ds1) = liftDeclGroup ds (e' , ds2) = liftExpr e-liftExpr (Case ct e alts) = (Case ct e' alts', concat $ ds' : dss')+liftExpr (Case spi ct e alts) = (Case spi ct e' alts', concat $ ds' : dss') where (e' , ds' ) = liftExpr e (alts', dss') = unzip $ map liftAlt alts-liftExpr (Typed e ty) = (Typed e' ty, ds) where (e', ds) = liftExpr e+liftExpr (Typed spi e ty) =+ (Typed spi e' ty, ds) where (e', ds) = liftExpr e liftExpr _ = internalError "Lift.liftExpr" liftAlt :: Eq a => Alt a -> (Alt a, [Decl a])@@ -374,16 +379,16 @@ where (rm, lhs') = renameLhs lhs renameLhs :: Eq a => Lhs a -> (RenameMap a, Lhs a)-renameLhs (FunLhs f ts) = (rm, FunLhs f ts')+renameLhs (FunLhs spi f ts) = (rm, FunLhs spi f ts') where (rm, ts') = foldr renamePattern ([], []) ts renameLhs _ = error "Lift.renameLhs" renamePattern :: Eq a => Pattern a -> (RenameMap a, [Pattern a]) -> (RenameMap a, [Pattern a])-renamePattern (VariablePattern a v) (rm, ts)+renamePattern (VariablePattern spi a v) (rm, ts) | v `elem` varPatNames ts = let v' = updIdentName (++ ("." ++ show (length rm))) v- in (((a, v), v') : rm, VariablePattern a v' : ts)+ in (((a, v), v') : rm, VariablePattern spi a v' : ts) renamePattern t (rm, ts) = (rm, t : ts) renameRhs :: Eq a => RenameMap a -> Rhs a -> Rhs a@@ -391,19 +396,20 @@ renameRhs _ _ = error "Lift.renameRhs" renameExpr :: Eq a => RenameMap a -> Expression a -> Expression a-renameExpr _ l@(Literal _ _) = l-renameExpr rm v@(Variable a v')+renameExpr _ l@(Literal _ _ _) = l+renameExpr rm v@(Variable spi a v') | isQualified v' = v | otherwise = case lookup (a, unqualify v') rm of- Just v'' -> Variable a (qualify v'')+ Just v'' -> Variable spi a (qualify v'') _ -> v-renameExpr _ c@(Constructor _ _) = c-renameExpr rm (Typed e ty) = Typed (renameExpr rm e) ty-renameExpr rm (Apply e1 e2) = Apply (renameExpr rm e1) (renameExpr rm e2)-renameExpr rm (Let ds e) =- Let (map (renameDecl rm) ds) (renameExpr rm e)-renameExpr rm (Case ct e alts) =- Case ct (renameExpr rm e) (map (renameAlt rm) alts)+renameExpr _ c@(Constructor _ _ _) = c+renameExpr rm (Typed spi e ty) = Typed spi (renameExpr rm e) ty+renameExpr rm (Apply spi e1 e2) =+ Apply spi (renameExpr rm e1) (renameExpr rm e2)+renameExpr rm (Let spi ds e) =+ Let spi (map (renameDecl rm) ds) (renameExpr rm e)+renameExpr rm (Case spi ct e alts) =+ Case spi ct (renameExpr rm e) (map (renameAlt rm) alts) renameExpr _ _ = error "Lift.renameExpr" renameDecl :: Eq a => RenameMap a -> Decl a -> Decl a@@ -423,16 +429,16 @@ isFunDecl _ = False mkFun :: ModuleIdent -> String -> a -> Ident -> Expression a-mkFun m pre a = Variable a . qualifyWith m . liftIdent pre+mkFun m pre a = Variable NoSpanInfo a . qualifyWith m . liftIdent pre liftIdent :: String -> Ident -> Ident liftIdent prefix x = renameIdent (mkIdent $ prefix ++ showIdent x) $ idUnique x varPatNames :: [Pattern a] -> [Ident]-varPatNames = catMaybes . map varPatName+varPatNames = mapMaybe varPatName varPatName :: Pattern a -> Maybe Ident-varPatName (VariablePattern _ i) = Just i+varPatName (VariablePattern _ _ i) = Just i varPatName _ = Nothing dummyType :: Type
src/Transformations/Newtypes.hs view
@@ -42,7 +42,7 @@ nt = mapM nt instance Show a => Newtypes (Module a) where- nt (Module ps m es is ds) = Module ps m es is <$> mapM nt ds+ nt (Module spi ps m es is ds) = Module spi ps m es is <$> mapM nt ds instance Show a => Newtypes (Decl a) where nt d@(InfixDecl _ _ _ _) = return d@@ -61,7 +61,7 @@ nt (Equation p lhs rhs) = Equation p <$> nt lhs <*> nt rhs instance Show a => Newtypes (Lhs a) where- nt (FunLhs f ts) = FunLhs f <$> nt ts+ nt (FunLhs spi f ts) = FunLhs spi f <$> nt ts nt lhs = internalError $ "Newtypes.Newtypes.nt: unexpected left-hand-side: " ++ show lhs @@ -71,32 +71,32 @@ "Newtypes.Newtypes.nt: unexpected right-hand-side: " ++ show rhs instance Show a => Newtypes (Pattern a) where- nt t@(LiteralPattern _ _) = return t- nt t@(VariablePattern _ _) = return t- nt (ConstructorPattern a c ts) = case ts of+ nt t@(LiteralPattern _ _ _) = return t+ nt t@(VariablePattern _ _ _) = return t+ nt (ConstructorPattern spi a c ts) = case ts of [t] -> do isNc <- isNewtypeConstr c if isNc then nt t- else ConstructorPattern a c <$> ((: []) <$> nt t)- _ -> ConstructorPattern a c <$> mapM nt ts- nt (AsPattern v t) = AsPattern v <$> nt t- nt t = internalError $+ else ConstructorPattern spi a c <$> ((: []) <$> nt t)+ _ -> ConstructorPattern spi a c <$> mapM nt ts+ nt (AsPattern spi v t) = AsPattern spi v <$> nt t+ nt t = internalError $ "Newtypes.Newtypes.nt: unexpected pattern: " ++ show t instance Show a => Newtypes (Expression a) where- nt e@(Literal _ _) = return e- nt e@(Variable _ _) = return e- nt (Constructor a c) = do+ nt e@(Literal _ _ _) = return e+ nt e@(Variable _ _ _) = return e+ nt (Constructor spi a c) = do isNc <- isNewtypeConstr c- return $ if isNc then Variable a qIdId else Constructor a c- nt (Apply e1 e2) = case e1 of- Constructor _ c -> do+ return $ if isNc then Variable spi a qIdId else Constructor spi a c+ nt (Apply spi e1 e2) = case e1 of+ Constructor _ _ c -> do isNc <- isNewtypeConstr c- if isNc then nt e2 else Apply <$> nt e1 <*> nt e2- _ -> Apply <$> nt e1 <*> nt e2- nt (Case ct e as) = Case ct <$> nt e <*> mapM nt as- nt (Let ds e) = Let <$> nt ds <*> nt e- nt (Typed e qty) = flip Typed qty <$> nt e+ if isNc then nt e2 else Apply spi <$> nt e1 <*> nt e2+ _ -> Apply spi <$> nt e1 <*> nt e2+ nt (Case spi ct e as) = Case spi ct <$> nt e <*> mapM nt as+ nt (Let spi ds e) = Let spi <$> nt ds <*> nt e+ nt (Typed spi e qty) = flip (Typed spi) qty <$> nt e nt e = internalError $ "Newtypes.Newtypes.nt: unexpected expression: " ++ show e
src/Transformations/Qual.hs view
@@ -51,20 +51,20 @@ qual m tcEnv tyEnv mdl = R.runReader (qModule mdl) (QualEnv m tcEnv tyEnv) qModule :: Qual (Module a)-qModule (Module ps m es is ds) = do+qModule (Module spi ps m es is ds) = do es' <- qExportSpec es ds' <- mapM qDecl ds- return (Module ps m es' is ds')+ return (Module spi ps m es' is ds') qExportSpec :: Qual (Maybe ExportSpec) qExportSpec Nothing = return Nothing qExportSpec (Just (Exporting p es)) = (Just . Exporting p) <$> mapM qExport es qExport :: Qual Export-qExport (Export x) = Export <$> qIdent x-qExport (ExportTypeWith t cs) = flip ExportTypeWith cs <$> qConstr t-qExport (ExportTypeAll t) = ExportTypeAll <$> qConstr t-qExport m@(ExportModule _) = return m+qExport (Export spi x) = Export spi <$> qIdent x+qExport (ExportTypeWith spi t cs) = flip (ExportTypeWith spi) cs <$> qConstr t+qExport (ExportTypeAll spi t) = ExportTypeAll spi <$> qConstr t+qExport m@(ExportModule _ _) = return m qDecl :: Qual (Decl a) qDecl i@(InfixDecl _ _ _ _) = return i@@ -103,100 +103,112 @@ qFieldDecl (FieldDecl p fs ty) = FieldDecl p fs <$> qTypeExpr ty qConstraint :: Qual Constraint-qConstraint (Constraint cls ty) = Constraint <$> qClass cls <*> qTypeExpr ty+qConstraint (Constraint spi cls ty) =+ Constraint spi <$> qClass cls <*> qTypeExpr ty qContext :: Qual Context qContext = mapM qConstraint qTypeExpr :: Qual TypeExpr-qTypeExpr (ConstructorType c) = ConstructorType <$> qConstr c-qTypeExpr (ApplyType ty1 ty2) = ApplyType <$> qTypeExpr ty1+qTypeExpr (ConstructorType spi c) = ConstructorType spi <$> qConstr c+qTypeExpr (ApplyType spi ty1 ty2) = ApplyType spi <$> qTypeExpr ty1 <*> qTypeExpr ty2-qTypeExpr v@(VariableType _) = return v-qTypeExpr (TupleType tys) = TupleType <$> mapM qTypeExpr tys-qTypeExpr (ListType ty) = ListType <$> qTypeExpr ty-qTypeExpr (ArrowType ty1 ty2) = ArrowType <$> qTypeExpr ty1+qTypeExpr v@(VariableType _ _) = return v+qTypeExpr (TupleType spi tys) = TupleType spi <$> mapM qTypeExpr tys+qTypeExpr (ListType spi ty) = ListType spi <$> qTypeExpr ty+qTypeExpr (ArrowType spi ty1 ty2) = ArrowType spi <$> qTypeExpr ty1 <*> qTypeExpr ty2-qTypeExpr (ParenType ty) = ParenType <$> qTypeExpr ty-qTypeExpr (ForallType vs ty) = ForallType vs <$> qTypeExpr ty+qTypeExpr (ParenType spi ty) = ParenType spi <$> qTypeExpr ty+qTypeExpr (ForallType spi vs ty) = ForallType spi vs <$> qTypeExpr ty qQualTypeExpr :: Qual QualTypeExpr-qQualTypeExpr (QualTypeExpr cx ty) = QualTypeExpr <$> qContext cx- <*> qTypeExpr ty+qQualTypeExpr (QualTypeExpr spi cx ty) = QualTypeExpr spi <$> qContext cx+ <*> qTypeExpr ty qEquation :: Qual (Equation a) qEquation (Equation p lhs rhs) = Equation p <$> qLhs lhs <*> qRhs rhs qLhs :: Qual (Lhs a)-qLhs (FunLhs f ts) = FunLhs f <$> mapM qPattern ts-qLhs (OpLhs t1 op t2) = flip OpLhs op <$> qPattern t1 <*> qPattern t2-qLhs (ApLhs lhs ts) = ApLhs <$> qLhs lhs <*> mapM qPattern ts+qLhs (FunLhs sp f ts) = FunLhs sp f <$> mapM qPattern ts+qLhs (OpLhs sp t1 op t2) = flip (OpLhs sp) op <$> qPattern t1 <*> qPattern t2+qLhs (ApLhs sp lhs ts) = ApLhs sp <$> qLhs lhs <*> mapM qPattern ts qPattern :: Qual (Pattern a)-qPattern l@(LiteralPattern _ _) = return l-qPattern n@(NegativePattern _ _) = return n-qPattern v@(VariablePattern _ _) = return v-qPattern (ConstructorPattern a c ts) = ConstructorPattern a- <$> qIdent c <*> mapM qPattern ts-qPattern (InfixPattern a t1 op t2) = InfixPattern a <$> qPattern t1- <*> qIdent op- <*> qPattern t2-qPattern (ParenPattern t) = ParenPattern <$> qPattern t-qPattern (RecordPattern a c fs) = RecordPattern a <$> qIdent c- <*> mapM (qField qPattern) fs-qPattern (TuplePattern ts) = TuplePattern <$> mapM qPattern ts-qPattern (ListPattern a ts) = ListPattern a <$> mapM qPattern ts-qPattern (AsPattern v t) = AsPattern v <$> qPattern t-qPattern (LazyPattern t) = LazyPattern <$> qPattern t-qPattern (FunctionPattern a f ts) = FunctionPattern a <$> qIdent f- <*> mapM qPattern ts-qPattern (InfixFuncPattern a t1 op t2) = InfixFuncPattern a <$> qPattern t1- <*> qIdent op- <*> qPattern t2+qPattern l@(LiteralPattern _ _ _) = return l+qPattern n@(NegativePattern _ _ _) = return n+qPattern v@(VariablePattern _ _ _) = return v+qPattern (ConstructorPattern spi a c ts) =+ ConstructorPattern spi a <$> qIdent c <*> mapM qPattern ts+qPattern (InfixPattern spi a t1 op t2) =+ InfixPattern spi a <$> qPattern t1 <*> qIdent op <*> qPattern t2+qPattern (ParenPattern spi t) = ParenPattern spi <$> qPattern t+qPattern (RecordPattern spi a c fs) = RecordPattern spi a <$> qIdent c+ <*> mapM (qField qPattern) fs+qPattern (TuplePattern spi ts) =+ TuplePattern spi <$> mapM qPattern ts+qPattern (ListPattern spi a ts) =+ ListPattern spi a <$> mapM qPattern ts+qPattern (AsPattern spi v t) = AsPattern spi v <$> qPattern t+qPattern (LazyPattern spi t) = LazyPattern spi <$> qPattern t+qPattern (FunctionPattern spi a f ts) =+ FunctionPattern spi a <$> qIdent f <*> mapM qPattern ts+qPattern (InfixFuncPattern spi a t1 op t2) =+ InfixFuncPattern spi a <$> qPattern t1 <*> qIdent op <*> qPattern t2 qRhs :: Qual (Rhs a)-qRhs (SimpleRhs p e ds) = SimpleRhs p <$> qExpr e <*> mapM qDecl ds-qRhs (GuardedRhs es ds) = GuardedRhs <$> mapM qCondExpr es <*> mapM qDecl ds+qRhs (SimpleRhs spi e ds) =+ SimpleRhs spi <$> qExpr e <*> mapM qDecl ds+qRhs (GuardedRhs spi es ds) =+ GuardedRhs spi <$> mapM qCondExpr es <*> mapM qDecl ds qCondExpr :: Qual (CondExpr a) qCondExpr (CondExpr p g e) = CondExpr p <$> qExpr g <*> qExpr e qExpr :: Qual (Expression a)-qExpr l@(Literal _ _) = return l-qExpr (Variable a v) = Variable a <$> qIdent v-qExpr (Constructor a c) = Constructor a <$> qIdent c-qExpr (Paren e) = Paren <$> qExpr e-qExpr (Typed e qty) = Typed <$> qExpr e- <*> qQualTypeExpr qty-qExpr (Record a c fs) =- Record a <$> qIdent c <*> mapM (qField qExpr) fs-qExpr (RecordUpdate e fs) = RecordUpdate <$> qExpr e- <*> mapM (qField qExpr) fs-qExpr (Tuple es) = Tuple <$> mapM qExpr es-qExpr (List a es) = List a <$> mapM qExpr es-qExpr (ListCompr e qs) = ListCompr <$> qExpr e <*> mapM qStmt qs-qExpr (EnumFrom e) = EnumFrom <$> qExpr e-qExpr (EnumFromThen e1 e2) = EnumFromThen <$> qExpr e1 <*> qExpr e2-qExpr (EnumFromTo e1 e2) = EnumFromTo <$> qExpr e1 <*> qExpr e2-qExpr (EnumFromThenTo e1 e2 e3) = EnumFromThenTo <$> qExpr e1 <*> qExpr e2- <*> qExpr e3-qExpr (UnaryMinus e) = UnaryMinus <$> qExpr e-qExpr (Apply e1 e2) = Apply <$> qExpr e1 <*> qExpr e2-qExpr (InfixApply e1 op e2) = InfixApply <$> qExpr e1 <*> qInfixOp op- <*> qExpr e2-qExpr (LeftSection e op) = LeftSection <$> qExpr e <*> qInfixOp op-qExpr (RightSection op e) = RightSection <$> qInfixOp op <*> qExpr e-qExpr (Lambda ts e) = Lambda <$> mapM qPattern ts <*> qExpr e-qExpr (Let ds e) = Let <$> mapM qDecl ds <*> qExpr e-qExpr (Do sts e) = Do <$> mapM qStmt sts <*> qExpr e-qExpr (IfThenElse e1 e2 e3) = IfThenElse <$> qExpr e1 <*> qExpr e2- <*> qExpr e3-qExpr (Case ct e as) = Case ct <$> qExpr e <*> mapM qAlt as+qExpr l@(Literal _ _ _) = return l+qExpr (Variable spi a v) = Variable spi a <$> qIdent v+qExpr (Constructor spi a c) = Constructor spi a <$> qIdent c+qExpr (Paren spi e) = Paren spi <$> qExpr e+qExpr (Typed spi e qty) = Typed spi <$> qExpr e+ <*> qQualTypeExpr qty+qExpr (Record spi a c fs) =+ Record spi a <$> qIdent c <*> mapM (qField qExpr) fs+qExpr (RecordUpdate spi e fs) =+ RecordUpdate spi <$> qExpr e <*> mapM (qField qExpr) fs+qExpr (Tuple spi es) = Tuple spi <$> mapM qExpr es+qExpr (List spi a es) = List spi a <$> mapM qExpr es+qExpr (ListCompr spi e qs) = ListCompr spi <$> qExpr e+ <*> mapM qStmt qs+qExpr (EnumFrom spi e) = EnumFrom spi <$> qExpr e+qExpr (EnumFromThen spi e1 e2) = EnumFromThen spi <$> qExpr e1+ <*> qExpr e2+qExpr (EnumFromTo spi e1 e2) = EnumFromTo spi <$> qExpr e1+ <*> qExpr e2+qExpr (EnumFromThenTo spi e1 e2 e3) = EnumFromThenTo spi <$> qExpr e1+ <*> qExpr e2+ <*> qExpr e3+qExpr (UnaryMinus spi e) = UnaryMinus spi <$> qExpr e+qExpr (Apply spi e1 e2) = Apply spi <$> qExpr e1+ <*> qExpr e2+qExpr (InfixApply spi e1 op e2) = InfixApply spi <$> qExpr e1+ <*> qInfixOp op+ <*> qExpr e2+qExpr (LeftSection spi e op) = LeftSection spi <$> qExpr e+ <*> qInfixOp op+qExpr (RightSection spi op e) = RightSection spi <$> qInfixOp op+ <*> qExpr e+qExpr (Lambda spi ts e) = Lambda spi <$> mapM qPattern ts+ <*> qExpr e+qExpr (Let spi ds e) = Let spi <$> mapM qDecl ds <*> qExpr e+qExpr (Do spi sts e) = Do spi <$> mapM qStmt sts <*> qExpr e+qExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> qExpr e1 <*> qExpr e2+ <*> qExpr e3+qExpr (Case spi ct e as) = Case spi ct <$> qExpr e <*> mapM qAlt as qStmt :: Qual (Statement a)-qStmt (StmtExpr e) = StmtExpr <$> qExpr e-qStmt (StmtBind t e) = StmtBind <$> qPattern t <*> qExpr e-qStmt (StmtDecl ds) = StmtDecl <$> mapM qDecl ds+qStmt (StmtExpr spi e) = StmtExpr spi <$> qExpr e+qStmt (StmtBind spi t e) = StmtBind spi <$> qPattern t <*> qExpr e+qStmt (StmtDecl spi ds) = StmtDecl spi <$> mapM qDecl ds qAlt :: Qual (Alt a) qAlt (Alt p t rhs) = Alt p <$> qPattern t <*> qRhs rhs
src/Transformations/Simplify.hs view
@@ -35,8 +35,8 @@ import Control.Monad.State as S (State, runState, gets, modify) import qualified Data.Map as Map (Map, empty, insert, lookup) -import Curry.Base.Position import Curry.Base.Ident+import Curry.Base.SpanInfo import Curry.Syntax import Base.Expr@@ -53,7 +53,7 @@ -- ----------------------------------------------------------------------------- simplify :: ValueEnv -> Module Type -> (Module Type, ValueEnv)-simplify vEnv mdl@(Module _ m _ _ _) = (mdl', valueEnv s')+simplify vEnv mdl@(Module _ _ m _ _ _) = (mdl', valueEnv s') where (mdl', s') = S.runState (simModule mdl) (SimplifyState m vEnv 1) -- -----------------------------------------------------------------------------@@ -96,8 +96,8 @@ -- ----------------------------------------------------------------------------- simModule :: Module Type -> SIM (Module Type)-simModule (Module ps m es is ds) = Module ps m es is- <$> mapM (simDecl Map.empty) ds+simModule (Module spi ps m es is ds) = Module spi ps m es is+ <$> mapM (simDecl Map.empty) ds -- Inline an expression for a variable type InlineEnv = Map.Map Ident (Expression Type)@@ -115,7 +115,7 @@ simRhs :: InlineEnv -> Rhs Type -> SIM (Rhs Type) simRhs env (SimpleRhs p e _) = simpleRhs p <$> simExpr env e-simRhs _ (GuardedRhs _ _) = error "Simplify.simRhs: guarded rhs"+simRhs _ (GuardedRhs _ _ _) = error "Simplify.simRhs: guarded rhs" -- ----------------------------------------------------------------------------- -- Inlining of Functions@@ -147,35 +147,36 @@ -- because it would require to represent the pattern matching code -- explicitly in a Curry expression. -inlineFun :: InlineEnv -> Position -> Lhs Type -> Rhs Type+inlineFun :: InlineEnv -> SpanInfo -> Lhs Type -> Rhs Type -> SIM [Equation Type] inlineFun env p lhs rhs = do m <- getModuleIdent case rhs of- SimpleRhs _ (Let [FunctionDecl _ _ f' eqs'] e) _+ SimpleRhs _ (Let NoSpanInfo [FunctionDecl _ _ f' eqs'] e) _ | -- @f'@ is not recursive f' `notElem` qfv m eqs' -- @f'@ does not perform any pattern matching- && and [all isVariablePattern ts1 | Equation _ (FunLhs _ ts1) _ <- eqs']+ && and [all isVariablePattern ts1 | Equation _ (FunLhs _ _ ts1) _ <- eqs'] -> do let a = eqnArity $ head eqs' (n, vs', e') = etaReduce 0 [] (reverse (snd $ flatLhs lhs)) e if -- the eta-reduced rhs of @f@ is a call to @f'@- e' == Variable (typeOf e') (qualify f')+ e' == Variable NoSpanInfo (typeOf e') (qualify f') -- @f'@ was fully applied before eta-reduction && n == a then mapM (mergeEqns p vs') eqs' else return [Equation p lhs rhs] _ -> return [Equation p lhs rhs] where- etaReduce n1 vs (VariablePattern ty v : ts1) (Apply e1 (Variable _ v'))+ etaReduce n1 vs (VariablePattern _ ty v : ts1)+ (Apply NoSpanInfo e1 (Variable NoSpanInfo _ v')) | qualify v == v' = etaReduce (n1 + 1) ((ty, v) : vs) ts1 e1 etaReduce n1 vs _ e1 = (n1, vs, e1) - mergeEqns p1 vs (Equation _ (FunLhs _ ts2) (SimpleRhs p2 e _))- = Equation p1 lhs <$> simRhs env (simpleRhs p2 (Let ds e))+ mergeEqns p1 vs (Equation _ (FunLhs _ _ ts2) (SimpleRhs p2 e _))+ = Equation p1 lhs <$> simRhs env (simpleRhs p2 (Let NoSpanInfo ds e)) where- ds = zipWith (\t v -> PatternDecl p2 t (simpleRhs p2 (uncurry mkVar v)))+ ds = zipWith (\t v -> PatternDecl NoSpanInfo t (simpleRhs p2 (uncurry mkVar v))) ts2 vs mergeEqns _ _ _ = error "Simplify.inlineFun.mergeEqns: no pattern match"@@ -205,31 +206,32 @@ -- functions in later phases of the compiler. simExpr :: InlineEnv -> Expression Type -> SIM (Expression Type)-simExpr _ l@(Literal _ _) = return l-simExpr _ c@(Constructor _ _) = return c+simExpr _ l@(Literal _ _ _) = return l+simExpr _ c@(Constructor _ _ _) = return c -- subsitution of variables-simExpr env v@(Variable ty x)+simExpr env v@(Variable _ ty x) | isQualified x = return v | otherwise = maybe (return v) (simExpr env . withType ty) (Map.lookup (unqualify x) env) -- simplification of application-simExpr env (Apply e1 e2) = case e1 of- Let ds e' -> simExpr env (Let ds (Apply e' e2))- Case ct e' bs -> simExpr env (Case ct e' (map (applyToAlt e2) bs))- _ -> Apply <$> simExpr env e1 <*> simExpr env e2+simExpr env (Apply _ e1 e2) = case e1 of+ Let _ ds e' -> simExpr env (Let NoSpanInfo ds (Apply NoSpanInfo e' e2))+ Case _ ct e' bs -> simExpr env (Case NoSpanInfo ct e' (map (applyToAlt e2) bs))+ _ -> Apply NoSpanInfo <$> simExpr env e1 <*> simExpr env e2 where- applyToAlt e (Alt p t rhs) = Alt p t (applyToRhs e rhs)- applyToRhs e (SimpleRhs p e1' _) = simpleRhs p (Apply e1' e)- applyToRhs _ (GuardedRhs _ _) = error "Simplify.simExpr.applyRhs: Guarded rhs"+ applyToAlt e (Alt p t rhs) = Alt p t (applyToRhs e rhs)+ applyToRhs e (SimpleRhs p e1' _) = simpleRhs p (Apply NoSpanInfo e1' e)+ applyToRhs _ (GuardedRhs _ _ _) = error "Simplify.simExpr.applyRhs: Guarded rhs" -- simplification of declarations-simExpr env (Let ds e) = do+simExpr env (Let _ ds e) = do m <- getModuleIdent dss <- mapM sharePatternRhs ds simplifyLet env (scc bv (qfv m) (foldr hoistDecls [] (concat dss))) e-simExpr env (Case ct e bs) = Case ct <$> simExpr env e- <*> mapM (simplifyAlt env) bs-simExpr env (Typed e qty) = flip Typed qty <$> simExpr env e-simExpr _ _ = error "Simplify.simExpr: no pattern match"+simExpr env (Case _ ct e bs) =+ Case NoSpanInfo ct <$> simExpr env e <*> mapM (simplifyAlt env) bs+simExpr env (Typed _ e qty) =+ flip (Typed NoSpanInfo) qty <$> simExpr env e+simExpr _ _ = error "Simplify.simExpr: no pattern match" -- Simplify a case alternative simplifyAlt :: InlineEnv -> Alt Type -> SIM (Alt Type)@@ -241,12 +243,12 @@ sharePatternRhs :: Decl Type -> SIM [Decl Type] --TODO: change to patterns instead of case sharePatternRhs (PatternDecl p t rhs) = case t of- VariablePattern _ _ -> return [PatternDecl p t rhs]- _ -> do+ VariablePattern _ _ _ -> return [PatternDecl p t rhs]+ _ -> do let ty = typeOf t v <- freshIdent patternId return [ PatternDecl p t (simpleRhs p (mkVar ty v))- , PatternDecl p (VariablePattern ty v) rhs+ , PatternDecl p (VariablePattern NoSpanInfo ty v) rhs ] where patternId n = mkIdent ("_#pat" ++ show n) sharePatternRhs d = return [d]@@ -254,7 +256,7 @@ -- Lift up nested let declarations in pattern declarations, i.e., replace -- @let p = let ds' in e'; ds in e@ by @let ds'; p = e'; ds in e@. hoistDecls :: Decl a -> [Decl a] -> [Decl a]-hoistDecls (PatternDecl p t (SimpleRhs p' (Let ds' e) _)) ds+hoistDecls (PatternDecl p t (SimpleRhs p' (Let NoSpanInfo ds' e) _)) ds = foldr hoistDecls ds (PatternDecl p t (simpleRhs p' e) : ds') hoistDecls d ds = d : ds @@ -291,14 +293,14 @@ inlineVars :: InlineEnv -> [Decl Type] -> SIM InlineEnv inlineVars env ds = case ds of- [PatternDecl _ (VariablePattern _ v) (SimpleRhs _ e _)] -> do+ [PatternDecl _ (VariablePattern _ _ v) (SimpleRhs _ e _)] -> do allowed <- canInlineVar v e return $ if allowed then Map.insert v e env else env _ -> return env where- canInlineVar _ (Literal _ _) = return True- canInlineVar _ (Constructor _ _) = return True- canInlineVar v (Variable _ v')+ canInlineVar _ (Literal _ _ _) = return True+ canInlineVar _ (Constructor _ _ _) = return True+ canInlineVar v (Variable _ _ v') | isQualified v' = (> 0) <$> getFunArity v' | otherwise = return $ v /= unqualify v' canInlineVar _ _ = return False@@ -306,13 +308,13 @@ mkLet' :: ModuleIdent -> [Decl Type] -> Expression Type -> Expression Type mkLet' m [FreeDecl p vs] e | null vs' = e- | otherwise = Let [FreeDecl p vs'] e -- remove unused free variables+ | otherwise = Let NoSpanInfo [FreeDecl p vs'] e -- remove unused free variables where vs' = filter ((`elem` qfv m e) . varIdent) vs-mkLet' m [PatternDecl _ (VariablePattern ty v) (SimpleRhs _ e _)] (Variable _ v')+mkLet' m [PatternDecl _ (VariablePattern _ ty v) (SimpleRhs _ e _)] (Variable _ _ v') | v' == qualify v && v `notElem` qfv m e = withType ty e -- inline single binding mkLet' m ds e- | null (filter (`elem` qfv m e) (bv ds)) = e -- removed unused bindings- | otherwise = Let ds e+ | not (any (`elem` qfv m e) (bv ds)) = e -- removed unused bindings+ | otherwise = Let NoSpanInfo ds e -- In order to implement lazy pattern matching in local declarations, -- pattern declarations 't = e' where 't' is not a variable@@ -330,15 +332,16 @@ -- of the let expression. expandPatternBindings :: [Ident] -> Decl Type -> SIM [Decl Type] expandPatternBindings fvs d@(PatternDecl p t (SimpleRhs _ e _)) = case t of- VariablePattern _ _ -> return [d]- _ ->+ VariablePattern _ _ _ -> return [d]+ _ -> -- used variables mapM mkSelectorDecl (filter ((`elem` fvs) . fst3) (patternVars t)) where- pty = typeOf t -- type of pattern+ pty = typeOf t -- type of patternNoSpaNoSpanInfonInfo mkSelectorDecl (v, _, vty) = do let fty = TypeArrow pty vty f <- freshIdent (updIdentName (++ '#' : idName v) . fpSelectorId) return $ varDecl p vty v $- Let [funDecl p fty f [t] (mkVar vty v)] (Apply (mkVar fty f) e)+ Let NoSpanInfo [funDecl p fty f [t] (mkVar vty v)]+ (Apply NoSpanInfo (mkVar fty f) e) expandPatternBindings _ d = return [d]