th-utilities-0.2.5.0/src/0000755000000000000000000000000014312501511013246 5ustar0000000000000000th-utilities-0.2.5.0/src/TH/0000755000000000000000000000000014312501526013567 5ustar0000000000000000th-utilities-0.2.5.0/src/TH/Derive/0000755000000000000000000000000014312501511014777 5ustar0000000000000000th-utilities-0.2.5.0/test/0000755000000000000000000000000014312502544013445 5ustar0000000000000000th-utilities-0.2.5.0/test/TH/0000755000000000000000000000000014312501511013751 5ustar0000000000000000th-utilities-0.2.5.0/test/TH/Derive/0000755000000000000000000000000014312501511015167 5ustar0000000000000000th-utilities-0.2.5.0/test/TH/DeriveSpec/0000755000000000000000000000000014312501511016002 5ustar0000000000000000th-utilities-0.2.5.0/src/TH/Derive.hs0000644000000000000000000001265414312501511015343 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -- | This module implements a system for registering and using typeclass -- derivers and instantiators. This allows you to derive instances for -- typeclasses beyond GHC's ability to generate instances in @deriving@ -- clauses. -- -- For example, "TH.Derive.Storable" defines a 'Deriver' for 'Storable'. -- This allows us to use 'derive' to generate an instance for Storable: -- -- @ -- data X = X Int Float -- -- $($(derive [d| -- instance Deriving (Storable X) -- |])) -- @ -- -- In particular, note the use of double splicing, @$($(derive [d| ... -- |]))@. The inner @$(derive [d| ... |])@ expression generates code -- which invokes the 'runDeriver' method with appropriate arguments. The -- outer @$( ... $)@ then runs that code in order to generate the -- resulting instances. This is how it does dispatch at compile time. -- -- There are a number of advantages of re-using instance syntax in this -- way: -- -- * It allows the user to specify constraints. Similarly to GHC's need -- for standalone deriving, it is sometimes very difficult for TH to -- figure out appropriate superclass constraints. -- -- * The instance gets thoroughly checked by GHC (syntax, kind, and type -- checking). This means that you get reasonably nice error messages -- when you misuse these. -- -- * It allows the user to specify methods. With 'Instantiator's, the -- user can provide values which can be used in the definition of the -- generated instance. This is a bit like having -- . -- We don't have pretty ways of writing these quite yet, but -- I have worked on something -- . -- -- * Using compile-time dispatch allows for concise specification of a -- multiple of instances you'd like derived. -- -- * In the case of use of a 'Deriver's, the user doesn't need to know -- about anything but 'derive' and the name of the class they want. (and -- the 'Deriver' instance must be in scope one way or another) module TH.Derive ( derive , Deriving , Deriver(..) , Instantiator(..) , dequalifyMethods ) where import Data.Data import Data.Generics import Language.Haskell.TH import Language.Haskell.TH.Instances () import TH.Utilities import TH.Derive.Internal import TH.Derive.Storable () import GHC.Exts (Any) --TODO: support deriving on constraint kinds, for concision! -- | This is the primary function for users of "TH.Derive". See the -- module documentation for usage info. derive :: DecsQ -> ExpQ derive decsq = do decs <- decsq let labeledDecs = zip (map (mkName . ("x" ++) . show) [(0::Int)..]) decs doE $ map toStmt labeledDecs ++ [ noBindS [e| return $ concat $(listE (map (varE . fst) labeledDecs)) |] ] where -- FIXME: handle overlap info in template-haskell > 2.11.0 toStmt (varName, dec) = case fromPlainInstanceD dec of Just (preds, AppT (ConT ((== ''Deriving) -> True)) cls, []) -> bindS (varP varName) [e| runDeriver $(proxyE (return (tyVarsToAny cls))) preds cls |] Just (preds, ty, decs) -> bindS (varP varName) [e| runInstantiator $(proxyE (return (tyVarsToAny ty))) preds ty decs |] _ -> fail $ "Expected deriver or instantiator, instead got:\n" ++ show dec -- | Turn type variables into uses of 'Any'. -- -- The purpose of this is to avoid errors such as described in -- https://github.com/fpco/store/issues/140 . The problem is that -- older GHC versions (<= 7.10) have a bug where they expect type -- variables in expressions to be in scope. tyVarsToAny :: Data a => a -> a tyVarsToAny = everywhere (id `extT` modifyType) where modifyType (VarT _) = ConT ''Any modifyType ty = ty -- | Useful function for defining 'Instantiator' instances. It uses -- 'Data' to generically replace references to the methods with plain -- 'Name's. This is handy when you are putting the definitions passed to -- the instantiator in a where clause. It is also useful so that you can -- reference the class methods from AST quotes involved in the -- definition of the instantiator. dequalifyMethods :: Data a => Name -> a -> Q a dequalifyMethods className x = do info <- reify className case info of ClassI (ClassD _ _ _ _ decls) _ -> return (go [n | SigD n _ <- decls] x) _ -> fail $ "dequalifyMethods expected class, but got:\n" ++ pprint info where go :: Data b => [Name] -> b -> b go names = gmapT (go names) `extT` (id :: String -> String) `extT` (\n -> if n `elem` names then dequalify n else n) {- -- Code originally from 'deriver' -- TODO: warnings / errors for invalid derivers? ClassI _ insts <- reify ''Deriver let derivers = mapMaybe deriverInfo insts deriverInfo :: InstanceDec -> Maybe (Name, Name, Type) deriverInfo (InstanceD _ (AppT (AppT (ConT ''Deriving) (ConT deriver)) cls)) = case unAppsT cls of (ConT clsName, _) -> Just (deriver, clsName, cls) _ -> Nothing deriverInfo _ = Nothing -} th-utilities-0.2.5.0/src/TH/Derive/Storable.hs0000644000000000000000000001372714312501511017120 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -- | Implementation of a 'Storable' deriver for data types. This works for -- any non-recursive datatype which has 'Storable' fields. -- -- Most users won't need to import this module directly. Instead, use -- 'derive' / 'Deriving' to create 'Storable' instances. module TH.Derive.Storable ( makeStorableInst ) where import Control.Applicative import Control.Monad import Data.List (find) import Data.Maybe (fromMaybe) import Data.Word import Foreign.Ptr import Foreign.Storable import Language.Haskell.TH import Language.Haskell.TH.Syntax import Prelude import TH.Derive.Internal import TH.ReifySimple import TH.Utilities instance Deriver (Storable a) where runDeriver _ = makeStorableInst -- | Implementation used for 'runDeriver'. makeStorableInst :: Cxt -> Type -> Q [Dec] makeStorableInst preds ty = do argTy <- expectTyCon1 ''Storable ty dt <- reifyDataTypeSubstituted argTy makeStorableImpl preds ty (dtCons dt) -- TODO: recursion check? At least document that this could in some -- cases work, but produce a bogus instance. makeStorableImpl :: Cxt -> Type -> [DataCon] -> Q [Dec] makeStorableImpl preds headTy cons = do -- Since this instance doesn't pay attention to alignment, we -- just say alignment doesn't matter. alignmentMethod <- [| 1 |] sizeOfMethod <- sizeExpr peekMethod <- peekExpr pokeMethod <- pokeExpr let methods = [ FunD (mkName "alignment") [Clause [WildP] (NormalB alignmentMethod) []] , FunD (mkName "sizeOf") [Clause [] (NormalB sizeOfMethod) []] , FunD (mkName "peek") [Clause [VarP ptrName] (NormalB peekMethod) []] , FunD (mkName "poke") [Clause [VarP ptrName, VarP valName] (NormalB pokeMethod) []] ] return [plainInstanceD preds headTy methods] where -- NOTE: Much of the code here resembles code in store for deriving -- Store instances. Changes here may be relevant there as well. (tagType, _, tagSize) = fromMaybe (error "Too many constructors") $ find (\(_, maxN, _) -> maxN >= length cons) tagTypes tagTypes :: [(Name, Int, Int)] tagTypes = [ ('(), 1, 0) , (''Word8, fromIntegral (maxBound :: Word8), 1) , (''Word16, fromIntegral (maxBound :: Word16), 2) , (''Word32, fromIntegral (maxBound :: Word32), 4) , (''Word64, fromIntegral (maxBound :: Word64), 8) ] valName = mkName "val" tagName = mkName "tag" ptrName = mkName "ptr" fName ix = mkName ("f" ++ show ix) ptrExpr = varE ptrName -- [[Int]] expression, where the inner lists are the sizes of the -- fields. Each member of the outer list corresponds to a different -- constructor. sizeExpr = appE (varE 'const) $ appE (varE 'maximum) $ listE [ appE (varE 'sum) (listE [sizeOfExpr ty | (_, ty) <- fields]) | (DataCon _ _ _ fields) <- cons ] -- Choose a tag size large enough for this constructor count. -- Expression used for the definition of peek. peekExpr = case cons of [] -> [| error ("Attempting to peek type with no constructors (" ++ $(lift (pprint headTy)) ++ ")") |] [con] -> peekCon con _ -> doE [ bindS (varP tagName) [| peek (castPtr $(ptrExpr)) |] , noBindS (caseE (sigE (varE tagName) (conT tagType)) (map peekMatch (zip [0..] cons) ++ [peekErr])) ] peekMatch (ix, con) = match (litP (IntegerL ix)) (normalB (peekCon con)) [] peekErr = match wildP (normalB [| error ("Found invalid tag while peeking (" ++ $(lift (pprint headTy)) ++ ")") |]) [] peekCon (DataCon cname _ _ fields) = letE (offsetDecls fields) $ case fields of [] -> [| pure $(conE cname) |] (_:fields') -> foldl (\acc (ix, _) -> [| $(acc) <*> $(peekOffset ix) |] ) [| $(conE cname) <$> $(peekOffset 0) |] (zip [1..] fields') peekOffset ix = [| peek (castPtr (plusPtr $(ptrExpr) $(varE (offset ix)))) |] -- Expression used for the definition of poke. pokeExpr = caseE (varE valName) (map pokeMatch (zip [0..] cons)) pokeMatch :: (Int, DataCon) -> MatchQ pokeMatch (ixcon, DataCon cname _ _ fields) = match (conP cname (map varP (map fName ixs))) (normalB (case tagPokes ++ offsetLet ++ fieldPokes of [] -> [|return ()|] stmts -> doE stmts)) [] where tagPokes = case cons of (_:_:_) -> [noBindS [| poke (castPtr $(ptrExpr)) (ixcon :: $(conT tagType)) |]] _ -> [] offsetLet | null ixs = [] | otherwise = [letS (offsetDecls fields)] fieldPokes = map (noBindS . pokeField) ixs ixs = map fst (zip [0..] fields) pokeField ix = [| poke (castPtr (plusPtr $(ptrExpr) $(varE (offset ix)))) $(varE (fName ix)) |] -- Generate declarations which compute the field offsets. offsetDecls fields = -- Skip the last one, to avoid unused variable warnings. init $ map (\(ix, expr) -> valD (varP (offset ix)) (normalB expr) []) $ -- Initial offset is the tag size. ((0, [| tagSize |]) :) $ map (\(ix, (_, ty)) -> (ix, offsetExpr ix ty)) $ zip [1..] fields where offsetExpr ix ty = [| $(sizeOfExpr ty) + $(varE (offset (ix - 1))) |] sizeOfExpr ty = [| $(varE 'sizeOf) (error "sizeOf evaluated its argument" :: $(return ty)) |] offset ix = mkName ("offset" ++ show (ix :: Int)) th-utilities-0.2.5.0/src/TH/FixQ.hs0000644000000000000000000000157414312501526015001 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | A compat module to take fixed points in 'Q'. module TH.FixQ (fixQ) where #if MIN_VERSION_template_haskell(2,17,0) import Control.Monad.Fix (mfix) import Language.Haskell.TH.Syntax (Q (..)) fixQ :: (a -> Q a) -> Q a fixQ = mfix #else -- We don't have a MonadFix instance for Q import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar) import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO) import Control.Exception.Base (FixIOException (..)) import Language.Haskell.TH.Syntax (Q (..), runIO) import GHC.IO.Unsafe (unsafeDupableInterleaveIO) fixQ :: (a -> Q a) -> Q a fixQ k = do m <- runIO newEmptyMVar ans <- runIO (unsafeDupableInterleaveIO (readMVar m `catch` \BlockedIndefinitelyOnMVar -> throwIO FixIOException)) result <- k ans runIO (putMVar m result) return result #endif th-utilities-0.2.5.0/src/TH/ReifySimple.hs0000644000000000000000000003247014312501511016353 0ustar0000000000000000{-# 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 #if MIN_VERSION_template_haskell(2,16,0) hiding (reifyType) #endif 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,15,0) go (NewtypeInstD preds _ lhs _kind con _deriving) | ConT name:params <- unAppsT lhs #elif 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,15,0) go (DataInstD preds _ lhs _kind cons _deriving) | ConT name:params <- unAppsT lhs #elif 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 (goInst name) 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 (goInst name) insts #endif _ -> Nothing where #if MIN_VERSION_template_haskell(2,15,0) toParams ps (AppT ty p) = toParams (p : ps) ty toParams ps (AppKindT ty _) = toParams ps ty toParams ps _ = ps goEqn name (TySynEqn _ lty rty) = TypeInst name (toParams [] lty) rty goInst name (TySynInstD eqn) = goEqn name eqn goInst _ info' = error $ "Unexpected instance in FamilyI in infoToTypeInsts:\n" ++ pprint info' #else goEqn name (TySynEqn params ty) = TypeInst name params ty goInst name (TySynInstD _ eqn) = goEqn name eqn goInst _ info' = error $ "Unexpected instance in FamilyI in infoToTypeInsts:\n" ++ pprint info' #endif 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 (\dn -> DataCon dn [] [] (map (\(_, ty) -> (Nothing, ty)) slots)) ns RecGadtC ns fields _ -> map (\dn -> DataCon dn [] [] (map (\(fn, _, ty) -> (Just fn, 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 th-utilities-0.2.5.0/src/TH/RelativePaths.hs0000644000000000000000000001136414312501511016675 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -- | This module provides Template Haskell utilities for loading files -- based on paths relative to the root of your Cabal package. -- -- Normally when building a cabal package, GHC is run with its current -- directory set at the package's root directory. This allows using -- relative paths to refer to files. However, this becomes problematic -- when you want to load modules from multiple projects, such as when -- using "stack ghci". -- -- This solves the problem by getting the current module's filepath from -- TH via 'location'. It then searches upwards in the directory tree for -- a .cabal file, and makes the provided path relative to the folder -- 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) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as LT 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, canonicalizePath) import System.FilePath -- | Reads a file as a strict ByteString. The path is specified relative -- to the package's root directory, and 'addDependentfile' is invoked on -- the target file. qReadFileBS :: FilePath -> Q BS.ByteString qReadFileBS fp = do fp' <- pathRelativeToCabalPackage fp addDependentFile fp' runIO $ BS.readFile fp' -- | Reads a file as a lazy ByteString. The path is specified relative -- to the package's root directory, and 'addDependentfile' is invoked on -- the target file. qReadFileLBS :: FilePath -> Q LBS.ByteString qReadFileLBS fp = do fp' <- pathRelativeToCabalPackage fp addDependentFile fp' runIO $ LBS.readFile fp' -- | Reads a file as a strict Text. The path is specified relative -- to the package's root directory, and 'addDependentfile' is invoked on -- the target file. qReadFileText :: FilePath -> Q T.Text qReadFileText fp = do fp' <- pathRelativeToCabalPackage fp addDependentFile fp' runIO $ T.readFile fp' -- | Reads a file as a lazy Text. The path is specified relative -- to the package's root directory, and 'addDependentfile' is invoked on -- the target file. qReadFileLazyText :: FilePath -> Q LT.Text qReadFileLazyText fp = do fp' <- pathRelativeToCabalPackage fp addDependentFile fp' runIO $ LT.readFile fp' -- | Reads a file as a String. The path is specified relative -- to the package's root directory, and 'addDependentfile' is invoked on -- the target file. qReadFileString :: FilePath -> Q String qReadFileString fp = do fp' <- pathRelativeToCabalPackage fp addDependentFile fp' runIO $ readFile fp' -- | Runs the 'Q' action, temporarily setting the current working -- directory to the root of the cabal package. withCabalPackageWorkDir :: Q a -> Q a withCabalPackageWorkDir f = do cwd' <- pathRelativeToCabalPackage "." cwd <- runIO $ getCurrentDirectory runIO $ setCurrentDirectory cwd' x <- f runIO $ setCurrentDirectory cwd return x -- | This utility takes a path that's relative to your package's cabal -- file, and resolves it to an absolute location. -- -- Note that this utility does _not_ invoke 'qAddDependentFile'. pathRelativeToCabalPackage :: FilePath -> Q FilePath pathRelativeToCabalPackage fp = do loc <- location parent <- if loc_filename loc == "" 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. findCabalFile :: FilePath -> IO (Maybe FilePath) findCabalFile dir = do let parent = takeDirectory dir contents <- getDirectoryContents parent case find (\fp -> takeExtension fp == ".cabal") contents of Nothing | parent == dir -> return Nothing | otherwise -> findCabalFile parent Just fp -> return (Just (parent fp)) th-utilities-0.2.5.0/src/TH/Utilities.hs0000644000000000000000000002042614312501526016102 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# 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 Control.Monad (foldM) import Data.Data import Data.Generics import Language.Haskell.TH import Language.Haskell.TH.Syntax import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndr_, tvName) import TH.FixQ (fixQ) -- | Get the 'Name' of a 'TyVarBndr' tyVarBndrName :: TyVarBndr_ flag -> Name tyVarBndrName = tvName 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. unAppsT :: Type -> [Type] unAppsT = go [] where go xs (AppT l x) = go (x : xs) l go xs ty = ty : xs -- | Given a list of types, produce the type of a tuple of -- those types. This is analogous to 'tupE' and 'tupP'. -- -- @ -- tupT [[t|Int|], [t|Char|], [t|Bool]] = [t| (Int, Char, Bool) |] -- @ -- -- @since FIXME tupT :: [Q Type] -> Q Type tupT ts = do -- We build the expression with a thunk inside that will be filled in with -- the length of the list once that's been determined. This works -- efficiently (in one pass) because TH.Type is rather lazy. (res, !_n) <- fixQ (\ ~(_res, n) -> foldM go (TupleT n, 0) ts) pure res where go (acc, !k) ty = do ty' <- ty pure (acc `AppT` ty', k + 1) -- | Given a list of types, produce the type of a promoted tuple of -- those types. This is analogous to 'tupE' and 'tupP'. -- -- @ -- promotedTupT [[t|3|], [t| 'True|], [t|Bool]] = [t| '(3, 'True, Bool) |] -- @ -- -- @since FIXME promotedTupT :: [Q Type] -> Q Type promotedTupT ts = do -- We build the expression with a thunk inside that will be filled in with -- the length of the list once that's been determined. This works -- efficiently (in one pass) because TH.Type is rather lazy. (res, !_n) <- fixQ (\ ~(_res, n) -> foldM go (PromotedTupleT n, 0) ts) pure res where go (acc, !k) ty = do ty' <- ty pure (acc `AppT` ty', k + 1) -- | Given a 'Type', returns a 'Just' value if it's a named type -- constructor applied to arguments. This value contains the name of the -- type and a list of arguments. typeToNamedCon :: Type -> Maybe (Name, [Type]) #if MIN_VERSION_template_haskell(2,11,0) typeToNamedCon (InfixT l n r) = Just (n, [l, r]) typeToNamedCon (UInfixT l n r) = Just (n, [l, r]) #endif typeToNamedCon (unAppsT -> (ConT n : args)) = Just (n, args) typeToNamedCon _ = Nothing -- | Expect the provided type to be an application of a regular type to -- one argument, otherwise fail with a message. This will also work if -- the name is a promoted data constructor ('PromotedT'). expectTyCon1 :: Name -> Type -> Q Type expectTyCon1 expected (AppT (ConT n) x) | expected == n = return x expectTyCon1 expected (AppT (PromotedT n) x) | expected == n = return x expectTyCon1 expected x = fail $ "Expected " ++ pprint expected ++ ", applied to one argument, but instead got " ++ pprint x ++ "." -- | Expect the provided type to be an application of a regular type to -- two arguments, otherwise fail with a message. This will also work if -- the name is a promoted data constructor ('PromotedT'). expectTyCon2 :: Name -> Type -> Q (Type, Type) expectTyCon2 expected (AppT (AppT (ConT n) x) y) | expected == n = return (x, y) expectTyCon2 expected (AppT (AppT (PromotedT n) x) y) | expected == n = return (x, y) #if MIN_VERSION_template_haskell(2,11,0) expectTyCon2 expected (InfixT x n y) | expected == n = return (x, y) expectTyCon2 expected (UInfixT x n y) | expected == n = return (x, y) #endif expectTyCon2 expected x = fail $ "Expected " ++ pprint expected ++ ", applied to two arguments, but instead got " ++ pprint x ++ "." -- | Given a type, construct the expression (Proxy :: Proxy ty). 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 dequalify = mkName . nameBase -- | Apply 'dequalify' to every type variable. dequalifyTyVars :: Data a => a -> a dequalifyTyVars = everywhere (id `extT` modifyType) where modifyType (VarT n) = VarT (dequalify n) modifyType ty = ty -- | Get the free type variables of a 'Type'. freeVarsT :: Type -> [Name] freeVarsT (ForallT tvs _ ty) = filter (`notElem` (map tyVarBndrName tvs)) (freeVarsT ty) freeVarsT (VarT n) = [n] freeVarsT ty = concat $ gmapQ (const [] `extQ` freeVarsT) ty -- | Utility to conveniently handle change to 'InstanceD' API in -- template-haskell-2.11.0 plainInstanceD :: Cxt -> Type -> [Dec] -> Dec plainInstanceD = #if MIN_VERSION_template_haskell(2,11,0) InstanceD Nothing #else InstanceD #endif -- | Utility to conveniently handle change to 'InstanceD' API in -- template-haskell-2.11.0 fromPlainInstanceD :: Dec -> Maybe (Cxt, Type, [Dec]) #if MIN_VERSION_template_haskell(2,11,0) fromPlainInstanceD (InstanceD _ a b c) = Just (a, b, c) #else 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 -- -- @ -- main = print $(lift [ExpLifter [e| 1 + 1 |], ExpLifter [e| 2 |]]) -- @ -- -- Here, 'lift' is working on a value of type @[ExpLifter]@. The code -- generated by 'lift' constructs a list with the 'ExpLifter' -- expressions providing the element values. -- -- Without 'ExpLifter', 'lift' tends to just generate code involving -- data construction. With 'ExpLifter', you can put more complicated -- expression into this construction. -- -- Note that this cannot be used in typed quotes, because 'liftTyped' -- will throw an exception. This is because this hack is incompatible -- with the type of 'liftTyped', as it would require the generated -- code to have type 'ExpLifter'. data ExpLifter = ExpLifter #if __GLASGOW_HASKELL__ >= 811 (forall m. Quote m => m Exp) #else ExpQ #endif deriving (Typeable) instance Lift ExpLifter where lift (ExpLifter e) = e #if MIN_VERSION_template_haskell(2,16,0) liftTyped = error $ concat [ "'liftTyped' is not implemented for 'ExpLifter', " , "because it would require the generated code to have type 'ExpLifter'" ] #endif -- | Print splices generated by a TH splice (the printing will happen -- during compilation, as a GHC warning). Useful for debugging. -- -- For instance, you can dump splices generated with 'makeLenses' by -- replacing a top-level invocation of 'makeLenses' in your code with: -- -- @dumpSplices $ makeLenses ''Foo@ dumpSplices :: DecsQ -> DecsQ dumpSplices x = do ds <- x let code = lines (pprint ds) reportWarning ("\n" ++ unlines (map (" " ++) code)) return ds th-utilities-0.2.5.0/src/TH/Derive/Internal.hs0000644000000000000000000000610414312501511017110 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE KindSignatures #-} module TH.Derive.Internal (Deriving, Deriver(..), Instantiator(..)) where import Data.Proxy (Proxy) import GHC.Exts (Constraint) import Language.Haskell.TH (Q, Dec, Cxt, Type) -- | This class has no instances. Its only purpose is usage within the -- @[d| ... |]@ quote provided to 'derive'. Usage such as @instance -- Deriving (Foo X)@ indicates that you would like to use the 'Deriver' -- registered for @Foo a@. class Deriving (cls :: Constraint) where -- Un-exported method, to prevent this class from being -- instantiated. _noInstances :: Proxy cls -- | Instances of 'Deriver' describe a default way of creating an -- instance for a particular typeclass. For example, if I wanted to -- write something that derives 'Eq' instances, I would write a -- @instance Deriver (Eq a)@. class Deriver (cls :: Constraint) where runDeriver :: Proxy cls -> Cxt -> Type -> Q [Dec] -- | Instances of 'Instantiator' are similar in purpose to instance of -- 'Deriver'. The difference is that instead of using the 'Deriving' -- class, each instantiator has its own new typeclass. This means that -- you can have multiple instantiators that all produce instances for -- the same typeclass, using different approaches. -- -- Having a new class also allows the instantiator to have methods and -- data / type family declarations. This allows the user to provide -- definitions which specify how the generated instances behave. For -- example, lets say we want to be able to directly define 'Eq' and -- 'Ord' instances via a conversion function to the type to compare. -- Here's what this currently looks like: -- -- @ -- class Ord o => InstEqOrdVia o a where -- _toOrd :: a -> o -- -- instance Instantiator (InstEqOrdVia o a) where -- runInstantiator _ preds (AppT (AppT (ConT ((== ''InstEqOrdVia) -> True)) _oTy) aTy) decls = -- dequalifyMethods ''InstEqOrdVia =<< -- sequence -- [instanceD (return preds) [t| Eq $(return aTy) |] $ -- [valD (varP '(==)) -- (normalB [| \l r -> _toOrd l == _toOrd r |]) -- (map return decls)] -- , instanceD (return preds) [t| Ord $(return aTy) |] $ -- [valD (varP 'compare) -- (normalB [| \l r -> compare (_toOrd l) (_toOrd r) |]) -- (map return decls) -- ] -- ] -- runInstantiator _ _ _ _ = -- fail "Theoretically impossible case in InstEqOrdVia instantiator" -- @ -- -- Why the underscore prefixing of @_toOrd@? It's to suppress name -- shadowing warnings which otherwise occur. In the future, this library -- will likely provide pretty ways to define instantiators. For now it's -- a bit ugly. -- -- Here's what usage of this looks like: -- -- @ -- data T = Y | Z -- -- $($(derive [d| -- instance InstEqOrdVia Bool T where -- _toOrd Y = True -- _toOrd Z = False -- |])) -- -- main = when (Y > Z) (putStrLn "It worked!!") -- @ class Instantiator (inst :: Constraint) where runInstantiator :: Proxy inst -> Cxt -> Type -> [Dec] -> Q [Dec] th-utilities-0.2.5.0/test/Main.hs0000644000000000000000000000005414312501511014655 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} th-utilities-0.2.5.0/test/TH/Derive/StorableSpec.hs0000644000000000000000000000214314312501511020111 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH.Derive.StorableSpec (spec) where import Control.Monad (when) import Data.Int import qualified Data.Vector.Storable as SV import Foreign.Storable import TH.Derive import TH.Derive.Storable () import Test.Hspec data ADataType = Con0 | Con1 Int32 | Con2 Int32 Int64 deriving (Eq, Show) $($(derive [d| instance Deriving (Storable ADataType) |])) spec :: Spec spec = describe "th-storable" $ it "can roundtrip a data type" $ do roundTrips Con0 roundTrips (Con1 minBound) roundTrips (Con1 0) roundTrips (Con1 maxBound) roundTrips (Con2 maxBound minBound) roundTrips (Con2 maxBound 0) roundTrips (Con2 maxBound maxBound) roundTrips :: (Storable a, Show a, Eq a) => a -> IO () roundTrips x = when (SV.head (SV.singleton x) /= x) $ fail ("Failed to roundtrip " ++ show x) -- Regression test for generating peek on single-constructor data types. data SingleCons = SingleCons $($(derive [d| instance Deriving (Storable SingleCons) |])) th-utilities-0.2.5.0/test/TH/DeriveSpec.hs0000644000000000000000000000146614312501511016345 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ViewPatterns #-} module TH.DeriveSpec (spec) where import TH.Derive import TH.DeriveSpec.TH import Test.Hspec data Foo = Foo data X = X data T = Y | Z $($(derive [d| instance InstShowBlind Foo instance InstShowConst X where _constResult _ = "wow!" instance InstEqOrdVia Bool T where _toOrd Y = True _toOrd Z = False |])) spec :: SpecWith () spec = describe "Instantiators" $ do it "InstShowBlind" $ do show Foo `shouldBe` "ShowBlind" it "InstShowConst" $ do show X `shouldBe` "wow!" it "InstEqOrdVia" $ do (Y == Z) `shouldBe` False (Y > Z) `shouldBe` True (Z == Z) `shouldBe` True th-utilities-0.2.5.0/test/TH/DeriveSpec/TH.hs0000644000000000000000000000375314312501511016661 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiParamTypeClasses #-} module TH.DeriveSpec.TH where import Data.Proxy import Language.Haskell.TH import TH.Derive import TH.Utilities class InstShowBlind a instance Instantiator (InstShowBlind a) where runInstantiator _ preds (AppT (ConT ((== ''InstShowBlind) -> True)) ty) []= do expr <- [| \_ -> "ShowBlind" |] return [plainInstanceD preds (AppT (ConT ''Show) ty) [ValD (VarP 'show) (NormalB expr) []]] runInstantiator _ _ _ _ = fail "Theoretically impossible case in InstShowBlind instantiator for Show" class InstShowConst a where _constResult :: Proxy a -> String instance Instantiator (InstShowConst a) where runInstantiator _ preds (AppT (ConT ((== ''InstShowConst) -> True)) ty) decls = dequalifyMethods ''InstShowConst =<< sequence [do headTy <- [t| Show $(return ty) |] method <- valD (varP 'show) (normalB [| \_ -> _constResult undefined |]) (map return decls) return (plainInstanceD preds headTy [method])] runInstantiator _ _ _ _ = fail "Theoretically impossible case in InstShowConst instantiator for Show" class Ord o => InstEqOrdVia o a where _toOrd :: a -> o instance Instantiator (InstEqOrdVia o a) where runInstantiator _ preds (AppT (AppT (ConT ((== ''InstEqOrdVia) -> True)) _oTy) aTy) decls = dequalifyMethods ''InstEqOrdVia =<< sequence [instanceD (return preds) [t| Eq $(return aTy) |] $ [valD (varP '(==)) (normalB [| \l r -> _toOrd l == _toOrd r |]) (map return decls)] , instanceD (return preds) [t| Ord $(return aTy) |] $ [valD (varP 'compare) (normalB [| \l r -> compare (_toOrd l) (_toOrd r) |]) (map return decls) ] ] runInstantiator _ _ _ _ = fail "Theoretically impossible case in InstEqOrdVia instantiator" th-utilities-0.2.5.0/LICENSE0000644000000000000000000000205414312501511013465 0ustar0000000000000000Copyright (c) 2016 FP Complete Corporation. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. th-utilities-0.2.5.0/Setup.hs0000644000000000000000000000005614312501511014114 0ustar0000000000000000import Distribution.Simple main = defaultMain th-utilities-0.2.5.0/th-utilities.cabal0000644000000000000000000000350414312503225016075 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack name: th-utilities version: 0.2.5.0 synopsis: Collection of useful functions for use with Template Haskell category: Template Haskell homepage: https://github.com/fpco/th-utilities#readme bug-reports: https://github.com/fpco/th-utilities/issues maintainer: Michael Sloan copyright: 2016 FP Complete license: MIT license-file: LICENSE build-type: Simple extra-source-files: README.md ChangeLog.md source-repository head type: git location: https://github.com/fpco/th-utilities library exposed-modules: TH.Derive TH.Derive.Storable TH.FixQ TH.ReifySimple TH.RelativePaths TH.Utilities other-modules: TH.Derive.Internal hs-source-dirs: src ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates build-depends: base >=4.7 && <5 , bytestring , containers , directory , filepath , primitive , syb , template-haskell >=2.7 , text , th-abstraction >=0.4 , th-orphans default-language: Haskell2010 test-suite test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: TH.Derive.StorableSpec TH.DeriveSpec TH.DeriveSpec.TH Paths_th_utilities hs-source-dirs: test ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates build-depends: base >=4.7 && <5 , bytestring , containers , directory , filepath , hspec , primitive , syb , template-haskell >=2.7 , text , th-abstraction >=0.4 , th-orphans , th-utilities , vector default-language: Haskell2010 th-utilities-0.2.5.0/README.md0000644000000000000000000000306014312501511013735 0ustar0000000000000000# th-utilities [![Build Status](https://travis-ci.org/commercialhaskell/th-utilities.svg?branch=master)](https://travis-ci.org/fpco/th-utilities) The 'th-utilities' package provides a number of useful utilities for [Template Haskell](https://hackage.haskell.org/package/template-haskell-2.10.0.0). In particular: * [`TH.Derive`](https://github.com/fpco/th-utilities/blob/master/src/TH/Derive.hs) provides a convenient system for using TH to derive typeclass instances. It allows for open registration of TH derivers, and reuses instance syntax for invoking them. - [`TH.Derive.Storable`](https://github.com/fpco/th-utilities/blob/master/src/TH/Derive/Storable.hs) defines derivation of Storable for ADTs. * [`TH.ReifyDataType`](https://github.com/fpco/th-utilities/blob/master/src/TH/ReifyDataType.hs) provides utilities for reifying simplified datatype info. It omits details that you don't usually want to handle, making it much more straightforward to generate code based on datatype structure. * [`TH.RelativePaths`](https://github.com/fpco/th-utilities/blob/master/src/TH/RelativePaths.hs) provides utilities for loading files based on paths relative to the cabal file. This is particularly handy for loading code into ghci even when its current dir isn't the package dir. Ideally, this module would be used by everyone who currently uses `qAddDependentFile`. * [`TH.Utilities`](https://github.com/fpco/th-utilities/blob/master/src/TH/Utilities.hs) provides a miscellaneous set of utilities that are useful within this package and elsewhere. th-utilities-0.2.5.0/ChangeLog.md0000644000000000000000000000322714312503176014645 0ustar0000000000000000# ChangeLog ## 0.2.5.0 * Adds `tupT` and `promotedTupT`. * Adds `TH.FixQ.fixQ`, a compatibility shim to provide fixQ for `template-haskell <= 2.17` (`ghc <= 9.0.1`). ## 0.2.4.3 * Adds a lower bound for `th-abstraction` dependency. Also released as a hackage revision of `0.2.4.2`. See [#15][] [#15]: https://github.com/fpco/th-utilities/issues/15 ## 0.2.4.2 * Fixes compilation with `GHC-9.0.*`. See [#14][] [#14]: https://github.com/fpco/th-utilities/issues/14 ## 0.2.4.1 * Fixes generated Storable instances to have a `sizeOf` definition which works with `-XStrict`. See [#13][] [#13]: https://github.com/fpco/th-utilities/issues/13 ## 0.2.4.0 * Compatibility with GHC-8.10 * Behavior change in reification of type family instances. Instead of erroring if the instance mentions a kind variable, now just ignores it. ## 0.2.3.1 * Compatibility with GHC-8.8 ## 0.2.3.0 * Improved fix to the type variable behavior with GHC <= 7.10. Uses `Any` in place of type variables instead of `()`, to allow for more kinds than just `*` and `Constraint`. ## 0.2.2.0 * Fixes derive and instantiator mechanisms to work with ghc 7.10 and earlier. Previously, invocation was broken when type variables were used. * Fixes `freeVarsT` - it now looks through more constructors of `Type`. * Adds `dequalifyTyVars` to dequalify every type variable. ## 0.2.0.1 * Fixes build on 7.8 * Fixes warnings ## 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