Static.hs

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 (Eq, Ord, Show, Enum, Bounded, Generic)

filePaths :: Scope -> FilePath -> Q [Dec]
filePaths = mkDeclsWith mkPattern
  where
    mkPattern fp fs = do
      let name = TH.mkName "paths"

      sigType <- [t| [FilePath] |]

      let
        body = TH.ListE do
          segments <- List.sort fs
          pure . TH.LitE . TH.StringL $
            joinPath (fp : segments)

      pure
        [ TH.SigD name sigType
        , TH.FunD name [TH.Clause [] (TH.NormalB body) []]
        ]

filePatterns :: Scope -> FilePath -> Q [Dec]
filePatterns = mkDeclsWith mkPattern
  where
    mkPattern fp fs =
      fmap concat $ for fs \segments -> do
        let
          name =
            TH.mkName . map (replace . toUpper) $
              List.intercalate "_" segments

        patType <- [t| FilePath |]
        let pat = TH.LitP . TH.StringL $ joinPath (fp : segments)

        pure
          [ TH.PatSynSigD name patType
          , TH.PatSynD name (TH.PrefixPatSyn []) TH.ImplBidir pat
          ]

    replace c =
      if isUpper c || isDigit c then
        c
      else
        '_'

mkDeclsWith
  :: (FilePath -> [[String]] -> Q [Dec])
  -> Scope
  -> FilePath
  -> Q [Dec]
mkDeclsWith mkDecl scope fp =
  qRunIO (getFileListPieces scope fp) >>= mkDecl fp

-- XXX: Initially sourced from yesod-static
getFileListPieces :: Scope -> FilePath -> IO [[String]]
getFileListPieces scope rootPath = evalStateT (go id rootPath) mempty
  where
    go
      :: ([String] -> [String])
      -> String
      -> StateT (Map.Map String String) IO [[String]]
    go prefixF parentPath = do
      let expandPath = combine parentPath
      rawContents <- liftIO $ getDirectoryContents parentPath
      (dirs, files) <- foldM (partitionContents expandPath) (mempty, mempty) $
        filter notHidden rawContents

      inner <- for dirs \(path, fullPath) ->
        go (prefixF . (:) path) fullPath

      let collect = traverse $ traverse dedupe . prefixF . pure
      current <- case scope of
        Dirs ->
          collect $ map snd dirs
        Files -> do
          collect files

      pure $ concat (current : inner)

    partitionContents expandPath acc@(accDirs, accFiles) path = do
      let fullPath = expandPath path
      isDir <- doesDirectoryExist fullPath
      if isDir then
        pure
          ( (path, fullPath) : accDirs
          , accFiles
          )
      else do
        isFile <- doesFileExist fullPath
        if isFile then
          pure
            ( accDirs
            , path : accFiles
            )
        else
          -- XXX: skip weird stuff
          pure acc

    -- | Reuse data buffers for identical strings
    dedupe :: String -> StateT (Map String String) IO String
    dedupe s = do
      m <- get
      case Map.lookup s m of
        Just seen ->
          pure seen
        Nothing -> do
          put $ Map.insert s s m
          pure s

    notHidden :: FilePath -> Bool
    notHidden = \case
      "tmp"   -> False
      '.' : _ -> False
      _       -> True