diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# ChangeLog + +## 0.1.0.0 + +* First public release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/TH/Derive.hs b/src/TH/Derive.hs new file mode 100644 --- /dev/null +++ b/src/TH/Derive.hs @@ -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 +-- . 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 () + +--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 +-} diff --git a/src/TH/Derive/Internal.hs b/src/TH/Derive/Internal.hs new file mode 100644 --- /dev/null +++ b/src/TH/Derive/Internal.hs @@ -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] diff --git a/src/TH/Derive/Storable.hs b/src/TH/Derive/Storable.hs new file mode 100644 --- /dev/null +++ b/src/TH/Derive/Storable.hs @@ -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) diff --git a/src/TH/ReifyDataType.hs b/src/TH/ReifyDataType.hs new file mode 100644 --- /dev/null +++ b/src/TH/ReifyDataType.hs @@ -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 diff --git a/src/TH/RelativePaths.hs b/src/TH/RelativePaths.hs new file mode 100644 --- /dev/null +++ b/src/TH/RelativePaths.hs @@ -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)) diff --git a/src/TH/Utilities.hs b/src/TH/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/TH/Utilities.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TH/Derive/StorableSpec.hs b/test/TH/Derive/StorableSpec.hs new file mode 100644 --- /dev/null +++ b/test/TH/Derive/StorableSpec.hs @@ -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) diff --git a/test/TH/DeriveSpec.hs b/test/TH/DeriveSpec.hs new file mode 100644 --- /dev/null +++ b/test/TH/DeriveSpec.hs @@ -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 diff --git a/test/TH/DeriveSpec/TH.hs b/test/TH/DeriveSpec/TH.hs new file mode 100644 --- /dev/null +++ b/test/TH/DeriveSpec/TH.hs @@ -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)] + ] diff --git a/th-utilities.cabal b/th-utilities.cabal new file mode 100644 --- /dev/null +++ b/th-utilities.cabal @@ -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