th-lift 0.7.2 → 0.7.5

raw patch · 4 files changed

+150/−34 lines, 4 filesdep +ghc-primdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ghc-prim

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• src/Language/Haskell/TH/Lift.hs +105/−29
• t/Foo.hs +30/−0
• t/Test.hs +8/−0
• th-lift.cabal +7/−5

@@ -11,6 +11,8 @@   , deriveLiftMany   , deriveLift'   , deriveLiftMany'+  , makeLift+  , makeLift'   , Lift(..)   ) where @@ -18,16 +20,23 @@ import Data.PackedString (PackedString, packString, unpackPS) #endif /* MIN_VERSION_template_haskell(2,4,0) */ -#if __GLASGOW_HASKELL__ < 710-import GHC.Exts (Int(..))-#endif+import GHC.Base (unpackCString#)+import GHC.Exts (Double(..), Float(..), Int(..), Word(..))+import GHC.Prim (Addr#, Double#, Float#, Int#, Word#)+#if MIN_VERSION_template_haskell(2,11,0)+import GHC.Exts (Char(..))+import GHC.Prim (Char#)+#endif /* !(MIN_VERSION_template_haskell(2,11,0)) */ +#if MIN_VERSION_template_haskell(2,8,0)+import Data.Char (ord)+#endif /* !(MIN_VERSION_template_haskell(2,8,0)) */ #if !(MIN_VERSION_template_haskell(2,10,0)) import Data.Ratio (Ratio) #endif /* !(MIN_VERSION_template_haskell(2,10,0)) */ import Language.Haskell.TH import Language.Haskell.TH.Syntax-import Control.Monad ((<=<))+import Control.Monad ((<=<), zipWithM) #if MIN_VERSION_template_haskell(2,9,0) import Data.Maybe (catMaybes) #endif /* MIN_VERSION_template_haskell(2,9,0) */@@ -51,14 +60,24 @@ deriveLiftMany' :: [Info] -> Q [Dec] deriveLiftMany' = mapM deriveLiftOne +-- | Generates a lambda expresson which behaves like 'lift' (without requiring+-- a 'Lift' instance). Example:+--+-- @+-- newtype Fix f = In { out :: f (Fix f) }+--+-- instance Lift (f (Fix f)) => Lift (Fix f) where+--   lift = $(makeLift ''Fix)+-- @+makeLift :: Name -> Q Exp+makeLift = makeLift' <=< reify++-- | Like 'makeLift', but using a custom reification function.+makeLift' :: Info -> Q Exp+makeLift' i = withInfo i $ \_ n _ cons -> makeLiftOne n cons+ deriveLiftOne :: Info -> Q Dec-deriveLiftOne i =-    case i of-      TyConI (DataD dcx n vsk cons _) ->-        liftInstance dcx n (map unTyVarBndr vsk) cons-      TyConI (NewtypeD dcx n vsk con _) ->-        liftInstance dcx n (map unTyVarBndr vsk) [con]-      _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i)+deriveLiftOne i = withInfo i liftInstance   where     liftInstance dcx n vs cons = do #if MIN_VERSION_template_haskell(2,9,0)@@ -73,7 +92,7 @@ #endif       instanceD (ctxt dcx phvars vs)                 (conT ''Lift `appT` typ n (map fst vs))-                [funD 'lift (map doCons cons)]+                [funD 'lift [clause [] (normalB (makeLiftOne n cons)) []]]     typ n = foldl appT (conT n) . map varT     -- Only consider *-kinded type variables, because Lift instances cannot     -- meaningfully be given to types of other kinds. Further, filter out type@@ -81,40 +100,97 @@     ctxt dcx phvars =         fmap (dcx ++) . cxt . concatMap liftPred . filter (`notElem` phvars) #if MIN_VERSION_template_haskell(2,10,0)-    unTyVarBndr (PlainTV v) = (v, StarT)-    unTyVarBndr (KindedTV v k) = (v, k)     liftPred (v, StarT) = [conT ''Lift `appT` varT v]     liftPred (_, _) = [] #elif MIN_VERSION_template_haskell(2,8,0)-    unTyVarBndr (PlainTV v) = (v, StarT)-    unTyVarBndr (KindedTV v k) = (v, k)     liftPred (v, StarT) = [classP ''Lift [varT v]]     liftPred (_, _) = [] #elif MIN_VERSION_template_haskell(2,4,0)-    unTyVarBndr (PlainTV v) = (v, StarK)-    unTyVarBndr (KindedTV v k) = (v, k)     liftPred (v, StarK) = [classP ''Lift [varT v]]     liftPred (_, _) = []-#else /* template-haskell < 2.4.0 */-    unTyVarBndr v = v+#else /* !(MIN_VERSION_template_haskell(2,4,0)) */     liftPred n = conT ''Lift `appT` varT n #endif -doCons :: Con -> Q Clause+makeLiftOne :: Name -> [Con] -> Q Exp+makeLiftOne n cons = do+  e <- newName "e"+  lam1E (varP e) $ caseE (varE e) $ consMatches n cons++consMatches :: Name -> [Con] -> [Q Match]+consMatches n [] = [match wildP (normalB e) []]+  where+    e = [| errorQExp $(stringE ("Can't lift value of empty datatype " ++ nameBase n)) |]+consMatches _ cons = map doCons cons++doCons :: Con -> Q Match doCons (NormalC c sts) = do-    let ns = zipWith (\_ i -> "x" ++ show (i :: Int)) sts [0..]-        con = [| conE c |]-        args = [ [| lift $(varE (mkName n)) |] | n <- ns ]+    ns <- zipWithM (\_ i -> newName ('x':show (i :: Int))) sts [0..]+    let con = [| conE c |]+        args = [ liftVar n t | (n, (_, t)) <- zip ns sts ]         e = foldl (\e1 e2 -> [| appE $e1 $e2 |]) con args-    clause [conP c (map (varP . mkName) ns)] (normalB e) []+    match (conP c (map varP ns)) (normalB e) [] doCons (RecC c sts) = doCons $ NormalC c [(s, t) | (_, s, t) <- sts]-doCons (InfixC _sty1 c _sty2) = do+doCons (InfixC sty1 c sty2) = do+    x0 <- newName "x0"+    x1 <- newName "x1"     let con = [| conE c |]-        left = [| lift $(varE (mkName "x0")) |]-        right = [| lift $(varE (mkName "x1")) |]+        left = liftVar x0 (snd sty1)+        right = liftVar x1 (snd sty2)         e = [| infixApp $left $con $right |]-    clause [infixP (varP (mkName "x0")) c (varP (mkName "x1"))] (normalB e) []+    match (infixP (varP x0) c (varP x1)) (normalB e) [] doCons (ForallC _ _ c) = doCons c++liftVar :: Name -> Type -> Q Exp+liftVar varName (ConT tyName)+#if MIN_VERSION_template_haskell(2,8,0)+  | tyName == ''Addr#   = [| litE (stringPrimL (map (fromIntegral . ord)+                                                    (unpackCString# $var))) |]+#else /* !(MIN_VERSION_template_haskell(2,8,0)) */+  | tyName == ''Addr#   = [| litE (stringPrimL (unpackCString# $var))       |]+#endif+#if MIN_VERSION_template_haskell(2,11,0)+  | tyName == ''Char#   = [| litE (charPrimL               (C# $var))  |]+#endif  /* !(MIN_VERSION_template_haskell(2,11,0)) */+  | tyName == ''Double# = [| litE (doublePrimL (toRational (D# $var))) |]+  | tyName == ''Float#  = [| litE (floatPrimL  (toRational (F# $var))) |]+  | tyName == ''Int#    = [| litE (intPrimL    (toInteger  (I# $var))) |]+  | tyName == ''Word#   = [| litE (wordPrimL   (toInteger  (W# $var))) |]+  where+    var :: Q Exp+    var = varE varName+liftVar varName _ = [| lift $(varE varName) |]++withInfo :: Info+#if MIN_VERSION_template_haskell(2,4,0)+         -> (Cxt -> Name -> [(Name, Kind)] -> [Con] -> Q a)+#else /* !(MIN_VERSION_template_haskell(2,4,0)) */+         -> (Cxt -> Name -> [Name]         -> [Con] -> Q a)+#endif+         -> Q a+withInfo i f = case i of+    TyConI (DataD dcx n vsk cons _) ->+        f dcx n (map unTyVarBndr vsk) cons+    TyConI (NewtypeD dcx n vsk con _) ->+        f dcx n (map unTyVarBndr vsk) [con]+    _ -> error (modName ++ ".deriveLift: unhandled: " ++ pprint i)+  where+#if MIN_VERSION_template_haskell(2,8,0)+    unTyVarBndr (PlainTV v) = (v, StarT)+    unTyVarBndr (KindedTV v k) = (v, k)+#elif MIN_VERSION_template_haskell(2,4,0)+    unTyVarBndr (PlainTV v) = (v, StarK)+    unTyVarBndr (KindedTV v k) = (v, k)+#else /* !(MIN_VERSION_template_haskell(2,4,0)) */+    unTyVarBndr :: Name -> Name+    unTyVarBndr v = v+#endif++-- A type-restricted version of error that ensures makeLift always returns a+-- value of type Q Exp, even when used on an empty datatype.+errorQExp :: String -> Q Exp+errorQExp = error+{-# INLINE errorQExp #-}  instance Lift Name where   lift (Name occName nameFlavour) = [| Name occName nameFlavour |]

