hyperbole-0.7.0: docs/Docgen.hs

module Main where

import Data.Char (isAlpha, isSpace)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import System.Directory
import System.Environment (getArgs)
import System.FilePath


main :: IO ()
main = do
  args <- getArgs
  case args of
    [original, input, output] -> do
      src <- readSource input
      expanded <- expandFile src
      let linePragma = T.pack $ "{-# LINE 1 \"" ++ original ++ "\" #-}"
      let final = SourceCode [linePragma] <> expanded
      T.writeFile output $ T.unlines final.lines
    _ -> error "Usage (Hyperbole Internal Only): docgen src/MyModule.hs /tmp/input/MyModule.hs /build/output/Original.hs"


-- test :: IO ()
-- test = do
--   src <- readSource "./src/Web/Hyperbole.hs"
--   SourceCode lns <- expandFile src
--   mapM_ print lns

-- expandSourcesTo :: FilePath -> IO ()
-- expandSourcesTo tmpDir = do
--   allFiles <- relativeSourceFiles "./src"
--   -- mapM_ (putStrLn . ("SOURCE " <>)) allFiles
--   mapM_ (expandAndCopyFileTo tmpDir) allFiles

-- copyExtraFilesTo :: FilePath -> IO ()
-- copyExtraFilesTo tmpDir = do
--   createDirectoryIfMissing True tmpDir
--   copyFile "./cabal.project" (tmpDir </> "cabal.project")
--   copyFile "./hyperbole.cabal" (tmpDir </> "hyperbole.cabal")
--   copyFile "./README.md" (tmpDir </> "README.md")
--   copyFile "./CHANGELOG.md" (tmpDir </> "CHANGELOG.md")
--   copyFile "./LICENSE" (tmpDir </> "LICENSE")
--   createDirectoryIfMissing True (tmpDir </> "client/dist")
--   copyFile "./client/dist/hyperbole.js" (tmpDir </> "client/dist/hyperbole.js")
--   copyFile "./client/dist/hyperbole.js.map" (tmpDir </> "client/dist/hyperbole.js.map")
--   createDirectoryIfMissing True (tmpDir </> "client/util")
--   copyFile "./client/util/live-reload.js" (tmpDir </> "client/util/live-reload.js")

-- expandAndCopyFileTo :: FilePath -> FilePath -> IO ()
-- expandAndCopyFileTo tmpDir pth = do
--   putStrLn $ "EXPANDING " <> pth
--   src <- readSource pth
--   expanded <- expandFile src
--   writeSource tmpDir pth expanded

readSource :: FilePath -> IO SourceCode
readSource pth = do
  inp <- T.readFile pth
  pure $ SourceCode $ T.lines inp


writeSource :: FilePath -> FilePath -> SourceCode -> IO ()
writeSource tmpDir relPath src = do
  let pth = tmpDir </> cleanRelativeDir relPath
  -- putStrLn $ "WRITE " <> pth <> " " <> show (length src.lines)
  createDirectoryIfMissing True $ takeDirectory pth
  T.writeFile pth $ T.unlines src.lines
 where
  cleanRelativeDir =
    dropWhile (== '/') . dropWhile (== '.')


-- relativeSourceFiles :: FilePath -> IO [FilePath]
-- relativeSourceFiles dir = do
--   contents <- tryDirectory dir
--   let folders = filter isFolder contents
--   let files = filter isSourceFile contents
--
--   files' <- mapM (relativeSourceFiles . addDir) folders
--
--   pure $ fmap addDir files <> mconcat files'
--  where
--   isSourceFile pth = takeExtension pth == ".hs"
--   isFolder pth = takeExtension pth == ""
--   addDir = (dir </>)
--   tryDirectory pth = do
--     res <- try $ listDirectory pth
--     case res of
--       Left (_ :: SomeException) -> do
--         putStrLn $ "SKIPPED" <> pth
--         pure []
--       Right files -> pure files

data Macro
  = Embed
  { moduleName :: ModuleName
  , definition :: TopLevelDefinition
  }
  deriving (Eq)
newtype SourceCode = SourceCode {lines :: [Text]}
  deriving newtype (Monoid, Semigroup)
instance Show Macro where
  -- show (Example p) = "Example " <> show p
  show (Embed mn def) = "Embed " <> show mn <> " " <> show def


newtype ModuleName = ModuleName Text
  deriving newtype (Eq, Show)


newtype TopLevelDefinition = TopLevelDefinition Text
  deriving newtype (Show, Eq)


expandFile :: SourceCode -> IO SourceCode
expandFile (SourceCode lns) =
  SourceCode . mconcat <$> mapM expandLine lns


