Syntax.hs 29.2 KB
Newer Older
Ian Lynagh's avatar
Ian Lynagh committed
1
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
2
-- The -fno-warn-warnings-deprecations flag is a temporary kludge.
Ian Lynagh's avatar
Ian Lynagh committed
3 4 5 6
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
-- for details
7

8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.Syntax
-- Copyright   :  (c) The University of Glasgow 2003
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Abstract syntax definitions for Template Haskell.
--
-----------------------------------------------------------------------------

module Language.Haskell.TH.Syntax(
23
	Quasi(..), Lift(..), liftString,
24 25 26

	Q, runQ, 
	report,	recover, reify,
27
	location, runIO,
28
        isClassInstance, classInstances,
29

aavogt's avatar
aavogt committed
30
	-- * Names
Ian Lynagh's avatar
Ian Lynagh committed
31
	Name(..), mkName, newName, nameBase, nameModule,
32
        showName, showName', NameIs(..),
33

aavogt's avatar
aavogt committed
34
	-- * The algebraic data types
35 36
	Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..),Cxt,
	Pred(..), Match(..),  Clause(..), Body(..), Guard(..), Stmt(..),
37
	Range(..), Lit(..), Pat(..), FieldExp, FieldPat, ClassInstance(..),
38 39
	Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
	InlineSpec(..),	StrictType, VarStrictType, FunDep(..), FamFlavour(..),
40
	Info(..), Loc(..), CharPos,
41 42
	Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,

aavogt's avatar
aavogt committed
43
	-- * Internal functions
44 45
	returnQ, bindQ, sequenceQ,
	NameFlavour(..), NameSpace (..), 
46
	mkNameG_v, mkNameG_d, mkNameG_tc, Uniq, mkNameL, mkNameU,
47
 	tupleTypeName, tupleDataName,
48
	OccName, mkOccName, occString,
49 50
	ModName, mkModName, modString,
	PkgName, mkPkgName, pkgString
51 52 53 54
    ) where

import GHC.Base		( Int(..), Int#, (<#), (==#) )

55
import Language.Haskell.TH.Syntax.Internals
56
import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex)
Ross Paterson's avatar
Ross Paterson committed
57
import qualified Data.Data as Data
58
import Data.IORef
59
import System.IO.Unsafe	( unsafePerformIO )
60
import Control.Monad (liftM)
61
import System.IO	( hPutStrLn, stderr )
62
import Data.Char        ( isAlpha )
63 64 65 66 67 68 69

-----------------------------------------------------
--
--		The Quasi class
--
-----------------------------------------------------

70
class (Monad m, Functor m) => Quasi m where
71
  qNewName :: String -> m Name
aavogt's avatar
aavogt committed
72
	-- ^ Fresh names
73 74

	-- Error reporting and recovery
aavogt's avatar
aavogt committed
75
  qReport  :: Bool -> String -> m ()	-- ^ Report an error (True) or warning (False)
76
					-- ...but carry on; use 'fail' to stop
aavogt's avatar
aavogt committed
77 78 79
  qRecover :: m a -- ^ the error handler
           -> m a -- ^ action which may fail
           -> m a		-- ^ Recover from the monadic 'fail'
80 81 82
 
	-- Inspect the type-checker's environment
  qReify :: Name -> m Info
83
  qClassInstances :: Name -> [Type] -> m [ClassInstance]
84 85 86
  		      -- Is (cls tys) an instance?
		      -- Returns list of matching witnesses

87
  qLocation :: m Loc
88 89

  qRunIO :: IO a -> m a
aavogt's avatar
aavogt committed
90
  -- ^ Input/output (dangerous)
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111


-----------------------------------------------------
--	The IO instance of Quasi
-- 
--  This instance is used only when running a Q
--  computation in the IO monad, usually just to
--  print the result.  There is no interesting
--  type environment, so reification isn't going to
--  work.
--
-----------------------------------------------------

instance Quasi IO where
  qNewName s = do { n <- readIORef counter
                 ; writeIORef counter (n+1)
                 ; return (mkNameU s n) }

  qReport True  msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
  qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)

112 113 114 115
  qReify _            = badIO "reify"
  qClassInstances _ _ = badIO "classInstances"
  qLocation    	      = badIO "currentLocation"
  qRecover _ _ 	      = badIO "recover" -- Maybe we could fix this?
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

  qRunIO m = m
  
badIO :: String -> IO a
badIO op = do	{ qReport True ("Can't do `" ++ op ++ "' in the IO monad")
		; fail "Template Haskell failure" }

