th-lift 0.3.1 → 0.4
raw patch · 7 files changed
+68/−48 lines, 7 filesdep ~basedep ~template-haskell
Dependency ranges changed: base, template-haskell
Files
- Changelog +7/−3
- Foo.hs +0/−11
- Language/Haskell/TH/Lift.hs +35/−21
- Test.hs +0/−10
- t/Foo.hs +13/−0
- t/Test.hs +10/−0
- th-lift.cabal +3/−3
Changelog view
@@ -1,7 +1,11 @@-2010-08-06 Ki Yung Ahn <kya@pdx.edu>+2010-08-02 Mathieu Boespflug <mboes@tweag.net> - * Backport patch to 0.3 since 0.4 doesn't work on ghc-6.12- * infix operator seems to work but not the record+ * Add support for newtypes and records syntax, thanks to a patch+ by Ben Millwood.+ * Add support for infix constructors.+ * deriveLift returns a list of declarations.+ * New deriveLiftWith function with custom reification, following a+ feature request by Jonas Duregård. 2010-03-24 Mathieu Boespflug <mboes@tweag.net>
− Foo.hs
@@ -1,11 +0,0 @@--module Foo where--import Language.Haskell.TH.Lift--data Foo a = Foo a Char | Bar a- deriving Show--$( do d <- deriveLift ''Foo- return [d] )-
Language/Haskell/TH/Lift.hs view
@@ -1,5 +1,4 @@--module Language.Haskell.TH.Lift where+module Language.Haskell.TH.Lift (deriveLift, deriveLiftWith, Lift(..)) where import GHC.Exts import Language.Haskell.TH@@ -8,28 +7,36 @@ modName :: String modName = "Language.Haskell.TH.Lift" +-- | Derive Lift instances for the given datatype. deriveLift :: Name -> Q [Dec]-deriveLift n- = do i <- reify n- case i of- TyConI (DataD _ _ vsk cons _) ->- let unTyVarBndr (PlainTV v) = v- unTyVarBndr (KindedTV v _) = v- vs = map unTyVarBndr vsk- ctxt = cxt [classP ''Lift [varT v] | v <- vs]- typ = foldl appT (conT n) $ map varT vs- fun = funD 'lift (map doCons cons)- in instanceD ctxt (conT ''Lift `appT` typ) [fun] >>= return . (:[])- _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i)+deriveLift = deriveLiftWith reify +-- | Obtain Info values through a custom reification function. This is useful+-- when generating instances for datatypes that have not yet been declared.+deriveLiftWith :: (Name -> Q Info) -> Name -> Q [Dec]+deriveLiftWith n = do+ i <- reify n+ case i of+ TyConI (DataD _ _ vsk cons _) ->+ liftInstance (map unTyVarBndr vsk) (map doCons cons)+ TyConI (NewtypeD _ _ vsk con _) ->+ liftInstance (map unTyVarBndr vsk) [doCons con]+ _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i)+ where liftInstance vs cases =+ fmap (:[]) $ instanceD (ctxt vs) (conT ''Lift `appT` typ vs) [funD 'lift cases]+ unTyVarBndr (PlainTV v) = v+ unTyVarBndr (KindedTV v _) = v+ ctxt = cxt . map (\n -> classP ''Lift [varT n])+ typ = foldl appT (conT n) . map varT+ doCons :: Con -> Q Clause-doCons (NormalC c sts)- = do let ns = zipWith (\_ i -> "x" ++ show i) sts [0..]- con = [| conE c |]- args = [ [| lift $(varE (mkName n)) |] | n <- ns ]- e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args- clause [conP c (map (varP . mkName) ns)] (normalB e) []--- doCons (RecC c sts) = doCons $ NormalC c [(s, t) | (_, s, t) <- sts]+doCons (NormalC c sts) = do+ let ns = zipWith (\_ i -> "x" ++ show i) sts [0..]+ con = [| conE c |]+ args = [ [| lift $(varE (mkName n)) |] | n <- ns ]+ e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args+ clause [conP c (map (varP . mkName) ns)] (normalB e) []+doCons (RecC c sts) = doCons $ NormalC c [(s, t) | (_, s, t) <- sts] doCons (InfixC sty1 c sty2) = do let con = [| conE c |] left = [| lift $(varE (mkName "x0")) |]@@ -65,3 +72,10 @@ lift DataName = [| DataName |] lift TcClsName = [| TcClsName |] +-- These instances should really go in the template-haskell package.++instance Lift () where+ lift _ = [| () |]++instance Lift Rational where+ lift x = return (LitE (RationalL x))
− Test.hs
@@ -1,10 +0,0 @@--module Main (main) where--import Foo-import Language.Haskell.TH.Syntax--main :: IO ()-main = do print $( lift (Foo "str1" 'c') )- print $( lift (Bar "str2") )-
+ t/Foo.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}+module Foo where++import Language.Haskell.TH.Lift++data Foo a = Foo a Char | Bar a+ deriving Show++newtype Rec a = Rec { field :: a }+ deriving Show++$(deriveLift ''Foo)+$(deriveLift ''Rec)
+ t/Test.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TemplateHaskell #-}+module Main (main) where++import Foo+import Language.Haskell.TH.Syntax++main :: IO ()+main = do print $( lift (Foo "str1" 'c') )+ print $( lift (Bar "str2") )+ print $( lift (Rec {field = 'a'}) )
th-lift.cabal view
@@ -1,5 +1,5 @@ Name: th-lift-Version: 0.3.1+Version: 0.4 Cabal-Version: >= 1.3 License: OtherLicense License-File: COPYING@@ -12,9 +12,9 @@ Category: Language Tested-With: GHC==6.12 Build-Depends: base >= 4 && < 5, template-haskell >= 2.4-Extensions: TemplateHaskell, MagicHash+Extensions: TemplateHaskell, MagicHash, TypeSynonymInstances build-type: Simple-Extra-source-files: BSD3, GPL-2, Changelog, Foo.hs, Test.hs+Extra-source-files: BSD3, GPL-2, Changelog, t/Foo.hs, t/Test.hs Exposed-modules: Language.Haskell.TH.Lift