Commit 2843cd57 authored by Finn Teegen's avatar Finn Teegen
Browse files

Remove source references

parent 7b19f40d
......@@ -97,31 +97,31 @@ instance QualExpr (Expression a) where
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 (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 (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 (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 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
......@@ -136,9 +136,9 @@ 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
......@@ -146,31 +146,31 @@ instance QualExpr (InfixOp a) where
instance QuantExpr (Pattern a) where
bv (LiteralPattern _ _) = []
bv (NegativePattern _ _ _) = []
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 (TuplePattern ts) = bv ts
bv (ListPattern _ ts) = bv ts
bv (AsPattern v t) = v : bv t
bv (LazyPattern _ t) = 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 _ (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 (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 (LazyPattern t) = qfv m t
qfv m (FunctionPattern _ f ts)
= maybe [] return (localIdent m f) ++ qfv m ts
qfv m (InfixFuncPattern _ t1 op t2)
......
......@@ -51,16 +51,16 @@ instance Typeable a => Typeable (Rhs a) where
instance Typeable a => Typeable (Pattern a) where
typeOf (LiteralPattern a _) = typeOf a
typeOf (NegativePattern 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 (TuplePattern ts) = tupleType $ map typeOf ts
typeOf (ListPattern a _) = typeOf a
typeOf (AsPattern _ t) = typeOf t
typeOf (LazyPattern _ t) = typeOf t
typeOf (LazyPattern t) = typeOf t
typeOf (FunctionPattern a _ _) = typeOf a
typeOf (InfixFuncPattern a _ _ _) = typeOf a
......@@ -72,14 +72,14 @@ instance Typeable a => Typeable (Expression a) where
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 (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 (UnaryMinus e) = typeOf e
typeOf (Apply e _) = case typeOf e of
TypeArrow _ ty -> ty
_ -> internalError "Base.Typing.typeOf: application"
......@@ -92,11 +92,11 @@ instance Typeable a => Typeable (Expression a) where
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 (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) = head [typeOf rhs | Alt _ _ rhs <- as]
typeOf (IfThenElse _ e _) = typeOf e
typeOf (Case _ _ as) = head [typeOf rhs | Alt _ _ rhs <- as]
-- When inlining variable and function definitions, the compiler must
-- eventually update the type annotations of the inlined expression. To
......@@ -170,18 +170,18 @@ declVars _ = internalError "Base.Typing.declVars"
patternVars :: (Eq t, Typeable t, ValueType t) => Pattern t -> [(Ident, Int, t)]
patternVars (LiteralPattern _ _) = []
patternVars (NegativePattern _ _ _) = []
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 (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 (LazyPattern t) = patternVars t
patternVars (FunctionPattern _ _ ts) = nub $ concatMap patternVars ts
patternVars (InfixFuncPattern _ t1 _ t2) =
nub $ patternVars t1 ++ patternVars t2
......@@ -194,28 +194,28 @@ instance HasType (Expression a) where
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 (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 (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 (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 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
......@@ -517,9 +517,9 @@ 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
......@@ -533,7 +533,7 @@ 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 (UnaryMinus e) = kcExpr tcEnv p e
kcExpr tcEnv p (Apply e1 e2) = do
kcExpr tcEnv p e1
kcExpr tcEnv p e2
......@@ -542,25 +542,25 @@ kcExpr tcEnv p (InfixApply e1 _ e2) = do
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 (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
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 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 tcEnv p (StmtBind _ e) = kcExpr tcEnv p e
kcAlt :: TCEnv -> Alt a -> KCM ()
kcAlt tcEnv (Alt _ _ rhs) = kcRhs tcEnv rhs
......
......@@ -156,7 +156,7 @@ checkLhs (ApLhs lhs ts) =
checkPattern :: Pattern a -> PCM (Pattern a)
checkPattern l@(LiteralPattern _ _) = return l
checkPattern n@(NegativePattern _ _ _) = return n
checkPattern n@(NegativePattern _ _) = return n
checkPattern v@(VariablePattern _ _) = return v
checkPattern (ConstructorPattern a c ts) =
ConstructorPattern a c <$> mapM checkPattern ts
......@@ -166,14 +166,14 @@ checkPattern (InfixPattern a t1 op t2) = do
fixPrecT (InfixPattern a) t1' op t2'
checkPattern (ParenPattern t) =
ParenPattern <$> checkPattern t
checkPattern (TuplePattern p ts) =
TuplePattern p <$> mapM checkPattern ts
checkPattern (ListPattern a p ts) =
ListPattern a p <$> mapM checkPattern ts
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 p t) =
LazyPattern p <$> 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
......@@ -201,10 +201,10 @@ 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 p es) = Tuple p <$> mapM checkExpr es
checkExpr (List a p es) = List a p <$> mapM checkExpr es
checkExpr (ListCompr p e qs) = withLocalPrecEnv $
flip (ListCompr p) <$> mapM checkStmt qs <*> checkExpr e
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
......@@ -212,7 +212,7 @@ checkExpr (EnumFromTo e1 e2) =
EnumFromTo <$> checkExpr e1 <*> checkExpr e2
checkExpr (EnumFromThenTo e1 e2 e3) =
EnumFromThenTo <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3
checkExpr (UnaryMinus r e) = UnaryMinus r <$> checkExpr e
checkExpr (UnaryMinus e) = UnaryMinus <$> checkExpr e
checkExpr (Apply e1 e2) =
Apply <$> checkExpr e1 <*> checkExpr e2
checkExpr (InfixApply e1 op e2) = do
......@@ -221,21 +221,21 @@ checkExpr (InfixApply e1 op e2) = do
fixPrec e1' op e2'
checkExpr (LeftSection e op) = checkExpr e >>= checkLSection op
checkExpr (RightSection op e) = checkExpr e >>= checkRSection op
checkExpr (Lambda r ts e) =
(Lambda r) <$> mapM checkPattern ts <*> checkExpr e
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 r e1 e2 e3) =
IfThenElse r <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3
checkExpr (Case r ct e alts) =
Case r ct <$> checkExpr e <*> mapM checkAlt alts
checkExpr (IfThenElse e1 e2 e3) =
IfThenElse <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3
checkExpr (Case ct e alts) =
Case ct <$> checkExpr e <*> mapM checkAlt alts
checkStmt :: Statement a -> PCM (Statement a)
checkStmt (StmtExpr p e) = StmtExpr p <$> checkExpr e
checkStmt (StmtDecl ds) = StmtDecl <$> checkDecls ds
checkStmt (StmtBind p t e) = StmtBind p <$> checkPattern t <*> checkExpr e
checkStmt (StmtExpr e) = StmtExpr <$> checkExpr e
checkStmt (StmtDecl ds) = StmtDecl <$> checkDecls ds
checkStmt (StmtBind t e) = StmtBind <$> checkPattern t <*> checkExpr e
checkAlt :: Alt a -> PCM (Alt a)
checkAlt (Alt p t rhs) = Alt p <$> checkPattern t <*> checkRhs rhs
......@@ -262,42 +262,42 @@ checkField check (Field p l x) = Field p l <$> check x
-- is called.
fixPrec :: Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixPrec (UnaryMinus ref e1) op e2 = do
fixPrec (UnaryMinus e1) op e2 = do
OpPrec fix pr <- getOpPrec op
if pr < 6 || pr == 6 && fix == InfixL
then fixRPrec (UnaryMinus ref e1) op e2
then fixRPrec (UnaryMinus e1) op e2
else if pr > 6
then fixUPrec ref e1 op e2
then fixUPrec e1 op e2
else do
report $ errAmbiguousParse "unary" (qualify minusId) (opName op)
return $ InfixApply (UnaryMinus ref e1) op e2
return $ InfixApply (UnaryMinus e1) op e2
fixPrec e1 op e2 = fixRPrec e1 op e2
fixUPrec :: SrcRef -> Expression a -> InfixOp a -> Expression a
fixUPrec :: Expression a -> InfixOp a -> Expression a
-> PCM (Expression a)
fixUPrec ref e1 op e2@(UnaryMinus _ _) = do
fixUPrec e1 op e2@(UnaryMinus _) = do
report $ errAmbiguousParse "operator" (opName op) (qualify minusId)
return $ UnaryMinus ref (InfixApply e1 op e2)
fixUPrec ref e1 op1 e'@(InfixApply e2 op2 e3) = do
return $ UnaryMinus (InfixApply e1 op e2)
fixUPrec e1 op1 e'@(InfixApply e2 op2 e3) = do
OpPrec fix2 pr2 <- getOpPrec op2
if pr2 < 6 || pr2 == 6 && fix2 == InfixL
then do
left <- fixUPrec ref e1 op1 e2
left <- fixUPrec e1 op1 e2
return $ InfixApply left op2 e3
else if pr2 > 6
then do
op <- fixRPrec e1 op1 $ InfixApply e2 op2 e3
return $ UnaryMinus ref op
return $ UnaryMinus op
else do
report $ errAmbiguousParse "unary" (qualify minusId) (opName op2)
return $ InfixApply (UnaryMinus ref e1) op1 e'
fixUPrec ref e1 op e2 = return $ UnaryMinus ref (InfixApply e1 op e2)
return $ InfixApply (UnaryMinus e1) op1 e'
fixUPrec e1 op e2 = return $ UnaryMinus (InfixApply e1 op e2)
fixRPrec :: Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixRPrec e1 op (UnaryMinus ref e2) = do
fixRPrec e1 op (UnaryMinus e2) = do
OpPrec _ pr <- getOpPrec op
unless (pr < 6) $ report $ errAmbiguousParse "operator" (opName op) (qualify minusId)
return $ InfixApply e1 op $ UnaryMinus ref e2
return $ InfixApply e1 op $ UnaryMinus e2
fixRPrec e1 op1 (InfixApply e2 op2 e3) = do
OpPrec fix1 pr1 <- getOpPrec op1
OpPrec fix2 pr2 <- getOpPrec op2
......@@ -321,7 +321,7 @@ fixRPrec e1 op e2 = return $ InfixApply e1 op e2
-- section, respectively.
checkLSection :: InfixOp a -> Expression a -> PCM (Expression a)
checkLSection op e@(UnaryMinus _ _) = do
checkLSection op e@(UnaryMinus _) = do
OpPrec fix pr <- getOpPrec op
unless (pr < 6 || pr == 6 && fix == InfixL) $
report $ errAmbiguousParse "unary" (qualify minusId) (opName op)
......@@ -335,7 +335,7 @@ checkLSection op1 e@(InfixApply _ op2 _) = do
checkLSection op e = return $ LeftSection e op
checkRSection :: InfixOp a -> Expression a -> PCM (Expression a)
checkRSection op e@(UnaryMinus _ _) = do
checkRSection op e@(UnaryMinus _) = do
OpPrec _ pr <- getOpPrec op
unless (pr < 6) $ report $ errAmbiguousParse "unary" (qualify minusId) (opName op)
return $ RightSection op e
......@@ -359,7 +359,7 @@ checkRSection op e = return $ RightSection op e
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
......@@ -368,7 +368,7 @@ fixPrecT infixpatt t1 op t2 = fixRPrecT infixpatt t1 op t2
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
......@@ -428,7 +428,7 @@ fixRPrecT _ _ t1 op t2 = InfixPattern t1 op t2-}
-- 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)
......@@ -442,7 +442,7 @@ checkOpL op1 t@(InfixPattern _ _ op2 _) = do
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
......
......@@ -708,7 +708,7 @@ checkLhs p (ApLhs lhs ts) =
checkParenPattern :: (Maybe QualIdent) -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern _ (LiteralPattern _ _) = []
checkParenPattern _ (NegativePattern _ _ _) = []
checkParenPattern _ (NegativePattern _ _) = []
checkParenPattern _ (VariablePattern _ _) = []
checkParenPattern _ (ConstructorPattern _ _ cs) =
concatMap (checkParenPattern Nothing) cs
......@@ -719,13 +719,13 @@ checkParenPattern _ (ParenPattern t) =
checkParenPattern Nothing t
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 t
checkParenPattern o (LazyPattern _ t) =
checkParenPattern o (LazyPattern t) =
checkParenPattern o t
checkParenPattern _ (FunctionPattern _ _ ts) =
concatMap (checkParenPattern Nothing) ts
......@@ -736,8 +736,8 @@ checkParenPattern o (InfixFuncPattern _ t1 op t2) =
checkPattern :: Position -> Pattern () -> SCM (Pattern ())
checkPattern _ (LiteralPattern a l) =
return $ LiteralPattern a l
checkPattern _ (NegativePattern a ref l) =
return $ NegativePattern a ref 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) []
......@@ -749,16 +749,16 @@ checkPattern p (ParenPattern t) =
ParenPattern <$> checkPattern p t
checkPattern p (RecordPattern _ c fs) =
checkRecordPattern p c fs
checkPattern p (TuplePattern pos ts) =
TuplePattern pos <$> mapM (checkPattern p) ts
checkPattern p (ListPattern a pos ts) =
ListPattern a pos <$> mapM (checkPattern p) ts
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 pos t) = do
checkPattern p (LazyPattern t) = do
t' <- checkPattern p t
banFPTerm "lazy pattern" p t'
return (LazyPattern pos t')
return (LazyPattern t')
checkPattern _ (FunctionPattern _ _ _) = internalError $
"SyntaxCheck.checkPattern: function pattern not defined"
checkPattern _ (InfixFuncPattern _ _ _ _) = internalError $
......@@ -878,12 +878,11 @@ 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 pos es) = Tuple pos <$> mapM (checkExpr p) es
checkExpr p (List a pos es) = List a pos <$> mapM (checkExpr p) es
checkExpr p (ListCompr pos e qs)
= withLocalEnv $ flip (ListCompr pos) <$>
-- Note: must be flipped to insert qs into RenameEnv first
mapM (checkStatement "list comprehension" p) qs <*> checkExpr p e
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 <$>
-- 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
......@@ -891,7 +890,7 @@ 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 ref e) = UnaryMinus ref <$> checkExpr p e
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) =
......@@ -900,28 +899,26 @@ 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 r ts e) = inNestedScope $
checkLambda p r ts 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 r e1 e2 e3) =
IfThenElse r <$> checkExpr p e1 <*> checkExpr p e2 <*> checkExpr p e3
checkExpr p (Case r ct e alts) =
Case r ct <$> checkExpr p e <*> mapM checkAlt alts
checkLambda :: Position -> SrcRef -> [Pattern ()] -> Expression ()
-> SCM (Expression ())
checkLambda p r ts e = case findMultiples (bvNoAnon ts) of
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
checkLambda :: Position -> [Pattern ()] -> Expression () -> SCM (Expression ())
checkLambda p ts e = case findMultiples (bvNoAnon ts) of
[] -> do
ts' <- mapM (bindPattern "lambda expression" p) ts
<