Syntax.hs 24 KB
Newer Older
Ian Lynagh's avatar
Ian Lynagh committed
1
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
Ian Lynagh's avatar
Ian Lynagh committed
2 3 4 5 6
-- The above warning supression flag is a temporary kludge.
-- 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 23 24 25
-----------------------------------------------------------------------------
-- |
-- 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(
	Quasi(..), Lift(..), 

	Q, runQ, 
	report,	recover, reify,
26
	location, runIO,
27 28

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

	-- The algebraic data types
	Dec(..), Exp(..), Con(..), Type(..), Cxt, Match(..), 
34
	Clause(..), Body(..), Guard(..), Stmt(..), Range(..),
35 36
	Lit(..), Pat(..), FieldExp, FieldPat, 
	Strict(..), Foreign(..), Callconv(..), Safety(..),
37
	StrictType, VarStrictType, FunDep(..),
38
	Info(..), Loc(..), CharPos,
39 40 41 42 43
	Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,

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

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

54 55
import Data.Generics (Data(..), Typeable, mkConstr, mkDataType)
import qualified Data.Generics as Generics
56 57
import Data.IORef
import GHC.IOBase	( unsafePerformIO )
58
import Control.Monad (liftM)
59
import System.IO	( hPutStrLn, stderr )
60
import Data.Char        ( isAlpha )
61 62 63 64 65 66 67

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

68
class (Monad m, Functor m) => Quasi m where
69 70 71 72 73 74 75 76 77 78 79
	-- 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
80
  qLocation :: m Loc
81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104

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

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

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

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

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

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

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

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


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

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)

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

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

227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253
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]

254 255 256 257 258 259 260 261 262 263
-- 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
264 265
trueName  = mkNameG DataName "base" "GHC.Base" "True"
falseName = mkNameG DataName "base" "GHC.Base" "False"
266

267 268 269 270 271 272 273 274
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"

275 276 277 278 279 280

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

type ModName = PackedString	-- Module name
281

282 283 284 285 286 287
mkModName :: String -> ModName
mkModName s = packString s

modString :: ModName -> String
modString m = unpackPS m

288

289 290 291 292 293 294 295 296 297
type PkgName = PackedString	-- package name

mkPkgName :: String -> PkgName
mkPkgName s = packString s

pkgString :: PkgName -> String
pkgString m = unpackPS m


298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326
-----------------------------------------------------
--		OccName
-----------------------------------------------------

type OccName = PackedString

mkOccName :: String -> OccName
mkOccName s = packString s

occString :: OccName -> String
occString occ = unpackPS occ


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

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

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

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

335 336 337 338 339 340 341 342
	-- 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#			-- 
343
  | NameG NameSpace PkgName ModName	-- An original name (occurrences only, not binders)
344 345
				-- Need the namespace too to be sure which 
				-- thing we are naming
346 347 348 349 350 351 352 353 354 355 356
  deriving ( Typeable )

instance Data NameFlavour where
     gunfold = error "gunfold"
     toConstr NameS = con_NameS
     toConstr (NameQ _) = con_NameQ
     toConstr (NameU _) = con_NameU
     toConstr (NameL _) = con_NameL
     toConstr (NameG _ _ _) = con_NameG
     dataTypeOf _ = ty_NameFlavour

Ian Lynagh's avatar
Ian Lynagh committed
357
con_NameS, con_NameQ, con_NameU, con_NameL, con_NameG :: Generics.Constr
358 359 360 361 362
con_NameS = mkConstr ty_NameFlavour "NameS" [] Generics.Prefix
con_NameQ = mkConstr ty_NameFlavour "NameQ" [] Generics.Prefix
con_NameU = mkConstr ty_NameFlavour "NameU" [] Generics.Prefix
con_NameL = mkConstr ty_NameFlavour "NameL" [] Generics.Prefix
con_NameG = mkConstr ty_NameFlavour "NameG" [] Generics.Prefix
Ian Lynagh's avatar
Ian Lynagh committed
363 364

ty_NameFlavour :: Generics.DataType
365 366 367
ty_NameFlavour = mkDataType "Language.Haskell.TH.Syntax.NameFlavour"
                            [con_NameS, con_NameQ, con_NameU,
                             con_NameL, con_NameG]
368 369 370 371 372

data NameSpace = VarName	-- Variables
	       | DataName	-- Data constructors 
	       | TcClsName	-- Type constructors and classes; Haskell has them
				-- in the same name space for now.
373
	       deriving( Eq, Ord, Data, Typeable )
374 375 376 377 378 379

type Uniq = Int

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

