-- |  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
    { AllModelsFile -> Module
amfModuleBase :: Module
    , AllModelsFile -> [Module]
amfModuleImports :: [Module]
    }

render :: Render -> String
render :: Render -> String
render Render
action =
    [String] -> String
unlines forall a b. (a -> b) -> a -> b
$ forall a. DList a -> [a]
DList.toList forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState (forall a. Render' a -> State (DList String) a
unRender Render
action) forall a. Monoid a => a
mempty

renderLine :: Render -> Render
renderLine :: Render -> Render
renderLine Render
action =
    forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. DList a -> [a]
DList.toList forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState (forall a. Render' a -> State (DList String) a
unRender Render
action) forall a. Monoid a => a
mempty

newtype Render' a = Render { forall a. Render' a -> State (DList String) a
unRender :: State (DList String) a }
    deriving newtype
        (forall a b. a -> Render' b -> Render' a
forall a b. (a -> b) -> Render' a -> Render' b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Render' b -> Render' a
$c<$ :: forall a b. a -> Render' b -> Render' a
fmap :: forall a b. (a -> b) -> Render' a -> Render' b
$cfmap :: forall a b. (a -> b) -> Render' a -> Render' b
Functor, Functor Render'
forall a. a -> Render' a
forall a b. Render' a -> Render' b -> Render' a
forall a b. Render' a -> Render' b -> Render' b
forall a b. Render' (a -> b) -> Render' a -> Render' b
forall a b c. (a -> b -> c) -> Render' a -> Render' b -> Render' c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Render' a -> Render' b -> Render' a
$c<* :: forall a b. Render' a -> Render' b -> Render' a
*> :: forall a b. Render' a -> Render' b -> Render' b
$c*> :: forall a b. Render' a -> Render' b -> Render' b
liftA2 :: forall a b c. (a -> b -> c) -> Render' a -> Render' b -> Render' c
$cliftA2 :: forall a b c. (a -> b -> c) -> Render' a -> Render' b -> Render' c
<*> :: forall a b. Render' (a -> b) -> Render' a -> Render' b
$c<*> :: forall a b. Render' (a -> b) -> Render' a -> Render' b
pure :: forall a. a -> Render' a
$cpure :: forall a. a -> Render' a
Applicative, Applicative Render'
forall a. a -> Render' a
forall a b. Render' a -> Render' b -> Render' b
forall a b. Render' a -> (a -> Render' b) -> Render' b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Render' a
$creturn :: forall a. a -> Render' a
>> :: forall a b. Render' a -> Render' b -> Render' b
$c>> :: forall a b. Render' a -> Render' b -> Render' b
>>= :: forall a b. Render' a -> (a -> Render' b) -> Render' b
$c>>= :: forall a b. Render' a -> (a -> Render' b) -> Render' b
Monad)

type Render = Render' ()

instance (a ~ ()) => IsString (Render' a) where
    fromString :: String -> Render' a
fromString String
str =
        forall a. State (DList String) a -> Render' a
Render (forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\DList String
s -> DList String
s forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
str))

indent :: Int -> Render -> Render
indent :: Int -> Render -> Render
indent Int
i Render
doc =
    forall a. State (DList String) a -> Render' a
Render do
        let
            new :: DList String
new =
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Int -> a -> [a]
replicate Int
i Char
' ' forall a. Semigroup a => a -> a -> a
<>)
                forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState (forall a. Render' a -> State (DList String) a
unRender Render
doc) forall a. Monoid a => a
mempty
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Semigroup a => a -> a -> a
<> DList String
new)

-- |
--
-- @since 0.1.0.0
discoverModels
    :: Source
    -> Destination
    -> IO ()
discoverModels :: Source -> Destination -> IO ()
discoverModels (Source String
src) (Destination String
dest) = do
    let (String
dir, String
file) = String -> (String, String)
splitFileName String
src
    [String]
files <- forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= String
file) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getFilesRecursive String
dir
    let
        input :: AllModelsFile
input =
            AllModelsFile
                { amfModuleBase :: Module
amfModuleBase =
                    forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ String -> Maybe Module
pathToModule String
src
                , amfModuleImports :: [Module]
amfModuleImports =
                    forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe Module
pathToModule (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
dir String -> String -> String
</>) [String]
files)
                }
        output :: String
output =
            AllModelsFile -> String
renderFile AllModelsFile
input

    String -> String -> IO ()
writeFile String
dest String
output

-- | Returns a list of relative paths to all files in the given directory.
getFilesRecursive :: FilePath      -- ^ The directory to search.
                  -> IO [FilePath]
getFilesRecursive :: String -> IO [String]
getFilesRecursive String
baseDir = forall a. Ord a => [a] -> [a]
sort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
go []
  where
    go :: FilePath -> IO [FilePath]
    go :: String -> IO [String]
