Syntax.hs 27.4 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 29

	-- Names
Ian Lynagh's avatar
Ian Lynagh committed
30
	Name(..), mkName, newName, nameBase, nameModule,
31
        showName, showName', NameIs(..),
32 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 42 43 44
	Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,

	-- Internal functions
	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 71 72 73 74 75 76 77 78 79 80
	-- Fresh names
  qNewName :: String -> m Name

	-- Error reporting and recovery
  qReport  :: Bool -> String -> m ()	-- Report an error (True) or warning (False)
					-- ...but carry on; use 'fail' to stop
  qRecover :: m a -> m a -> m a		-- Recover from the monadic 'fail'
					-- The first arg is the error handler
 
	-- Inspect the type-checker's environment
  qReify :: Name -> m Info
81
  qLocation :: m Loc
82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105

	-- Input/output (dangerous)
  qRunIO :: IO a -> m a


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

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

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

142 143 144 145 146 147 148 149 150 151 152
----------------------------------------------------
-- 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)

recover :: Q a -> Q a -> Q a
recover (Q r) (Q m) = Q (qRecover r m)

153
-- | 'reify' looks up information about the 'Name'
154 155 156
reify :: Name -> Q Info
reify v = Q (qReify v)

157
-- | 'location' gives you the 'Location' at which this
158
-- computation is spliced.
159 160
location :: Q Loc
location = Q qLocation
161

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

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


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

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)

217 218 219 220 221 222 223 224
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)

225 226 227
instance Lift a => Lift [a] where
  lift xs = do { xs' <- mapM lift xs; return (ListE xs') }

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

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

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

272 273 274 275 276 277 278 279
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"

280 281 282 283 284 285

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

mkModName :: String -> ModName
286
mkModName s = ModName s
287 288

modString :: ModName -> String
289
modString (ModName m) = m
290

291 292

mkPkgName :: String -> PkgName
293
mkPkgName s = PkgName s
294 295

pkgString :: PkgName -> String
296
pkgString (PkgName m) = m
297 298


299 300 301 302 303
-----------------------------------------------------
--		OccName
-----------------------------------------------------

mkOccName :: String -> OccName
304
mkOccName s = OccName s
305 306

occString :: OccName -> String
307
occString (OccName occ) = occ
308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325


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

-- For "global" names (NameG) we need a totally unique name,
-- so we must include the name-space of the thing
--
-- For unique-numbered things (NameU), we've got a unique reference
-- anyway, so no need for name space
--
-- For dynamically bound thing (NameS) we probably want them to 
-- in a context-dependent way, so again we don't want the name
-- space.  For example:
--	let v = mkName "T" in [| data $v = $v |]
-- Here we use the same Name for both type constructor and data constructor

326
data Name = Name OccName NameFlavour deriving (Typeable, Data)
327 328

data NameFlavour
329 330
  = NameS 			-- An unqualified name; dynamically bound
  | NameQ ModName		-- A qualified name; dynamically bound
331

332
  | NameU Int#			-- A unique local name
333

334 335 336 337 338 339 340 341
	-- The next two are for lexically-scoped names that
	-- are bound *outside* the TH syntax tree, 
	-- either globally (NameG) or locally (NameL)
	-- e.g. 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

  | NameL Int#			-- 
342
  | NameG NameSpace PkgName ModName	-- An original name (occurrences only, not binders)
343 344
				-- Need the namespace too to be sure which 
				-- thing we are naming
345 346
  deriving ( Typeable )

347 348 349 350 351 352 353 354 355 356
-- 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
357
instance Data NameFlavour where
358 359 360 361 362 363 364 365 366 367 368 369
     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"
370 371 372 373 374 375 376
     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
377 378 379 380 381 382
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
383

Ross Paterson's avatar
Ross Paterson committed
384
ty_NameFlavour :: Data.DataType
385 386 387
ty_NameFlavour = mkDataType "Language.Haskell.TH.Syntax.NameFlavour"
                            [con_NameS, con_NameQ, con_NameU,
                             con_NameL, con_NameG]
388 389 390 391 392

