Language/TCT/Read/Markup.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE Rank2Types #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 module Language.TCT.Read.Markup where
   6
   7 import Control.Applicative (Applicative(..), Alternative(..))
   8 import Control.Monad (Monad(..), void)
   9 import Data.Bool
  10 import Data.Char (Char)
  11 import Data.Eq (Eq(..))
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Monoid (Monoid(..))
  15 import Data.Semigroup (Semigroup(..))
  16 import Data.Sequence (ViewR(..))
  17 import Prelude (undefined)
  18 import qualified Data.Char as Char
  19 import qualified Data.Sequence as Seq
  20 import qualified Data.Text as Text
  21 import qualified Text.Megaparsec as P
  22 import Data.Text (Text)
  23
  24 -- import Language.TCT.Tree
  25 import Language.TCT.Markup
  26 import Language.TCT.Read.Tree
  27
  28 p_Markup :: Parser e s Markup
  29 p_Markup = pdbg "Markup" $
  30         mconcat
  31          <$> some (
  32                 P.choice $
  33                  [ -- P.try p_MarkupEscape
  34                  -- , P.try p_Tag
  35                  -- , P.try p_Group
  36                          p_MarkupPlain
  37                  ])
  38
  39 p_MarkupTag :: Parser e s Markup
  40 p_MarkupTag = pdbg "MarkupTag" $ P.try p_MarkupTagGroup <|> p_MarkupTagOpen
  41         where
  42         p_MarkupTagGroup :: Parser e s Markup
  43         p_MarkupTagGroup = P.char '#' *> p_MarkupTagName <* P.char '#'
  44                 where
  45                 p_MarkupTagName :: Parser e s Markup
  46                 p_MarkupTagName =
  47                         (\w ws -> MarkupTag $ Text.concat $ w : ws)
  48                          <$> p_MarkupTagNameWord
  49                          <*> many ((<>) <$> (Text.pack <$> many (P.char ' ')) <*> p_MarkupTagNameWord)
  50                 p_MarkupTagNameWord :: Parser e s Text
  51                 p_MarkupTagNameWord = Text.pack <$> some (P.satisfy $ \c -> c/=' ' && c/='#' && Char.isPrint c)
  52         p_MarkupTagOpen = P.char '#' *> p_MarkupTagName
  53                 where
  54                 p_MarkupTagName = MarkupTag . Text.pack <$> some (P.satisfy isTagNameCharShort)
  55
  56 isTagNameCharShort :: Char -> Bool
  57 isTagNameCharShort c | Char.isAlphaNum c = True
  58 isTagNameCharShort '-' = True
  59 isTagNameCharShort '_' = True
  60 isTagNameCharShort _   = False
  61
  62 p_MarkupEscape :: Parser e s Markup
  63 p_MarkupEscape = do
  64         void $ P.char '\\'
  65         P.option (MarkupPlain $ "\\") $ P.try $ do
  66                 P.choice
  67                  [ P.char c >> pure (MarkupPlain $ Text.singleton c)
  68                  | c <- "<>=|@#*_\\/`'\"«»-"
  69                  ]
  70
  71 p_MarkupGroup :: Parser e s Markup
  72 p_MarkupGroup =
  73         P.choice
  74          [ p_MarkupGroup1 GroupStar        '*'
  75          , p_MarkupGroup1 GroupSlash       '/'
  76          , p_MarkupGroup1 GroupUnderscore  '_'
  77          , p_MarkupGroup1 GroupDash        '-'
  78          , p_MarkupGroup1 GroupBackquote   '`'
  79          , p_MarkupGroup1 GroupSinglequote '\''
  80          , p_MarkupGroup1 GroupDoublequote '"'
  81          -- , MarkupGroup GroupFrenchquote <$ p_MarkupGroup2 '«' '»'
  82          ]
  83
  84 p_MarkupGroup1 :: Group -> Char -> Parser e s Markup
  85 p_MarkupGroup1 g c = (if c == '/' then pdbg "MarkupGroup1" else (\p -> p)) $ do
  86         void $ P.char c
  87         P.option (MarkupPlain $ Text.singleton c) $ P.try $ do
  88                 P.notFollowedBy $ P.char ' '
  89                 v <- (if c == '/' then pdbg "MarkupGroup1: Markup" else (\p -> p)) $ p_Markup
  90                 case lastCharOfMarkup v of
  91                  ' ' -> fail "grouped Markup ends with space"
  92                  _   -> return ()
  93                 void $ P.char c
  94                 return $ MarkupGroup g v
  95
  96 lastCharOfMarkup :: Markup -> Char
  97 lastCharOfMarkup = \case
  98  MarkupPlain t -> Text.last t
  99  MarkupTag t | Text.all (\c -> Char.isAlphaNum c || c=='-' || c=='_') t -> Text.last t
 100  MarkupTag _t -> '#'
 101  MarkupGroup _ v -> lastCharOfMarkup v
 102  Markups vs | _:>v <- Seq.viewr vs -> lastCharOfMarkup v
 103  Markups{} -> undefined
 104
 105 p_MarkupPlain :: Parser e s Markup
 106 p_MarkupPlain = pdbg "Plain" $
 107         MarkupPlain . Text.pack
 108          <$> P.many
 109                  (P.satisfy $ \case
 110                         -- '%' -> False
 111                         -- '#'  -> False
 112                         -- '*'  -> False
 113                         -- '_'  -> False
 114                         -- '/'  -> False
 115                         -- '`'  -> False
 116                         -- '\'' -> False
 117                         -- '"'  -> False
 118                         -- '«'  -> False
 119                         -- '»'  -> False
 120                          _    -> True
 121                  )