diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 --- a/ChangeLog.md +++ /dev/null @@ -1,5 +0,0 @@ -# ChangeLog - -## 0.1.0.0 - -* First public release diff --git a/src/TH/Derive.hs b/src/TH/Derive.hs --- a/src/TH/Derive.hs +++ b/src/TH/Derive.hs @@ -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 --- . We don't have pretty ways of writing these quite yet, but +-- . +-- We don't have pretty ways of writing these quite yet, but -- I have worked on something -- . -- diff --git a/src/TH/Derive/Internal.hs b/src/TH/Derive/Internal.hs --- a/src/TH/Derive/Internal.hs +++ b/src/TH/Derive/Internal.hs @@ -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] diff --git a/src/TH/Derive/Storable.hs b/src/TH/Derive/Storable.hs --- a/src/TH/Derive/Storable.hs +++ b/src/TH/Derive/Storable.hs @@ -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)) diff --git a/src/TH/ReifyDataType.hs b/src/TH/ReifyDataType.hs --- a/src/TH/ReifyDataType.hs +++ b/src/TH/ReifyDataType.hs @@ -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 diff --git a/src/TH/RelativePaths.hs b/src/TH/RelativePaths.hs --- a/src/TH/RelativePaths.hs +++ b/src/TH/RelativePaths.hs @@ -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 diff --git a/src/TH/Utilities.hs b/src/TH/Utilities.hs --- a/src/TH/Utilities.hs +++ b/src/TH/Utilities.hs @@ -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 diff --git a/test/TH/DeriveSpec.hs b/test/TH/DeriveSpec.hs --- a/test/TH/DeriveSpec.hs +++ b/test/TH/DeriveSpec.hs @@ -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 diff --git a/test/TH/DeriveSpec/TH.hs b/test/TH/DeriveSpec/TH.hs --- a/test/TH/DeriveSpec/TH.hs +++ b/test/TH/DeriveSpec/TH.hs @@ -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" diff --git a/th-utilities.cabal b/th-utilities.cabal --- a/th-utilities.cabal +++ b/th-utilities.cabal @@ -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 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