Syntax.hs 28.1 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

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

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

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

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

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

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

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

	-- Error reporting and recovery
aavogt's avatar
aavogt committed
74
  qReport  :: Bool -> String -> m ()	-- ^ Report an error (True) or warning (False)
75
					-- ...but carry on; use 'fail' to stop
aavogt's avatar
aavogt committed
76 77 78
  qRecover :: m a -- ^ the error handler
           -> m a -- ^ action which may fail
           -> m a		-- ^ Recover from the monadic 'fail'
79 80 81
 
	-- Inspect the type-checker's environment
  qReify :: Name -> m Info
82
  qLocation :: m Loc
83 84

  qRunIO :: IO a -> m a
aavogt's avatar
aavogt committed
85
  -- ^ Input/output (dangerous)
86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106


-----------------------------------------------------
--	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)

Ian Lynagh's avatar
Ian Lynagh committed
107
  qReify _     = badIO "reify"
108
  qLocation    = badIO "currentLocation"
Ian Lynagh's avatar
Ian Lynagh committed
109
  qRecover _ _ = badIO "recover" -- Maybe we could fix this?
110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137

  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)
138
  fail s     = report True s >> Q (fail "Q monad failure")
139

140 141 142
instance Functor Q where
  fmap f (Q x) = Q (fmap f x)

143 144 145 146 147 148 149 150
----------------------------------------------------
-- 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
151 152 153
recover :: Q a -- ^ recover with this one
        -> Q a -- ^ failing action
        -> Q a
154 155
recover (Q r) (Q m) = Q (qRecover r m)

156
-- | 'reify' looks up information about the 'Name'
157 158 159
reify :: Name -> Q Info
reify v = Q (qReify v)

160
-- | 'location' gives you the 'Location' at which this
161
-- computation is spliced.
162 163
location :: Q Loc
location = Q qLocation
164

dons's avatar
dons committed
165
-- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
166 167 168 169 170 171
-- 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.
172 173 174 175
runIO :: IO a -> Q a
runIO m = Q (qRunIO m)

instance Quasi Q where
176 177 178 179 180 181
  qNewName  = newName
  qReport   = report
  qRecover  = recover 
  qReify    = reify
  qLocation = location
  qRunIO    = runIO
182 183 184 185


----------------------------------------------------
-- The following operations are used solely in DsMeta when desugaring brackets
186
-- They are not necessary for the user, who can use ordinary return and (>>=) etc
187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219

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)

220 221 222 223 224 225 226 227
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)

228 229 230
instance Lift a => Lift [a] where
  lift xs = do { xs' <- mapM lift xs; return (ListE xs') }

231 232 233 234
liftString :: String -> Q Exp
-- Used in TcExpr to short-circuit the lifting for strings
liftString s = return (LitE (StringL s))

235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261
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]

262 263 264 265 266 267 268 269 270 271
-- 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
272 273
trueName  = mkNameG DataName "ghc-prim" "GHC.Bool" "True"
falseName = mkNameG DataName "ghc-prim" "GHC.Bool" "False"
274

275 276 277 278 279 280 281 282
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"

283 284 285 286 287 288

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

mkModName :: String -> ModName
289
mkModName s = ModName s
290 291

modString :: ModName -> String
292
modString (ModName m) = m
293

294 295

mkPkgName :: String -> PkgName
296
mkPkgName s = PkgName s
297 298

pkgString :: PkgName -> String
299
pkgString (PkgName m) = m
300 301


302 303 304 305 306
-----------------------------------------------------
--		OccName
-----------------------------------------------------

mkOccName :: String -> OccName
307
mkOccName s = OccName s
308 309

occString :: OccName -> String
310
occString (OccName occ) = occ
311 312 313 314 315 316


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

aavogt's avatar
aavogt committed
317 318
-- |
-- For "global" names ('NameG') we need a totally unique name,
319 320
-- so we must include the name-space of the thing
--
aavogt's avatar
aavogt committed
321
-- For unique-numbered things ('NameU'), we've got a unique reference
322 323
-- anyway, so no need for name space
--
aavogt's avatar
aavogt committed
324
-- For dynamically bound thing ('NameS') we probably want them to
325 326
-- in a context-dependent way, so again we don't want the name
-- space.  For example:
aavogt's avatar
aavogt committed
327 328 329
--
-- > let v = mkName "T" in [| data $v = $v |]
--
330
-- Here we use the same Name for both type constructor and data constructor
aavogt's avatar
aavogt committed
331 332 333 334 335 336 337 338 339 340
--
--
-- 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
341
data Name = Name OccName NameFlavour deriving (Typeable, Data)
342 343

