diff options
Diffstat (limited to 'libraries/template-haskell/Language/Haskell/TH/Syntax.hs')
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Syntax.hs | 200 |
1 files changed, 66 insertions, 134 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index b5163cb44b..48199a4d8e 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, PolymorphicComponents, RoleAnnotations, UnboxedTuples #-} +{-# LANGUAGE CPP, DeriveDataTypeable, PolymorphicComponents, + RoleAnnotations, DeriveGeneric #-} ----------------------------------------------------------------------------- -- | @@ -16,9 +17,7 @@ module Language.Haskell.TH.Syntax where -import GHC.Exts -import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex) -import qualified Data.Data as Data +import Data.Data (Data(..), Typeable ) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative( Applicative(..) ) #endif @@ -28,6 +27,7 @@ import Control.Monad (liftM) import System.IO ( hPutStrLn, stderr ) import Data.Char ( isAlpha, isAlphaNum, isUpper ) import Data.Word ( Word8 ) +import GHC.Generics ( Generic ) ----------------------------------------------------- -- @@ -377,9 +377,16 @@ runIO :: IO a -> Q a runIO m = Q (qRunIO m) -- | Record external files that runIO is using (dependent upon). --- The compiler can then recognize that it should re-compile the file using this TH when the external file changes. --- Note that ghc -M will still not know about these dependencies - it does not execute TH. +-- The compiler can then recognize that it should re-compile the Haskell file +-- when an external file changes. +-- -- Expects an absolute file path. +-- +-- Notes: +-- +-- * ghc -M does not know about these dependencies - it does not execute TH. +-- +-- * The dependency is based on file content, not a modification time addDependentFile :: FilePath -> Q () addDependentFile fp = Q (qAddDependentFile fp) @@ -525,17 +532,17 @@ rightName = mkNameG DataName "base" "Data.Either" "Right" ----------------------------------------------------- newtype ModName = ModName String -- Module name - deriving (Show,Eq,Ord,Typeable,Data) + deriving (Show,Eq,Ord,Typeable,Data,Generic) newtype PkgName = PkgName String -- package name - deriving (Show,Eq,Ord,Typeable,Data) + deriving (Show,Eq,Ord,Typeable,Data,Generic) -- | Obtained from 'reifyModule' and 'thisModule'. data Module = Module PkgName ModName -- package qualified module name - deriving (Show,Eq,Ord,Typeable,Data) + deriving (Show,Eq,Ord,Typeable,Data,Generic) newtype OccName = OccName String - deriving (Show,Eq,Ord,Typeable,Data) + deriving (Show,Eq,Ord,Typeable,Data,Generic) mkModName :: String -> ModName mkModName s = ModName s @@ -646,67 +653,29 @@ Names constructed using @newName@ and @mkName@ may be used in bindings (such as @let x = ...@ or @\x -> ...@), but names constructed using @lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not. -} -data Name = Name OccName NameFlavour deriving (Typeable, Data) +data Name = Name OccName NameFlavour deriving (Typeable, Data, Eq, Generic) + +instance Ord Name where + -- check if unique is different before looking at strings + (Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp` + (o1 `compare` o2) data NameFlavour = NameS -- ^ An unqualified name; dynamically bound | NameQ ModName -- ^ A qualified name; dynamically bound - | NameU Int# -- ^ A unique local name - | NameL Int# -- ^ Local name bound outside of the TH AST + | NameU !Int -- ^ A unique local name + | 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) -- Need the namespace too to be sure which -- thing we are naming - deriving ( Typeable ) - --- | --- 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 separately from GHC itself. --- --- This instance cannot be derived automatically due to bug #2701 -instance Data NameFlavour where - 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" - toConstr NameS = con_NameS - toConstr (NameQ _) = con_NameQ - toConstr (NameU _) = con_NameU - toConstr (NameL _) = con_NameL - toConstr (NameG _ _ _) = con_NameG - dataTypeOf _ = ty_NameFlavour - -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 - -ty_NameFlavour :: Data.DataType -ty_NameFlavour = mkDataType "Language.Haskell.TH.Syntax.NameFlavour" - [con_NameS, con_NameQ, con_NameU, - con_NameL, con_NameG] + deriving ( Typeable, Data, Eq, Ord, Generic ) data NameSpace = VarName -- ^ Variables | DataName -- ^ Data constructors | TcClsName -- ^ Type constructors and classes; Haskell has them -- in the same name space for now. - deriving( Eq, Ord, Data, Typeable ) + deriving( Eq, Ord, Data, Typeable, Generic ) type Uniq = Int @@ -789,11 +758,11 @@ mkName str -- | Only used internally mkNameU :: String -> Uniq -> Name -mkNameU s (I# u) = Name (mkOccName s) (NameU u) +mkNameU s u = Name (mkOccName s) (NameU u) -- | Only used internally mkNameL :: String -> Uniq -> Name -mkNameL s (I# u) = Name (mkOccName s) (NameL u) +mkNameL s u = Name (mkOccName s) (NameL u) -- | Used for 'x etc, but not available to the programmer mkNameG :: NameSpace -> String -> String -> String -> Name @@ -805,45 +774,6 @@ 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 - -- NameS < NameQ < NameU < NameL < NameG - NameS `compare` NameS = EQ - NameS `compare` _ = LT - - (NameQ _) `compare` NameS = GT - (NameQ m1) `compare` (NameQ m2) = m1 `compare` m2 - (NameQ _) `compare` _ = LT - - (NameU _) `compare` NameS = GT - (NameU _) `compare` (NameQ _) = GT - (NameU u1) `compare` (NameU u2) | isTrue# (u1 <# u2) = LT - | isTrue# (u1 ==# u2) = EQ - | otherwise = GT - (NameU _) `compare` _ = LT - - (NameL _) `compare` NameS = GT - (NameL _) `compare` (NameQ _) = GT - (NameL _) `compare` (NameU _) = GT - (NameL u1) `compare` (NameL u2) | isTrue# (u1 <# u2) = LT - | isTrue# (u1 ==# u2) = EQ - | otherwise = GT - (NameL _) `compare` _ = LT - - (NameG ns1 p1 m1) `compare` (NameG ns2 p2 m2) = (ns1 `compare` ns2) `thenCmp` - (p1 `compare` p2) `thenCmp` - (m1 `compare` m2) - (NameG _ _ _) `compare` _ = GT - data NameIs = Alone | Applied | Infix showName :: Name -> String @@ -870,8 +800,8 @@ showName' ni nm 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) + Name occ (NameU u) -> occString occ ++ "_" ++ show u + Name occ (NameL u) -> occString occ ++ "_" ++ show u pnam = classify nms @@ -1015,13 +945,13 @@ data Info | TyVarI -- Scoped type variable Name Type -- What it is bound to - deriving( Show, Data, Typeable ) + deriving( Show, Data, Typeable, Generic ) -- | Obtained from 'reifyModule' in the 'Q' Monad. data ModuleInfo = -- | Contains the import list of the module. ModuleInfo [Module] - deriving( Show, Data, Typeable ) + deriving( Show, Data, Typeable, Generic ) {- | In 'ClassOpI' and 'DataConI', name of the parent class or type @@ -1045,9 +975,9 @@ type Unlifted = Bool type InstanceDec = Dec data Fixity = Fixity Int FixityDirection - deriving( Eq, Show, Data, Typeable ) + deriving( Eq, Show, Data, Typeable, Generic ) data FixityDirection = InfixL | InfixR | InfixN - deriving( Eq, Show, Data, Typeable ) + deriving( Eq, Show, Data, Typeable, Generic ) -- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9) maxPrecedence :: Int @@ -1139,7 +1069,7 @@ data Lit = CharL Char | FloatPrimL Rational | DoublePrimL Rational | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr# - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) -- We could add Int, Float, Double etc, as we do in HsLit, -- but that could complicate the @@ -1167,15 +1097,15 @@ data Pat | ListP [ Pat ] -- ^ @{ [1,2,3] }@ | SigP Pat Type -- ^ @{ p :: t }@ | ViewP Exp Pat -- ^ @{ e -> p }@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) type FieldPat = (Name,Pat) data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Clause = Clause [Pat] Body [Dec] -- ^ @f { p1 p2 = body where decs }@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Exp = VarE Name -- ^ @{ x }@ @@ -1222,7 +1152,7 @@ data Exp | SigE Exp Type -- ^ @{ e :: t }@ | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@ | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) type FieldExp = (Name,Exp) @@ -1233,23 +1163,23 @@ data Body -- | e3 = e4 } -- where ds@ | NormalB Exp -- ^ @f p { = e } where ds@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Guard = NormalG Exp -- ^ @f x { | odd x } = x@ | PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Stmt = BindS Pat Exp | LetS [ Dec ] | NoBindS Exp | ParS [[Stmt]] - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Range = FromR Exp | FromThenR Exp Exp | FromToR Exp Exp | FromThenToR Exp Exp Exp - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Dec = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@ @@ -1292,29 +1222,31 @@ data Dec [TySynEqn] -- ^ @{ type family F a b :: * where ... }@ | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@ - deriving( Show, Eq, Data, Typeable ) + | StandaloneDerivD Cxt Type -- ^ @{ deriving instance Ord a => Ord (Foo a) }@ + | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@ + deriving( Show, Eq, Data, Typeable, Generic ) -- | One equation of a type family instance or closed type family. The -- arguments are the left-hand-side type patterns and the right-hand-side -- result. data TySynEqn = TySynEqn [Type] Type - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data FunDep = FunDep [Name] [Name] - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data FamFlavour = TypeFam | DataFam - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Foreign = ImportF Callconv Safety String Name Type | ExportF Callconv String Name Type - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Callconv = CCall | StdCall - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Safety = Unsafe | Safe | Interruptible - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Pragma = InlineP Name Inline RuleMatch Phases | SpecialiseP Name Type (Maybe Inline) Phases @@ -1322,30 +1254,30 @@ data Pragma = InlineP Name Inline RuleMatch Phases | RuleP String [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP Int String - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data Inline = NoInline | Inline | Inlinable - deriving (Show, Eq, Data, Typeable) + deriving (Show, Eq, Data, Typeable, Generic) data RuleMatch = ConLike | FunLike - deriving (Show, Eq, Data, Typeable) + deriving (Show, Eq, Data, Typeable, Generic) data Phases = AllPhases | FromPhase Int | BeforePhase Int - deriving (Show, Eq, Data, Typeable) + deriving (Show, Eq, Data, Typeable, Generic) data RuleBndr = RuleVar Name | TypedRuleVar Name Type - deriving (Show, Eq, Data, Typeable) + deriving (Show, Eq, Data, Typeable, Generic) data AnnTarget = ModuleAnnotation | TypeAnnotation Name | ValueAnnotation Name - deriving (Show, Eq, Data, Typeable) + deriving (Show, Eq, Data, Typeable, Generic) type Cxt = [Pred] -- ^ @(Eq a, Ord b)@ @@ -1355,13 +1287,13 @@ type Cxt = [Pred] -- ^ @(Eq a, Ord b)@ type Pred = Type data Strict = IsStrict | NotStrict | Unpacked - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) 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]@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) type StrictType = (Strict, Type) type VarStrictType = (Name, Strict, Type) @@ -1385,27 +1317,27 @@ data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> -> \<t | StarT -- ^ @*@ | ConstraintT -- ^ @Constraint@ | LitT TyLit -- ^ @0,1,2, etc.@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data TyVarBndr = PlainTV Name -- ^ @a@ | KindedTV Name Kind -- ^ @(a :: k)@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) data TyLit = NumTyLit Integer -- ^ @2@ | StrTyLit String -- ^ @"Hello"@ - deriving ( Show, Eq, Data, Typeable ) + deriving ( Show, Eq, Data, Typeable, Generic ) -- | Role annotations data Role = NominalR -- ^ @nominal@ | RepresentationalR -- ^ @representational@ | PhantomR -- ^ @phantom@ | InferR -- ^ @_@ - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) -- | Annotation target for reifyAnnotations data AnnLookup = AnnLookupModule Module | AnnLookupName Name - deriving( Show, Eq, Data, Typeable ) + deriving( Show, Eq, Data, Typeable, Generic ) -- | To avoid duplication between kinds and types, they -- are defined to be the same. Naturally, you would never |