1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
{- |
    Module      :  Check.CheckPosAST
    Description :  Checking of PosAST

    This module provides a tree traversal for the PosAST while
    applying checks to each node and the computation of subterms
    for all data structures of the PosAST which are defined recursively.
-}







module Check.CheckPosAST where

-- import AST.AST               (Pos, Ident (..), QualIdent (..))
import AST.AddSpans       (apModule)
import AST.Ident
import AST.SpanAST
import AST.Span           (Pos)
import AST.SortSplit      (sortSplitModule)
import Check.ConstrDecl   (constrDeclCheck)
import Check.Decl         (declCheck)
import Check.Expression   (expressionCheck)
import Check.ImportExport (impDeclCheck, expSpecCheck)
import Check.Pattern      (patternCheck)
import Check.Rhs          (rhsCheck)
import Check.TypeExpr     (typeExprCheck)
import Check.Types        (CheckF)

-- ----------------------------------------------------------------------------
-- Traverse PosAST and apply check functions.
-- ----------------------------------------------------------------------------

-- |Check Module
checkModule :: CheckF Module
checkModule (Module _ _ _ _ mexp ids ds)
  =    checkExpSpec mexp
    ++ concatMap checkImpDecl ids
    ++ concatMap checkDecl ds

-- |Check ImportDecl
checkImpDecl :: CheckF ImportDecl
checkImpDecl i = impDeclCheck i

-- |Check ExportSpec
checkExpSpec :: CheckF (Maybe ExportSpec)
checkExpSpec exps = case exps of
  Just exp   -> [ m | m <- expSpecCheck exp]
  _          -> []

-- |Check Decl
checkDecl :: CheckF Decl
checkDecl d = case d of
  DataDecl     _   _   _   _  cds  _ -> [ m | m <- declCheck d ]
                                        ++ concatMap checkConstrDecl cds
  NewtypeDecl  _   _   _   _  ncd    -> checkNewConstrDecl ncd
  TypeDecl     _   _   _   _  te     -> checkTypeExpr te
  TypeSig      _   _   _   te        -> checkTypeExpr te
  FunctionDecl _   eqs               -> concatMap checkEquation eqs
  ForeignDecl  _   _   _   _  _  te  -> checkTypeExpr te
  PatternDecl  pat rhs               -> checkPattern pat ++ checkRhs rhs
  _                                  -> []

-- |Check ConstrDecl
checkConstrDecl :: CheckF ConstrDecl
checkConstrDecl cd = case cd of
  ConstrDecl _ _   tes         -> concatMap checkTypeExpr tes
  ConOpDecl  _ te1 _   te2     -> checkTypeExpr te1 ++ checkTypeExpr te2
  RecordDecl _ _   _   fds _ _ -> [ m | m <- constrDeclCheck cd ]
                                  ++ concatMap checkFieldDecl fds

-- |Check NewConstrDecl
checkNewConstrDecl :: CheckF NewConstrDecl
checkNewConstrDecl ncd = case ncd of
  NewConstrDecl _ _ te              -> checkTypeExpr te
  NewRecordDecl _ _ _  (_, _, te) _ -> checkTypeExpr te

-- |Check FieldDecl
checkFieldDecl :: CheckF FieldDecl
checkFieldDecl (FieldDecl _ _ _ te) = checkTypeExpr te

-- |Check TypeExpr
checkTypeExpr :: CheckF TypeExpr
checkTypeExpr te = [ m | te' <- subTypeExprs te, m <- typeExprCheck te']

-- |Check Equation
checkEquation :: CheckF Equation
checkEquation (Equation lhs rhs) = checkLhs lhs ++ checkRhs rhs

-- |Check Lhs
checkLhs :: CheckF Lhs
checkLhs lhs = case lhs of
  FunLhs _ ps -> concatMap checkPattern ps
  OpLhs p1 _ p2   ->    [ m | p1' <- subPattern p1, m <- check p1' ]
                     ++ [ m | p2' <- subPattern p2, m <- check p2' ]
    where check = patternCheck
  ApLhs _ ps      -> concatMap checkPattern ps

-- |Check Rhs
checkRhs :: CheckF Rhs
checkRhs rhs = case rhs of
  SimpleRhs _ e _ ds      -> checkExpression e ++ concatMap checkDecl ds
  GuardedRhs _ ces _ _ ds -> [ m | m <- rhsCheck rhs ]
                             ++ concatMap checkCondExpr ces
                             ++ concatMap checkDecl ds

-- |Check CondExpr
checkCondExpr :: CheckF CondExpr
checkCondExpr (CondExpr e1 _ e2) = checkExpression e1 ++ checkExpression e2

-- |Check Pattern
checkPattern :: CheckF Pattern
checkPattern p = [ m | p' <- subPattern p, m <- patternCheck p' ]

