th-utilities 0.1.0.0 → 0.1.0.1
raw patch · 10 files changed
+155/−83 lines, 10 filesdep ~basedep ~template-haskell
Dependency ranges changed: base, template-haskell
Files
- ChangeLog.md +0/−5
- src/TH/Derive.hs +2/−2
- src/TH/Derive/Internal.hs +46/−2
- src/TH/Derive/Storable.hs +10/−12
- src/TH/ReifyDataType.hs +7/−6
- src/TH/RelativePaths.hs +1/−1
- src/TH/Utilities.hs +5/−0
- test/TH/DeriveSpec.hs +8/−6
- test/TH/DeriveSpec/TH.hs +17/−9
- th-utilities.cabal +59/−40
− ChangeLog.md
@@ -1,5 +0,0 @@-# ChangeLog--## 0.1.0.0--* First public release
src/TH/Derive.hs view
@@ -41,8 +41,8 @@ -- * 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--- <https://ghc.haskell.org/trac/ghc/wiki/InstanceTemplates Instance--- Templates>. We don't have pretty ways of writing these quite yet, but+-- <https://ghc.haskell.org/trac/ghc/wiki/InstanceTemplates Instance Templates>.+-- We don't have pretty ways of writing these quite yet, but -- I have worked on something -- <https://github.com/mgsloan/instance-templates similar in the past>. --
src/TH/Derive/Internal.hs view
@@ -14,7 +14,7 @@ class Deriving (cls :: Constraint) where -- Un-exported method, to prevent this class from being -- instantiated.- noInstances :: cls => ()+ _noInstances :: cls => () -- | Instances of 'Deriver' describe a default way of creating an -- instance for a particular typeclass. For example, if I wanted to@@ -31,6 +31,50 @@ -- -- 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 instance behaves.+-- 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]
src/TH/Derive/Storable.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-}@@ -16,38 +17,35 @@ ( makeStorableInst ) where +import Control.Applicative import Control.Monad-import Data.Data (Data, gmapT)-import Data.Generics.Aliases (extT) import Data.List (find)-import qualified Data.Map as M import Data.Maybe (fromMaybe)-import Data.Primitive.Types (Prim(..))-import Data.Typeable 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.ReifyDataType import TH.Utilities-import TH.Derive.Internal instance Deriver (Storable a) where runDeriver _ = makeStorableInst -- | Implementation used for 'runDeriver'. makeStorableInst :: Cxt -> Type -> Q [Dec]-makeStorableInst cxt ty = do+makeStorableInst preds ty = do argTy <- expectTyCon1 ''Storable ty dt <- reifyDataTypeSubstituted argTy- makeStorableImpl cxt ty (dtCons dt)+ 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 cxt headTy cons = do+makeStorableImpl preds headTy cons = do -- Since this instance doesn't pay attention to alignment, we -- just say alignment doesn't matter. alignmentMethod <- [| 1 |]@@ -60,7 +58,7 @@ , FunD (mkName "peek") [Clause [VarP ptrName] (NormalB peekMethod) []] , FunD (mkName "poke") [Clause [VarP ptrName, VarP valName] (NormalB pokeMethod) []] ]- return [InstanceD cxt headTy methods]+ return [InstanceD 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.@@ -85,7 +83,7 @@ -- constructor. sizeExpr = appE (varE 'maximum) $ listE [ appE (varE 'sum) (listE [sizeOfExpr ty | (_, ty) <- fields])- | (DataCon cname _ _ fields) <- cons+ | (DataCon _ _ _ fields) <- cons ] -- Choose a tag size large enough for this constructor count. -- Expression used for the definition of peek.@@ -139,4 +137,4 @@ 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)+ offset ix = mkName ("offset" ++ show (ix :: Int))
src/TH/ReifyDataType.hs view
@@ -20,6 +20,7 @@ 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@@ -48,21 +49,21 @@ info <- reify queryName case info of #if MIN_VERSION_template_haskell(2,11,0)- TyConI (DataD cxt name vars _kind cons _deriving) -> do+ TyConI (DataD preds name vars _kind cons _deriving) -> do #else- TyConI (DataD cxt name vars cons _deriving) -> do+ TyConI (DataD preds name vars cons _deriving) -> do #endif let tvs = map tyVarBndrName vars cs = concatMap conToDataCons cons- return (DataType name tvs cxt cs)+ return (DataType name tvs preds cs) #if MIN_VERSION_template_haskell(2,11,0)- TyConI (NewtypeD cxt name vars _kind con _deriving) -> do+ TyConI (NewtypeD preds name vars _kind con _deriving) -> do #else- TyConI (NewtypeD cxt name vars con _deriving) -> do+ TyConI (NewtypeD preds name vars con _deriving) -> do #endif let tvs = map tyVarBndrName vars cs = conToDataCons con- return (DataType name tvs cxt cs)+ 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
src/TH/RelativePaths.hs view
@@ -24,7 +24,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, doesFileExist)+import System.Directory (getDirectoryContents, getCurrentDirectory, setCurrentDirectory) import System.FilePath -- | Reads a file as a strict ByteString. The path is specified relative
src/TH/Utilities.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-} -- | Miscellaneous Template Haskell utilities, added as needed by -- packages in the th-utilities repo and elsewhere.@@ -87,6 +88,10 @@ -- @ -- 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
test/TH/DeriveSpec.hs view
@@ -14,24 +14,26 @@ data X = X -data Y = Y | Z+data T = Y | Z $($(derive [d| instance InstShowBlind Foo instance InstShowConst X where- constResult _ = "wow!"+ _constResult _ = "wow!" - instance InstEqBy Y Bool where- toEq Y = True- toEq Z = False+ 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 "InstEqBy" $ do+ it "InstEqOrdVia" $ do (Y == Z) `shouldBe` False+ (Y > Z) `shouldBe` True (Z == Z) `shouldBe` True
test/TH/DeriveSpec/TH.hs view
@@ -17,7 +17,7 @@ runInstantiator _ _ _ _ = fail "Theoretically impossible case in InstShowBlind instantiator for Show" -class InstShowConst a where constResult :: Proxy a -> String+class InstShowConst a where _constResult :: Proxy a -> String instance Instantiator (InstShowConst a) where runInstantiator _ preds (AppT (ConT ((== ''InstShowConst) -> True)) ty) decls =@@ -25,20 +25,28 @@ sequence [ instanceD (return preds) [t| Show $(return ty) |] $ [valD (varP 'show)- (normalB [| \_ -> constResult undefined |])+ (normalB [| \_ -> _constResult undefined |]) (map return decls)]] runInstantiator _ _ _ _ = fail "Theoretically impossible case in InstShowConst instantiator for Show" -class Eq b => InstEqBy a b where- toEq :: a -> b+class Ord o => InstEqOrdVia o a where+ _toOrd :: a -> o -instance Instantiator (InstEqBy a b) where- runInstantiator _ preds (AppT (AppT (ConT ((== ''InstEqBy) -> True)) aTy) bTy) decls =- dequalifyMethods ''InstEqBy =<<+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) |] $+ [instanceD (return preds) [t| Eq $(return aTy) |] $ [valD (varP '(==))- (normalB [| \l r -> toEq l == toEq r |])+ (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.cabal view
@@ -1,52 +1,71 @@+-- This file has been generated from package.yaml by hpack version 0.13.0.+--+-- see: https://github.com/sol/hpack+ name: th-utilities-version: 0.1.0.0+version: 0.1.0.1 synopsis: Collection of useful functions for use with Template Haskell-description: Please see README.md homepage: https://github.com/fpco/th-utilities#readme+bug-reports: https://github.com/fpco/th-utilities/issues license: MIT license-file: LICENSE-author: Michael Sloan-maintainer: sloan@fpcomplete.com+maintainer: Michael Sloan <sloan@fpcomplete.com> copyright: 2016 FP Complete category: Template Haskell build-type: Simple-extra-source-files: ChangeLog.md-cabal-version: >=1.10+cabal-version: >= 1.10 +source-repository head+ type: git+ location: https://github.com/fpco/th-utilities+ library- hs-source-dirs: src- exposed-modules: TH.Derive- TH.Derive.Storable- TH.ReifyDataType- TH.RelativePaths- TH.Utilities- other-modules: TH.Derive.Internal- build-depends: base >= 4.7 && < 5,- bytestring,- containers,- directory,- filepath,- primitive,- syb,- template-haskell >= 2.7,- text,- th-orphans- default-language: Haskell2010+ 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-orphans+ exposed-modules:+ TH.Derive+ TH.Derive.Storable+ TH.ReifyDataType+ TH.RelativePaths+ TH.Utilities+ other-modules:+ TH.Derive.Internal+ default-language: Haskell2010 test-suite test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Main.hs- other-modules: TH.Derive.StorableSpec,- TH.DeriveSpec,- TH.DeriveSpec.TH- build-depends: base,- hspec,- template-haskell,- th-utilities,- vector- default-language: Haskell2010--source-repository head- type: git- location: https://github.com/fpco/th-utilities+ type: exitcode-stdio-1.0+ main-is: Main.hs+ 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,+ primitive,+ syb,+ template-haskell >= 2.7,+ text,+ th-orphans,+ th-utilities,+ hspec,+ vector+ other-modules:+ TH.Derive.StorableSpec+ TH.DeriveSpec+ TH.DeriveSpec.TH+ default-language: Haskell2010