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
 323 pairBorders :: Foldable f => Pair -> f a -> (TL.Text,TL.Text)
 324 pairBorders p ts | null ts   = pairBordersSingle p
 325                  | otherwise = pairBordersDouble p
 326
 327 pairBordersSingle :: Pair -> (TL.Text,TL.Text)
 328 pairBordersSingle = \case
 329  PairElem n as ->
 330         ("<"<>n<>foldMap f as<>"/>","")
 331         where f (elemAttr_white,ElemAttr{..}) =
 332                 elemAttr_white <>
 333                 elemAttr_name  <>
 334                 elemAttr_open  <>
 335                 elemAttr_value <>
 336                 elemAttr_close
 337  p -> pairBordersDouble p
 338
 339 pairBordersDouble :: Pair -> (TL.Text,TL.Text)
 340 pairBordersDouble = \case
 341  PairElem n as -> ("<"<>n<>foldMap f as<>">","</"<>n<>">")
 342         where f (elemAttr_white,ElemAttr{..}) =
 343                 elemAttr_white <>
 344                 elemAttr_name  <>
 345                 elemAttr_open  <>
 346                 elemAttr_value <>
 347                 elemAttr_close
 348  PairHash        -> ("#","#")
 349  PairStar        -> ("*","*")
 350  PairSlash       -> ("/","/")
 351  PairUnderscore  -> ("_","_")
 352  PairDash        -> ("-","-")
 353  PairBackquote   -> ("`","`")
 354  PairSinglequote -> ("'","'")
 355  PairDoublequote -> ("\"","\"")
 356  PairFrenchquote -> ("«","»")
 357  PairParen       -> ("(",")")
 358  PairBrace       -> ("{","}")
 359  PairBracket     -> ("[","]")
 360
 361 -- * Class 'TagFrom'
 362 class TagFrom a where
 363         tagFrom :: a -> Maybe (Cell Tag, a)
 364 instance TagFrom Tokens where
 365         tagFrom ts =
 366                 case Seq.viewl ts of
 367                  EmptyL -> Nothing
 368                  Tree0 (Cell loc0@(Span _f0 _b0 e0:|_l0) n) :< ns ->
 369                         case n of
 370                          NodeToken (TokenText t) ->
 371                                 case tagFrom $ Cell loc0 t of
 372                                  Nothing -> Nothing
 373                                  Just (t0,r0) ->
 374                                         if TL.null $ unCell r0
 375                                         then
 376                                                 case tagFrom ns of
 377                                                  Just (t1@(Cell (Span _f1 b1 _e1:|_l1) _), r1) | e0 == b1 ->
 378                                                         Just (t0<>t1, r1)
 379                                                  _ -> Just (t0, ns)
 380                                         else Just (t0, pure n0 `unionTokens` ns)
 381                                         where n0 = Tree0 $ NodeToken . TokenText <$> r0
 382                          _ -> Nothing
 383                  _ -> Nothing
 384 instance TagFrom (Cell TL.Text) where
 385         tagFrom (Cell (Span fp bp ep:|sp) t)
 386          | (w,r) <- TL.span isTagChar t
 387          , not $ TL.null w
 388          , ew <- pos_column bp + sum (Text.length <$> TL.toChunks w) =
 389                 Just
 390                  ( Cell (Span fp bp bp{pos_column=ew}:|sp) w
 391                  , Cell (Span fp bp{pos_column=ew} ep:|sp) r )
 392         tagFrom _ = Nothing
 393
 394 isTagChar :: Char -> Bool
 395 isTagChar c =
 396         Char.isAlphaNum c ||
 397         c=='·' ||
 398         case Char.generalCategory c of
 399          Char.DashPunctuation -> True
 400          Char.ConnectorPunctuation -> True
 401          _ -> False
 402
 403 {-
 404 -- | Build 'Tokens' from many 'Token's.
 405 tokens :: [Cell Token] -> Tokens
 406 tokens ts = Seq.fromList $ Tree0 . (NodeToken <$>) <$> ts
 407
 408 -- | Build 'Tokens' from one 'Token'.
 409 tokens1 :: Tree (Cell Node) -> Tokens
 410 tokens1 = Seq.singleton
 411
 412 unTokenElem :: Tokens -> Maybe (Cell (ElemName,ElemAttrs,Tokens))
 413 unTokenElem toks =
 414         case toList $ {-Seq.dropWhileR isTokenWhite-} toks of
 415          [Tree (Cell bp ep (NodePair (PairElem e as))) ts] -> Just (Cell bp ep (e,as,ts))
 416          _ -> Nothing
 417
 418 isTokenElem :: Tokens -> Bool
 419 isTokenElem toks =
 420         case toList $ {-Seq.dropWhileR isTokenWhite-} toks of
 421          [Tree (unCell -> NodePair PairElem{}) _] -> True
 422          _ -> False
 423 -}