beam-th 0.1.0.3 → 0.2.0.0
raw patch · 6 files changed
+98/−29 lines, 6 files
Files
- CHANGELOG.md +7/−0
- beam-th.cabal +4/−2
- src/Database/Beam/TH.hs +1/−1
- src/Database/Beam/TH/Internal.hs +80/−21
- test/Test.hs +1/−1
- test/TestData.hs +5/−4
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Changelog for the [`beam-th` package](http://hackage.haskell.org/package/beam-th) +## 0.2.0.0 *July 2016*++ * Increase test suite coverage+ * Expose the `Database.Beam.TH.Internal` module together with added documentation+ * Change the fixity of some internal operators (no visible changes)+ * Remove unused `TupleSections` extension+ ## 0.1.0.3 * Final round of name lookup fixes
beam-th.cabal view
@@ -1,5 +1,5 @@ name: beam-th-version: 0.1.0.3+version: 0.2.0.0 synopsis: Template Haskell utilities for beam description: (Completely optional) Template Haskell functions@@ -17,6 +17,7 @@ build-type: Simple cabal-version: >=1.18 stability: Experimental+tested-with: GHC == 8.0.1 source-repository head type: git@@ -27,7 +28,8 @@ ghc-options: -Wall -Wcompat hs-source-dirs: src exposed-modules: Database.Beam.TH- other-modules: Database.Beam.TH.Internal+ , Database.Beam.TH.Internal+--other-modules: other-extensions: StandaloneDeriving , GeneralizedNewtypeDeriving , DeriveGeneric
src/Database/Beam/TH.hs view
@@ -80,7 +80,7 @@ where renameFields (cname, _, t) = (rename (++ "C") cname, t) lens' = ''Lens'- extractCon (AppT (ConT c) _) = pure c+ extractCon (AppT (ConT c) _) = fmap fromJust . lookupValueName . nameBase $ c extractCon (AppT (AppT _ (ConT c)) _) = fmap fromJust . lookupValueName . (++ "Id") . nameBase =<< 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
src/Database/Beam/TH/Internal.hs view
@@ -1,11 +1,26 @@-{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, TupleSections #-}+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-}+-- | Various internal utilities for beam-th. The usual caveats apply. module Database.Beam.TH.Internal (- MakeTableT(..), MakeTable, MakeTableT', MakeTableT'',+ -- * The MakeTableT monad transformer+ -- ** Definition+ MakeTableT(..),+ -- ** Derived type synonyms+ MakeTable, MakeTableT', MakeTableT'',+ -- ** Helper functions runTableT, tellD,+ -- ** Extracting values from a MakeTableT+ vst,+ -- *** Simple and composite names+ name, nameId, nameId', nameT,+ -- * Name utilities rename,- vst, name, nameId, nameId', nameT,+ -- * Type and Expression Application Sugar (<~>), (<+>), (~>),- assert, assertMany, invalidConstructor+ -- * Error handling+ -- ** Constructor types+ invalidConstructor,+ -- ** Table names+ assert, assertMany ) where import Control.Monad (unless)@@ -19,34 +34,56 @@ import Language.Haskell.TH.Syntax (VarBangType) import Data.Typeable (Typeable) -{-# INLINE rename #-}+-- | Rename a 'Name' using a function on 'String's rename :: (String -> String) -> Name -> Name rename f = mkName . f . nameBase+{-# INLINE rename #-} -{-# INLINE mkNameSelector #-} mkNameSelector :: MonadReader (Name, VarBangType) m => String -> m Name mkNameSelector suffix = asks (rename (++ suffix) . fst)-{-# INLINE vst #-}+{-# INLINE mkNameSelector #-}++-- | Extract the 'PrimaryKey' 'VarBangType' vst :: MonadReader (Name, VarBangType) m => m VarBangType vst = asks snd-{-# INLINE name #-}-{-# INLINE nameId #-}-{-# INLINE nameId' #-}-{-# INLINE nameT #-}+{-# INLINE vst #-}+ name, nameId, nameId', nameT :: MonadReader (Name, VarBangType) m => m Name+-- | Get the base name name = asks fst+-- | Get the name with an \"Id\" suffix nameId = mkNameSelector "Id"+-- | Get the name with an \"Id'\" suffix nameId' = mkNameSelector "Id'"+-- | Get the name with a \"T\" suffix nameT = mkNameSelector "T"+{-# INLINE name #-}+{-# INLINE nameId #-}+{-# INLINE nameId' #-}+{-# INLINE nameT #-} +-- | A monad transformer for writing Template Haskell declarations.+--+-- The Reader contains both the base name of the table and the 'VarBangType'+-- of the primary key field.+--+-- If you can come up with a better name, drop me a line. 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 synonym for 'MakeTableT' in the 'Identity' monad.+--+-- Only defined for complying with the monad transformer conventions+-- and not actually used. type MakeTable a = MakeTableT Identity a+-- | Type synonym for 'MakeTableT' in the 'Q' monad. type MakeTableT' a = MakeTableT Q a+-- | Type synonym for 'MakeTableT' in the 'Q' monad with the empty tuple as the inner type.+-- This is the most common use case. type MakeTableT'' = MakeTableT' ()+ {- instance Monoid MakeTableT'' where mempty = MakeTableT . WriterT . lift . pure $ ((), [])@@ -55,35 +92,57 @@ f = fmap snd . MakeTableT . lift . runWriterT . runTable mkt = MakeTableT . WriterT . ReaderT . const . pure . ((),) -}-{-# INLINE runTableT #-}-runTableT :: Name -> VarBangType -> MakeTableT' a -> DecsQ++-- | Run the table writing sequence (or, the 'MakeTableT' if you prefer).+runTableT ::+ Name -- ^ The base name of the table, without the trailing \"T\".+ -> VarBangType -- ^ The primary key field.+ -> MakeTableT' a -- ^ The table writing sequence to be executed. The inner type is ignored.+ -> DecsQ runTableT n v = flip runReaderT (n, v) . execWriterT . runTable+{-# INLINE runTableT #-} -{-# INLINE tellD #-}+-- | Write a single 'Dec' tellD :: MonadWriter [Dec] m => Dec -> m () tellD = tell . pure+{-# INLINE tellD #-} -{-# INLINE (<~>) #-}+-- $setup+-- >>> let nm = mkName "nm"++-- | Convenient syntactic sugar for application of types.+--+-- >>> ConT nm <~> ConT nm <~> ConT nm+-- AppT (AppT (ConT nm) (ConT nm)) (ConT nm) (<~>) :: Type -> Type -> Type a <~> b = AppT a b+{-# INLINE (<~>) #-} -{-# INLINE (<+>) #-}+-- | Convenient syntactic sugar for application of expressions.+--+-- >>> ConE nm <+> ConE nm <+> ConE nm+-- AppE (AppE (ConE nm) (ConE nm)) (ConE nm) (<+>) :: Exp -> Exp -> Exp a <+> b = AppE a b+{-# INLINE (<+>) #-} -{-# INLINE (~>) #-}+-- | Convenient syntactic sugar for arrows in types.+--+-- >>> StarT ~> StarT+-- AppT (AppT ArrowT StarT) StarT (~>) :: Type -> Type -> Type a ~> b = ArrowT <~> a <~> b+{-# INLINE (~>) #-} -infixl 4 <~>, <+>, ~>+infixl 6 <~>, <+>, ~> -{-# INLINE assert #-}+-- | Assert a condition related to the table base name and suggest following the naming convention. assert :: Bool -> String -> Q () assert cond msg = unless cond (reportError $ "Table name does not follow convention: " ++ msg ++ "; use 'MyTableNameT' or so")-{-# INLINE assertMany #-}+-- | Assert a list of conditions and associated error messages. assertMany :: [(Bool, String)] -> Q () assertMany = traverse_ (uncurry assert) -{-# INLINE invalidConstructor #-}+-- | Complain about an unknown field in the table. invalidConstructor :: Fail.MonadFail m => m a invalidConstructor = Fail.fail "Invalid constructor field; the primary key must be of the form 'Columnar f SomeType'"
test/Test.hs view
@@ -26,7 +26,7 @@ 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')),SigD userNameC (AppT (AppT (ConT Lens.Micro.Type.Lens') (AppT (ConT UserT) (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT UserT)))) (AppT (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT UserT)) WildCardT)),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 orderItemC (AppT (AppT (ConT Lens.Micro.Type.Lens') (AppT (ConT OrderT) (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)))) (AppT (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)) WildCardT)),SigD orderIssuerC (AppT (AppT (ConT Lens.Micro.Type.Lens') (AppT (ConT OrderT) (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)))) (AppT (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)) WildCardT)),SigD orderAmountC (AppT (AppT (ConT Lens.Micro.Type.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 TestData.UserId [ConP Database.Beam.Schema.Tables.LensFor [VarP orderIssuerC]],ConP Database.Beam.Schema.Tables.LensFor [VarP orderAmountC]]) (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 orderItemC (AppT (AppT (ConT Lens.Micro.Type.Lens') (AppT (ConT OrderT) (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)))) (AppT (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)) WildCardT)),SigD orderIssuerC (AppT (AppT (ConT Lens.Micro.Type.Lens') (AppT (ConT OrderT) (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)))) (AppT (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)) WildCardT)),SigD orderRecipientC (AppT (AppT (ConT Lens.Micro.Type.Lens') (AppT (ConT OrderT) (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)))) (AppT (AppT (ConT Database.Beam.Schema.Tables.TableField) (ConT OrderT)) WildCardT)),SigD orderAmountC (AppT (AppT (ConT Lens.Micro.Type.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 TestData.UserId [ConP Database.Beam.Schema.Tables.LensFor [VarP orderIssuerC]],ConP TestData.UserId [ConP Database.Beam.Schema.Tables.LensFor [VarP orderRecipientC]],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" [
test/TestData.hs view
@@ -6,13 +6,14 @@ import Database.Beam.TH data UserT f = User {- userName :: Columnar f Text+ userName :: Columnar f Text } deriving (Generic) makeTable' ''UserT data OrderT f = Order {- orderItem :: Columnar f Text,- orderIssuer :: PrimaryKey UserT f, -- not using UserId here for simplicity- orderAmount :: Columnar f Int+ orderItem :: Columnar f Text,+ orderIssuer :: UserId f,+ orderRecipient :: PrimaryKey UserT f,+ orderAmount :: Columnar f Int } deriving (Generic) makeTable' ''OrderT