-- |
-- Module      : Slab.Report
-- Description : Report information about Slab templates (mostly empty for now)
--
-- This module serves as a way to explore new Slab features, e.g. creating a
-- module system, or analyzing a growing HTML code base to help refactor it.
module Slab.Report
  ( reportPages
  , reportHeadings
  ) where

import Data.Text (Text)
import Data.Text qualified as T
import Data.Tree (Tree (..), drawForest)
import Slab.Build qualified as Build
import Slab.Error qualified as Error
import Slab.Evaluate qualified as Evaluate
import Slab.Render qualified as Render
import Slab.Syntax qualified as Syntax

--------------------------------------------------------------------------------
reportPages :: FilePath -> IO ()
reportPages :: String -> IO ()
reportPages String
srcDir = do
  [Module]
modules <- String -> IO [Module]
buildDir String
srcDir
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Read " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([Module] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Module]
modules) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" modules."
  let pages :: [Module]
pages = (Module -> Bool) -> [Module] -> [Module]
forall a. (a -> Bool) -> [a] -> [a]
filter Module -> Bool
isPage [Module]
modules
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show ([Module] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Module]
pages) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" pages."
  (Module -> IO ()) -> [Module] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> (Module -> String) -> Module -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> String
modulePath) [Module]
pages

data Module = Module
  { Module -> String
modulePath :: FilePath
  , Module -> [Block]
moduleNodes :: [Syntax.Block]
  }
  deriving (Int -> Module -> String -> String
[Module] -> String -> String
Module -> String
(Int -> Module -> String -> String)
-> (Module -> String)
-> ([Module] -> String -> String)
-> Show Module
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Module -> String -> String
showsPrec :: Int -> Module -> String -> String
$cshow :: Module -> String
show :: Module -> String
$cshowList :: [Module] -> String -> String
showList :: [Module] -> String -> String
Show)

isPage :: Module -> Bool
isPage :: Module -> Bool
isPage Module {moduleNodes :: Module -> [Block]
moduleNodes = (Block
x : [Block]
_)} = Block -> Bool
Syntax.isDoctype Block
x
isPage Module
_ = Bool
False

--------------------------------------------------------------------------------
reportHeadings :: FilePath -> IO ()
reportHeadings :: String -> IO ()
reportHeadings String
path = do
  Module
modl <- String -> IO Module
buildFile String
path
  let headings :: [Heading]
headings = [Block] -> [Heading]
extractHeadings ([Block] -> [Heading])
-> ([Block] -> [Block]) -> [Block] -> [Heading]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> [Block]
Evaluate.simplify ([Block] -> [Heading]) -> [Block] -> [Heading]
forall a b. (a -> b) -> a -> b
$ Module -> [Block]
moduleNodes Module
modl
      f :: Heading -> String
f (Heading Int
level Maybe Text
_ Text
t) = Int -> String
forall a. Show a => a -> String
show Int
level String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
t
  String -> IO ()
putStrLn (String -> IO ())
-> ([Tree Heading] -> String) -> [Tree Heading] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tree String] -> String
drawForest ([Tree String] -> String)
-> ([Tree Heading] -> [Tree String]) -> [Tree Heading] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree Heading -> Tree String) -> [Tree Heading] -> [Tree String]
forall a b. (a -> b) -> [a] -> [b]
map ((Heading -> String) -> Tree Heading -> Tree String
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Heading -> String
f) ([Tree Heading] -> IO ()) -> [Tree Heading] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Heading] -> [Tree Heading]
buildTrees [Heading]
headings

--------------------------------------------------------------------------------
-- Similar to Build.buildDir and buildFile, but don't render HTML to disk.
-- TODO Move this code to (and combine it with) with @Slab.Build@.

buildDir :: FilePath -> IO [Module]
buildDir :: String -> IO [Module]
buildDir String
srcDir = do
  [String]
templates <- String -> IO [String]
Build.listTemplates String
srcDir
  (String -> IO Module) -> [String] -> IO [Module]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO Module
buildFile [String]
templates

buildFile :: FilePath -> IO Module
buildFile :: String -> IO Module
buildFile String
path = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Reading " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"..."
  [Block]
nodes <- String -> IO (Either Error [Block])
Evaluate.evaluateFile String
path IO (Either Error [Block])
-> (Either Error [Block] -> IO [Block]) -> IO [Block]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Error [Block] -> IO [Block]
forall a. Either Error a -> IO a
Error.unwrap
  Module -> IO Module
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Module
      { modulePath :: String
modulePath = String
path
      , moduleNodes :: [Block]
moduleNodes = [Block]
nodes
      }

--------------------------------------------------------------------------------

buildTrees :: [Heading] -> [Tree Heading]
buildTrees :: [Heading] -> [Tree Heading]
buildTrees [] = []
buildTrees (Heading
h : [Heading]
hs) =
  let ([Heading]
children, [Heading]
rest) = (Heading -> Bool) -> [Heading] -> ([Heading], [Heading])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Heading -> Int
headingLevel Heading
h) (Int -> Bool) -> (Heading -> Int) -> Heading -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Heading -> Int
headingLevel) [Heading]
hs
      childTrees :: [Tree Heading]
childTrees = [Heading] -> [Tree Heading]
buildTrees [Heading]
children
      tree :: Tree Heading
