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
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300

{- |
    Module      :  ACSpans.PositionUtils
    Description :  Auxiliary functions for positions

    This module provides some auxiliary functions concerning positions.
-}





module ACSpans.PositionUtils where

import qualified ACSpans.Ident     as I
import           ACSpans.Span (Pos, Span, start, virtualPos)
import           ACSpans.SpanAST
import           ACSpans.Token

-- |Return the line of a position
line :: Pos -> Int
line pos = fst pos

-- |Return the column of a position
col :: Pos -> Int
col pos = snd pos

-- |Check whether the columns in a list of positions are all equal
allColEq :: [Pos] -> Bool
allColEq xs = case xs of
  [] -> True
  _  -> all (== col (head xs)) (map col (tail xs))

-- |Check whether the lines in a list of positions are all equal
allLinesEq :: [Pos] -> Bool
allLinesEq xs = case xs of
  [] -> True
  _  -> all (== line (head xs)) (map line (tail xs))

-- |move given position by n columns
moveColBy :: Pos -> Int -> Pos
moveColBy (l,c) n = (l, c + n)

--- |Change a position by a delta
--- @param l  -  line
--- @param c  -  column
--- @param ml -  delta line
--- @param mc -  delta column
--- @return   -  input position changed by delta line and delta column

relocate :: Pos -> (Int, Int) -> Pos
relocate (l, c) (ml, mc) = (l + ml, c + mc)

-- ----------------------------------------------------------------------------
-- Get positions of AST elements
-- ----------------------------------------------------------------------------

-- |Get start position of QualIdent
qidPos :: I.QualIdent -> Pos
qidPos (I.QualIdent _ i) = idPos i

-- |Get start position of Ident
idPos :: I.Ident -> Pos
idPos (I.Ident sp _ _) = start sp

-- |Get start position of Ident that might be surrounded by
-- |some kind of symbols, e.g. parens or backticks
sidPos :: I.SymIdent -> Pos
sidPos (I.SymIdent mpl i _) = case mpl of
  Just pl -> start pl
  Nothing -> idPos i

-- |Get start position of QualIdent that might be surrounded by
-- |some kind of symbols, e.g. parens or backticks
sqidPos :: I.SymQualIdent -> Pos
sqidPos (I.SymQualIdent mpl qi _) = case mpl of
  Just pl -> start pl
  Nothing -> qidPos qi

-- |Get start position of Export
exportPos :: Export -> Pos
exportPos e = case e of
  Export         qi          -> sqidPos qi
  ExportTypeWith qi _  _ _ _ -> qidPos  qi
  ExportTypeAll  qi _  _ _   -> qidPos  qi
  ExportModule   _  mi       -> start (I.midSpan mi)

-- |Get start position of Decl
declPos :: Decl -> Pos
declPos d = case d of
  PatternDecl pat _ -> patPos pat
  _                 -> virtualPos

-- |Get position of equality sign in Decl
declPosEq :: Decl -> Pos
declPosEq d = case d of
  PatternDecl _ rhs -> rhsPos rhs
  _                 -> virtualPos

-- |Get position of Infix Keyword
infPos :: Infix -> Pos
infPos i = case i of
  InfixL s -> start s
  InfixR s -> start s
  Infix  s -> start s

-- |Get start position of ConstrDecl
constrDeclPos :: ConstrDecl -> Pos
constrDeclPos c = case c of
  ConstrDecl _ i  _       -> idPos i
  ConOpDecl  _ te _ _     -> typeExprPos te
  RecordDecl _ i  _ _ _ _ -> idPos i

-- |Get Type positions of ConstrDecl
constrDeclConstrTypePos :: ConstrDecl -> [Pos]
constrDeclConstrTypePos cd = case cd of
  ConstrDecl _ _ cts       -> if null cts
                                then [virtualPos]
                                else map typeExprPos cts
  RecordDecl _ _ _ fds _ _ -> if null fds
                                then [virtualPos]
                                else map fieldDeclTEPos fds
  _                        -> [virtualPos]

-- |Get position of first Type in ConstrDecl
firstCDConstrTypePos :: ConstrDecl -> Pos
firstCDConstrTypePos cd = case cd of
  ConstrDecl _ _ cts -> if null cts then virtualPos else typeExprPos $ head cts
  _                  -> virtualPos

-- |Get position of commas in FieldDecl
fieldDeclCPos :: FieldDecl -> [Pos]
fieldDeclCPos (FieldDecl _ sps _ _) = map start sps

