Hdoc/TCT/Read/Token.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Hdoc.TCT.Read.Token where
   9
  10 import Control.Applicative (Applicative(..), Alternative(..))
  11 import Control.Monad (Monad(..))
  12 import Data.Bool
  13 import Data.Char (Char)
  14 import Data.Either (Either(..))
  15 import Data.Eq (Eq(..))
  16 import Data.Foldable (Foldable(..))
  17 import Data.Function (($), (.))
  18 import Data.Functor ((<$>), ($>))
  19 import Data.List.NonEmpty (NonEmpty(..))
  20 import Data.Maybe (Maybe(..))
  21 import Data.Monoid (Monoid(..))
  22 import Data.Semigroup (Semigroup(..))
  23 import Data.Sequence (ViewL(..), ViewR(..), (<|))
  24 import Data.TreeSeq.Strict (Tree(..), Trees)
  25 import Data.Tuple (fst,snd)
  26 import Data.Void (Void)
  27 import Prelude (Num(..))
  28 import Text.Show (Show(..))
  29 import qualified Data.Char as Char
  30 import qualified Data.List.NonEmpty as NonEmpty
  31 import qualified Data.Sequence as Seq
  32 import qualified Data.Text as Text
  33 import qualified Data.Text.Lazy as TL
  34 import qualified Text.Megaparsec as P
  35 import qualified Text.Megaparsec.Char as P
  36
  37 import Hdoc.TCT.Debug
  38 import Hdoc.TCT.Cell
  39 import Hdoc.TCT.Elem
  40 import Hdoc.TCT.Tree
  41 import Hdoc.TCT.Read.Elem
  42 import Hdoc.TCT.Read.Cell
  43
  44 -- * Type 'Pairs'
  45 -- | Right-only Dyck language,
  46 -- to keep track of opened 'Pair's.
  47 type Pairs = (Tokens,[Opening])
  48 type Tokens = Trees (Cell Node)
  49
  50 -- ** Type 'Opening'
  51 -- | An opened 'Pair' and its content so far.
  52 type Opening = (Cell Pair,Tokens)
  53
  54 appendPairsToken :: Pairs -> Tree (Cell Node) -> Pairs
  55 appendPairsToken ps t = appendPairsTokens ps (pure t)
  56
  57 appendPairsText :: Pairs -> Cell TL.Text -> Pairs
  58 appendPairsText ps (Cell sp t) =
  59         appendPairsToken ps $
  60                 Tree0 $ Cell sp $
  61                         NodeToken $ TokenText t
  62
  63 appendPairsTokens :: Pairs -> Tokens -> Pairs
  64 appendPairsTokens (ts,[])         toks = (ts`unionTokens`toks,[])
  65 appendPairsTokens (ts,(p0,t0):ps) toks = (ts,(p0,t0`unionTokens`toks):ps)
  66
  67 -- | Unify two 'Tokens', merging border 'TokenText's if any.
  68 unionTokens :: Tokens -> Tokens -> Tokens
  69 unionTokens x y =
  70         case (Seq.viewr x, Seq.viewl y) of
  71          (xs :> x0, y0 :< ys) ->
  72                 case (x0,y0) of
  73                  (  Tree (Cell (Span  fx  bx _ex:| lx) (NodeToken (TokenText tx))) tsx
  74                   , Tree (Cell (Span _fy _by  ey:|_ly) (NodeToken (TokenText ty))) tsy ) ->
  75                         xs `unionTokens`
  76                         pure (Tree (Cell (Span fx bx ey:|lx) $ NodeToken $ TokenText $ tx <> ty) (tsx<>tsy)) `unionTokens`
  77                         ys
  78                  _ -> x <> y
  79          (EmptyR, _) -> y
  80          (_, EmptyL) -> x
  81
  82 unionsTokens :: Foldable f => f Tokens -> Tokens
  83 unionsTokens = foldl' unionTokens mempty
  84
  85 openPair :: Pairs -> Cell Pair -> Pairs
  86 openPair (t,ps) p = (t,(p,mempty):ps)
  87
  88 -- | Close a 'Pair' when there is a matching 'LexemePairClose'.
  89 closePair :: Pairs -> Cell Pair -> Pairs
  90 closePair ps@(_,[]) (Cell loc p) = -- debug0 "closePair" $
  91         appendPairsText ps $ Cell loc $
  92                 snd $ pairBordersDouble p
  93 closePair (t,(cx@(Cell (Span  fx  bx _ex:| lx) px),t1):ts)
  94               cy@(Cell (Span _fy _by  ey:|_ly) py) = -- debug0 "closePair" $
  95         case (px,py) of
  96          (PairElem nx ax, PairElem ny ay) | nx == ny ->
  97                 appendPairsToken (t,ts) $
  98                 Tree (Cell (Span fx bx ey:|lx) $ NodePair $ PairElem nx as) t1
  99                 where as | null ay   = ax
 100                          | otherwise = ax<>ay
 101          _ | px == py ->
 102                 appendPairsToken (t,ts) $
 103                 Tree (Cell (Span fx bx ey:|lx) $ NodePair px) t1
 104          _ ->
 105                 (`closePair` cy) $
 106                 appendPairsTokens
 107                  (t,ts)
 108                  (closeImpaired mempty (cx,t1))
 109
 110 -- | Close a 'Pair' when there is no matching 'LexemePairClose'.
 111 closeImpaired :: Tokens -> (Cell Pair, Tokens) -> Tokens
 112 closeImpaired acc (Cell loc@(s0:|lp) pair, toks) = -- debug0 "closeImpaired" $
 113         case pair of
 114          -- NOTE: try to close 'PairHash' as 'TokenTag' instead of 'TokenPlain'.
 115          PairHash | Just (Cell (Span{span_end}:|_lt) tag, rest) <- tagFrom body ->
 116                 Tree0 (Cell (s0{span_end}:|lp) $ NodeToken $ TokenTag tag) <| rest
 117                 -- NOTE: use bp (not bt) to include the '#'
 118          _ -> pure open `unionTokens` body
 119         where
 120         body = toks `unionTokens` acc
 121         open = Tree0 $ Cell loc $ NodeToken $ TokenText $ fst $ pairBordersDouble pair
 122
 123 -- | Close remaining 'Pair's at end of parsing.
 124 closePairs :: Pairs -> Tokens
 125 closePairs (t0,ps) = -- debug0 "closePairs" $
 126         t0 `unionTokens` foldl' closeImpaired mempty ps
 127
 128 appendLexeme :: Lexeme -> Pairs -> Pairs
 129 appendLexeme lex acc = -- debug2 "appendLexeme" "lex" "acc" $ \lex acc ->
 130         case lex of
 131          LexemePairOpen ps -> foldl' open acc ps
 132                 where
 133                 -- NOTE: insert an empty node to encode <elem></elem>, not <elem/>
 134                 open a p@(Cell (Span{span_end, ..}:|sp) PairElem{}) = openPair a p `appendPairsText` Cell (Span{span_begin=span_end, ..}:|sp) ""
 135                 open a p = openPair a p
 136          LexemePairClose ps -> foldl' closePair acc ps
 137          LexemePairAny   ps -> foldl' openPair  acc ps
 138          {-
 139          LexemePairAny ps ->
 140                 appendPairsText acc $ sconcat $
 141                         ((fst . pairBordersSingle) <$>) <$> ps
 142          -}
 143          LexemePairBoth ps -> appendPairsTokens acc $ Seq.fromList $ toList $ Tree0 . (NodePair <$>) <$> ps
 144          LexemeEscape   c  -> appendPairsToken  acc $ Tree0 $ NodeToken . TokenEscape <$> c
 145          LexemeLink     t  -> appendPairsToken  acc $ Tree0 $ NodeToken . TokenLink <$> t
 146          {-LexemeWhite (unCell -> "") -> acc-}
 147          -- LexemeWhite (unCell -> Text.all (==' ') -> True) -> acc
 148          LexemeWhite    t  -> appendPairsText acc t
 149          LexemeAlphaNum t  -> appendPairsText acc t
 150          LexemeOther    t  -> appendPairsText acc t
 151          LexemeTree     t  -> appendPairsToken acc t
 152          LexemeEnd -> acc
 153
 154 appendLexemes :: Pairs -> [Lexeme] -> Pairs
 155 appendLexemes = foldr appendLexeme
 156
 157 -- * Type 'Lexeme'
 158 -- | 'Lexeme's cut the input in the longest chunks of common semantic,
 159 -- this enables 'orientLexemePairAny' to work with a more meaningful context.
 160 data Lexeme
 161  =   LexemePairOpen  !(NonEmpty (Cell Pair))
 162  |   LexemePairClose !(NonEmpty (Cell Pair))
 163  |   LexemePairAny   !(NonEmpty (Cell Pair))
 164      -- ^ orientation depending on the surrounding 'Lexeme's,
 165      -- see 'orientLexemePairAny'
 166  |   LexemePairBoth  !(NonEmpty (Cell Pair))
 167  |   LexemeEscape    !(Cell Char)
 168  |   LexemeLink      !(Cell TL.Text)
 169  |   LexemeWhite     !(Cell TL.Text)
 170  |   LexemeAlphaNum  !(Cell TL.Text)
 171  |   LexemeOther     !(Cell TL.Text)
 172  |   LexemeTree      !(Tree (Cell Node))
 173  |   LexemeEnd
 174  deriving (Eq, Show)
 175 instance Pretty Lexeme
 176
 177 parseTokens :: [Lexeme] -> Tokens
 178 parseTokens ps =
 179         closePairs $
 180         appendLexemes mempty $
 181         -- debug0 "Lexemes (post orient)" $
 182         orientLexemePairAny $ LexemeEnd :
 183         ps
 184
 185 parseLexemes ::
 186  Cell TL.Text ->
 187  Either (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)) [Lexeme]
 188 parseLexemes = runParserOnCell (p_Lexemes <* P.eof)
 189
 190 -- | Parse 'Lexeme's, returning them in reverse order
 191 -- to apply 'orientLexemePairAny'.
 192 p_Lexemes :: P.Tokens s ~ TL.Text => Parser e s [Lexeme]
 193 p_Lexemes = debugParser "Lexemes" $ go []
 194         where
 195         go :: P.Tokens s ~ TL.Text => [Lexeme] -> Parser e s [Lexeme]
 196         go acc =
 197                 (P.eof $> acc) <|>
 198                 (p_Lexeme >>= \next -> go $ orientLexemePairAny $ next:acc)
 199
 200 -- | Must be called on parsed 'Lexeme's after the prepending of any new 'Lexeme',
 201 -- so that it can try to orient nearby 'LexemePairAny'
 202 -- to 'LexemePairOpen' or 'LexemePairClose'.
 203 orientLexemePairAny :: [Lexeme] -> [Lexeme]
 204 orientLexemePairAny = \case
 205          -- LexemeOther (Cell _bx ex x):LexemeOther (Cell by _ey y):acc -> LexemeOther (Cell by ex (x<>y)):acc
 206
 207          -- "
 208          t@LexemeTree{}:LexemePairAny p:acc -> t:LexemePairClose p:acc
 209          w@LexemeWhite{}:LexemePairAny p:acc -> w:LexemePairClose p:acc
 210          LexemeEnd:LexemePairAny p:acc -> LexemePairClose p:acc
 211          --    "
 212          LexemePairAny p:t@LexemeTree{}:acc -> LexemePairOpen p:t:acc
 213          LexemePairAny p:w@LexemeWhite{}:acc -> LexemePairOpen p:w:acc
 214          LexemePairAny p:[] -> LexemePairOpen p:[]
 215
 216          --    ,,,"
 217          LexemePairAny p:a@LexemeOther{}:w@LexemeWhite{}:acc -> LexemePairOpen p:a:w:acc
 218          LexemePairAny p:a@LexemeOther{}:[] -> LexemePairOpen p:a:[]
 219          -- ",,,
 220          w@LexemeWhite{}:a@LexemeOther{}:LexemePairAny p:acc -> w:a:LexemePairClose p:acc
 221          LexemeEnd:a@LexemeOther{}:LexemePairAny p:acc -> a:LexemePairClose p:acc
 222
 223          -- ",,,AAA
 224          an@LexemeAlphaNum{}:a@LexemeOther{}:LexemePairAny p:acc -> an:a:LexemePairClose p:acc
 225          -- ,,,"AAA
 226          an@LexemeAlphaNum{}:LexemePairAny p:a@LexemeOther{}:acc -> an:LexemePairOpen p:a:acc
 227
 228          -- ")
 229          c@LexemePairClose{}:LexemePairAny p:acc -> c:LexemePairClose p:acc
 230          -- ("
 231          LexemePairAny p:o@LexemePairOpen{}:acc -> LexemePairOpen p:o:acc
 232
 233          -- "(
 234          o@LexemePairOpen{}:LexemePairAny p:acc -> o:LexemePairClose p:acc
 235          -- )"
 236          LexemePairAny p:c@LexemePairClose{}:acc -> LexemePairClose p:c:acc
 237
 238          acc -> acc
 239
 240 p_Lexeme :: P.Tokens s ~ TL.Text => Parser e s Lexeme
 241 p_Lexeme = debugParser "Lexeme" $
 242         P.choice
 243          [ P.try $ LexemeWhite     <$> p_Cell p_Spaces1
 244          , P.try $ LexemePairAny   <$> p_some (p_Cell $ p_satisfyMaybe pairAny)
 245          , P.try $ LexemePairBoth  <$> p_some (P.try $ p_Cell p_ElemSingle)
 246          , P.try $ LexemePairOpen  <$> p_some (p_Cell $ p_satisfyMaybe pairOpen  <|> P.try p_ElemOpen)
 247          , P.try $ LexemePairClose <$> p_some (p_Cell $ p_satisfyMaybe pairClose <|> P.try p_ElemClose)
 248          , P.try $ LexemeEscape    <$> p_Cell p_Escape
 249          , P.try $ LexemeLink      <$> p_Cell p_Link
 250          , P.try $ LexemeAlphaNum  <$> p_Cell (P.takeWhile1P (Just "AlphaNum") Char.isAlphaNum)
 251          ,         LexemeOther     <$> p_Cell (TL.singleton <$> P.anyChar)
 252          ]
 253
 254 p_some :: Parser e s a -> Parser e s (NonEmpty a)
 255 p_some p = NonEmpty.fromList <$> P.some p
 256
 257 pairAny :: Char -> Maybe Pair
 258 pairAny = \case
 259  '-'  -> Just PairDash
 260  '/'  -> Just PairSlash
 261  '"'  -> Just PairDoublequote
 262  '\'' -> Just PairSinglequote
 263  '`'  -> Just PairBackquote
 264  '_'  -> Just PairUnderscore
 265  '*'  -> Just PairStar
 266  '#'  -> Just PairHash
 267  _    -> Nothing
 268
 269 pairOpen :: Char -> Maybe Pair
 270 pairOpen = \case
 271  '('  -> Just PairParen
 272  '['  -> Just PairBracket
 273  '{'  -> Just PairBrace
 274  '«'  -> Just PairFrenchquote
 275  _    -> Nothing
 276
 277 pairClose :: Char -> Maybe Pair
 278 pairClose = \case
 279  ')'  -> Just PairParen
 280  ']'  -> Just PairBracket
 281  '}'  -> Just PairBrace
 282  '»'  -> Just PairFrenchquote
 283  _    -> Nothing
 284
 285 p_Escape :: Parser e s Char
 286 p_Escape = P.char '\\' *> P.satisfy Char.isPrint
 287
 288 p_Link :: P.Tokens s ~ TL.Text => Parser e s TL.Text
 289 p_Link =
 290         P.try (P.char '<' *> p <* P.char '>') <|>
 291         p
 292         where
 293         p :: P.Tokens s ~ TL.Text => Parser e s TL.Text
 294         p =
 295                 (\scheme addr -> scheme <> "//" <> addr)
 296                  <$> P.option "" (P.try p_scheme)
 297                  <*  P.string "//"
 298                  <*> p_addr
 299         p_scheme :: P.Tokens s ~ TL.Text => Parser e s TL.Text
 300         p_scheme =
 301                 (<> ":")
 302                  <$> (P.takeWhile1P (Just "scheme") $ \c ->
 303                         Char.isAlphaNum c
 304                         || c=='_'
 305                         || c=='-'
 306                         || c=='+')
 307                  <* P.char ':'
 308         p_addr :: P.Tokens s ~ TL.Text => Parser e s TL.Text
 309         p_addr =
 310                 P.takeWhileP (Just "addr") $ \c ->
 311                         Char.isAlphaNum c
 312                         || c=='%'
 313                         || c=='/'
 314                         || c=='('
 315                         || c==')'
 316                         || c=='-'
 317                         || c=='_'
 318                         || c=='.'
 319                         || c=='#'
 320                         || c=='?'
 321                         || c=='='
 322                         || c=='@'
 323
 324 pairBorders :: Foldable f => Pair -> f a -> (TL.Text,TL.Text)
 325 pairBorders p ts | null ts   = pairBordersSingle p
 326                  | otherwise = pairBordersDouble p
 327
 328 pairBordersSingle :: Pair -> (TL.Text,TL.Text)
 329 pairBordersSingle = \case
 330  PairElem n as ->
 331         ("<"<>n<>foldMap f as<>"/>","")
 332         where f (elemAttr_white,ElemAttr{..}) =
 333                 elemAttr_white <>
 334                 elemAttr_name  <>
 335                 elemAttr_open  <>
 336                 elemAttr_value <>
 337                 elemAttr_close
 338  p -> pairBordersDouble p
 339
 340 pairBordersDouble :: Pair -> (TL.Text,TL.Text)
 341 pairBordersDouble = \case
 342  PairElem n as -> ("<"<>n<>foldMap f as<>">","</"<>n<>">")
 343         where f (elemAttr_white,ElemAttr{..}) =
 344                 elemAttr_white <>
 345                 elemAttr_name  <>
 346                 elemAttr_open  <>
 347                 elemAttr_value <>
 348                 elemAttr_close
 349  PairHash        -> ("#","#")
 350  PairStar        -> ("*","*")
 351  PairSlash       -> ("/","/")
 352  PairUnderscore  -> ("_","_")
 353  PairDash        -> ("-","-")
 354  PairBackquote   -> ("`","`")
 355  PairSinglequote -> ("'","'")
 356  PairDoublequote -> ("\"","\"")
 357  PairFrenchquote -> ("«","»")
 358  PairParen       -> ("(",")")
 359  PairBrace       -> ("{","}")
 360  PairBracket     -> ("[","]")
 361
 362 -- * Class 'TagFrom'
 363 class TagFrom a where
 364         tagFrom :: a -> Maybe (Cell Tag, a)
 365 instance TagFrom Tokens where
 366         tagFrom ts =
 367                 case Seq.viewl ts of
 368                  EmptyL -> Nothing
 369                  Tree0 (Cell loc0@(Span _f0 _b0 e0:|_l0) n) :< ns ->
 370                         case n of
 371                          NodeToken (TokenText t) ->
 372                                 case tagFrom $ Cell loc0 t of
 373                                  Nothing -> Nothing
 374                                  Just (t0,r0) ->
 375                                         if TL.null $ unCell r0
 376                                         then
 377                                                 case tagFrom ns of
 378                                                  Just (t1@(Cell (Span _f1 b1 _e1:|_l1) _), r1) | e0 == b1 ->
 379                                                         Just (t0<>t1, r1)
 380                                                  _ -> Just (t0, ns)
 381                                         else Just (t0, pure n0 `unionTokens` ns)
 382                                         where n0 = Tree0 $ NodeToken . TokenText <$> r0
 383                          _ -> Nothing
 384                  _ -> Nothing
 385 instance TagFrom (Cell TL.Text) where
 386         tagFrom (Cell (Span fp bp ep:|sp) t)
 387          | (w,r) <- TL.span isTagChar t
 388          , not $ TL.null w
 389          , ew <- pos_column bp + sum (Text.length <$> TL.toChunks w) =
 390                 Just
 391                  ( Cell (Span fp bp bp{pos_column=ew}:|sp) w
 392                  , Cell (Span fp bp{pos_column=ew} ep:|sp) r )
 393         tagFrom _ = Nothing
 394
 395 isTagChar :: Char -> Bool
 396 isTagChar c =
 397         Char.isAlphaNum c ||
 398         c=='·' ||
 399         case Char.generalCategory c of
 400          Char.DashPunctuation -> True
 401          Char.ConnectorPunctuation -> True
 402          _ -> False
 403
 404 {-
 405 -- | Build 'Tokens' from many 'Token's.
 406 tokens :: [Cell Token] -> Tokens
 407 tokens ts = Seq.fromList $ Tree0 . (NodeToken <$>) <$> ts
 408
 409 -- | Build 'Tokens' from one 'Token'.
 410 tokens1 :: Tree (Cell Node) -> Tokens
 411 tokens1 = Seq.singleton
 412
 413 unTokenElem :: Tokens -> Maybe (Cell (ElemName,ElemAttrs,Tokens))
 414 unTokenElem toks =
 415         case toList $ {-Seq.dropWhileR isTokenWhite-} toks of
 416          [Tree (Cell bp ep (NodePair (PairElem e as))) ts] -> Just (Cell bp ep (e,as,ts))
 417          _ -> Nothing
 418
 419 isTokenElem :: Tokens -> Bool
 420 isTokenElem toks =
 421         case toList $ {-Seq.dropWhileR isTokenWhite-} toks of
 422          [Tree (unCell -> NodePair PairElem{}) _] -> True
 423          _ -> False
 424 -}