diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. 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/examples/persistent-template-classy-example.hs b/examples/persistent-template-classy-example.hs new file mode 100644 --- /dev/null +++ b/examples/persistent-template-classy-example.hs @@ -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 + diff --git a/persistent-template-classy.cabal b/persistent-template-classy.cabal new file mode 100644 --- /dev/null +++ b/persistent-template-classy.cabal @@ -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 diff --git a/src/Database/Persist/TH/Classy.hs b/src/Database/Persist/TH/Classy.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/TH/Classy.hs @@ -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]