module Ondim.Targets.Whiskers.Parser (parseWhiskers) where import Data.Char (isAlphaNum, isSpace, isSymbol) import Data.Sequence (Seq (..), (|>)) import Data.Text qualified as T import Ondim.Targets.Whiskers.Instances (WNode (..)) import Text.Megaparsec import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L import Prelude hiding (many, some) newtype Nodes = Nodes {Nodes -> Seq WNode unNodes :: Seq WNode} instance Semigroup Nodes where (Nodes (Seq WNode xs :|> Textual Text t1)) <> :: Nodes -> Nodes -> Nodes <> (Nodes (Textual Text t2 :<| Seq WNode ys)) = Seq WNode -> Nodes Nodes ((Seq WNode xs Seq WNode -> WNode -> Seq WNode forall a. Seq a -> a -> Seq a |> Text -> WNode Textual (Text t1 Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text t2)) Seq WNode -> Seq WNode -> Seq WNode forall a. Semigroup a => a -> a -> a <> Seq WNode ys) (Nodes Seq WNode xs) <> (Nodes Seq WNode ys) = Seq WNode -> Nodes Nodes (Seq WNode xs Seq WNode -> Seq WNode -> Seq WNode forall a. Semigroup a => a -> a -> a <> Seq WNode ys) instance Monoid Nodes where mempty :: Nodes mempty = Seq WNode -> Nodes Nodes Seq WNode forall a. Monoid a => a mempty instance One Nodes where type OneItem Nodes = WNode one :: OneItem Nodes -> Nodes one = Seq WNode -> Nodes Nodes (Seq WNode -> Nodes) -> (WNode -> Seq WNode) -> WNode -> Nodes forall b c a. (b -> c) -> (a -> b) -> a -> c . OneItem (Seq WNode) -> Seq WNode WNode -> Seq WNode forall x. One x => OneItem x -> x one data ParserState = ParserState { ParserState -> (Text, Text) delimiters :: (Text, Text), ParserState -> Text whitespace :: Text, ParserState -> Text bolspace :: Text, ParserState -> Bool alone :: Bool, ParserState -> Int level :: Int } initialParserstate :: ParserState initialParserstate :: ParserState initialParserstate = (Text, Text) -> Text -> Text -> Bool -> Int -> ParserState ParserState (Text "<<", Text ">>") Text "" Text "" Bool True Int 0 type Parser = StateT ParserState (Parsec Void Text) parseBool :: Parser a -> Parser Bool parseBool :: forall a. Parser a -> Parser Bool parseBool Parser a m = Bool -> Parser Bool -> Parser Bool forall (m :: * -> *) a. Alternative m => a -> m a -> m a option Bool False (Parser Bool -> Parser Bool) -> Parser Bool -> Parser Bool forall a b. (a -> b) -> a -> b $ Parser a m Parser a -> Bool -> Parser Bool forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> Bool True hwhitespace :: Parser Text hwhitespace :: Parser Text hwhitespace = Maybe String -> (Token Text -> Bool) -> StateT ParserState (Parsec Void Text) (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 -> Bool isSpace Char Token Text c Bool -> Bool -> Bool && Char Token Text c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool /= Char '\n') hwhitespace1 :: Parser Text hwhitespace1 :: Parser Text hwhitespace1 = Maybe String -> (Token Text -> Bool) -> StateT ParserState (Parsec Void Text) (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 isSpace Char Token Text c Bool -> Bool -> Bool && Char Token Text c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool /= Char '\n') bolspace' :: Parser () bolspace' :: Parser () bolspace' = do ws <- Parser Text hwhitespace modify \ParserState s -> ParserState s {bolspace = ws, alone = True} trimmedBOL :: Parser Text trimmedBOL :: Parser Text trimmedBOL = (ParserState -> Text) -> Parser Text forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a gets \ParserState s -> Int -> Text -> Text T.drop (Int 2 Int -> Int -> Int forall a. Num a => a -> a -> a * ParserState -> Int level ParserState s) (ParserState -> Text bolspace ParserState s) newline' :: Parser () newline' :: Parser () newline' = do _ <- StateT ParserState (Parsec Void Text) Char StateT ParserState (Parsec Void Text) (Token Text) forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => m (Token s) newline bol <- trimmedBOL modify \ParserState s -> ParserState s {whitespace = whitespace s <> "\n" <> bol} bolspace' openDelimiter :: Parser (Text, Text) openDelimiter :: Parser (Text, Text) openDelimiter = do _ <- Tokens Text -> StateT ParserState (Parsec Void Text) (Tokens Text) Text -> Parser Text forall e s (m :: * -> *). MonadParsec e s m => Tokens s -> m (Tokens s) string (Text -> Parser Text) -> Parser Text -> Parser Text forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< (ParserState -> Text) -> Parser Text forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a gets ((Text, Text) -> Text forall a b. (a, b) -> a fst ((Text, Text) -> Text) -> (ParserState -> (Text, Text)) -> ParserState -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . ParserState -> (Text, Text) delimiters) (ws, bolws) <- (char '~' $> mempty) <|> liftA2 (,) (gets whitespace) trimmedBOL modify \ParserState s -> ParserState s {whitespace = "", bolspace = ""} return (ws, bolws) closeDelimiter :: Parser () closeDelimiter :: Parser () closeDelimiter = do stripEnd <- StateT ParserState (Parsec Void Text) Char -> Parser Bool forall a. Parser a -> Parser Bool parseBool (StateT ParserState (Parsec Void Text) Char -> Parser Bool) -> StateT ParserState (Parsec Void Text) Char -> Parser Bool forall a b. (a -> b) -> a -> b $ Token Text -> StateT ParserState (Parsec Void Text) (Token Text) forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) char Char Token Text '~' _ <- string =<< gets (snd . delimiters) whenM (gets alone) do void $ optional $ try $ hspace *> newline *> bolspace' when stripEnd do _ <- many newline' modify \ParserState s -> ParserState s {whitespace = "", bolspace = ""} modify \ParserState s -> ParserState s {alone = False} space' :: Parser () space' :: Parser () space' = do ws <- Parser Text hwhitespace1 modify \ParserState s -> ParserState s {whitespace = whitespace s <> ws} parseWhiskers :: (Text, Text) -> String -> Text -> Either String [WNode] parseWhiskers :: (Text, Text) -> String -> Text -> Either String [WNode] parseWhiskers (Text, Text) d String fp = (ParseErrorBundle Text Void -> String) -> Either (ParseErrorBundle Text Void) [WNode] -> Either String [WNode] forall a b c. (a -> b) -> Either a c -> Either b c forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first ParseErrorBundle Text Void -> String forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> String errorBundlePretty (Either (ParseErrorBundle Text Void) [WNode] -> Either String [WNode]) -> (Text -> Either (ParseErrorBundle Text Void) [WNode]) -> Text -> Either String [WNode] forall b c a. (b -> c) -> (a -> b) -> a -> c . Parsec Void Text [WNode] -> String -> Text -> Either (ParseErrorBundle Text Void) [WNode] forall e s a. Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a parse (StateT ParserState (Parsec Void Text) [WNode] -> ParserState -> Parsec Void Text [WNode] forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a evalStateT StateT ParserState (Parsec Void Text) [WNode] document ParserState initialParserstate {delimiters = d}) String fp document :: Parser [WNode] document :: StateT ParserState (Parsec Void Text) [WNode] document = do Parser () bolspace' Nodes nodes <- Parser Nodes manyNodes ws <- liftA2 (<>) (gets whitespace) (gets bolspace) eof return $ toList $ nodes |> Textual ws manyNodes :: Parser Nodes manyNodes :: Parser Nodes manyNodes = [Nodes] -> Nodes forall a. Monoid a => [a] -> a mconcat ([Nodes] -> Nodes) -> StateT ParserState (Parsec Void Text) [Nodes] -> Parser Nodes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser Nodes -> StateT ParserState (Parsec Void Text) [Nodes] forall (m :: * -> *) a. MonadPlus m => m a -> m [a] many ( Parser Nodes rawText Parser Nodes -> Parser Nodes -> Parser Nodes forall a. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Parser () space' Parser () -> Nodes -> Parser Nodes forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> Nodes forall a. Monoid a => a mempty Parser Nodes -> Parser Nodes -> Parser Nodes forall a. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Parser () newline' Parser () -> Nodes -> Parser Nodes forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> Nodes forall a. Monoid a => a mempty Parser Nodes -> Parser Nodes -> Parser Nodes forall a. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Parser Nodes sectionStart ) rawText :: Parser Nodes rawText :: Parser Nodes rawText = do txt <- [Text] -> Text forall a. Monoid a => [a] -> a mconcat ([Text] -> Text) -> StateT ParserState (Parsec Void Text) [Text] -> Parser Text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser Text -> StateT ParserState (Parsec Void Text) [Text] forall (m :: * -> *) a. MonadPlus m => m a -> m [a] some do Parser (Text, Text) -> Parser () forall a. StateT ParserState (Parsec Void Text) a -> Parser () forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m () notFollowedBy Parser (Text, Text) openDelimiter (Char -> Text -> Text) -> StateT ParserState (Parsec Void Text) Char -> Parser Text -> Parser Text forall a b c. (a -> b -> c) -> StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) b -> StateT ParserState (Parsec Void Text) c forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 Char -> Text -> Text T.cons ((Token Text -> Bool) -> StateT ParserState (Parsec Void Text) (Token Text) forall e s (m :: * -> *). MonadParsec e s m => (Token s -> Bool) -> m (Token s) satisfy (Bool -> Bool not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Char -> Bool isSpace)) (Parser Text -> Parser Text) -> Parser Text -> Parser Text forall a b. (a -> b) -> a -> b $ Maybe String -> (Token Text -> Bool) -> StateT ParserState (Parsec Void Text) (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 -> Bool -> Bool not (Char -> Bool isSymbol Char Token Text c Bool -> Bool -> Bool || Char -> Bool isSpace Char Token Text c)) ws <- liftA2 (<>) (gets whitespace) trimmedBOL modify \ParserState s -> ParserState s {whitespace = "", bolspace = "", alone = False} return $ one $ Textual (ws <> txt) sectionStart :: Parser Nodes sectionStart :: Parser Nodes sectionStart = do (ws, bolws) <- Parser (Text, Text) -> Parser (Text, Text) forall a. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) a forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a try (Parser (Text, Text) -> Parser (Text, Text)) -> Parser (Text, Text) -> Parser (Text, Text) forall a b. (a -> b) -> a -> b $ Parser (Text, Text) openDelimiter Parser (Text, Text) -> Parser () -> Parser (Text, Text) forall a b. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) b -> StateT ParserState (Parsec Void Text) a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* StateT ParserState (Parsec Void Text) Char -> Parser () forall a. StateT ParserState (Parsec Void Text) a -> Parser () forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m () notFollowedBy (Token Text -> StateT ParserState (Parsec Void Text) (Token Text) forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) char Char Token Text '/') (alone', level') <- gets (alone &&& level) space isSection <- parseBool $ char '#' name <- takeWhileP (Just "Wnode name") isAllowedName attributes <- option [] $ space1 *> (pair `sepBy1'` space1) space closeDelimiter if isSection then do modify \ParserState s -> ParserState s {level = level s + 1} child <- manyNodes modify \ParserState s -> ParserState s {alone = alone', level = level'} end <- sectionEnd name <?> "end of section " <> show name return $ Nodes ( Empty |> Textual ws |> Section name attributes (toList $ unNodes $ child <> end) ) else return $ Nodes ( Empty |> Textual (ws <> bolws) |> Single name attributes ) where sepBy1' :: f a -> f a -> f [a] sepBy1' f a p f a sep = (:) (a -> [a] -> [a]) -> f a -> f ([a] -> [a]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f a p f ([a] -> [a]) -> f [a] -> f [a] forall a b. f (a -> b) -> f a -> f b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> f a -> f [a] forall (m :: * -> *) a. MonadPlus m => m a -> m [a] many (f a -> f a forall a. f a -> f a forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a try (f a -> f a) -> f a -> f a forall a b. (a -> b) -> a -> b $ f a sep f a -> f a -> f a forall a b. f a -> f b -> f b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> f a p) str :: Parser Text str = (Token Text -> StateT ParserState (Parsec Void Text) (Token Text) forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) char Char Token Text '"' StateT ParserState (Parsec Void Text) Char -> Parser Text -> Parser Text forall a b. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) b -> StateT ParserState (Parsec Void Text) b forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> (String -> Text forall a. ToText a => a -> Text toText (String -> Text) -> StateT ParserState (Parsec Void Text) String -> Parser Text forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StateT ParserState (Parsec Void Text) Char -> StateT ParserState (Parsec Void Text) Char -> StateT ParserState (Parsec Void Text) String forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a] manyTill StateT ParserState (Parsec Void Text) Char forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => m Char L.charLiteral (Token Text -> StateT ParserState (Parsec Void Text) (Token Text) forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) char Char Token Text '"'))) Parser Text -> Parser Text -> Parser Text forall a. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Maybe String -> (Token Text -> Bool) -> StateT ParserState (Parsec Void Text) (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 Char -> Bool Token Text -> Bool isAllowedName pair :: StateT ParserState (Parsec Void Text) (Text, [WNode]) pair = StateT ParserState (Parsec Void Text) (Text, [WNode]) -> StateT ParserState (Parsec Void Text) (Text, [WNode]) forall a. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) a forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a try (StateT ParserState (Parsec Void Text) (Text, [WNode]) -> StateT ParserState (Parsec Void Text) (Text, [WNode])) -> StateT ParserState (Parsec Void Text) (Text, [WNode]) -> StateT ParserState (Parsec Void Text) (Text, [WNode]) forall a b. (a -> b) -> a -> b $ (Text -> [WNode] -> (Text, [WNode])) -> Parser Text -> StateT ParserState (Parsec Void Text) [WNode] -> StateT ParserState (Parsec Void Text) (Text, [WNode]) forall a b c. (a -> b -> c) -> StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) b -> StateT ParserState (Parsec Void Text) c forall (f :: * -> *) a b c. Applicative f => (a -> b -> c) -> f a -> f b -> f c liftA2 (,) Parser Text str (StateT ParserState (Parsec Void Text) [WNode] -> StateT ParserState (Parsec Void Text) (Text, [WNode])) -> StateT ParserState (Parsec Void Text) [WNode] -> StateT ParserState (Parsec Void Text) (Text, [WNode]) forall a b. (a -> b) -> a -> b $ [WNode] -> StateT ParserState (Parsec Void Text) [WNode] -> StateT ParserState (Parsec Void Text) [WNode] forall (m :: * -> *) a. Alternative m => a -> m a -> m a option [WNode] forall a. Monoid a => a mempty (StateT ParserState (Parsec Void Text) [WNode] -> StateT ParserState (Parsec Void Text) [WNode]) -> StateT ParserState (Parsec Void Text) [WNode] -> StateT ParserState (Parsec Void Text) [WNode] forall a b. (a -> b) -> a -> b $ StateT ParserState (Parsec Void Text) [WNode] -> StateT ParserState (Parsec Void Text) [WNode] forall a. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) a forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a try (StateT ParserState (Parsec Void Text) [WNode] -> StateT ParserState (Parsec Void Text) [WNode]) -> StateT ParserState (Parsec Void Text) [WNode] -> StateT ParserState (Parsec Void Text) [WNode] forall a b. (a -> b) -> a -> b $ Parser () forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => m () space Parser () -> StateT ParserState (Parsec Void Text) Char -> StateT ParserState (Parsec Void Text) Char forall a b. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) b -> StateT ParserState (Parsec Void Text) b forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> Token Text -> StateT ParserState (Parsec Void Text) (Token Text) forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) char Char Token Text '=' StateT ParserState (Parsec Void Text) Char -> Parser () -> Parser () forall a b. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) b -> StateT ParserState (Parsec Void Text) b forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> Parser () forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => m () space Parser () -> StateT ParserState (Parsec Void Text) [WNode] -> StateT ParserState (Parsec Void Text) [WNode] forall a b. StateT ParserState (Parsec Void Text) a -> StateT ParserState (Parsec Void Text) b -> StateT ParserState (Parsec Void Text) b forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> (Seq WNode -> [WNode] forall a. Seq a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] toList (Seq WNode -> [WNode]) -> (Nodes -> Seq WNode) -> Nodes -> [WNode] forall b c a. (b -> c) -> (a -> b) -> a -> c . Nodes -> Seq WNode unNodes (Nodes -> [WNode]) -> Parser Nodes -> StateT ParserState (Parsec Void Text) [WNode] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Parser Nodes manyNodes) isAllowedName :: Char -> Bool isAllowedName :: Char -> Bool isAllowedName Char c = Char -> Bool isAlphaNum Char c Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '-' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '.' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char ':' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '@' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '&' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '%' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '#' Bool -> Bool -> Bool || Char c Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '!' sectionEnd :: Text -> Parser Nodes sectionEnd :: Text -> Parser Nodes sectionEnd Text name = do (ws, _) <- Parser (Text, Text) openDelimiter hspace _ <- char '/' _ <- optional (string name) hspace closeDelimiter return $ one $ Textual ws