go String
dir = do
      [String]
c <- forall a b. (a -> b) -> [a] -> [b]
map (String
dir String -> String -> String
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
".", String
".."]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents (String
baseDir String -> String -> String
</> String
dir)
      [[String]]
dirs <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesDirectoryExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
baseDir String -> String -> String
</>)) [String]
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
go
      [String]
files <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
baseDir String -> String -> String
</>)) [String]
c
      forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
files forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
dirs)

renderFile
    :: AllModelsFile
    -> String
renderFile :: AllModelsFile -> String
renderFile AllModelsFile
amf = Render -> String
render do
    let
        modName :: String
modName =
            Module -> String
moduleName forall a b. (a -> b) -> a -> b
$ AllModelsFile -> Module
amfModuleBase AllModelsFile
amf
    Render -> Render
renderLine do
        Render
"{-# LINE 1 "
        forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
modName
        Render
" #-}"
    Render
"{-# LANGUAGE TemplateHaskell #-}"
    Render
""
    Render -> Render
renderLine do
        Render
"module "
        forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String
modName
        Render
" where"
    Render
""
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (AllModelsFile -> [Module]
amfModuleImports AllModelsFile
amf) \Module
mod' ->
        Render -> Render
renderLine do
            Render
"import "
            forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Module -> String
moduleName Module
mod'
            Render
" ()"
    Render
""
    Render
"import Database.Persist.TH (discoverEntities)"
    Render
"import Database.Persist.Types (EntityDef)"
    Render
""
    Render
"-- | All of the entity definitions, as discovered by the @persistent-discover@ utility."
    Render
"allEntityDefs :: [EntityDef]"
    Render
"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
    { Module -> String
moduleName :: String
    , Module -> String
modulePath :: FilePath
    }
    deriving (Module -> Module -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Module -> Module -> Bool
$c/= :: Module -> Module -> Bool
== :: Module -> Module -> Bool
$c== :: Module -> Module -> Bool
Eq, Int -> Module -> String -> String
[Module] -> String -> String
Module -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Module] -> String -> String
$cshowList :: [Module] -> String -> String
show :: Module -> String
$cshow :: Module -> String
showsPrec :: Int -> Module -> String -> String
$cshowsPrec :: Int -> Module -> String -> String
Show)

mkModulePieces
    :: FilePath
    -> [String]
mkModulePieces :: String -> [String]
mkModulePieces String
fp = do
    let
        extension :: String
extension =
            String -> String
takeExtension String
fp
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
extension forall a. Eq a => a -> a -> Bool
== String
".hs" Bool -> Bool -> Bool
|| String
extension forall a. Eq a => a -> a -> Bool
== String
".lhs")
    forall a. [a] -> [a]
reverse
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isLowerFirst)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall {a}. (Eq a, IsString a) => a -> Bool
noDots
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropExtension
        forall a b. (a -> b) -> a -> b
$ String
fp
  where
    noDots :: a -> Bool
noDots a
x =
        a
"." forall a. Eq a => a -> a -> Bool
/= a
x Bool -> Bool -> Bool
&& a
".." forall a. Eq a => a -> a -> Bool
/= a
x

isLowerFirst :: String -> Bool
isLowerFirst :: String -> Bool
isLowerFirst [] = Bool
True
isLowerFirst (Char
c:String
_) = Char -> Bool
isLower Char
c

pathToModule
    :: FilePath
    -> Maybe Module
pathToModule :: String -> Maybe Module
pathToModule String
file = do
    case String -> [String]
mkModulePieces String
file of
        [] ->
            forall (f :: * -> *) a. Alternative f => f a
empty
        String
x : [String]
xs ->  do
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all String -> Bool
isValidModuleName (String
x forall a. a -> [a] -> [a]
: [String]
xs)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String -> Module
Module (forall a. [a] -> [[a]] -> [a]
intercalate String
"." (String
xforall a. a -> [a] -> [a]
:[String]
xs)) String
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 :: String -> Bool
isValidModuleName []     = Bool
False
isValidModuleName (Char
c:String
cs) = Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isValidModuleChar String
cs

-- | Returns True if the given Char is a valid taks module character.
isValidModuleChar :: Char -> Bool
isValidModuleChar :: Char -> Bool
isValidModuleChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\''

-- | Convert a String in camel case to snake case.
casify :: String -> String
casify :: String -> String
casify String
str = forall a. [a] -> [[a]] -> [a]
intercalate String
"_" forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\Char
a Char
b -> Char -> Bool
isUpper Char
a Bool -> Bool -> Bool
&& Char -> Bool
isLower Char
b) String
str

stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
stripSuffix :: forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [a]
suffix [a]
str =
    forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (forall a. [a] -> [a]
reverse [a]
suffix) (forall a. [a] -> [a]
reverse [a]
str)