{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} module Language.TCT.Read.Markup where import Control.Applicative (Applicative(..), Alternative(..)) import Control.Monad (Monad(..), void) import Data.Bool import Data.Char (Char) import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Functor ((<$>)) import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (ViewR(..)) import Prelude (undefined) import qualified Data.Char as Char import qualified Data.Sequence as Seq import qualified Data.Text as Text import qualified Text.Megaparsec as P import Data.Text (Text) -- import Language.TCT.Tree import Language.TCT.Markup import Language.TCT.Read.Tree p_Markup :: Parser e s Markup p_Markup = pdbg "Markup" $ mconcat <$> some ( P.choice $ [ -- P.try p_MarkupEscape -- , P.try p_Tag -- , P.try p_Group p_MarkupPlain ]) p_MarkupTag :: Parser e s Markup p_MarkupTag = pdbg "MarkupTag" $ P.try p_MarkupTagGroup <|> p_MarkupTagOpen where p_MarkupTagGroup :: Parser e s Markup p_MarkupTagGroup = P.char '#' *> p_MarkupTagName <* P.char '#' where p_MarkupTagName :: Parser e s Markup p_MarkupTagName = (\w ws -> MarkupTag $ Text.concat $ w : ws) <$> p_MarkupTagNameWord <*> many ((<>) <$> (Text.pack <$> many (P.char ' ')) <*> p_MarkupTagNameWord) p_MarkupTagNameWord :: Parser e s Text p_MarkupTagNameWord = Text.pack <$> some (P.satisfy $ \c -> c/=' ' && c/='#' && Char.isPrint c) p_MarkupTagOpen = P.char '#' *> p_MarkupTagName where p_MarkupTagName = MarkupTag . Text.pack <$> some (P.satisfy isTagNameCharShort) isTagNameCharShort :: Char -> Bool isTagNameCharShort c | Char.isAlphaNum c = True isTagNameCharShort '-' = True isTagNameCharShort '_' = True isTagNameCharShort _ = False p_MarkupEscape :: Parser e s Markup p_MarkupEscape = do void $ P.char '\\' P.option (MarkupPlain $ "\\") $ P.try $ do P.choice [ P.char c >> pure (MarkupPlain $ Text.singleton c) | c <- "<>=|@#*_\\/`'\"«»-" ] p_MarkupGroup :: Parser e s Markup p_MarkupGroup = P.choice [ p_MarkupGroup1 GroupStar '*' , p_MarkupGroup1 GroupSlash '/' , p_MarkupGroup1 GroupUnderscore '_' , p_MarkupGroup1 GroupDash '-' , p_MarkupGroup1 GroupBackquote '`' , p_MarkupGroup1 GroupSinglequote '\'' , p_MarkupGroup1 GroupDoublequote '"' -- , MarkupGroup GroupFrenchquote <$ p_MarkupGroup2 '«' '»' ] p_MarkupGroup1 :: Group -> Char -> Parser e s Markup p_MarkupGroup1 g c = (if c == '/' then pdbg "MarkupGroup1" else (\p -> p)) $ do void $ P.char c P.option (MarkupPlain $ Text.singleton c) $ P.try $ do P.notFollowedBy $ P.char ' ' v <- (if c == '/' then pdbg "MarkupGroup1: Markup" else (\p -> p)) $ p_Markup case lastCharOfMarkup v of ' ' -> fail "grouped Markup ends with space" _ -> return () void $ P.char c return $ MarkupGroup g v lastCharOfMarkup :: Markup -> Char lastCharOfMarkup = \case MarkupPlain t -> Text.last t MarkupTag t | Text.all (\c -> Char.isAlphaNum c || c=='-' || c=='_') t -> Text.last t MarkupTag _t -> '#' MarkupGroup _ v -> lastCharOfMarkup v Markups vs | _:>v <- Seq.viewr vs -> lastCharOfMarkup v Markups{} -> undefined p_MarkupPlain :: Parser e s Markup p_MarkupPlain = pdbg "Plain" $ MarkupPlain . Text.pack <$> P.many (P.satisfy $ \case -- '%' -> False -- '#' -> False -- '*' -> False -- '_' -> False -- '/' -> False -- '`' -> False -- '\'' -> False -- '"' -> False -- '«' -> False -- '»' -> False _ -> True )