380
nameModule :: Name -> Maybe String
Ian Lynagh's avatar
Ian Lynagh committed
381
nameModule (Name _ (NameQ m))     = Just (modString m)
382
nameModule (Name _ (NameG _ _ m)) = Just (modString m)
Ian Lynagh's avatar
Ian Lynagh committed
383
nameModule _                      = Nothing
384

385
mkName :: String -> Name
386 387 388 389 390 391 392 393 394 395 396 397 398
-- 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
399 400 401 402 403 404 405 406 407
    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
408
    split occ (c:rev)   = split (c:occ) rev
409 410 411 412

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

413 414 415
mkNameL :: String -> Uniq -> Name	-- Only used internally
mkNameL s (I# u) = Name (mkOccName s) (NameL u)

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

420
mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name
421 422 423 424 425 426 427 428 429 430 431 432 433 434 435
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
436
	-- NameS < NameQ < NameU < NameL < NameG
437
  NameS `compare` NameS = EQ
Ian Lynagh's avatar
Ian Lynagh committed
438
  NameS `compare` _     = LT
439

440 441
  (NameQ _)  `compare` NameS      = GT
  (NameQ m1) `compare` (NameQ m2) = m1 `compare` m2
Ian Lynagh's avatar
Ian Lynagh committed
442
  (NameQ _)  `compare` _          = LT
443 444 445

  (NameU _)  `compare` NameS      = GT
  (NameU _)  `compare` (NameQ _)  = GT
446 447 448
  (NameU u1) `compare` (NameU u2) | u1  <# u2 = LT
				  | u1 ==# u2 = EQ
				  | otherwise = GT
Ian Lynagh's avatar
Ian Lynagh committed
449
  (NameU _)  `compare` _     = LT
450

451 452 453 454 455 456
  (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
457
  (NameL _)  `compare` _          = LT
458

459 460 461
  (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
462
  (NameG _ _ _)    `compare` _ = GT
463

Ian Lynagh's avatar
Ian Lynagh committed
464 465 466 467 468 469 470 471 472 473 474 475 476 477 478
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
479
    where
480 481 482 483 484
	-- 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.
485 486
	-- Ditto NameU and NameL
        nms = case nm of
Ian Lynagh's avatar
Ian Lynagh committed
487 488 489 490 491
                    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)
492 493 494

        pnam = classify nms

Ian Lynagh's avatar
Ian Lynagh committed
495 496
        -- True if we are function style, e.g. f, [], (,)
        -- False if we are operator style, e.g. +, :+
497
        classify "" = False -- shouldn't happen; . operator is handled below
Ian Lynagh's avatar
Ian Lynagh committed
498
        classify (x:xs) | isAlpha x || (x `elem` "_[]()") =
499 500 501 502
                            case dropWhile (/='.') xs of
                                  (_:xs') -> classify xs'
                                  []      -> True
                        | otherwise = False
503

504
instance Show Name where
Ian Lynagh's avatar
Ian Lynagh committed
505
  show = showName
506

507 508 509 510 511 512 513 514 515 516 517 518
-- 	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
519
mk_tup_name :: Int -> NameSpace -> Name
520
mk_tup_name n_commas space
521
  = Name occ (NameG space (mkPkgName "base") tup_mod)
522 523
  where
    occ = mkOccName ('(' : replicate n_commas ',' ++ ")")
524
    tup_mod = mkModName "Data.Tuple"
525 526


527

528 529 530 531 532 533 534 535 536 537 538 539 540
-----------------------------------------------------
--		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

541

542 543 544 545 546 547 548 549 550 551 552 553 554 555 556
-----------------------------------------------------
--
--	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
557 558 559 560 561 562 563

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

564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580
  | 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
581
  deriving( Show, Data, Typeable )
582

583 584 585 586
data Fixity          = Fixity Int FixityDirection
    deriving( Eq, Show, Data, Typeable )
data FixityDirection = InfixL | InfixR | InfixN
    deriving( Eq, Show, Data, Typeable )
587

588
maxPrecedence :: Int
589
maxPrecedence = (9::Int)
590 591

defaultFixity :: Fixity
592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608
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
609
         | WordPrimL Integer
610 611
         | FloatPrimL Rational
         | DoublePrimL Rational
612
    deriving( Show, Eq, Data, Typeable )
613 614 615 616 617 618 619 620 621 622

    -- 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' }
  | VarP Name                   -- { x }
  | TupP [Pat]                    -- { (p1,p2) }
  | ConP Name [Pat]             -- data T1 = C1 t1 t2; {C1 p1 p1} = e 
623
  | InfixP Pat Name Pat           -- foo ({x :+ y}) = e 
624 625 626 627 628
  | TildeP Pat                    -- { ~p }
  | AsP Name Pat                -- { x @ p }
  | WildP                         -- { _ }
  | RecP Name [FieldPat]        -- f (Pt { pointx = x }) = g x
  | ListP [ Pat ]                 -- { [1,2,3] }
629
  | SigP Pat Type                 -- p :: t
630
  deriving( Show, Eq, Data, Typeable )
631 632 633 634 635

type FieldPat = (Name,Pat)

data Match = Match Pat Body [Dec]
                                    -- case e of { pat -> body where decs } 
636
    deriving( Show, Eq, Data, Typeable )
637 638
data Clause = Clause [Pat] Body [Dec]
                                    -- f { p1 p2 = body where decs }
639
    deriving( Show, Eq, Data, Typeable )
640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665
 
data Exp 
  = VarE Name                        -- { x }
  | ConE Name                        -- data T1 = C1 t1 t2; p = {C1} e1 e2  
  | 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] }
  | SigE Exp Type                      -- e :: t
  | RecConE Name [FieldExp]            -- { T { x = y, z = w } }
  | RecUpdE Exp [FieldExp]             -- { (f x) { z = w } }
666
  deriving( Show, Eq, Data, Typeable )
667 668 669 670 671 672

type FieldExp = (Name,Exp)

-- Omitted: implicit parameters

data Body
673
  = GuardedB [(Guard,Exp)]   -- f p { | e1 = e2 | e3 = e4 } where ds
674
  | NormalB Exp              -- f p { = e } where ds
675
  deriving( Show, Eq, Data, Typeable )
676

677 678 679
data Guard
  = NormalG Exp
  | PatG [Stmt]
680
  deriving( Show, Eq, Data, Typeable )
681

682 683 684 685 686
data Stmt
  = BindS Pat Exp
  | LetS [ Dec ]
  | NoBindS Exp
  | ParS [[Stmt]]
687
  deriving( Show, Eq, Data, Typeable )
688 689 690

data Range = FromR Exp | FromThenR Exp Exp
           | FromToR Exp Exp | FromThenToR Exp Exp Exp
691
          deriving( Show, Eq, Data, Typeable )
692 693 694 695 696 697 698 699 700 701 702
  
data Dec 
  = FunD Name [Clause]            -- { f p1 p2 = b where decs }
  | ValD Pat Body [Dec]           -- { p = b where decs }
  | DataD Cxt Name [Name] 
         [Con] [Name]             -- { data Cxt x => T x = A x | B (T x)
                                  --       deriving (Z,W)}
  | NewtypeD Cxt Name [Name] 
         Con [Name]               -- { newtype Cxt x => T x = A (B x)
                                  --       deriving (Z,W)}
  | TySynD Name [Name] Type       -- { type T x = (x,x) }
703 704
  | ClassD Cxt Name [Name] [FunDep] [Dec]
                                  -- { class Eq a => Ord a where ds }
705 706 707 708
  | InstanceD Cxt Type [Dec]      -- { instance Show w => Show [w]
                                  --       where ds }
  | SigD Name Type                -- { length :: [a] -> Int }
  | ForeignD Foreign
709
  deriving( Show, Eq, Data, Typeable )
710

711
data FunDep = FunDep [Name] [Name]
712
  deriving( Show, Eq, Data, Typeable )
713

714 715
data Foreign = ImportF Callconv Safety String Name Type
             | ExportF Callconv        String Name Type
716
         deriving( Show, Eq, Data, Typeable )
717 718

data Callconv = CCall | StdCall
719
          deriving( Show, Eq, Data, Typeable )
720 721

data Safety = Unsafe | Safe | Threadsafe
722
        deriving( Show, Eq, Data, Typeable )
723 724 725 726

type Cxt = [Type]    -- (Eq a, Ord b)

data Strict = IsStrict | NotStrict
727
         deriving( Show, Eq, Data, Typeable )
728 729 730 731

data Con = NormalC Name [StrictType]
         | RecC Name [VarStrictType]
         | InfixC StrictType Name StrictType
732
         | ForallC [Name] Cxt Con
733
         deriving( Show, Eq, Data, Typeable )
734 735 736 737 738 739 740 741 742 743 744 745 746

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

-- FIXME: Why this special status for "List" (even tuples might be handled
--      differently)? -=chak
data Type = ForallT [Name] Cxt Type   -- forall <vars>. <ctxt> -> <type>
          | VarT Name                 -- a
          | ConT Name                 -- T
          | TupleT Int                -- (,), (,,), etc.
          | ArrowT                    -- ->
          | ListT                     -- []
          | AppT Type Type            -- T a b
747
      deriving( Show, Eq, Data, Typeable )
748 749 750 751 752 753 754 755 756 757 758

-----------------------------------------------------
--		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
759
thenCmp o1 _  = o1
760