-
Notifications
You must be signed in to change notification settings - Fork 95
/
Fixity.hs
449 lines (387 loc) · 19.3 KB
/
Fixity.hs
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
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Language.Haskell.Exts.Fixity
-- Copyright : (c) Niklas Broberg 2009
-- License : BSD-style (see the file LICENSE.txt)
--
-- Maintainer : Niklas Broberg, d00nibro@chalmers.se
-- Stability : stable
-- Portability : portable
--
-- Fixity information to give the parser so that infix operators can
-- be parsed properly.
--
-----------------------------------------------------------------------------
module Language.Haskell.Exts.Fixity
(
-- * Fixity representation
Fixity(..)
-- | The following three functions all create lists of
-- fixities from textual representations of operators.
-- The intended usage is e.g.
--
-- > fixs = infixr_ 0 ["$","$!","`seq`"]
--
-- Note that the operators are expected as you would
-- write them infix, i.e. with ` characters surrounding
-- /varid/ operators, and /varsym/ operators written as is.
, infix_, infixl_, infixr_
-- ** Collections of fixities
, preludeFixities, baseFixities
-- * Applying fixities to an AST
, AppFixity(..)
) where
import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.SrcLoc
import Control.Monad (when, (<=<), liftM, liftM2, liftM3, liftM4)
import Data.Traversable (mapM)
import Data.Maybe (fromMaybe)
import Data.Typeable
import Data.Data hiding (Fixity)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$))
#endif
import Prelude hiding (mapM)
-- | Operator fixities are represented by their associativity
-- (left, right or none) and their precedence (0-9).
data Fixity = Fixity (Assoc ()) Int (QName ())
deriving (Eq,Ord,Show,Typeable,Data)
-- | All AST elements that may include expressions which in turn may
-- need fixity tweaking will be instances of this class.
class AppFixity ast where
-- | Tweak any expressions in the element to account for the
-- fixities given. Assumes that all operator expressions are
-- fully left associative chains to begin with.
applyFixities :: Monad m => [Fixity] -- ^ The fixities to account for.
-> ast SrcSpanInfo -- ^ The element to tweak.
-> m (ast SrcSpanInfo) -- ^ The same element, but with operator expressions updated, or a failure.
assocNone, assocLeft, assocRight :: Assoc ()
assocNone = AssocNone ()
assocLeft = AssocLeft ()
assocRight = AssocRight ()
instance AppFixity Exp where
applyFixities fixs' = infFix fixs' <=< leafFix fixs'
where -- This is the real meat case. We can assume a left-associative list to begin with.
infFix fixs (InfixApp l2 a op2 z) = do
e <- infFix fixs a
let fixup (a1,p1) (a2,p2) y pre = do
when (p1 == p2 && (a1 /= a2 || a1 == assocNone)) -- Ambiguous infix expression!
$ fail "Ambiguous infix expression"
if p1 > p2 || p1 == p2 && (a1 == assocLeft || a2 == assocNone) -- Already right order
then return $ InfixApp l2 e op2 z
else liftM pre (infFix fixs $ InfixApp (ann y <++> ann z) y op2 z)
case e of
InfixApp _ x op1 y -> fixup (askFixity fixs op1) (askFixity fixs op2) y (InfixApp l2 x op1)
NegApp _ y -> fixup prefixMinusFixity (askFixity fixs op2) y (NegApp l2)
_ -> return $ InfixApp l2 e op2 z
infFix _ e = return e
--ambOps l = ParseFailed (getPointLoc l) $ "Ambiguous infix expression"
instance AppFixity Pat where
applyFixities fixs' = infFix fixs' <=< leafFixP fixs'
where -- This is the real meat case. We can assume a left-associative list to begin with.
infFix fixs (PInfixApp l2 a op2 z) = do
p <- infFix fixs a
let fixup (a1,p1) (a2,p2) y pre = do
when (p1 == p2 && (a1 /= a2 || a1 == assocNone )) -- Ambiguous infix expression!
$ fail "Ambiguous infix expression"
if p1 > p2 || p1 == p2 && (a1 == assocLeft || a2 == assocNone) -- Already right order
then return $ PInfixApp l2 p op2 z
else liftM pre (infFix fixs $ PInfixApp (ann y <++> ann z) y op2 z)
case p of
PInfixApp _ x op1 y -> fixup (askFixityP fixs op1) (askFixityP fixs op2) y (PInfixApp l2 x op1)
_ -> return $ PInfixApp l2 p op2 z
infFix _ p = return p
-- Internal: lookup associativity and precedence of an operator
askFixity :: [Fixity] -> QOp l -> (Assoc (), Int)
askFixity xs k = askFix xs (f (() <$ k))
where
f (QVarOp _ x) = g x
f (QConOp _ x) = g x
g (Special _ (Cons _)) = UnQual () (Symbol () ":")
g x = x
-- Same using patterns
askFixityP :: [Fixity] -> QName l -> (Assoc (), Int)
askFixityP xs qn = askFix xs (g (() <$ qn))
where
g (Special _ (Cons _)) = UnQual () (Symbol () ":")
g x = x
askFix :: [Fixity] -> QName l -> (Assoc (), Int)
askFix xs = \k -> lookupWithDefault (assocLeft, 9) (() <$ k) mp
where
lookupWithDefault def k mp' = fromMaybe def $ lookup k mp'
mp = [(x,(a,p)) | Fixity a p x <- xs]
-- | Built-in fixity for prefix minus
prefixMinusFixity :: (Assoc (), Int)
prefixMinusFixity = (AssocLeft (), 6)
-- | All fixities defined in the Prelude.
preludeFixities :: [Fixity]
preludeFixities = concat
[infixr_ 9 ["."]
,infixl_ 9 ["!!"]
,infixr_ 8 ["^","^^","**"]
,infixl_ 7 ["*","/","`quot`","`rem`","`div`","`mod`"]
,infixl_ 6 ["+","-"]
,infixr_ 5 [":","++"]
,infix_ 4 ["==","/=","<","<=",">=",">","`elem`","`notElem`"]
,infixl_ 4 ["<$>","<$","<*>","<*","*>"]
,infixr_ 3 ["&&"]
,infixr_ 2 ["||"]
,infixl_ 1 [">>",">>="]
,infixr_ 1 ["=<<"]
,infixr_ 0 ["$","$!","`seq`"]
]
-- | All fixities defined in the base package.
--
-- Note that the @+++@ operator appears in both Control.Arrows and
-- Text.ParserCombinators.ReadP. The listed precedence for @+++@ in
-- this list is that of Control.Arrows.
baseFixities :: [Fixity]
baseFixities = preludeFixities ++ concat
[infixl_ 9 ["!","//","!:"]
,infixr_ 9 ["`Compose`"]
,infixl_ 8 ["`shift`","`rotate`","`shiftL`","`shiftR`","`rotateL`","`rotateR`"]
,infixl_ 7 [".&.","%"]
,infixr_ 6 ["<>"]
,infixl_ 6 ["`xor`"]
,infix_ 6 [":+"]
,infixl_ 5 [".|."]
,infixr_ 5 ["+:+","<++","<+>","<|"] -- fixity conflict for +++ between ReadP and Arrow
,infix_ 5 ["\\\\"]
,infixl_ 4 ["<**>","$>","<$","<$!>"]
,infix_ 4 ["`elemP`","`notElemP`",":~:",":~~:"]
,infixl_ 3 ["<|>"]
,infixr_ 3 ["&&&","***"]
,infixr_ 2 ["+++","|||"]
,infixr_ 1 ["<=<",">=>",">>>","<<<","^<<","<<^","^>>",">>^"]
,infixl_ 1 ["&"]
,infixl_ 0 ["`on`"]
,infixr_ 0 ["`par`","`pseq`"]
]
infixr_, infixl_, infix_ :: Int -> [String] -> [Fixity]
infixr_ = fixity assocRight
infixl_ = fixity assocLeft
infix_ = fixity assocNone
-- Internal: help function for the above definitions.
fixity :: Assoc () -> Int -> [String] -> [Fixity]
fixity a p = map (Fixity a p . op)
where
op ('`':xs) = UnQual () $ Ident () $ init xs
op xs = UnQual () $ Symbol () xs
-------------------------------------------------------------------
-- Boilerplate - yuck!! Everything below here is internal stuff
instance AppFixity Module where
applyFixities fixs (Module l mmh prs imp decls) =
liftM (Module l mmh prs imp) $ appFixDecls mmn fixs decls
where mmn = getMmn mmh
getMmn (Just (ModuleHead _ n _ _)) = Just n
getMmn _ = Nothing
applyFixities fixs (XmlPage l mn os xn xas mexp cs) =
liftM3 (XmlPage l mn os xn) (fix xas) (fix mexp) (fix cs)
where fix xs = mapM (applyFixities fixs) xs
applyFixities fixs (XmlHybrid l mmh prs imp decls xn xas mexp cs) =
liftM4 (flip (XmlHybrid l mmh prs imp) xn) (appFixDecls mmn fixs decls)
(fixe xas) (fixe mexp) (fixe cs)
where mmn = getMmn mmh
getMmn (Just (ModuleHead _ n _ _)) = Just n
getMmn _ = Nothing
fixe xs = let extraFixs = getFixities mmn decls
in mapM (applyFixities (fixs++extraFixs)) xs
instance AppFixity Decl where
applyFixities fixs decl = case decl of
ClassDecl l ctxt dh deps cdecls -> liftM (ClassDecl l ctxt dh deps) $ mapM (mapM fix) cdecls
InstDecl l olp ih idecls -> liftM (InstDecl l olp ih) $ mapM (mapM fix) idecls
SpliceDecl l spl -> liftM (SpliceDecl l) $ fix spl
FunBind l matches -> liftM (FunBind l) $ mapM fix matches
PatBind l p rhs bs ->
let extraFix x = applyFixities (fixs ++ maybe [] getBindFixities bs) x
in liftM3 (PatBind l) (extraFix p) (extraFix rhs) (mapM extraFix bs)
AnnPragma l ann' -> liftM (AnnPragma l) $ fix ann'
PatSyn l p1 p2 dir -> liftM (PatSyn l p1 p2) (fix dir)
_ -> return decl
where fix x = applyFixities fixs x
instance AppFixity PatternSynDirection where
applyFixities fixs dir = case dir of
ExplicitBidirectional l ds -> liftM (ExplicitBidirectional l) (mapM fix ds)
_ -> return dir
where fix x = applyFixities fixs x
appFixDecls :: Monad m => Maybe (ModuleName SrcSpanInfo) -> [Fixity] -> [Decl SrcSpanInfo] -> m [Decl SrcSpanInfo]
appFixDecls mmdl fixs decls =
let extraFixs = getFixities mmdl decls
in mapM (applyFixities (fixs++extraFixs)) decls
getFixities :: Maybe (ModuleName l) -> [Decl l] -> [Fixity]
getFixities mmdl = concatMap (getFixity mmdl)
getFixity :: Maybe (ModuleName l) -> Decl l -> [Fixity]
getFixity mmdl d =
case d of
InfixDecl _ a mp ops -> let p = fromMaybe 9 mp
in map (Fixity (scrub a) p) (concatMap g (map scrub ops))
ClassDecl _ _ _ _ cds -> maybe [] (concatMap getClassFixity) cds
_ -> []
where g (VarOp _ x) = f x
g (ConOp _ x) = f x
f x = case mmdl of
Nothing -> [UnQual () x]
Just m -> [Qual () (scrub m) x, UnQual () x]
getClassFixity (ClsDecl _ cd) = getFixity mmdl cd
getClassFixity _ = []
scrub :: Functor f => f a -> f ()
scrub f = () <$ f
getBindFixities :: Binds l -> [Fixity]
getBindFixities bs = case bs of
BDecls _ ds -> getFixities Nothing ds
_ -> []
instance AppFixity Annotation where
applyFixities fixs ann' = case ann' of
Ann l n e -> liftM (Ann l n) $ fix e
TypeAnn l n e -> liftM (TypeAnn l n) $ fix e
ModuleAnn l e -> liftM (ModuleAnn l) $ fix e
where fix x = applyFixities fixs x
instance AppFixity ClassDecl where
applyFixities fixs (ClsDecl l decl) = liftM (ClsDecl l) $ applyFixities fixs decl
applyFixities _ cdecl = return cdecl
instance AppFixity InstDecl where
applyFixities fixs (InsDecl l decl) = liftM (InsDecl l) $ applyFixities fixs decl
applyFixities _ idecl = return idecl
instance AppFixity Match where
applyFixities fixs match = case match of
Match l n ps rhs bs -> liftM3 (Match l n) (mapM (fix bs) ps) (fix bs rhs) (mapM (fix bs) bs)
InfixMatch l a n ps rhs bs -> liftM4 (flip (InfixMatch l) n) (fix bs a) (mapM (fix bs) ps) (fix bs rhs) (mapM (fix bs) bs)
where fix bs x = applyFixities fixs' x
where fixs' = fixs ++ maybe [] getBindFixities bs
instance AppFixity Rhs where
applyFixities fixs rhs = case rhs of
UnGuardedRhs l e -> liftM (UnGuardedRhs l) $ fix e
GuardedRhss l grhss -> liftM (GuardedRhss l) $ mapM fix grhss
where fix x = applyFixities fixs x
instance AppFixity GuardedRhs where
applyFixities fixs (GuardedRhs l stmts e) = liftM2 (GuardedRhs l) (mapM fix stmts) $ fix e
where fix x = applyFixities fixs x
instance AppFixity PatField where
applyFixities fixs (PFieldPat l n p) = liftM (PFieldPat l n) $ applyFixities fixs p
applyFixities _ pf = return pf
instance AppFixity RPat where
applyFixities fixs rp' = case rp' of
RPOp l rp op -> liftM (flip (RPOp l) op) $ fix rp
RPEither l a b -> liftM2 (RPEither l) (fix a) (fix b)
RPSeq l rps -> liftM (RPSeq l) $ mapM fix rps
RPGuard l p stmts -> liftM2 (RPGuard l) (fix p) $ mapM fix stmts
RPCAs l n rp -> liftM (RPCAs l n) $ fix rp
RPAs l n rp -> liftM (RPAs l n) $ fix rp
RPParen l rp -> liftM (RPParen l) $ fix rp
RPPat l p -> liftM (RPPat l) $ fix p
where fix x = applyFixities fixs x
instance AppFixity PXAttr where
applyFixities fixs (PXAttr l n p) = liftM (PXAttr l n) $ applyFixities fixs p
instance AppFixity Stmt where
applyFixities fixs stmt = case stmt of
Generator l p e -> liftM2 (Generator l) (fix p) (fix e)
Qualifier l e -> liftM (Qualifier l) $ fix e
LetStmt l bs -> liftM (LetStmt l) $ fix bs -- special behavior
RecStmt l stmts -> liftM (RecStmt l) $ mapM fix stmts
where fix x = applyFixities fixs x
instance AppFixity Binds where
applyFixities fixs bs = case bs of
BDecls l decls -> liftM (BDecls l) $ appFixDecls Nothing fixs decls -- special behavior
IPBinds l ips -> liftM (IPBinds l) $ mapM fix ips
where fix x = applyFixities fixs x
instance AppFixity IPBind where
applyFixities fixs (IPBind l n e) = liftM (IPBind l n) $ applyFixities fixs e
instance AppFixity FieldUpdate where
applyFixities fixs (FieldUpdate l n e) = liftM (FieldUpdate l n) $ applyFixities fixs e
applyFixities _ fup = return fup
instance AppFixity Alt where
applyFixities fixs (Alt l p galts bs) = liftM3 (Alt l) (fix p) (fix galts) (mapM fix bs)
where fix x = applyFixities fixs x
instance AppFixity QualStmt where
applyFixities fixs qstmt = case qstmt of
QualStmt l s -> liftM (QualStmt l) $ fix s
ThenTrans l e -> liftM (ThenTrans l) $ fix e
ThenBy l e1 e2 -> liftM2 (ThenBy l) (fix e1) (fix e2)
GroupBy l e -> liftM (GroupBy l) (fix e)
GroupUsing l e -> liftM (GroupUsing l) (fix e)
GroupByUsing l e1 e2 -> liftM2 (GroupByUsing l) (fix e1) (fix e2)
where fix x = applyFixities fixs x
instance AppFixity Bracket where
applyFixities fixs br = case br of
ExpBracket l e -> liftM (ExpBracket l) $ fix e
PatBracket l p -> liftM (PatBracket l) $ fix p
DeclBracket l ds -> liftM (DeclBracket l) $ mapM fix ds
_ -> return br
where fix x = applyFixities fixs x
instance AppFixity Splice where
applyFixities fixs (ParenSplice l e) = liftM (ParenSplice l) $ applyFixities fixs e
applyFixities _ s = return s
instance AppFixity XAttr where
applyFixities fixs (XAttr l n e) = liftM (XAttr l n) $ applyFixities fixs e
-- the boring boilerplate stuff for expressions too
-- Recursively fixes the "leaves" of the infix chains,
-- without yet touching the chain itself. We assume all chains are
-- left-associate to begin with.
leafFix :: Monad m => [Fixity] -> Exp SrcSpanInfo -> m (Exp SrcSpanInfo)
leafFix fixs e' = case e' of
InfixApp l e1 op e2 -> liftM2 (flip (InfixApp l) op) (leafFix fixs e1) (fix e2)
App l e1 e2 -> liftM2 (App l) (fix e1) (fix e2)
NegApp l e -> liftM (NegApp l) $ fix e
Lambda l pats e -> liftM2 (Lambda l) (mapM fix pats) $ fix e
Let l bs e ->
let extraFix x = applyFixities (fixs ++ getBindFixities bs) x
in liftM2 (Let l) (extraFix bs) $ extraFix e
If l e a b -> liftM3 (If l) (fix e) (fix a) (fix b)
MultiIf l alts -> liftM (MultiIf l) (mapM fix alts)
Case l e alts -> liftM2 (Case l) (fix e) $ mapM fix alts
Do l stmts -> liftM (Do l) $ mapM fix stmts
MDo l stmts -> liftM (MDo l) $ mapM fix stmts
Tuple l bx exps -> liftM (Tuple l bx) $ mapM fix exps
List l exps -> liftM (List l) $ mapM fix exps
Paren l e -> liftM (Paren l) $ fix e
LeftSection l e op -> liftM (flip (LeftSection l) op) (fix e)
RightSection l op e -> liftM (RightSection l op) $ fix e
RecConstr l n fups -> liftM (RecConstr l n) $ mapM fix fups
RecUpdate l e fups -> liftM2 (RecUpdate l) (fix e) $ mapM fix fups
EnumFrom l e -> liftM (EnumFrom l) $ fix e
EnumFromTo l e1 e2 -> liftM2 (EnumFromTo l) (fix e1) (fix e2)
EnumFromThen l e1 e2 -> liftM2 (EnumFromThen l) (fix e1) (fix e2)
EnumFromThenTo l e1 e2 e3 -> liftM3 (EnumFromThenTo l) (fix e1) (fix e2) (fix e3)
ListComp l e quals -> liftM2 (ListComp l) (fix e) $ mapM fix quals
ParComp l e qualss -> liftM2 (ParComp l) (fix e) $ mapM (mapM fix) qualss
ExpTypeSig l e t -> liftM (flip (ExpTypeSig l) t) (fix e)
BracketExp l b -> liftM (BracketExp l) $ fix b
SpliceExp l s -> liftM (SpliceExp l) $ fix s
XTag l n ats mexp cs -> liftM3 (XTag l n) (mapM fix ats) (mapM fix mexp) (mapM fix cs)
XETag l n ats mexp -> liftM2 (XETag l n) (mapM fix ats) (mapM fix mexp)
XExpTag l e -> liftM (XExpTag l) $ fix e
XChildTag l cs -> liftM (XChildTag l) $ mapM fix cs
Proc l p e -> liftM2 (Proc l) (fix p) (fix e)
LeftArrApp l e1 e2 -> liftM2 (LeftArrApp l) (fix e1) (fix e2)
RightArrApp l e1 e2 -> liftM2 (RightArrApp l) (fix e1) (fix e2)
LeftArrHighApp l e1 e2 -> liftM2 (LeftArrHighApp l) (fix e1) (fix e2)
RightArrHighApp l e1 e2 -> liftM2 (RightArrHighApp l) (fix e1) (fix e2)
CorePragma l s e -> liftM (CorePragma l s) (fix e)
SCCPragma l s e -> liftM (SCCPragma l s) (fix e)
GenPragma l s ab cd e -> liftM (GenPragma l s ab cd) (fix e)
LCase l alts -> liftM (LCase l) $ mapM fix alts
_ -> return e'
where
fix x = applyFixities fixs x
leafFixP :: Monad m => [Fixity] -> Pat SrcSpanInfo -> m (Pat SrcSpanInfo)
leafFixP fixs p' = case p' of
PInfixApp l p1 op p2 -> liftM2 (flip (PInfixApp l) op) (leafFixP fixs p1) (fix p2)
PApp l n ps -> liftM (PApp l n) $ mapM fix ps
PTuple l bx ps -> liftM (PTuple l bx) $ mapM fix ps
PList l ps -> liftM (PList l) $ mapM fix ps
PParen l p -> liftM (PParen l) $ fix p
PRec l n pfs -> liftM (PRec l n) $ mapM fix pfs
PAsPat l n p -> liftM (PAsPat l n) $ fix p
PIrrPat l p -> liftM (PIrrPat l) $ fix p
PatTypeSig l p t -> liftM (flip (PatTypeSig l) t) (fix p)
PViewPat l e p -> liftM2 (PViewPat l) (fix e) (fix p)
PRPat l rps -> liftM (PRPat l) $ mapM fix rps
PXTag l n ats mp ps -> liftM3 (PXTag l n) (mapM fix ats) (mapM fix mp) (mapM fix ps)
PXETag l n ats mp -> liftM2 (PXETag l n) (mapM fix ats) (mapM fix mp)
PXPatTag l p -> liftM (PXPatTag l) $ fix p
PXRPats l rps -> liftM (PXRPats l) $ mapM fix rps
PBangPat l p -> liftM (PBangPat l) $ fix p
_ -> return p'
where fix x = applyFixities fixs x