data NameFlavour
aavogt's avatar
aavogt committed
344 345
  = NameS           -- ^ An unqualified name; dynamically bound
  | NameQ ModName   -- ^ A qualified name; dynamically bound
346

aavogt's avatar
aavogt committed
347
  | NameU Int#      -- ^ A unique local name
348

349

aavogt's avatar
aavogt committed
350 351 352 353
  | 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)
                --
354 355
				-- Need the namespace too to be sure which 
				-- thing we are naming
356 357
  deriving ( Typeable )

aavogt's avatar
aavogt committed
358
-- |
359 360 361 362 363 364 365 366 367 368
-- 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
369
instance Data NameFlavour where
370 371 372 373 374 375 376 377 378 379 380 381
     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"
382 383 384 385 386 387 388
     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
389 390 391 392 393 394
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
395

Ross Paterson's avatar
Ross Paterson committed
396
ty_NameFlavour :: Data.DataType
397 398 399
ty_NameFlavour = mkDataType "Language.Haskell.TH.Syntax.NameFlavour"
                            [con_NameS, con_NameQ, con_NameU,
                             con_NameL, con_NameG]
400

aavogt's avatar
aavogt committed
401 402 403
data NameSpace = VarName	-- ^ Variables
	       | DataName	-- ^ Data constructors 
	       | TcClsName	-- ^ Type constructors and classes; Haskell has them
404
				-- in the same name space for now.
405
	       deriving( Eq, Ord, Data, Typeable )
406 407 408

type Uniq = Int

aavogt's avatar
aavogt committed
409
-- | Base, unqualified name.
410 411 412
nameBase :: Name -> String
nameBase (Name occ _) = occString occ

413
nameModule :: Name -> Maybe String
Ian Lynagh's avatar
Ian Lynagh committed
414
nameModule (Name _ (NameQ m))     = Just (modString m)
415
nameModule (Name _ (NameG _ _ m)) = Just (modString m)
Ian Lynagh's avatar
Ian Lynagh committed
416
nameModule _                      = Nothing
417

418
mkName :: String -> Name
aavogt's avatar
aavogt committed
419
-- ^ The string can have a '.', thus "Foo.baz",
420 421 422 423 424 425
-- 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
426 427 428
--
-- > Foo.Baz.x   as    Qual Foo.Baz x
--
429 430 431 432 433
-- So we parse it from back to front
mkName str
  = split [] (reverse str)
  where
    split occ []        = Name (mkOccName occ) NameS
434 435 436 437 438 439 440 441 442
    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
443
    split occ (c:rev)   = split (c:occ) rev
444

aavogt's avatar
aavogt committed
445 446
-- | Only used internally
mkNameU :: String -> Uniq -> Name
447 448
mkNameU s (I# u) = Name (mkOccName s) (NameU u)

aavogt's avatar
aavogt committed
449 450
-- | Only used internally
mkNameL :: String -> Uniq -> Name
451 452
mkNameL s (I# u) = Name (mkOccName s) (NameL u)

aavogt's avatar
aavogt committed
453 454 455
-- | 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
456
  = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName modu))
457

458
mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name
459 460 461 462 463 464 465 466 467 468 469 470 471 472 473
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
474
	-- NameS < NameQ < NameU < NameL < NameG
475
  NameS `compare` NameS = EQ
Ian Lynagh's avatar
Ian Lynagh committed
476
  NameS `compare` _     = LT
477

478 479
  (NameQ _)  `compare` NameS      = GT
  (NameQ m1) `compare` (NameQ m2) = m1 `compare` m2
Ian Lynagh's avatar
Ian Lynagh committed
480
  (NameQ _)  `compare` _          = LT
481 482 483

  (NameU _)  `compare` NameS      = GT
  (NameU _)  `compare` (NameQ _)  = GT
484 485 486
  (NameU u1) `compare` (NameU u2) | u1  <# u2 = LT
				  | u1 ==# u2 = EQ
				  | otherwise = GT
Ian Lynagh's avatar
Ian Lynagh committed
487
  (NameU _)  `compare` _     = LT
488

