{-# LANGUAGE RecordWildCards #-}
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
=
BlockDoctype
| BlockElem Elem TrailingSym [Attr] [Block]
| BlockText TextSyntax [Inline]
|
BlockInclude (Maybe Text) FilePath (Maybe [Block])
|
BlockFragmentDef Text [Text] [Block]
| BlockFragmentCall Text TrailingSym [Attr] [Expr] [Block]
| BlockFor Text (Maybe Text) Expr [Block]
|
CommentType Text
| BlockFilter Text Text
| BlockRawElem Text [Block]
|
BlockDefault Text [Block]
|
BlockImport FilePath (Maybe [Block]) [Block]
| BlockRun Text (Maybe [Block])
|
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
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]
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
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
data = |
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
|
| Head
| Meta
| Main
| Link
| A
| P
| Ul
| Li
| Title
| Table
| Thead
| Tbody
| Tr
| Td
| Dl
| Dt
| Dd
|
| Figure
| Form
| Label
| Blockquote
| Button
| Figcaption
| Audio
| Script
| Style
| Small
| Source
| Pre
| Code
| Img
| IFrame
| Input
| I
| Svg
| Textarea
| Canvas
|
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)
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)
data TextSyntax
=
Normal
|
Pipe
|
Dot
|
Include
|
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)
data Expr
= Variable Text
| Bool Bool
| Int Int
| SingleQuoteString Text
| List [Expr]
| Object [(Expr, Expr)]
|
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
|
Cons Expr Expr
| Block Block
|
Frag [Text] Env [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)
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 []
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)]
_ -> []
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
_ -> []
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]
= [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]
_) = []
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
_) = []
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
_ = []
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]
= (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)]
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'