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
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
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
Ord, Int -> Scope -> ShowS
[Scope] -> ShowS
Scope -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Scope] -> ShowS
$cshowList :: [Scope] -> ShowS
show :: Scope -> FilePath
$cshow :: Scope -> FilePath
showsPrec :: Int -> Scope -> ShowS
$cshowsPrec :: Int -> Scope -> ShowS
Show, Int -> Scope
Scope -> Int
Scope -> [Scope]
Scope -> Scope
Scope -> Scope -> [Scope]
Scope -> Scope -> Scope -> [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
forall a. a -> a -> Bounded a
maxBound :: Scope
$cmaxBound :: Scope
minBound :: Scope
$cminBound :: Scope
Bounded, 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 -> FilePath -> Q [Dec]
filePaths = (FilePath -> [[FilePath]] -> Q [Dec])
-> Scope -> FilePath -> Q [Dec]
mkDeclsWith 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 <- forall a. Ord a => [a] -> [a]
List.sort [[FilePath]]
fs
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
TH.LitE forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Lit
TH.StringL forall a b. (a -> b) -> a -> b
$
            [FilePath] -> FilePath
joinPath (FilePath
fp forall a. a -> [a] -> [a]
: [FilePath]
segments)

      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 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 =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char
replace forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toUpper) forall a b. (a -> b) -> a -> b
$
              forall a. [a] -> [[a]] -> [a]
List.intercalate FilePath
"_" [FilePath]
segments

        Type
patType <- [t| FilePath |]
        let pat :: Pat
pat = Lit -> Pat
TH.LitP forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Lit
TH.StringL forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
joinPath (FilePath
fp forall a. a -> [a] -> [a]
: [FilePath]
segments)

        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 =
  forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (Scope -> FilePath -> IO [[FilePath]]
getFileListPieces Scope
scope FilePath
fp) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> [[FilePath]] -> Q [Dec]
mkDecl FilePath
fp

-- XXX: Initially sourced from yesod-static
getFileListPieces :: Scope -> FilePath -> IO [[String]]
getFileListPieces :: Scope -> FilePath -> IO [[FilePath]]
getFileListPieces Scope
scope FilePath
rootPath = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (([FilePath] -> [FilePath])
-> FilePath -> StateT (Map FilePath FilePath) IO [[FilePath]]
go forall a. a -> a
id FilePath
rootPath) 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => FilePath -> m [FilePath]
getDirectoryContents FilePath
parentPath
      ([(FilePath, FilePath)]
dirs, [FilePath]
files) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall {m :: * -> *} {a}.
MonadIO m =>
(a -> FilePath)
-> ([(a, FilePath)], [a]) -> a -> m ([(a, FilePath)], [a])
partitionContents ShowS
expandPath) (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
notHidden [FilePath]
rawContents

      [[[FilePath]]]
inner <- 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) FilePath
path) FilePath
fullPath

      let collect :: [FilePath] -> StateT (Map FilePath FilePath) IO [[FilePath]]
collect = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> StateT (Map FilePath FilePath) IO FilePath
dedupe forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
prefixF forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(FilePath, FilePath)]
dirs
        Scope
Files -> do
          [FilePath] -> StateT (Map FilePath FilePath) IO [[FilePath]]
collect [FilePath]
files

      pure $ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]]
current 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 <- forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesDirectoryExist FilePath
fullPath
      if Bool
isDir then
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( (a
path, FilePath
fullPath) forall a. a -> [a] -> [a]
: [(a, FilePath)]
accDirs
          , [a]
accFiles
          )
      else do
        Bool
isFile <- forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist FilePath
fullPath
        if Bool
isFile then
          forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( [(a, FilePath)]
accDirs
            , a
path forall a. a -> [a] -> [a]
: [a]
accFiles
            )
        else
          -- XXX: skip weird stuff
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(a, FilePath)], [a])
acc

    -- | Reuse data buffers for identical strings
    dedupe :: String -> StateT (Map String String) IO String
    dedupe :: FilePath -> StateT (Map FilePath FilePath) IO FilePath
dedupe FilePath
s = do
      Map FilePath FilePath
m <- forall s (m :: * -> *). MonadState s m => m s
get
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
s Map FilePath FilePath
m of
        Just FilePath
seen ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
seen
        Maybe FilePath
Nothing -> do
          forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ 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