Static.hs

module Resource.Static where

import RIO

import Data.Char (isDigit, isLower, isUpper, toUpper)
import Language.Haskell.TH (Q, Dec)
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax (qRunIO)
import Language.Haskell.TH.Syntax qualified as TH
import RIO.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
import RIO.FilePath (combine, joinPath)
import RIO.List qualified as List
import RIO.Map qualified as Map
import RIO.State (StateT, evalStateT, get, put)

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 $ patternName 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 :: Char -> Char
replace c =
  if isLower c || isUpper c || isDigit c then
    c
  else
    '_'

fieldName :: [[Char]] -> String
fieldName =
  map replace . List.takeWhile (/= '.') . List.intercalate "_"

patternName :: [[Char]] -> String
patternName =
  map (replace . toUpper) . List.intercalate "_"

collection :: [(String, TH.Name)] -> Scope -> FilePath -> Q [Dec]
collection prologue scope fp = do
  pattDecs <- filePatterns scope fp
  recDecs <- collectionRec prologue scope fp
  sourcesDecs <- sourcesVal prologue scope fp
  pure $ mconcat [recDecs, pattDecs, sourcesDecs]

collectionRec :: [(String, TH.Name)] -> Scope -> FilePath -> Q [Dec]
collectionRec prologue = mkDeclsWith mkRecord
  where
    mkRecord _fp fs = do
      let
        mkConstr = recC collName $
          map mkInclude prologue ++ map mkField (List.sort fs)

      appViaGen1 <- viaStrategy (conT (TH.mkName "Generically1") `appT` conT collName)
      let
        derivs =
          [ derivClause Nothing $ map (conT . TH.mkName) ["Show", "Functor", "Foldable", "Traversable", "Generic1"]
          , derivClause (Just appViaGen1) [conT $ TH.mkName "Applicative"]
          ]
      collectionData <- dataD mempty collName [plainTV a] Nothing [mkConstr] derivs
      pure [collectionData]

    mkField segments =
      varBangType (TH.mkName $ fieldName segments) (a')

    mkInclude (f, t) =
      varBangType (TH.mkName f) . bangType_ $
        conT t `appT` varT a

    a = TH.mkName "a"
    a' = bangType_ $ varT a

    bangType_ = bangType (bang noSourceUnpackedness noSourceStrictness)

collName :: TH.Name
collName = TH.mkName "Collection"

sourcesVal :: [(String, TH.Name)] -> Scope -> FilePath -> Q [Dec]
sourcesVal prologue = mkDeclsWith mkVal
  where
    sources = TH.mkName "sources"
    mkVal _fp fs = do
      sig <- sigD sources $ conT collName `appT`conT (TH.mkName "Source")
      let body = recConE collName $ map prologueSource prologue <> map sourceVal fs
      fun <- funD sources [clause [] (normalB body) []]
      pure [sig, fun]
    prologueSource (fn, cn) =
      pure (TH.mkName fn, TH.VarE $ samePkg cn "sources")

    sourceVal segments = (TH.mkName $ fieldName segments,) <$> mkSrc
      where
        mkSrc = [| File Nothing $val |]
        val = conE . TH.mkName $ patternName segments

samePkg :: TH.Name -> String -> TH.Name
samePkg (TH.Name _occ nf) identifier =
  TH.Name (TH.mkOccName identifier) $
    case nf of
      TH.NameG _ns _pkg mn -> TH.NameQ mn
      _ -> nf

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