-- |Check Expression
checkExpression :: CheckF Expression
checkExpression e = case e of
    ListCompr _ _   _  sts _  _   -> [ m | e' <- subExprs e, m <- check e' ]
                                     ++ concatMap checkStatement sts
    Do        _ sts _             -> [ m | e' <- subExprs e, m <- check e' ]
                                     ++ concatMap checkStatement sts
    Case      _ _   _ _    alts   -> [ m | e' <- subExprs e, m <- check e' ]
                                     ++ concatMap checkAlt alts
    _                             -> [ m | e' <- subExprs e, m <- check e' ]
  where
    check = expressionCheck

-- |Check Statement
checkStatement :: CheckF Statement
checkStatement s = case s of
  StmtExpr e       -> checkExpression e
  StmtDecl _ ds    -> concatMap checkDecl ds
  StmtBind _ pat e -> checkPattern pat ++ checkExpression e

-- |Check Alt
checkAlt :: CheckF Alt
checkAlt (Alt pat rhs) = checkPattern pat ++ checkRhs rhs


-- ----------------------------------------------------------------------------
-- Compute subterms for all data structures which are defined recursively
-- ----------------------------------------------------------------------------

-- |Sub-TypeExprs
subTypeExprs :: TypeExpr -> [TypeExpr]
subTypeExprs te = te : case te of
  ConstructorType _   _   tes _ -> concatMap subTypeExprs tes
  VariableType    _             -> []
  TupleType       _   tes _   _ -> concatMap subTypeExprs tes
  ListType        _   te1 _     -> subTypeExprs te1
  ArrowType       te1 _   te2   -> concatMap subTypeExprs [te1, te2]
  ParenType       _   te1 _     -> subTypeExprs te1

-- |Sub-Lhs
subLhs :: Lhs -> [Lhs]
subLhs lhs = lhs : case lhs of
  ApLhs  lhs1 _       -> subLhs lhs1
  _                   -> []

-- |Sub-Patterns
subPattern :: Pattern -> [Pattern]
subPattern p = p : case p of
  LiteralPattern     _              -> []
  NegativePattern    _  _           -> []
  VariablePattern    _              -> []
  ConstructorPattern _  ps          -> concatMap subPattern ps
  InfixPattern       p1  _ p2       -> concatMap subPattern [p1, p2]
  ParenPattern       _  p1 _        -> subPattern p1
  RecordPattern      _  _  fps _ _  -> concatMap subFieldPat fps
    where subFieldPat (Field _ _ p1) = subPattern p1
  TuplePattern       _  ps _   _    -> concatMap subPattern ps
  ListPattern        _  ps _   _    -> concatMap subPattern ps
  AsPattern          _  _  p1       -> subPattern p1
  LazyPattern        _  p1          -> subPattern p1
  FunctionPattern    _  ps          -> concatMap subPattern ps
  InfixFuncPattern   p1 _  p2       -> concatMap subPattern [p1, p2]

-- |Sub-Expressions
subExprs :: Expression -> [Expression]
subExprs e = e : case e of
  Literal        _                  -> []
  Variable       _                  -> []
  Constructor    _                  -> []
  Paren          _  e1    _         -> subExprs e1
  Typed          e1 _  _            -> subExprs e1
  Record         _  _  fs _  _      -> concatMap subFieldExprs fs
  RecordUpdate   e1 _  fs _  _      -> subExprs e1 ++ concatMap subFieldExprs fs
  Tuple          _  es _  _         -> concatMap subExprs es
  List           _  es _  _         -> concatMap subExprs es
  ListCompr      _  e1 _  _  _ _    -> subExprs e1
  EnumFrom       _  e1 _  _         -> subExprs e1
  EnumFromThen   _  e1 _  e2 _ _    -> concatMap subExprs [e1, e2]
  EnumFromTo     _  e1 _  e2 _      -> concatMap subExprs [e1, e2]
  EnumFromThenTo _  e1 _  e2 _ e3 _ -> concatMap subExprs [e1, e2, e3]
  UnaryMinus     _  e1              -> subExprs e1
  Apply          e1 e2              -> concatMap subExprs [e1, e2]
  InfixApply     e1 _  e2           -> concatMap subExprs [e1, e2]
  LeftSection    _  e1 _  _         -> subExprs e1
  RightSection   _  _  e2 _         -> subExprs e2
  Lambda         _  _  _  e1        -> subExprs e1
  Let            _  ds _  e1        -> (concatMap declExprs ds) ++ (subExprs e1)
  Do             _  _  e1           -> subExprs e1
  IfThenElse     _  e1 _  e2 _ e3   -> concatMap subExprs [e1, e2, e3]
  Case           _  _  e1 _  _      -> subExprs e1
 where
   declExprs d = case d of
     PatternDecl _ rhs -> rhsExprs rhs
     _                 -> []
   rhsExprs rhs = case rhs of
     SimpleRhs _ e1 _ _ -> subExprs e1
     _                  -> []
   subFieldExprs (Field _ _ e1) = subExprs e1