{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      : Slab.Syntax
-- Description : The abstract syntax used by Slab
--
-- @Slab.Syntax@ provides data types to represent the syntax used by the Slab
-- language. It also provides small helpers functions to operate on the syntax.
module Slab.Syntax
  ( Block (..)
  , isDoctype
  , pasteBlocks
  , setAttrs
  , setContent
  , CommentType (..)
  , Elem (..)
  , TrailingSym (..)
  , Attr (..)
  , TextSyntax (..)
  , Expr (..)
  , Inline (..)
  , Env (..)
  , emptyEnv
  , displayEnv
  , trailingSym
  , freeVariables
  , thunk
  , extractClasses
  , extractFragments
  , findFragment
  , idNamesFromAttrs
  , classNamesFromAttrs
  , namesFromAttrs
  , groupAttrs
  ) where

import Data.Aeson qualified as Aeson
import Data.List (nub, sort)
import Data.Text (Text)
import Data.Text qualified as T

--------------------------------------------------------------------------------
data Block
  = -- | Only @doctype html@ for now.
    BlockDoctype
  | BlockElem Elem TrailingSym [Attr] [Block]
  | BlockText TextSyntax [Inline]
  | -- | @Nothing@ when the template is parsed, then @Just nodes@ after
    -- preprocessing (i.e. actually running the include statement).
    -- The filter name follows the same behavior as BlockFilter.
    BlockInclude (Maybe Text) FilePath (Maybe [Block])
  | -- | This doesn't exist in Pug. This is like a mixin than receive block arguments.
    -- Or like a parent template that can be @extended@ by a child template.
    BlockFragmentDef Text [Text] [Block]
  | BlockFragmentCall Text TrailingSym [Attr] [Expr] [Block]
  | BlockFor Text (Maybe Text) Expr [Block]
  | -- TODO Should we allow string interpolation here ?
    BlockComment CommentType Text
  | BlockFilter Text Text
  | BlockRawElem Text [Block]
  | -- | @default@ defines an optional formal parameter with a default content.
    -- Its content is used when the argument is not given.
    BlockDefault Text [Block]
  | -- | Similar to an anonymous fragment call, where the fragment body is the
    -- content of the referenced file.
    BlockImport FilePath (Maybe [Block]) [Block]
  | BlockRun Text (Maybe [Block])
  | -- | Allow to assign the content of a JSON file to a variable. The syntax
    -- is specific to how Struct has a @require@ function in scope.
    BlockReadJson Text FilePath (Maybe Aeson.Value)
  | BlockAssignVar Text Expr
  | BlockIf Expr [Block] [Block]
  | BlockList [Block]
  | BlockCode Expr
  deriving (Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
(Int -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Block -> ShowS
showsPrec :: Int -> Block -> ShowS
$cshow :: Block -> String
show :: Block -> String
$cshowList :: [Block] -> ShowS
showList :: [Block] -> ShowS
Show, Block -> Block -> Bool
(Block -> Block -> Bool) -> (Block -> Block -> Bool) -> Eq Block
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
/= :: Block -> Block -> Bool
Eq)

isDoctype :: Block -> Bool
isDoctype :: Block -> Bool
isDoctype Block
BlockDoctype = Bool
True
isDoctype Block
_ = Bool
False

trailingSym :: Block -> TrailingSym
trailingSym :: Block -> TrailingSym
trailingSym (BlockElem Elem
_ TrailingSym
sym [Attr]
_ [Block]
_) = TrailingSym
sym
trailingSym (BlockFragmentCall Text
_ TrailingSym
sym [Attr]
_ [Expr]
_ [Block]
_) = TrailingSym
sym
trailingSym Block
_ = TrailingSym
NoSym

-- | Takes two blocks and returns a BlockList containing both, but peel the
-- outer list of a and b if they are themselves BlockList.
pasteBlocks :: Block -> Block -> Block
pasteBlocks :: Block -> Block -> Block
pasteBlocks Block
a Block
b = [Block] -> Block
BlockList ([Block] -> Block) -> [Block] -> Block
forall a b. (a -> b) -> a -> b
$ Block -> [Block]
peel Block
a [Block] -> [Block] -> [Block]
forall a. Semigroup a => a -> a -> a
<> Block -> [Block]
peel Block
b
 where
  peel :: Block -> [Block]
peel (BlockList [Block]
xs) = [Block]
xs
  peel Block
x = [Block
x]

-- | Set attrs on a the first block, if it is a BlockElem.
setAttrs :: [Attr] -> [Block] -> [Block]
setAttrs :: [Attr] -> [Block] -> [Block]
setAttrs [Attr]
attrs (BlockElem Elem
name TrailingSym
mdot [Attr]
attrs' [Block]
nodes : [Block]
bs) =
  Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
name TrailingSym
mdot ([Attr]
attrs' [Attr] -> [Attr] -> [Attr]
forall a. Semigroup a => a -> a -> a
<> [Attr]
attrs) [Block]
nodes Block -> [Block] -> [Block]
forall a. a -> [a] -> [a]
: [Block]
bs
setAttrs [Attr]
_ [Block]
bs = [Block]
bs

-- | Set the content on a block, if it is a BlockElem.
setContent :: [Block] -> Block -> Block
setContent :: [Block] -> Block -> Block
setContent [Block]
nodes (BlockElem Elem
name TrailingSym
mdot [Attr]
attrs [Block]
_) =
  Elem -> TrailingSym -> [Attr] -> [Block] -> Block
BlockElem Elem
name TrailingSym
mdot [Attr]
attrs [Block]
nodes
setContent [Block]
_ Block
b = Block
b

-- | A "passthrough" comment will be included in the generated HTML.
data CommentType = NormalComment | PassthroughComment
  deriving (Int -> CommentType -> ShowS
[CommentType] -> ShowS
CommentType -> String
(Int -> CommentType -> ShowS)
-> (CommentType -> String)
-> ([CommentType] -> ShowS)
-> Show CommentType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommentType -> ShowS
showsPrec :: Int -> CommentType -> ShowS
$cshow :: CommentType -> String
show :: CommentType -> String
$cshowList :: [CommentType] -> ShowS
showList :: [CommentType] -> ShowS
Show, CommentType -> CommentType -> Bool
(CommentType -> CommentType -> Bool)
-> (CommentType -> CommentType -> Bool) -> Eq CommentType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommentType -> CommentType -> Bool
== :: CommentType -> CommentType -> Bool
$c/= :: CommentType -> CommentType -> Bool
/= :: CommentType -> CommentType -> Bool
Eq)

data Elem
  = Html
  | Body
  | Div
  | Span
  | Br
  | Hr
  | H1
  | H2
  | H3
  | H4
  | H5
  | H6
  | Header
  | Head
  | Meta
  | Main
  | Link
  | A
  | P
  | Ul
  | Li
  | Title
  | Table
  | Thead
  | Tbody
  | Tr
  | Td
  | Dl
  | Dt
  | Dd
  | Footer
  | Figure
  | Form
  | Label
  | Blockquote
  | Button
  | Figcaption
  | Audio
  | Script
  | Style
  | Small
  | Source
  | Pre
  | Code
  | Img
  | IFrame
  | Input
  | I
  | Svg
  | Textarea
  | Canvas
  | -- | Arbitrary element name, using the @el@ keyword.
    Elem Text
  deriving (Int -> Elem -> ShowS
[Elem] -> ShowS
Elem -> String
(Int -> Elem -> ShowS)
-> (Elem -> String) -> ([Elem] -> ShowS) -> Show Elem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Elem -> ShowS
showsPrec :: Int -> Elem -> ShowS
$cshow :: Elem -> String
show :: Elem -> String
$cshowList :: [Elem] -> ShowS
showList :: [Elem] -> ShowS
Show, Elem -> Elem -> Bool
(Elem -> Elem -> Bool) -> (Elem -> Elem -> Bool) -> Eq Elem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Elem -> Elem -> Bool
== :: Elem -> Elem -> Bool
$c/= :: Elem -> Elem -> Bool
/= :: Elem -> Elem -> Bool
Eq)

data TrailingSym = HasDot | HasEqual | NoSym
  deriving (Int -> TrailingSym -> ShowS
[TrailingSym] -> ShowS
TrailingSym -> String
(Int -> TrailingSym -> ShowS)
-> (TrailingSym -> String)
-> ([TrailingSym] -> ShowS)
-> Show TrailingSym
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TrailingSym -> ShowS
showsPrec :: Int -> TrailingSym -> ShowS
$cshow :: TrailingSym -> String
show :: TrailingSym -> String
$cshowList :: [TrailingSym] -> ShowS
showList :: [TrailingSym] -> ShowS
Show, TrailingSym -> TrailingSym -> Bool
(TrailingSym -> TrailingSym -> Bool)
-> (TrailingSym -> TrailingSym -> Bool) -> Eq TrailingSym
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TrailingSym -> TrailingSym -> Bool
== :: TrailingSym -> TrailingSym -> Bool
$c/= :: TrailingSym -> TrailingSym -> Bool
/= :: TrailingSym -> TrailingSym -> Bool
Eq)

-- The Code must already be evaluated.
data Attr = Id Text | Class Text | Attr Text (Maybe Expr)
  deriving (Int -> Attr -> ShowS
[Attr] -> ShowS
Attr -> String
(Int -> Attr -> ShowS)
-> (Attr -> String) -> ([Attr] -> ShowS) -> Show Attr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Attr -> ShowS
showsPrec :: Int -> Attr -> ShowS
$cshow :: Attr -> String
show :: Attr -> String
$cshowList :: [Attr] -> ShowS
showList :: [Attr] -> ShowS
Show, Attr -> Attr -> Bool
(Attr -> Attr -> Bool) -> (Attr -> Attr -> Bool) -> Eq Attr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Attr -> Attr -> Bool
== :: Attr -> Attr -> Bool
$c/= :: Attr -> Attr -> Bool
/= :: Attr -> Attr -> Bool
Eq)

-- Tracks the syntax used to enter the text.
data TextSyntax
  = -- | The text follows an element on the same line.
    Normal
  | -- | The text follows a pipe character. Multiple lines each introduced by a
    -- pipe symbol are grouped as a single 'BlockText' node.
    Pipe
  | -- | The text is part of a text block following a trailing dot.
    Dot
  | -- | The text is the content of an include statement without a .slab extension.
    Include
  | -- | The text is the output of command.
    RunOutput
  deriving (Int -> TextSyntax -> ShowS
[TextSyntax] -> ShowS
TextSyntax -> String
(Int -> TextSyntax -> ShowS)
-> (TextSyntax -> String)
-> ([TextSyntax] -> ShowS)
-> Show TextSyntax
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TextSyntax -> ShowS
showsPrec :: Int -> TextSyntax -> ShowS
$cshow :: TextSyntax -> String
show :: TextSyntax -> String
$cshowList :: [TextSyntax] -> ShowS
showList :: [TextSyntax] -> ShowS
Show, TextSyntax -> TextSyntax -> Bool
(TextSyntax -> TextSyntax -> Bool)
-> (TextSyntax -> TextSyntax -> Bool) -> Eq TextSyntax
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TextSyntax -> TextSyntax -> Bool
== :: TextSyntax -> TextSyntax -> Bool
$c/= :: TextSyntax -> TextSyntax -> Bool
/= :: TextSyntax -> TextSyntax -> Bool
Eq)

-- | Simple expression language.
data Expr
  = Variable Text
  | Bool Bool
  | Int Int
  | SingleQuoteString Text
  | List [Expr]
  | Object [(Expr, Expr)]
  | -- The object[key] lookup. This is quite restrive as a start.
    Lookup Text Expr
  | Application Expr Expr
  | Add Expr Expr
  | Sub Expr Expr
  | Times Expr Expr
  | Divide Expr Expr
  | GreaterThan Expr Expr
  | LesserThan Expr Expr
  | Equal Expr Expr
  | -- Not really a cons for lists, but instead to add content to an element.
    -- E.g. p : "Hello."
    Cons Expr Expr
  | Block Block
  | -- Expr can be a fragment, so we can manipulate them with code later.
    -- We also capture the current environment.
    Frag [Text] Env [Block]
  | -- Same for Expr instead of Block.
    Thunk Env Expr
  | BuiltIn Text
  deriving (Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> String
(Int -> Expr -> ShowS)
-> (Expr -> String) -> ([Expr] -> ShowS) -> Show Expr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Expr -> ShowS
showsPrec :: Int -> Expr -> ShowS
$cshow :: Expr -> String
show :: Expr -> String
$cshowList :: [Expr] -> ShowS
showList :: [Expr] -> ShowS
Show, Expr -> Expr -> Bool
(Expr -> Expr -> Bool) -> (Expr -> Expr -> Bool) -> Eq Expr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
/= :: Expr -> Expr -> Bool
Eq)

-- | A representation of a 'Data.Text' template is a list of Inline, supporting
-- efficient rendering. Use 'parse' to create a template from a text containing
-- placeholders. 'Lit' is a literal Text value. 'Place' is a placeholder created
-- with @#{...}@.
data Inline = Lit {-# UNPACK #-} !Text | Place !Expr
  deriving (Inline -> Inline -> Bool
(Inline -> Inline -> Bool)
-> (Inline -> Inline -> Bool) -> Eq Inline
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Inline -> Inline -> Bool
== :: Inline -> Inline -> Bool
$c/= :: Inline -> Inline -> Bool
/= :: Inline -> Inline -> Bool
Eq, Int -> Inline -> ShowS
[Inline] -> ShowS
Inline -> String
(Int -> Inline -> ShowS)
-> (Inline -> String) -> ([Inline] -> ShowS) -> Show Inline
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Inline -> ShowS
showsPrec :: Int -> Inline -> ShowS
$cshow :: Inline -> String
show :: Inline -> String
$cshowList :: [Inline] -> ShowS
showList :: [Inline] -> ShowS
Show)

data Env = Env
  { Env -> [(Text, Expr)]
envVariables :: [(Text, Expr)]
  }
  deriving (Env -> Env -> Bool
(Env -> Env -> Bool) -> (Env -> Env -> Bool) -> Eq Env
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Env -> Env -> Bool
== :: Env -> Env -> Bool
$c/= :: Env -> Env -> Bool
/= :: Env -> Env -> Bool
Eq, Int -> Env -> ShowS
[Env] -> ShowS
Env -> String
(Int -> Env -> ShowS)
-> (Env -> String) -> ([Env] -> ShowS) -> Show Env
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Env -> ShowS
showsPrec :: Int -> Env -> ShowS
$cshow :: Env -> String
show :: Env -> String
$cshowList :: [Env] -> ShowS
showList :: [Env] -> ShowS
Show)

emptyEnv :: Env
emptyEnv :: Env
emptyEnv = [(Text, Expr)] -> Env
Env []

-- Similar to `show`, but makes the environment capture by "Frag" and "Thunk"
-- empty to avoid an infinite data structure.
displayEnv :: Env -> Text
displayEnv :: Env -> Text
displayEnv = String -> Text
T.pack (String -> Text) -> (Env -> String) -> Env -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Expr)] -> String
forall a. Show a => a -> String
show ([(Text, Expr)] -> String)
-> (Env -> [(Text, Expr)]) -> Env -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Expr) -> (Text, Expr)) -> [(Text, Expr)] -> [(Text, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
a, Expr
b) -> (Text
a, Expr -> Expr
f Expr
b)) ([(Text, Expr)] -> [(Text, Expr)])
-> (Env -> [(Text, Expr)]) -> Env -> [(Text, Expr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> [(Text, Expr)]
envVariables
 where
  f :: Expr -> Expr
f = \case
    Frag [Text]
names Env
_ [Block]
children -> [Text] -> Env -> [Block] -> Expr
Frag [Text]
names Env
emptyEnv [Block]
children
    Thunk Env
_ Expr
expr -> Env -> Expr -> Expr
Thunk Env
emptyEnv Expr
expr
    Expr
expr -> Expr
expr

--------------------------------------------------------------------------------
freeVariables :: Expr -> [Text]
freeVariables :: Expr -> [Text]
freeVariables =
  [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ([Text] -> [Text]) -> (Expr -> [Text]) -> Expr -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Variable Text
a -> [Text
a]
    Bool Bool
_ -> []
    Int Int
_ -> []
    SingleQuoteString Text
_ -> []
    List [Expr]
as -> (Expr -> [Text]) -> [Expr] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Expr -> [Text]
freeVariables [Expr]
as
    Object [(Expr, Expr)]
_ -> [] -- TODO I guess some of those can contain variables.
    Lookup Text
a Expr
b -> Text
a Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Expr -> [Text]
freeVariables Expr
b
    Add Expr
a Expr
b -> Expr -> [Text]
freeVariables Expr
a [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Expr -> [Text]
freeVariables Expr
b
    Sub Expr
a Expr
b -> Expr -> [Text]
freeVariables Expr
a [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Expr -> [Text]
freeVariables Expr
b
    Times Expr
a Expr
b -> Expr -> [Text]
freeVariables Expr
a [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Expr -> [Text]
freeVariables Expr
b
    Divide Expr
a Expr
b -> Expr -> [Text]
freeVariables Expr
a [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Expr -> [Text]
freeVariables Expr
b
    Frag [Text]
_ Env
_ [Block]
_ -> []
    Thunk Env
_ Expr
_ -> []

-- Capture an environment, but limit its content to only the free variables of
-- the expression.
thunk :: Env -> Expr -> Expr
thunk :: Env -> Expr -> Expr
thunk Env {[(Text, Expr)]
envVariables :: Env -> [(Text, Expr)]
envVariables :: [(Text, Expr)]
..} Expr
code = Env -> Expr -> Expr
Thunk Env
env Expr
code
 where
  env :: Env
env = [(Text, Expr)] -> Env
Env ([(Text, Expr)] -> Env) -> [(Text, Expr)] -> Env
forall a b. (a -> b) -> a -> b
$ ((Text, Expr) -> Bool) -> [(Text, Expr)] -> [(Text, Expr)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
frees) (Text -> Bool) -> ((Text, Expr) -> Text) -> (Text, Expr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Expr) -> Text
forall a b. (a, b) -> a
fst) [(Text, Expr)]
envVariables
  frees :: [Text]
frees = Expr -> [Text]
freeVariables Expr
code

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

extractClasses :: [Block] -> [Text]
extractClasses :: [Block] -> [Text]
extractClasses = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ([Text] -> [Text]) -> ([Block] -> [Text]) -> [Block] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort ([Text] -> [Text]) -> ([Block] -> [Text]) -> [Block] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> [Text]) -> [Block] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [Text]
f
 where
  f :: Block -> [Text]
f Block
BlockDoctype = []
  f (BlockElem Elem
_ TrailingSym
_ [Attr]
attrs [Block]
children) = (Attr -> [Text]) -> [Attr] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Attr -> [Text]
g [Attr]
attrs [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Block] -> [Text]
extractClasses [Block]
children
  f (BlockText TextSyntax
_ [Inline]
_) = []
  f (BlockInclude Maybe Text
_ String
_ Maybe [Block]
children) = [Text] -> ([Block] -> [Text]) -> Maybe [Block] -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Block] -> [Text]
extractClasses Maybe [Block]
children
  f (BlockFragmentDef Text
_ [Text]
_ [Block]
_) = [] -- We extract them in BlockFragmentCall instead.
  f (BlockFragmentCall Text
_ TrailingSym
_ [Attr]
attrs [Expr]
_ [Block]
children) = (Attr -> [Text]) -> [Attr] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Attr -> [Text]
g [Attr]
attrs [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Block] -> [Text]
extractClasses [Block]
children
  f (BlockFor Text
_ Maybe Text
_ Expr
_ [Block]
children) = [Block] -> [Text]
extractClasses [Block]
children
  f (BlockComment CommentType
_ Text
_) = []
  f (BlockFilter Text
_ Text
_) = []
  -- TODO Would be nice to extract classes from verbatim HTML too.
  f (BlockRawElem Text
_ [Block]
_) = []
  f (BlockDefault Text
_ [Block]
children) = [Block] -> [Text]
extractClasses [Block]
children
  f (BlockImport String
_ Maybe [Block]
children [Block]
blocks) = [Text] -> ([Block] -> [Text]) -> Maybe [Block] -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Block] -> [Text]
extractClasses Maybe [Block]
children [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Block] -> [Text]
extractClasses [Block]
blocks
  f (BlockRun Text
_ Maybe [Block]
_) = []
  f (BlockReadJson Text
_ String
_ Maybe Value
_) = []
  f (BlockAssignVar Text
_ Expr
_) = []
  f (BlockIf Expr
_ [Block]
as [Block]
bs) = [Block] -> [Text]
extractClasses [Block]
as [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Block] -> [Text]
extractClasses [Block]
bs
  f (BlockList [Block]
children) = [Block] -> [Text]
extractClasses [Block]
children
  f (BlockCode Expr
_) = []

  g :: Attr -> [Text]
g (Id Text
_) = []
  g (Class Text
c) = [Text
c]
  g (Attr Text
a Maybe Expr
b) = Text -> Maybe Expr -> [Text]
forall {a}. (Eq a, IsString a) => a -> Maybe Expr -> [Text]
h Text
a Maybe Expr
b
  h :: a -> Maybe Expr -> [Text]
h a
"class" (Just (SingleQuoteString Text
c)) = [Text
c]
  h a
"class" Maybe Expr
_ = String -> [Text]
forall a. HasCallStack => String -> a
error String
"The class is not a string"
  h a
_ Maybe Expr
_ = []

-- Return type used for `extractFragments`.
data BlockFragment
  = BlockFragmentDef' Text [Block]
  | BlockFragmentCall' Text
  deriving (Int -> BlockFragment -> ShowS
[BlockFragment] -> ShowS
BlockFragment -> String
(Int -> BlockFragment -> ShowS)
-> (BlockFragment -> String)
-> ([BlockFragment] -> ShowS)
-> Show BlockFragment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockFragment -> ShowS
showsPrec :: Int -> BlockFragment -> ShowS
$cshow :: BlockFragment -> String
show :: BlockFragment -> String
$cshowList :: [BlockFragment] -> ShowS
showList :: [BlockFragment] -> ShowS
Show, BlockFragment -> BlockFragment -> Bool
(BlockFragment -> BlockFragment -> Bool)
-> (BlockFragment -> BlockFragment -> Bool) -> Eq BlockFragment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockFragment -> BlockFragment -> Bool
== :: BlockFragment -> BlockFragment -> Bool
$c/= :: BlockFragment -> BlockFragment -> Bool
/= :: BlockFragment -> BlockFragment -> Bool
Eq)

extractFragments :: [Block] -> [BlockFragment]
extractFragments :: [Block] -> [BlockFragment]
extractFragments = (Block -> [BlockFragment]) -> [Block] -> [BlockFragment]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [BlockFragment]
f
 where
  f :: Block -> [BlockFragment]
f Block
BlockDoctype = []
  f (BlockElem Elem
_ TrailingSym
_ [Attr]
_ [Block]
children) = [Block] -> [BlockFragment]
extractFragments [Block]
children
  f (BlockText TextSyntax
_ [Inline]
_) = []
  f (BlockInclude Maybe Text
_ String
_ Maybe [Block]
children) = [BlockFragment]
-> ([Block] -> [BlockFragment]) -> Maybe [Block] -> [BlockFragment]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Block] -> [BlockFragment]
extractFragments Maybe [Block]
children
  f (BlockFragmentDef Text
name [Text]
_ [Block]
children) = [Text -> [Block] -> BlockFragment
BlockFragmentDef' Text
name [Block]
children]
  f (BlockFragmentCall Text
name TrailingSym
_ [Attr]
_ [Expr]
_ [Block]
children) =
    [Text -> BlockFragment
BlockFragmentCall' Text
name] [BlockFragment] -> [BlockFragment] -> [BlockFragment]
forall a. Semigroup a => a -> a -> a
<> [Block] -> [BlockFragment]
extractFragments [Block]
children
  f (BlockFor Text
_ Maybe Text
_ Expr
_ [Block]
children) = [Block] -> [BlockFragment]
extractFragments [Block]
children
  f (BlockComment CommentType
_ Text
_) = []
  f (BlockFilter Text
_ Text
_) = []
  f (BlockRawElem Text
_ [Block]
_) = []
  f (BlockDefault Text
_ [Block]
children) = [Block] -> [BlockFragment]
extractFragments [Block]
children
  f (BlockImport String
_ Maybe [Block]
children [Block]
args) = [BlockFragment]
-> ([Block] -> [BlockFragment]) -> Maybe [Block] -> [BlockFragment]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Block] -> [BlockFragment]
extractFragments Maybe [Block]
children [BlockFragment] -> [BlockFragment] -> [BlockFragment]
forall a. Semigroup a => a -> a -> a
<> [Block] -> [BlockFragment]
extractFragments [Block]
args
  f (BlockRun Text
_ Maybe [Block]
_) = []
  f (BlockReadJson Text
_ String
_ Maybe Value
_) = []
  f (BlockAssignVar Text
_ Expr
_) = []
  f (BlockIf Expr
_ [Block]
as [Block]
bs) = [Block] -> [BlockFragment]
extractFragments [Block]
as [BlockFragment] -> [BlockFragment] -> [BlockFragment]
forall a. Semigroup a => a -> a -> a
<> [Block] -> [BlockFragment]
extractFragments [Block]
bs
  f (BlockList [Block]
children) = [Block] -> [BlockFragment]
extractFragments [Block]
children
  f (BlockCode Expr
_) = []

findFragment :: Text -> [BlockFragment] -> Maybe [Block]
findFragment :: Text -> [BlockFragment] -> Maybe [Block]
findFragment Text
name [BlockFragment]
ms = case (BlockFragment -> Bool) -> [BlockFragment] -> [BlockFragment]
forall a. (a -> Bool) -> [a] -> [a]
filter BlockFragment -> Bool
f [BlockFragment]
ms of
  [BlockFragmentDef' Text
_ [Block]
nodes] -> [Block] -> Maybe [Block]
forall a. a -> Maybe a
Just [Block]
nodes
  [BlockFragment]
_ -> Maybe [Block]
forall a. Maybe a
Nothing
 where
  f :: BlockFragment -> Bool
f (BlockFragmentDef' Text
name' [Block]
_) = Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name'
  f BlockFragment
_ = Bool
False

--------------------------------------------------------------------------------
idNamesFromAttrs :: [Attr] -> [Text]
idNamesFromAttrs :: [Attr] -> [Text]
idNamesFromAttrs =
  (Attr -> [Text]) -> [Attr] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
    ( \case
        Id Text
i -> [Text
i]
        Class Text
_ -> []
        Attr Text
a Maybe Expr
b -> Text -> Maybe Expr -> [Text]
forall {a}. (Eq a, IsString a) => a -> Maybe Expr -> [Text]
f Text
a Maybe Expr
b
    )
 where
  f :: a -> Maybe Expr -> [Text]
f a
"id" (Just (SingleQuoteString Text
x)) = [Text
x]
  f a
"id" (Just Expr
_) = String -> [Text]
forall a. HasCallStack => String -> a
error String
"The id is not a string"
  f a
_ Maybe Expr
_ = []

classNamesFromAttrs :: [Attr] -> [Text]
classNamesFromAttrs :: [Attr] -> [Text]
classNamesFromAttrs =
  (Attr -> [Text]) -> [Attr] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
    ( \case
        Id Text
_ -> []
        Class Text
c -> [Text
c]
        Attr Text
a Maybe Expr
b -> Text -> Maybe Expr -> [Text]
forall {a}. (Eq a, IsString a) => a -> Maybe Expr -> [Text]
f Text
a Maybe Expr
b
    )
 where
  f :: a -> Maybe Expr -> [Text]
f a
"class" (Just (SingleQuoteString Text
x)) = [Text
x]
  f a
"class" (Just Expr
_) = String -> [Text]
forall a. HasCallStack => String -> a
error String
"The class is not a string"
  f a
_ Maybe Expr
_ = []

namesFromAttrs :: [Attr] -> [(Text, Text)]
namesFromAttrs :: [Attr] -> [(Text, Text)]
namesFromAttrs =
  (Attr -> [(Text, Text)]) -> [Attr] -> [(Text, Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
    ( \case
        Id Text
_ -> []
        Class Text
_ -> []
        Attr Text
a Maybe Expr
b -> Text -> Maybe Expr -> [(Text, Text)]
f Text
a Maybe Expr
b
    )
 where
  f :: Text -> Maybe Expr -> [(Text, Text)]
f Text
"id" Maybe Expr
_ = []
  f Text
"class" Maybe Expr
_ = []
  f Text
a (Just (SingleQuoteString Text
b)) = [(Text
a, Text
b)]
  f Text
a (Just (Int Int
b)) = [(Text
a, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
b)]
  f Text
_ (Just Expr
_) = String -> [(Text, Text)]
forall a. HasCallStack => String -> a
error String
"The attribute is not a string"
  f Text
a Maybe Expr
Nothing = [(Text
a, Text
a)]

-- | Group multiple classes or IDs in a single class or ID, and transform the
-- other attributes in 'SingleQuoteString's.
groupAttrs :: [Attr] -> [Attr]
groupAttrs :: [Attr] -> [Attr]
groupAttrs [Attr]
attrs = [Attr]
elemId [Attr] -> [Attr] -> [Attr]
forall a. Semigroup a => a -> a -> a
<> [Attr]
elemClass [Attr] -> [Attr] -> [Attr]
forall a. Semigroup a => a -> a -> a
<> [Attr]
elemAttrs
 where
  idNames :: [Text]
idNames = [Attr] -> [Text]
idNamesFromAttrs [Attr]
attrs
  idNames' :: Text
  idNames' :: Text
idNames' = Text -> [Text] -> Text
T.intercalate Text
" " [Text]
idNames
  elemId :: [Attr]
elemId =
    if [Text]
idNames [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== []
      then []
      else [Text -> Attr
Id Text
idNames']

  classNames :: [Text]
classNames = [Attr] -> [Text]
classNamesFromAttrs [Attr]
attrs
  classNames' :: Text
  classNames' :: Text
classNames' = Text -> [Text] -> Text
T.intercalate Text
" " [Text]
classNames
  elemClass :: [Attr]
elemClass =
    if [Text]
classNames [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== []
      then []
      else [Text -> Attr
Class Text
classNames']

  attrs' :: [(Text, Text)]
attrs' = [Attr] -> [(Text, Text)]
namesFromAttrs [Attr]
attrs
  elemAttrs :: [Attr]
elemAttrs = ((Text, Text) -> Attr) -> [(Text, Text)] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
a, Text
b) -> Text -> Maybe Expr -> Attr
Attr Text
a (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ Text -> Expr
SingleQuoteString Text
b)) [(Text, Text)]
attrs'