packages feed

th-utilities (empty) → 0.1.0.0

raw patch · 14 files changed

+819/−0 lines, 14 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, directory, filepath, hspec, primitive, syb, template-haskell, text, th-orphans, th-utilities, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# ChangeLog++## 0.1.0.0++* First public release
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/TH/Derive.hs view
@@ -0,0 +1,128 @@+{-# 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 exmaple, "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+-- <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>.+--+-- * 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 ()++--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+    toStmt (varName, InstanceD preds (AppT (ConT ((== ''Deriving) -> True)) cls) []) =+        bindS (varP varName)+              [e| runDeriver $(proxyE (return cls))+                             preds+                             cls |]+    toStmt (varName, InstanceD preds ty decs) =+        bindS (varP varName)+              [e| runInstantiator $(proxyE (return ty))+                                  preds+                                  ty+                                  decs |]+    toStmt (_, decl) = fail $+        "Expected deriver instance, instead got:\n" +++        show decl++-- | 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+-}
+ src/TH/Derive/Internal.hs view
@@ -0,0 +1,36 @@+{-# 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 :: 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 instance behaves.+class Instantiator (inst :: Constraint) where+    runInstantiator :: Proxy inst -> Cxt -> Type -> [Dec] -> Q [Dec]
+ src/TH/Derive/Storable.hs view
@@ -0,0 +1,142 @@+{-# 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.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           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+    argTy <- expectTyCon1 ''Storable ty+    dt <- reifyDataTypeSubstituted argTy+    makeStorableImpl cxt 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+    -- 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 [WildP] (NormalB sizeOfMethod) []]+            , FunD (mkName "peek") [Clause [VarP ptrName] (NormalB peekMethod) []]+            , FunD (mkName "poke") [Clause [VarP ptrName, VarP valName] (NormalB pokeMethod) []]+            ]+    return [InstanceD cxt 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 'maximum) $+        listE [ appE (varE 'sum) (listE [sizeOfExpr ty | (_, ty) <- fields])+              | (DataCon cname _ _ 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 (doE (tagPokes ++ offsetLet ++ fieldPokes)))+              []+      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)
+ src/TH/ReifyDataType.hs view
@@ -0,0 +1,109 @@+{-# 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           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 cxt name vars _kind cons _deriving) -> do+#else+        TyConI (DataD cxt name vars cons _deriving) -> do+#endif+            let tvs = map tyVarBndrName vars+                cs = concatMap conToDataCons cons+            return (DataType name tvs cxt cs)+#if MIN_VERSION_template_haskell(2,11,0)+        TyConI (NewtypeD cxt name vars _kind con _deriving) -> do+#else+        TyConI (NewtypeD cxt name vars con _deriving) -> do+#endif+            let tvs = map tyVarBndrName vars+                cs = conToDataCons con+            return (DataType name tvs cxt 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/RelativePaths.hs view
@@ -0,0 +1,111 @@+{-# 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 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, doesFileExist)+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+    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)++-- | 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))
+ src/TH/Utilities.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++-- | Miscellaneous Template Haskell utilities, added as needed by+-- packages in the th-utilities repo and elsewhere.+module TH.Utilities where++import Data.Proxy+import Data.Typeable+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++-- | Get the 'Name' of a 'TyVarBndr'+tyVarBndrName :: TyVarBndr -> Name+tyVarBndrName (PlainTV n) = n+tyVarBndrName (KindedTV n _) = n++-- | 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 '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 r) | expected == n = return (x, y)+expectTyCon2 expected (UInfixT x n r) | 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) |]++-- | 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++-- | Get the free type variables of a 'Type'.+freeVarsT :: Type -> [Name]+freeVarsT (ForallT tvs _ ty) = filter (`notElem` (map tyVarBndrName tvs)) (freeVarsT ty)+freeVarsT (AppT l r) = freeVarsT l ++ freeVarsT r+freeVarsT (SigT ty k) = freeVarsT ty ++ freeVarsT k+freeVarsT (VarT n) = [n]+#if MIN_VERSION_template_haskell(2,11,0)+freeVarsT (InfixT x n r) = freeVarsT x ++ freeVarsT y+freeVarsT (UInfixT x n r) = freeVarsT x ++ freeVarsT y+#endif+freeVarsT _ = []++-- | 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 |]])+-- @+--+-- Without 'ExpLifter', 'lift' tends to just generate code involving+-- data construction. With 'ExpLifter', you can put more complicated+-- expression into this construction.+data ExpLifter = ExpLifter ExpQ deriving (Typeable)++instance Lift ExpLifter where+  lift (ExpLifter e) = e
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TH/Derive/StorableSpec.hs view
@@ -0,0 +1,35 @@+{-# 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)
+ test/TH/DeriveSpec.hs view
@@ -0,0 +1,37 @@+{-# 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 Y = Y | Z++$($(derive [d|+  instance InstShowBlind Foo++  instance InstShowConst X where+      constResult _ = "wow!"++  instance InstEqBy Y Bool where+      toEq Y = True+      toEq Z = False+  |]))++spec = describe "Instantiators" $ do+    it "InstShowBlind" $ do+        show Foo `shouldBe` "ShowBlind"+    it "InstShowConst" $ do+        show X `shouldBe` "wow!"+    it "InstEqBy" $ do+        (Y == Z) `shouldBe` False+        (Z == Z) `shouldBe` True
+ test/TH/DeriveSpec/TH.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module TH.DeriveSpec.TH where++import TH.Derive+import Language.Haskell.TH+import Data.Proxy++class InstShowBlind a++instance Instantiator (InstShowBlind a) where+    runInstantiator _ preds (AppT (ConT ((== ''InstShowBlind) -> True)) ty)  []= do+        expr <- [| \_ -> "ShowBlind" |]+        return [InstanceD 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+        [ instanceD (return preds) [t| Show $(return ty) |] $+            [valD (varP 'show)+                  (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++instance Instantiator (InstEqBy a b) where+    runInstantiator _ preds (AppT (AppT (ConT ((== ''InstEqBy) -> True)) aTy) bTy) decls =+        dequalifyMethods ''InstEqBy =<<+        sequence+        [ instanceD (return preds) [t| Eq $(return aTy) |] $+            [valD (varP '(==))+                  (normalB [| \l r -> toEq l == toEq r |])+                  (map return decls)]+        ]
+ th-utilities.cabal view
@@ -0,0 +1,52 @@+name:                th-utilities+version:             0.1.0.0+synopsis:            Collection of useful functions for use with Template Haskell+description:         Please see README.md+homepage:            https://github.com/fpco/th-utilities#readme+license:             MIT+license-file:        LICENSE+author:              Michael Sloan+maintainer:          sloan@fpcomplete.com+copyright:           2016 FP Complete+category:            Template Haskell+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++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++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