data NameSpace = VarName	-- Variables
	       | DataName	-- Data constructors 
	       | TcClsName	-- Type constructors and classes; Haskell has them
				-- in the same name space for now.
393
	       deriving( Eq, Ord, Data, Typeable )
394 395 396 397 398 399

type Uniq = Int

nameBase :: Name -> String
nameBase (Name occ _) = occString occ

400
nameModule :: Name -> Maybe String
Ian Lynagh's avatar
Ian Lynagh committed
401
nameModule (Name _ (NameQ m))     = Just (modString m)
402
nameModule (Name _ (NameG _ _ m)) = Just (modString m)
Ian Lynagh's avatar
Ian Lynagh committed
403
nameModule _                      = Nothing
404

405
mkName :: String -> Name
406 407 408 409 410 411 412 413 414 415 416 417 418
-- The string can have a '.', thus "Foo.baz",
-- 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 
--	Foo.Baz.x as Qual Foo.Baz x
-- So we parse it from back to front
mkName str
  = split [] (reverse str)
  where
    split occ []        = Name (mkOccName occ) NameS
419 420 421 422 423 424 425 426 427
    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
428
    split occ (c:rev)   = split (c:occ) rev
429 430 431 432

mkNameU :: String -> Uniq -> Name	-- Only used internally
mkNameU s (I# u) = Name (mkOccName s) (NameU u)

433 434 435
mkNameL :: String -> Uniq -> Name	-- Only used internally
mkNameL s (I# u) = Name (mkOccName s) (NameL u)

436
mkNameG :: NameSpace -> String -> String -> String -> Name	-- Used for 'x etc, but not available
Ian Lynagh's avatar
Ian Lynagh committed
437 438
mkNameG ns pkg modu occ 					-- to the programmer
  = Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName modu))
439

440
mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name
441 442 443 444 445 446 447 448 449 450 451 452 453 454 455
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
456
	-- NameS < NameQ < NameU < NameL < NameG
457
  NameS `compare` NameS = EQ
Ian Lynagh's avatar
Ian Lynagh committed
458
  NameS `compare` _     = LT
459

460 461
  (NameQ _)  `compare` NameS      = GT
  (NameQ m1) `compare` (NameQ m2) = m1 `compare` m2
Ian Lynagh's avatar
Ian Lynagh committed
462
  (NameQ _)  `compare` _          = LT
463 464 465

  (NameU _)  `compare` NameS      = GT
  (NameU _)  `compare` (NameQ _)  = GT
466 467 468
  (NameU u1) `compare` (NameU u2) | u1  <# u2 = LT
				  | u1 ==# u2 = EQ
				  | otherwise = GT
Ian Lynagh's avatar
Ian Lynagh committed
469
  (NameU _)  `compare` _     = LT
470