-- | Get position of doublecolon in FieldDecl
fieldDeclDCPos :: FieldDecl -> Pos
fieldDeclDCPos (FieldDecl _ _ sp _) = start sp

-- |Get position of first constructor in FieldDecl
fieldDeclIDPos :: FieldDecl -> Pos
fieldDeclIDPos (FieldDecl ids _ _ _) = idPos $ head ids

-- |Get position of TypeExpression in FieldDecl
fieldDeclTEPos :: FieldDecl -> Pos
fieldDeclTEPos (FieldDecl _ _ _ te) = typeExprPos te

-- |Get start position of TypeExpr
typeExprPos :: TypeExpr -> Pos
typeExprPos te = case te of
  ConstructorType msp qi _ _ -> case msp of
                                    Just sp -> start sp
                                    Nothing -> qidPos qi
  VariableType    i          -> idPos i
  TupleType       sp   _ _ _ -> start sp
  ListType        sp   _ _   -> start sp
  ArrowType       te1 _ _    -> typeExprPos te1
  ParenType       sp   _ _   -> start sp

-- |Get position of equality sign or rightarrow in Rhs
rhsPos :: Rhs -> Pos
rhsPos rhs = case rhs of
  SimpleRhs  sp _ _ _   -> start sp
  GuardedRhs sp _ _ _ _ -> start sp

-- |Get start position of Lhs
lhsPos :: Lhs -> Pos
lhsPos lhs = case lhs of
  FunLhs si _   -> sidPos si
  OpLhs  p  _ _ -> patPos p
  ApLhs  l  _   -> lhsPos l

-- |Get start position of CondExpr
condExprPos :: CondExpr -> Pos
condExprPos (CondExpr _ sp _) = start sp

-- |Get start position of Literal
litPos :: Literal -> Pos
litPos l = case l of
  Char   sp _ -> start sp
  Int    sp _ -> start sp
  Float  sp _ -> start sp
  String sp _ -> start sp

-- |Get start position of Pattern
patPos :: Pattern -> Pos
patPos p = case p of
  LiteralPattern     l             -> litPos l
  NegativePattern    i   _         -> idPos  i
  VariablePattern    i             -> idPos  i
  ConstructorPattern qi  _         -> qidPos qi
  InfixPattern       pat _   _     -> patPos pat
  ParenPattern       _   pat _     -> patPos pat
  RecordPattern      qi  _   _ _ _ -> qidPos qi
  TuplePattern       spl  _   _ _  -> start spl
  ListPattern        spl  _   _ _  -> start spl
  AsPattern          i   _   _     -> idPos  i
  LazyPattern        sp  _         -> start sp
  FunctionPattern    qi  _         -> qidPos qi
  InfixFuncPattern   pat _   _     -> patPos pat

-- |Get start position of Expression
exprPos :: Expression -> Pos
exprPos e = case e of
  Literal        l               -> litPos   l
  Variable       v               -> sqidPos  v
  Constructor    qi              -> sqidPos  qi
  Paren          spl _ _         -> start spl
  Typed          e1 _ _          -> exprPos  e1
  Record         qi _ _ _ _      -> qidPos   qi
  RecordUpdate   e1 _ _ _ _      -> exprPos  e1
  Tuple          spl _ _ _       -> start spl
  List           spl _ _ _       -> start spl
  ListCompr      spl _ _ _ _ _   -> start spl
  EnumFrom       spl _ _ _       -> start spl
  EnumFromThen   spl _ _ _ _ _   -> start spl
  EnumFromTo     spl _ _ _ _     -> start spl
  EnumFromThenTo spl _ _ _ _ _ _ -> start spl
  UnaryMinus     i  _            -> idPos    i
  Apply          e1 _            -> exprPos  e1
  InfixApply     e1 _ _          -> exprPos  e1
  LeftSection    spl _ _ _       -> start spl
  RightSection   spl _ _ _       -> start spl
  Lambda         sp  _ _ _       -> start sp
  Let            sp  _ _ _       -> start sp
  Do             sp  _ _         -> start sp
  IfThenElse     spi _ _ _ _ _   -> start spi
  Case           _  sp _ _ _     -> start sp

-- |Get start position of Statement
stmtPos :: Statement -> Pos
stmtPos s = case s of
  StmtExpr       e -> exprPos e
  StmtDecl     sp _ -> start sp
  StmtBind _ pat _ -> patPos pat