@@ -1,7 +1,17 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-} module Foo where +import GHC.Prim (Double#, Float#, Int#, Word#)+#if MIN_VERSION_template_haskell(2,11,0)+import GHC.Prim (Char#)+#endif+ import Language.Haskell.TH.Lift  -- Phantom type parameters can't be dealt with poperly on GHC < 7.8.@@ -15,5 +25,25 @@ newtype Rec a = Rec { field :: a }                 deriving Show +data Empty a++data Unboxed = Unboxed {+-- Template Haskell couldn't handle unlifted chars on GHC < 8.0+#if MIN_VERSION_template_haskell(2,11,0)+  primChar   :: Char#,+#endif+  primDouble :: Double#,+  primFloat  :: Float#,+  primInt    :: Int#,+  primWord   :: Word#+  } deriving Show++newtype Fix f = In { out :: f (Fix f) }+deriving instance Show (f (Fix f)) => Show (Fix f)+ $(deriveLift ''Foo) $(deriveLift ''Rec)+$(deriveLift ''Empty)+$(deriveLift ''Unboxed)+instance Lift (f (Fix f)) => Lift (Fix f) where+  lift = $(makeLift ''Fix)

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} module Main (main) where @@ -8,3 +10,9 @@ main = do print $( lift (Foo "str1" 'c') )           print $( lift (Bar "str2") )           print $( lift (Rec {field = 'a'}) )+          print $( lift (Unboxed+#if MIN_VERSION_template_haskell(2,11,0)+                          'a'#+#endif+                          1.0## 1.0# 1# 1##) )+          print $( lift (In { out = Nothing }) )

@@ -1,5 +1,5 @@ Name:               th-lift-Version:            0.7.2+Version:            0.7.5 Cabal-Version:      >= 1.8 License:            BSD3 License-Files:      COPYING, BSD3, GPL-2@@ -11,7 +11,7 @@ Description:   Derive Template Haskell's Lift class for datatypes. Category:           Language-Tested-With:        GHC==7.4, GHC==7.6, GHC==7.8+Tested-With:        GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.2 build-type:         Simple Extra-source-files: Changelog @@ -23,14 +23,15 @@   Exposed-modules: Language.Haskell.TH.Lift   Extensions:      CPP, TemplateHaskell, MagicHash, TypeSynonymInstances, FlexibleInstances   Hs-Source-Dirs:  src-  Build-Depends:   base >= 3 && < 5+  Build-Depends:   base >= 3 && < 5,+                   ghc-prim    ghc-options:     -Wall   if impl(ghc < 6.12)     Build-Depends: packedstring == 0.1.*,                    template-haskell >= 2.2 && < 2.4   else-    Build-Depends: template-haskell >= 2.4 && < 2.11+    Build-Depends: template-haskell >= 2.4 && < 2.12  Test-Suite test   Type:             exitcode-stdio-1.0@@ -39,9 +40,10 @@   other-modules:    Foo   ghc-options:      -Wall   Build-Depends:    base >= 3 && < 5,+                    ghc-prim,                     th-lift   if impl(ghc < 6.12)     Build-Depends: packedstring == 0.1.*,                    template-haskell >= 2.2 && < 2.4   else-    Build-Depends: template-haskell >= 2.4 && < 2.11+    Build-Depends: template-haskell >= 2.4 && < 2.12