tree = Heading -> [Tree Heading] -> Tree Heading
forall a. a -> [Tree a] -> Tree a
Node Heading
h [Tree Heading]
childTrees
   in Tree Heading
tree Tree Heading -> [Tree Heading] -> [Tree Heading]
forall a. a -> [a] -> [a]
: [Heading] -> [Tree Heading]
buildTrees [Heading]
rest

data Heading = Heading
  { Heading -> Int
headingLevel :: Int
  , Heading -> Maybe Text
headingId :: Maybe Text
  , Heading -> Text
headingText :: Text
  }
  deriving (Int -> Heading -> String -> String
[Heading] -> String -> String
Heading -> String
(Int -> Heading -> String -> String)
-> (Heading -> String)
-> ([Heading] -> String -> String)
-> Show Heading
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Heading -> String -> String
showsPrec :: Int -> Heading -> String -> String
$cshow :: Heading -> String
show :: Heading -> String
$cshowList :: [Heading] -> String -> String
showList :: [Heading] -> String -> String
Show, Heading -> Heading -> Bool
(Heading -> Heading -> Bool)
-> (Heading -> Heading -> Bool) -> Eq Heading
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Heading -> Heading -> Bool
== :: Heading -> Heading -> Bool
$c/= :: Heading -> Heading -> Bool
/= :: Heading -> Heading -> Bool
Eq)

extractHeadings :: [Syntax.Block] -> [Heading]
extractHeadings :: [Block] -> [Heading]
extractHeadings = (Block -> [Heading]) -> [Block] -> [Heading]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [Heading]
f
 where
  f :: Block -> [Heading]
f Block
Syntax.BlockDoctype = []
  f (Syntax.BlockElem Elem
el TrailingSym
_ [Attr]
attrs [Block]
children) =
    let i :: Maybe Text
i = [Attr] -> Maybe Text
Syntax.idNamesFromAttrs' [Attr]
attrs
        t :: Text
t = [Block] -> Text
Render.extractTexts [Block]
children
     in case Elem
el of
          Elem
Syntax.H1 -> [Int -> Maybe Text -> Text -> Heading
Heading Int
1 Maybe Text
i Text
t]
          Elem
Syntax.H2 -> [Int -> Maybe Text -> Text -> Heading
Heading Int
2 Maybe Text
i Text
t]
          Elem
Syntax.H3 -> [Int -> Maybe Text -> Text -> Heading
Heading Int
3 Maybe Text
i Text
t]
          Elem
Syntax.H4 -> [Int -> Maybe Text -> Text -> Heading
Heading Int
4 Maybe Text
i Text
t]
          Elem
Syntax.H5 -> [Int -> Maybe Text -> Text -> Heading
Heading Int
5 Maybe Text
i Text
t]
          Elem
Syntax.H6 -> [Int -> Maybe Text -> Text -> Heading
Heading Int
6 Maybe Text
i Text
t]
          Elem
_ -> [Block] -> [Heading]
extractHeadings [Block]
children
  f (Syntax.BlockText TextSyntax
_ [Inline]
_) = []
  f (Syntax.BlockInclude Maybe Text
_ String
_ Maybe [Block]
children) = [Heading] -> ([Block] -> [Heading]) -> Maybe [Block] -> [Heading]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Block] -> [Heading]
extractHeadings Maybe [Block]
children
  f (Syntax.BlockFragmentDef DefinitionUse
_ Text
_ [Text]
_ [Block]
_) = []
  f (Syntax.BlockFragmentCall Text
_ TrailingSym
_ [Attr]
_ [Expr]
_ [Block]
children) =
    [Block] -> [Heading]
extractHeadings [Block]
children
  f (Syntax.BlockFor Text
_ Maybe Text
_ Expr
_ [Block]
children) = [Block] -> [Heading]
extractHeadings [Block]
children
  f (Syntax.BlockComment CommentType
_ Text
_) = []
  f (Syntax.BlockFilter Text
_ Text
_) = []
  f (Syntax.BlockRawElem Text
_ [Block]
_) = []
  f (Syntax.BlockDefault Text
_ [Block]
children) = [Block] -> [Heading]
extractHeadings [Block]
children
  f (Syntax.BlockImport String
_ Maybe [Block]
children [Block]
args) = [Heading] -> ([Block] -> [Heading]) -> Maybe [Block] -> [Heading]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Block] -> [Heading]
extractHeadings Maybe [Block]
children [Heading] -> [Heading] -> [Heading]
forall a. Semigroup a => a -> a -> a
<> [Block] -> [Heading]
extractHeadings [Block]
args
  f (Syntax.BlockRun Text
_ Maybe Text
_ Maybe [Block]
_) = []
  f (Syntax.BlockAssignVars [(Text, Expr)]
_) = []
  f (Syntax.BlockIf Expr
_ [Block]
as [Block]
bs) = [Block] -> [Heading]
extractHeadings [Block]
as [Heading] -> [Heading] -> [Heading]
forall a. Semigroup a => a -> a -> a
<> [Block] -> [Heading]
extractHeadings [Block]
bs
  f (Syntax.BlockList [Block]
children) = [Block] -> [Heading]
extractHeadings [Block]
children
  f (Syntax.BlockCode Expr
_) = []