Skip to content

GitLab

Commit 369538e8 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Adopted the latest changes in the Curry AST

parent adda624b
Hide whitespace changes
Inline Side-by-side
src/Base/Expr.hs
View file @ 369538e8
......@@ -62,13 +62,13 @@ instance QualExpr Decl where
qfv _ _ = []
instance QuantExpr Decl where
bv (TypeSig _ vs _) = vs
bv (FunctionDecl _ f _) = [f]
bv (ExternalDecl _ _ _ f _) = [f]
bv (FlatExternalDecl _ fs) = fs
bv (PatternDecl _ t _) = bv t
bv (ExtraVariables _ vs) = vs
bv _ = []
bv (TypeSig _ vs _) = vs
bv (FunctionDecl _ f _) = [f]
bv (ForeignDecl _ _ _ f _) = [f]
bv (ExternalDecl _ fs) = fs
bv (PatternDecl _ t _) = bv t
bv (FreeDecl _ vs) = vs
bv _ = []
instance QualExpr Equation where
qfv m (Equation _ lhs rhs) = filterBv lhs $ qfv m lhs ++ qfv m rhs
......@@ -139,7 +139,7 @@ instance QualExpr InfixOp where
qfv m (InfixOp op) = qfv m $ Variable op
qfv _ (InfixConstr _) = []
instance QuantExpr ConstrTerm where
instance QuantExpr Pattern where
bv (LiteralPattern _) = []
bv (NegativePattern _ _) = []
bv (VariablePattern v) = [v]
......@@ -154,7 +154,7 @@ instance QuantExpr ConstrTerm where
bv (InfixFuncPattern t1 op t2) = bvFuncPatt $ InfixFuncPattern t1 op t2
bv (RecordPattern fs r) = maybe [] bv r ++ bv fs
instance QualExpr ConstrTerm where
instance QualExpr Pattern where
qfv _ (LiteralPattern _) = []
qfv _ (NegativePattern _ _) = []
qfv _ (VariablePattern _) = []
......@@ -189,7 +189,7 @@ filterBv e = filter (`Set.notMember` Set.fromList (bv e))
-- Each variable occuring in the function pattern will be unique in the result
-- list.
bvFuncPatt :: ConstrTerm -> [Ident]
bvFuncPatt :: Pattern -> [Ident]
bvFuncPatt = bvfp []
where
bvfp bvs (LiteralPattern _) = bvs
......
src/Base/Typing.lhs
View file @ 369538e8
......@@ -99,7 +99,7 @@ environment.}
> instance Typeable Ident where
> typeOf = computeType identType
> instance Typeable ConstrTerm where
> instance Typeable Pattern where
> typeOf = computeType argType
> instance Typeable Expression where
......@@ -135,7 +135,7 @@ environment.}
> litType _ (Float _ _) = return floatType
> litType _ (String _ _) = return stringType
> argType :: ValueEnv -> ConstrTerm -> TyState Type
> argType :: ValueEnv -> Pattern -> TyState Type
> argType tyEnv (LiteralPattern l) = litType tyEnv l
> argType tyEnv (NegativePattern _ l) = litType tyEnv l
> argType tyEnv (VariablePattern v) = identType tyEnv v
......@@ -182,7 +182,7 @@ environment.}
> tys <- mapM (fieldPattType tyEnv) fs
> return (TypeRecord tys Nothing)
> fieldPattType :: ValueEnv -> Field ConstrTerm -> TyState (Ident,Type)
> fieldPattType :: ValueEnv -> Field Pattern -> TyState (Ident,Type)
> fieldPattType tyEnv (Field _ l t) =
> do
> lty <- instUniv (labelType l tyEnv)
......
src/Checks/KindCheck.lhs
View file @ 369538e8
......@@ -113,27 +113,27 @@ traversed because they can contain local type signatures.
\begin{verbatim}
> checkDecl :: Decl -> KCM Decl
> checkDecl (DataDecl p tc tvs cs) = do
> checkDecl (DataDecl p tc tvs cs) = do
> tvs' <- checkTypeLhs tvs
> cs' <- mapM (checkConstrDecl tvs') cs
> return $ DataDecl p tc tvs' cs'
> checkDecl (NewtypeDecl p tc tvs nc) = do
> checkDecl (NewtypeDecl p tc tvs nc) = do
> tvs' <- checkTypeLhs tvs
> nc' <- checkNewConstrDecl tvs' nc
> return $ NewtypeDecl p tc tvs' nc'
> checkDecl (TypeDecl p tc tvs ty) = do
> checkDecl (TypeDecl p tc tvs ty) = do
> tvs' <- checkTypeLhs tvs
> ty' <- checkClosedType tvs' ty
> return $ TypeDecl p tc tvs' ty'
> checkDecl (TypeSig p vs ty) =
> checkDecl (TypeSig p vs ty) =
> TypeSig p vs `liftM` checkType ty
> checkDecl (FunctionDecl p f eqs) =
> checkDecl (FunctionDecl p f eqs) =
> FunctionDecl p f `liftM` mapM checkEquation eqs
> checkDecl (PatternDecl p t rhs) =
> checkDecl (PatternDecl p t rhs) =
> PatternDecl p t `liftM` checkRhs rhs
> checkDecl (ExternalDecl p cc ie f ty) =
> ExternalDecl p cc ie f `liftM` checkType ty
> checkDecl d = return d
> checkDecl (ForeignDecl p cc ie f ty) =
> ForeignDecl p cc ie f `liftM` checkType ty
> checkDecl d = return d
> checkConstrDecl :: [Ident] -> ConstrDecl -> KCM ConstrDecl
> checkConstrDecl tvs (ConstrDecl p evs c tys) = do
......
src/Checks/PrecCheck.lhs
View file @ 369538e8
......@@ -107,10 +107,10 @@ imported precedence environment.
> constr (ConOpDecl _ _ _ op _) = op
> boundValues (NewtypeDecl _ _ _ (NewConstrDecl _ _ c _)) = [c]
> boundValues (FunctionDecl _ f _) = [f]
> boundValues (ExternalDecl _ _ _ f _) = [f]
> boundValues (FlatExternalDecl _ fs) = fs
> boundValues (ForeignDecl _ _ _ f _) = [f]
> boundValues (ExternalDecl _ fs) = fs
> boundValues (PatternDecl _ t _) = bv t
> boundValues (ExtraVariables _ vs) = vs
> boundValues (FreeDecl _ vs) = vs
> boundValues _ = []
\end{verbatim}
......@@ -131,7 +131,7 @@ interface.
> checkDecl (FunctionDecl p f eqs) =
> FunctionDecl p f `liftM` mapM checkEquation eqs
> checkDecl (PatternDecl p t rhs) =
> liftM2 (PatternDecl p) (checkConstrTerm t) (checkRhs rhs)
> liftM2 (PatternDecl p) (checkPattern t) (checkRhs rhs)
> checkDecl d = return d
> checkEquation :: Equation -> PCM Equation
......@@ -139,47 +139,47 @@ interface.
> liftM2 (Equation p) (checkLhs lhs) (checkRhs rhs)
> checkLhs :: Lhs -> PCM Lhs
> checkLhs (FunLhs f ts) = FunLhs f `liftM` mapM checkConstrTerm ts
> checkLhs (FunLhs f ts) = FunLhs f `liftM` mapM checkPattern ts
> checkLhs (OpLhs t1 op t2) =
> liftM2 (flip OpLhs op) (checkConstrTerm t1 >>= checkOpL op)
> (checkConstrTerm t2 >>= checkOpR op)
> liftM2 (flip OpLhs op) (checkPattern t1 >>= checkOpL op)
> (checkPattern t2 >>= checkOpR op)
> checkLhs (ApLhs lhs ts) =
> liftM2 ApLhs (checkLhs lhs) (mapM checkConstrTerm ts)
> checkConstrTerm :: ConstrTerm -> PCM ConstrTerm
> checkConstrTerm l@(LiteralPattern _) = return l
> checkConstrTerm n@(NegativePattern _ _) = return n
> checkConstrTerm v@(VariablePattern _) = return v
> checkConstrTerm (ConstructorPattern c ts) =
> ConstructorPattern c `liftM` mapM checkConstrTerm ts
> checkConstrTerm (InfixPattern t1 op t2) = do
> t1' <- checkConstrTerm t1
> t2' <- checkConstrTerm t2
> liftM2 ApLhs (checkLhs lhs) (mapM checkPattern ts)
> checkPattern :: Pattern -> PCM Pattern
> checkPattern l@(LiteralPattern _) = return l
> checkPattern n@(NegativePattern _ _) = return n
> checkPattern v@(VariablePattern _) = return v
> checkPattern (ConstructorPattern c ts) =
> ConstructorPattern c `liftM` mapM checkPattern ts
> checkPattern (InfixPattern t1 op t2) = do
> t1' <- checkPattern t1
> t2' <- checkPattern t2
> fixPrecT InfixPattern t1' op t2'
> checkConstrTerm (ParenPattern t) =
> ParenPattern `liftM` checkConstrTerm t
> checkConstrTerm (TuplePattern p ts) =
> TuplePattern p `liftM` mapM checkConstrTerm ts
> checkConstrTerm (ListPattern p ts) =
> ListPattern p `liftM` mapM checkConstrTerm ts
> checkConstrTerm (AsPattern v t) =
> AsPattern v `liftM` checkConstrTerm t
> checkConstrTerm (LazyPattern p t) =
> LazyPattern p `liftM` checkConstrTerm t
> checkConstrTerm (FunctionPattern f ts) =
> FunctionPattern f `liftM` mapM checkConstrTerm ts
> checkConstrTerm (InfixFuncPattern t1 op t2) = do
> t1' <- checkConstrTerm t1
> t2' <- checkConstrTerm t2
> checkPattern (ParenPattern t) =
> ParenPattern `liftM` checkPattern t
> checkPattern (TuplePattern p ts) =
> TuplePattern p `liftM` mapM checkPattern ts
> checkPattern (ListPattern p ts) =
> ListPattern p `liftM` mapM checkPattern ts
> checkPattern (AsPattern v t) =
> AsPattern v `liftM` checkPattern t
> checkPattern (LazyPattern p t) =
> LazyPattern p `liftM` checkPattern t
> checkPattern (FunctionPattern f ts) =
> FunctionPattern f `liftM` mapM checkPattern ts
> checkPattern (InfixFuncPattern t1 op t2) = do
> t1' <- checkPattern t1
> t2' <- checkPattern t2
> fixPrecT InfixFuncPattern t1' op t2'
> checkConstrTerm (RecordPattern fs r) =
> checkPattern (RecordPattern fs r) =
> liftM2 RecordPattern (mapM checkFieldPattern fs) $
> case r of
> Nothing -> return Nothing
> Just r' -> Just `fmap` checkConstrTerm r'
> Just r' -> Just `fmap` checkPattern r'
> checkFieldPattern :: Field ConstrTerm -> PCM (Field ConstrTerm)
> checkFieldPattern (Field p l e) = Field p l `liftM` checkConstrTerm e
> checkFieldPattern :: Field Pattern -> PCM (Field Pattern)
> checkFieldPattern (Field p l e) = Field p l `liftM` checkPattern e
> checkRhs :: Rhs -> PCM Rhs
> checkRhs (SimpleRhs p e ds) = withLocalPrecEnv $
......@@ -218,7 +218,7 @@ interface.
> checkExpr (LeftSection e op) = checkExpr e >>= checkLSection op
> checkExpr (RightSection op e) = checkExpr e >>= checkRSection op
> checkExpr (Lambda r ts e) =
> liftM2 (Lambda r) (mapM checkConstrTerm ts) (checkExpr e)
> liftM2 (Lambda r) (mapM checkPattern ts) (checkExpr e)
> checkExpr (Let ds e) = withLocalPrecEnv $
> liftM2 Let (checkDecls ds) (checkExpr e)
> checkExpr (Do sts e) = withLocalPrecEnv $
......@@ -241,10 +241,10 @@ interface.
> checkStmt (StmtExpr p e) = StmtExpr p `liftM` checkExpr e
> checkStmt (StmtDecl ds) = StmtDecl `liftM` checkDecls ds
> checkStmt (StmtBind p t e) =
> liftM2 (StmtBind p) (checkConstrTerm t) (checkExpr e)
> liftM2 (StmtBind p) (checkPattern t) (checkExpr e)
> checkAlt :: Alt -> PCM Alt
> checkAlt (Alt p t rhs) = liftM2 (Alt p) (checkConstrTerm t) (checkRhs rhs)
> checkAlt (Alt p t rhs) = liftM2 (Alt p) (checkPattern t) (checkRhs rhs)
\end{verbatim}
The functions \texttt{fixPrec}, \texttt{fixUPrec}, and
......@@ -368,8 +368,8 @@ this case, the negation must bind more tightly than the operator for
the pattern to be accepted.
\begin{verbatim}
> fixPrecT :: (ConstrTerm -> QualIdent -> ConstrTerm -> ConstrTerm)
> -> ConstrTerm -> QualIdent -> ConstrTerm -> PCM ConstrTerm
> fixPrecT :: (Pattern -> QualIdent -> Pattern -> Pattern)
> -> Pattern -> QualIdent -> Pattern -> PCM Pattern
> fixPrecT infixpatt t1@(NegativePattern uop _) op t2 = do
> OpPrec fix pr <- prec op `liftM` getPrecEnv
> unless (pr < 6 || pr == 6 && fix == InfixL) $
......@@ -377,8 +377,8 @@ the pattern to be accepted.
> fixRPrecT infixpatt t1 op t2
> fixPrecT infixpatt t1 op t2 = fixRPrecT infixpatt t1 op t2
> fixRPrecT :: (ConstrTerm -> QualIdent -> ConstrTerm -> ConstrTerm)
> -> ConstrTerm -> QualIdent -> ConstrTerm -> PCM ConstrTerm
> fixRPrecT :: (Pattern -> QualIdent -> Pattern -> Pattern)
> -> Pattern -> QualIdent -> Pattern -> PCM Pattern
> fixRPrecT infixpatt t1 op t2@(NegativePattern uop _) = do
> OpPrec _ pr <- prec op `liftM` getPrecEnv
> unless (pr < 6) $ report $ errInvalidParse "unary" uop op
......@@ -409,16 +409,16 @@ the pattern to be accepted.
> return $ infixpatt t1 op1 (InfixFuncPattern t2 op2 t3)
> fixRPrecT infixpatt t1 op t2 = return $ infixpatt t1 op t2
> {-fixPrecT :: Position -> OpPrecEnv -> ConstrTerm -> QualIdent -> ConstrTerm
> -> ConstrTerm
> {-fixPrecT :: Position -> OpPrecEnv -> Pattern -> QualIdent -> Pattern
> -> Pattern
> fixPrecT p pEnv t1@(NegativePattern uop l) op t2
> | pr < 6 || pr == 6 && fix == InfixL = fixRPrecT p pEnv t1 op t2
> | otherwise = errorAt p $ errInvalidParse "unary" uop op
> where OpPrec fix pr = prec op pEnv
> fixPrecT p pEnv t1 op t2 = fixRPrecT p pEnv t1 op t2-}
> {-fixRPrecT :: Position -> OpPrecEnv -> ConstrTerm -> QualIdent -> ConstrTerm
> -> ConstrTerm
> {-fixRPrecT :: Position -> OpPrecEnv -> Pattern -> QualIdent -> Pattern
> -> Pattern
> fixRPrecT p pEnv t1 op t2@(NegativePattern uop l)
> | pr < 6 = InfixPattern t1 op t2
> | otherwise = errorAt p $ errInvalidParse "unary" uop op
......@@ -440,7 +440,7 @@ patterns they must bind more tightly than the operator, otherwise the
left-hand side of the declaration is invalid.
\begin{verbatim}
> checkOpL :: Ident -> ConstrTerm -> PCM ConstrTerm
> checkOpL :: Ident -> Pattern -> PCM Pattern
> checkOpL op t@(NegativePattern uop _) = do
> OpPrec fix pr <- prec (qualify op) `liftM` getPrecEnv
> unless (pr < 6 || pr == 6 && fix == InfixL) $
......@@ -454,7 +454,7 @@ left-hand side of the declaration is invalid.
> return t
> checkOpL _ t = return t
> checkOpR :: Ident -> ConstrTerm -> PCM ConstrTerm
> checkOpR :: Ident -> Pattern -> PCM Pattern
> checkOpR op t@(NegativePattern uop _) = do
> OpPrec _ pr <- prec (qualify op) `liftM` getPrecEnv
> when (pr >= 6) $ report $ errInvalidParse "unary" uop (qualify op)
......
src/Checks/SyntaxCheck.lhs
View file @ 369538e8
......@@ -249,7 +249,7 @@ Furthermore, it is not allowed to declare a label more than once.
> | otherwise = let arty = length $ snd $ getFlatLhs $ head equs
> qid = qualifyWith m ident
> in bindGlobal m ident (GlobalVar arty qid) env
> bindFuncDecl m (ExternalDecl _ _ _ ident texpr) env
> bindFuncDecl m (ForeignDecl _ _ _ ident texpr) env
> = let arty = typeArity texpr
> qid = qualifyWith m ident
> in bindGlobal m ident (GlobalVar arty qid) env
......@@ -272,7 +272,7 @@ Furthermore, it is not allowed to declare a label more than once.
> | otherwise = let arty = length $ snd $ getFlatLhs $ head equs
> in bindLocal (unRenameIdent ident) (LocalVar arty ident) env
> bindVarDecl (PatternDecl _ t _) env = foldr bindVar env (bv t)
> bindVarDecl (ExtraVariables _ vs) env = foldr bindVar env vs
> bindVarDecl (FreeDecl _ vs) env = foldr bindVar env vs
> bindVarDecl _ env = env
> bindVar :: Ident -> RenameEnv -> RenameEnv
......@@ -357,14 +357,14 @@ top-level.
> (\vs' -> TypeSig p vs' ty) `liftM` mapM (checkVar "type signature") vs
> checkDeclLhs (FunctionDecl p _ eqs) =
> checkEquationsLhs p eqs
> checkDeclLhs (ExternalDecl p cc ie f ty) =
> (\f' -> ExternalDecl p cc ie f' ty) `liftM` checkVar "external declaration" f
> checkDeclLhs (FlatExternalDecl p fs) =
> FlatExternalDecl p `liftM` mapM (checkVar "flat external declaration") fs
> checkDeclLhs (ForeignDecl p cc ie f ty) =
> (\f' -> ForeignDecl p cc ie f' ty) `liftM` checkVar "foreign declaration" f
> checkDeclLhs ( ExternalDecl p fs) =
> ExternalDecl p `liftM` mapM (checkVar "external declaration") fs
> checkDeclLhs (PatternDecl p t rhs) =
> (\t' -> PatternDecl p t' rhs) `liftM` checkConstrTerm p t
> checkDeclLhs (ExtraVariables p vs) =
> ExtraVariables p `liftM` mapM (checkVar "free variables declaration") vs
> (\t' -> PatternDecl p t' rhs) `liftM` checkPattern p t
> checkDeclLhs (FreeDecl p vs) =
> FreeDecl p `liftM` mapM (checkVar "free variables declaration") vs
> checkDeclLhs d = return d
> checkVar :: String -> Ident -> SCM Ident
......@@ -389,7 +389,7 @@ top-level.
> return $ PatternDecl p' t rhs
> checkEquationsLhs _ _ = internalError "SyntaxCheck.checkEquationsLhs"
> checkEqLhs :: Position -> Lhs -> SCM (Either (Ident, Lhs) ConstrTerm)
> checkEqLhs :: Position -> Lhs -> SCM (Either (Ident, Lhs) Pattern)
> checkEqLhs p toplhs = do
> m <- getModuleIdent
> k <- getScopeId
......@@ -426,8 +426,8 @@ top-level.
> return $ r
> where (f, _) = flatLhs lhs
> checkOpLhs :: Integer -> RenameEnv -> (ConstrTerm -> ConstrTerm)
> -> ConstrTerm -> Either (Ident, Lhs) ConstrTerm
> checkOpLhs :: Integer -> RenameEnv -> (Pattern -> Pattern)
> -> Pattern -> Either (Ident, Lhs) Pattern
> checkOpLhs k env f (InfixPattern t1 op t2)
> | isJust m || isDataConstr op' env
> = checkOpLhs k env (f . InfixPattern t1 op) t2
......@@ -453,7 +453,7 @@ top-level.
> let dbls@[dblVar, dblTys] = map findDouble [bvs, tys]
> onJust (report . errDuplicateDefinition) dblVar
> onJust (report . errDuplicateTypeSig ) dblTys
> let missingTy = [f | FlatExternalDecl _ fs' <- ds, f <- fs', f `notElem` tys]
> let missingTy = [f | ExternalDecl _ fs' <- ds, f <- fs', f `notElem` tys]
> mapM_ (report . errNoTypeSig) missingTy
> if all isNothing dbls && null missingTy
> then do
......@@ -489,80 +489,80 @@ top-level.
> return $ Equation p lhs' rhs'
> checkLhs :: Position -> Lhs -> SCM Lhs
> checkLhs p (FunLhs f ts) = FunLhs f `liftM` mapM (checkConstrTerm p) ts
> checkLhs p (FunLhs f ts) = FunLhs f `liftM` mapM (checkPattern p) ts
> checkLhs p (OpLhs t1 op t2) = do
> let wrongCalls = concatMap (checkParenConstrTerm (Just $ qualify op)) [t1,t2]
> let wrongCalls = concatMap (checkParenPattern (Just $ qualify op)) [t1,t2]
> unless (null wrongCalls) $ report $ errInfixWithoutParens
> (idPosition op) wrongCalls
> liftM2 (flip OpLhs op) (checkConstrTerm p t1) (checkConstrTerm p t2)
> liftM2 (flip OpLhs op) (checkPattern p t1) (checkPattern p t2)
> checkLhs p (ApLhs lhs ts) =
> liftM2 ApLhs (checkLhs p lhs) (mapM (checkConstrTerm p) ts)
> liftM2 ApLhs (checkLhs p lhs) (mapM (checkPattern p) ts)
checkParen
@param Aufrufende InfixFunktion
@param ConstrTerm
@param Pattern
@return Liste mit fehlerhaften Funktionsaufrufen
\begin{verbatim}
> checkParenConstrTerm :: (Maybe QualIdent) -> ConstrTerm -> [(QualIdent,QualIdent)]
> checkParenConstrTerm _ (LiteralPattern _) = []
> checkParenConstrTerm _ (NegativePattern _ _) = []
> checkParenConstrTerm _ (VariablePattern _) = []
> checkParenConstrTerm _ (ConstructorPattern _ cs) =
> concatMap (checkParenConstrTerm Nothing) cs
> checkParenConstrTerm o (InfixPattern t1 op t2) =
> checkParenPattern :: (Maybe QualIdent) -> Pattern -> [(QualIdent,QualIdent)]
> checkParenPattern _ (LiteralPattern _) = []
> checkParenPattern _ (NegativePattern _ _) = []
> checkParenPattern _ (VariablePattern _) = []
> checkParenPattern _ (ConstructorPattern _ cs) =
> concatMap (checkParenPattern Nothing) cs
> checkParenPattern o (InfixPattern t1 op t2) =
> maybe [] (\c -> [(c, op)]) o
> ++ checkParenConstrTerm Nothing t1 ++ checkParenConstrTerm Nothing t2
> checkParenConstrTerm _ (ParenPattern t) =
> checkParenConstrTerm Nothing t
> checkParenConstrTerm _ (TuplePattern _ ts) =
> concatMap (checkParenConstrTerm Nothing) ts
> checkParenConstrTerm _ (ListPattern _ ts) =
> concatMap (checkParenConstrTerm Nothing) ts
> checkParenConstrTerm o (AsPattern _ t) =
> checkParenConstrTerm o t
> checkParenConstrTerm o (LazyPattern _ t) =
> checkParenConstrTerm o t
> checkParenConstrTerm _ (FunctionPattern _ ts) =
> concatMap (checkParenConstrTerm Nothing) ts
> checkParenConstrTerm o (InfixFuncPattern t1 op t2) =
> ++ checkParenPattern Nothing t1 ++ checkParenPattern Nothing t2
> checkParenPattern _ (ParenPattern t) =
> checkParenPattern Nothing t
> checkParenPattern _ (TuplePattern _ ts) =
> concatMap (checkParenPattern Nothing) ts
> checkParenPattern _ (ListPattern _ ts) =
> concatMap (checkParenPattern Nothing) ts
> checkParenPattern o (AsPattern _ t) =
> checkParenPattern o t
> checkParenPattern o (LazyPattern _ t) =
> checkParenPattern o t
> checkParenPattern _ (FunctionPattern _ ts) =
> concatMap (checkParenPattern Nothing) ts
> checkParenPattern o (InfixFuncPattern t1 op t2) =
> maybe [] (\c -> [(c, op)]) o
> ++ checkParenConstrTerm Nothing t1 ++ checkParenConstrTerm Nothing t2
> checkParenConstrTerm _ (RecordPattern fs t) =
> maybe [] (checkParenConstrTerm Nothing) t
> ++ concatMap (\(Field _ _ t') -> checkParenConstrTerm Nothing t') fs
> ++ checkParenPattern Nothing t1 ++ checkParenPattern Nothing t2
> checkParenPattern _ (RecordPattern fs t) =
> maybe [] (checkParenPattern Nothing) t
> ++ concatMap (\(Field _ _ t') -> checkParenPattern Nothing t') fs
> checkConstrTerm :: Position -> ConstrTerm -> SCM ConstrTerm
> checkConstrTerm _ (LiteralPattern l) =
> checkPattern :: Position -> Pattern -> SCM Pattern
> checkPattern _ (LiteralPattern l) =
> LiteralPattern `liftM` renameLiteral l
> checkConstrTerm _ (NegativePattern op l) =
> checkPattern _ (NegativePattern op l) =
> NegativePattern op `liftM` renameLiteral l
> checkConstrTerm p (VariablePattern v)
> checkPattern p (VariablePattern v)
> | isAnonId v = (VariablePattern . renameIdent v) `liftM` newId
> | otherwise = checkConstructorPattern p (qualify v) []
> checkConstrTerm p (ConstructorPattern c ts) =
> checkPattern p (ConstructorPattern c ts) =
> checkConstructorPattern p c ts
> checkConstrTerm p (InfixPattern t1 op t2) =
> checkPattern p (InfixPattern t1 op t2) =
> checkInfixPattern p t1 op t2
> checkConstrTerm p (ParenPattern t) =
> ParenPattern `liftM` checkConstrTerm p t
> checkConstrTerm p (TuplePattern pos ts) =
> TuplePattern pos `liftM` mapM (checkConstrTerm p) ts
> checkConstrTerm p (ListPattern pos ts) =
> ListPattern pos `liftM` mapM (checkConstrTerm p) ts
> checkConstrTerm p (AsPattern v t) = do
> liftM2 AsPattern (checkVar "@ pattern" v) (checkConstrTerm p t)
> checkConstrTerm p (LazyPattern pos t) =
> LazyPattern pos `liftM` checkConstrTerm p t
> checkConstrTerm p (RecordPattern fs t) =
> checkPattern p (ParenPattern t) =
> ParenPattern `liftM` checkPattern p t
> checkPattern p (TuplePattern pos ts) =
> TuplePattern pos `liftM` mapM (checkPattern p) ts
> checkPattern p (ListPattern pos ts) =
> ListPattern pos `liftM` mapM (checkPattern p) ts
> checkPattern p (AsPattern v t) = do
> liftM2 AsPattern (checkVar "@ pattern" v) (checkPattern p t)
> checkPattern p (LazyPattern pos t) =
> LazyPattern pos `liftM` checkPattern p t
> checkPattern p (RecordPattern fs t) =
> checkRecordPattern p fs t
> checkConstrTerm _ (FunctionPattern _ _) = internalError $
> "SyntaxCheck.checkConstrTerm: function pattern not defined"
> checkConstrTerm _ (InfixFuncPattern _ _ _) = internalError $
> "SyntaxCheck.checkConstrTerm: infix function pattern not defined"
> checkPattern _ (FunctionPattern _ _) = internalError $
> "SyntaxCheck.checkPattern: function pattern not defined"
> checkPattern _ (InfixFuncPattern _ _ _) = internalError $
> "SyntaxCheck.checkPattern: infix function pattern not defined"
> checkConstructorPattern :: Position -> QualIdent -> [ConstrTerm]
> -> SCM ConstrTerm
> checkConstructorPattern :: Position -> QualIdent -> [Pattern]
> -> SCM Pattern
> checkConstructorPattern p c ts = do
> env <- getRenameEnv
> m <- getModuleIdent
......@@ -585,22 +585,22 @@ checkParen
> n' = length ts
> processCons qc n = do
> when (n /= n') $ report $ errWrongArity c n n'
> ConstructorPattern qc `liftM` mapM (checkConstrTerm p) ts
> ConstructorPattern qc `liftM` mapM (checkPattern p) ts
> processVarFun r k = do
> let n = arity r
> if null ts && not (isQualified c)
> then return $ VariablePattern $ renameIdent (varIdent r) k
> else do
> checkFuncPatsExtension p
> ts' <- mapM (checkConstrTerm p) ts
> ts' <- mapM (checkPattern p) ts
> if n' > n
> then let (ts1, ts2) = splitAt n ts'
> in return $ genFuncPattAppl
> (FunctionPattern (qualVarIdent r) ts1) ts2
> else return $ FunctionPattern (qualVarIdent r) ts'
> checkInfixPattern :: Position -> ConstrTerm -> QualIdent -> ConstrTerm
> -> SCM ConstrTerm
> checkInfixPattern :: Position -> Pattern -> QualIdent -> Pattern
> -> SCM Pattern
> checkInfixPattern p t1 op t2 = do
> m <- getModuleIdent
> env <- getRenameEnv
......@@ -617,17 +617,17 @@ checkParen
> where
> infixPattern qop n = do
> when (n /= 2) $ report $ errWrongArity op n 2
> liftM2 (flip InfixPattern qop) (checkConstrTerm p t1)
> (checkConstrTerm p t2)
> liftM2 (flip InfixPattern qop) (checkPattern p t1)
> (checkPattern p t2)
> funcPattern qop = do
> checkFuncPatsExtension p
> liftM2 (flip InfixFuncPattern qop) (checkConstrTerm p t1)
> (checkConstrTerm p t2)
> liftM2 (flip InfixFuncPattern qop) (checkPattern p t1)
> (checkPattern p t2)
> checkRecordPattern :: Position -> [Field ConstrTerm]
> -> (Maybe ConstrTerm) -> SCM ConstrTerm
> checkRecordPattern :: Position -> [Field Pattern]
> -> (Maybe Pattern) -> SCM Pattern
> checkRecordPattern p fs t = do
> checkRecordExtension p
> case fs of
......@@ -647,7 +647,7 @@ checkParen
> else if t == Just (VariablePattern anonId)
> then liftM2 RecordPattern
> (mapM (checkFieldPatt r) fs)
> (Just `liftM` checkConstrTerm p (fromJust t))
> (Just `liftM` checkPattern p (fromJust t))
> else do report (errIllegalRecordPattern p)
> return $ RecordPattern fs t
> where ls' = map fieldLabel fs
......@@ -657,7 +657,7 @@ checkParen
> [_] -> report (errNotALabel l) >> return (RecordPattern fs t)
> _ -> report (errDuplicateDefinition l) >> return (RecordPattern fs t)
> checkFieldPatt :: QualIdent -> Field ConstrTerm -> SCM (Field ConstrTerm)
> checkFieldPatt :: QualIdent -> Field Pattern -> SCM (Field Pattern)
> checkFieldPatt r (Field p l t) = do
> env <- getRenameEnv
> case lookupVar l env of
......@@ -665,7 +665,7 @@ checkParen
> [] -> report $ errUndefinedLabel l
> [_] -> report $ errNotALabel l
> _ -> report $ errDuplicateDefinition l
> Field p l `liftM` checkConstrTerm (idPosition l) t
> Field p l `liftM` checkPattern (idPosition l) t