diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for the [`beam-th` package](http://hackage.haskell.org/package/beam-th) + +## 0.1.0.0 *June 2016* + + * Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright 2016 Tobias Markus +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +(Completely optional) Template Haskell functions +to derive common boilerplate code when writing table types +for the [beam](https://hackage.haskell.org/package/beam) library. 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/beam-th.cabal b/beam-th.cabal new file mode 100644 --- /dev/null +++ b/beam-th.cabal @@ -0,0 +1,77 @@ +name: beam-th +version: 0.1.0.0 +synopsis: Template Haskell utilities for beam +description: + (Completely optional) Template Haskell functions + to derive common boilerplate code when writing table types + for the library. +license: BSD3 +license-file: LICENSE +category: Database, Template Haskell +extra-source-files: README.md CHANGELOG.md +author: Tobias Markus +maintainer: Tobias Markus +copyright: Copyright 2016 Tobias Markus +homepage: https://github.com/hesiod/beam-th +bug-reports: https://github.com/hesiod/beam-th/issues +build-type: Simple +cabal-version: >=1.18 +stability: Experimental + +source-repository head + type: git + location: https://github.com/hesiod/beam-th.git + +library + default-language: Haskell2010 + ghc-options: -Wall -Wcompat + hs-source-dirs: src + exposed-modules: Database.Beam.TH + other-modules: Database.Beam.TH.Internal + other-extensions: StandaloneDeriving + , GeneralizedNewtypeDeriving + , DeriveGeneric + , TypeSynonymInstances + , FlexibleInstances + , FlexibleContexts + , TypeFamilies + , LambdaCase + , TemplateHaskell + build-depends: base >= 4.9 && < 4.10 + , template-haskell >= 2.11 && < 2.12 + , th-expand-syns >= 0.4 && < 0.5 + , transformers >= 0.5 && < 0.6 + , mtl >= 2.2 && < 2.3 + , beam >= 0.3 && < 0.5 + +test-suite test-beam-th + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -Wall -Wcompat + hs-source-dirs: test + main-is: Test.hs + other-modules: TestData + other-extensions: StandaloneDeriving + , DeriveGeneric + , TypeSynonymInstances + , FlexibleInstances + , FlexibleContexts + , TypeFamilies + , TemplateHaskell + build-depends: base + , beam-th + , beam >= 0.3 && < 0.5 + , text >= 1.0 && < 1.3 + , template-haskell >= 2.11 && < 2.12 + , tasty >= 0.8 && < 0.12 + , tasty-hunit >= 0.9 && < 0.10 + +test-suite doctest-beam-th + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -Wall -Wcompat -threaded + HS-Source-Dirs: test + main-is: DoctestDriver.hs + build-depends: base + , doctest >= 0.11 && < 0.12 + , doctest-discover >= 0.1 && < 0.2 diff --git a/src/Database/Beam/TH.hs b/src/Database/Beam/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/TH.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE TemplateHaskell, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase #-} +-- | Functions to derive common boilerplate code when writing table types for the +-- library. Only use them if you what you're doing. +module Database.Beam.TH (makeTable, makeTable') where + +import Control.Monad ((>=>), forM) +import Control.Monad.Identity (Identity) +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.Writer (WriterT, execWriterT) +import GHC.Generics (Generic) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax hiding (lift) +import Language.Haskell.TH.ExpandSyns + +import Database.Beam (Table, TableField, Columnar, PrimaryKey, primaryKey, tableConfigLenses, LensFor) + +import Database.Beam.TH.Internal + +{-# INLINE getColTy #-} +getColTy :: Type -> Q Name +getColTy (AppT (AppT (ConT _) (VarT _)) (ConT tyInner)) = pure tyInner +getColTy _ = invalidConstructor + +primaryKeyTy, primaryKeyFun :: WriterT [Dec] (MakeTableT Q) () +primaryKeyTy = do + (_, str, ty) <- vst + nmT <- nameT + nmI <- nameId + f <- lift . lift $ newName "f" + cty <- lift . lift $ getColTy ty + let primaryKeyTyRHS = pure (str, ConT ''Columnar <~> VarT f <~> ConT cty) + tellD $ DataInstD [] ''PrimaryKey [ConT nmT, VarT f] Nothing [NormalC nmI primaryKeyTyRHS] [ConT ''Generic] +primaryKeyFun = do + (pk, _, _) <- vst + nmI <- nameId + x <- lift . lift $ newName "x" + tellD . FunD 'primaryKey . pure $ Clause [VarP x] (NormalB (ConE nmI <+> (VarE pk <+> VarE x))) [] +nameInst, nameTySyn, nameIdTySyn, nameLens :: MakeTableT'' +nameInst = do + nmT <- nameT + decs <- execWriterT $ primaryKeyTy >> primaryKeyFun + tellD $ InstanceD Nothing [] (ConT ''Table <~> ConT nmT) decs +nameTySyn = do + nm <- name + nmT <- nameT + tellD . TySynD nm [] $ ConT nmT <~> ConT ''Identity + tellD . StandaloneDerivD [] $ ConT ''Show <~> ConT nm +nameIdTySyn = do + nmT <- nameT + nmId <- nameId + nmId' <- nameId' + f <- lift $ newName "f" + tellD . TySynD nmId [KindedTV f (StarT ~> StarT)] $ ConT ''PrimaryKey <~> ConT nmT <~> VarT f + tellD . TySynD nmId' [] $ ConT nmId <~> ConT ''Identity + tellD . StandaloneDerivD [] $ ConT ''Show <~> ConT nmId' +nameLens = do + nm <- name + nmT <- nameT +-- Lens' (AdT (TableField AdT)) (TableField AdT _) + (TyConI (DataD _ _ _ _ (RecC _ vsts:_) _)) <- lift $ reify nmT + let fields = fmap renameFields vsts + fields' <- forM fields (\(x, t) -> lift (opportunisticExpand t) >>= \case + AppT (AppT (ConT test) (ConT _)) _ | test == ''PrimaryKey -> do + tellD . SigD x $ ConT lens' <~> (ConT nmT <~> (ConT ''TableField <~> ConT nmT)) + <~> (ConT ''TableField <~> ConT nmT <~> WildCardT) + c <- lift . extractCon $ t + pure . ConP c . pure . ConP ''LensFor . pure . VarP $ x + _ -> pure . ConP ''LensFor . pure $ VarP x) + tellD $ ValD (ConP nm fields') (NormalB (VarE 'tableConfigLenses)) [] + where + renameFields (cname, _, t) = (rename (++ "C") cname, t) + lens' = mkName "Lens'" + extractCon (AppT (ConT c) _) = pure c + extractCon (AppT (AppT _ (ConT c)) _) = pure . rename (++ "Id") =<< baseName c + extractCon x = error $ "Unknown cross-table reference '" ++ pprint x ++ "'; use PrimaryKey OtherTableT f or the synonymous OtherTableId f" + -- To circumvent th-expand-syns: WARNING: Type synonym families (and associated type synonyms) are currently not supported (they won't be expanded). Name of unsupported family: Database.Beam.Schema.Tables.Columnar + opportunisticExpand t@(AppT (AppT (ConT x) _ ) _) | x == ''Columnar = pure t + opportunisticExpand x = expandSyns x + +baseName :: Name -> Q Name +baseName nmT = do + let nbT = nameBase nmT + len = length nbT + assertMany [ + (len >= 3, "Too short"), + (last nbT == 'T', "Table name does not end with 'T'") + ] + pure . mkName . take (pred len) $ nbT + +makeTableWithType :: Name -> VarStrictType -> DecsQ +makeTableWithType nmT v = do + nm <- baseName nmT + fmap concat . mapM (runTableT nm v) $ [nameTySyn, nameInst, nameIdTySyn, nameLens] + +recordFields :: Info -> [VarBangType] +recordFields (TyConI (DataD _ _ _ _ (RecC _ x:_) _)) = x +recordFields _ = invalidConstructor + +-- | Derives boilerplate code for beam table types. +-- +-- 'makeTable' is equivalent to 'makeTable'' except that 'makeTable' takes a second argument, +-- the name of the primary key, while 'makeTable'' automatically makes the first field of the record +-- the primary key. +-- +-- > makeTable ''UserT 'userNumber == makeTable' ''UserT +makeTable :: + Name -- ^ The table type name. It should end with \"T\", otherwise the derived names will be bogus. + -> Name -- ^ The primary key field name + -> DecsQ +makeTable nmT nmPk = do + i <- reify nmT + makeTableWithType nmT . head . filter (\(nm, _, _) -> nm == nmPk) . recordFields $ i + +{-# INLINE firstRecord #-} +firstRecord :: Name -> VarBangTypeQ +firstRecord = reify >=> (pure . head . recordFields) + +-- | Derives boilerplate code for beam table types. +-- +-- >>> :set -XTemplateHaskell +-- >>> data UserT f = User { userNumber :: Columnar f Int } +-- >>> putStrLn $(stringE . pprint =<< makeTable' ''UserT) +-- type User = UserT Data.Functor.Identity.Identity +-- deriving instance GHC.Show.Show User +-- instance Database.Beam.Schema.Tables.Table UserT +-- where data Database.Beam.Schema.Tables.PrimaryKey UserT f_0 +-- = UserId (Database.Beam.Schema.Tables.Columnar f_0 GHC.Types.Int) +-- deriving GHC.Generics.Generic +-- Database.Beam.Schema.Tables.primaryKey x_1 = UserId (Ghci4.userNumber x_1) +-- type UserId (f_2 :: * -> +-- *) = Database.Beam.Schema.Tables.PrimaryKey UserT f_2 +-- type UserId' = UserId Data.Functor.Identity.Identity +-- deriving instance GHC.Show.Show UserId' +-- User (Database.Beam.Schema.Tables.LensFor userNumberC) = Database.Beam.Schema.Lenses.tableConfigLenses +-- +-- Note: While the above example actually is a valid doctest, due to variable renaming and the pretty printer +-- having a line break deficit it looks rather confusing. Therefore, consider the following reformatted but +-- otherwise equivalent example: +-- +-- @ +-- type User = UserT Identity +-- deriving instance Show User +-- instance Table UserT where +-- data PrimaryKey UserT f = UserId (Columnar f Int) deriving Generic +-- primaryKey = UserId . userNumber +-- type UserId f = PrimaryKey UserT f +-- type UserId' = UserId Identity +-- deriving instance Show UserId' +-- User (LensFor userNumberC) = tableConfigLenses +-- @ +-- +-- Note that the @UserId@ type synonym is very useful when refering to other tables in fields. Consider this: +-- @ +-- data BlogPostT f = BlogPost { blogPostId :: Columnar f Int, blogPostAuthor :: UserId f } +-- @ +-- +-- 'makeTable' is equivalent to 'makeTable'' except that 'makeTable' takes a second argument, +-- the name of the primary key, while 'makeTable'' automatically makes the first field of the record +-- the primary key. +-- +-- > makeTable ''UserT 'userNumber == makeTable' ''UserT +makeTable' :: + Name -- ^ The table type name. It should end with \"T\", otherwise the derived names will be bogus. + -> DecsQ +makeTable' nm = do + fr <- firstRecord nm + makeTableWithType nm fr diff --git a/src/Database/Beam/TH/Internal.hs b/src/Database/Beam/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/Beam/TH/Internal.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, TupleSections #-} +module Database.Beam.TH.Internal ( + MakeTableT(..), MakeTable, MakeTableT', MakeTableT'', + runTableT, tellD, + rename, + vst, name, nameId, nameId', nameT, + (<~>), (<+>), (~>), + assert, assertMany, invalidConstructor + ) where + +import Control.Monad (unless) +import qualified Control.Monad.Fail as Fail (MonadFail(..)) +import Control.Monad.Identity (Identity) +import Control.Monad.Reader (ReaderT(..), MonadReader, asks) +import Control.Monad.Writer (WriterT(..), MonadWriter, execWriterT, tell) +import Control.Monad.Trans (MonadTrans(..)) +import Data.Foldable (traverse_) +import Language.Haskell.TH (Name, mkName, nameBase, reportError, Q, DecsQ, Dec, Type(..), Exp(..)) +import Language.Haskell.TH.Syntax (VarBangType) +import Data.Typeable (Typeable) + +{-# INLINE rename #-} +rename :: (String -> String) -> Name -> Name +rename f = mkName . f . nameBase + +{-# INLINE mkNameSelector #-} +mkNameSelector :: MonadReader (Name, VarBangType) m => String -> m Name +mkNameSelector suffix = asks (rename (++ suffix) . fst) +{-# INLINE vst #-} +vst :: MonadReader (Name, VarBangType) m => m VarBangType +vst = asks snd +{-# INLINE name #-} +{-# INLINE nameId #-} +{-# INLINE nameId' #-} +{-# INLINE nameT #-} +name, nameId, nameId', nameT :: MonadReader (Name, VarBangType) m => m Name +name = asks fst +nameId = mkNameSelector "Id" +nameId' = mkNameSelector "Id'" +nameT = mkNameSelector "T" + + +newtype MakeTableT m a = MakeTableT { runTable :: WriterT [Dec] (ReaderT (Name, VarBangType) m) a } + deriving (Typeable, Functor, Applicative, Monad, MonadReader (Name, VarBangType), MonadWriter [Dec], Fail.MonadFail) +instance MonadTrans MakeTableT where + lift = MakeTableT . lift . lift +type MakeTable a = MakeTableT Identity a +type MakeTableT' a = MakeTableT Q a +type MakeTableT'' = MakeTableT' () +{- +instance Monoid MakeTableT'' where + mempty = MakeTableT . WriterT . lift . pure $ ((), []) + mappend = curry (mkt <=< (uncurry ((<*>) . (mappend <$>)) . (f *** f))) + where + f = fmap snd . MakeTableT . lift . runWriterT . runTable + mkt = MakeTableT . WriterT . ReaderT . const . pure . ((),) +-} +{-# INLINE runTableT #-} +runTableT :: Name -> VarBangType -> MakeTableT' a -> DecsQ +runTableT n v = flip runReaderT (n, v) . execWriterT . runTable + +{-# INLINE tellD #-} +tellD :: MonadWriter [Dec] m => Dec -> m () +tellD = tell . pure + +{-# INLINE (<~>) #-} +(<~>) :: Type -> Type -> Type +a <~> b = AppT a b + +{-# INLINE (<+>) #-} +(<+>) :: Exp -> Exp -> Exp +a <+> b = AppE a b + +{-# INLINE (~>) #-} +(~>) :: Type -> Type -> Type +a ~> b = ArrowT <~> a <~> b + +infixl 4 <~>, <+>, ~> + +{-# INLINE assert #-} +assert :: Bool -> String -> Q () +assert cond msg = unless cond (reportError $ "Table name does not follow convention: " ++ msg ++ "; use 'MyTableNameT' or so") +{-# INLINE assertMany #-} +assertMany :: [(Bool, String)] -> Q () +assertMany = traverse_ (uncurry assert) + +{-# INLINE invalidConstructor #-} +invalidConstructor :: Fail.MonadFail m => m a +invalidConstructor = Fail.fail "Invalid constructor field; the primary key must be of the form 'Columnar f SomeType'" diff --git a/test/DoctestDriver.hs b/test/DoctestDriver.hs new file mode 100644 --- /dev/null +++ b/test/DoctestDriver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF doctest-discover -optF doctest-config.json #-} diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Data.Char (isDigit) +import Language.Haskell.TH +import Test.Tasty +import Test.Tasty.Runners +import Test.Tasty.HUnit + +import Database.Beam +import Database.Beam.TH + +import TestData + +main :: IO () +main = defaultMainWithIngredients [ consoleTestReporter ] tests + +-- To check for equality, remove the uniqueness suffixes (x_12345678) added by the renamer +pruneUniqueVars :: String -> String +pruneUniqueVars = go + where + go [] = [] + go (x:xs) = case x of + '_' -> go . dropWhile isDigit $ xs + _ -> x : go xs + +expectUser, expectOrder :: String +expectUser = "[TySynD User [] (AppT (ConT UserT) (ConT Data.Functor.Identity.Identity)),StandaloneDerivD [] (AppT (ConT GHC.Show.Show) (ConT User)),InstanceD Nothing [] (AppT (ConT Database.Beam.Schema.Tables.Table) (ConT UserT)) [DataInstD [] Database.Beam.Schema.Tables.PrimaryKey [ConT UserT,VarT f] Nothing [NormalC UserId [(Bang NoSourceUnpackedness NoSourceStrictness,AppT (AppT (ConT Database.Beam.Schema.Tables.Columnar) (VarT f)) (ConT Data.Text.Internal.Text))]] [ConT GHC.Generics.Generic],FunD Database.Beam.Schema.Tables.primaryKey [Clause [VarP x] (NormalB (AppE (ConE UserId) (AppE (VarE TestData.userName) (VarE x)))) []]],TySynD UserId [KindedTV f (AppT (AppT ArrowT StarT) StarT)] (AppT (AppT (ConT Database.Beam.Schema.Tables.PrimaryKey) (ConT UserT)) (VarT f)),TySynD UserId' [] (AppT (ConT UserId) (ConT Data.Functor.Identity.Identity)),StandaloneDerivD [] (AppT (ConT GHC.Show.Show) (ConT UserId')),ValD (ConP User [ConP Database.Beam.Schema.Tables.LensFor [VarP userNameC]]) (NormalB (VarE Database.Beam.Schema.Lenses.tableConfigLenses)) []]" +expectOrder = "[TySynD Order [] (AppT (ConT OrderT) (ConT Data.Functor.Identity.Identity)),StandaloneDerivD [] (AppT (ConT GHC.Show.Show) (ConT Order)),InstanceD Nothing [] (AppT (ConT Database.Beam.Schema.Tables.Table) (ConT OrderT)) [DataInstD [] Database.Beam.Schema.Tables.PrimaryKey [ConT OrderT,VarT f] Nothing [NormalC OrderId [(Bang NoSourceUnpackedness NoSourceStrictness,AppT (AppT (ConT Database.Beam.Schema.Tables.Columnar) (VarT f)) (ConT Data.Text.Internal.Text))]] [ConT GHC.Generics.Generic],FunD Database.Beam.Schema.Tables.primaryKey [Clause [VarP x] (NormalB (AppE (ConE OrderId) (AppE (VarE TestData.orderItem) (VarE x)))) []]],TySynD OrderId [KindedTV f (AppT (AppT ArrowT StarT) StarT)] (AppT (AppT (ConT Database.Beam.Schema.Tables.PrimaryKey) (ConT OrderT)) (VarT f)),TySynD OrderId' [] (AppT (ConT OrderId) (ConT Data.Functor.Identity.Identity)),StandaloneDerivD [] (AppT (ConT GHC.Show.Show) (ConT OrderId')),SigD orderIssuerC (AppT (AppT (ConT Lens') (AppT (ConT OrderT) (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)))) (AppT (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)) WildCardT)),ValD (ConP Order [ConP Database.Beam.Schema.Tables.LensFor [VarP orderItemC],ConP UserId [ConP Database.Beam.Schema.Tables.LensFor [VarP orderIssuerC]],ConP Database.Beam.Schema.Tables.LensFor [VarP orderAmountC]]) (NormalB (VarE Database.Beam.Schema.Lenses.tableConfigLenses)) []]" + +tests :: TestTree +tests = testGroup "Template Haskell boilerpate generation" [ testGroup "Compare Output against Golden Value" [ + testCase "makeTable ''UserT 'userName" $ do + let decs = $(stringE . show =<< makeTable ''UserT 'userName) + assertEqual "" expectUser (pruneUniqueVars decs), + testCase "makeTable' ''UserT" $ do + let decs = $(stringE . show =<< makeTable' ''UserT) + assertEqual "" expectUser (pruneUniqueVars decs), + testCase "makeTable ''OrderT 'orderItem" $ do + let decs = $(stringE . show =<< makeTable ''OrderT 'orderItem) + assertEqual "" expectOrder (pruneUniqueVars decs), + testCase "makeTable' ''OrderT" $ do + let decs = $(stringE . show =<< makeTable' ''OrderT) + assertEqual "" expectOrder (pruneUniqueVars decs) + ]] diff --git a/test/TestData.hs b/test/TestData.hs new file mode 100644 --- /dev/null +++ b/test/TestData.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveGeneric #-} +module TestData where + +import Data.Text (Text) +import Database.Beam + +data UserT f = User { + userName :: Columnar f Text + } deriving (Generic) + +data OrderT f = Order { + orderItem :: Columnar f Text, + orderIssuer :: PrimaryKey UserT f, -- not using UserId here for simplicity + orderAmount :: Columnar f Int + } deriving (Generic)