471 472 473 474 475 476
  (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
477
  (NameL _)  `compare` _          = LT
478

479 480 481
  (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
482
  (NameG _ _ _)    `compare` _ = GT
483

Ian Lynagh's avatar
Ian Lynagh committed
484 485 486 487 488 489 490 491 492 493 494 495 496 497 498
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
499
    where
500 501 502 503 504
	-- 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.
505 506
	-- Ditto NameU and NameL
        nms = case nm of
Ian Lynagh's avatar
Ian Lynagh committed
507 508 509 510 511
                    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)
512 513 514

        pnam = classify nms

Ian Lynagh's avatar
Ian Lynagh committed
515 516
        -- True if we are function style, e.g. f, [], (,)
        -- False if we are operator style, e.g. +, :+
517
        classify "" = False -- shouldn't happen; . operator is handled below
Ian Lynagh's avatar
Ian Lynagh committed
518
        classify (x:xs) | isAlpha x || (x `elem` "_[]()") =
519 520 521 522
                            case dropWhile (/='.') xs of
                                  (_:xs') -> classify xs'
                                  []      -> True
                        | otherwise = False
523

524
instance Show Name where
Ian Lynagh's avatar
Ian Lynagh committed
525
  show = showName
526

527 528 529 530 531 532 533 534 535 536 537 538
-- 	Tuple data and type constructors
tupleDataName  :: Int -> Name	-- Data constructor
tupleTypeName :: Int -> Name 	-- Type constructor

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
539
mk_tup_name :: Int -> NameSpace -> Name
540
mk_tup_name n_commas space
Ian Lynagh's avatar
Ian Lynagh committed
541
  = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod)
542 543
  where
    occ = mkOccName ('(' : replicate n_commas ',' ++ ")")
Ian Lynagh's avatar
Ian Lynagh committed
544 545
    -- XXX Should it be GHC.Unit for 0 commas?
    tup_mod = mkModName "GHC.Tuple"
546 547


548

549 550 551 552 553 554 555 556 557 558 559 560 561
-----------------------------------------------------
--		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

562

563 564 565 566 567 568 569 570 571 572 573 574 575 576 577
-----------------------------------------------------
--
--	The Info returned by reification
--
-----------------------------------------------------

data Info 
  = 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
578 579 580 581 582 583 584

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

585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601
  | 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
602
  deriving( Show, Data, Typeable )
603

604 605 606 607
data Fixity          = Fixity Int FixityDirection
    deriving( Eq, Show, Data, Typeable )
data FixityDirection = InfixL | InfixR | InfixN
    deriving( Eq, Show, Data, Typeable )
608

609
maxPrecedence :: Int
610
maxPrecedence = (9::Int)
611 612

defaultFixity :: Fixity
613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629
defaultFixity = Fixity maxPrecedence InfixL


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

data Lit = CharL Char 
         | StringL String 
         | IntegerL Integer     -- Used for overloaded and non-overloaded
                                -- 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
630
         | WordPrimL Integer
631 632
         | FloatPrimL Rational
         | DoublePrimL Rational
633
    deriving( Show, Eq, Data, Typeable )
634 635 636 637 638 639 640

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

data Pat 
  = LitP Lit                      -- { 5 or 'c' }
641
  | VarP Name                     -- { x }
642
  | TupP [Pat]                    -- { (p1,p2) }
643
  | ConP Name [Pat]               -- data T1 = C1 t1 t2; {C1 p1 p1} = e 
644
  | InfixP Pat Name Pat           -- foo ({x :+ y}) = e 
645
  | TildeP Pat                    -- { ~p }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
646
  | BangP Pat                     -- { !p }
647
  | AsP Name Pat                  -- { x @ p }
648
  | WildP                         -- { _ }
649
  | RecP Name [FieldPat]          -- f (Pt { pointx = x }) = g x
650
  | ListP [ Pat ]                 -- { [1,2,3] }
651
  | SigP Pat Type                 -- { p :: t }
652
  deriving( Show, Eq, Data, Typeable )
653 654 655 656 657

type FieldPat = (Name,Pat)

data Match = Match Pat Body [Dec]
                                    -- case e of { pat -> body where decs } 
658
    deriving( Show, Eq, Data, Typeable )
659 660
data Clause = Clause [Pat] Body [Dec]
                                    -- f { p1 p2 = body where decs }
661
    deriving( Show, Eq, Data, Typeable )
662
 
663 664 665 666 667
-- | 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'.
-- E.g. [ f x | x <- xs ] is represented by
--   CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]
668
data Exp 
669 670
  = VarE Name                          -- { x }
  | ConE Name                          -- data T1 = C1 t1 t2; p = {C1} e1 e2  
671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689
  | LitE Lit                           -- { 5 or 'c'}
  | AppE Exp Exp                       -- { f x }

  | InfixE (Maybe Exp) Exp (Maybe Exp) -- {x + y} or {(x+)} or {(+ x)} or {(+)}
    -- 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?

  | 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] }
690
  | SigE Exp Type                      -- { e :: t }
691 692
  | RecConE Name [FieldExp]            -- { T { x = y, z = w } }
  | RecUpdE Exp [FieldExp]             -- { (f x) { z = w } }
693
  deriving( Show, Eq, Data, Typeable )
694 695 696 697 698 699

type FieldExp = (Name,Exp)

-- Omitted: implicit parameters

data Body
700
  = GuardedB [(Guard,Exp)]   -- f p { | e1 = e2 | e3 = e4 } where ds
