{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module IHP.HSX.Parser
( parseHsx
, Node (..)
, Attribute (..)
, AttributeValue (..)
, collapseSpace
) where
import Prelude
import Data.Text
import Data.Set
import Text.Megaparsec
import Text.Megaparsec.Char
import Data.Void
import qualified Data.Char as Char
import qualified Data.Text as Text
import Control.Monad.Fail
import Data.String.Conversions
import qualified Data.List as List
import Control.Monad (unless)
import Prelude (show)
import qualified Language.Haskell.Meta as Haskell
import qualified Language.Haskell.TH.Syntax as Haskell
import qualified "template-haskell" Language.Haskell.TH as TH
import qualified Data.Set as Set
import qualified Data.Containers.ListUtils as List
data AttributeValue = TextValue !Text | ExpressionValue !Haskell.Exp deriving (AttributeValue -> AttributeValue -> Bool
(AttributeValue -> AttributeValue -> Bool)
-> (AttributeValue -> AttributeValue -> Bool) -> Eq AttributeValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttributeValue -> AttributeValue -> Bool
$c/= :: AttributeValue -> AttributeValue -> Bool
== :: AttributeValue -> AttributeValue -> Bool
$c== :: AttributeValue -> AttributeValue -> Bool
Eq, Int -> AttributeValue -> ShowS
[AttributeValue] -> ShowS
AttributeValue -> String
(Int -> AttributeValue -> ShowS)
-> (AttributeValue -> String)
-> ([AttributeValue] -> ShowS)
-> Show AttributeValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttributeValue] -> ShowS
$cshowList :: [AttributeValue] -> ShowS
show :: AttributeValue -> String
$cshow :: AttributeValue -> String
showsPrec :: Int -> AttributeValue -> ShowS
$cshowsPrec :: Int -> AttributeValue -> ShowS
Show)
data Attribute = StaticAttribute !Text !AttributeValue | SpreadAttributes !Haskell.Exp deriving (Attribute -> Attribute -> Bool
(Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool) -> Eq Attribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c== :: Attribute -> Attribute -> Bool
Eq, Int -> Attribute -> ShowS
[Attribute] -> ShowS
Attribute -> String
(Int -> Attribute -> ShowS)
-> (Attribute -> String)
-> ([Attribute] -> ShowS)
-> Show Attribute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attribute] -> ShowS
$cshowList :: [Attribute] -> ShowS
show :: Attribute -> String
$cshow :: Attribute -> String
showsPrec :: Int -> Attribute -> ShowS
$cshowsPrec :: Int -> Attribute -> ShowS
Show)
data Node = Node !Text ![Attribute] ![Node] !Bool
| TextNode !Text
| PreEscapedTextNode !Text
| SplicedNode !Haskell.Exp
| Children ![Node]
| !Text
deriving (Node -> Node -> Bool
(Node -> Node -> Bool) -> (Node -> Node -> Bool) -> Eq Node
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c== :: Node -> Node -> Bool
Eq, Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Node] -> ShowS
$cshowList :: [Node] -> ShowS
show :: Node -> String
$cshow :: Node -> String
showsPrec :: Int -> Node -> ShowS
$cshowsPrec :: Int -> Node -> ShowS
Show)
parseHsx :: SourcePos -> Text -> Either (ParseErrorBundle Text Void) Node
parseHsx :: SourcePos -> Text -> Either (ParseErrorBundle Text Void) Node
parseHsx SourcePos
position Text
code = Parsec Void Text Node
-> String -> Text -> Either (ParseErrorBundle Text Void) Node
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (SourcePos -> ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => SourcePos -> m ()
setPosition SourcePos
position ParsecT Void Text Identity ()
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Node
parser) String
"" Text
code
type Parser = Parsec Void Text
setPosition :: SourcePos -> m ()
setPosition SourcePos
pstateSourcePos = (State s e -> State s e) -> m ()
forall e s (m :: * -> *).
MonadParsec e s m =>
(State s e -> State s e) -> m ()
updateParserState (\State s e
state -> State s e
state {
statePosState :: PosState s
statePosState = (State s e -> PosState s
forall s e. State s e -> PosState s
statePosState State s e
state) { SourcePos
pstateSourcePos :: SourcePos
pstateSourcePos :: SourcePos
pstateSourcePos }
})
parser :: Parser Node
parser :: Parsec Void Text Node
parser = do
ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
Node
node <- Parsec Void Text Node
manyHsxElement Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node
hsxElement
ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure Node
node
hsxElement :: Parsec Void Text Node
hsxElement = Parsec Void Text Node -> Parsec Void Text Node
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parsec Void Text Node
hsxComment Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node -> Parsec Void Text Node
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parsec Void Text Node
hsxSelfClosingElement Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node
hsxNormalElement
manyHsxElement :: Parsec Void Text Node
manyHsxElement = do
[Node]
children <- Parsec Void Text Node -> ParsecT Void Text Identity [Node]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parsec Void Text Node
hsxChild
Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Node] -> Node
Children ([Node] -> [Node]
stripTextNodeWhitespaces [Node]
children))
hsxSelfClosingElement :: Parsec Void Text Node
hsxSelfClosingElement = do
Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'<'
Text
name <- Parser Text
hsxElementName
let isLeaf :: Bool
isLeaf = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
leafs
[Attribute]
attributes <-
if Bool
isLeaf
then Parser Text -> Parser [Attribute]
forall a. Parser a -> Parser [Attribute]
hsxNodeAttributes (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
">" Parser Text -> Parser Text -> Parser Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"/>")
else Parser Text -> Parser [Attribute]
forall a. Parser a -> Parser [Attribute]
hsxNodeAttributes (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"/>")
ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Attribute] -> [Node] -> Bool -> Node
Node Text
name [Attribute]
attributes [] Bool
isLeaf)
hsxNormalElement :: Parsec Void Text Node
hsxNormalElement = do
(Text
name, [Attribute]
attributes) <- ParsecT Void Text Identity (Text, [Attribute])
hsxOpeningElement
let parsePreEscapedTextChildren :: (Text -> Text) -> ParsecT Void Text Identity [Node]
parsePreEscapedTextChildren Text -> Text
transformText = do
let closingElement :: Text
closingElement = Text
"</" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"
Text
text <- String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text)
-> ParsecT Void Text Identity String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> Parser Text -> ParsecT Void Text Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT Void Text Identity Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
closingElement)
[Node] -> ParsecT Void Text Identity [Node]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text -> Node
PreEscapedTextNode (Text -> Text
transformText Text
text)]
let parseNormalHSXChildren :: ParsecT Void Text Identity [Node]
parseNormalHSXChildren = [Node] -> [Node]
stripTextNodeWhitespaces ([Node] -> [Node])
-> ParsecT Void Text Identity [Node]
-> ParsecT Void Text Identity [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [Node]
-> ParsecT Void Text Identity [Node]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Parsec Void Text Node
-> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity [Node]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill (Parsec Void Text Node -> Parsec Void Text Node
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parsec Void Text Node
hsxChild) (ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void Text Identity ()
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, IsString (Tokens s), Semigroup (Tokens s),
Token s ~ Char, Tokens s ~ Text) =>
Text -> m ()
hsxClosingElement Text
name))))
[Node]
children <- case Text
name of
Text
"script" -> (Text -> Text) -> ParsecT Void Text Identity [Node]
parsePreEscapedTextChildren Text -> Text
Text.strip
Text
"style" -> (Text -> Text) -> ParsecT Void Text Identity [Node]
parsePreEscapedTextChildren (Text -> Text
collapseSpace (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip)
Text
otherwise -> ParsecT Void Text Identity [Node]
parseNormalHSXChildren
Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Attribute] -> [Node] -> Bool -> Node
Node Text
name [Attribute]
attributes [Node]
children Bool
False)
hsxOpeningElement :: ParsecT Void Text Identity (Text, [Attribute])
hsxOpeningElement = do
Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'<'
Text
name <- Parser Text
hsxElementName
ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
[Attribute]
attributes <- ParsecT Void Text Identity Char -> Parser [Attribute]
forall a. Parser a -> Parser [Attribute]
hsxNodeAttributes (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'>')
(Text, [Attribute])
-> ParsecT Void Text Identity (Text, [Attribute])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
name, [Attribute]
attributes)
hsxComment :: Parser Node
= do
Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"<!--"
String
body :: String <- ParsecT Void Text Identity Char
-> Parser Text -> ParsecT Void Text Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True)) (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-->")
ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Node
CommentNode (String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs String
body))
hsxNodeAttributes :: Parser a -> Parser [Attribute]
hsxNodeAttributes :: Parser a -> Parser [Attribute]
hsxNodeAttributes Parser a
end = Parser [Attribute]
staticAttributes
where
staticAttributes :: Parser [Attribute]
staticAttributes = do
[Attribute]
attributes <- ParsecT Void Text Identity Attribute
-> Parser a -> Parser [Attribute]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill (ParsecT Void Text Identity Attribute
hsxNodeAttribute ParsecT Void Text Identity Attribute
-> ParsecT Void Text Identity Attribute
-> ParsecT Void Text Identity Attribute
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Attribute
hsxSplicedAttributes) Parser a
end
let staticAttributes :: [Attribute]
staticAttributes = (Attribute -> Bool) -> [Attribute] -> [Attribute]
forall a. (a -> Bool) -> [a] -> [a]
List.filter Attribute -> Bool
isStaticAttribute [Attribute]
attributes
let keys :: [Text]
keys = (Attribute -> Text) -> [Attribute] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
List.map (\(StaticAttribute Text
name AttributeValue
_) -> Text
name) [Attribute]
staticAttributes
let uniqueKeys :: [Text]
uniqueKeys = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
List.nubOrd [Text]
keys
Bool
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text]
keys [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
uniqueKeys) (String -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void Text Identity ())
-> String -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ String
"Duplicate attribute found in tag: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show ([Text]
keys [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
List.\\ [Text]
uniqueKeys))
[Attribute] -> Parser [Attribute]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Attribute]
attributes
isStaticAttribute :: Attribute -> Bool
isStaticAttribute (StaticAttribute Text
_ AttributeValue
_) = Bool
True
isStaticAttribute Attribute
_ = Bool
False
hsxSplicedAttributes :: Parser Attribute
hsxSplicedAttributes :: ParsecT Void Text Identity Attribute
hsxSplicedAttributes = do
Text
name <- Parser Text -> Parser Text -> Parser Text -> Parser Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"{...") (Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"}") (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}'))
ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
Exp
haskellExpression <- case String -> Either String Exp
Haskell.parseExp (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
name) of
Right Exp
expression -> Exp -> ParsecT Void Text Identity Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Exp
patchExpr Exp
expression)
Left String
error -> String -> ParsecT Void Text Identity Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ShowS
forall a. Show a => a -> String
show String
error)
Attribute -> ParsecT Void Text Identity Attribute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Attribute
SpreadAttributes Exp
haskellExpression)
hsxNodeAttribute :: ParsecT Void Text Identity Attribute
hsxNodeAttribute = do
Text
key <- Parser Text
hsxAttributeName
ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
let attributeWithoutValue :: ParsecT Void Text Identity Attribute
attributeWithoutValue = do
let value :: Text
value = if Text
"data-" Text -> Text -> Bool
`Text.isPrefixOf` Text
key
then Text
"true"
else Text
key
Attribute -> ParsecT Void Text Identity Attribute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> AttributeValue -> Attribute
StaticAttribute Text
key (Text -> AttributeValue
TextValue Text
value))
let attributeWithValue :: ParsecT Void Text Identity Attribute
attributeWithValue = do
Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'='
ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
AttributeValue
value <- Parser AttributeValue
hsxQuotedValue Parser AttributeValue
-> Parser AttributeValue -> Parser AttributeValue
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser AttributeValue
hsxSplicedValue
ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
Attribute -> ParsecT Void Text Identity Attribute
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> AttributeValue -> Attribute
StaticAttribute Text
key AttributeValue
value)
ParsecT Void Text Identity Attribute
attributeWithValue ParsecT Void Text Identity Attribute
-> ParsecT Void Text Identity Attribute
-> ParsecT Void Text Identity Attribute
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Attribute
attributeWithoutValue
hsxAttributeName :: Parser Text
hsxAttributeName :: Parser Text
hsxAttributeName = do
Text
name <- Parser Text
ParsecT Void Text Identity (Tokens Text)
rawAttribute
Bool
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
isValidAttributeName Text
name) (String -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void Text Identity ())
-> String -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid attribute name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
name)
Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
name
where
isValidAttributeName :: Text -> Bool
isValidAttributeName Text
name =
Text
"data-" Text -> Text -> Bool
`Text.isPrefixOf` Text
name
Bool -> Bool -> Bool
|| Text
"aria-" Text -> Text -> Bool
`Text.isPrefixOf` Text
name
Bool -> Bool -> Bool
|| Text
"hx-" Text -> Text -> Bool
`Text.isPrefixOf` Text
name
Bool -> Bool -> Bool
|| Text
"hx-" Text -> Text -> Bool
`Text.isPrefixOf` Text
name
Bool -> Bool -> Bool
|| Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
attributes
rawAttribute :: ParsecT Void Text Identity (Tokens Text)
rawAttribute = Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (\Token Text
c -> Char -> Bool
Char.isAlphaNum Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
hsxQuotedValue :: Parser AttributeValue
hsxQuotedValue :: Parser AttributeValue
hsxQuotedValue = do
Text
value <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char -> Parser Text -> Parser Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"') (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"') (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe String
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\"'))
AttributeValue -> Parser AttributeValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> AttributeValue
TextValue Text
value)
hsxSplicedValue :: Parser AttributeValue
hsxSplicedValue :: Parser AttributeValue
hsxSplicedValue = do
Text
value <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char -> Parser Text -> Parser Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'{') (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'}') (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}'))
Exp
haskellExpression <- case String -> Either String Exp
Haskell.parseExp (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
value) of
Right Exp
expression -> Exp -> ParsecT Void Text Identity Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Exp
patchExpr Exp
expression)
Left String
error -> String -> ParsecT Void Text Identity Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ShowS
forall a. Show a => a -> String
show String
error)
AttributeValue -> Parser AttributeValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> AttributeValue
ExpressionValue Exp
haskellExpression)
hsxClosingElement :: Text -> m ()
hsxClosingElement Text
name = (Tokens s -> m ()
forall e s (m :: * -> *).
(MonadParsec e s m, IsString (Tokens s), Semigroup (Tokens s),
Token s ~ Char) =>
Tokens s -> m ()
hsxClosingElement' Text
Tokens s
name) m () -> String -> m ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
friendlyErrorMessage
where
friendlyErrorMessage :: String
friendlyErrorMessage = ShowS
forall a. Show a => a -> String
show (Text -> String
Text.unpack (Text
"</" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"))
hsxClosingElement' :: Tokens s -> m ()
hsxClosingElement' Tokens s
name = do
Tokens s
_ <- Tokens s -> m (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Tokens s
"</" Tokens s -> Tokens s -> Tokens s
forall a. Semigroup a => a -> a -> a
<> Tokens s
name)
m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
Token s -> m (Token s)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char (Char
Token s
'>')
() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
hsxChild :: Parsec Void Text Node
hsxChild = Parsec Void Text Node
hsxElement Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node
hsxSplicedNode Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node -> Parsec Void Text Node
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void Text Identity ()
-> Parsec Void Text Node -> Parsec Void Text Node
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parsec Void Text Node
hsxElement) Parsec Void Text Node
-> Parsec Void Text Node -> Parsec Void Text Node
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text Node
hsxText
hsxText :: Parser Node
hsxText :: Parsec Void Text Node
hsxText = Text -> Node
buildTextNode (Text -> Node) -> Parser Text -> Parsec Void Text Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"text") (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'<' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>')
buildTextNode :: Text -> Node
buildTextNode :: Text -> Node
buildTextNode Text
value = Text -> Node
TextNode (Text -> Text
collapseSpace Text
value)
data TokenTree = TokenLeaf Text | TokenNode [TokenTree] deriving (Int -> TokenTree -> ShowS
[TokenTree] -> ShowS
TokenTree -> String
(Int -> TokenTree -> ShowS)
-> (TokenTree -> String)
-> ([TokenTree] -> ShowS)
-> Show TokenTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TokenTree] -> ShowS
$cshowList :: [TokenTree] -> ShowS
show :: TokenTree -> String
$cshow :: TokenTree -> String
showsPrec :: Int -> TokenTree -> ShowS
$cshowsPrec :: Int -> TokenTree -> ShowS
Show)
hsxSplicedNode :: Parser Node
hsxSplicedNode :: Parsec Void Text Node
hsxSplicedNode = do
Text
expression <- Parser Text
doParse
Exp
haskellExpression <- case String -> Either String Exp
Haskell.parseExp (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
expression) of
Right Exp
expression -> Exp -> ParsecT Void Text Identity Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Exp
patchExpr Exp
expression)
Left String
error -> String -> ParsecT Void Text Identity Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ShowS
forall a. Show a => a -> String
show String
error)
Node -> Parsec Void Text Node
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Node
SplicedNode Exp
haskellExpression)
where
doParse :: Parser Text
doParse = do
TokenTree
tree <- ParsecT Void Text Identity TokenTree
node
let value :: Text
value = (Text -> TokenTree -> Text
treeToString Text
"" TokenTree
tree)
Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.init (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
Text.tail Text
value
parseTree :: ParsecT Void Text Identity TokenTree
parseTree = ParsecT Void Text Identity TokenTree
node ParsecT Void Text Identity TokenTree
-> ParsecT Void Text Identity TokenTree
-> ParsecT Void Text Identity TokenTree
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity TokenTree
leaf
node :: ParsecT Void Text Identity TokenTree
node = [TokenTree] -> TokenTree
TokenNode ([TokenTree] -> TokenTree)
-> ParsecT Void Text Identity [TokenTree]
-> ParsecT Void Text Identity TokenTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [TokenTree]
-> ParsecT Void Text Identity [TokenTree]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'{') (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'}') (ParsecT Void Text Identity TokenTree
-> ParsecT Void Text Identity [TokenTree]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void Text Identity TokenTree
parseTree)
leaf :: ParsecT Void Text Identity TokenTree
leaf = Text -> TokenTree
TokenLeaf (Text -> TokenTree)
-> Parser Text -> ParsecT Void Text Identity TokenTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (\Token Text
c -> Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{' Bool -> Bool -> Bool
&& Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}')
treeToString :: Text -> TokenTree -> Text
treeToString :: Text -> TokenTree -> Text
treeToString Text
acc (TokenLeaf Text
value) = Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value
treeToString Text
acc (TokenNode []) = Text
acc
treeToString Text
acc (TokenNode (TokenTree
x:[TokenTree]
xs)) = ((Text -> TokenTree -> Text
treeToString (Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{") TokenTree
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([Text] -> Text
Text.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (TokenTree -> Text) -> [TokenTree] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> TokenTree -> Text
treeToString Text
"") [TokenTree]
xs)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
hsxElementName :: Parser Text
hsxElementName :: Parser Text
hsxElementName = do
Text
name <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"identifier") (\Token Text
c -> Char -> Bool
Char.isAlphaNum Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
let isValidParent :: Bool
isValidParent = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
parents
let isValidLeaf :: Bool
isValidLeaf = Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Text
leafs
let isValidCustomWebComponent :: Bool
isValidCustomWebComponent = Text
"-" Text -> Text -> Bool
`Text.isInfixOf` Text
name
Bool
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isValidParent Bool -> Bool -> Bool
|| Bool
isValidLeaf Bool -> Bool -> Bool
|| Bool
isValidCustomWebComponent) (String -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void Text Identity ())
-> String -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid tag name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
name)
ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
name
hsxIdentifier :: Parser Text
hsxIdentifier :: Parser Text
hsxIdentifier = do
Text
name <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"identifier") (\Token Text
c -> Char -> Bool
Char.isAlphaNum Char
Token Text
c Bool -> Bool -> Bool
|| Char
Token Text
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_')
ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
Text -> Parser Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
name
attributes :: Set Text
attributes :: Set Text
attributes = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
[ Text
"accept", Text
"accept-charset", Text
"accesskey", Text
"action", Text
"alt", Text
"async"
, Text
"autocomplete", Text
"autofocus", Text
"autoplay", Text
"challenge", Text
"charset"
, Text
"checked", Text
"cite", Text
"class", Text
"cols", Text
"colspan", Text
"content"
, Text
"contenteditable", Text
"contextmenu", Text
"controls", Text
"coords", Text
"data"
, Text
"datetime", Text
"defer", Text
"dir", Text
"disabled", Text
"draggable", Text
"enctype"
, Text
"form", Text
"formaction", Text
"formenctype", Text
"formmethod", Text
"formnovalidate"
, Text
"for"
, Text
"formtarget", Text
"headers", Text
"height", Text
"hidden", Text
"high", Text
"href"
, Text
"hreflang", Text
"http-equiv", Text
"icon", Text
"id", Text
"ismap", Text
"item", Text
"itemprop"
, Text
"itemscope", Text
"itemtype"
, Text
"keytype", Text
"label", Text
"lang", Text
"list", Text
"loop", Text
"low", Text
"manifest", Text
"max"
, Text
"maxlength", Text
"media", Text
"method", Text
"min", Text
"multiple", Text
"name"
, Text
"novalidate", Text
"onbeforeonload", Text
"onbeforeprint", Text
"onblur", Text
"oncanplay"
, Text
"oncanplaythrough", Text
"onchange", Text
"oncontextmenu", Text
"onclick"
, Text
"ondblclick", Text
"ondrag", Text
"ondragend", Text
"ondragenter", Text
"ondragleave"
, Text
"ondragover", Text
"ondragstart", Text
"ondrop", Text
"ondurationchange", Text
"onemptied"
, Text
"onended", Text
"onerror", Text
"onfocus", Text
"onformchange", Text
"onforminput"
, Text
"onhaschange", Text
"oninput", Text
"oninvalid", Text
"onkeydown", Text
"onkeyup"
, Text
"onload", Text
"onloadeddata", Text
"onloadedmetadata", Text
"onloadstart"
, Text
"onmessage", Text
"onmousedown", Text
"onmousemove", Text
"onmouseout", Text
"onmouseover"
, Text
"onmouseup", Text
"onmousewheel", Text
"ononline", Text
"onpagehide", Text
"onpageshow"
, Text
"onpause", Text
"onplay", Text
"onplaying", Text
"onprogress", Text
"onpropstate"
, Text
"onratechange", Text
"onreadystatechange", Text
"onredo", Text
"onresize", Text
"onscroll"
, Text
"onseeked", Text
"onseeking", Text
"onselect", Text
"onstalled", Text
"onstorage"
, Text
"onsubmit", Text
"onsuspend", Text
"ontimeupdate", Text
"onundo", Text
"onunload"
, Text
"onvolumechange", Text
"onwaiting", Text
"open", Text
"optimum", Text
"pattern", Text
"ping"
, Text
"placeholder", Text
"preload", Text
"pubdate", Text
"radiogroup", Text
"readonly", Text
"rel"
, Text
"required", Text
"reversed", Text
"rows", Text
"rowspan", Text
"sandbox", Text
"scope"
, Text
"scoped", Text
"seamless", Text
"selected", Text
"shape", Text
"size", Text
"sizes", Text
"span"
, Text
"spellcheck", Text
"src", Text
"srcdoc", Text
"srcset", Text
"start", Text
"step", Text
"style", Text
"subject"
, Text
"summary", Text
"tabindex", Text
"target", Text
"title", Text
"type", Text
"usemap", Text
"value"
, Text
"width", Text
"wrap", Text
"xmlns"
, Text
"ontouchstart", Text
"download"
, Text
"allowtransparency", Text
"minlength", Text
"maxlength", Text
"property"
, Text
"role"
, Text
"d", Text
"viewBox", Text
"cx", Text
"cy", Text
"r", Text
"x", Text
"y", Text
"text-anchor", Text
"alignment-baseline"
, Text
"line-spacing", Text
"letter-spacing"
, Text
"integrity", Text
"crossorigin", Text
"poster"
, Text
"accent-height", Text
"accumulate", Text
"additive", Text
"alphabetic", Text
"amplitude"
, Text
"arabic-form", Text
"ascent", Text
"attributeName", Text
"attributeType", Text
"azimuth"
, Text
"baseFrequency", Text
"baseProfile", Text
"bbox", Text
"begin", Text
"bias", Text
"by", Text
"calcMode"
, Text
"cap-height", Text
"class", Text
"clipPathUnits", Text
"contentScriptType"
, Text
"contentStyleType", Text
"cx", Text
"cy", Text
"d", Text
"descent", Text
"diffuseConstant", Text
"divisor"
, Text
"dur", Text
"dx", Text
"dy", Text
"edgeMode", Text
"elevation", Text
"end", Text
"exponent"
, Text
"externalResourcesRequired", Text
"filterRes", Text
"filterUnits", Text
"font-family"
, Text
"font-size", Text
"font-stretch", Text
"font-style", Text
"font-variant", Text
"font-weight"
, Text
"format", Text
"from", Text
"fx", Text
"fy", Text
"g1", Text
"g2", Text
"glyph-name", Text
"glyphRef"
, Text
"gradientTransform", Text
"gradientUnits", Text
"hanging", Text
"height", Text
"horiz-adv-x"
, Text
"horiz-origin-x", Text
"horiz-origin-y", Text
"id", Text
"ideographic", Text
"in", Text
"in2"
, Text
"intercept", Text
"k", Text
"k1", Text
"k2", Text
"k3", Text
"k4", Text
"kernelMatrix", Text
"kernelUnitLength"
, Text
"keyPoints", Text
"keySplines", Text
"keyTimes", Text
"lang", Text
"lengthAdjust"
, Text
"limitingConeAngle", Text
"local", Text
"markerHeight", Text
"markerUnits", Text
"markerWidth"
, Text
"maskContentUnits", Text
"maskUnits", Text
"mathematical", Text
"max", Text
"media", Text
"method"
, Text
"min", Text
"mode", Text
"name", Text
"numOctaves", Text
"offset", Text
"onabort", Text
"onactivate"
, Text
"onbegin", Text
"onclick", Text
"onend", Text
"onerror", Text
"onfocusin", Text
"onfocusout", Text
"onload"
, Text
"onmousedown", Text
"onmousemove", Text
"onmouseout", Text
"onmouseover", Text
"onmouseup"
, Text
"onrepeat", Text
"onresize", Text
"onscroll", Text
"onunload", Text
"onzoom", Text
"operator", Text
"order"
, Text
"orient", Text
"orientation", Text
"origin", Text
"overline-position", Text
"overline-thickness"
, Text
"panose-1", Text
"path", Text
"pathLength", Text
"patternContentUnits", Text
"patternTransform"
, Text
"patternUnits", Text
"points", Text
"pointsAtX", Text
"pointsAtY", Text
"pointsAtZ"
, Text
"preserveAlpha", Text
"preserveAspectRatio", Text
"primitiveUnits", Text
"r", Text
"radius"
, Text
"refX", Text
"refY", Text
"rendering-intent", Text
"repeatCount", Text
"repeatDur"
, Text
"requiredExtensions", Text
"requiredFeatures", Text
"restart", Text
"result", Text
"rotate", Text
"rx"
, Text
"ry", Text
"scale", Text
"seed", Text
"slope", Text
"spacing", Text
"specularConstant"
, Text
"specularExponent", Text
"spreadMethod", Text
"startOffset", Text
"stdDeviation", Text
"stemh"
, Text
"stemv", Text
"stitchTiles", Text
"strikethrough-position", Text
"strikethrough-thickness"
, Text
"string", Text
"style", Text
"surfaceScale", Text
"systemLanguage", Text
"tableValues", Text
"target"
, Text
"targetX", Text
"targetY", Text
"textLength", Text
"title", Text
"to", Text
"transform", Text
"type", Text
"u1"
, Text
"u2", Text
"underline-position", Text
"underline-thickness", Text
"unicode", Text
"unicode-range"
, Text
"units-per-em", Text
"v-alphabetic", Text
"v-hanging", Text
"v-ideographic", Text
"v-mathematical"
, Text
"values", Text
"version", Text
"vert-adv-y", Text
"vert-origin-x", Text
"vert-origin-y", Text
"viewBox"
, Text
"viewTarget", Text
"width", Text
"widths", Text
"x", Text
"x-height", Text
"x1", Text
"x2"
, Text
"xChannelSelector", Text
"xlink:actuate", Text
"xlink:arcrole", Text
"xlink:href"
, Text
"xlink:role", Text
"xlink:show", Text
"xlink:title", Text
"xlink:type", Text
"xml:base"
, Text
"xml:lang", Text
"xml:space", Text
"y", Text
"y1", Text
"y2", Text
"yChannelSelector", Text
"z", Text
"zoomAndPan"
, Text
"alignment-baseline", Text
"baseline-shift", Text
"clip-path", Text
"clip-rule"
, Text
"clip", Text
"color-interpolation-filters", Text
"color-interpolation"
, Text
"color-profile", Text
"color-rendering", Text
"color", Text
"cursor", Text
"direction"
, Text
"display", Text
"dominant-baseline", Text
"enable-background", Text
"fill-opacity"
, Text
"fill-rule", Text
"fill", Text
"filter", Text
"flood-color", Text
"flood-opacity"
, Text
"font-size-adjust", Text
"glyph-orientation-horizontal"
, Text
"glyph-orientation-vertical", Text
"image-rendering", Text
"kerning", Text
"letter-spacing"
, Text
"lighting-color", Text
"marker-end", Text
"marker-mid", Text
"marker-start", Text
"mask"
, Text
"opacity", Text
"overflow", Text
"pointer-events", Text
"shape-rendering", Text
"stop-color"
, Text
"stop-opacity", Text
"stroke-dasharray", Text
"stroke-dashoffset", Text
"stroke-linecap"
, Text
"stroke-linejoin", Text
"stroke-miterlimit", Text
"stroke-opacity", Text
"stroke-width"
, Text
"stroke", Text
"text-anchor", Text
"text-decoration", Text
"text-rendering", Text
"unicode-bidi"
, Text
"visibility", Text
"word-spacing", Text
"writing-mode", Text
"is"
, Text
"cellspacing", Text
"cellpadding", Text
"bgcolor", Text
"classes"
, Text
"loading"
, Text
"frameborder", Text
"allow", Text
"allowfullscreen", Text
"nonce", Text
"referrerpolicy"
]
parents :: Set Text
parents :: Set Text
parents = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
[ Text
"a"
, Text
"abbr"
, Text
"address"
, Text
"animate"
, Text
"animateMotion"
, Text
"animateTransform"
, Text
"article"
, Text
"aside"
, Text
"audio"
, Text
"b"
, Text
"bdi"
, Text
"bdo"
, Text
"blink"
, Text
"blockquote"
, Text
"body"
, Text
"button"
, Text
"canvas"
, Text
"caption"
, Text
"circle"
, Text
"cite"
, Text
"clipPath"
, Text
"code"
, Text
"colgroup"
, Text
"command"
, Text
"data"
, Text
"datalist"
, Text
"dd"
, Text
"defs"
, Text
"del"
, Text
"desc"
, Text
"details"
, Text
"dfn"
, Text
"dialog"
, Text
"discard"
, Text
"div"
, Text
"dl"
, Text
"dt"
, Text
"ellipse"
, Text
"em"
, Text
"feBlend"
, Text
"feColorMatrix"
, Text
"feComponentTransfer"
, Text
"feComposite"
, Text
"feConvolveMatrix"
, Text
"feDiffuseLighting"
, Text
"feDisplacementMap"
, Text
"feDistantLight"
, Text
"feDropShadow"
, Text
"feFlood"
, Text
"feFuncA"
, Text
"feFuncB"
, Text
"feFuncG"
, Text
"feFuncR"
, Text
"feGaussianBlur"
, Text
"feImage"
, Text
"feMerge"
, Text
"feMergeNode"
, Text
"feMorphology"
, Text
"feOffset"
, Text
"fePointLight"
, Text
"feSpecularLighting"
, Text
"feSpotLight"
, Text
"feTile"
, Text
"feTurbulence"
, Text
"fieldset"
, Text
"figcaption"
, Text
"figure"
, Text
"filter"
, Text
"footer"
, Text
"foreignObject"
, Text
"form"
, Text
"g"
, Text
"h1"
, Text
"h2"
, Text
"h3"
, Text
"h4"
, Text
"h5"
, Text
"h6"
, Text
"hatch"
, Text
"hatchpath"
, Text
"head"
, Text
"header"
, Text
"hgroup"
, Text
"html"
, Text
"i"
, Text
"iframe"
, Text
"ins"
, Text
"ion-icon"
, Text
"kbd"
, Text
"label"
, Text
"legend"
, Text
"li"
, Text
"line"
, Text
"linearGradient"
, Text
"loading"
, Text
"main"
, Text
"map"
, Text
"mark"
, Text
"marker"
, Text
"marquee"
, Text
"mask"
, Text
"menu"
, Text
"mesh"
, Text
"meshgradient"
, Text
"meshpatch"
, Text
"meshrow"
, Text
"metadata"
, Text
"meter"
, Text
"mpath"
, Text
"nav"
, Text
"noscript"
, Text
"object"
, Text
"ol"
, Text
"optgroup"
, Text
"option"
, Text
"output"
, Text
"p"
, Text
"path"
, Text
"pattern"
, Text
"picture"
, Text
"polygon"
, Text
"polyline"
, Text
"pre"
, Text
"progress"
, Text
"q"
, Text
"radialGradient"
, Text
"rect"
, Text
"rp"
, Text
"rt"
, Text
"ruby"
, Text
"s"
, Text
"samp"
, Text
"script"
, Text
"section"
, Text
"select"
, Text
"set"
, Text
"slot"
, Text
"small"
, Text
"source"
, Text
"span"
, Text
"stop"
, Text
"strong"
, Text
"style"
, Text
"sub"
, Text
"summary"
, Text
"sup"
, Text
"svg"
, Text
"switch"
, Text
"symbol"
, Text
"table"
, Text
"tbody"
, Text
"td"
, Text
"template"
, Text
"text"
, Text
"textPath"
, Text
"textarea"
, Text
"tfoot"
, Text
"th"
, Text
"thead"
, Text
"time"
, Text
"title"
, Text
"tr"
, Text
"track"
, Text
"tspan"
, Text
"u"
, Text
"ul"
, Text
"unknown"
, Text
"use"
, Text
"var"
, Text
"video"
, Text
"view"
, Text
"wbr"
]
leafs :: Set Text
leafs :: Set Text
leafs = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
[ Text
"area"
, Text
"base"
, Text
"br"
, Text
"col"
, Text
"embed"
, Text
"hr"
, Text
"img"
, Text
"input"
, Text
"link"
, Text
"meta"
, Text
"param"
]
stripTextNodeWhitespaces :: [Node] -> [Node]
stripTextNodeWhitespaces [Node]
nodes = [Node] -> [Node]
stripLastTextNodeWhitespaces ([Node] -> [Node]
stripFirstTextNodeWhitespaces [Node]
nodes)
stripLastTextNodeWhitespaces :: [Node] -> [Node]
stripLastTextNodeWhitespaces [Node]
nodes =
let strippedLastElement :: Maybe Node
strippedLastElement = if [Node] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [Node]
nodes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then case [Node] -> Node
forall a. [a] -> a
List.last [Node]
nodes of
TextNode Text
text -> Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
forall a b. (a -> b) -> a -> b
$ Text -> Node
TextNode (Text -> Text
Text.stripEnd Text
text)
Node
otherwise -> Maybe Node
forall a. Maybe a
Nothing
else Maybe Node
forall a. Maybe a
Nothing
in case Maybe Node
strippedLastElement of
Just Node
last -> (([Node], [Node]) -> [Node]
forall a b. (a, b) -> a
fst (([Node], [Node]) -> [Node]) -> ([Node], [Node]) -> [Node]
forall a b. (a -> b) -> a -> b
$ Int -> [Node] -> ([Node], [Node])
forall a. Int -> [a] -> ([a], [a])
List.splitAt (([Node] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [Node]
nodes) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Node]
nodes) [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
last]
Maybe Node
Nothing -> [Node]
nodes
stripFirstTextNodeWhitespaces :: [Node] -> [Node]
stripFirstTextNodeWhitespaces [Node]
nodes =
let strippedFirstElement :: Maybe Node
strippedFirstElement = if [Node] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length [Node]
nodes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then case [Node] -> Node
forall a. [a] -> a
List.head [Node]
nodes of
TextNode Text
text -> Node -> Maybe Node
forall a. a -> Maybe a
Just (Node -> Maybe Node) -> Node -> Maybe Node
forall a b. (a -> b) -> a -> b
$ Text -> Node
TextNode (Text -> Text
Text.stripStart Text
text)
Node
otherwise -> Maybe Node
forall a. Maybe a
Nothing
else Maybe Node
forall a. Maybe a
Nothing
in case Maybe Node
strippedFirstElement of
Just Node
first -> Node
firstNode -> [Node] -> [Node]
forall a. a -> [a] -> [a]
:([Node] -> [Node]
forall a. [a] -> [a]
List.tail [Node]
nodes)
Maybe Node
Nothing -> [Node]
nodes
collapseSpace :: Text -> Text
collapseSpace :: Text -> Text
collapseSpace Text
text = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
filterDuplicateSpaces (Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
text)
where
filterDuplicateSpaces :: String -> String
filterDuplicateSpaces :: ShowS
filterDuplicateSpaces String
string = String -> Bool -> String
filterDuplicateSpaces' String
string Bool
False
filterDuplicateSpaces' :: String -> Bool -> String
filterDuplicateSpaces' :: String -> Bool -> String
filterDuplicateSpaces' (Char
char:String
rest) Bool
True | Char -> Bool
Char.isSpace Char
char = String -> Bool -> String
filterDuplicateSpaces' String
rest Bool
True
filterDuplicateSpaces' (Char
char:String
rest) Bool
False | Char -> Bool
Char.isSpace Char
char = Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:(String -> Bool -> String
filterDuplicateSpaces' String
rest Bool
True)
filterDuplicateSpaces' (Char
char:String
rest) Bool
isRemovingSpaces = Char
charChar -> ShowS
forall a. a -> [a] -> [a]
:(String -> Bool -> String
filterDuplicateSpaces' String
rest Bool
False)
filterDuplicateSpaces' [] Bool
isRemovingSpaces = []
patchExpr :: TH.Exp -> TH.Exp
patchExpr :: Exp -> Exp
patchExpr (TH.UInfixE (TH.VarE Name
varName) (TH.VarE Name
hash) (TH.VarE Name
labelValue)) | Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"#" = Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE Name
varName) Exp
fromLabel
where
fromLabel :: Exp
fromLabel = Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"fromLabel")) (TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (Name -> String
forall a. Show a => a -> String
show Name
labelValue)))
patchExpr input :: Exp
input@(TH.UInfixE (TH.UInfixE Exp
a (TH.VarE Name
arrow) (TH.VarE Name
get)) (TH.VarE Name
hash) (TH.VarE Name
labelValue)) | (Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"#") Bool -> Bool -> Bool
&& (Name
arrow Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"|>") Bool -> Bool -> Bool
&& (Name
get Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"get") =
(Exp -> Exp -> Exp -> Exp
TH.UInfixE (Exp -> Exp
patchExpr Exp
a) (Name -> Exp
TH.VarE Name
arrow) (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE Name
get) Exp
fromLabel))
where
fromLabel :: Exp
fromLabel = Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"fromLabel")) (TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (Name -> String
forall a. Show a => a -> String
show Name
labelValue)))
patchExpr (TH.UInfixE (TH.UInfixE Exp
a Exp
b Exp
get) (TH.VarE Name
hash) (TH.AppE (TH.VarE Name
labelValue) (TH.VarE Name
d))) | (Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"#") =
Exp -> Exp -> Exp -> Exp
TH.UInfixE (Exp -> Exp
patchExpr Exp
a) (Exp -> Exp
patchExpr Exp
b) (Exp -> Exp -> Exp
TH.AppE (Exp -> Exp -> Exp
TH.AppE Exp
get Exp
fromLabel) (Name -> Exp
TH.VarE Name
d))
where
fromLabel :: Exp
fromLabel = Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"fromLabel")) (TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (Name -> String
forall a. Show a => a -> String
show Name
labelValue)))
patchExpr (TH.UInfixE (TH.VarE Name
varName) (TH.VarE Name
hash) (TH.AppE (TH.VarE Name
labelValue) Exp
arg)) | Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"#" = Exp -> Exp -> Exp
TH.AppE (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE Name
varName) Exp
fromLabel) Exp
arg
where
fromLabel :: Exp
fromLabel = Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"fromLabel")) (TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (Name -> String
forall a. Show a => a -> String
show Name
labelValue)))
patchExpr (TH.UInfixE (TH.VarE Name
a) (TH.VarE Name
hash) (TH.AppE (TH.VarE Name
labelValue) (TH.VarE Name
b))) | Name
hash Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
TH.mkName String
"#" =
Exp -> Exp -> Exp
TH.AppE (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE Name
a) Exp
fromLabel) (Name -> Exp
TH.VarE Name
b)
where
fromLabel :: Exp
fromLabel = Exp -> Type -> Exp
TH.AppTypeE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"fromLabel")) (TyLit -> Type
TH.LitT (String -> TyLit
TH.StrTyLit (Name -> String
forall a. Show a => a -> String
show Name
labelValue)))
patchExpr (TH.UInfixE Exp
a Exp
b Exp
c) = Exp -> Exp -> Exp -> Exp
TH.UInfixE (Exp -> Exp
patchExpr Exp
a) (Exp -> Exp
patchExpr Exp
b) (Exp -> Exp
patchExpr Exp
c)
patchExpr (TH.ParensE Exp
e) = Exp -> Exp
TH.ParensE (Exp -> Exp
patchExpr Exp
e)
patchExpr (TH.RecUpdE Exp
a [FieldExp]
b) = Exp -> [FieldExp] -> Exp
TH.RecUpdE (Exp -> Exp
patchExpr Exp
a) [FieldExp]
b
patchExpr (TH.AppE Exp
a Exp
b) = Exp -> Exp -> Exp
TH.AppE (Exp -> Exp
patchExpr Exp
a) (Exp -> Exp
patchExpr Exp
b)
patchExpr (TH.LamE [Pat]
a Exp
b) = [Pat] -> Exp -> Exp
TH.LamE [Pat]
a (Exp -> Exp
patchExpr Exp
b)
patchExpr (TH.LetE [Dec]
a Exp
b) = [Dec] -> Exp -> Exp
TH.LetE [Dec]
a' (Exp -> Exp
patchExpr Exp
b)
where
a' :: [Dec]
a' = (Dec -> Dec) -> [Dec] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
List.map Dec -> Dec
patchDec [Dec]
a
patchDec :: Dec -> Dec
patchDec (TH.ValD Pat
a (TH.NormalB Exp
b) [Dec]
c) = (Pat -> Body -> [Dec] -> Dec
TH.ValD Pat
a (Exp -> Body
TH.NormalB (Exp -> Exp
patchExpr Exp
b)) [Dec]
c)
patchDec Dec
a = Dec
a
patchExpr (TH.CondE Exp
a Exp
b Exp
c) = Exp -> Exp -> Exp -> Exp
TH.CondE (Exp -> Exp
patchExpr Exp
a) (Exp -> Exp
patchExpr Exp
b) (Exp -> Exp
patchExpr Exp
c)
patchExpr (TH.SigE Exp
a Type
b) = Exp -> Type -> Exp
TH.SigE (Exp -> Exp
patchExpr Exp
a) Type
b
patchExpr Exp
e = Exp
e