Language/TCT/Read/Token.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE Rank2Types #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 module Language.TCT.Read.Token where
   6
   7 import Control.Applicative (Applicative(..), Alternative(..))
   8 import Control.Monad (Monad(..))
   9 import Data.Bool
  10 import Data.Char (Char)
  11 import Data.Eq (Eq(..))
  12 import Data.Foldable (Foldable(..))
  13 import Data.Function (($), (.), flip)
  14 import Data.Functor ((<$>), ($>), (<$))
  15 import Data.Maybe (Maybe(..), fromMaybe)
  16 import Data.Monoid (Monoid(..))
  17 import Data.Semigroup (Semigroup(..))
  18 import Data.Sequence (ViewL(..), (<|))
  19 import Data.Text (Text)
  20 import Data.Text.Buildable (Buildable(..))
  21 import Data.Tuple (fst,snd)
  22 import Text.Show (Show(..))
  23 import qualified Data.Char as Char
  24 import qualified Data.Sequence as Seq
  25 import qualified Data.Text as Text
  26 import qualified Data.Text.Lazy as TL
  27 import qualified Data.Text.Lazy.Builder as Builder
  28 import qualified Text.Megaparsec as P
  29
  30 import Language.TCT.Token
  31 import Language.TCT.Elem
  32 import Language.TCT.Read.Elem -- hiding (pdbg)
  33
  34 -- pdbg m p = P.dbg m p
  35
  36 textOf :: Buildable a => a -> Text
  37 textOf = TL.toStrict . Builder.toLazyText . build
  38
  39 -- * Type 'Pairs'
  40 type Pairs = (Token,[(Pair,Token)])
  41
  42 openPair :: Pair -> Pairs -> Pairs
  43 openPair g (t,ms) = (t,(g,mempty):ms)
  44
  45 insertToken :: Token -> Pairs -> Pairs
  46 insertToken tok (t,[])         = (t<>tok,[])
  47 insertToken tok (t,(g0,t0):gs) = (t,(g0,t0<>tok):gs)
  48
  49 -- | Close a 'Pair' when there is a matching 'LexemePairClose'.
  50 closePair :: Pair -> Pairs -> Pairs
  51 closePair g (t,[]) = dbg "closePair" $ (t<>TokenPlain (snd $ pairBorders g mempty),[])
  52 closePair g (t,(g1,m1):ms) = dbg "closePair" $
  53         case (g,g1) of
  54          (PairElem x ax, PairElem y ay) | x == y ->
  55                 insertToken (TokenPair (PairElem x (ax<>ay)) m1) (t,ms)
  56          (x,y) | x == y -> insertToken (TokenPair g1 m1) (t,ms)
  57          _ ->
  58                 closePair g $
  59                 insertToken
  60                  (closelessPair mempty (g1,m1))
  61                  (t,ms)
  62
  63 -- | Close a 'Pair' when there is not a matching 'LexemePairClose'.
  64 closelessPair :: Token -> (Pair,Token) -> Token
  65 closelessPair acc (g,t) = dbg "closelessPair" $
  66         case g of
  67          -- NOTE: try to close 'PairHash' as 'TokenTag' instead of 'TokenPlain'.
  68          PairHash | TokenPlain p :< toks <- Seq.viewl $ unTokens $ t <> acc ->
  69                 case Text.findIndex (not . isTagChar) p of
  70                  Just 0 -> TokenPlain (fst $ pairBorders g mempty) <> t <> acc
  71                  Just i -> Tokens $ TokenTag tag <| TokenPlain p' <| toks
  72                         where (tag,p') = Text.splitAt i p
  73                  Nothing -> Tokens $ TokenTag p <| toks
  74          _ -> TokenPlain (fst $ pairBorders g mempty) <> t <> acc
  75         where
  76         isTagChar c =
  77                 Char.isAlphaNum c ||
  78                 c=='·' ||
  79                 case Char.generalCategory c of
  80                  Char.DashPunctuation -> True
  81                  Char.ConnectorPunctuation -> True
  82                  _ -> False
  83
  84 -- | Close remaining 'Pair's at end of parsing.
  85 closePairs :: Pairs -> Token
  86 closePairs (t0,gs) = dbg "closePairs" $
  87         t0 <> foldl' closelessPair mempty gs
  88
  89 -- * Type 'Lexeme'
  90 data Lexeme
  91  =   LexemePairOpen   Pair
  92  |   LexemePairClose  Pair
  93  |   LexemePunctOrSym Char
  94  |   LexemeWhite      Text
  95  |   LexemeWord       Text
  96  |   LexemeToken      Token
  97  |   LexemeEscape     Char
  98  |   LexemeLink       Text
  99  deriving (Show, Eq)
 100
 101 appendLexeme :: Lexeme -> Pairs -> Pairs
 102 appendLexeme lex gs =
 103         dbg "appendLexeme" $
 104         case dbg "appendLexeme" lex of
 105          LexemePairOpen  g -> openPair g gs
 106          LexemePairClose g -> closePair g gs
 107          LexemePunctOrSym c -> insertToken (TokenPlain (Text.singleton c)) gs
 108          LexemeWhite wh     -> insertToken (TokenPlain wh) gs
 109          LexemeWord  wo     -> insertToken (TokenPlain wo) gs
 110          LexemeToken tok    -> insertToken tok gs
 111          LexemeEscape c     -> insertToken (TokenEscape c) gs
 112          LexemeLink lnk     -> insertToken (TokenLink lnk) gs
 113
 114 appendLexemes :: Pairs -> [Lexeme] -> Pairs
 115 appendLexemes = foldl' (flip appendLexeme)
 116
 117 -- * Parsers
 118
 119 p_Token :: Parser e s Token
 120 p_Token = closePairs <$> p_Pairs (mempty,[])
 121
 122 p_Pairs :: Pairs -> Parser e s Pairs
 123 p_Pairs gs = pdbg "Pairs" $
 124         (p_Lexemes (mempty == gs) >>= p_Pairs . appendLexemes gs) <|>
 125         (P.eof $> gs)
 126
 127 p_Lexemes :: Bool -> Parser e s [Lexeme]
 128 p_Lexemes isBOF = pdbg "Lexemes" $
 129         P.choice
 130          [ P.try $ p_PairCloseWhite
 131          , P.try $ p_PairWhiteOpen isBOF
 132          , P.try $ p_PairCloseBorder
 133          , P.try $ p_PairBorderOpen
 134          , P.try $ p_PairClose
 135          , P.try $ p_PairOpen
 136          , P.try $ pure . LexemePunctOrSym <$> p_PunctOrSym
 137          , P.try $ pure <$> p_White
 138          , pure . LexemeWord <$> p_Word
 139          ]
 140
 141 p_White :: Parser e s Lexeme
 142 p_White = pdbg "White" $ LexemeWhite <$> p_Spaces
 143
 144 p_PunctOrSym :: Parser e s Char
 145 p_PunctOrSym = P.satisfy $ \c ->
 146         Char.isPunctuation c ||
 147         Char.isSymbol c
 148
 149 p_PairCloseWhite :: Parser e s [Lexeme]
 150 p_PairCloseWhite = pdbg "PairCloseWhite" $
 151         (\c b -> mconcat c <> b)
 152          <$> P.some (P.try p_PairClose <|> pure . LexemePunctOrSym <$> p_PunctOrSym)
 153          <*> ((pure <$> p_White) <|> P.eof $> [])
 154
 155 p_PairWhiteOpen :: Bool -> Parser e s [Lexeme]
 156 p_PairWhiteOpen isBOF = pdbg "PairWhiteOpen" $
 157         (\b o -> b <> mconcat o)
 158          <$> (if isBOF then return [] else pure <$> p_White)
 159          <*> P.some (P.try p_PairOpen <|> pure . LexemePunctOrSym <$> p_PunctOrSym)
 160
 161 p_PairCloseBorder :: Parser e s [Lexeme]
 162 p_PairCloseBorder = pdbg "PairCloseBorder" $
 163         P.try p0 <|> p1
 164         where
 165         p0 =
 166                 (\c b -> mconcat $ c <> b)
 167                  <$> P.some (P.try p_PairClose)
 168                  <*> P.some (P.try $ P.choice
 169                          [ P.try p_ElemOpen
 170                          , P.try p_ElemClose
 171                          , do
 172                                 c <- p_PunctOrSym
 173                                 case l_PairClose c of
 174                                  Just l -> return [l]
 175                                  Nothing ->
 176                                         case l_PairOpenAndClose LexemePairOpen c <|> l_PairOpen c of
 177                                          Nothing -> return [LexemePunctOrSym c]
 178                                          _ -> fail ""
 179                          ])
 180         p1 =
 181                 (\c b -> mconcat c <> [LexemePunctOrSym b])
 182                  <$> P.some (P.try p_PairClose)
 183                  <*> p_PunctOrSym
 184
 185 p_PairBorderOpen :: Parser e s [Lexeme]
 186 p_PairBorderOpen = pdbg "PairBorderOpen" $
 187         P.try p0 <|> p1
 188         where
 189         p0 =
 190                 (\b o -> mconcat $ b <> o)
 191                  <$> P.some (P.try $ P.choice
 192                          [ P.try p_ElemOpen
 193                          , P.try p_ElemClose
 194                          , do
 195                                 c <- p_PunctOrSym
 196                                 case l_PairOpen c <|> l_PairClose c of
 197                                  Just l -> return [l]
 198                                  Nothing -> fail ""
 199                          ])
 200                  <*> P.some (P.try p_PairOpen)
 201         p1 =
 202                 (\b o -> LexemePunctOrSym b : mconcat o)
 203                  <$> p_PunctOrSym
 204                  <*> P.some (P.try p_PairOpen)
 205
 206 p_PairOpen :: Parser e s [Lexeme]
 207 p_PairOpen = pdbg "PairOpen" $ do
 208         P.choice
 209          [ P.try p_ElemOpen
 210          , P.try (pure <$> p_Escape)
 211          , P.try (pure <$> p_Link)
 212          , do
 213                 c <- p_PunctOrSym
 214                 case l_PairOpenOrClose LexemePairOpen c of
 215                  Just l -> return [l]
 216                  _ -> fail ""
 217          ]
 218
 219 p_PairClose :: Parser e s [Lexeme]
 220 p_PairClose = pdbg "PairClose" $ do
 221         P.choice
 222          [ P.try p_ElemClose
 223          , P.try p_ElemSingle
 224          , P.try (pure <$> p_Escape)
 225          , P.try (pure <$> p_Link)
 226          , do
 227                 c <- p_PunctOrSym
 228                 case l_PairOpenOrClose LexemePairClose c of
 229                  Just l -> return [l]
 230                  _ -> fail ""
 231          ]
 232
 233 p_PairPlain :: (Char -> Maybe Lexeme) -> Parser e s [Lexeme]
 234 p_PairPlain pair = pdbg "PairPlain" $ do
 235         (<$> p_PunctOrSym) $ \c ->
 236                 pure $
 237                 LexemePunctOrSym c `fromMaybe`
 238                 pair c
 239
 240 l_PairOpenAndClose :: (Pair -> Lexeme) -> Char -> Maybe Lexeme
 241 l_PairOpenAndClose lxm c =
 242         case c of
 243          '/'  -> Just $ lxm PairSlash
 244          '-'  -> Just $ lxm PairDash
 245          '"'  -> Just $ lxm PairDoublequote
 246          '\'' -> Just $ lxm PairSinglequote
 247          '`'  -> Just $ lxm PairBackquote
 248          '_'  -> Just $ lxm PairUnderscore
 249          '*'  -> Just $ lxm PairStar
 250          '#'  -> Just $ lxm PairHash
 251          _    -> Nothing
 252
 253 l_PairOpenOrClose :: (Pair -> Lexeme) -> Char -> Maybe Lexeme
 254 l_PairOpenOrClose lxm c =
 255         l_PairOpenAndClose lxm c <|>
 256         l_PairOpen c <|>
 257         l_PairClose c
 258
 259 l_PairOpen :: Char -> Maybe Lexeme
 260 l_PairOpen c =
 261         case c of
 262          '('  -> Just $ LexemePairOpen PairParen
 263          '['  -> Just $ LexemePairOpen PairBracket
 264          '{'  -> Just $ LexemePairOpen PairBrace
 265          '«'  -> Just $ LexemePairOpen PairFrenchquote
 266          _    -> Nothing
 267
 268 l_PairClose :: Char -> Maybe Lexeme
 269 l_PairClose c =
 270         case c of
 271          ')'  -> Just $ LexemePairClose PairParen
 272          ']'  -> Just $ LexemePairClose PairBracket
 273          '}'  -> Just $ LexemePairClose PairBrace
 274          '»'  -> Just $ LexemePairClose PairFrenchquote
 275          _    -> Nothing
 276
 277 p_Link :: Parser e s Lexeme
 278 p_Link =
 279         (\scheme ss addr -> LexemeLink $ Text.pack $ scheme <> ss <> addr)
 280          <$> P.option "" (P.try p_scheme)
 281          <*> P.string "//"
 282          <*> p_addr
 283         where
 284         p_scheme =
 285                 (<>)
 286                  <$> P.some (P.satisfy $ \c ->
 287                         Char.isAlphaNum c
 288                         || c=='_'
 289                         || c=='-'
 290                         || c=='+')
 291                  <*> P.string ":"
 292         p_addr =
 293                 P.many $
 294                         P.satisfy $ \c ->
 295                                 Char.isAlphaNum c
 296                                 || c=='%'
 297                                 || c=='/'
 298                                 || c=='('
 299                                 || c==')'
 300                                 || c=='-'
 301                                 || c=='_'
 302                                 || c=='.'
 303
 304 p_Escape :: Parser e s Lexeme
 305 p_Escape =
 306         LexemeEscape
 307          <$  P.char '\\'
 308          <*> P.satisfy Char.isPrint
 309
 310 p_ElemSingle :: Parser e s [Lexeme]
 311 p_ElemSingle = pdbg "ElemOpen" $
 312         (\e as ->
 313                 [ LexemePairOpen  $ PairElem e as
 314                 , LexemeToken      $ Tokens mempty
 315                   -- NOTE: encode that it's the same Elem for open and close
 316                 , LexemePairClose $ PairElem e [] ])
 317          <$  P.char '<'
 318          <*> p_Word
 319          <*> p_Attrs
 320          <*  P.string "/>"
 321
 322 p_ElemOpen :: Parser e s [Lexeme]
 323 p_ElemOpen = pdbg "ElemOpen" $
 324         (\e as oc ->
 325                 case oc of
 326                  True  -> [ LexemePairOpen  $ PairElem e as
 327                           , LexemeToken      $ Tokens mempty
 328                           , LexemePairClose $ PairElem e [] ]
 329                  False -> [LexemePairOpen $ PairElem e as])
 330          <$  P.char '<'
 331          <*> p_Word
 332          <*> p_Attrs
 333          <*> P.option False (True <$ P.char '/')
 334          <*  P.char '>'
 335
 336 p_ElemClose :: Parser e s [Lexeme]
 337 p_ElemClose = pdbg "ElemClose" $
 338         (\e -> [LexemePairClose $ PairElem e []])
 339          <$  P.string "</"
 340          <*> p_Word
 341          <*  P.char '>'