Add script to generate code

package.yaml

@@ -8,6 +8,7 @@ library:
   source-dirs: src
   dependencies:
     - base >= 4.10 && < 5
+    - conduit >= 1.3.0.3 && < 2
     - containers >= 0.5.10.2 && < 0.7
     - mtl >= 2.2.2 && < 3
     - persistent >= 2.8.2 && < 3

persistent-mtl.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: f1717fb11c2c334c4fb635d2ab3fafd4960e5d56d9f998a53962019736a970e5
+-- hash: ccffc525bb8ea958adc029c2843acb2d57cdde2da16fdefa077abe546000ab44
 
 name:           persistent-mtl
 version:        0.1.0.0
@@ -25,6 +25,7 @@ library
   ghc-options: -Wall
   build-depends:
       base >=4.10 && <5
+    , conduit >=1.3.0.3 && <2
     , containers >=0.5.10.2 && <0.7
     , mtl >=2.2.2 && <3
     , persistent >=2.8.2 && <3

scripts/generate/GeneratePersistentAPI.hs

@@ -0,0 +1,145 @@
+{-
+  stack script --resolver lts-16.23
+    --package aeson
+    --package containers
+    --package mustache
+    --package text
+    --package unliftio
+    --package yaml
+-}
+
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+import Control.Monad (forM_)
+import Data.Aeson (FromJSON(..), withObject, (.!=), (.:), (.:?))
+import Data.Char (isAlphaNum, toUpper)
+import Data.List (nub, sort)
+import Data.Map (Map)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import qualified Data.Yaml as Yaml
+import Text.Mustache (ToMustache(..), object, (~>))
+import qualified Text.Mustache as Mustache
+import qualified Text.Mustache.Types as Mustache
+
+{- Configuration -}
+
+-- | See `README.md` for a description of this data type.
+data PersistentFunction = PersistentFunction
+  { name        :: Text
+  , constraints :: [Text]
+  , args        :: [Text]
+  , result      :: Text
+  } deriving (Show)
+
+instance FromJSON PersistentFunction where
+  parseJSON = withObject "PersistentFunction" $ \o ->
+    PersistentFunction
+      <$> o .: "name"
+      <*> o .:? "constraints" .!= []
+      <*> o .:? "args" .!= []
+      <*> o .: "result"
+
+{- Rendering -}
+
+data Context = Context
+  { functions :: [FunctionContext]
+  }
+
+instance ToMustache Context where
+  toMustache Context{..} = object [ "functions" ~> functions ]
+
+buildContext :: [PersistentFunction] -> Context
+buildContext = Context . map buildFunctionContext
+
+data FunctionContext = FunctionContext
+  { name        :: Text
+  , constraints :: [Text]
+  , args        :: [Text]
+  , result      :: Text
+  }
+
+buildFunctionContext :: PersistentFunction -> FunctionContext
+buildFunctionContext PersistentFunction{..} = FunctionContext{..}
+
+instance ToMustache FunctionContext where
+  toMustache FunctionContext{..} = object
+    [ "name" ~> name
+    , "nameCapital" ~> capitalize name
+    , "constraints" ~> enumerateWith fromConstraint constraints
+    , "args" ~> enumerateWith fromArg args
+    , "result" ~> result
+    , "sqlQueryRepRecord" ~> sqlQueryRepRecord
+    , "recordTypeVars" ~> recordTypeVars
+    ]
+    where
+      fromConstraint constraint = object [ "type" ~> constraint ]
+      fromArg arg = object [ "type" ~> arg ]
+      recordTypeVars = getRecordTypeVars constraints
+
+      -- the `record` type variable for SqlQueryRep
+      sqlQueryRepRecord = case recordTypeVars of
+        [] -> "Void"
+        [record] -> record
+        records -> "(" <> Text.intercalate ", " records <> ")"
+
+-- | Get all `record` type variables in the given list of constraints.
+--
+-- A type variable is considered a `record` type variable if it matches the
+-- pattern "record|recordN", where `N` is a number. The type variables will
+-- be sorted when returned.
+--
+-- e.g.
+--   ["Foo record"] -> ["record"]
+--   ["Bar record1", "Foo record2 record1"] -> ["record1", "record2"]
+getRecordTypeVars :: [Text] -> [Text]
+getRecordTypeVars = sort . nub . concatMap getPersistRecordsIn
+  where
+    getPersistRecordsIn = filter ("record" `Text.isPrefixOf`) . Text.words . ignoreNonAlphaNum
+    ignoreNonAlphaNum = Text.map (\c -> if isAlphaNum c then c else ' ')
+
+capitalize :: Text -> Text
+capitalize t = case Text.uncons t of
+  Just (c, cs) -> Text.cons (toUpper c) cs
+  Nothing -> t
+
+-- | Convert each element in the list into a Value with the given function,
+-- adding the "index" and "last" keys indicating the element's index in the list
+-- and whether the element is the last one in the list, respectively.
+enumerateWith :: (a -> Mustache.Value) -> [a] -> [Mustache.Value]
+enumerateWith f xs =
+  let mkElem x i = merge (f x) $ object
+        [ "index" ~> i
+        , "last" ~> (i == length xs)
+        ]
+  in zipWith mkElem xs [1..]
+
+-- If only Value had a Monoid instance...
+merge :: Mustache.Value -> Mustache.Value -> Mustache.Value
+merge (Mustache.Object o1) (Mustache.Object o2) = Mustache.Object $ o1 <> o2
+merge v _ = v
+
+{- Main -}
+
+main :: IO ()
+main = do
+  context <- buildContext <$> Yaml.decodeFileThrow "persistent-api.yaml"
+
+  generate "SqlQueryRep.mustache" "Database/Persist/Monad/SqlQueryRep.hs" context
+  generate "Shim.mustache" "Database/Persist/Monad/Shim.hs" context
+
+srcDir :: FilePath
+srcDir = "../../src/"
+
+generate :: ToMustache k => FilePath -> FilePath -> k -> IO ()
+generate templatePath output value = do
+  template <- either (error . show) return =<< Mustache.automaticCompile ["./templates"] templatePath
+  case Mustache.checkedSubstitute template value of
+    ([], rendered) -> Text.writeFile (srcDir ++ output) rendered
+    (errors, _) -> error $ unlines $
+      "Found errors when generating template:" : map showError errors
+  where
+    showError e = "* " ++ show e