-- Global variable to generate unique symbols
counter :: IORef Int
{-# NOINLINE counter #-}
counter = unsafePerformIO (newIORef 0)


-----------------------------------------------------
--
--		The Q monad
--
-----------------------------------------------------

newtype Q a = Q { unQ :: forall m. Quasi m => m a }

runQ :: Quasi m => Q a -> m a
runQ (Q m) = m

instance Monad Q where
  return x   = Q (return x)
  Q m >>= k  = Q (m >>= \x -> unQ (k x))
  Q m >> Q n = Q (m >> n)
144
  fail s     = report True s >> Q (fail "Q monad failure")
145

146 147 148
instance Functor Q where
  fmap f (Q x) = Q (fmap f x)

149 150 151 152 153 154 155 156
----------------------------------------------------
-- Packaged versions for the programmer, hiding the Quasi-ness
newName :: String -> Q Name
newName s = Q (qNewName s)

report  :: Bool -> String -> Q ()
report b s = Q (qReport b s)

aavogt's avatar
aavogt committed
157 158 159
recover :: Q a -- ^ recover with this one
        -> Q a -- ^ failing action
        -> Q a
160 161
recover (Q r) (Q m) = Q (qRecover r m)

162
-- | 'reify' looks up information about the 'Name'
163 164 165
reify :: Name -> Q Info
reify v = Q (qReify v)

166
-- | 'classInstances' looks up instaces of a class
167
classInstances :: Name -> [Type] -> Q [ClassInstance]
168 169 170 171 172 173
classInstances cls tys = Q (qClassInstances cls tys)

isClassInstance :: Name -> [Type] -> Q Bool
isClassInstance cls tys = do { dfuns <- classInstances cls tys
                             ; return (not (null dfuns)) }

174
-- | 'location' gives you the 'Location' at which this
175
-- computation is spliced.
176 177
location :: Q Loc
location = Q qLocation
178

dons's avatar
dons committed
179
-- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
180 181 182 183 184 185
-- Take care: you are guaranteed the ordering of calls to 'runIO' within 
-- a single 'Q' computation, but not about the order in which splices are run.  
--
-- Note: for various murky reasons, stdout and stderr handles are not 
-- necesarily flushed when the  compiler finishes running, so you should
-- flush them yourself.
186 187 188 189
runIO :: IO a -> Q a
runIO m = Q (qRunIO m)

instance Quasi Q where
190 191 192 193 194 195 196
  qNewName  	  = newName
  qReport   	  = report
  qRecover  	  = recover 
  qReify    	  = reify
  qClassInstances = classInstances
  qLocation 	  = location
  qRunIO    	  = runIO
197 198 199 200


----------------------------------------------------
-- The following operations are used solely in DsMeta when desugaring brackets
201
-- They are not necessary for the user, who can use ordinary return and (>>=) etc
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

returnQ :: a -> Q a
returnQ = return

bindQ :: Q a -> (a -> Q b) -> Q b
bindQ = (>>=)

sequenceQ :: [Q a] -> Q [a]
sequenceQ = sequence


-----------------------------------------------------
--
--		The Lift class
--
-----------------------------------------------------

class Lift t where
  lift :: t -> Q Exp
  
instance Lift Integer where
  lift x = return (LitE (IntegerL x))

instance Lift Int where
  lift x= return (LitE (IntegerL (fromIntegral x)))

instance Lift Char where
  lift x = return (LitE (CharL x))

instance Lift Bool where
  lift True  = return (ConE trueName)
  lift False = return (ConE falseName)

235 236 237 238 239 240 241 242
instance Lift a => Lift (Maybe a) where
  lift Nothing  = return (ConE nothingName)
  lift (Just x) = liftM (ConE justName `AppE`) (lift x)

instance (Lift a, Lift b) => Lift (Either a b) where
  lift (Left x)  = liftM (ConE leftName  `AppE`) (lift x)
  lift (Right y) = liftM (ConE rightName `AppE`) (lift y)

243 244 245
instance Lift a => Lift [a] where
  lift xs = do { xs' <- mapM lift xs; return (ListE xs') }

246 247 248 249
liftString :: String -> Q Exp
-- Used in TcExpr to short-circuit the lifting for strings
liftString s = return (LitE (StringL s))

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
instance (Lift a, Lift b) => Lift (a, b) where
  lift (a, b)
    = liftM TupE $ sequence [lift a, lift b]

instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where
  lift (a, b, c)
    = liftM TupE $ sequence [lift a, lift b, lift c]

instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where
  lift (a, b, c, d)
    = liftM TupE $ sequence [lift a, lift b, lift c, lift d]

instance (Lift a, Lift b, Lift c, Lift d, Lift e)
      => Lift (a, b, c, d, e) where
  lift (a, b, c, d, e)
    = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]

instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
      => Lift (a, b, c, d, e, f) where
  lift (a, b, c, d, e, f)
    = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]

instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
      => Lift (a, b, c, d, e, f, g) where
  lift (a, b, c, d, e, f, g)
    = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]

