module Resource.Static where
import RIO
import Data.Char (isDigit, isUpper, toUpper)
import Language.Haskell.TH (Q, Dec)
import Language.Haskell.TH.Syntax (qRunIO)
import RIO.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
import RIO.FilePath (combine, joinPath)
import RIO.State (StateT, evalStateT, get, put)
import qualified Language.Haskell.TH.Syntax as TH
import qualified RIO.List as List
import qualified RIO.Map as Map
data Scope
= Files
| Dirs
deriving (Scope -> Scope -> Bool
(Scope -> Scope -> Bool) -> (Scope -> Scope -> Bool) -> Eq Scope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Scope -> Scope -> Bool
== :: Scope -> Scope -> Bool
$c/= :: Scope -> Scope -> Bool
/= :: Scope -> Scope -> Bool
Eq, Eq Scope
Eq Scope
-> (Scope -> Scope -> Ordering)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Bool)
-> (Scope -> Scope -> Scope)
-> (Scope -> Scope -> Scope)
-> Ord Scope
Scope -> Scope -> Bool
Scope -> Scope -> Ordering
Scope -> Scope -> Scope
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Scope -> Scope -> Ordering
compare :: Scope -> Scope -> Ordering
$c< :: Scope -> Scope -> Bool
< :: Scope -> Scope -> Bool
$c<= :: Scope -> Scope -> Bool
<= :: Scope -> Scope -> Bool
$c> :: Scope -> Scope -> Bool
> :: Scope -> Scope -> Bool
$c>= :: Scope -> Scope -> Bool
>= :: Scope -> Scope -> Bool
$cmax :: Scope -> Scope -> Scope
max :: Scope -> Scope -> Scope
$cmin :: Scope -> Scope -> Scope
min :: Scope -> Scope -> Scope
Ord, Int -> Scope -> ShowS
[Scope] -> ShowS
Scope -> FilePath
(Int -> Scope -> ShowS)
-> (Scope -> FilePath) -> ([Scope] -> ShowS) -> Show Scope
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Scope -> ShowS
showsPrec :: Int -> Scope -> ShowS
$cshow :: Scope -> FilePath
show :: Scope -> FilePath
$cshowList :: [Scope] -> ShowS
showList :: [Scope] -> ShowS
Show, Int -> Scope
Scope -> Int
Scope -> [Scope]
Scope -> Scope
Scope -> Scope -> [Scope]
Scope -> Scope -> Scope -> [Scope]
(Scope -> Scope)
-> (Scope -> Scope)
-> (Int -> Scope)
-> (Scope -> Int)
-> (Scope -> [Scope])
-> (Scope -> Scope -> [Scope])
-> (Scope -> Scope -> [Scope])
-> (Scope -> Scope -> Scope -> [Scope])
-> Enum Scope
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Scope -> Scope
succ :: Scope -> Scope
$cpred :: Scope -> Scope
pred :: Scope -> Scope
$ctoEnum :: Int -> Scope
toEnum :: Int -> Scope
$cfromEnum :: Scope -> Int
fromEnum :: Scope -> Int
$cenumFrom :: Scope -> [Scope]
enumFrom :: Scope -> [Scope]
$cenumFromThen :: Scope -> Scope -> [Scope]
enumFromThen :: Scope -> Scope -> [Scope]
$cenumFromTo :: Scope -> Scope -> [Scope]
enumFromTo :: Scope -> Scope -> [Scope]
$cenumFromThenTo :: Scope -> Scope -> Scope -> [Scope]
enumFromThenTo :: Scope -> Scope -> Scope -> [Scope]
Enum, Scope
Scope -> Scope -> Bounded Scope
forall a. a -> a -> Bounded a
$cminBound :: Scope
minBound :: Scope
$cmaxBound :: Scope
maxBound :: Scope
Bounded, (forall x. Scope -> Rep Scope x)
-> (forall x. Rep Scope x -> Scope) -> Generic Scope
forall x. Rep Scope x -> Scope
forall x. Scope -> Rep Scope x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Scope -> Rep Scope x
from :: forall x. Scope -> Rep Scope x
$cto :: forall x. Rep Scope x -> Scope
to :: forall x. Rep Scope x -> Scope
Generic)
filePaths :: Scope -> FilePath -> Q [Dec]
filePaths :: Scope -> FilePath -> Q [Dec]
filePaths = (FilePath -> [[FilePath]] -> Q [Dec])
-> Scope -> FilePath -> Q [Dec]
mkDeclsWith FilePath -> [[FilePath]] -> Q [Dec]
forall {m :: * -> *}.
Quote m =>
FilePath -> [[FilePath]] -> m [Dec]
mkPattern
where
mkPattern :: FilePath -> [[FilePath]] -> m [Dec]
mkPattern FilePath
fp [[FilePath]]
fs = do
let name :: Name
name = FilePath -> Name
TH.mkName FilePath
"paths"
Type
sigType <- [t| [FilePath] |]
let
body :: Exp
body = [Exp] -> Exp
TH.ListE do
[FilePath]
segments <- [[FilePath]] -> [[FilePath]]
forall a. Ord a => [a] -> [a]
List.sort [[FilePath]]
fs
Exp -> [Exp]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> [Exp]) -> (FilePath -> Exp) -> FilePath -> [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
TH.LitE (Lit -> Exp) -> (FilePath -> Lit) -> FilePath -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Lit
TH.StringL (FilePath -> [Exp]) -> FilePath -> [Exp]
forall a b. (a -> b) -> a -> b
$
[FilePath] -> FilePath
joinPath (FilePath
fp FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
segments)
[Dec] -> m [Dec]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Name -> Type -> Dec
TH.SigD Name
name Type
sigType
, Name -> [Clause] -> Dec
TH.FunD Name
name [[Pat] -> Body -> [Dec] -> Clause
TH.Clause [] (Exp -> Body
TH.NormalB Exp
body) []]
]
filePatterns :: Scope -> FilePath -> Q [Dec]
filePatterns :: Scope -> FilePath -> Q [Dec]
filePatterns = (FilePath -> [[FilePath]] -> Q [Dec])
-> Scope -> FilePath -> Q [Dec]
mkDeclsWith FilePath -> [[FilePath]] -> Q [Dec]
forall {t :: * -> *} {f :: * -> *}.
(Traversable t, Quote f) =>
FilePath -> t [FilePath] -> f [Dec]
mkPattern
where
mkPattern :: FilePath -> t [FilePath] -> f [Dec]
mkPattern FilePath
fp t [FilePath]
fs =
(t [Dec] -> [Dec]) -> f (t [Dec]) -> f [Dec]
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t [Dec] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (f (t [Dec]) -> f [Dec]) -> f (t [Dec]) -> f [Dec]
forall a b. (a -> b) -> a -> b
$ t [FilePath] -> ([FilePath] -> f [Dec]) -> f (t [Dec])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for t [FilePath]
fs \[FilePath]
segments -> do
let
name :: Name
name =
FilePath -> Name
TH.mkName (FilePath -> Name) -> ShowS -> FilePath -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char
replace (Char -> Char) -> (Char -> Char) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toUpper) (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$
FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
List.intercalate FilePath
"_" [FilePath]
segments
Type
patType <- [t| FilePath |]
let pat :: Pat
pat = Lit -> Pat
TH.LitP (Lit -> Pat) -> (FilePath -> Lit) -> FilePath -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Lit
TH.StringL (FilePath -> Pat) -> FilePath -> Pat
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
joinPath (FilePath
fp FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
segments)
[Dec] -> f [Dec]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Name -> Type -> Dec
TH.PatSynSigD Name
name Type
patType
, Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
TH.PatSynD Name
name ([Name] -> PatSynArgs
TH.PrefixPatSyn []) PatSynDir
TH.ImplBidir Pat
pat
]
replace :: Char -> Char
replace Char
c =
if Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c then
Char
c
else
Char
'_'
mkDeclsWith
:: (FilePath -> [[String]] -> Q [Dec])
-> Scope
-> FilePath
-> Q [Dec]
mkDeclsWith :: (FilePath -> [[FilePath]] -> Q [Dec])
-> Scope -> FilePath -> Q [Dec]
mkDeclsWith FilePath -> [[FilePath]] -> Q [Dec]
mkDecl Scope
scope FilePath
fp =
IO [[FilePath]] -> Q [[FilePath]]
forall a. IO a -> Q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (Scope -> FilePath -> IO [[FilePath]]
getFileListPieces Scope
scope FilePath
fp) Q [[FilePath]] -> ([[FilePath]] -> Q [Dec]) -> Q [Dec]
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> [[FilePath]] -> Q [Dec]
mkDecl FilePath
fp
getFileListPieces :: Scope -> FilePath -> IO [[String]]
getFileListPieces :: Scope -> FilePath -> IO [[FilePath]]
getFileListPieces Scope
scope FilePath
rootPath = StateT (Map FilePath FilePath) IO [[FilePath]]
-> Map FilePath FilePath -> IO [[FilePath]]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (([FilePath] -> [FilePath])
-> FilePath -> StateT (Map FilePath FilePath) IO [[FilePath]]
go [FilePath] -> [FilePath]
forall a. a -> a
id FilePath
rootPath) Map FilePath FilePath
forall a. Monoid a => a
mempty
where
go
:: ([String] -> [String])
-> String
-> StateT (Map.Map String String) IO [[String]]
go :: ([FilePath] -> [FilePath])
-> FilePath -> StateT (Map FilePath FilePath) IO [[FilePath]]
go [FilePath] -> [FilePath]
prefixF FilePath
parentPath = do
let expandPath :: ShowS
expandPath = FilePath -> ShowS
combine FilePath
parentPath
[FilePath]
rawContents <- IO [FilePath] -> StateT (Map FilePath FilePath) IO [FilePath]
forall a. IO a -> StateT (Map FilePath FilePath) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> StateT (Map FilePath FilePath) IO [FilePath])
-> IO [FilePath] -> StateT (Map FilePath FilePath) IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
forall (m :: * -> *). MonadIO m => FilePath -> m [FilePath]
getDirectoryContents FilePath
parentPath
([(FilePath, FilePath)]
dirs, [FilePath]
files) <- (([(FilePath, FilePath)], [FilePath])
-> FilePath
-> StateT
(Map FilePath FilePath) IO ([(FilePath, FilePath)], [FilePath]))
-> ([(FilePath, FilePath)], [FilePath])
-> [FilePath]
-> StateT
(Map FilePath FilePath) IO ([(FilePath, FilePath)], [FilePath])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (ShowS
-> ([(FilePath, FilePath)], [FilePath])
-> FilePath
-> StateT
(Map FilePath FilePath) IO ([(FilePath, FilePath)], [FilePath])
forall {m :: * -> *} {a}.
MonadIO m =>
(a -> FilePath)
-> ([(a, FilePath)], [a]) -> a -> m ([(a, FilePath)], [a])
partitionContents ShowS
expandPath) ([(FilePath, FilePath)]
forall a. Monoid a => a
mempty, [FilePath]
forall a. Monoid a => a
mempty) ([FilePath]
-> StateT
(Map FilePath FilePath) IO ([(FilePath, FilePath)], [FilePath]))
-> [FilePath]
-> StateT
(Map FilePath FilePath) IO ([(FilePath, FilePath)], [FilePath])
forall a b. (a -> b) -> a -> b
$
(FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
notHidden [FilePath]
rawContents
[[[FilePath]]]
inner <- [(FilePath, FilePath)]
-> ((FilePath, FilePath)
-> StateT (Map FilePath FilePath) IO [[FilePath]])
-> StateT (Map FilePath FilePath) IO [[[FilePath]]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(FilePath, FilePath)]
dirs \(FilePath
path, FilePath
fullPath) ->
([FilePath] -> [FilePath])
-> FilePath -> StateT (Map FilePath FilePath) IO [[FilePath]]
go ([FilePath] -> [FilePath]
prefixF ([FilePath] -> [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) FilePath
path) FilePath
fullPath
let collect :: [FilePath] -> StateT (Map FilePath FilePath) IO [[FilePath]]
collect = (FilePath -> StateT (Map FilePath FilePath) IO [FilePath])
-> [FilePath] -> StateT (Map FilePath FilePath) IO [[FilePath]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((FilePath -> StateT (Map FilePath FilePath) IO [FilePath])
-> [FilePath] -> StateT (Map FilePath FilePath) IO [[FilePath]])
-> (FilePath -> StateT (Map FilePath FilePath) IO [FilePath])
-> [FilePath]
-> StateT (Map FilePath FilePath) IO [[FilePath]]
forall a b. (a -> b) -> a -> b
$ (FilePath -> StateT (Map FilePath FilePath) IO FilePath)
-> [FilePath] -> StateT (Map FilePath FilePath) IO [FilePath]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse FilePath -> StateT (Map FilePath FilePath) IO FilePath
dedupe ([FilePath] -> StateT (Map FilePath FilePath) IO [FilePath])
-> (FilePath -> [FilePath])
-> FilePath
-> StateT (Map FilePath FilePath) IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
prefixF ([FilePath] -> [FilePath])
-> (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[[FilePath]]
current <- case Scope
scope of
Scope
Dirs ->
[FilePath] -> StateT (Map FilePath FilePath) IO [[FilePath]]
collect ([FilePath] -> StateT (Map FilePath FilePath) IO [[FilePath]])
-> [FilePath] -> StateT (Map FilePath FilePath) IO [[FilePath]]
forall a b. (a -> b) -> a -> b
$ ((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd [(FilePath, FilePath)]
dirs
Scope
Files -> do
[FilePath] -> StateT (Map FilePath FilePath) IO [[FilePath]]
collect [FilePath]
files
pure $ [[[FilePath]]] -> [[FilePath]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]]
current [[FilePath]] -> [[[FilePath]]] -> [[[FilePath]]]
forall a. a -> [a] -> [a]
: [[[FilePath]]]
inner)
partitionContents :: (a -> FilePath)
-> ([(a, FilePath)], [a]) -> a -> m ([(a, FilePath)], [a])
partitionContents a -> FilePath
expandPath acc :: ([(a, FilePath)], [a])
acc@([(a, FilePath)]
accDirs, [a]
accFiles) a
path = do
let fullPath :: FilePath
fullPath = a -> FilePath
expandPath a
path
Bool
isDir <- FilePath -> m Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesDirectoryExist FilePath
fullPath
if Bool
isDir then
([(a, FilePath)], [a]) -> m ([(a, FilePath)], [a])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( (a
path, FilePath
fullPath) (a, FilePath) -> [(a, FilePath)] -> [(a, FilePath)]
forall a. a -> [a] -> [a]
: [(a, FilePath)]
accDirs
, [a]
accFiles
)
else do
Bool
isFile <- FilePath -> m Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist FilePath
fullPath
if Bool
isFile then
([(a, FilePath)], [a]) -> m ([(a, FilePath)], [a])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( [(a, FilePath)]
accDirs
, a
path a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
accFiles
)
else
([(a, FilePath)], [a]) -> m ([(a, FilePath)], [a])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(a, FilePath)], [a])
acc
dedupe :: String -> StateT (Map String String) IO String
dedupe :: FilePath -> StateT (Map FilePath FilePath) IO FilePath
dedupe FilePath
s = do
Map FilePath FilePath
m <- StateT (Map FilePath FilePath) IO (Map FilePath FilePath)
forall s (m :: * -> *). MonadState s m => m s
get
case FilePath -> Map FilePath FilePath -> Maybe FilePath
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
s Map FilePath FilePath
m of
Just FilePath
seen ->
FilePath -> StateT (Map FilePath FilePath) IO FilePath
forall a. a -> StateT (Map FilePath FilePath) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
seen
Maybe FilePath
Nothing -> do
Map FilePath FilePath -> StateT (Map FilePath FilePath) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Map FilePath FilePath -> StateT (Map FilePath FilePath) IO ())
-> Map FilePath FilePath -> StateT (Map FilePath FilePath) IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
-> FilePath -> Map FilePath FilePath -> Map FilePath FilePath
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
s FilePath
s Map FilePath FilePath
m
pure FilePath
s
notHidden :: FilePath -> Bool
notHidden :: FilePath -> Bool
notHidden = \case
FilePath
"tmp" -> Bool
False
Char
'.' : FilePath
_ -> Bool
False
FilePath
_ -> Bool
True