template-haskell: define `MonadFail Q` instance
[ghc.git] / libraries / template-haskell / Language / Haskell / TH / Syntax.hs
1 {-# LANGUAGE CPP, DeriveDataTypeable,
2 DeriveGeneric, FlexibleInstances, DefaultSignatures,
3 RankNTypes, RoleAnnotations, ScopedTypeVariables #-}
4
5 {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}
6
7 #if MIN_VERSION_base(4,9,0)
8 # define HAS_MONADFAIL 1
9 #endif
10
11 -----------------------------------------------------------------------------
12 -- |
13 -- Module : Language.Haskell.Syntax
14 -- Copyright : (c) The University of Glasgow 2003
15 -- License : BSD-style (see the file libraries/base/LICENSE)
16 --
17 -- Maintainer : libraries@haskell.org
18 -- Stability : experimental
19 -- Portability : portable
20 --
21 -- Abstract syntax definitions for Template Haskell.
22 --
23 -----------------------------------------------------------------------------
24
25 module Language.Haskell.TH.Syntax
26 ( module Language.Haskell.TH.Syntax
27 -- * Language extensions
28 , module Language.Haskell.TH.LanguageExtensions
29 ) where
30
31 import Data.Data hiding (Fixity(..))
32 import Data.IORef
33 import System.IO.Unsafe ( unsafePerformIO )
34 import Control.Monad (liftM)
35 import System.IO ( hPutStrLn, stderr )
36 import Data.Char ( isAlpha, isAlphaNum, isUpper )
37 import Data.Int
38 import Data.Word
39 import Data.Ratio
40 import GHC.Generics ( Generic )
41 import GHC.Lexeme ( startsVarSym, startsVarId )
42 import Language.Haskell.TH.LanguageExtensions
43 import Numeric.Natural
44
45 #if HAS_MONADFAIL
46 import qualified Control.Monad.Fail as Fail
47 #endif
48
49 -----------------------------------------------------
50 --
51 -- The Quasi class
52 --
53 -----------------------------------------------------
54
55 #if HAS_MONADFAIL
56 class Fail.MonadFail m => Quasi m where
57 #else
58 class Monad m => Quasi m where
59 #endif
60 qNewName :: String -> m Name
61 -- ^ Fresh names
62
63 -- Error reporting and recovery
64 qReport :: Bool -> String -> m () -- ^ Report an error (True) or warning (False)
65 -- ...but carry on; use 'fail' to stop
66 qRecover :: m a -- ^ the error handler
67 -> m a -- ^ action which may fail
68 -> m a -- ^ Recover from the monadic 'fail'
69
70 -- Inspect the type-checker's environment
71 qLookupName :: Bool -> String -> m (Maybe Name)
72 -- True <=> type namespace, False <=> value namespace
73 qReify :: Name -> m Info
74 qReifyFixity :: Name -> m (Maybe Fixity)
75 qReifyInstances :: Name -> [Type] -> m [Dec]
76 -- Is (n tys) an instance?
77 -- Returns list of matching instance Decs
78 -- (with empty sub-Decs)
79 -- Works for classes and type functions
80 qReifyRoles :: Name -> m [Role]
81 qReifyAnnotations :: Data a => AnnLookup -> m [a]
82 qReifyModule :: Module -> m ModuleInfo
83 qReifyConStrictness :: Name -> m [DecidedStrictness]
84
85 qLocation :: m Loc
86
87 qRunIO :: IO a -> m a
88 -- ^ Input/output (dangerous)
89
90 qAddDependentFile :: FilePath -> m ()
91
92 qAddTopDecls :: [Dec] -> m ()
93
94 qAddModFinalizer :: Q () -> m ()
95
96 qGetQ :: Typeable a => m (Maybe a)
97
98 qPutQ :: Typeable a => a -> m ()
99
100 qIsExtEnabled :: Extension -> m Bool
101 qExtsEnabled :: m [Extension]
102
103 -----------------------------------------------------
104 -- The IO instance of Quasi
105 --
106 -- This instance is used only when running a Q
107 -- computation in the IO monad, usually just to
108 -- print the result. There is no interesting
109 -- type environment, so reification isn't going to
110 -- work.
111 --
112 -----------------------------------------------------
113
114 instance Quasi IO where
115 qNewName s = do { n <- readIORef counter
116 ; writeIORef counter (n+1)
117 ; return (mkNameU s n) }
118
119 qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
120 qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
121
122 qLookupName _ _ = badIO "lookupName"
123 qReify _ = badIO "reify"
124 qReifyFixity _ = badIO "reifyFixity"
125 qReifyInstances _ _ = badIO "reifyInstances"
126 qReifyRoles _ = badIO "reifyRoles"
127 qReifyAnnotations _ = badIO "reifyAnnotations"
128 qReifyModule _ = badIO "reifyModule"
129 qReifyConStrictness _ = badIO "reifyConStrictness"
130 qLocation = badIO "currentLocation"
131 qRecover _ _ = badIO "recover" -- Maybe we could fix this?
132 qAddDependentFile _ = badIO "addDependentFile"
133 qAddTopDecls _ = badIO "addTopDecls"
134 qAddModFinalizer _ = badIO "addModFinalizer"
135 qGetQ = badIO "getQ"
136 qPutQ _ = badIO "putQ"
137 qIsExtEnabled _ = badIO "isExtEnabled"
138 qExtsEnabled = badIO "extsEnabled"
139
140 qRunIO m = m
141
142 badIO :: String -> IO a
143 badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
144 ; fail "Template Haskell failure" }
145
146 -- Global variable to generate unique symbols
147 counter :: IORef Int
148 {-# NOINLINE counter #-}
149 counter = unsafePerformIO (newIORef 0)
150
151
152 -----------------------------------------------------
153 --
154 -- The Q monad
155 --
156 -----------------------------------------------------
157
158 newtype Q a = Q { unQ :: forall m. Quasi m => m a }
159
160 -- \"Runs\" the 'Q' monad. Normal users of Template Haskell
161 -- should not need this function, as the splice brackets @$( ... )@
162 -- are the usual way of running a 'Q' computation.
163 --
164 -- This function is primarily used in GHC internals, and for debugging
165 -- splices by running them in 'IO'.
166 --
167 -- Note that many functions in 'Q', such as 'reify' and other compiler
168 -- queries, are not supported when running 'Q' in 'IO'; these operations
169 -- simply fail at runtime. Indeed, the only operations guaranteed to succeed
170 -- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
171 runQ :: Quasi m => Q a -> m a
172 runQ (Q m) = m
173
174 instance Monad Q where
175 Q m >>= k = Q (m >>= \x -> unQ (k x))
176 (>>) = (*>)
177 #if !HAS_MONADFAIL
178 fail s = report True s >> Q (fail "Q monad failure")
179 #else
180 fail = Fail.fail
181
182 instance Fail.MonadFail Q where
183 fail s = report True s >> Q (Fail.fail "Q monad failure")
184 #endif
185
186 instance Functor Q where
187 fmap f (Q x) = Q (fmap f x)
188
189 instance Applicative Q where
190 pure x = Q (pure x)
191 Q f <*> Q x = Q (f <*> x)
192 Q m *> Q n = Q (m *> n)
193
194 -----------------------------------------------------
195 --
196 -- The TExp type
197 --
198 -----------------------------------------------------
199
200 type role TExp nominal -- See Note [Role of TExp]
201 newtype TExp a = TExp { unType :: Exp }
202
203 unTypeQ :: Q (TExp a) -> Q Exp
204 unTypeQ m = do { TExp e <- m
205 ; return e }
206
207 unsafeTExpCoerce :: Q Exp -> Q (TExp a)
208 unsafeTExpCoerce m = do { e <- m
209 ; return (TExp e) }
210
211 {- Note [Role of TExp]
212 ~~~~~~~~~~~~~~~~~~~~~~
213 TExp's argument must have a nominal role, not phantom as would
214 be inferred (Trac #8459). Consider
215
216 e :: TExp Age
217 e = MkAge 3
218
219 foo = $(coerce e) + 4::Int
220
221 The splice will evaluate to (MkAge 3) and you can't add that to
222 4::Int. So you can't coerce a (TExp Age) to a (TExp Int). -}
223
224 ----------------------------------------------------
225 -- Packaged versions for the programmer, hiding the Quasi-ness
226
227 {- |
228 Generate a fresh name, which cannot be captured.
229
230 For example, this:
231
232 @f = $(do
233 nm1 <- newName \"x\"
234 let nm2 = 'mkName' \"x\"
235 return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1)))
236 )@
237
238 will produce the splice
239
240 >f = \x0 -> \x -> x0
241
242 In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@,
243 and is not captured by the binding @VarP nm2@.
244
245 Although names generated by @newName@ cannot /be captured/, they can
246 /capture/ other names. For example, this:
247
248 >g = $(do
249 > nm1 <- newName "x"
250 > let nm2 = mkName "x"
251 > return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2)))
252 > )
253
254 will produce the splice
255
256 >g = \x -> \x0 -> x0
257
258 since the occurrence @VarE nm2@ is captured by the innermost binding
259 of @x@, namely @VarP nm1@.
260 -}
261 newName :: String -> Q Name
262 newName s = Q (qNewName s)
263
264 -- | Report an error (True) or warning (False),
265 -- but carry on; use 'fail' to stop.
266 report :: Bool -> String -> Q ()
267 report b s = Q (qReport b s)
268 {-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
269
270 -- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
271 reportError :: String -> Q ()
272 reportError = report True
273
274 -- | Report a warning to the user, and carry on.
275 reportWarning :: String -> Q ()
276 reportWarning = report False
277
278 -- | Recover from errors raised by 'reportError' or 'fail'.
279 recover :: Q a -- ^ handler to invoke on failure
280 -> Q a -- ^ computation to run
281 -> Q a
282 recover (Q r) (Q m) = Q (qRecover r m)
283
284 -- We don't export lookupName; the Bool isn't a great API
285 -- Instead we export lookupTypeName, lookupValueName
286 lookupName :: Bool -> String -> Q (Maybe Name)
287 lookupName ns s = Q (qLookupName ns s)
288
289 -- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
290 lookupTypeName :: String -> Q (Maybe Name)
291 lookupTypeName s = Q (qLookupName True s)
292
293 -- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
294 lookupValueName :: String -> Q (Maybe Name)
295 lookupValueName s = Q (qLookupName False s)
296
297 {-
298 Note [Name lookup]
299 ~~~~~~~~~~~~~~~~~~
300 -}
301 {- $namelookup #namelookup#
302 The functions 'lookupTypeName' and 'lookupValueName' provide
303 a way to query the current splice's context for what names
304 are in scope. The function 'lookupTypeName' queries the type
305 namespace, whereas 'lookupValueName' queries the value namespace,
306 but the functions are otherwise identical.
307
308 A call @lookupValueName s@ will check if there is a value
309 with name @s@ in scope at the current splice's location. If
310 there is, the @Name@ of this value is returned;
311 if not, then @Nothing@ is returned.
312
313 The returned name cannot be \"captured\".
314 For example:
315
316 > f = "global"
317 > g = $( do
318 > Just nm <- lookupValueName "f"
319 > [| let f = "local" in $( varE nm ) |]
320
321 In this case, @g = \"global\"@; the call to @lookupValueName@
322 returned the global @f@, and this name was /not/ captured by
323 the local definition of @f@.
324
325 The lookup is performed in the context of the /top-level/ splice
326 being run. For example:
327
328 > f = "global"
329 > g = $( [| let f = "local" in
330 > $(do
331 > Just nm <- lookupValueName "f"
332 > varE nm
333 > ) |] )
334
335 Again in this example, @g = \"global\"@, because the call to
336 @lookupValueName@ queries the context of the outer-most @$(...)@.
337
338 Operators should be queried without any surrounding parentheses, like so:
339
340 > lookupValueName "+"
341
342 Qualified names are also supported, like so:
343
344 > lookupValueName "Prelude.+"
345 > lookupValueName "Prelude.map"
346
347 -}
348
349
350 {- | 'reify' looks up information about the 'Name'.
351
352 It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName'
353 to ensure that we are reifying from the right namespace. For instance, in this context:
354
355 > data D = D
356
357 which @D@ does @reify (mkName \"D\")@ return information about? (Answer: @D@-the-type, but don't rely on it.)
358 To ensure we get information about @D@-the-value, use 'lookupValueName':
359
360 > do
361 > Just nm <- lookupValueName "D"
362 > reify nm
363
364 and to get information about @D@-the-type, use 'lookupTypeName'.
365 -}
366 reify :: Name -> Q Info
367 reify v = Q (qReify v)
368
369 {- | @reifyFixity nm@ attempts to find a fixity declaration for @nm@. For
370 example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
371 @reifyFixity 'foo@ would return @'Just' ('Fixity' 7 'InfixR')@. If the function
372 @bar@ does not have a fixity declaration, then @reifyFixity 'bar@ returns
373 'Nothing', so you may assume @bar@ has 'defaultFixity'.
374 -}
375 reifyFixity :: Name -> Q (Maybe Fixity)
376 reifyFixity nm = Q (qReifyFixity nm)
377
378 {- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is,
379 if @nm@ is the name of a type class, then all instances of this class at the types @tys@
380 are returned. Alternatively, if @nm@ is the name of a data family or type family,
381 all instances of this family at the types @tys@ are returned.
382 -}
383 reifyInstances :: Name -> [Type] -> Q [InstanceDec]
384 reifyInstances cls tys = Q (qReifyInstances cls tys)
385
386 {- | @reifyRoles nm@ returns the list of roles associated with the parameters of
387 the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon.
388 The returned list should never contain 'InferR'.
389 -}
390 reifyRoles :: Name -> Q [Role]
391 reifyRoles nm = Q (qReifyRoles nm)
392
393 -- | @reifyAnnotations target@ returns the list of annotations
394 -- associated with @target@. Only the annotations that are
395 -- appropriately typed is returned. So if you have @Int@ and @String@
396 -- annotations for the same target, you have to call this function twice.
397 reifyAnnotations :: Data a => AnnLookup -> Q [a]
398 reifyAnnotations an = Q (qReifyAnnotations an)
399
400 -- | @reifyModule mod@ looks up information about module @mod@. To
401 -- look up the current module, call this function with the return
402 -- value of @thisModule@.
403 reifyModule :: Module -> Q ModuleInfo
404 reifyModule m = Q (qReifyModule m)
405
406 -- | @reifyConStrictness nm@ looks up the strictness information for the fields
407 -- of the constructor with the name @nm@. Note that the strictness information
408 -- that 'reifyConStrictness' returns may not correspond to what is written in
409 -- the source code. For example, in the following data declaration:
410 --
411 -- @
412 -- data Pair a = Pair a a
413 -- @
414 --
415 -- 'reifyConStrictness' would return @['DecidedLazy', DecidedLazy]@ under most
416 -- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
417 -- @-XStrictData@ language extension was enabled.
418 reifyConStrictness :: Name -> Q [DecidedStrictness]
419 reifyConStrictness n = Q (qReifyConStrictness n)
420
421 -- | Is the list of instances returned by 'reifyInstances' nonempty?
422 isInstance :: Name -> [Type] -> Q Bool
423 isInstance nm tys = do { decs <- reifyInstances nm tys
424 ; return (not (null decs)) }
425
426 -- | The location at which this computation is spliced.
427 location :: Q Loc
428 location = Q qLocation
429
430 -- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
431 -- Take care: you are guaranteed the ordering of calls to 'runIO' within
432 -- a single 'Q' computation, but not about the order in which splices are run.
433 --
434 -- Note: for various murky reasons, stdout and stderr handles are not
435 -- necessarily flushed when the compiler finishes running, so you should
436 -- flush them yourself.
437 runIO :: IO a -> Q a
438 runIO m = Q (qRunIO m)
439
440 -- | Record external files that runIO is using (dependent upon).
441 -- The compiler can then recognize that it should re-compile the Haskell file
442 -- when an external file changes.
443 --
444 -- Expects an absolute file path.
445 --
446 -- Notes:
447 --
448 -- * ghc -M does not know about these dependencies - it does not execute TH.
449 --
450 -- * The dependency is based on file content, not a modification time
451 addDependentFile :: FilePath -> Q ()
452 addDependentFile fp = Q (qAddDependentFile fp)
453
454 -- | Add additional top-level declarations. The added declarations will be type
455 -- checked along with the current declaration group.
456 addTopDecls :: [Dec] -> Q ()
457 addTopDecls ds = Q (qAddTopDecls ds)
458
459 -- | Add a finalizer that will run in the Q monad after the current module has
460 -- been type checked. This only makes sense when run within a top-level splice.
461 addModFinalizer :: Q () -> Q ()
462 addModFinalizer act = Q (qAddModFinalizer (unQ act))
463
464 -- | Get state from the 'Q' monad.
465 getQ :: Typeable a => Q (Maybe a)
466 getQ = Q qGetQ
467
468 -- | Replace the state in the 'Q' monad.
469 putQ :: Typeable a => a -> Q ()
470 putQ x = Q (qPutQ x)
471
472 -- | Determine whether the given language extension is enabled in the 'Q' monad.
473 isExtEnabled :: Extension -> Q Bool
474 isExtEnabled ext = Q (qIsExtEnabled ext)
475
476 -- | List all enabled language extensions.
477 extsEnabled :: Q [Extension]
478 extsEnabled = Q qExtsEnabled
479
480 instance Quasi Q where
481 qNewName = newName
482 qReport = report
483 qRecover = recover
484 qReify = reify
485 qReifyFixity = reifyFixity
486 qReifyInstances = reifyInstances
487 qReifyRoles = reifyRoles
488 qReifyAnnotations = reifyAnnotations
489 qReifyModule = reifyModule
490 qReifyConStrictness = reifyConStrictness
491 qLookupName = lookupName
492 qLocation = location
493 qRunIO = runIO
494 qAddDependentFile = addDependentFile
495 qAddTopDecls = addTopDecls
496 qAddModFinalizer = addModFinalizer
497 qGetQ = getQ
498 qPutQ = putQ
499 qIsExtEnabled = isExtEnabled
500 qExtsEnabled = extsEnabled
501
502
503 ----------------------------------------------------
504 -- The following operations are used solely in DsMeta when desugaring brackets
505 -- They are not necessary for the user, who can use ordinary return and (>>=) etc
506
507 returnQ :: a -> Q a
508 returnQ = return
509
510 bindQ :: Q a -> (a -> Q b) -> Q b
511 bindQ = (>>=)
512
513 sequenceQ :: [Q a] -> Q [a]
514 sequenceQ = sequence
515
516
517 -----------------------------------------------------
518 --
519 -- The Lift class
520 --
521 -----------------------------------------------------
522
523 -- | A 'Lift' instance can have any of its values turned into a Template
524 -- Haskell expression. This is needed when a value used within a Template
525 -- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@) but not
526 -- at the top level. As an example:
527 --
528 -- > add1 :: Int -> Q Exp
529 -- > add1 x = [| x + 1 |]
530 --
531 -- Template Haskell has no way of knowing what value @x@ will take on at
532 -- splice-time, so it requires the type of @x@ to be an instance of 'Lift'.
533 --
534 -- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@
535 -- GHC language extension:
536 --
537 -- > {-# LANGUAGE DeriveLift #-}
538 -- > module Foo where
539 -- >
540 -- > import Language.Haskell.TH.Syntax
541 -- >
542 -- > data Bar a = Bar1 a (Bar a) | Bar2 String
543 -- > deriving Lift
544 class Lift t where
545 -- | Turn a value into a Template Haskell expression, suitable for use in
546 -- a splice.
547 lift :: t -> Q Exp
548 default lift :: Data t => t -> Q Exp
549 lift = liftData
550
551 -- If you add any instances here, consider updating test th/TH_Lift
552 instance Lift Integer where
553 lift x = return (LitE (IntegerL x))
554
555 instance Lift Int where
556 lift x = return (LitE (IntegerL (fromIntegral x)))
557
558 instance Lift Int8 where
559 lift x = return (LitE (IntegerL (fromIntegral x)))
560
561 instance Lift Int16 where
562 lift x = return (LitE (IntegerL (fromIntegral x)))
563
564 instance Lift Int32 where
565 lift x = return (LitE (IntegerL (fromIntegral x)))
566
567 instance Lift Int64 where
568 lift x = return (LitE (IntegerL (fromIntegral x)))
569
570 instance Lift Word where
571 lift x = return (LitE (IntegerL (fromIntegral x)))
572
573 instance Lift Word8 where
574 lift x = return (LitE (IntegerL (fromIntegral x)))
575
576 instance Lift Word16 where
577 lift x = return (LitE (IntegerL (fromIntegral x)))
578
579 instance Lift Word32 where
580 lift x = return (LitE (IntegerL (fromIntegral x)))
581
582 instance Lift Word64 where
583 lift x = return (LitE (IntegerL (fromIntegral x)))
584
585 instance Lift Natural where
586 lift x = return (LitE (IntegerL (fromIntegral x)))
587
588 instance Integral a => Lift (Ratio a) where
589 lift x = return (LitE (RationalL (toRational x)))
590
591 instance Lift Float where
592 lift x = return (LitE (RationalL (toRational x)))
593
594 instance Lift Double where
595 lift x = return (LitE (RationalL (toRational x)))
596
597 instance Lift Char where
598 lift x = return (LitE (CharL x))
599
600 instance Lift Bool where
601 lift True = return (ConE trueName)
602 lift False = return (ConE falseName)
603
604 instance Lift a => Lift (Maybe a) where
605 lift Nothing = return (ConE nothingName)
606 lift (Just x) = liftM (ConE justName `AppE`) (lift x)
607
608 instance (Lift a, Lift b) => Lift (Either a b) where
609 lift (Left x) = liftM (ConE leftName `AppE`) (lift x)
610 lift (Right y) = liftM (ConE rightName `AppE`) (lift y)
611
612 instance Lift a => Lift [a] where
613 lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
614
615 liftString :: String -> Q Exp
616 -- Used in TcExpr to short-circuit the lifting for strings
617 liftString s = return (LitE (StringL s))
618
619 instance Lift () where
620 lift () = return (ConE (tupleDataName 0))
621
622 instance (Lift a, Lift b) => Lift (a, b) where
623 lift (a, b)
624 = liftM TupE $ sequence [lift a, lift b]
625
626 instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where
627 lift (a, b, c)
628 = liftM TupE $ sequence [lift a, lift b, lift c]
629
630 instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where
631 lift (a, b, c, d)
632 = liftM TupE $ sequence [lift a, lift b, lift c, lift d]
633
634 instance (Lift a, Lift b, Lift c, Lift d, Lift e)
635 => Lift (a, b, c, d, e) where
636 lift (a, b, c, d, e)
637 = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]
638
639 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
640 => Lift (a, b, c, d, e, f) where
641 lift (a, b, c, d, e, f)
642 = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
643
644 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
645 => Lift (a, b, c, d, e, f, g) where
646 lift (a, b, c, d, e, f, g)
647 = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
648
649 -- TH has a special form for literal strings,
650 -- which we should take advantage of.
651 -- NB: the lhs of the rule has no args, so that
652 -- the rule will apply to a 'lift' all on its own
653 -- which happens to be the way the type checker
654 -- creates it.
655 {-# RULES "TH:liftString" lift = \s -> return (LitE (StringL s)) #-}
656
657
658 trueName, falseName :: Name
659 trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True"
660 falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False"
661
662 nothingName, justName :: Name
663 nothingName = mkNameG DataName "base" "GHC.Base" "Nothing"
664 justName = mkNameG DataName "base" "GHC.Base" "Just"
665
666 leftName, rightName :: Name
667 leftName = mkNameG DataName "base" "Data.Either" "Left"
668 rightName = mkNameG DataName "base" "Data.Either" "Right"
669
670 -----------------------------------------------------
671 --
672 -- Generic Lift implementations
673 --
674 -----------------------------------------------------
675
676 -- | 'dataToQa' is an internal utility function for constructing generic
677 -- conversion functions from types with 'Data' instances to various
678 -- quasi-quoting representations. See the source of 'dataToExpQ' and
679 -- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@
680 -- and @appQ@ are overloadable to account for different syntax for
681 -- expressions and patterns; @antiQ@ allows you to override type-specific
682 -- cases, a common usage is just @const Nothing@, which results in
683 -- no overloading.
684 dataToQa :: forall a k q. Data a
685 => (Name -> k)
686 -> (Lit -> Q q)
687 -> (k -> [Q q] -> Q q)
688 -> (forall b . Data b => b -> Maybe (Q q))
689 -> a
690 -> Q q
691 dataToQa mkCon mkLit appCon antiQ t =
692 case antiQ t of
693 Nothing ->
694 case constrRep constr of
695 AlgConstr _ ->
696 appCon (mkCon funOrConName) conArgs
697 where
698 funOrConName :: Name
699 funOrConName =
700 case showConstr constr of
701 "(:)" -> Name (mkOccName ":")
702 (NameG DataName
703 (mkPkgName "ghc-prim")
704 (mkModName "GHC.Types"))
705 con@"[]" -> Name (mkOccName con)
706 (NameG DataName
707 (mkPkgName "ghc-prim")
708 (mkModName "GHC.Types"))
709 con@('(':_) -> Name (mkOccName con)
710 (NameG DataName
711 (mkPkgName "ghc-prim")
712 (mkModName "GHC.Tuple"))
713 -- It is possible for a Data instance to be defined such
714 -- that toConstr uses a Constr defined using a function,
715 -- not a data constructor. In such a case, we must take
716 -- care to build the Name using mkNameG_v (for values),
717 -- not mkNameG_d (for data constructors).
718 -- See Trac #10796.
719 fun@(x:_) | startsVarSym x || startsVarId x
720 -> mkNameG_v tyconPkg tyconMod fun
721 con -> mkNameG_d tyconPkg tyconMod con
722 where
723 tycon :: TyCon
724 tycon = (typeRepTyCon . typeOf) t
725
726 tyconPkg, tyconMod :: String
727 tyconPkg = tyConPackage tycon
728 tyconMod = tyConModule tycon
729
730 conArgs :: [Q q]
731 conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t
732 IntConstr n ->
733 mkLit $ IntegerL n
734 FloatConstr n ->
735 mkLit $ RationalL n
736 CharConstr c ->
737 mkLit $ CharL c
738 where
739 constr :: Constr
740 constr = toConstr t
741
742 Just y -> y
743
744 -- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the
745 -- same value, in the SYB style. It is generalized to take a function
746 -- override type-specific cases; see 'liftData' for a more commonly
747 -- used variant.
748 dataToExpQ :: Data a
749 => (forall b . Data b => b -> Maybe (Q Exp))
750 -> a
751 -> Q Exp
752 dataToExpQ = dataToQa varOrConE litE (foldl appE)
753 where
754 -- Make sure that VarE is used if the Constr value relies on a
755 -- function underneath the surface (instead of a constructor).
756 -- See Trac #10796.
757 varOrConE s =
758 case nameSpace s of
759 Just VarName -> return (VarE s)
760 Just DataName -> return (ConE s)
761 _ -> fail $ "Can't construct an expression from name "
762 ++ showName s
763 appE x y = do { a <- x; b <- y; return (AppE a b)}
764 litE c = return (LitE c)
765
766 -- | 'liftData' is a variant of 'lift' in the 'Lift' type class which
767 -- works for any type with a 'Data' instance.
768 liftData :: Data a => a -> Q Exp
769 liftData = dataToExpQ (const Nothing)
770
771 -- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same
772 -- value, in the SYB style. It takes a function to handle type-specific cases,
773 -- alternatively, pass @const Nothing@ to get default behavior.
774 dataToPatQ :: Data a
775 => (forall b . Data b => b -> Maybe (Q Pat))
776 -> a
777 -> Q Pat
778 dataToPatQ = dataToQa id litP conP
779 where litP l = return (LitP l)
780 conP n ps =
781 case nameSpace n of
782 Just DataName -> do
783 ps' <- sequence ps
784 return (ConP n ps')
785 _ -> fail $ "Can't construct a pattern from name "
786 ++ showName n
787
788 -----------------------------------------------------
789 -- Names and uniques
790 -----------------------------------------------------
791
792 newtype ModName = ModName String -- Module name
793 deriving (Show,Eq,Ord,Typeable,Data,Generic)
794
795 newtype PkgName = PkgName String -- package name
796 deriving (Show,Eq,Ord,Typeable,Data,Generic)
797
798 -- | Obtained from 'reifyModule' and 'thisModule'.
799 data Module = Module PkgName ModName -- package qualified module name
800 deriving (Show,Eq,Ord,Typeable,Data,Generic)
801
802 newtype OccName = OccName String
803 deriving (Show,Eq,Ord,Typeable,Data,Generic)
804
805 mkModName :: String -> ModName
806 mkModName s = ModName s
807
808 modString :: ModName -> String
809 modString (ModName m) = m
810
811
812 mkPkgName :: String -> PkgName
813 mkPkgName s = PkgName s
814
815 pkgString :: PkgName -> String
816 pkgString (PkgName m) = m
817
818
819 -----------------------------------------------------
820 -- OccName
821 -----------------------------------------------------
822
823 mkOccName :: String -> OccName
824 mkOccName s = OccName s
825
826 occString :: OccName -> String
827 occString (OccName occ) = occ
828
829
830 -----------------------------------------------------
831 -- Names
832 -----------------------------------------------------
833 --
834 -- For "global" names ('NameG') we need a totally unique name,
835 -- so we must include the name-space of the thing
836 --
837 -- For unique-numbered things ('NameU'), we've got a unique reference
838 -- anyway, so no need for name space
839 --
840 -- For dynamically bound thing ('NameS') we probably want them to
841 -- in a context-dependent way, so again we don't want the name
842 -- space. For example:
843 --
844 -- > let v = mkName "T" in [| data $v = $v |]
845 --
846 -- Here we use the same Name for both type constructor and data constructor
847 --
848 --
849 -- NameL and NameG are bound *outside* the TH syntax tree
850 -- either globally (NameG) or locally (NameL). Ex:
851 --
852 -- > f x = $(h [| (map, x) |])
853 --
854 -- The 'map' will be a NameG, and 'x' wil be a NameL
855 --
856 -- These Names should never appear in a binding position in a TH syntax tree
857
858 {- $namecapture #namecapture#
859 Much of 'Name' API is concerned with the problem of /name capture/, which
860 can be seen in the following example.
861
862 > f expr = [| let x = 0 in $expr |]
863 > ...
864 > g x = $( f [| x |] )
865 > h y = $( f [| y |] )
866
867 A naive desugaring of this would yield:
868
869 > g x = let x = 0 in x
870 > h y = let x = 0 in y
871
872 All of a sudden, @g@ and @h@ have different meanings! In this case,
873 we say that the @x@ in the RHS of @g@ has been /captured/
874 by the binding of @x@ in @f@.
875
876 What we actually want is for the @x@ in @f@ to be distinct from the
877 @x@ in @g@, so we get the following desugaring:
878
879 > g x = let x' = 0 in x
880 > h y = let x' = 0 in y
881
882 which avoids name capture as desired.
883
884 In the general case, we say that a @Name@ can be captured if
885 the thing it refers to can be changed by adding new declarations.
886 -}
887
888 {- |
889 An abstract type representing names in the syntax tree.
890
891 'Name's can be constructed in several ways, which come with different
892 name-capture guarantees (see "Language.Haskell.TH.Syntax#namecapture" for
893 an explanation of name capture):
894
895 * the built-in syntax @'f@ and @''T@ can be used to construct names,
896 The expression @'f@ gives a @Name@ which refers to the value @f@
897 currently in scope, and @''T@ gives a @Name@ which refers to the
898 type @T@ currently in scope. These names can never be captured.
899
900 * 'lookupValueName' and 'lookupTypeName' are similar to @'f@ and
901 @''T@ respectively, but the @Name@s are looked up at the point
902 where the current splice is being run. These names can never be
903 captured.
904
905 * 'newName' monadically generates a new name, which can never
906 be captured.
907
908 * 'mkName' generates a capturable name.
909
910 Names constructed using @newName@ and @mkName@ may be used in bindings
911 (such as @let x = ...@ or @\x -> ...@), but names constructed using
912 @lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not.
913 -}
914 data Name = Name OccName NameFlavour deriving (Typeable, Data, Eq, Generic)
915
916 instance Ord Name where
917 -- check if unique is different before looking at strings
918 (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp`
919 (o1 `compare` o2)
920
921 data NameFlavour
922 = NameS -- ^ An unqualified name; dynamically bound
923 | NameQ ModName -- ^ A qualified name; dynamically bound
924 | NameU !Int -- ^ A unique local name
925 | NameL !Int -- ^ Local name bound outside of the TH AST
926 | NameG NameSpace PkgName ModName -- ^ Global name bound outside of the TH AST:
927 -- An original name (occurrences only, not binders)
928 -- Need the namespace too to be sure which
929 -- thing we are naming
930 deriving ( Typeable, Data, Eq, Ord, Show, Generic )
931
932 data NameSpace = VarName -- ^ Variables
933 | DataName -- ^ Data constructors
934 | TcClsName -- ^ Type constructors and classes; Haskell has them
935 -- in the same name space for now.
936 deriving( Eq, Ord, Show, Data, Typeable, Generic )
937
938 type Uniq = Int
939
940 -- | The name without its module prefix.
941 --
942 -- ==== __Examples__
943 --
944 -- >>> nameBase ''Data.Either.Either
945 -- "Either"
946 -- >>> nameBase (mkName "foo")
947 -- "foo"
948 -- >>> nameBase (mkName "Module.foo")
949 -- "foo"
950 nameBase :: Name -> String
951 nameBase (Name occ _) = occString occ
952
953 -- | Module prefix of a name, if it exists.
954 --
955 -- ==== __Examples__
956 --
957 -- >>> nameModule ''Data.Either.Either
958 -- Just "Data.Either"
959 -- >>> nameModule (mkName "foo")
960 -- Nothing
961 -- >>> nameModule (mkName "Module.foo")
962 -- Just "Module"
963 nameModule :: Name -> Maybe String
964 nameModule (Name _ (NameQ m)) = Just (modString m)
965 nameModule (Name _ (NameG _ _ m)) = Just (modString m)
966 nameModule _ = Nothing
967
968 -- | A name's package, if it exists.
969 --
970 -- ==== __Examples__
971 --
972 -- >>> namePackage ''Data.Either.Either
973 -- Just "base"
974 -- >>> namePackage (mkName "foo")
975 -- Nothing
976 -- >>> namePackage (mkName "Module.foo")
977 -- Nothing
978 namePackage :: Name -> Maybe String
979 namePackage (Name _ (NameG _ p _)) = Just (pkgString p)
980 namePackage _ = Nothing
981
982 -- | Returns whether a name represents an occurrence of a top-level variable
983 -- ('VarName'), data constructor ('DataName'), type constructor, or type class
984 -- ('TcClsName'). If we can't be sure, it returns 'Nothing'.
985 --
986 -- ==== __Examples__
987 --
988 -- >>> nameSpace 'Prelude.id
989 -- Just VarName
990 -- >>> nameSpace (mkName "id")
991 -- Nothing -- only works for top-level variable names
992 -- >>> nameSpace 'Data.Maybe.Just
993 -- Just DataName
994 -- >>> nameSpace ''Data.Maybe.Maybe
995 -- Just TcClsName
996 -- >>> nameSpace ''Data.Ord.Ord
997 -- Just TcClsName
998 nameSpace :: Name -> Maybe NameSpace
999 nameSpace (Name _ (NameG ns _ _)) = Just ns
1000 nameSpace _ = Nothing
1001
1002 {- |
1003 Generate a capturable name. Occurrences of such names will be
1004 resolved according to the Haskell scoping rules at the occurrence
1005 site.
1006
1007 For example:
1008
1009 > f = [| pi + $(varE (mkName "pi")) |]
1010 > ...
1011 > g = let pi = 3 in $f
1012
1013 In this case, @g@ is desugared to
1014
1015 > g = Prelude.pi + 3
1016
1017 Note that @mkName@ may be used with qualified names:
1018
1019 > mkName "Prelude.pi"
1020
1021 See also 'Language.Haskell.TH.Lib.dyn' for a useful combinator. The above example could
1022 be rewritten using 'dyn' as
1023
1024 > f = [| pi + $(dyn "pi") |]
1025 -}
1026 mkName :: String -> Name
1027 -- The string can have a '.', thus "Foo.baz",
1028 -- giving a dynamically-bound qualified name,
1029 -- in which case we want to generate a NameQ
1030 --
1031 -- Parse the string to see if it has a "." in it
1032 -- so we know whether to generate a qualified or unqualified name
1033 -- It's a bit tricky because we need to parse
1034 --
1035 -- > Foo.Baz.x as Qual Foo.Baz x
1036 --
1037 -- So we parse it from back to front
1038 mkName str
1039 = split [] (reverse str)
1040 where
1041 split occ [] = Name (mkOccName occ) NameS
1042 split occ ('.':rev) | not (null occ)
1043 , is_rev_mod_name rev
1044 = Name (mkOccName occ) (NameQ (mkModName (reverse rev)))
1045 -- The 'not (null occ)' guard ensures that
1046 -- mkName "&." = Name "&." NameS
1047 -- The 'is_rev_mod' guards ensure that
1048 -- mkName ".&" = Name ".&" NameS
1049 -- mkName "^.." = Name "^.." NameS -- Trac #8633
1050 -- mkName "Data.Bits..&" = Name ".&" (NameQ "Data.Bits")
1051 -- This rather bizarre case actually happened; (.&.) is in Data.Bits
1052 split occ (c:rev) = split (c:occ) rev
1053
1054 -- Recognises a reversed module name xA.yB.C,
1055 -- with at least one component,
1056 -- and each component looks like a module name
1057 -- (i.e. non-empty, starts with capital, all alpha)
1058 is_rev_mod_name rev_mod_str
1059 | (compt, rest) <- break (== '.') rev_mod_str
1060 , not (null compt), isUpper (last compt), all is_mod_char compt
1061 = case rest of
1062 [] -> True
1063 (_dot : rest') -> is_rev_mod_name rest'
1064 | otherwise
1065 = False
1066
1067 is_mod_char c = isAlphaNum c || c == '_' || c == '\''
1068
1069 -- | Only used internally
1070 mkNameU :: String -> Uniq -> Name
1071 mkNameU s u = Name (mkOccName s) (NameU u)
1072
1073 -- | Only used internally
1074 mkNameL :: String -> Uniq -> Name
1075 mkNameL s u = Name (mkOccName s) (NameL u)
1076
1077 -- | Used for 'x etc, but not available to the programmer
1078 mkNameG :: NameSpace -> String -> String -> String -> Name
1079 mkNameG ns pkg modu occ
1080 = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName modu))
1081
1082 mkNameS :: String -> Name
1083 mkNameS n = Name (mkOccName n) NameS
1084
1085 mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name
1086 mkNameG_v = mkNameG VarName
1087 mkNameG_tc = mkNameG TcClsName
1088 mkNameG_d = mkNameG DataName
1089
1090 data NameIs = Alone | Applied | Infix
1091
1092 showName :: Name -> String
1093 showName = showName' Alone
1094
1095 showName' :: NameIs -> Name -> String
1096 showName' ni nm
1097 = case ni of
1098 Alone -> nms
1099 Applied
1100 | pnam -> nms
1101 | otherwise -> "(" ++ nms ++ ")"
1102 Infix
1103 | pnam -> "`" ++ nms ++ "`"
1104 | otherwise -> nms
1105 where
1106 -- For now, we make the NameQ and NameG print the same, even though
1107 -- NameQ is a qualified name (so what it means depends on what the
1108 -- current scope is), and NameG is an original name (so its meaning
1109 -- should be independent of what's in scope.
1110 -- We may well want to distinguish them in the end.
1111 -- Ditto NameU and NameL
1112 nms = case nm of
1113 Name occ NameS -> occString occ
1114 Name occ (NameQ m) -> modString m ++ "." ++ occString occ
1115 Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ
1116 Name occ (NameU u) -> occString occ ++ "_" ++ show u
1117 Name occ (NameL u) -> occString occ ++ "_" ++ show u
1118
1119 pnam = classify nms
1120
1121 -- True if we are function style, e.g. f, [], (,)
1122 -- False if we are operator style, e.g. +, :+
1123 classify "" = False -- shouldn't happen; . operator is handled below
1124 classify (x:xs) | isAlpha x || (x `elem` "_[]()") =
1125 case dropWhile (/='.') xs of
1126 (_:xs') -> classify xs'
1127 [] -> True
1128 | otherwise = False
1129
1130 instance Show Name where
1131 show = showName
1132
1133 -- Tuple data and type constructors
1134 -- | Tuple data constructor
1135 tupleDataName :: Int -> Name
1136 -- | Tuple type constructor
1137 tupleTypeName :: Int -> Name
1138
1139 tupleDataName 0 = mk_tup_name 0 DataName
1140 tupleDataName 1 = error "tupleDataName 1"
1141 tupleDataName n = mk_tup_name (n-1) DataName
1142
1143 tupleTypeName 0 = mk_tup_name 0 TcClsName
1144 tupleTypeName 1 = error "tupleTypeName 1"
1145 tupleTypeName n = mk_tup_name (n-1) TcClsName
1146
1147 mk_tup_name :: Int -> NameSpace -> Name
1148 mk_tup_name n_commas space
1149 = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod)
1150 where
1151 occ = mkOccName ('(' : replicate n_commas ',' ++ ")")
1152 tup_mod = mkModName "GHC.Tuple"
1153
1154 -- Unboxed tuple data and type constructors
1155 -- | Unboxed tuple data constructor
1156 unboxedTupleDataName :: Int -> Name
1157 -- | Unboxed tuple type constructor
1158 unboxedTupleTypeName :: Int -> Name
1159
1160 unboxedTupleDataName 0 = error "unboxedTupleDataName 0"
1161 unboxedTupleDataName 1 = error "unboxedTupleDataName 1"
1162 unboxedTupleDataName n = mk_unboxed_tup_name (n-1) DataName
1163
1164 unboxedTupleTypeName 0 = error "unboxedTupleTypeName 0"
1165 unboxedTupleTypeName 1 = error "unboxedTupleTypeName 1"
1166 unboxedTupleTypeName n = mk_unboxed_tup_name (n-1) TcClsName
1167
1168 mk_unboxed_tup_name :: Int -> NameSpace -> Name
1169 mk_unboxed_tup_name n_commas space
1170 = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod)
1171 where
1172 occ = mkOccName ("(#" ++ replicate n_commas ',' ++ "#)")
1173 tup_mod = mkModName "GHC.Tuple"
1174
1175
1176
1177 -----------------------------------------------------
1178 -- Locations
1179 -----------------------------------------------------
1180
1181 data Loc
1182 = Loc { loc_filename :: String
1183 , loc_package :: String
1184 , loc_module :: String
1185 , loc_start :: CharPos
1186 , loc_end :: CharPos }
1187 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1188
1189 type CharPos = (Int, Int) -- ^ Line and character position
1190
1191
1192 -----------------------------------------------------
1193 --
1194 -- The Info returned by reification
1195 --
1196 -----------------------------------------------------
1197
1198 -- | Obtained from 'reify' in the 'Q' Monad.
1199 data Info
1200 =
1201 -- | A class, with a list of its visible instances
1202 ClassI
1203 Dec
1204 [InstanceDec]
1205
1206 -- | A class method
1207 | ClassOpI
1208 Name
1209 Type
1210 ParentName
1211
1212 -- | A \"plain\" type constructor. \"Fancier\" type constructors are returned using 'PrimTyConI' or 'FamilyI' as appropriate
1213 | TyConI
1214 Dec
1215
1216 -- | A type or data family, with a list of its visible instances. A closed
1217 -- type family is returned with 0 instances.
1218 | FamilyI
1219 Dec
1220 [InstanceDec]
1221
1222 -- | A \"primitive\" type constructor, which can't be expressed with a 'Dec'. Examples: @(->)@, @Int#@.
1223 | PrimTyConI
1224 Name
1225 Arity
1226 Unlifted
1227
1228 -- | A data constructor
1229 | DataConI
1230 Name
1231 Type
1232 ParentName
1233
1234 {- |
1235 A \"value\" variable (as opposed to a type variable, see 'TyVarI').
1236
1237 The @Maybe Dec@ field contains @Just@ the declaration which
1238 defined the variable -- including the RHS of the declaration --
1239 or else @Nothing@, in the case where the RHS is unavailable to
1240 the compiler. At present, this value is _always_ @Nothing@:
1241 returning the RHS has not yet been implemented because of
1242 lack of interest.
1243 -}
1244 | VarI
1245 Name
1246 Type
1247 (Maybe Dec)
1248
1249 {- |
1250 A type variable.
1251
1252 The @Type@ field contains the type which underlies the variable.
1253 At present, this is always @'VarT' theName@, but future changes
1254 may permit refinement of this.
1255 -}
1256 | TyVarI -- Scoped type variable
1257 Name
1258 Type -- What it is bound to
1259 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1260
1261 -- | Obtained from 'reifyModule' in the 'Q' Monad.
1262 data ModuleInfo =
1263 -- | Contains the import list of the module.
1264 ModuleInfo [Module]
1265 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1266
1267 {- |
1268 In 'ClassOpI' and 'DataConI', name of the parent class or type
1269 -}
1270 type ParentName = Name
1271
1272 -- | In 'PrimTyConI', arity of the type constructor
1273 type Arity = Int
1274
1275 -- | In 'PrimTyConI', is the type constructor unlifted?
1276 type Unlifted = Bool
1277
1278 -- | 'InstanceDec' desribes a single instance of a class or type function.
1279 -- It is just a 'Dec', but guaranteed to be one of the following:
1280 --
1281 -- * 'InstanceD' (with empty @['Dec']@)
1282 --
1283 -- * 'DataInstD' or 'NewtypeInstD' (with empty derived @['Name']@)
1284 --
1285 -- * 'TySynInstD'
1286 type InstanceDec = Dec
1287
1288 data Fixity = Fixity Int FixityDirection
1289 deriving( Eq, Ord, Show, Data, Typeable, Generic )
1290 data FixityDirection = InfixL | InfixR | InfixN
1291 deriving( Eq, Ord, Show, Data, Typeable, Generic )
1292
1293 -- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9)
1294 maxPrecedence :: Int
1295 maxPrecedence = (9::Int)
1296
1297 -- | Default fixity: @infixl 9@
1298 defaultFixity :: Fixity
1299 defaultFixity = Fixity maxPrecedence InfixL
1300
1301
1302 {-
1303 Note [Unresolved infix]
1304 ~~~~~~~~~~~~~~~~~~~~~~~
1305 -}
1306 {- $infix #infix#
1307 When implementing antiquotation for quasiquoters, one often wants
1308 to parse strings into expressions:
1309
1310 > parse :: String -> Maybe Exp
1311
1312 But how should we parse @a + b * c@? If we don't know the fixities of
1313 @+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a
1314 + b) * c@.
1315
1316 In cases like this, use 'UInfixE', 'UInfixP', or 'UInfixT', which stand for
1317 \"unresolved infix expression/pattern/type\", respectively. When the compiler
1318 is given a splice containing a tree of @UInfixE@ applications such as
1319
1320 > UInfixE
1321 > (UInfixE e1 op1 e2)
1322 > op2
1323 > (UInfixE e3 op3 e4)
1324
1325 it will look up and the fixities of the relevant operators and
1326 reassociate the tree as necessary.
1327
1328 * trees will not be reassociated across 'ParensE', 'ParensP', or 'ParensT',
1329 which are of use for parsing expressions like
1330
1331 > (a + b * c) + d * e
1332
1333 * 'InfixE', 'InfixP', and 'InfixT' expressions are never reassociated.
1334
1335 * The 'UInfixE' constructor doesn't support sections. Sections
1336 such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer
1337 sections such as @(a + b * c -)@, use an 'InfixE' constructor for the
1338 outer-most section, and use 'UInfixE' constructors for all
1339 other operators:
1340
1341 > InfixE
1342 > Just (UInfixE ...a + b * c...)
1343 > op
1344 > Nothing
1345
1346 Sections such as @(a + b +)@ and @((a + b) +)@ should be rendered
1347 into 'Exp's differently:
1348
1349 > (+ a + b) ---> InfixE Nothing + (Just $ UInfixE a + b)
1350 > -- will result in a fixity error if (+) is left-infix
1351 > (+ (a + b)) ---> InfixE Nothing + (Just $ ParensE $ UInfixE a + b)
1352 > -- no fixity errors
1353
1354 * Quoted expressions such as
1355
1356 > [| a * b + c |] :: Q Exp
1357 > [p| a : b : c |] :: Q Pat
1358 > [t| T + T |] :: Q Type
1359
1360 will never contain 'UInfixE', 'UInfixP', 'UInfixT', 'InfixT', 'ParensE',
1361 'ParensP', or 'ParensT' constructors.
1362
1363 -}
1364
1365 -----------------------------------------------------
1366 --
1367 -- The main syntax data types
1368 --
1369 -----------------------------------------------------
1370
1371 data Lit = CharL Char
1372 | StringL String
1373 | IntegerL Integer -- ^ Used for overloaded and non-overloaded
1374 -- literals. We don't have a good way to
1375 -- represent non-overloaded literals at
1376 -- the moment. Maybe that doesn't matter?
1377 | RationalL Rational -- Ditto
1378 | IntPrimL Integer
1379 | WordPrimL Integer
1380 | FloatPrimL Rational
1381 | DoublePrimL Rational
1382 | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr#
1383 | CharPrimL Char
1384 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1385
1386 -- We could add Int, Float, Double etc, as we do in HsLit,
1387 -- but that could complicate the
1388 -- supposedly-simple TH.Syntax literal type
1389
1390 -- | Pattern in Haskell given in @{}@
1391 data Pat
1392 = LitP Lit -- ^ @{ 5 or \'c\' }@
1393 | VarP Name -- ^ @{ x }@
1394 | TupP [Pat] -- ^ @{ (p1,p2) }@
1395 | UnboxedTupP [Pat] -- ^ @{ (\# p1,p2 \#) }@
1396 | ConP Name [Pat] -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@
1397 | InfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@
1398 | UInfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@
1399 --
1400 -- See "Language.Haskell.TH.Syntax#infix"
1401 | ParensP Pat -- ^ @{(p)}@
1402 --
1403 -- See "Language.Haskell.TH.Syntax#infix"
1404 | TildeP Pat -- ^ @{ ~p }@
1405 | BangP Pat -- ^ @{ !p }@
1406 | AsP Name Pat -- ^ @{ x \@ p }@
1407 | WildP -- ^ @{ _ }@
1408 | RecP Name [FieldPat] -- ^ @f (Pt { pointx = x }) = g x@
1409 | ListP [ Pat ] -- ^ @{ [1,2,3] }@
1410 | SigP Pat Type -- ^ @{ p :: t }@
1411 | ViewP Exp Pat -- ^ @{ e -> p }@
1412 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1413
1414 type FieldPat = (Name,Pat)
1415
1416 data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@
1417 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1418 data Clause = Clause [Pat] Body [Dec]
1419 -- ^ @f { p1 p2 = body where decs }@
1420 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1421
1422 data Exp
1423 = VarE Name -- ^ @{ x }@
1424 | ConE Name -- ^ @data T1 = C1 t1 t2; p = {C1} e1 e2 @
1425 | LitE Lit -- ^ @{ 5 or \'c\'}@
1426 | AppE Exp Exp -- ^ @{ f x }@
1427
1428 | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@
1429
1430 -- It's a bit gruesome to use an Exp as the
1431 -- operator, but how else can we distinguish
1432 -- constructors from non-constructors?
1433 -- Maybe there should be a var-or-con type?
1434 -- Or maybe we should leave it to the String itself?
1435
1436 | UInfixE Exp Exp Exp -- ^ @{x + y}@
1437 --
1438 -- See "Language.Haskell.TH.Syntax#infix"
1439 | ParensE Exp -- ^ @{ (e) }@
1440 --
1441 -- See "Language.Haskell.TH.Syntax#infix"
1442 | LamE [Pat] Exp -- ^ @{ \\ p1 p2 -> e }@
1443 | LamCaseE [Match] -- ^ @{ \\case m1; m2 }@
1444 | TupE [Exp] -- ^ @{ (e1,e2) } @
1445 | UnboxedTupE [Exp] -- ^ @{ (\# e1,e2 \#) } @
1446 | CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@
1447 | MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@
1448 | LetE [Dec] Exp -- ^ @{ let x=e1; y=e2 in e3 }@
1449 | CaseE Exp [Match] -- ^ @{ case e of m1; m2 }@
1450 | DoE [Stmt] -- ^ @{ do { p <- e1; e2 } }@
1451 | CompE [Stmt] -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@
1452 --
1453 -- The result expression of the comprehension is
1454 -- the /last/ of the @'Stmt'@s, and should be a 'NoBindS'.
1455 --
1456 -- E.g. translation:
1457 --
1458 -- > [ f x | x <- xs ]
1459 --
1460 -- > CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]
1461
1462 | ArithSeqE Range -- ^ @{ [ 1 ,2 .. 10 ] }@
1463 | ListE [ Exp ] -- ^ @{ [1,2,3] }@
1464 | SigE Exp Type -- ^ @{ e :: t }@
1465 | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@
1466 | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@
1467 | StaticE Exp -- ^ @{ static e }@
1468 | UnboundVarE Name -- ^ @{ _x }@ (hole)
1469 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1470
1471 type FieldExp = (Name,Exp)
1472
1473 -- Omitted: implicit parameters
1474
1475 data Body
1476 = GuardedB [(Guard,Exp)] -- ^ @f p { | e1 = e2
1477 -- | e3 = e4 }
1478 -- where ds@
1479 | NormalB Exp -- ^ @f p { = e } where ds@
1480 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1481
1482 data Guard
1483 = NormalG Exp -- ^ @f x { | odd x } = x@
1484 | PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@
1485 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1486
1487 data Stmt
1488 = BindS Pat Exp
1489 | LetS [ Dec ]
1490 | NoBindS Exp
1491 | ParS [[Stmt]]
1492 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1493
1494 data Range = FromR Exp | FromThenR Exp Exp
1495 | FromToR Exp Exp | FromThenToR Exp Exp Exp
1496 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1497
1498 data Dec
1499 = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@
1500 | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@
1501 | DataD Cxt Name [TyVarBndr]
1502 (Maybe Kind) -- Kind signature (allowed only for GADTs)
1503 [Con] Cxt
1504 -- ^ @{ data Cxt x => T x = A x | B (T x)
1505 -- deriving (Z,W)}@
1506 | NewtypeD Cxt Name [TyVarBndr]
1507 (Maybe Kind) -- Kind signature
1508 Con Cxt -- ^ @{ newtype Cxt x => T x = A (B x)
1509 -- deriving (Z,W Q)}@
1510 | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@
1511 | ClassD Cxt Name [TyVarBndr]
1512 [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@
1513 | InstanceD Cxt Type [Dec] -- ^ @{ instance Show w => Show [w]
1514 -- where ds }@
1515 | SigD Name Type -- ^ @{ length :: [a] -> Int }@
1516 | ForeignD Foreign -- ^ @{ foreign import ... }
1517 --{ foreign export ... }@
1518
1519 | InfixD Fixity Name -- ^ @{ infix 3 foo }@
1520
1521 -- | pragmas
1522 | PragmaD Pragma -- ^ @{ {\-\# INLINE [1] foo \#-\} }@
1523
1524 -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
1525 | DataFamilyD Name [TyVarBndr]
1526 (Maybe Kind)
1527 -- ^ @{ data family T a b c :: * }@
1528
1529 | DataInstD Cxt Name [Type]
1530 (Maybe Kind) -- Kind signature
1531 [Con] Cxt -- ^ @{ data instance Cxt x => T [x]
1532 -- = A x | B (T x) deriving (Z,W)}@
1533
1534 | NewtypeInstD Cxt Name [Type]
1535 (Maybe Kind) -- Kind signature
1536 Con Cxt -- ^ @{ newtype instance Cxt x => T [x]
1537 -- = A (B x) deriving (Z,W)}@
1538 | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@
1539
1540 -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
1541 | OpenTypeFamilyD TypeFamilyHead
1542 -- ^ @{ type family T a b c = (r :: *) | r -> a b }@
1543
1544 | ClosedTypeFamilyD TypeFamilyHead [TySynEqn]
1545 -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@
1546
1547 | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@
1548 | StandaloneDerivD Cxt Type -- ^ @{ deriving instance Ord a => Ord (Foo a) }@
1549 | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@
1550 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1551
1552 -- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'.
1553 -- By analogy with with "head" for type classes and type class instances as
1554 -- defined in /Type classes: an exploration of the design space/, the
1555 -- @TypeFamilyHead@ is defined to be the elements of the declaration between
1556 -- @type family@ and @where@.
1557 data TypeFamilyHead =
1558 TypeFamilyHead Name [TyVarBndr] FamilyResultSig (Maybe InjectivityAnn)
1559 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1560
1561 -- | One equation of a type family instance or closed type family. The
1562 -- arguments are the left-hand-side type patterns and the right-hand-side
1563 -- result.
1564 data TySynEqn = TySynEqn [Type] Type
1565 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1566
1567 data FunDep = FunDep [Name] [Name]
1568 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1569
1570 data FamFlavour = TypeFam | DataFam
1571 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1572
1573 data Foreign = ImportF Callconv Safety String Name Type
1574 | ExportF Callconv String Name Type
1575 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1576
1577 -- keep Callconv in sync with module ForeignCall in ghc/compiler/prelude/ForeignCall.hs
1578 data Callconv = CCall | StdCall | CApi | Prim | JavaScript
1579 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1580
1581 data Safety = Unsafe | Safe | Interruptible
1582 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1583
1584 data Pragma = InlineP Name Inline RuleMatch Phases
1585 | SpecialiseP Name Type (Maybe Inline) Phases
1586 | SpecialiseInstP Type
1587 | RuleP String [RuleBndr] Exp Exp Phases
1588 | AnnP AnnTarget Exp
1589 | LineP Int String
1590 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1591
1592 data Inline = NoInline
1593 | Inline
1594 | Inlinable
1595 deriving (Show, Eq, Ord, Data, Typeable, Generic)
1596
1597 data RuleMatch = ConLike
1598 | FunLike
1599 deriving (Show, Eq, Ord, Data, Typeable, Generic)
1600
1601 data Phases = AllPhases
1602 | FromPhase Int
1603 | BeforePhase Int
1604 deriving (Show, Eq, Ord, Data, Typeable, Generic)
1605
1606 data RuleBndr = RuleVar Name
1607 | TypedRuleVar Name Type
1608 deriving (Show, Eq, Ord, Data, Typeable, Generic)
1609
1610 data AnnTarget = ModuleAnnotation
1611 | TypeAnnotation Name
1612 | ValueAnnotation Name
1613 deriving (Show, Eq, Ord, Data, Typeable, Generic)
1614
1615 type Cxt = [Pred] -- ^ @(Eq a, Ord b)@
1616
1617 -- | Since the advent of @ConstraintKinds@, constraints are really just types.
1618 -- Equality constraints use the 'EqualityT' constructor. Constraints may also
1619 -- be tuples of other constraints.
1620 type Pred = Type
1621
1622 data SourceUnpackedness
1623 = NoSourceUnpackedness -- ^ @C a@
1624 | SourceNoUnpack -- ^ @C { {\-\# NOUNPACK \#-\} } a@
1625 | SourceUnpack -- ^ @C { {\-\# UNPACK \#-\} } a@
1626 deriving (Show, Eq, Ord, Data, Typeable, Generic)
1627
1628 data SourceStrictness = NoSourceStrictness -- ^ @C a@
1629 | SourceLazy -- ^ @C {~}a@
1630 | SourceStrict -- ^ @C {!}a@
1631 deriving (Show, Eq, Ord, Data, Typeable, Generic)
1632
1633 -- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness'
1634 -- refers to the strictness that the compiler chooses for a data constructor
1635 -- field, which may be different from what is written in source code. See
1636 -- 'reifyConStrictness' for more information.
1637 data DecidedStrictness = DecidedLazy
1638 | DecidedStrict
1639 | DecidedUnpack
1640 deriving (Show, Eq, Ord, Data, Typeable, Generic)
1641
1642 data Con = NormalC Name [BangType] -- ^ @C Int a@
1643 | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@
1644 | InfixC BangType Name BangType -- ^ @Int :+ a@
1645 | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@
1646 | GadtC [Name] [BangType]
1647 Type -- See Note [GADT return type]
1648 -- ^ @C :: a -> b -> T b Int@
1649 | RecGadtC [Name] [VarBangType]
1650 Type -- See Note [GADT return type]
1651 -- ^ @C :: { v :: Int } -> T b Int@
1652 deriving (Show, Eq, Ord, Data, Typeable, Generic)
1653
1654 -- Note [GADT return type]
1655 -- ~~~~~~~~~~~~~~~~~~~~~~~
1656 --
1657 -- The return type of a GADT constructor does not necessarily match the name of
1658 -- the data type:
1659 --
1660 -- type S = T
1661 --
1662 -- data T a where
1663 -- MkT :: S Int
1664 --
1665 --
1666 -- type S a = T
1667 --
1668 -- data T a where
1669 -- MkT :: S Char Int
1670 --
1671 --
1672 -- type Id a = a
1673 -- type S a = T
1674 --
1675 -- data T a where
1676 -- MkT :: Id (S Char Int)
1677 --
1678 --
1679 -- That is why we allow the return type stored by a constructor to be an
1680 -- arbitrary type. See also #11341
1681
1682 data Bang = Bang SourceUnpackedness SourceStrictness
1683 -- ^ @C { {\-\# UNPACK \#-\} !}a@
1684 deriving (Show, Eq, Ord, Data, Typeable, Generic)
1685
1686 type BangType = (Bang, Type)
1687 type VarBangType = (Name, Bang, Type)
1688
1689 -- | As of @template-haskell-2.11.0.0@, 'Strict' has been replaced by 'Bang'.
1690 type Strict = Bang
1691
1692 -- | As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by
1693 -- 'BangType'.
1694 type StrictType = BangType
1695
1696 -- | As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by
1697 -- 'VarBangType'.
1698 type VarStrictType = VarBangType
1699
1700 data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> -> \<type\>@
1701 | AppT Type Type -- ^ @T a b@
1702 | SigT Type Kind -- ^ @t :: k@
1703 | VarT Name -- ^ @a@
1704 | ConT Name -- ^ @T@
1705 | PromotedT Name -- ^ @'T@
1706 | InfixT Type Name Type -- ^ @T + T@
1707 | UInfixT Type Name Type -- ^ @T + T@
1708 --
1709 -- See "Language.Haskell.TH.Syntax#infix"
1710 | ParensT Type -- ^ @(T)@
1711
1712 -- See Note [Representing concrete syntax in types]
1713 | TupleT Int -- ^ @(,), (,,), etc.@
1714 | UnboxedTupleT Int -- ^ @(\#,\#), (\#,,\#), etc.@
1715 | ArrowT -- ^ @->@
1716 | EqualityT -- ^ @~@
1717 | ListT -- ^ @[]@
1718 | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@
1719 | PromotedNilT -- ^ @'[]@
1720 | PromotedConsT -- ^ @(':)@
1721 | StarT -- ^ @*@
1722 | ConstraintT -- ^ @Constraint@
1723 | LitT TyLit -- ^ @0,1,2, etc.@
1724 | WildCardT -- ^ @_,
1725 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1726
1727 data TyVarBndr = PlainTV Name -- ^ @a@
1728 | KindedTV Name Kind -- ^ @(a :: k)@
1729 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1730
1731 -- | Type family result signature
1732 data FamilyResultSig = NoSig -- ^ no signature
1733 | KindSig Kind -- ^ @k@
1734 | TyVarSig TyVarBndr -- ^ @= r, = (r :: k)@
1735 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1736
1737 -- | Injectivity annotation
1738 data InjectivityAnn = InjectivityAnn Name [Name]
1739 deriving ( Show, Eq, Ord, Data, Typeable, Generic )
1740
1741 data TyLit = NumTyLit Integer -- ^ @2@
1742 | StrTyLit String -- ^ @"Hello"@
1743 deriving ( Show, Eq, Ord, Data, Typeable, Generic )
1744
1745 -- | Role annotations
1746 data Role = NominalR -- ^ @nominal@
1747 | RepresentationalR -- ^ @representational@
1748 | PhantomR -- ^ @phantom@
1749 | InferR -- ^ @_@
1750 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1751
1752 -- | Annotation target for reifyAnnotations
1753 data AnnLookup = AnnLookupModule Module
1754 | AnnLookupName Name
1755 deriving( Show, Eq, Ord, Data, Typeable, Generic )
1756
1757 -- | To avoid duplication between kinds and types, they
1758 -- are defined to be the same. Naturally, you would never
1759 -- have a type be 'StarT' and you would never have a kind
1760 -- be 'SigT', but many of the other constructors are shared.
1761 -- Note that the kind @Bool@ is denoted with 'ConT', not
1762 -- 'PromotedT'. Similarly, tuple kinds are made with 'TupleT',
1763 -- not 'PromotedTupleT'.
1764
1765 type Kind = Type
1766
1767 {- Note [Representing concrete syntax in types]
1768 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1769 Haskell has a rich concrete syntax for types, including
1770 t1 -> t2, (t1,t2), [t], and so on
1771 In TH we represent all of this using AppT, with a distinguished
1772 type constructor at the head. So,
1773 Type TH representation
1774 -----------------------------------------------
1775 t1 -> t2 ArrowT `AppT` t2 `AppT` t2
1776 [t] ListT `AppT` t
1777 (t1,t2) TupleT 2 `AppT` t1 `AppT` t2
1778 '(t1,t2) PromotedTupleT 2 `AppT` t1 `AppT` t2
1779
1780 But if the original HsSyn used prefix application, we won't use
1781 these special TH constructors. For example
1782 [] t ConT "[]" `AppT` t
1783 (->) t ConT "->" `AppT` t
1784 In this way we can faithfully represent in TH whether the original
1785 HsType used concrete syntax or not.
1786
1787 The one case that doesn't fit this pattern is that of promoted lists
1788 '[ Maybe, IO ] PromotedListT 2 `AppT` t1 `AppT` t2
1789 but it's very smelly because there really is no type constructor
1790 corresponding to PromotedListT. So we encode HsExplicitListTy with
1791 PromotedConsT and PromotedNilT (which *do* have underlying type
1792 constructors):
1793 '[ Maybe, IO ] PromotedConsT `AppT` Maybe `AppT`
1794 (PromotedConsT `AppT` IO `AppT` PromotedNilT)
1795 -}
1796
1797 -----------------------------------------------------
1798 -- Internal helper functions
1799 -----------------------------------------------------
1800
1801 cmpEq :: Ordering -> Bool
1802 cmpEq EQ = True
1803 cmpEq _ = False
1804
1805 thenCmp :: Ordering -> Ordering -> Ordering
1806 thenCmp EQ o2 = o2
1807 thenCmp o1 _ = o1