489 490 491 492 493 494
  (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
495
  (NameL _)  `compare` _          = LT
496

497 498 499
  (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
500
  (NameG _ _ _)    `compare` _ = GT
501

Ian Lynagh's avatar
Ian Lynagh committed
502 503 504 505 506 507 508 509 510 511 512 513 514 515 516
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
517
    where
518 519 520 521 522
	-- 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.
523 524
	-- Ditto NameU and NameL
        nms = case nm of
Ian Lynagh's avatar
Ian Lynagh committed
525 526 527 528 529
                    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)
530 531 532

        pnam = classify nms

Ian Lynagh's avatar
Ian Lynagh committed
533 534
        -- True if we are function style, e.g. f, [], (,)
        -- False if we are operator style, e.g. +, :+
535
        classify "" = False -- shouldn't happen; . operator is handled below
Ian Lynagh's avatar
Ian Lynagh committed
536
        classify (x:xs) | isAlpha x || (x `elem` "_[]()") =
537 538 539 540
                            case dropWhile (/='.') xs of
                                  (_:xs') -> classify xs'
                                  []      -> True
                        | otherwise = False
541

542
instance Show Name where
Ian Lynagh's avatar
Ian Lynagh committed
543
  show = showName
544

545
-- 	Tuple data and type constructors
aavogt's avatar
aavogt committed
546 547
tupleDataName :: Int -> Name    -- ^ Data constructor
tupleTypeName :: Int -> Name    -- ^ Type constructor
548 549 550 551 552 553 554 555 556

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
557
mk_tup_name :: Int -> NameSpace -> Name
558
mk_tup_name n_commas space
Ian Lynagh's avatar
Ian Lynagh committed
559
  = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod)
560 561
  where
    occ = mkOccName ('(' : replicate n_commas ',' ++ ")")
Ian Lynagh's avatar
Ian Lynagh committed
562 563
    -- XXX Should it be GHC.Unit for 0 commas?
    tup_mod = mkModName "GHC.Tuple"
564 565


566

567 568 569 570 571 572 573 574 575 576 577 578 579
-----------------------------------------------------
--		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

580

581 582 583 584 585 586
-----------------------------------------------------
--
--	The Info returned by reification
--
-----------------------------------------------------

aavogt's avatar
aavogt committed
587 588
-- | Obtained from 'reify' in the 'Q' Monad.
data Info
589 590 591 592 593 594 595 596
  = ClassI Dec
  | ClassOpI
	Name	-- The class op itself
	Type 	-- Type of the class-op (fully polymoprhic)
	Name 	-- Name of the parent class
	Fixity

  | TyConI Dec
597 598 599 600 601 602 603

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

604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620
  | 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
621
  deriving( Show, Data, Typeable )
622

623 624 625 626
data Fixity          = Fixity Int FixityDirection
    deriving( Eq, Show, Data, Typeable )
data FixityDirection = InfixL | InfixR | InfixN
    deriving( Eq, Show, Data, Typeable )
627

628
maxPrecedence :: Int
629
maxPrecedence = (9::Int)
630 631

defaultFixity :: Fixity
632 633 634 635 636 637 638 639 640 641 642
defaultFixity = Fixity maxPrecedence InfixL


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

data Lit = CharL Char 
         | StringL String 
aavogt's avatar
aavogt committed
643
         | IntegerL Integer     -- ^ Used for overloaded and non-overloaded
644 645 646 647 648
                                -- 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
649
         | WordPrimL Integer
650 651
         | FloatPrimL Rational
         | DoublePrimL Rational
652
         | StringPrimL String	-- ^ A primitive C-style string, type Addr#
653
    deriving( Show, Eq, Data, Typeable )
654 655 656 657 658

    -- 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
659
-- | Pattern in Haskell given in @{}@
660
data Pat 
aavogt's avatar
aavogt committed
661 662 663 664 665 666 667 668 669 670 671 672
  = 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 }@
673
  deriving( Show, Eq, Data, Typeable )
674 675 676

type FieldPat = (Name,Pat)

aavogt's avatar
aavogt committed
677
data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@
678
    deriving( Show, Eq, Data, Typeable )
679
data Clause = Clause [Pat] Body [Dec]
aavogt's avatar
aavogt committed
680
                                  -- ^ @f { p1 p2 = body where decs }@
681
    deriving( Show, Eq, Data, Typeable )
682
 
683 684 685
-- | 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
686 687 688 689 690 691
--
-- E.g. translation:
--
-- > [ f x | x <- xs ]
--
-- > CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]
692
data Exp 
aavogt's avatar
aavogt committed
693 694 695 696
  = VarE Name                          -- ^ @{ x }@
  | ConE Name                          -- ^ @data T1 = C1 t1 t2; p = {C1} e1 e2  @
  | LitE Lit                           -- ^ @{ 5 or 'c'}@
  | AppE Exp Exp                       -- ^ @{ f x }@
697

aavogt's avatar
aavogt committed
698 699
  | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@
    --
700 701 702 703 704 705
    -- 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
706 707 708 709 710 711 712 713 714 715 716 717
  | 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 } }@
718
  deriving( Show, Eq, Data, Typeable )
