beam-th 0.1.0.1 → 0.1.0.2
raw patch · 5 files changed
+31/−10 lines, 5 filesdep +microlens
Dependencies added: microlens
Files
- CHANGELOG.md +5/−0
- beam-th.cabal +2/−1
- src/Database/Beam/TH.hs +19/−7
- test/Test.hs +1/−1
- test/TestData.hs +4/−1
CHANGELOG.md view
@@ -1,5 +1,10 @@ # Changelog for the [`beam-th` package](http://hackage.haskell.org/package/beam-th) +## 0.1.0.2++ * Further name lookup fixes+ * Generate type annotations for all record fields, not just for `PrimaryKey` fields+ ## 0.1.0.1 * Fix name lookup for `LensFor`
beam-th.cabal view
@@ -1,5 +1,5 @@ name: beam-th-version: 0.1.0.1+version: 0.1.0.2 synopsis: Template Haskell utilities for beam description: (Completely optional) Template Haskell functions@@ -43,6 +43,7 @@ , transformers >= 0.5 && < 0.6 , mtl >= 2.2 && < 2.3 , beam >= 0.3 && < 0.5+ , microlens >= 0.4 && < 0.5 test-suite test-beam-th default-language: Haskell2010
src/Database/Beam/TH.hs view
@@ -1,6 +1,12 @@ {-# LANGUAGE TemplateHaskell, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, LambdaCase #-} -- | Functions to derive common boilerplate code when writing table types for the <https://hackage.haskell.org/package/beam beam> -- library. Only use them if you what you're doing.+--+-- The following GHC extensions have to be enabled in order to make the generated code typecheck:+--+-- @+-- {-\# LANGUAGE TemplateHaskell, KindSignatures, StandaloneDeriving, TypeFamilies, TypeSynonymInstances, FlexibleInstances, DeriveGeneric \#-}+-- @ module Database.Beam.TH (makeTable, makeTable') where import Control.Monad ((>=>), forM)@@ -12,8 +18,9 @@ import Language.Haskell.TH.Syntax hiding (lift) import Language.Haskell.TH.ExpandSyns (expandSyns) -import Database.Beam (Table, TableField, Columnar, PrimaryKey, primaryKey, tableConfigLenses, LensFor)+import Database.Beam (Table, TableField, Columnar, PrimaryKey, primaryKey, tableConfigLenses, LensFor(..)) import Database.Beam.TH.Internal+import Lens.Micro (Lens') {-# INLINE getColTy #-} getColTy :: Type -> Q Name@@ -55,21 +62,23 @@ nameLens = do nm <- name nmT <- nameT--- Lens' (AdT (TableField AdT)) (TableField AdT _)- (Just lf) <- lift . lookupTypeName $ "LensFor"+ (Just lf) <- lift . lookupValueName $ "LensFor" (TyConI (DataD _ _ _ _ (RecC _ vsts:_) _)) <- lift $ reify nmT let fields = fmap renameFields vsts+ signature x = tellD . SigD x $ ConT lens' <~> (ConT nmT <~> (ConT ''TableField <~> ConT nmT))+ <~> (ConT ''TableField <~> ConT nmT <~> WildCardT) 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)+ signature x c <- lift . extractCon $ t pure . ConP c . pure . ConP lf . pure . VarP $ x- _ -> pure . ConP lf . pure . VarP $ x)+ _ -> do+ signature x+ pure . ConP lf . pure . VarP $ x) tellD $ ValD (ConP nm fields') (NormalB (VarE 'tableConfigLenses)) [] where renameFields (cname, _, t) = (rename (++ "C") cname, t)- lens' = mkName "Lens'"+ lens' = ''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"@@ -131,6 +140,8 @@ -- *) = Database.Beam.Schema.Tables.PrimaryKey UserT f_2 -- type UserId' = UserId Data.Functor.Identity.Identity -- deriving instance GHC.Show.Show UserId'+-- userNumberC :: Lens.Micro.Type.Lens' (UserT (Database.Beam.Schema.Tables.TableField UserT))+-- (Database.Beam.Schema.Tables.TableField UserT _) -- 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@@ -146,6 +157,7 @@ -- type UserId f = PrimaryKey UserT f -- type UserId' = UserId Identity -- deriving instance Show UserId'+-- userNumberC :: Lens' (UserT (TableField UserT)) (TableField UserT Int) -- User (LensFor userNumberC) = tableConfigLenses -- @ --
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')),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)) []]"+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.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 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" [
test/TestData.hs view
@@ -1,15 +1,18 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell, KindSignatures, StandaloneDeriving, TypeFamilies, TypeSynonymInstances, FlexibleInstances, DeriveGeneric #-} module TestData where import Data.Text (Text) import Database.Beam+import Database.Beam.TH data UserT f = User { 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 } deriving (Generic)+makeTable' ''OrderT