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