diff options
Diffstat (limited to 'libraries/template-haskell/Language/Haskell/TH/Syntax.hs')
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Syntax.hs | 100 |
1 files changed, 98 insertions, 2 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index a6f970d125..8ab183c745 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, DeriveDataTypeable, PolymorphicComponents, - DeriveGeneric, FlexibleInstances #-} + DeriveGeneric, FlexibleInstances, DefaultSignatures, + ScopedTypeVariables, Rank2Types #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE RoleAnnotations #-} @@ -28,7 +29,7 @@ module Language.Haskell.TH.Syntax where -import Data.Data (Data(..), Typeable ) +import Data.Data hiding (Fixity(..)) #if __GLASGOW_HASKELL__ < 709 import Control.Applicative( Applicative(..) ) #endif @@ -468,6 +469,8 @@ sequenceQ = sequence class Lift t where lift :: t -> Q Exp + default lift :: Data t => t -> Q Exp + lift = liftData -- If you add any instances here, consider updating test th/TH_Lift instance Lift Integer where @@ -590,6 +593,99 @@ leftName, rightName :: Name leftName = mkNameG DataName "base" "Data.Either" "Left" rightName = mkNameG DataName "base" "Data.Either" "Right" +----------------------------------------------------- +-- +-- Generic Lift implementations +-- +----------------------------------------------------- + +-- | 'dataToQa' is an internal utility function for constructing generic +-- conversion functions from types with 'Data' instances to various +-- quasi-quoting representations. See the source of 'dataToExpQ' and +-- 'dataToPatQ' for two example usages: @mkCon@, @mkLit@ +-- and @appQ@ are overloadable to account for different syntax for +-- expressions and patterns; @antiQ@ allows you to override type-specific +-- cases, a common usage is just @const Nothing@, which results in +-- no overloading. +dataToQa :: forall a k q. Data a + => (Name -> k) + -> (Lit -> Q q) + -> (k -> [Q q] -> Q q) + -> (forall b . Data b => b -> Maybe (Q q)) + -> a + -> Q q +dataToQa mkCon mkLit appCon antiQ t = + case antiQ t of + Nothing -> + case constrRep constr of + AlgConstr _ -> + appCon (mkCon conName) conArgs + where + conName :: Name + conName = + case showConstr constr of + "(:)" -> Name (mkOccName ":") + (NameG DataName + (mkPkgName "ghc-prim") + (mkModName "GHC.Types")) + con@"[]" -> Name (mkOccName con) + (NameG DataName + (mkPkgName "ghc-prim") + (mkModName "GHC.Types")) + con@('(':_) -> Name (mkOccName con) + (NameG DataName + (mkPkgName "ghc-prim") + (mkModName "GHC.Tuple")) + con -> mkNameG_d (tyConPackage tycon) + (tyConModule tycon) + con + where + tycon :: TyCon + tycon = (typeRepTyCon . typeOf) t + + conArgs :: [Q q] + conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t + IntConstr n -> + mkLit $ IntegerL n + FloatConstr n -> + mkLit $ RationalL n + CharConstr c -> + mkLit $ CharL c + where + constr :: Constr + constr = toConstr t + + Just y -> y + +-- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the +-- same value, in the SYB style. It is generalized to take a function +-- override type-specific cases; see 'liftData' for a more commonly +-- used variant. +dataToExpQ :: Data a + => (forall b . Data b => b -> Maybe (Q Exp)) + -> a + -> Q Exp +dataToExpQ = dataToQa conE litE (foldl appE) + where conE s = return (ConE s) + appE x y = do { a <- x; b <- y; return (AppE a b)} + litE c = return (LitE c) + +-- | 'liftData' is a variant of 'lift' in the 'Lift' type class which +-- works for any type with a 'Data' instance. +liftData :: Data a => a -> Q Exp +liftData = dataToExpQ (const Nothing) + +-- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same +-- value, in the SYB style. It takes a function to handle type-specific cases, +-- alternatively, pass @const Nothing@ to get default behavior. +dataToPatQ :: Data a + => (forall b . Data b => b -> Maybe (Q Pat)) + -> a + -> Q Pat +dataToPatQ = dataToQa id litP conP + where litP l = return (LitP l) + conP n ps = do ps' <- sequence ps + return (ConP n ps') ----------------------------------------------------- -- Names and uniques |