packages feed

th-utilities 0.1.1.1 → 0.2.0.0

raw patch · 7 files changed

+398/−121 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

- TH.ReifyDataType: DataCon :: Name -> [Name] -> Cxt -> [(Maybe Name, Type)] -> DataCon
- TH.ReifyDataType: DataType :: Name -> [Name] -> Cxt -> [DataCon] -> DataType
- TH.ReifyDataType: [dcCxt] :: DataCon -> Cxt
- TH.ReifyDataType: [dcFields] :: DataCon -> [(Maybe Name, Type)]
- TH.ReifyDataType: [dcName] :: DataCon -> Name
- TH.ReifyDataType: [dcTvs] :: DataCon -> [Name]
- TH.ReifyDataType: [dtCons] :: DataType -> [DataCon]
- TH.ReifyDataType: [dtCxt] :: DataType -> Cxt
- TH.ReifyDataType: [dtName] :: DataType -> Name
- TH.ReifyDataType: [dtTvs] :: DataType -> [Name]
- TH.ReifyDataType: conToDataCons :: Con -> [DataCon]
- TH.ReifyDataType: data DataCon
- TH.ReifyDataType: data DataType
- TH.ReifyDataType: instance Data.Data.Data TH.ReifyDataType.DataCon
- TH.ReifyDataType: instance Data.Data.Data TH.ReifyDataType.DataType
- TH.ReifyDataType: instance GHC.Classes.Eq TH.ReifyDataType.DataCon
- TH.ReifyDataType: instance GHC.Classes.Eq TH.ReifyDataType.DataType
- TH.ReifyDataType: instance GHC.Classes.Ord TH.ReifyDataType.DataCon
- TH.ReifyDataType: instance GHC.Classes.Ord TH.ReifyDataType.DataType
- TH.ReifyDataType: instance GHC.Generics.Generic TH.ReifyDataType.DataCon
- TH.ReifyDataType: instance GHC.Generics.Generic TH.ReifyDataType.DataType
- TH.ReifyDataType: instance GHC.Show.Show TH.ReifyDataType.DataCon
- TH.ReifyDataType: instance GHC.Show.Show TH.ReifyDataType.DataType
- TH.ReifyDataType: reifyDataType :: Name -> Q DataType
- TH.ReifyDataType: reifyDataTypeSubstituted :: Type -> Q DataType
+ TH.ReifySimple: DataCon :: Name -> [Name] -> Cxt -> [(Maybe Name, Type)] -> DataCon
+ TH.ReifySimple: DataFamily :: Name -> [Name] -> [DataInst] -> DataFamily
+ TH.ReifySimple: DataInst :: Name -> Cxt -> [Type] -> [DataCon] -> DataInst
+ TH.ReifySimple: DataType :: Name -> [Name] -> Cxt -> [DataCon] -> DataType
+ TH.ReifySimple: TypeFamily :: Name -> [Name] -> [TypeInst] -> TypeFamily
+ TH.ReifySimple: TypeInst :: Name -> [Type] -> Type -> TypeInst
+ TH.ReifySimple: [dcCxt] :: DataCon -> Cxt
+ TH.ReifySimple: [dcFields] :: DataCon -> [(Maybe Name, Type)]
+ TH.ReifySimple: [dcName] :: DataCon -> Name
+ TH.ReifySimple: [dcTvs] :: DataCon -> [Name]
+ TH.ReifySimple: [dfInsts] :: DataFamily -> [DataInst]
+ TH.ReifySimple: [dfName] :: DataFamily -> Name
+ TH.ReifySimple: [dfTvs] :: DataFamily -> [Name]
+ TH.ReifySimple: [diCons] :: DataInst -> [DataCon]
+ TH.ReifySimple: [diCxt] :: DataInst -> Cxt
+ TH.ReifySimple: [diName] :: DataInst -> Name
+ TH.ReifySimple: [diParams] :: DataInst -> [Type]
+ TH.ReifySimple: [dtCons] :: DataType -> [DataCon]
+ TH.ReifySimple: [dtCxt] :: DataType -> Cxt
+ TH.ReifySimple: [dtName] :: DataType -> Name
+ TH.ReifySimple: [dtTvs] :: DataType -> [Name]
+ TH.ReifySimple: [tfInsts] :: TypeFamily -> [TypeInst]
+ TH.ReifySimple: [tfName] :: TypeFamily -> Name
+ TH.ReifySimple: [tfTvs] :: TypeFamily -> [Name]
+ TH.ReifySimple: [tiName] :: TypeInst -> Name
+ TH.ReifySimple: [tiParams] :: TypeInst -> [Type]
+ TH.ReifySimple: [tiType] :: TypeInst -> Type
+ TH.ReifySimple: conToDataCons :: Con -> [DataCon]
+ TH.ReifySimple: data DataCon
+ TH.ReifySimple: data DataFamily
+ TH.ReifySimple: data DataInst
+ TH.ReifySimple: data DataType
+ TH.ReifySimple: data TypeFamily
+ TH.ReifySimple: data TypeInfo
+ TH.ReifySimple: data TypeInst
+ TH.ReifySimple: infoToDataCon :: Info -> Maybe DataCon
+ TH.ReifySimple: infoToDataFamily :: Info -> Maybe DataFamily
+ TH.ReifySimple: infoToDataType :: Info -> Maybe DataType
+ TH.ReifySimple: infoToType :: Info -> Q (Maybe TypeInfo)
+ TH.ReifySimple: infoToTypeFamily :: Info -> Maybe TypeFamily
+ TH.ReifySimple: infoToTypeNoDataKinds :: Info -> Maybe TypeInfo
+ TH.ReifySimple: instance Data.Data.Data TH.ReifySimple.DataCon
+ TH.ReifySimple: instance Data.Data.Data TH.ReifySimple.DataFamily
+ TH.ReifySimple: instance Data.Data.Data TH.ReifySimple.DataInst
+ TH.ReifySimple: instance Data.Data.Data TH.ReifySimple.DataType
+ TH.ReifySimple: instance Data.Data.Data TH.ReifySimple.TypeFamily
+ TH.ReifySimple: instance Data.Data.Data TH.ReifySimple.TypeInst
+ TH.ReifySimple: instance GHC.Classes.Eq TH.ReifySimple.DataCon
+ TH.ReifySimple: instance GHC.Classes.Eq TH.ReifySimple.DataFamily
+ TH.ReifySimple: instance GHC.Classes.Eq TH.ReifySimple.DataInst
+ TH.ReifySimple: instance GHC.Classes.Eq TH.ReifySimple.DataType
+ TH.ReifySimple: instance GHC.Classes.Eq TH.ReifySimple.TypeFamily
+ TH.ReifySimple: instance GHC.Classes.Eq TH.ReifySimple.TypeInst
+ TH.ReifySimple: instance GHC.Classes.Ord TH.ReifySimple.DataCon
+ TH.ReifySimple: instance GHC.Classes.Ord TH.ReifySimple.DataFamily
+ TH.ReifySimple: instance GHC.Classes.Ord TH.ReifySimple.DataInst
+ TH.ReifySimple: instance GHC.Classes.Ord TH.ReifySimple.DataType
+ TH.ReifySimple: instance GHC.Classes.Ord TH.ReifySimple.TypeFamily
+ TH.ReifySimple: instance GHC.Classes.Ord TH.ReifySimple.TypeInst
+ TH.ReifySimple: instance GHC.Generics.Generic TH.ReifySimple.DataCon
+ TH.ReifySimple: instance GHC.Generics.Generic TH.ReifySimple.DataFamily
+ TH.ReifySimple: instance GHC.Generics.Generic TH.ReifySimple.DataInst
+ TH.ReifySimple: instance GHC.Generics.Generic TH.ReifySimple.DataType
+ TH.ReifySimple: instance GHC.Generics.Generic TH.ReifySimple.TypeFamily
+ TH.ReifySimple: instance GHC.Generics.Generic TH.ReifySimple.TypeInst
+ TH.ReifySimple: instance GHC.Show.Show TH.ReifySimple.DataCon
+ TH.ReifySimple: instance GHC.Show.Show TH.ReifySimple.DataFamily
+ TH.ReifySimple: instance GHC.Show.Show TH.ReifySimple.DataInst
+ TH.ReifySimple: instance GHC.Show.Show TH.ReifySimple.DataType
+ TH.ReifySimple: instance GHC.Show.Show TH.ReifySimple.TypeFamily
+ TH.ReifySimple: instance GHC.Show.Show TH.ReifySimple.TypeInst
+ TH.ReifySimple: reifyDataCon :: Name -> Q DataCon
+ TH.ReifySimple: reifyDataFamily :: Name -> Q DataFamily
+ TH.ReifySimple: reifyDataType :: Name -> Q DataType
+ TH.ReifySimple: reifyDataTypeSubstituted :: Type -> Q DataType
+ TH.ReifySimple: reifyType :: Name -> Q TypeInfo
+ TH.ReifySimple: reifyTypeFamily :: Name -> Q TypeFamily
+ TH.ReifySimple: reifyTypeNoDataKinds :: Name -> Q (Maybe TypeInfo)
+ TH.ReifySimple: typeToDataCon :: Name -> Type -> DataCon
+ TH.Utilities: appsT :: Type -> [Type] -> Type
+ TH.Utilities: everywhereButStrings :: Data a => (forall b. Data b => b -> b) -> a -> a
+ TH.Utilities: everywhereButStringsM :: forall a m. (Data a, Monad m) => GenericM m -> a -> m a
+ TH.Utilities: toSimpleName :: Name -> Name
+ TH.Utilities: typeRepToType :: TypeRep -> Q Type