277 278 279 280 281 282 283 284 285 286
-- TH has a special form for literal strings,
-- which we should take advantage of.
-- NB: the lhs of the rule has no args, so that
--     the rule will apply to a 'lift' all on its own
--     which happens to be the way the type checker 
--     creates it.
{-# RULES "TH:liftString" lift = \s -> return (LitE (StringL s)) #-}


trueName, falseName :: Name
Ian Lynagh's avatar
Ian Lynagh committed
287 288
trueName  = mkNameG DataName "ghc-prim" "GHC.Types" "True"
falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False"
289

290 291 292 293 294 295 296 297
nothingName, justName :: Name
nothingName = mkNameG DataName "base" "Data.Maybe" "Nothing"
justName    = mkNameG DataName "base" "Data.Maybe" "Just"

leftName, rightName :: Name
leftName  = mkNameG DataName "base" "Data.Either" "Left"
rightName = mkNameG DataName "base" "Data.Either" "Right"

298 299 300 301 302 303

-----------------------------------------------------
--		Names and uniques 
-----------------------------------------------------

mkModName :: String -> ModName
304
mkModName s = ModName s
305 306

modString :: ModName -> String
307
modString (ModName m) = m
308

309 310

mkPkgName :: String -> PkgName
311
mkPkgName s = PkgName s
312 313

pkgString :: PkgName -> String
314
pkgString (PkgName m) = m
315 316


317 318 319 320 321
-----------------------------------------------------
--		OccName
-----------------------------------------------------

mkOccName :: String -> OccName
322
mkOccName s = OccName s
323 324

occString :: OccName -> String
325
occString (OccName occ) = occ
326 327 328 329 330 331


-----------------------------------------------------
--		 Names
-----------------------------------------------------

aavogt's avatar
aavogt committed
332 333
-- |
-- For "global" names ('NameG') we need a totally unique name,
334 335
-- so we must include the name-space of the thing
--
aavogt's avatar
aavogt committed
336
-- For unique-numbered things ('NameU'), we've got a unique reference
337 338
-- anyway, so no need for name space
--
aavogt's avatar
aavogt committed
339
-- For dynamically bound thing ('NameS') we probably want them to
340 341
-- in a context-dependent way, so again we don't want the name
-- space.  For example:
aavogt's avatar
aavogt committed
342 343 344
--
-- > let v = mkName "T" in [| data $v = $v |]
--
345
-- Here we use the same Name for both type constructor and data constructor
aavogt's avatar
aavogt committed
346 347 348 349 350 351 352 353 354 355
--
--
-- NameL and NameG are bound *outside* the TH syntax tree
-- either globally (NameG) or locally (NameL). Ex:
--
-- > f x = $(h [| (map, x) |])
--
-- The 'map' will be a NameG, and 'x' wil be a NameL
--
-- These Names should never appear in a binding position in a TH syntax tree
356
data Name = Name OccName NameFlavour deriving (Typeable, Data)
357 358

data NameFlavour
aavogt's avatar
aavogt committed
359 360
  = NameS           -- ^ An unqualified name; dynamically bound
  | NameQ ModName   -- ^ A qualified name; dynamically bound
361

aavogt's avatar
aavogt committed
362
  | NameU Int#      -- ^ A unique local name
363

364

aavogt's avatar
aavogt committed
365 366 367 368
  | NameL Int#      -- ^ Local name bound outside of the TH AST
  | NameG NameSpace PkgName ModName -- ^ Global name bound outside of the TH AST:
                -- An original name (occurrences only, not binders)
                --
369 370
				-- Need the namespace too to be sure which 
				-- thing we are naming
371 372
  deriving ( Typeable )

aavogt's avatar
aavogt committed
373
-- |
374 375 376 377 378 379 380 381 382 383
-- Although the NameFlavour type is abstract, the Data instance is not. The reason for this
-- is that currently we use Data to serialize values in annotations, and in order for that to
-- work for Template Haskell names introduced via the 'x syntax we need gunfold on NameFlavour
-- to work. Bleh!
--
-- The long term solution to this is to use the binary package for annotation serialization and
-- then remove this instance. However, to do _that_ we need to wait on binary to become stable, since
-- boot libraries cannot be upgraded seperately from GHC itself.
--
-- This instance cannot be derived automatically due to bug #2701
384
instance Data NameFlavour where
385 386 387 388 389 390 391 392 393 394 395 396
     gfoldl _ z NameS          = z NameS
     gfoldl k z (NameQ mn)     = z NameQ `k` mn
     gfoldl k z (NameU i)      = z (\(I# i') -> NameU i') `k` (I# i)
     gfoldl k z (NameL i)      = z (\(I# i') -> NameL i') `k` (I# i)
     gfoldl k z (NameG ns p m) = z NameG `k` ns `k` p `k` m
     gunfold k z c = case constrIndex c of
         1 -> z NameS
         2 -> k $ z NameQ
         3 -> k $ z (\(I# i) -> NameU i)
         4 -> k $ z (\(I# i) -> NameL i)
         5 -> k $ k $ k $ z NameG
         _ -> error "gunfold: NameFlavour"
397 398 399 400 401 402 403
     toConstr NameS = con_NameS
     toConstr (NameQ _) = con_NameQ
     toConstr (NameU _) = con_NameU
     toConstr (NameL _) = con_NameL
     toConstr (NameG _ _ _) = con_NameG
     dataTypeOf _ = ty_NameFlavour

Ross Paterson's avatar
Ross Paterson committed
404 405 406 407 408 409
con_NameS, con_NameQ, con_NameU, con_NameL, con_NameG :: Data.Constr
con_NameS = mkConstr ty_NameFlavour "NameS" [] Data.Prefix
con_NameQ = mkConstr ty_NameFlavour "NameQ" [] Data.Prefix
con_NameU = mkConstr ty_NameFlavour "NameU" [] Data.Prefix
con_NameL = mkConstr ty_NameFlavour "NameL" [] Data.Prefix
con_NameG = mkConstr ty_NameFlavour "NameG" [] Data.Prefix
Ian Lynagh's avatar
Ian Lynagh committed
410

Ross Paterson's avatar
Ross Paterson committed
411
ty_NameFlavour :: Data.DataType
412 413 414
ty_NameFlavour = mkDataType "Language.Haskell.TH.Syntax.NameFlavour"
                            [con_NameS, con_NameQ, con_NameU,
                             con_NameL, con_NameG]
415

aavogt's avatar
aavogt committed
416 417 418
data NameSpace = VarName	-- ^ Variables
	       | DataName	-- ^ Data constructors 
	       | TcClsName	-- ^ Type constructors and classes; Haskell has them
419
				-- in the same name space for now.
420
	       deriving( Eq, Ord, Data, Typeable )
421 422 423

type Uniq = Int

aavogt's avatar
aavogt committed
424
-- | Base, unqualified name.
425 426 427
nameBase :: Name -> String
nameBase (Name occ _) = occString occ

428
nameModule :: Name -> Maybe String
Ian Lynagh's avatar
Ian Lynagh committed
429
nameModule (Name _ (NameQ m))     = Just (modString m)
430
nameModule (Name _ (NameG _ _ m)) = Just (modString m)
Ian Lynagh's avatar
Ian Lynagh committed
431
nameModule _                      = Nothing
432

433
mkName :: String -> Name
aavogt's avatar
aavogt committed
434
-- ^ The string can have a '.', thus "Foo.baz",
435 436 437 438 439 440
-- giving a dynamically-bound qualified name,
-- in which case we want to generate a NameQ
--
-- Parse the string to see if it has a "." in it
-- so we know whether to generate a qualified or unqualified name
-- It's a bit tricky because we need to parse 
aavogt's avatar
aavogt committed
441 442 443
--
-- > Foo.Baz.x   as    Qual Foo.Baz x
--
444 445 446 447 448
-- So we parse it from back to front
mkName str
  = split [] (reverse str)
  where
    split occ []        = Name (mkOccName occ) NameS
449 450 451 452 453 454 455 456 457
    split occ ('.':rev)	| not (null occ), 
			  not (null rev), head rev /= '.'
			= Name (mkOccName occ) (NameQ (mkModName (reverse rev)))
	-- The 'not (null occ)' guard ensures that
	-- 	mkName "&." = Name "&." NameS
	-- The 'rev' guards ensure that
	--	mkName ".&" = Name ".&" NameS
	--	mkName "Data.Bits..&" = Name ".&" (NameQ "Data.Bits")
	-- This rather bizarre case actually happened; (.&.) is in Data.Bits
458
    split occ (c:rev)   = split (c:occ) rev
459

aavogt's avatar
aavogt committed
460 461
-- | Only used internally
mkNameU :: String -> Uniq -> Name
462 463
mkNameU s (I# u) = Name (mkOccName s) (NameU u)

aavogt's avatar
aavogt committed
464 465
-- | Only used internally
mkNameL :: String -> Uniq -> Name
466 467
mkNameL s (I# u) = Name (mkOccName s) (NameL u)

aavogt's avatar
aavogt committed
468 469 470
-- | Used for 'x etc, but not available to the programmer
mkNameG :: NameSpace -> String -> String -> String -> Name
mkNameG ns pkg modu occ
Ian Lynagh's avatar
Ian Lynagh committed
471
  = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName modu))
472

473
mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name
474 475 476 477 478 479 480 481 482 483 484 485 486 487 488
mkNameG_v  = mkNameG VarName
mkNameG_tc = mkNameG TcClsName
mkNameG_d  = mkNameG DataName

instance Eq Name where
  v1 == v2 = cmpEq (v1 `compare` v2)

instance Ord Name where
  (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2)   `thenCmp`
				        (o1 `compare` o2)

instance Eq NameFlavour where
  f1 == f2 = cmpEq (f1 `compare` f2)

instance Ord NameFlavour where
489
	-- NameS < NameQ < NameU < NameL < NameG
490
  NameS `compare` NameS = EQ
Ian Lynagh's avatar
Ian Lynagh committed
491
  NameS `compare` _     = LT
492

493 494
  (NameQ _)  `compare` NameS      = GT
  (NameQ m1) `compare` (NameQ m2) = m1 `compare` m2
Ian Lynagh's avatar
Ian Lynagh committed
495
  (NameQ _)  `compare` _          = LT
496 497 498

  (NameU _)  `compare` NameS      = GT
  (NameU _)  `compare` (NameQ _)  = GT
499 500 501
  (NameU u1) `compare` (NameU u2) | u1  <# u2 = LT
				  | u1 ==# u2 = EQ
				  | otherwise = GT
Ian Lynagh's avatar
Ian Lynagh committed
502
  (NameU _)  `compare` _     = LT
503

504 505 506 507 508 509
  (NameL _)  `compare` NameS      = GT
  (NameL _)  `compare` (NameQ _)  = GT
  (NameL _)  `compare` (NameU _)  = GT
  (NameL u1) `compare` (NameL u2) | u1  <# u2 = LT
				  | u1 ==# u2 = EQ
				  | otherwise = GT
Ian Lynagh's avatar
Ian Lynagh committed
510
  (NameL _)  `compare` _          = LT
511

512 513 514
  (NameG ns1 p1 m1) `compare` (NameG ns2 p2 m2) = (ns1 `compare` ns2) `thenCmp`
                                            (p1 `compare` p2) `thenCmp`
					    (m1 `compare` m2) 
Ian Lynagh's avatar
Ian Lynagh committed
515
  (NameG _ _ _)    `compare` _ = GT
516

Ian Lynagh's avatar
Ian Lynagh committed
517 518 519 520 521 522 523 524 525 526 527 528 529 530 531
data NameIs = Alone | Applied | Infix

showName :: Name -> String
showName = showName' Alone

showName' :: NameIs -> Name -> String
showName' ni nm
 = case ni of
       Alone        -> nms
       Applied
        | pnam      -> nms
        | otherwise -> "(" ++ nms ++ ")"
       Infix
        | pnam      -> "`" ++ nms ++ "`"
        | otherwise -> nms
532
    where
533 534 535 536 537
	-- For now, we make the NameQ and NameG print the same, even though
	-- NameQ is a qualified name (so what it means depends on what the
	-- current scope is), and NameG is an original name (so its meaning
	-- should be independent of what's in scope.
	-- We may well want to distinguish them in the end.
538 539
	-- Ditto NameU and NameL
        nms = case nm of
Ian Lynagh's avatar
Ian Lynagh committed
540 541 542 543 544
                    Name occ NameS         -> occString occ
                    Name occ (NameQ m)     -> modString m ++ "." ++ occString occ
                    Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ
                    Name occ (NameU u)     -> occString occ ++ "_" ++ show (I# u)
                    Name occ (NameL u)     -> occString occ ++ "_" ++ show (I# u)
545 546 547

        pnam = classify nms

Ian Lynagh's avatar
Ian Lynagh committed
548 549
        -- True if we are function style, e.g. f, [], (,)
        -- False if we are operator style, e.g. +, :+
550
        classify "" = False -- shouldn't happen; . operator is handled below
Ian Lynagh's avatar
Ian Lynagh committed
551
        classify (x:xs) | isAlpha x || (x `elem` "_[]()") =
552 553 554 555
                            case dropWhile (/='.') xs of
                                  (_:xs') -> classify xs'
                                  []      -> True
                        | otherwise = False
556

557
instance Show Name where
Ian Lynagh's avatar
Ian Lynagh committed
558
  show = showName
559

560
-- 	Tuple data and type constructors
aavogt's avatar
aavogt committed
561 562
tupleDataName :: Int -> Name    -- ^ Data constructor
tupleTypeName :: Int -> Name    -- ^ Type constructor
563 564 565 566 567 568 569 570 571

tupleDataName 0 = mk_tup_name 0 DataName 
tupleDataName 1 = error "tupleDataName 1"
tupleDataName n = mk_tup_name (n-1) DataName 

tupleTypeName 0 = mk_tup_name 0 TcClsName 
tupleTypeName 1 = error "tupleTypeName 1"
tupleTypeName n = mk_tup_name (n-1) TcClsName 

Ian Lynagh's avatar
Ian Lynagh committed
572
mk_tup_name :: Int -> NameSpace -> Name
573
mk_tup_name n_commas space
Ian Lynagh's avatar
Ian Lynagh committed
574
  = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod)
575 576
  where
    occ = mkOccName ('(' : replicate n_commas ',' ++ ")")
Ian Lynagh's avatar
Ian Lynagh committed
577 578
    -- XXX Should it be GHC.Unit for 0 commas?
    tup_mod = mkModName "GHC.Tuple"
579 580


581

582 583 584 585 586 587 588 589 590 591 592 593 594
-----------------------------------------------------
--		Locations
-----------------------------------------------------

data Loc
  = Loc { loc_filename :: String
	, loc_package  :: String
	, loc_module   :: String
	, loc_start    :: CharPos
	, loc_end      :: CharPos }

type CharPos = (Int, Int)	-- Line and character position

595

596 597 598 599 600 601
-----------------------------------------------------
--
--	The Info returned by reification
--
-----------------------------------------------------

aavogt's avatar
aavogt committed
602 603
-- | Obtained from 'reify' in the 'Q' Monad.
data Info
604 605 606 607 608 609
  = -- | A class is reified to its declaration 
    --   and a list of its instances
    ClassI 
        Dec             -- Declaration of the class
        [ClassInstance]	-- The instances of that class

610 611 612 613 614 615 616
  | ClassOpI
	Name	-- The class op itself
	Type 	-- Type of the class-op (fully polymoprhic)
	Name 	-- Name of the parent class
	Fixity

  | TyConI Dec
617 618 619 620 621 622 623

  | PrimTyConI 	-- Ones that can't be expressed with a data type 
		-- decl, such as (->), Int#
	Name 
	Int	-- Arity
	Bool	-- False => lifted type; True => unlifted

624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640
  | DataConI 
	Name	-- The data con itself
	Type 	-- Type of the constructor (fully polymorphic)
	Name 	-- Name of the parent TyCon
	Fixity

  | VarI 
	Name	-- The variable itself
	Type 
	(Maybe Dec)	-- Nothing for lambda-bound variables, and 
			-- for anything else TH can't figure out
			-- E.g. [| let x = 1 in $(do { d <- reify 'x; .. }) |]
	Fixity

  | TyVarI 	-- Scoped type variable
	Name
	Type	-- What it is bound to
641
  deriving( Show, Data, Typeable )
642

643 644 645 646 647 648 649 650 651 652
-- | 'ClassInstance' desribes a single instance of a class
data ClassInstance 
  = ClassInstance {
      ci_dfun :: Name,	  -- The witness
      ci_tvs  :: [TyVarBndr], 
      ci_cxt  :: Cxt,
      ci_cls  :: Name,  
      ci_tys  :: [Type]
    } deriving( Show, Data, Typeable )

653 654 655 656
data Fixity          = Fixity Int FixityDirection
    deriving( Eq, Show, Data, Typeable )
data FixityDirection = InfixL | InfixR | InfixN
    deriving( Eq, Show, Data, Typeable )
657

658
maxPrecedence :: Int
659
maxPrecedence = (9::Int)
660 661

defaultFixity :: Fixity
662 663 664 665 666 667 668 669 670 671 672
defaultFixity = Fixity maxPrecedence InfixL


-----------------------------------------------------
--
--	The main syntax data types
--
-----------------------------------------------------

data Lit = CharL Char 
         | StringL String 
aavogt's avatar
aavogt committed
673
         | IntegerL Integer     -- ^ Used for overloaded and non-overloaded
674 675 676 677 678
                                -- literals. We don't have a good way to
                                -- represent non-overloaded literals at
                                -- the moment. Maybe that doesn't matter?
         | RationalL Rational   -- Ditto
         | IntPrimL Integer
679
         | WordPrimL Integer
680 681
         | FloatPrimL Rational
         | DoublePrimL Rational
682
         | StringPrimL String	-- ^ A primitive C-style string, type Addr#
683
    deriving( Show, Eq, Data, Typeable )
684 685 686 687 688

    -- We could add Int, Float, Double etc, as we do in HsLit, 
    -- but that could complicate the
    -- suppposedly-simple TH.Syntax literal type

aavogt's avatar
aavogt committed
689
-- | Pattern in Haskell given in @{}@
690
data Pat 
aavogt's avatar
aavogt committed
691 692 693 694 695 696 697 698 699 700 701 702
  = LitP Lit                      -- ^ @{ 5 or 'c' }@
  | VarP Name                     -- ^ @{ x }@
  | TupP [Pat]                    -- ^ @{ (p1,p2) }@
  | ConP Name [Pat]               -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@
  | InfixP Pat Name Pat           -- ^ @foo ({x :+ y}) = e@
  | TildeP Pat                    -- ^ @{ ~p }@
  | BangP Pat                     -- ^ @{ !p }@
  | AsP Name Pat                  -- ^ @{ x \@ p }@
  | WildP                         -- ^ @{ _ }@
  | RecP Name [FieldPat]          -- ^ @f (Pt { pointx = x }) = g x@
  | ListP [ Pat ]                 -- ^ @{ [1,2,3] }@
  | SigP Pat Type                 -- ^ @{ p :: t }@
reinerp's avatar
reinerp committed
703
  | ViewP Exp Pat                 -- ^ @{ e -> p }@
704
  deriving( Show, Eq, Data, Typeable )
705 706 707

type FieldPat = (Name,Pat)

aavogt's avatar
aavogt committed
708
data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@
709
    deriving( Show, Eq, Data, Typeable )
710
data Clause = Clause [Pat] Body [Dec]
aavogt's avatar
aavogt committed
711
                                  -- ^ @f { p1 p2 = body where decs }@
712
    deriving( Show, Eq, Data, Typeable )
713
 
714 715 716
-- | The 'CompE' constructor represents a list comprehension, and 
-- takes a ['Stmt'].  The result expression of the comprehension is
-- the *last* of these, and should be a 'NoBindS'.
aavogt's avatar
aavogt committed
717 718 719 720 721 722
--
-- E.g. translation:
--
-- > [ f x | x <- xs ]
--
-- > CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]
723
data Exp 
aavogt's avatar
aavogt committed
724 725 726 727
  = VarE Name                          -- ^ @{ x }@
  | ConE Name                          -- ^ @data T1 = C1 t1 t2; p = {C1} e1 e2  @
  | LitE Lit                           -- ^ @{ 5 or 'c'}@
  | AppE Exp Exp                       -- ^ @{ f x }@
728

aavogt's avatar
aavogt committed
729 730
  | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@
    --
731 732 733 734 735 736
    -- It's a bit gruesome to use an Exp as the
    -- operator, but how else can we distinguish
    -- constructors from non-constructors?
    -- Maybe there should be a var-or-con type?
    -- Or maybe we should leave it to the String itself?

aavogt's avatar
aavogt committed
737 738 739 740 741 742 743 744 745 746 747 748
  | LamE [Pat] Exp                     -- ^ @{ \ p1 p2 -> e }@
  | TupE [Exp]                         -- ^ @{ (e1,e2) }  @
  | CondE Exp Exp Exp                  -- ^ @{ if e1 then e2 else e3 }@
  | LetE [Dec] Exp                     -- ^ @{ let x=e1;   y=e2 in e3 }@
  | CaseE Exp [Match]                  -- ^ @{ case e of m1; m2 }@
  | DoE [Stmt]                         -- ^ @{ do { p <- e1; e2 }  }@
  | CompE [Stmt]                       -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@
  | ArithSeqE Range                    -- ^ @{ [ 1 ,2 .. 10 ] }@
  | ListE [ Exp ]                      -- ^ @{ [1,2,3] }@
  | SigE Exp Type                      -- ^ @{ e :: t }@
  | RecConE Name [FieldExp]            -- ^ @{ T { x = y, z = w } }@
  | RecUpdE Exp [FieldExp]             -- ^ @{ (f x) { z = w } }@
749
  deriving( Show, Eq, Data, Typeable )
750 751 752 753 754 755

type FieldExp = (Name,Exp)

-- Omitted: implicit parameters

data Body
aavogt's avatar
aavogt committed
756 757
  = GuardedB [(Guard,Exp)]   -- ^ @f p { | e1 = e2 | e3 = e4 } where ds@
  | NormalB Exp              -- ^ @f p { = e } where ds@
758
  deriving( Show, Eq, Data, Typeable )
759

760 761 762
data Guard
  = NormalG Exp
  | PatG [Stmt]
763
  deriving( Show, Eq, Data, Typeable )
764

765 766 767 768 769
data Stmt
  = BindS Pat Exp
  | LetS [ Dec ]
  | NoBindS Exp
  | ParS [[Stmt]]
770
  deriving( Show, Eq, Data, Typeable )
771 772 773

data Range = FromR Exp | FromThenR Exp Exp
           | FromToR Exp Exp | FromThenToR Exp Exp Exp
774
          deriving( Show, Eq, Data, Typeable )
775 776
  
data Dec 
aavogt's avatar
aavogt committed
777 778
  = FunD Name [Clause]            -- ^ @{ f p1 p2 = b where decs }@
  | ValD Pat Body [Dec]           -- ^ @{ p = b where decs }@
779
  | DataD Cxt Name [TyVarBndr] 
aavogt's avatar
aavogt committed
780 781
         [Con] [Name]             -- ^ @{ data Cxt x => T x = A x | B (T x)
                                  --       deriving (Z,W)}@
782
  | NewtypeD Cxt Name [TyVarBndr] 
aavogt's avatar
aavogt committed
783 784 785
         Con [Name]               -- ^ @{ newtype Cxt x => T x = A (B x)
                                  --       deriving (Z,W)}@
  | TySynD Name [TyVarBndr] Type  -- ^ @{ type T x = (x,x) }@
786
  | ClassD Cxt Name [TyVarBndr] 
aavogt's avatar
aavogt committed
787 788 789 790
         [FunDep] [Dec]           -- ^ @{ class Eq a => Ord a where ds }@
  | InstanceD Cxt Type [Dec]      -- ^ @{ instance Show w => Show [w]
                                  --       where ds }@
  | SigD Name Type                -- ^ @{ length :: [a] -> Int }@
791
  | ForeignD Foreign
aavogt's avatar
aavogt committed
792 793 794 795 796

  -- | pragmas
  | PragmaD Pragma                -- ^ @{ {-# INLINE [1] foo #-} }@

  -- | type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
797
  | FamilyD FamFlavour Name 
aavogt's avatar
aavogt committed
798
         [TyVarBndr] (Maybe Kind) -- ^ @{ type family T a b c :: * }@
799
                                 
800
  | DataInstD Cxt Name [Type]
aavogt's avatar
aavogt committed
801
         [Con] [Name]             -- ^ @{ data instance Cxt x => T [x] = A x 
802
                                  --                                | B (T x)
aavogt's avatar
aavogt committed
803
                                  --       deriving (Z,W)}@
804
  | NewtypeInstD Cxt Name [Type]
aavogt's avatar
aavogt committed
805 806 807
         Con [Name]               -- ^ @{ newtype instance Cxt x => T [x] = A (B x)
                                  --       deriving (Z,W)}@
  | TySynInstD Name [Type] Type   -- ^ @{ type instance T (Maybe x) = (x,x) }@
808
  deriving( Show, Eq, Data, Typeable )
809

810
data FunDep = FunDep [Name] [Name]
811
  deriving( Show, Eq, Data, Typeable )
812

813 814 815
data FamFlavour = TypeFam | DataFam
  deriving( Show, Eq, Data, Typeable )

816 817
data Foreign = ImportF Callconv Safety String Name Type
             | ExportF Callconv        String Name Type
818
         deriving( Show, Eq, Data, Typeable )
819 820

data Callconv = CCall | StdCall
821
          deriving( Show, Eq, Data, Typeable )
822

823
data Safety = Unsafe | Safe | Threadsafe | Interruptible
824
        deriving( Show, Eq, Data, Typeable )
825

826 827 828 829 830 831 832 833 834 835
data Pragma = InlineP     Name InlineSpec
            | SpecialiseP Name Type (Maybe InlineSpec)
        deriving( Show, Eq, Data, Typeable )

data InlineSpec 
  = InlineSpec Bool                 -- False: no inline; True: inline 
               Bool                 -- False: fun-like; True: constructor-like
               (Maybe (Bool, Int))  -- False: before phase; True: from phase
  deriving( Show, Eq, Data, Typeable )

aavogt's avatar
aavogt committed
836
type Cxt = [Pred]                 -- ^ @(Eq a, Ord b)@
837

aavogt's avatar
aavogt committed
838 839
data Pred = ClassP Name [Type]    -- ^ @Eq (Int, a)@
          | EqualP Type Type      -- ^ @F a ~ Bool@
840
          deriving( Show, Eq, Data, Typeable )
841 842

data Strict = IsStrict | NotStrict
843
         deriving( Show, Eq, Data, Typeable )
844

aavogt's avatar
aavogt committed
845 846 847 848
data Con = NormalC Name [StrictType]          -- ^ @C Int a@
         | RecC Name [VarStrictType]          -- ^ @C { v :: Int, w :: a }@
         | InfixC StrictType Name StrictType  -- ^ @Int :+ a@
         | ForallC [TyVarBndr] Cxt Con        -- ^ @forall a. Eq a => C [a]@
849
         deriving( Show, Eq, Data, Typeable )
850 851 852 853

type StrictType = (Strict, Type)
type VarStrictType = (Name, Strict, Type)

aavogt's avatar
aavogt committed
854 855 856 857 858 859 860 861
data Type = ForallT [TyVarBndr] Cxt Type  -- ^ @forall <vars>. <ctxt> -> <type>@
          | VarT Name                     -- ^ @a@
          | ConT Name                     -- ^ @T@
          | TupleT Int                    -- ^ @(,), (,,), etc.@
          | ArrowT                        -- ^ @->@
          | ListT                         -- ^ @[]@
          | AppT Type Type                -- ^ @T a b@
          | SigT Type Kind                -- ^ @t :: k@
862 863
      deriving( Show, Eq, Data, Typeable )

aavogt's avatar
aavogt committed
864 865
data TyVarBndr = PlainTV  Name            -- ^ @a@
               | KindedTV Name Kind       -- ^ @(a :: k)@
866 867
      deriving( Show, Eq, Data, Typeable )

aavogt's avatar
aavogt committed
868 869
data Kind = StarK                         -- ^ @'*'@
          | ArrowK Kind Kind              -- ^ @k1 -> k2@
870
      deriving( Show, Eq, Data, Typeable )
871 872 873 874 875 876 877 878 879 880 881

-----------------------------------------------------
--		Internal helper functions
-----------------------------------------------------

cmpEq :: Ordering -> Bool
cmpEq EQ = True
cmpEq _  = False

thenCmp :: Ordering -> Ordering -> Ordering
thenCmp EQ o2 = o2
Ian Lynagh's avatar
Ian Lynagh committed
882
thenCmp o1 _  = o1
883