Commit 72795a31 authored by Kai-Oliver Prott's avatar Kai-Oliver Prott

Fix compilation errors resulting from AST changes

parent bdee80a4
......@@ -15,6 +15,7 @@ module Base.AnnotExpr (QualAnnotExpr (..)) where
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 Lhs where
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 :: ModuleIdent -> Statement Type -> [(Type, Ident)] -> [(Type, Ident)]
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]
......
......@@ -39,6 +39,7 @@ import qualified Data.Set as Set
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 :: [Ident] -> [CS.TypeExpr] -> [Type]
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 :: [Ident] -> CS.Constraint -> Pred
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 :: [Ident] -> CS.QualTypeExpr -> PredType
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 @@ toQualPredType m tvs = qualifyPredType m . toPredType tvs
-- 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 @@ restrictContext tvs cx =
-- 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 :: ModuleIdent -> [Ident] -> Type -> CS.TypeExpr
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 @@ fromQualPredSet m tvs = fromPredSet tvs . unqualifyPredSet m
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
......
......@@ -27,6 +27,7 @@ import Data.List (nub)
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 (Lhs a) where
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 @@ instance QualExpr a => QualExpr (Field a) where
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))
......@@ -46,57 +46,57 @@ instance Typeable PredType where
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 _