packages feed

beam-th (empty) → 0.1.0.0

raw patch · 10 files changed

+433/−0 lines, 10 filesdep +basedep +beamdep +beam-thsetup-changed

Dependencies added: base, beam, beam-th, doctest, doctest-discover, mtl, tasty, tasty-hunit, template-haskell, text, th-expand-syns, transformers

Files

+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright 2016 Tobias Markus <tobias AT miglix DOT eu>+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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ beam-th.cabal view
@@ -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 <https://hackage.haskell.org/package/beam beam> library.+license:                 BSD3+license-file:            LICENSE+category:                Database, Template Haskell+extra-source-files:      README.md CHANGELOG.md+author:                  Tobias Markus <tobias AT miglix DOT eu>+maintainer:              Tobias Markus <tobias AT miglix DOT eu>+copyright:               Copyright 2016 Tobias Markus <tobias AT miglix DOT eu>+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
+ src/Database/Beam/TH.hs view
@@ -0,0 +1,167 @@+{-# 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.+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
+ src/Database/Beam/TH/Internal.hs view
@@ -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'"
+ test/DoctestDriver.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF doctest-discover -optF doctest-config.json #-}
+ test/Test.hs view
@@ -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)+           ]]
+ test/TestData.hs view
@@ -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)