persistent-template-classy (empty) → 0.1.0.0
raw patch · 6 files changed
+324/−0 lines, 6 filesdep +basedep +lensdep +persistentsetup-changed
Dependencies added: base, lens, persistent, persistent-sqlite, persistent-template, persistent-template-classy, template-haskell, text
Files
- LICENSE +30/−0
- README.md +81/−0
- Setup.hs +2/−0
- examples/persistent-template-classy-example.hs +49/−0
- persistent-template-classy.cabal +55/−0
- src/Database/Persist/TH/Classy.hs +107/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT+OWNER 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,81 @@+# persistent-template-classy++Generate classy lens for your Persistent fields. For example:++```haskell+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++import Control.Lens (Lens', (^.), lens)+import Control.Monad.IO.Class (liftIO)+import Database.Persist+import Database.Persist.Sqlite+import Database.Persist.TH+import Database.Persist.TH.Classy++$(mkClassyClass "name")+$(mkClassyClass "age")+$(mkClassyClass "title")+$(mkClassyClass "authorId")++share+ [mkPersist sqlSettings, mkMigrate "migrateAll", mkClassyInstances]+ [persistLowerCase|+Person+ name String+ age Int Maybe+ deriving Show+BlogPost+ title String+ authorId PersonId+ deriving Show+|]++main :: IO ()+main =+ runSqlite ":memory:" $ do+ runMigration migrateAll+ let johnDoe = Person "John Doe" $ Just 35+ johnId <- insert johnDoe+ liftIO $ print $ johnDoe ^. name+ liftIO $ print $ johnDoe ^. age+ let post = BlogPost "My fr1st p0st" johnId+ liftIO $ print $ post ^. title+```++This would essentially generate this additional code:++```haskell+class HasName ev a | ev -> a where+ name :: Lens' ev a+class HasAge ev a | ev -> a where+ age :: Lens' ev a+class HasTitle ev a | ev -> a where+ title :: Lens' ev a+class HasAuthorId ev a | ev -> a where+ authorId :: Lens' ev a++instance HasName Person String where+ name = (lens personName) (\ x y -> x {personName = y})+instance HasAge Person Int where+ age = (lens personAge) (\ x y -> x {personAge = y})+instance HasTitle BlogPost String where+ title = (lens blogPostTitle) (\ x y -> x {blogPostTitle = y})+instance HasAuthorId BlogPost PersonId where+ authorId+ = (lens blogPostAuthorId) (\ x y -> x {blogPostAuthorId = y})+```++Class-generation is separated from instance-generation because it's+wise to keep it in a single place in your project and reuse with a+non-persistent code.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/persistent-template-classy-example.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++import Control.Lens (Lens', (^.), lens)+import Control.Monad.IO.Class (liftIO)+import Database.Persist+import Database.Persist.Sqlite+import Database.Persist.TH+import Database.Persist.TH.Classy++$(mkClassyClass "name")+$(mkClassyClass "age")+$(mkClassyClass "title")+$(mkClassyClass "authorId")++share+ [mkPersist sqlSettings, mkMigrate "migrateAll", mkClassyInstances]+ [persistLowerCase|+Person+ name String+ age Int Maybe+ deriving Show+BlogPost+ title String+ authorId PersonId+ deriving Show+|]++main :: IO ()+main =+ runSqlite ":memory:" $ do+ runMigration migrateAll+ let johnDoe = Person "John Doe" $ Just 35+ johnId <- insert johnDoe+ liftIO $ print $ johnDoe ^. name+ liftIO $ print $ johnDoe ^. age+ let post = BlogPost "My fr1st p0st" johnId+ liftIO $ print $ post ^. title+
+ persistent-template-classy.cabal view
@@ -0,0 +1,55 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: a6e78e8bb31adbcfbd23254db1be689f79966cee61715a656e7a9c572227c77b++name: persistent-template-classy+version: 0.1.0.0+synopsis: Generate classy lens field accessors for persistent models+description: Generate classy lens field accessors for persistent models.+category: Database, Lens, Yesod+homepage: https://github.com/k-bx/persistent-template-classy#readme+author: Kostiantyn Rybnikov+maintainer: k-bx@k-bx.com+copyright: 2018 Kostiantyn Rybnikov+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md++library+ exposed-modules:+ Database.Persist.TH.Classy+ other-modules:+ Paths_persistent_template_classy+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , lens+ , persistent+ , persistent-sqlite+ , persistent-template+ , template-haskell+ , text+ default-language: Haskell2010++test-suite persistent-template-classy-example+ type: exitcode-stdio-1.0+ main-is: examples/persistent-template-classy-example.hs+ other-modules:+ Paths_persistent_template_classy+ build-depends:+ base >=4.7 && <5+ , lens+ , persistent+ , persistent-sqlite+ , persistent-template+ , persistent-template-classy+ , template-haskell+ , text+ default-language: Haskell2010
+ src/Database/Persist/TH/Classy.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.Persist.TH.Classy where++import Control.Lens (Lens')+import qualified Data.Char as Char+import qualified Data.Text as T+import Data.Traversable (forM)+import Database.Persist+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax++-- | Generate something like:+--+-- class HasName ev a | ev -> a where+-- name :: Lens' ev a+mkClassyClass ::+ String -- ^ like "name"+ -> Q [Dec]+mkClassyClass name+ -- | like "Name"+ =+ let nameCapitalized =+ case name of+ "" -> ""+ (x:xs) -> Char.toUpper x : xs+ -- | like "HasName"+ hasName = "Has" <> nameCapitalized+ in return+ [ ClassD+ []+ (mkName hasName)+ [PlainTV (mkName "ev"), PlainTV (mkName "a")]+ [FunDep [mkName "ev"] [mkName "a"]]+ [ SigD+ (mkName name)+ (AppT+ (AppT (ConT (mkName "Lens'")) (VarT (mkName "ev")))+ (VarT (mkName "a")))+ ]+ ]++-- | Generate something like:+--+-- instance HasName Person String where+-- name = (lens personName) (\ x y -> x {personName = y})+mkClassyInstances :: [EntityDef] -> Q [Dec]+mkClassyInstances defs = do+ concat <$> mapM mkClassyInstance defs++mkClassyInstance :: EntityDef -> Q [Dec]+mkClassyInstance EntityDef {..} = do+ forM entityFields $ \FieldDef {..} ->+ case fieldType of+ FTTypeCon _ tname -> do+ let _unused = ()+ -- | like "Person"+ instanceTypeName =+ ConT (mkName (T.unpack (unHaskellName entityHaskell)))+ -- | like "person"+ instanceTypeNameLowerFirstChar =+ case T.unpack (unHaskellName entityHaskell) of+ "" -> ""+ (x:xs) -> Char.toLower x : xs+ -- | like "Name"+ fieldUpperFirstChar =+ case T.unpack (unHaskellName fieldHaskell) of+ "" -> ""+ (x:xs) -> Char.toUpper x : xs+ -- | like "HasName"+ instanceHasName = mkName ("Has" <> fieldUpperFirstChar)+ -- | like "personName"+ fieldLongName =+ mkName (instanceTypeNameLowerFirstChar ++ fieldUpperFirstChar)+ fieldClause =+ Clause+ []+ (NormalB+ (AppE+ (AppE (VarE (mkName "lens")) (VarE fieldLongName))+ (LamE+ [VarP (mkName "x"), VarP (mkName "y")]+ (RecUpdE+ (VarE (mkName "x"))+ [(fieldLongName, VarE (mkName "y"))]))))+ []+ field =+ FunD+ (mkName (T.unpack (unHaskellName fieldHaskell)))+ [fieldClause]+ fieldTName =+ let nonMaybe = ConT (mkName (T.unpack tname))+ in case "Maybe" `elem` fieldAttrs of+ False -> nonMaybe+ True -> AppT (ConT (mkName "Maybe")) nonMaybe+ return $+ InstanceD+ Nothing+ []+ ((AppT (AppT (ConT instanceHasName) instanceTypeName) fieldTName))+ [field]