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
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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