701
  | NormalB Exp              -- f p { = e } where ds
702
  deriving( Show, Eq, Data, Typeable )
703

704 705 706
data Guard
  = NormalG Exp
  | PatG [Stmt]
707
  deriving( Show, Eq, Data, Typeable )
708

709 710 711 712 713
data Stmt
  = BindS Pat Exp
  | LetS [ Dec ]
  | NoBindS Exp
  | ParS [[Stmt]]
714
  deriving( Show, Eq, Data, Typeable )
715 716 717

data Range = FromR Exp | FromThenR Exp Exp
           | FromToR Exp Exp | FromThenToR Exp Exp Exp
718
          deriving( Show, Eq, Data, Typeable )
719 720 721 722
  
data Dec 
  = FunD Name [Clause]            -- { f p1 p2 = b where decs }
  | ValD Pat Body [Dec]           -- { p = b where decs }
723
  | DataD Cxt Name [TyVarBndr] 
724 725
         [Con] [Name]             -- { data Cxt x => T x = A x | B (T x)
                                  --       deriving (Z,W)}
726
  | NewtypeD Cxt Name [TyVarBndr] 
727 728
         Con [Name]               -- { newtype Cxt x => T x = A (B x)
                                  --       deriving (Z,W)}
729 730 731
  | TySynD Name [TyVarBndr] Type  -- { type T x = (x,x) }
  | ClassD Cxt Name [TyVarBndr] 
         [FunDep] [Dec]           -- { class Eq a => Ord a where ds }
732 733 734 735
  | InstanceD Cxt Type [Dec]      -- { instance Show w => Show [w]
                                  --       where ds }
  | SigD Name Type                -- { length :: [a] -> Int }
  | ForeignD Foreign
736 737
  -- pragmas
  | PragmaD Pragma                -- { {-# INLINE [1] foo #-} }
738 739 740 741
  -- type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
  | FamilyD FamFlavour Name 
         [TyVarBndr] (Maybe Kind) -- { type family T a b c :: * }
                                 
742 743 744 745 746 747 748 749
  | DataInstD Cxt Name [Type]
         [Con] [Name]             -- { data instance Cxt x => T [x] = A x 
                                  --                                | B (T x)
                                  --       deriving (Z,W)}
  | NewtypeInstD Cxt Name [Type]
         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) }
750
  deriving( Show, Eq, Data, Typeable )
751

752
data FunDep = FunDep [Name] [Name]
753
  deriving( Show, Eq, Data, Typeable )
754

755 756 757
data FamFlavour = TypeFam | DataFam
  deriving( Show, Eq, Data, Typeable )

758 759
data Foreign = ImportF Callconv Safety String Name Type
             | ExportF Callconv        String Name Type
760
         deriving( Show, Eq, Data, Typeable )
761 762

data Callconv = CCall | StdCall
763
          deriving( Show, Eq, Data, Typeable )
764 765

data Safety = Unsafe | Safe | Threadsafe
766
        deriving( Show, Eq, Data, Typeable )
767

768 769 770 771 772 773 774 775 776 777
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 )

778 779 780 781 782
type Cxt = [Pred]                 -- (Eq a, Ord b)

data Pred = ClassP Name [Type]    -- Eq (Int, a)
          | EqualP Type Type      -- F a ~ Bool
          deriving( Show, Eq, Data, Typeable )
783 784

data Strict = IsStrict | NotStrict
785
         deriving( Show, Eq, Data, Typeable )
786

787 788 789 790
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]
791
         deriving( Show, Eq, Data, Typeable )
792 793 794 795

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

796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811
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
      deriving( Show, Eq, Data, Typeable )

data TyVarBndr = PlainTV  Name            -- a
               | KindedTV Name Kind       -- (a :: k)
      deriving( Show, Eq, Data, Typeable )

data Kind = StarK                         -- '*'
          | ArrowK Kind Kind              -- k1 -> k2
812
      deriving( Show, Eq, Data, Typeable )
813 814 815 816 817 818 819 820 821 822 823

-----------------------------------------------------
--		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
824
thenCmp o1 _  = o1
825