-- |Get position of rightarrow in Alt
altPos :: Alt -> Pos
altPos (Alt _ rhs) = rhsPos rhs

-- span computation

-- TODO: Remove when curry-frontend was extended correspondingly

-- | Compute for a given token and its starting position a corresponding span
spanToken :: (Pos,Token) -> (Span,Token)
spanToken posTok = case posTok of
  (p,   CharTok c) -> ((p, moveColBy p (length (show c) - 1)), CharTok c)
  (p,    IntTok i) -> ((p, moveColBy p (length (show i) - 1)), IntTok i)
  (p,  FloatTok f) -> ((p, moveColBy p (length (show f) - 1)), FloatTok f)
  (p, StringTok s) -> ((p, moveColBy p (length (show s) - 1)), StringTok s)

  (p,        Id i) -> ((p, moveColBy p (length i - 1)), Id i)
  (p,      QId qi) -> ((p, moveColBy p (length qi - 1)), QId qi)
  (p,       Sym s) -> ((p, moveColBy p (length s - 1)), Sym s)
  (p,     QSym qs) -> ((p, moveColBy p (length qs - 1)), QSym qs)

  (p,     KW_case) -> ((p, moveColBy p 3), KW_case)
  (p,     KW_data) -> ((p, moveColBy p 3), KW_data)
  (p,       KW_do) -> ((p, moveColBy p 1), KW_do)
  (p,     KW_else) -> ((p, moveColBy p 3), KW_else)
  (p, KW_external) -> ((p, moveColBy p 7), KW_external)
  (p,    KW_fcase) -> ((p, moveColBy p 4), KW_fcase)
  (p,  KW_foreign) -> ((p, moveColBy p 6), KW_foreign)
  (p,     KW_free) -> ((p, moveColBy p 3), KW_free)
  (p,       KW_if) -> ((p, moveColBy p 1), KW_if)
  (p,   KW_import) -> ((p, moveColBy p 5), KW_import)
  (p,       KW_in) -> ((p, moveColBy p 1), KW_in)
  (p,    KW_infix) -> ((p, moveColBy p 4), KW_infix)
  (p,   KW_infixl) -> ((p, moveColBy p 5), KW_infixl)
  (p,   KW_infixr) -> ((p, moveColBy p 5), KW_infixr)
  (p,      KW_let) -> ((p, moveColBy p 2), KW_let)
  (p,   KW_module) -> ((p, moveColBy p 5), KW_module)
  (p,  KW_newtype) -> ((p, moveColBy p 6), KW_newtype)
  (p,       KW_of) -> ((p, moveColBy p 1), KW_of)
  (p,     KW_then) -> ((p, moveColBy p 3), KW_then)
  (p,     KW_type) -> ((p, moveColBy p 3), KW_type)
  (p,    KW_where) -> ((p, moveColBy p 4), KW_where)

  (p,      DotDot) -> ((p, moveColBy p 1), DotDot)
  (p, DoubleColon) -> ((p, moveColBy p 1), DoubleColon)
  (p,   LeftArrow) -> ((p, moveColBy p 1), LeftArrow)
  (p,  RightArrow) -> ((p, moveColBy p 1), RightArrow)
  (p,        Bind) -> ((p, moveColBy p 1), Bind)
  (p,      Select) -> ((p, moveColBy p 1), Select)

  (p,        Id_as) -> ((p, moveColBy p 1), Id_as)
  (p,     Id_ccall) -> ((p, moveColBy p 4), Id_ccall)
  (p,    Id_forall) -> ((p, moveColBy p 5), Id_forall)
  (p,    Id_hiding) -> ((p, moveColBy p 5), Id_hiding)
  (p, Id_interface) -> ((p, moveColBy p 8), Id_interface)
  (p, Id_primitive) -> ((p, moveColBy p 8), Id_primitive)
  (p, Id_qualified) -> ((p, moveColBy p 8), Id_qualified)

  (p, SymMinusDot) -> ((p, moveColBy p 1), SymMinusDot)

  (p, PragmaLanguage    ) -> ((p, moveColBy p 11), PragmaLanguage)
  (p, PragmaOptions ms s) -> ((p, moveColBy p (length s + 11)), PragmaOptions ms s)
  (p, PragmaHiding      ) -> ((p, moveColBy p 9), PragmaHiding)
  (p, PragmaEnd         ) -> ((p, moveColBy p 2), PragmaEnd)

  (p,             tok) -> ((p, p), tok)