Files

ChangeLog.md view
@@ -1,5 +1,14 @@ # ChangeLog +## 0.2.0.0++* Adds TH.ReifySimple, which supports reifying most of the information TH users+  care about.++* Adds some utilities based on SYB, which is often useful for TH.++* Makes relative path stuff less noisyi with GHCi.+ ## 0.1.0.0  * First public release
src/TH/Derive/Storable.hs view
@@ -28,7 +28,7 @@ import           Language.Haskell.TH.Syntax import           Prelude import           TH.Derive.Internal-import           TH.ReifyDataType+import           TH.ReifySimple import           TH.Utilities  instance Deriver (Storable a) where
− src/TH/ReifyDataType.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}---- | Utilities for reifying simplified datatype info. It omits details--- that aren't usually relevant to generating instances that work with--- the datatype. This makes it easier to use TH to derive instances.-module TH.ReifyDataType-    ( DataType(..)-    , DataCon(..)-    , reifyDataType-    , conToDataCons-    , reifyDataTypeSubstituted-    ) where--import           Data.Data (Data, gmapT)-import           Data.Generics.Aliases (extT)-import qualified Data.Map as M-import           Data.Typeable (Typeable)-import           GHC.Generics (Generic)-import           Language.Haskell.TH-import           Language.Haskell.TH.Instances ()-import           TH.Utilities---- | Simplified info about a 'DataD'. Omits deriving, strictness, and--- kind info.-data DataType = DataType-    { dtName :: Name-    , dtTvs :: [Name]-    , dtCxt :: Cxt-    , dtCons :: [DataCon]-    } deriving (Eq, Show, Ord, Data, Typeable, Generic)---- | Simplified info about a 'Con'. Omits strictness, and kind info.--- This is much nicer than consuming 'Con' directly, because it unifies--- all the constructors into one.-data DataCon = DataCon-    { dcName :: Name-    , dcTvs :: [Name]-    , dcCxt :: Cxt-    , dcFields :: [(Maybe Name, Type)]-    } deriving (Eq, Show, Ord, Data, Typeable, Generic)---- | Reify the given data or newtype declaration, and yields its--- 'DataType' representation.-reifyDataType :: Name -> Q DataType-reifyDataType queryName = do-    info <- reify queryName-    case info of-#if MIN_VERSION_template_haskell(2,11,0)-        TyConI (DataD preds name vars _kind cons _deriving) -> do-#else-        TyConI (DataD preds name vars cons _deriving) -> do-#endif-            let tvs = map tyVarBndrName vars-                cs = concatMap conToDataCons cons-            return (DataType name tvs preds cs)-#if MIN_VERSION_template_haskell(2,11,0)-        TyConI (NewtypeD preds name vars _kind con _deriving) -> do-#else-        TyConI (NewtypeD preds name vars con _deriving) -> do-#endif-            let tvs = map tyVarBndrName vars-                cs = conToDataCons con-            return (DataType name tvs preds cs)-        _ -> fail $ "Expected to reify a datatype, instead got:\n" ++ pprint info---- | Convert a 'Con' to a list of 'DataCon'. The result is a list--- because 'GadtC' and 'RecGadtC' can define multiple constructors.-conToDataCons :: Con -> [DataCon]-conToDataCons = \case-    NormalC name slots ->-        [DataCon name [] [] (map (\(_, ty) -> (Nothing, ty)) slots)]-    RecC name fields ->-        [DataCon name [] [] (map (\(n, _, ty) -> (Just n, ty)) fields)]-    InfixC (_, ty1) name (_, ty2) ->-        [DataCon name [] [] [(Nothing, ty1), (Nothing, ty2)]]-    ForallC tvs preds con ->-        map (\(DataCon name tvs0 preds0 fields) ->-            DataCon name (tvs0 ++ map tyVarBndrName tvs) (preds0 ++ preds) fields) (conToDataCons con)-#if MIN_VERSION_template_haskell(2,11,0)-    GadtC ns slots _ ->-        map (\n -> DataCon n [] [] (map (\(_, ty) -> (Nothing, ty)) slots)) ns-    RecGadtC ns fields _ ->-        map (\n -> DataCon n [] [] (map (\(n, _, ty) -> (Just n, ty)) fields)) ns-#endif---- | Like 'reifyDataType', but takes a 'Type' instead of just the 'Name'--- of the datatype. It expects a normal datatype argument (see--- 'typeToNamedCon').-reifyDataTypeSubstituted :: Type -> Q DataType-reifyDataTypeSubstituted ty =-    case typeToNamedCon ty of-        Nothing -> fail $ "Expected a datatype, but reifyDataTypeSubstituted was applied to " ++ pprint ty-        Just (n, args) -> do-            dt <- reifyDataType n-            let cons' = substituteTvs (M.fromList (zip (dtTvs dt) args)) (dtCons dt)-            return (dt { dtCons = cons' })---- TODO: add various handy generics based traversals to TH.Utilities--substituteTvs :: Data a => M.Map Name Type -> a -> a-substituteTvs mp = transformTypes go-  where-    go (VarT name) | Just ty <- M.lookup name mp = ty-    go ty = gmapT (substituteTvs mp) ty--transformTypes :: Data a => (Type -> Type) -> a -> a-transformTypes f = gmapT (transformTypes f) `extT` (id :: String -> String) `extT` f
+ src/TH/ReifySimple.hs view
@@ -0,0 +1,333 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++-- | Utilities for reifying simplified datatype info. It omits details+-- that aren't usually relevant to generating instances that work with+-- the datatype. This makes it easier to use TH to derive instances.+--+-- The \"Simple\" in the module name refers to the simplicity of the+-- datatypes, not the module itself, which exports quite a few things+-- which are useful in some circumstance or another. I anticipate that+-- the most common uses of this will be the following APIs:+--+-- * Getting info about a @data@ or @newtype@ declaration, via+--   'DataType', 'reifyDataType', and 'DataCon'. This is useful for+--   writing something which generates declarations based on a datatype,+--   one of the most common uses of Template Haskell.+--+-- * Getting nicely structured info about a named type. See 'TypeInfo'+--   and 'reifyType'. This does not yet support reifying typeclasses,+--   primitive type constructors, or type variables ('TyVarI').+--+-- Currently, this module supports reifying simplified versions of the+-- following 'Info' constructors:+--+-- * 'TyConI' with 'DataD' and 'NewtypeD' (becomes a 'DataType' value)+--+-- * 'FamilyI' becomes a 'DataFamily' or 'TypeFamily' value.+--+-- * 'DataConI' becomes a 'DataCon' value.+--+-- In the future it will hopefully also have support for the remaining+-- 'Info' constructors, 'ClassI', 'ClassOpI', 'PrimTyConI', 'VarI', and+-- 'TyVarI'.+module TH.ReifySimple+    (+    -- * Reifying simplified type info+      TypeInfo, reifyType, infoToType+    , reifyTypeNoDataKinds, infoToTypeNoDataKinds+    -- * Reifying simplified info for specific declaration varieties+    -- ** Datatype info+    , DataType(..), reifyDataType, infoToDataType+    -- ** Data constructor info+    , DataCon(..), reifyDataCon, infoToDataCon, typeToDataCon+    -- ** Data family info+    , DataFamily(..), DataInst(..), reifyDataFamily, infoToDataFamily+    -- ** Type family info+    , TypeFamily(..), TypeInst(..), reifyTypeFamily, infoToTypeFamily+    -- * Other utilities+    , conToDataCons+    , reifyDataTypeSubstituted+    ) where++import           Control.Applicative ((<|>))+import           Data.Data (Data, gmapT)+import           Data.Generics.Aliases (extT)+import qualified Data.Map as M+import           Data.Typeable (Typeable)+import           GHC.Generics (Generic)+import           Language.Haskell.TH+import           Language.Haskell.TH.Instances ()+import           TH.Utilities++data TypeInfo+    = DataTypeInfo DataType+    | DataFamilyInfo DataFamily+    | TypeFamilyInfo TypeFamily+    | LiftedDataConInfo DataCon++-- | Reifies a 'Name' as a 'TypeInfo', and calls 'fail' if this doesn't+-- work. Use 'reify' with 'infoToType' if you want to handle the failure+-- case more gracefully.+--+-- This does not yet support reifying typeclasses, primitive type+-- constructors, or type variables ('TyVarI').+reifyType :: Name -> Q TypeInfo+reifyType name = do+   info <- reify name+   mres <- infoToType info+   case mres of+       Just res -> return res+       Nothing -> fail $+           "Expected to reify a data type, data family, or type family. Instead got:\n" +++           pprint info++-- | Convert an 'Info' into a 'TypeInfo' if possible, and otherwise+-- yield 'Nothing'.  Needs to run in 'Q' so that+infoToType :: Info -> Q (Maybe TypeInfo)+infoToType info =+    case (infoToTypeNoDataKinds info, infoToDataCon info) of+       (Just result, _) -> return (Just result)+       (Nothing, Just dc) -> do+#if MIN_VERSION_template_haskell(2,11,0)+           dataKindsEnabled <- isExtEnabled DataKinds+#else+           reportWarning $+               "For " ++ pprint (dcName dc) +++               ", assuming DataKinds is on, and yielding LiftedDataConInfo."+           let dataKindsEnabled = True+#endif+           return $ if dataKindsEnabled then Just (LiftedDataConInfo dc) else Nothing+       (Nothing, Nothing) -> return Nothing++-- | Reifies type info, but instead of yielding a 'LiftedDataConInfo',+-- will instead yield 'Nothing'.+reifyTypeNoDataKinds :: Name -> Q (Maybe TypeInfo)+reifyTypeNoDataKinds = fmap infoToTypeNoDataKinds . reify++-- | Convert an 'Info into a 'TypeInfo' if possible. If it's a data+-- constructor, instead of yielding 'LiftedDataConInfo', it will instead+-- yield 'Nothing'.+infoToTypeNoDataKinds :: Info -> Maybe TypeInfo+infoToTypeNoDataKinds info =+   (DataTypeInfo <$> infoToDataType info) <|>+   (DataFamilyInfo <$> infoToDataFamily info) <|>+   (TypeFamilyInfo <$> infoToTypeFamily info)++--------------------------------------------------------------------------------+-- Reifying specific declaration varieties++-- | Simplified info about a 'DataD'. Omits deriving, strictness,+-- kind info, and whether it's @data@ or @newtype@.+data DataType = DataType+    { dtName :: Name+    , dtTvs :: [Name]+    , dtCxt :: Cxt+    , dtCons :: [DataCon]+    } deriving (Eq, Show, Ord, Data, Typeable, Generic)++-- | Simplified info about a 'Con'. Omits deriving, strictness, and kind+-- info. This is much nicer than consuming 'Con' directly, because it+-- unifies all the constructors into one.+data DataCon = DataCon+    { dcName :: Name+    , dcTvs :: [Name]+    , dcCxt :: Cxt+    , dcFields :: [(Maybe Name, Type)]+    } deriving (Eq, Show, Ord, Data, Typeable, Generic)++-- | Simplified info about a data family. Omits deriving, strictness, and+-- kind info.+data DataFamily = DataFamily+    { dfName :: Name+    , dfTvs :: [Name]+    , dfInsts :: [DataInst]+    } deriving (Eq, Show, Ord, Data, Typeable, Generic)++-- | Simplified info about a data family instance. Omits deriving,+-- strictness, and kind info.+data DataInst = DataInst+    { diName :: Name+    , diCxt :: Cxt+    , diParams :: [Type]+    , diCons :: [DataCon]+    } deriving (Eq, Show, Ord, Data, Typeable, Generic)++-- | Simplified info about a type family. Omits kind info and injectivity+-- info.+data TypeFamily = TypeFamily+    { tfName :: Name+    , tfTvs :: [Name]+    , tfInsts :: [TypeInst]+    } deriving (Eq, Show, Ord, Data, Typeable, Generic)++-- | Simplified info about a type family instance. Omits nothing.+data TypeInst = TypeInst+    { tiName :: Name+    , tiParams :: [Type]+    , tiType :: Type+    } deriving (Eq, Show, Ord, Data, Typeable, Generic)++-- | Reify the given data or newtype declaration, and yields its+-- 'DataType' representation.+reifyDataType :: Name -> Q DataType+reifyDataType name = do+    info <- reify name+    case infoToDataType info of+        Nothing -> fail $ "Expected to reify a datatype. Instead got:\n" ++ pprint info+        Just x -> return x++-- | Reify the given data constructor.+reifyDataCon :: Name -> Q DataCon+reifyDataCon name = do+    info <- reify name+    case infoToDataCon info of+        Nothing -> fail $ "Expected to reify a constructor. Instead got:\n" ++ pprint info+        Just x -> return x++-- | Reify the given data family, and yield its 'DataFamily'+-- representation.+reifyDataFamily :: Name -> Q DataFamily+reifyDataFamily name = do+    info <- reify name+    case infoToDataFamily info of+        Nothing -> fail $ "Expected to reify a data family. Instead got:\n" ++ pprint info+        Just x -> return x++-- | Reify the given type family instance declaration, and yields its+-- 'TypeInst' representation.+reifyTypeFamily :: Name -> Q TypeFamily+reifyTypeFamily name = do+    info <- reify name+    case infoToTypeFamily info of+        Nothing -> fail $ "Expected to reify a type family. Instead got:\n" ++ pprint info+        Just x -> return x++infoToDataType :: Info -> Maybe DataType+infoToDataType info = case info of+#if MIN_VERSION_template_haskell(2,11,0)+    TyConI (DataD preds name tvs _kind cons _deriving) ->+#else+    TyConI (DataD preds name tvs cons _deriving) ->+#endif+        Just $ DataType name (map tyVarBndrName tvs) preds (concatMap conToDataCons cons)+#if MIN_VERSION_template_haskell(2,11,0)+    TyConI (NewtypeD preds name tvs _kind con _deriving) ->+#else+    TyConI (NewtypeD preds name tvs con _deriving) ->+#endif+        Just $ DataType name (map tyVarBndrName tvs) preds (conToDataCons con)+    _ -> Nothing++infoToDataFamily :: Info -> Maybe DataFamily+infoToDataFamily info = case info of+#if MIN_VERSION_template_haskell(2,11,0)+    FamilyI (DataFamilyD name tvs _kind) insts ->+#else+    FamilyI (FamilyD DataFam name tvs _kind) insts ->+#endif+        Just $ DataFamily name (map tyVarBndrName tvs) (map go insts)+    _ -> Nothing+  where+#if MIN_VERSION_template_haskell(2,11,0)+    go (NewtypeInstD preds name params _kind con _deriving) =+#else+    go (NewtypeInstD preds name params       con _deriving) =+#endif+        DataInst name preds params (conToDataCons con)+#if MIN_VERSION_template_haskell(2,11,0)+    go (DataInstD preds name params _kind cons _deriving) =+#else+    go (DataInstD preds name params       cons _deriving) =+#endif+        DataInst name preds params (concatMap conToDataCons cons)+    go info' = error $+        "Unexpected instance in FamilyI in infoToDataInsts:\n" ++ pprint info'++infoToTypeFamily :: Info -> Maybe TypeFamily+infoToTypeFamily info = case info of+#if MIN_VERSION_template_haskell(2,11,0)+    FamilyI (ClosedTypeFamilyD (TypeFamilyHead name tvs _result _injectivity) eqns) _ ->+        Just $ TypeFamily name (map tyVarBndrName tvs) $ map (goEqn name) eqns+    FamilyI (OpenTypeFamilyD (TypeFamilyHead name tvs _result _injectivity)) insts ->+        Just $ TypeFamily name (map tyVarBndrName tvs) $ map go insts+#else+    FamilyI (ClosedTypeFamilyD name tvs _kind eqns) [] ->+        Just $ TypeFamily name (map tyVarBndrName tvs) $ map (goEqn name) eqns+    FamilyI (FamilyD TypeFam name tvs _kind) insts ->+        Just $ TypeFamily name (map tyVarBndrName tvs) $ map go insts+#endif+    _ -> Nothing+  where+    goEqn name (TySynEqn params ty) = TypeInst name params ty+    go (TySynInstD name (TySynEqn params ty)) = TypeInst name params ty+    go info' = error $+        "Unexpected instance in FamilyI in infoToTypeInsts:\n" ++ pprint info'++infoToDataCon :: Info -> Maybe DataCon+infoToDataCon info = case info of+#if MIN_VERSION_template_haskell(2,11,0)+    DataConI name ty _parent ->+#else+    DataConI name ty _parent _fixity ->+#endif+        Just (typeToDataCon name ty)+    _ -> Nothing++-- | Creates a 'DataCon' given the 'Name' and 'Type' of a+-- data-constructor.  Note that the result the function type is *not* checked to match the provided 'Name'.+typeToDataCon :: Name -> Type -> DataCon+typeToDataCon dcName ty0 = DataCon {..}+  where+    (dcTvs, dcCxt, dcFields) = case ty0 of+        ForallT tvs preds ty -> (map tyVarBndrName tvs, preds, typeToFields ty)+        ty -> ([], [], typeToFields ty)+    -- TODO: Should we sanity check the result type?+    typeToFields = init . map (Nothing, ) . unAppsT++-- | Convert a 'Con' to a list of 'DataCon'. The result is a list+-- because 'GadtC' and 'RecGadtC' can define multiple constructors.+conToDataCons :: Con -> [DataCon]+conToDataCons = \case+    NormalC name slots ->+        [DataCon name [] [] (map (\(_, ty) -> (Nothing, ty)) slots)]+    RecC name fields ->+        [DataCon name [] [] (map (\(n, _, ty) -> (Just n, ty)) fields)]+    InfixC (_, ty1) name (_, ty2) ->+        [DataCon name [] [] [(Nothing, ty1), (Nothing, ty2)]]+    ForallC tvs preds con ->+        map (\(DataCon name tvs0 preds0 fields) ->+            DataCon name (tvs0 ++ map tyVarBndrName tvs) (preds0 ++ preds) fields) (conToDataCons con)+#if MIN_VERSION_template_haskell(2,11,0)+    GadtC ns slots _ ->+        map (\n -> DataCon n [] [] (map (\(_, ty) -> (Nothing, ty)) slots)) ns+    RecGadtC ns fields _ ->+        map (\n -> DataCon n [] [] (map (\(n, _, ty) -> (Just n, ty)) fields)) ns+#endif++-- | Like 'reifyDataType', but takes a 'Type' instead of just the 'Name'+-- of the datatype. It expects a normal datatype argument (see+-- 'typeToNamedCon').+reifyDataTypeSubstituted :: Type -> Q DataType+reifyDataTypeSubstituted ty =+    case typeToNamedCon ty of+        Nothing -> fail $ "Expected a datatype, but reifyDataTypeSubstituted was applied to " ++ pprint ty+        Just (n, args) -> do+            dt <- reifyDataType n+            let cons' = substituteTvs (M.fromList (zip (dtTvs dt) args)) (dtCons dt)+            return (dt { dtCons = cons' })++-- TODO: add various handy generics based traversals to TH.Utilities++substituteTvs :: Data a => M.Map Name Type -> a -> a+substituteTvs mp = transformTypes go+  where+    go (VarT name) | Just ty <- M.lookup name mp = ty+    go ty = gmapT (substituteTvs mp) ty++transformTypes :: Data a => (Type -> Type) -> a -> a+transformTypes f = gmapT (transformTypes f) `extT` (id :: String -> String) `extT` f
src/TH/RelativePaths.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}  -- | This module provides Template Haskell utilities for loading files@@ -15,6 +16,7 @@ -- it's in. module TH.RelativePaths where +import           Control.Exception (IOException, catch) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import           Data.List (find)@@ -24,7 +26,7 @@ import qualified Data.Text.Lazy.IO as LT import           Language.Haskell.TH (Q, Loc(loc_filename), location, runIO, reportWarning) import           Language.Haskell.TH.Syntax (addDependentFile)-import           System.Directory (getDirectoryContents, getCurrentDirectory, setCurrentDirectory)+import           System.Directory (getDirectoryContents, getCurrentDirectory, setCurrentDirectory, canonicalizePath) import           System.FilePath  -- | Reads a file as a strict ByteString. The path is specified relative@@ -90,13 +92,19 @@ pathRelativeToCabalPackage :: FilePath -> Q FilePath pathRelativeToCabalPackage fp = do     loc <- location-    mcabalFile <- runIO $ findCabalFile (loc_filename loc)-    case mcabalFile of-        Just cabalFile -> return (takeDirectory cabalFile </> fp)-        Nothing -> do-            reportWarning "Failed to find cabal file, in order to resolve relative paths in TH.  Using current working directory instead."-            cwd <- runIO getCurrentDirectory-            return (cwd </> fp)+    parent <-+        if loc_filename loc == "<interactive>"+            then runIO getCurrentDirectory+            else do+                mcanonical <- runIO $ fmap Just (canonicalizePath (loc_filename loc))+                   `catch` \(_err :: IOException) -> return Nothing+                mcabalFile <- runIO $ maybe (return Nothing) findCabalFile mcanonical+                case mcabalFile of+                    Just cabalFile -> return (takeDirectory cabalFile)+                    Nothing -> do+                        reportWarning "Failed to find cabal file, in order to resolve relative paths in TH.  Using current working directory instead."+                        runIO getCurrentDirectory+    return (parent </> fp)  -- | Given the path to a file or directory, search parent directories -- for a .cabal file.
src/TH/Utilities.hs view
@@ -2,11 +2,15 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Miscellaneous Template Haskell utilities, added as needed by -- packages in the th-utilities repo and elsewhere. module TH.Utilities where +import Data.Data+import Data.Generics import Data.Proxy import Data.Typeable import Language.Haskell.TH@@ -17,6 +21,10 @@ tyVarBndrName (PlainTV n) = n tyVarBndrName (KindedTV n _) = n +appsT :: Type -> [Type] -> Type+appsT x [] = x+appsT x (y:xs) = appsT (AppT x y) xs+ -- | Breaks a type application like @A b c@ into [A, b, c]. In other -- words, it descends leftwards down 'AppT' constructors, and yields a -- list of the results.@@ -65,6 +73,24 @@ proxyE :: TypeQ -> ExpQ proxyE ty = [| Proxy :: Proxy $(ty) |] +-- | Like the 'everywhere' generic traversal strategy, but skips over+-- strings. This can aid performance of TH traversals quite a bit.+everywhereButStrings :: Data a => (forall b. Data b => b -> b) -> a -> a+everywhereButStrings f =+    (f . gmapT (everywhereButStrings f)) `extT` (id :: String -> String)++-- | Like the 'everywhereM' generic traversal strategy, but skips over+-- strings. This can aid performance of TH traversals quite a bit.+everywhereButStringsM :: forall a m. (Data a, Monad m) => GenericM m -> a -> m a+everywhereButStringsM f x = do+    x' <- gmapM (everywhereButStringsM f) x+    (f `extM` (return :: String -> m String)) x'++-- | Make a 'Name' with a 'NameS' or 'NameQ' flavour, from a 'Name' with+-- any 'NameFlavour'. This may change the meaning of names.+toSimpleName :: Name -> Name+toSimpleName = mkName . pprint+ -- | Construct a plain name ('mkName') based on the given name. This is -- useful for cases where TH doesn't expect a unique name. dequalify :: Name -> Name@@ -101,6 +127,17 @@ fromPlainInstanceD (InstanceD a b c) = Just (a, b, c) #endif fromPlainInstanceD _ = Nothing++-- | Utility to convert "Data.Typeable" 'TypeRep' to a 'Type'. Note that+-- this function is known to not yet work for many cases, but it does+-- work for normal user datatypes. In future versions this function+-- might have better behavior.+typeRepToType :: TypeRep -> Q Type+typeRepToType tr = do+    let (con, args) = splitTyConApp tr+        name = Name (OccName (tyConName con)) (NameG TcClsName (PkgName (tyConPackage con)) (ModName (tyConModule con)))+    resultArgs <- mapM typeRepToType args+    return (appsT (ConT name) resultArgs)  -- | Hack to enable putting expressions inside 'lift'-ed TH data. For -- example, you could do
th-utilities.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:                th-utilities-version:             0.1.1.1+version:             0.2.0.0 synopsis:            Collection of useful functions for use with Template Haskell homepage:            https://github.com/fpco/th-utilities#readme bug-reports:         https://github.com/fpco/th-utilities/issues@@ -41,7 +41,7 @@   exposed-modules:     TH.Derive     TH.Derive.Storable-    TH.ReifyDataType+    TH.ReifySimple     TH.RelativePaths     TH.Utilities   other-modules: