-- | This preprocessor splices in imports to the file you define it in. Haskell
-- source files are discovered according to a glob relative to the file the code
-- is defined in. This utility is useful when metaprogramming with a group of
-- related files, where you want to use @TemplateHaskell@ or similar
--
-- By default, the glob is for all modules in the directory containing the
-- source file. Imports are qualified with the full module name to avoid
-- potential import conflicts. The pre-processor will splice in a top-level
-- value @_importedModules :: [String]@ which contains the fully qualified
-- names of the modules that were imported.
--
-- You may want to disable warnings for redundant imports, if you are only using
-- type class information. A future option to the library may only do empty
-- import lists, to only get access to type class instances.
--
-- As an example, consider the
-- <https://hackage.haskell.org/package/persistent-discover
-- @persistent-discover@> utility, which is inspired by @hspec-discover@. That
-- utility will perform the following transformation:
--
-- @
-- -- 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)
-- @
--
-- With this package, we can generalize the overall pattern. The new source
-- module will look like this:
--
-- @
-- -- src/PersistentModels/All.hs
--
-- {-# OPTIONS_GHC -F -pgmF glob-imports #-}
--
-- module PersistentModels.All where
--
-- import Database.Persist.Sql
-- {- GLOB_IMPORTS_SPLICE -}
--
-- allEntityDefs :: [EntityDef]
-- allEntityDefs = $(discoverEntities)
-- @
--
-- This preprocessor will convert this into this form:
--
-- @
-- -- src/PersistentModels/All.hs
--
-- module PersistentModels.All where
--
-- import Database.Persist.Sql
-- import qualified PersistentModels.Foo
-- import qualified PersistentModels.Bar
-- import qualified PersistentModels.Baz
--
-- allEntityDefs :: [EntityDef]
-- allEntityDefs = $(discoverEntities)
-- @
--
-- Note how the only difference is that imports have been spliced in. This
-- allows you to more flexibly customize how the code works.
--
-- @since 0.1.0.0
module GlobImports.Exe where

import System.FilePath
import Control.Monad (guard, filterM)
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

-- | The source file location. This is the first argument passed to the
-- preprocessor.
newtype Source = Source { Source -> String
unSource :: FilePath }

-- | The source file contents. This is the 'String' contained in the file of the
-- second argument passed to the preprocessor.
newtype SourceContents = SourceContents { SourceContents -> String
unSourceContents :: String }

-- | The destination file path to write the final source to. This is the third
-- argument passed to the preprocessor.
newtype Destination = Destination { Destination -> String
unDestination :: FilePath }

data AllModelsFile = AllModelsFile
    { AllModelsFile -> Module
amfModuleBase :: Module
    , AllModelsFile -> [Module]
amfModuleImports :: [Module]
    }

-- |
--
-- @since 0.1.0.0
spliceImports
    :: Source
    -> SourceContents
    -> Destination
    -> IO ()
spliceImports :: Source -> SourceContents -> Destination -> IO ()
spliceImports (Source String
src) (SourceContents String
srcContents) (Destination String
dest) = do
    let (String
dir, String
file) = String -> (String, String)
splitFileName String
src
    [String]
files <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
file) ([String] -> [String]) -> IO [String] -> IO [String]
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 =
                    Maybe Module -> Module
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Module -> Module) -> Maybe Module -> Module
forall a b. (a -> b) -> a -> b
$ String -> Maybe Module
pathToModule String
src
                , amfModuleImports :: [Module]
amfModuleImports =
                    (String -> Maybe Module) -> [String] -> [Module]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe Module
pathToModule ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
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 -> String
renderFile AllModelsFile
input String
srcContents

    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 = [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> IO [String] -> IO [String]
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 <- (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
dir String -> String -> String
</>) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
".", String
".."]) ([String] -> [String]) -> IO [String] -> IO [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 <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesDirectoryExist (String -> IO Bool) -> (String -> String) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
baseDir String -> String -> String
</>)) [String]
c IO [String] -> ([String] -> IO [[String]]) -> IO [[String]]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO [String]
go
      [String]