scripts/generate/README.md

@@ -0,0 +1,53 @@
+# Generating lifted persistent functions
+
+## Usage
+
+```
+scripts/generate/run.sh
+```
+
+## Configuration
+
+Configuration lives in `persistent-api.yaml`. The file contains a list of objects, where each object corresponds to a `persistent` function that we want to lift into the `MonadSqlQuery` context. Follow the instructions in this guide to update the YAML file, which will generate the appropriate Haskell code. If you're trying to add a function that doesn't fit neatly with the instructions or categories, bring up a discussion with other developers.
+
+To add a function, write down its type then do the following:
+
+1. Update type variables
+    * Specialize `backend` as `SqlBackend`
+    * Ensure the `PersistEntity` type variable is named `record`. If there are multiple `PersistEntity` types, they should be named `record1`, `record2`, etc. Choose an order that makes sense for `withRecord`, e.g.
+
+        ```hs
+        withRecord @(record1, record2, ...) $ ...
+        ```
+
+1. Simplify constraints
+    * Remove redundant constraints, e.g. `PersistQueryRead SqlBackend`
+    * Substitute `PersistRecordBackend`, if applicable
+
+1. Look at the monad type(s) in the function:
+    1. If there are multiple monad types, go to the "Advanced" section
+    1. If the monad has a constraint other than `Monad`, `MonadIO`, or `MonadUnliftIO`, go to the "Advanced" section
+    1. Otherwise, go to the "Basic" section
+
+### Basic
+
+First, make the following modifications:
+
+1. Ensure the monad type variable is named `m`
+1. Remove all `Monad`, `MonadIO`, and `MonadUnliftIO` constraints
+    * At this point, the monad shouldn't have any constraints
+1. Rename `ReaderT SqlBackend m a` as `m a`
+
+Then add the function to the YAML file in the following format:
+
+* `name`: The function's name
+* `constraints`: The function's constraints
+* `args`: The function's arguments
+* `result`: The function's result, without the monad
+    * e.g. a function that returns `m (Maybe Foo)` should have `result` set to just `(Maybe Foo)`
+
+There should be no references to `m` here.
+
+### Advanced
+
+TODO