persistent-discover (empty) → 0.1.0.0

raw patch · 11 files changed

+512/−0 lines, 11 filesdep +basedep +directorydep +dlistsetup-changed

Dependencies added: base, directory, dlist, file-embed, filepath, hspec, hspec-discover, mtl, persistent, persistent-discover, template-haskell

Files

• ChangeLog.md +7/−0
• LICENSE +30/−0
• README.md +48/−0
• Setup.hs +2/−0
• app/Main.hs +18/−0
• persistent-discover.cabal +96/−0
• src/Database/Persist/Discover.hs +33/−0
• src/Database/Persist/Discover/Exe.hs +214/−0
• src/Lib.hs +6/−0
• test/Database/Persist/Discover/ExeSpec.hs +56/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,7 @@+# Changelog for persistent-discover++## Unreleased changes++## 0.1.0.0++- Initial Release

@@ -0,0 +1,30 @@+Copyright Matt Parsons (c) 2021++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 Matt Parsons 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.

@@ -0,0 +1,48 @@+# persistent-discover++![build status](https://github.com/parsonsmatt/persistent-discover/actions/workflows/haskell.yml/badge.svg)+++Supports automatic discovery of your+[`persistent`](https://hackage.haskell.org/package/persistent) models.++## As an executable++Let's say you've got a ton of `persistent` database models, all defined in a+module hierarchy like this:++```+src/+  Models/+    Foo.hs+    Bar.hs+    Baz.hs+    Blargh.hs+    What.hs+    OhNo.hs+```++If you're using `persistent` to automatically generate migrations, you'll want+to have all the `[EntityDef]` in scope from each module. You can do that by+importing each module that defines models and calling `$(discoverEntities)`,+introduced in `persistent-2.13`.++But you may forget to import a module.++This utility imports *all* the modules defined in the current directory and+sub-directories, and then it calls `$(discoverEntities)` for you.++To use it, place the following command in a file, located in the same directory+that your Haskell modules are in:++```+{-# OPTIONS_GHC -F -pgmF persistent-discover #-}+```++Let's say we put that in `src/Models/All.hs`.+This generates a module `Models.All` that exports a single item: `allEntities`,+which is a `[EntityDef]` and can be used by `migrateModels` to properly perform+migrations.++You'll need to add `persistent-discover` to the `build-tool-depends` on your cabal file+for this to work.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,18 @@+module Main where++import Database.Persist.Discover.Exe+import System.Environment (getArgs)++main :: IO ()+main = do+    args <- getArgs+    case args of+        src : _ : dest : _ ->+            discoverModels (Source src) (Destination dest)+        _ ->+            fail . mconcat $+               [ "persistent-discover: expected to be called with three arguments as an -F -pgmF preprocessor. got:"+               , show args+               ]++

@@ -0,0 +1,96 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 367368542f35766d0f032885ef0642293c2d78cc493e4ed99fdd2d71c68d68d2++name:           persistent-discover+version:        0.1.0.0+synopsis:       Persistent module discover utilities+description:    This package provides an executable for discovering Persistent model definition files, as well as a library function to glob all persistent model files. Please see the README on GitHub at <https://github.com/parsonsmatt/persistent-discover#readme>+category:       Web+homepage:       https://github.com/parsonsmatt/persistent-discover#readme+bug-reports:    https://github.com/parsonsmatt/persistent-discover/issues+author:         Matt Parsons+maintainer:     parsonsmatt@gmail.com+copyright:      Matt Parsons+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/parsonsmatt/persistent-discover++library+  exposed-modules:+      Database.Persist.Discover+      Database.Persist.Discover.Exe+      Lib+  other-modules:+      Paths_persistent_discover+  hs-source-dirs:+      ./src+  default-extensions: BlockArguments TypeFamilies FlexibleInstances MultiParamTypeClasses OverloadedStrings GeneralizedNewtypeDeriving DerivingStrategies TypeFamilies GADTs DerivingStrategies StandaloneDeriving DataKinds FlexibleInstances+  ghc-options: -Wall+  build-depends:+      base >=4.12 && <5+    , directory+    , dlist+    , file-embed+    , filepath+    , mtl+    , persistent >=2.13.0.0+    , template-haskell >=2.16.0.0+  default-language: Haskell2010++executable persistent-discover+  main-is: Main.hs+  other-modules:+      Paths_persistent_discover+  hs-source-dirs:+      app+  default-extensions: BlockArguments TypeFamilies FlexibleInstances MultiParamTypeClasses OverloadedStrings GeneralizedNewtypeDeriving DerivingStrategies TypeFamilies GADTs DerivingStrategies StandaloneDeriving DataKinds FlexibleInstances+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.12 && <5+    , directory+    , dlist+    , file-embed+    , filepath+    , mtl+    , persistent >=2.13.0.0+    , persistent-discover+    , template-haskell >=2.16.0.0+  default-language: Haskell2010++test-suite persistent-discover-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Database.Persist.Discover.ExeSpec+      Paths_persistent_discover+  hs-source-dirs:+      test+  default-extensions: BlockArguments TypeFamilies FlexibleInstances MultiParamTypeClasses OverloadedStrings GeneralizedNewtypeDeriving DerivingStrategies TypeFamilies GADTs DerivingStrategies StandaloneDeriving DataKinds FlexibleInstances+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      base >=4.12 && <5+    , directory+    , dlist+    , file-embed+    , filepath+    , hspec+    , hspec-discover+    , mtl+    , persistent >=2.13.0.0+    , persistent-discover+    , template-haskell >=2.16.0.0+  default-language: Haskell2010