files <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist (String -> IO Bool) -> (String -> String) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
baseDir String -> String -> String
</>)) [String]
c
      [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
files [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
dirs)

renderFile
    :: AllModelsFile
    -> String
    -> String
renderFile :: AllModelsFile -> String -> String
renderFile AllModelsFile
amf String
originalContents =
    ([String] -> String) -> [[String]] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [String] -> String
unlines
        [ [String]
modulePrior
        , [String]
newImportLines
        , [String]
newModuleRest
        ]
  where
    originalLines :: [String]
originalLines =
        String -> [String]
lines String
originalContents

    ([String]
modulePrior, [String]
moduleRest) =
        case (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String
"GLOB_IMPORTS_SPLICE" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) [String]
originalLines of
            ([String]
_, []) ->
                String -> ([String], [String])
forall a. HasCallStack => String -> a
error (String -> ([String], [String])) -> String -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                    [ String
"While processing the module, I was unable to find a comment with GLOB_IMPORTS_SPLICE."
                    , String
"I need this to know where to splice imports into the file. Please add a comment like "
                    , String
"this to the source file in the import section: "
                    , String
""
                    , String
"-- GLOB_IMPORTS_SPLICE"
                    ]
            ([String]
prior, (String
_globImportLine : [String]
rest)) ->
                ([String]
prior, [String]
rest)

    newModuleRest :: [String]
newModuleRest =
        let
            ([String]
remainingModule, [String]
lastImportLine) =
                (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String
"import" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
moduleRest)
            quoteModuleName :: Module -> String
quoteModuleName Module
mod' =
                String
"\"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Module -> String
moduleName Module
mod' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\""
            mkFirstModuleLine :: Module -> String
mkFirstModuleLine Module
mod' =
                String
"  [ " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Module -> String
quoteModuleName Module
mod'
            mkRestModuleLine :: Module -> String
mkRestModuleLine Module
mod' =
                String
"  , " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Module -> String
quoteModuleName Module
mod'
            newLines :: [String]
newLines =
                [String] -> [String]
forall a. [a] -> [a]
reverse case AllModelsFile -> [Module]
amfModuleImports AllModelsFile
amf of
                    [] ->
                        []
                    (Module
firstModule : [Module]
restModules) ->
                        [ String
"_importedModules :: [String]"
                        , String
"_importedModules ="
                        , Module -> String
mkFirstModuleLine Module
firstModule
                        ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (Module -> String) -> [Module] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Module -> String
mkRestModuleLine [Module]
restModules
                          [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [ String
"  ]"]
         in
            [String] -> [String]
forall a. [a] -> [a]
reverse ([[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]
remainingModule, [String]
newLines, [String]
lastImportLine])

    newImportLines :: [String]
newImportLines =
        (Module -> String) -> [Module] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Module
mod' -> String
"import qualified " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Module -> String
moduleName Module
mod') (AllModelsFile -> [Module]
amfModuleImports AllModelsFile
amf)







--     render do
--     let
--         modName =
--             moduleName $ amfModuleBase amf
--     renderLine do
--         "{-# LINE 1 "
--         fromString $ show modName
--         " #-}"
--     "{-# LANGUAGE TemplateHaskell #-}"
--     ""
--     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 @glob-imports@ 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
    { Module -> String
moduleName :: String
    , Module -> String
modulePath :: FilePath
    }
    deriving (Module -> Module -> Bool
(Module -> Module -> Bool)
-> (Module -> Module -> Bool) -> Eq Module
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Module -> Module -> Bool
== :: Module -> Module -> Bool
$c/= :: Module -> Module -> Bool
/= :: Module -> Module -> Bool
Eq, Int -> Module -> String -> String
[Module] -> String -> String
Module -> String
(Int -> Module -> String -> String)
-> (Module -> String)
-> ([Module] -> String -> String)
-> Show Module
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Module -> String -> String
showsPrec :: Int -> Module -> String -> String
$cshow :: Module -> String
show :: Module -> String
$cshowList :: [Module] -> String -> String
showList :: [Module] -> String -> String
Show)

mkModulePieces
    :: FilePath
    -> [String]
mkModulePieces :: String -> [String]
mkModulePieces String
fp = do
    let
        extension :: String
extension =
            String -> String
takeExtension String
fp
    Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
extension String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".hs" Bool -> Bool -> Bool
|| String
extension String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".lhs")
    [String] -> [String]
forall a. [a] -> [a]
reverse
        ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isLowerFirst)
        ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse
        ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall {a}. (Eq a, IsString a) => a -> Bool
noDots
        ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories
        (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
dropExtension
        (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
fp
  where
    noDots :: a -> Bool
noDots a
x =
        a
"." a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
x Bool -> Bool -> Bool
&& a
".." a -> a -> Bool
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
        [] ->
            Maybe Module
forall a. Maybe a
forall (f :: * -> *) a. Alternative f => f a
empty
        String
x : [String]
xs ->  do
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all String -> Bool
isValidModuleName (String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs)
            Module -> Maybe Module
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Module
                { moduleName :: String
moduleName = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." (String
xString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs)
                , modulePath :: String
modulePath = 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
&& (Char -> Bool) -> String -> 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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
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 = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Char -> Bool) -> String -> [String]
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 =
    [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
suffix) ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
str)