-- > EMBED Example/Docs/BasicPage.hs page
expandLine :: Text -> IO [Text]
expandLine line = do
  case parseMacro line of
    Nothing -> do
      pure [line]
    Just (pre, Embed src def) -> do
      expandEmbed src pre def
 where
  -- Just (pre, Example src) -> do
  --   expandExample src pre

  parseMacro :: Text -> Maybe (Text, Macro)
  parseMacro inp = do
    parseEmbed inp -- <|> parseExample inp

  -- parseExample l = do
  --   case T.splitOn "#EXAMPLE " l of
  --     [prefix, src] -> do
  --       pure (prefix, Example $ path src)
  --     _ -> Nothing

  parseEmbed l = do
    case T.splitOn "#EMBED " l of
      [prefix, info] -> do
        (mn, definition) <- splitSrcDef $ T.dropWhile (== ' ') info
        pure (prefix, Embed mn definition)
      _ -> Nothing

  splitSrcDef inp =
    let (mn, def) = T.breakOn " " inp
     in pure (ModuleName mn, TopLevelDefinition $ T.drop 1 def)


-- look it up as a URI...

-- * #EXAMPLE /simple


-- expandExample :: Path -> Text -> IO [Text]
-- expandExample p prefix = do
--   let pre = if T.null prefix then "▶️ " else prefix
--   r <- appRoute
--   pure [pre <> "[" <> routeTitle r <> "](" <> uriToText (exampleBaseURI ./. p) <> ")"]
--  where
--   appRoute :: IO AppRoute
--   appRoute = do
--     case matchRoute @AppRoute p of
--       Nothing -> fail $ "Could not find example: " <> cs (pathToText False p)
--       Just r -> pure r

-- exampleBaseURI :: URI
-- exampleBaseURI = [uri|https://hyperbole.live|]

modulePath :: ModuleName -> FilePath
modulePath (ModuleName mn) = cs $ T.replace "." "/" mn <> ".hs"


expandEmbed :: ModuleName -> Text -> TopLevelDefinition -> IO [Text]
expandEmbed mn pfx def = do
  let src = modulePath mn
  -- putStrLn $ "  embed: " <> src
  source <- T.readFile $ "./demo/" <> src
  expanded <- requireTopLevel def (SourceCode $ T.lines source)
  pure $ fmap markupLine expanded
 where
  requireTopLevel :: TopLevelDefinition -> SourceCode -> IO [Text]
  requireTopLevel tld sc =
    case findTopLevel tld sc of
      [] -> fail $ "Could not find: " <> show (Embed mn def) <> " " <> show def
      lns -> pure lns

  -- addPrefix line = embed.prefix <> line
  markupLine :: Text -> Text
  markupLine line =
    case pfx of
      "" -> markupLineAt line
      _ -> markupLinePrefix line
  markupLineAt =
    T.replace "\"" "\\\"" . highlightTermsLine
  markupLinePrefix line =
    pfx <> line


highlightTermsLine :: Text -> Text
highlightTermsLine ln = mconcat $ fmap highlightWord $ T.groupBy isSameTerm ln
 where
  isSameTerm :: Char -> Char -> Bool
  isSameTerm c1 c2 =
    (isAlpha c1 && isAlpha c2)
      || (isSpace c1 && isSpace c2)

  highlightWord :: Text -> Text
  highlightWord w =
    if w `elem` terms
      then "'" <> w <> "'"
      else w

  terms :: [Text]
  terms =
    [ "HyperView"
    , "View"
    , "Action"
    , "update"
    , "hyper"
    , "Page"
    , "liveApp"
    , "quickStartDocument"
    , "runPage"
    , "run"
    , "ViewId"
    , "viewId"
    , "ViewAction"
    , "Eff"
    , "button"
    , "el"
    , "el_"
    , "Hyperbole"
    , "Route"
    , "routeRequest"
    , "route"
    , "layout"
    , "Response"
    , "ToParam"
    , "FromParam"
    , "Session"
    , "FromQuery"
    , "ToQuery"
    , "lookupParam"
    , "setParam"
    , "DefaultParam"
    , "Client"
    ]


-- returns lines of a top-level definition
findTopLevel :: TopLevelDefinition -> SourceCode -> [Text]
findTopLevel (TopLevelDefinition definition) source =
  let rest = dropWhile (not . isTopLevel) source.lines
   in dropWhileEnd isEmpty $ takeWhile isCurrentDefinition rest
 where
  isTopLevel = T.isPrefixOf definition
  isEmpty = T.null
  -- isBlankLine line = T.null $ T.strip line
  isCurrentDefinition line =
    isTopLevel line || not (isFullyOutdented line)
  dropWhileEnd p as =
    reverse $ dropWhile p $ reverse as


isFullyOutdented :: Text -> Bool
isFullyOutdented line =
  case cs (T.take 1 line) of
    "" -> False
    [c] -> not $ isSpace c
    _ -> False