@@ -0,0 +1,33 @@+-- |+--+-- @since 0.1.0.0+module Database.Persist.Discover+    ( findPersistentModelFiles+    ) where++import Database.Persist.Discover.Exe (getFilesRecursive, stripSuffix)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Data.FileEmbed++-- | Returns a list of all files with the @.persistentmodels@ suffix.+--+-- > allFiles :: [FilePath]+-- > allFiles = $$(findPersistentModelFiles "config/models/")+--+-- @since 0.1.0.0+findPersistentModelFiles+    :: FilePath+    -- ^ The root directory to search from.+    -> Q (TExp [FilePath])+findPersistentModelFiles root = do+    projectRoot <- makeRelativeToProject root+    files <- runIO $ filter isPersistentModelFile <$> getFilesRecursive projectRoot+    liftTyped files+  where+    isPersistentModelFile filename =+        case stripSuffix ".persistentmodels" filename of+            Just _ ->+                True+            _ ->+                False

@@ -0,0 +1,214 @@+-- |  This module contains types, definitions, and the logic behind+-- finding persistent definitions.+--+-- In brief, we do an import of all the models defined in the current+-- directory or any subdirectories. These imports are "instances only"+-- imports. Then we splice in @$(discoverEntities)@ to+--+-- The result module is named @All@, and it's placed in the hierarchy where+-- you define this. So if you have a source file:+--+-- @+-- -- src/PersistentModels/All.hs+--+-- {-# OPTIONS_GHC -F -pgmF persistent-discover+-- @+--+-- Then it will translate to:+--+-- @+-- -- src/PersistentModels/All.hs+--+-- module PersistentModels.All where+--+-- import PersistentModels.Foo ()+-- import PersistentModels.Bar ()+-- import PersistentModels.Baz ()+--+-- allEntityDefs :: [EntityDef]+-- allEntityDefs = $(discoverEntities)+-- @+--+-- @since 0.1.0.0+module Database.Persist.Discover.Exe where++import System.FilePath+import Control.Monad.State+import Data.String+import Data.DList (DList(..))+import qualified Data.DList as DList+import Data.Foldable (for_)+import System.Directory+import Data.List+import Data.Char+import Control.Applicative+import Data.Maybe++newtype Source = Source FilePath++newtype Destination = Destination FilePath++data AllModelsFile = AllModelsFile+    { amfModuleBase :: Module+    , amfModuleImports :: [Module]+    }++render :: Render -> String+render action =+    unlines $ DList.toList $ execState (unRender action) mempty++renderLine :: Render -> Render+renderLine action =+    fromString $ mconcat $ DList.toList $ execState (unRender action) mempty++newtype Render' a = Render { unRender :: State (DList String) a }+    deriving newtype+        (Functor, Applicative, Monad)++type Render = Render' ()++instance (a ~ ()) => IsString (Render' a) where+    fromString str =+        Render (modify (\s -> s <> pure str))++indent :: Int -> Render -> Render+indent i doc =+    Render do+        let+            new =+                fmap (replicate i ' ' <>)+                $ execState (unRender doc) mempty+        modify (<> new)++-- |+--+-- @since 0.1.0.0+discoverModels+    :: Source+    -> Destination+    -> IO ()+discoverModels (Source src) (Destination dest) = do+    let (dir, file) = splitFileName src+    files <- filter (/= file) <$> getFilesRecursive dir+    let+        input =+            AllModelsFile+                { amfModuleBase =+                    fromJust $ pathToModule src+                , amfModuleImports =+                    mapMaybe pathToModule (fmap (dir </>) files)+                }+        output =+            renderFile input++    writeFile dest output++-- | Returns a list of relative paths to all files in the given directory.+getFilesRecursive :: FilePath      -- ^ The directory to search.+                  -> IO [FilePath]+getFilesRecursive baseDir = sort <$> go []+  where+    go :: FilePath -> IO [FilePath]+    go dir = do+      c <- map (dir </>) . filter (`notElem` [".", ".."]) <$> getDirectoryContents (baseDir </> dir)+      dirs <- filterM (doesDirectoryExist . (baseDir </>)) c >>= mapM go+      files <- filterM (doesFileExist . (baseDir </>)) c+      return (files ++ concat dirs)++renderFile+    :: AllModelsFile+    -> String+renderFile amf = render do+    let+        modName =+            moduleName $ amfModuleBase amf+    renderLine do+        "{-# LINE 1 "+        fromString $ show modName+        " #-}"+    ""+    renderLine do+        "module "+        fromString $ modName+        " where"+    ""+    for_ (amfModuleImports amf) \mod' ->+        renderLine do+            "import "+            fromString $ moduleName mod'+            " ()"+    ""+    "import Database.Persist.TH (discoverEntities)"+    "import Database.Persist.Types (EntityDef)"+    ""+    "-- | All of the entity definitions, as discovered by the @persistent-discover@ utility."+    "allEntityDefs :: [EntityDef]"+    "allEntityDefs = $(discoverEntities)"++-- -- | Derive module name from specified path.+-- pathToModule :: FilePath -> Module+-- pathToModule f =+--     Module+--         { moduleName =+--             intercalate "." $ mapMaybe go $ splitDirectories f+--         , modulePath =+--             f+--         }+--   where+--     go :: String -> Maybe String+--     go (c:cs) =+--         Just (toUpper c : cs)+--     fileName = last $ splitDirectories f+--     m:ms = takeWhile (/='.') fileName++data Module = Module+    { moduleName :: String+    , modulePath :: FilePath+    }+    deriving (Eq, Show)++mkModulePieces+    :: FilePath+    -> [String]+mkModulePieces fp =+    fmap dropSuffixes $ dropWhile isLowerFirst $ filter noDots $ splitDirectories fp+  where+    noDots x =+        "." /= x && ".." /= x+    dropSuffixes str =+        fromMaybe str+            $ stripSuffix ".hs" str+            <|> stripSuffix ".lhs" str++isLowerFirst :: String -> Bool+isLowerFirst [] = True+isLowerFirst (c:_) = isLower c+++pathToModule+    :: FilePath+    -> Maybe Module+pathToModule file = do+    case mkModulePieces file of+        [] ->+            empty+        x:xs ->  do+            pure (Module (intercalate "." (x:xs)) file)++-- | Returns True if the given string is a valid task module name.+-- See `Cabal.Distribution.ModuleName` (http://git.io/bj34)+isValidModuleName :: String -> Bool+isValidModuleName []     = False+isValidModuleName (c:cs) = isUpper c && all isValidModuleChar cs++-- | Returns True if the given Char is a valid taks module character.+isValidModuleChar :: Char -> Bool+isValidModuleChar c = isAlphaNum c || c == '_' || c == '\''++-- | Convert a String in camel case to snake case.+casify :: String -> String+casify str = intercalate "_" $ groupBy (\a b -> isUpper a && isLower b) str++stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix suffix str =+    reverse <$> stripPrefix (reverse suffix) (reverse str)

@@ -0,0 +1,6 @@+module Lib+    ( someFunc+    ) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"

@@ -0,0 +1,56 @@+module Database.Persist.Discover.ExeSpec where++import Test.Hspec+import Database.Persist.Discover.Exe+import System.FilePath++spec :: Spec+spec = do+    describe "Render" do+        it "works" do+            shouldBe+                do render do+                    "hello"+                    "world"+                do+                    "hello\nworld\n"+        describe "indent" do+            it "works" do+                shouldBe+                    do render do+                        "hello"+                        indent 4 do+                            "world"+                        "goodbye"+                    do+                        "hello\n    world\ngoodbye\n"++    describe "mkModulePieces" do+        let+            exPath =+                "src/Foo/Bar.hs"+        it "works" do+            mkModulePieces exPath+                `shouldBe`+                    ["Foo", "Bar"]+++    describe "pathToModule" do+        let+            exPath =+                "./src/Foo/Bar.hs"+            (dir, file) =+                splitFileName exPath+        it "splits how i expect" $ do+            dir `shouldBe` "./src/Foo/"+            file `shouldBe` "Bar.hs"+        it "works" do+            pathToModule exPath+                `shouldBe`+                    Just Module+                        { moduleName =+                            "Foo.Bar"+                        , modulePath =+                            exPath+                        }+

@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+