719 720 721 722 723 724

type FieldExp = (Name,Exp)

-- Omitted: implicit parameters

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

729 730 731
data Guard
  = NormalG Exp
  | PatG [Stmt]
732
  deriving( Show, Eq, Data, Typeable )
733

734 735 736 737 738
data Stmt
  = BindS Pat Exp
  | LetS [ Dec ]
  | NoBindS Exp
  | ParS [[Stmt]]
739
  deriving( Show, Eq, Data, Typeable )
740 741 742

data Range = FromR Exp | FromThenR Exp Exp
           | FromToR Exp Exp | FromThenToR Exp Exp Exp
743
          deriving( Show, Eq, Data, Typeable )
744 745
  
data Dec 
aavogt's avatar
aavogt committed
746 747
  = FunD Name [Clause]            -- ^ @{ f p1 p2 = b where decs }@
  | ValD Pat Body [Dec]           -- ^ @{ p = b where decs }@
748
  | DataD Cxt Name [TyVarBndr] 
aavogt's avatar
aavogt committed
749 750
         [Con] [Name]             -- ^ @{ data Cxt x => T x = A x | B (T x)
                                  --       deriving (Z,W)}@
751
  | NewtypeD Cxt Name [TyVarBndr] 
aavogt's avatar
aavogt committed
752 753 754
         Con [Name]               -- ^ @{ newtype Cxt x => T x = A (B x)
                                  --       deriving (Z,W)}@
  | TySynD Name [TyVarBndr] Type  -- ^ @{ type T x = (x,x) }@
755
  | ClassD Cxt Name [TyVarBndr] 
aavogt's avatar
aavogt committed
756 757 758 759
         [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 }@
760
  | ForeignD Foreign
aavogt's avatar
aavogt committed
761 762 763 764 765

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

  -- | type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
766
  | FamilyD FamFlavour Name 
aavogt's avatar
aavogt committed
767
         [TyVarBndr] (Maybe Kind) -- ^ @{ type family T a b c :: * }@
768
                                 
769
  | DataInstD Cxt Name [Type]
aavogt's avatar
aavogt committed
770
         [Con] [Name]             -- ^ @{ data instance Cxt x => T [x] = A x 
771
                                  --                                | B (T x)
aavogt's avatar
aavogt committed
772
                                  --       deriving (Z,W)}@
773
  | NewtypeInstD Cxt Name [Type]
aavogt's avatar
aavogt committed
774 775 776
         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) }@
777
  deriving( Show, Eq, Data, Typeable )
778

779
data FunDep = FunDep [Name] [Name]
780
  deriving( Show, Eq, Data, Typeable )
781

782 783 784
data FamFlavour = TypeFam | DataFam
  deriving( Show, Eq, Data, Typeable )

785 786
data Foreign = ImportF Callconv Safety String Name Type
             | ExportF Callconv        String Name Type
787
         deriving( Show, Eq, Data, Typeable )
788 789

data Callconv = CCall | StdCall
790
          deriving( Show, Eq, Data, Typeable )
791 792

data Safety = Unsafe | Safe | Threadsafe
793
        deriving( Show, Eq, Data, Typeable )
794

795 796 797 798 799 800 801 802 803 804
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
805
type Cxt = [Pred]                 -- ^ @(Eq a, Ord b)@
806

aavogt's avatar
aavogt committed
807 808
data Pred = ClassP Name [Type]    -- ^ @Eq (Int, a)@
          | EqualP Type Type      -- ^ @F a ~ Bool@
809
          deriving( Show, Eq, Data, Typeable )
810 811

data Strict = IsStrict | NotStrict
812
         deriving( Show, Eq, Data, Typeable )
813

aavogt's avatar
aavogt committed
814 815 816 817
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]@
818
         deriving( Show, Eq, Data, Typeable )
819 820 821 822

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

aavogt's avatar
aavogt committed
823 824 825 826 827 828 829 830
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@
831 832
      deriving( Show, Eq, Data, Typeable )

aavogt's avatar
aavogt committed
833 834
data TyVarBndr = PlainTV  Name            -- ^ @a@
               | KindedTV Name Kind       -- ^ @(a :: k)@
835 836
      deriving( Show, Eq, Data, Typeable )

aavogt's avatar
aavogt committed
837 838
data Kind = StarK                         -- ^ @'*'@
          | ArrowK Kind Kind              -- ^ @k1 -> k2@
839
      deriving( Show, Eq, Data, Typeable )
840 841 842 843 844 845 846 847 848 849 850

-----------------------------------------------------
--		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
851
thenCmp o1 _  = o1
852