src/Symantic/XML/Read.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE InstanceSigs #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 {-# LANGUAGE UndecidableInstances #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Symantic.XML.Read where
   8
   9 import Control.Applicative as Alternative (Applicative(..), Alternative(..), optional)
  10 import Control.Monad (Monad(..))
  11 import Control.Monad.Trans.Class (MonadTrans(..))
  12 import Data.Bool
  13 import Data.Either (Either(..))
  14 import Data.Eq (Eq(..))
  15 import Data.Foldable (Foldable(..), all)
  16 import Data.Function (($), (.), const, id, flip)
  17 import Data.Functor (Functor(..), (<$>))
  18 import Data.List.NonEmpty (NonEmpty(..))
  19 import Data.Maybe (Maybe(..), maybe, isNothing, maybeToList)
  20 import Data.Monoid (Monoid(..))
  21 import Data.Ord (Ord(..))
  22 import Data.Proxy (Proxy(..))
  23 import Data.Semigroup (Semigroup(..))
  24 import Data.String (String, IsString(..))
  25 import Data.Tuple (fst)
  26 import Data.Void (Void)
  27 import Numeric.Natural (Natural)
  28 import Prelude ((+), Integer, undefined)
  29 import System.IO (IO, FilePath)
  30 import Text.Show (Show(..))
  31 import qualified Data.Char as Char
  32 import qualified Data.HashMap.Strict as HM
  33 import qualified Data.List as List
  34 import qualified Data.List.NonEmpty as NonEmpty
  35 import qualified Data.Sequence as Seq
  36 import qualified Data.Set as Set
  37 import qualified Data.Text as Text
  38 import qualified Data.Text.Lazy as TL
  39 import qualified Data.Text.Lazy.Builder as TLB
  40 import qualified Data.TreeSeq.Strict as TS
  41 import qualified Text.Megaparsec as P
  42 import qualified Text.Megaparsec.Char as P
  43 import qualified Text.Megaparsec.Char.Lexer as P
  44 import qualified Text.Megaparsec.Internal as P
  45
  46 import Symantic.Base
  47 import Symantic.XML.Language
  48 import Symantic.XML.RelaxNG.Language
  49 import Symantic.XML.Tree
  50
  51 -- | Main reading function.
  52 read ::
  53  Read FileSourced Void (x->x) a ->
  54  FilePath ->
  55  IO (Either String a)
  56 read rng path =
  57   readTree path >>= \case
  58    Left  err -> return $ Left err
  59    Right xml -> return $ runRead rng xml
  60
  61 -- | Like 'readWithRelaxNG' but on a 'FileSourcedTrees'.
  62 runRead ::
  63  Read FileSourced Void (x->x) a ->
  64  FileSourcedTrees ->
  65  Either String a
  66 runRead rng xml =
  67   case P.runParser (unRead rng) "" (mempty, xml) of
  68    Left err -> Left $ foldMap parseErrorTextPretty $ P.bundleErrors err
  69    Right a -> Right $ a id
  70
  71 -- * Type 'ReadStream'
  72 type ReadStream src =
  73  ( HM.HashMap QName (src EscapedAttr)
  74  , Trees src
  75  )
  76
  77 -- | Take one 'Node' from the 'ReadStream',
  78 -- or fallback to an attribute, or 'Nothing'.
  79 --
  80 -- Use 'pTokenAttr' to take only attributes.
  81 take1_ ::
  82  UnSource src =>
  83  (Node (src EscapedAttr) -> Bool) ->
  84  ReadStream src ->
  85  Maybe ( P.Token (ReadStream src)
  86        , ReadStream src )
  87 take1_ isIgnoredNode s@(attrs, trees) =
  88   go trees
  89   where
  90   go trs =
  91     case Seq.viewl trs of
  92      Seq.EmptyL
  93       | null attrs -> Nothing
  94       | otherwise -> Just (Left attrs, s)
  95      t Seq.:< ts ->
  96       case unSource (TS.unTree t) of
  97        n | isIgnoredNode n -> go ts
  98          | otherwise -> Just (Right t, (attrs, ts))
  99         -- Note that having an ignored node
 100         -- can split a text into two 'NodeText's.
 101         -- Not sure if it would be better to unify them.
 102
 103 -- ** Type 'ReadConstraints'
 104 -- | Convenient alias to be less verbose.
 105 type ReadConstraints src =
 106  ( Ord (src (Node (src EscapedAttr)))
 107  , Ord (src EscapedAttr)
 108  , UnSource src
 109  , NoSource src
 110  , SourceOf src
 111  , Show (Source src)
 112  , Show (src String)
 113  , Functor src
 114  )
 115
 116 instance ReadConstraints src => P.Stream (ReadStream src) where
 117   type Token (ReadStream src) = Either
 118    (HM.HashMap QName (src EscapedAttr))
 119    (Tree src)
 120   type Tokens (ReadStream src) = ReadStream src
 121   take1_ = take1_ isIgnoredNode
 122     where
 123     isIgnoredNode = \case
 124      NodeComment{} -> True
 125      NodePI{}      -> True
 126      _ -> False
 127   showTokens _s toks =
 128     orList $
 129     mconcat $
 130     toList $ showTree <$> toks
 131     where
 132     showSource :: src String -> String
 133     showSource sa =
 134       let src = sourceOf sa in
 135       if nullSource @src src
 136       then unSource sa
 137       else unSource sa<>" at "<>show src
 138     showTree = \case
 139      Left as ->
 140       (\(an, av) -> showSource $ ("(attribute "<>show an<>")") <$ av)
 141        <$> List.sortOn fst (HM.toList as)
 142      Right (TS.Tree nod ts) ->
 143       pure $
 144       showSource . (<$ nod) $
 145       case unSource nod of
 146        NodeElem n _as -> "(element "<>show n<>")"
 147        NodeText{} ->
 148         case Seq.viewl ts of
 149          TS.Tree tn _ Seq.:< _
 150           | NodeText lit <- unSource tn ->
 151           -- Abuse the encoding to detect expected 'literal'
 152           -- using nested 'NodeText'
 153           "\""<>TL.unpack (unescapeText lit)<>"\""
 154          _ -> "text"
 155        NodeComment _c -> "comment"
 156        NodePI n _t    -> "(processing-instruction "<>show n<>")"
 157        NodeCDATA _t   -> "cdata"
 158   -- Useless methods for validating an XML AST
 159   takeN_ = undefined
 160   tokensToChunk = undefined
 161   chunkToTokens = undefined
 162   chunkLength = undefined
 163   takeWhile_ = undefined
 164   reachOffset = undefined
 165   reachOffsetNoLine = undefined
 166
 167 -- * Type 'Read'
 168 newtype Read src e f k
 169  =      Read
 170  {    unRead :: P.Parsec e (ReadStream src) (f->k) }
 171
 172 instance
 173  ( Ord err
 174  , ReadConstraints src
 175  ) => Emptyable (Read src err) where
 176   empty = Read $ id <$ P.eof
 177 instance
 178  ( Ord err
 179  , ReadConstraints src
 180  ) => Unitable (Read src err) where
 181   unit = Read $ return ($ ())
 182 instance
 183  ( Ord err
 184  , ReadConstraints src
 185  ) => Voidable (Read src err) where
 186   void _a (Read x) = Read $
 187     (\a2b2k b -> a2b2k (\_a -> b)) <$> x
 188 instance
 189  ( Ord err
 190  , ReadConstraints src
 191  ) => Constant (Read src err) where
 192   constant a = Read $ return ($ a)
 193 instance
 194  ( Ord err
 195  , ReadConstraints src
 196  ) => Permutable (Read src err) where
 197   type Permutation (Read src err) =
 198     ReadPerm src err
 199   permutable (ReadPerm ma p) = Read $ do
 200     r <- Alternative.optional p
 201     unRead $
 202       case r of
 203        Just perms -> permutable perms
 204        Nothing ->
 205         Read $ maybe
 206          -- Not 'empty' here so that 'P.TrivialError'
 207          -- has the unexpected token.
 208          (P.token (const Nothing) Set.empty)
 209          return ma
 210   noPerm = ReadPerm Nothing Alternative.empty
 211   perm (Read x) =
 212     ReadPerm Nothing $ (<$> x) $ \a ->
 213       ReadPerm (Just a) Alternative.empty
 214   permWithDefault d (Read x) =
 215     ReadPerm (Just ($ d)) $ (<$> x) $ \a ->
 216       ReadPerm (Just a) Alternative.empty
 217 instance
 218  ( Ord err
 219  , ReadConstraints src
 220  ) => Composable (Read src err) where
 221   Read x <.> Read y = Read $
 222     x >>= \a2b -> (. a2b) <$> y
 223 instance
 224  ( Ord err
 225  , ReadConstraints src
 226  ) => Tupable (Read src err) where
 227   Read x <:> Read y = Read $
 228     consCont (,) <$> x <*> y
 229 instance
 230  ( Ord err
 231  , ReadConstraints src
 232  ) => Eitherable (Read src err) where
 233   Read x <+> Read y = Read $
 234     mapCont Left <$> P.try x <|>
 235     mapCont Right <$> y
 236 {-
 237 instance
 238  ( Ord err
 239  , ReadConstraints src
 240  ) => Routable (Read src err) where
 241   Read x <!> Read y = Read $
 242     (\a2k (a:!:_b) -> a2k a) <$> P.try x <|>
 243     (\b2k (_a:!:b) -> b2k b) <$> y
 244 -}
 245 instance
 246  ( Ord err
 247  , ReadConstraints src
 248  ) => Optionable (Read src err) where
 249   option (Read x) = Read $
 250     P.try x <|> return id
 251   optional (Read x) = Read $
 252     mapCont Just <$> P.try x <|>
 253     return ($ Nothing)
 254 instance
 255  ( Ord err
 256  , ReadConstraints src
 257  ) => Repeatable (Read src err) where
 258   many0 (Read x) = Read $ concatCont <$> many x
 259   many1 (Read x) = Read $ concatCont <$> some x
 260 instance
 261  ( Ord err
 262  , ReadConstraints src
 263  ) => Dimapable (Read src err) where
 264   dimap a2b _b2a (Read r) =
 265     Read $ (\k b2k -> k (b2k . a2b)) <$> r
 266 instance
 267  ( Ord err
 268  , ReadConstraints src
 269  ) => Dicurryable (Read src err) where
 270   dicurry (_::proxy args) constr _destr (Read x) = Read $ do
 271     f <- x
 272     return $ \r2k ->
 273       f (mapresultN @args r2k constr)
 274 instance
 275  ( Ord err
 276  , ReadConstraints src
 277  , Textable (Read src err)
 278  ) => XML (Read src err) where
 279   namespace _nm _ns = Read (return id)
 280   element n p = Read $ do
 281     s <- P.token check $ Set.singleton $
 282       P.Tokens $ pure expected
 283     unRead $ readNested p s
 284     where
 285     expected = Right $ TS.tree0 $ noSource $ NodeElem n mempty
 286     check = \case
 287      Right (TS.Tree nod ts)
 288       | NodeElem e as <- unSource nod
 289       , e == n
 290       -> Just (removeXMLNS as, removeSpaces ts)
 291      _ -> Nothing
 292   attribute n p = Read $ do
 293     v <- pTokenAttr n $ Set.singleton $
 294       P.Tokens $ pure expected
 295     unRead $ readNested p
 296      (mempty, pure (TS.tree0 (NodeText . EscapedText . unEscapedAttr <$> v)))
 297     -- Cast 'EscapedAttr' into 'EscapedText'
 298     -- because it will be read, not written,
 299     -- hence only given to 'unescapeText'
 300     -- which is the same than 'unescapeAttr'.
 301     where
 302     expected = Left $ HM.singleton n $ noSource ""
 303   literal lit = Read $ do
 304     P.token check $ Set.singleton $ P.Tokens $ pure expected
 305     where
 306     expected = Right $
 307       TS.Tree (noSource $ NodeText "")
 308        (pure $ TS.tree0 (noSource $ NodeText $ escapeText lit))
 309     check = \case
 310      Right (Tree0 nod)
 311       | NodeText t <- unSource nod
 312       , unescapeText t == lit
 313       -> Just id
 314      _ -> Nothing
 315   pi n = Read $ do
 316     v <- pTokenPI n $ Set.singleton $
 317       P.Tokens $ pure expected
 318     return ($ v)
 319     where
 320     expected = Right $ TS.tree0 $ noSource $ NodePI n mempty
 321   cdata = Read $
 322     P.token check $ Set.singleton $
 323       P.Tokens $ pure expected
 324     where
 325     expected = Right $ TS.tree0 $ noSource $ NodeCDATA mempty
 326     check = \case
 327      Right (Tree0 nod)
 328       | NodeCDATA v <- unSource nod
 329       -> Just ($ v)
 330      _ -> Nothing
 331   comment = Read $
 332     P.token check $ Set.singleton $
 333       P.Tokens $ pure expected
 334     where
 335     expected = Right $ TS.tree0 $ noSource $ NodeComment mempty
 336     check = \case
 337      Right (Tree0 nod)
 338       | NodeComment v <- unSource nod
 339       -> Just ($ v)
 340      _ -> Nothing
 341 instance Ord err => Textable (Read FileSourced err) where
 342   type TextConstraint (Read FileSourced err) a =
 343     DecodeText a
 344   text :: forall a k repr.
 345    repr ~ Read FileSourced err =>
 346    TextConstraint repr a => repr (a->k) k
 347   text = Read $ do
 348     Sourced (FileSource (src :| _)) txt <-
 349       P.token check $ Set.singleton $ P.Tokens $ pure expected
 350     case P.runParser @Void (decodeText @a <* P.eof) "" (unescapeText txt) of
 351      Right a -> return ($ a)
 352      Left errs -> P.fancyFailure $ Set.singleton $ P.ErrorFail $
 353       (`foldMap` P.bundleErrors errs) $ \err ->
 354         fileRange_path src <> ":" <>
 355         show (fileRange_begin src <> Offset (P.errorOffset err)) <> "\n" <>
 356         P.parseErrorTextPretty err
 357     where
 358     expected = Right $ TS.tree0 $ noSource $ NodeText $ EscapedText mempty
 359     check = \case
 360      Right (Tree0 nod)
 361       | NodeText t <- unSource nod
 362       -> Just (t <$ nod)
 363      _ -> Nothing
 364 instance
 365  ( Ord err
 366  , ReadConstraints src
 367  , Textable (Read src err)
 368  , Definable (Read src err)
 369  ) => RelaxNG (Read src err) where
 370   elementMatch nc p = Read $ do
 371     (n,s) <- P.token check $ Set.singleton $
 372       P.Tokens $ pure expected
 373     ((\a2k n2a -> a2k (n2a n)) <$>) $
 374       unRead (readNested p s)
 375     where
 376     expected = Right $ TS.tree0 $ noSource $
 377       NodeElem (qName (NCName (TLB.toLazyText
 378        (textify (mempty::Namespaces NCName,(infixN0,SideL),nc)))))
 379        mempty
 380     check = \case
 381      Right (TS.Tree nod ts)
 382       | NodeElem n as <- unSource nod
 383       , matchNameClass nc n
 384       -> Just (n, (removeXMLNS as, removeSpaces ts))
 385      _ -> Nothing
 386   attributeMatch nc p = Read $ do
 387     (an,av) <- pTokenAttrNameClass nc $ Set.singleton $
 388       P.Tokens $ pure expected
 389     ((\a2k n2a -> a2k (n2a an)) <$>) $
 390       unRead $ readNested p
 391        (mempty, pure (TS.tree0 (NodeText . EscapedText . unEscapedAttr <$> av)))
 392     -- See comment in 'attribute' about the cast to 'EscapedText' here.
 393     where
 394     expected = Left $ HM.singleton (qName (NCName n)) $ noSource ""
 395       where n = TLB.toLazyText $ textify (mempty::Namespaces NCName,(infixN0,SideL),nc)
 396 instance Ord err => Definable (Read FileSourced err) where
 397   define n = Read . P.label n . unRead
 398
 399 -- ** Type 'ReadPerm'
 400 data ReadPerm (src :: * -> *) err a k
 401  =   ReadPerm
 402  {   readPerm_result :: !(Maybe (a->k))
 403  ,   readPerm_parser :: P.Parsec err (ReadStream src) (ReadPerm src err a k)
 404  }
 405
 406 instance
 407  (Ord err, ReadConstraints src) =>
 408  Dimapable (ReadPerm src err) where
 409   dimap a2b b2a (ReadPerm a ma) =
 410     ReadPerm (merge <$> a)
 411     (dimap a2b b2a `fmap` ma)
 412     where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
 413 instance
 414  (Ord err, ReadConstraints src) =>
 415  Dicurryable (ReadPerm src err) where
 416   dicurry ::
 417    forall args r k proxy.
 418    CurryN args =>
 419    proxy args ->
 420    (args-..->r) -> -- construction
 421    (r->Tuples args) -> -- destruction
 422    ReadPerm src err (args-..->k) k ->
 423    ReadPerm src err (r->k) k
 424   dicurry px constr destr (ReadPerm a ma) =
 425     ReadPerm (merge <$> a)
 426      (dicurry px constr destr `fmap` ma)
 427     where
 428     merge args2k2k = \r2k ->
 429       args2k2k $ mapresultN @args r2k constr
 430 instance
 431  (Ord err, ReadConstraints src) =>
 432  Composable (ReadPerm src err) where
 433   lhs@(ReadPerm da pa) <.> rhs@(ReadPerm db pb) =
 434     ReadPerm a $
 435       lhsAlt <|> rhsAlt
 436     where
 437     lhsAlt = (<.> rhs) <$> pa
 438     rhsAlt = (lhs <.>) <$> pb
 439     a = flip (.) <$> da <*> db
 440 instance
 441  (Ord err, ReadConstraints src) =>
 442  Tupable (ReadPerm src err) where
 443   lhs@(ReadPerm da pa) <:> rhs@(ReadPerm db pb) =
 444     ReadPerm a (lhsAlt <|> rhsAlt)
 445     where
 446     lhsAlt = (<:> rhs) <$> pa
 447     rhsAlt = (lhs <:>) <$> pb
 448     a = consCont (,) <$> da <*> db
 449 instance Definable (ReadPerm src err) where
 450   define _n = id
 451
 452 -- * Utils
 453
 454 concatCont :: [(a->k)->k] -> ([a]->k)->k
 455 concatCont = List.foldr (consCont (:)) ($ [])
 456 {-# INLINE concatCont #-}
 457
 458 consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
 459 consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
 460 {-# INLINE consCont #-}
 461
 462 mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
 463 mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
 464 {-# INLINE mapCont #-}
 465
 466 -- | An adaptation of megaparsec's 'pToken',
 467 -- to handle 'attribute' properly.
 468 pTokenAttr ::
 469  forall e m src.
 470  ReadConstraints src =>
 471  QName ->
 472  Set.Set (P.ErrorItem (P.Token (ReadStream src))) ->
 473  P.ParsecT e (ReadStream src) m (src EscapedAttr)
 474 pTokenAttr an ps = P.ParsecT $ \st@(P.State s@(attrs,trees) o pst de) cok _ _ eerr ->
 475   case HM.lookup an attrs of
 476    Just av -> cok av (P.State (HM.delete an attrs, trees) (o+1) pst de) mempty
 477    Nothing -> eerr (P.TrivialError o us ps) st
 478     where
 479     us = case P.take1_ s of
 480      Nothing -> pure P.EndOfInput
 481      Just (t,_ts) -> (Just . P.Tokens . pure) t
 482 {-# INLINE pTokenAttr #-}
 483
 484 -- | An adaptation of megaparsec's 'pToken',
 485 -- to handle 'attributeMatch' properly.
 486 pTokenAttrNameClass ::
 487  forall e m src.
 488  ReadConstraints src =>
 489  NameClass ->
 490  Set.Set (P.ErrorItem (P.Token (ReadStream src))) ->
 491  P.ParsecT e (ReadStream src) m (QName, src EscapedAttr)
 492 pTokenAttrNameClass nc ps = P.ParsecT $ \st@(P.State s@(attrs,trees) o pst de) cok _ _ eerr ->
 493   case HM.toList attrs of
 494    a@(an,_av):_ | matchNameClass nc an -> cok a (P.State (HM.delete an attrs, trees) (o+1) pst de) mempty
 495    _ -> eerr (P.TrivialError o us ps) st
 496     where
 497     us = case P.take1_ s of
 498      Nothing -> pure P.EndOfInput
 499      Just (t,_ts) -> (Just . P.Tokens . pure) t
 500 {-# INLINE pTokenAttrNameClass #-}
 501
 502 -- | An adaptation of megaparsec's 'pToken',
 503 -- to handle 'pi' since 'NodePI' is ignored by 'P.take1_'.
 504 pTokenPI ::
 505  forall e m src.
 506  UnSource src =>
 507  PName ->
 508  Set.Set (P.ErrorItem (P.Token (ReadStream src))) ->
 509  P.ParsecT e (ReadStream src) m TL.Text
 510 pTokenPI n ps = P.ParsecT $ \st@(P.State s o pst de) cok _ _ eerr ->
 511   case take1 s of
 512    Nothing -> eerr (P.TrivialError o us ps) st
 513     where us = pure P.EndOfInput
 514    Just (c, cs)
 515     | Right (TS.Tree nod _) <- c
 516     , NodePI pn pv <- unSource nod
 517     , pn == n -> cok pv (P.State cs (o+1) pst de) mempty
 518     | otherwise -> eerr (P.TrivialError o us ps) st
 519       where
 520       us = case take1 s of
 521        Nothing -> pure P.EndOfInput
 522        Just (t,_ts) -> (Just . P.Tokens . pure) t
 523   where
 524   take1 = take1_ isIgnoredNode
 525     where
 526     isIgnoredNode = \case
 527      NodeComment{} -> True
 528      _ -> False
 529
 530 removeXMLNS ::
 531  HM.HashMap QName (src EscapedAttr) ->
 532  HM.HashMap QName (src EscapedAttr)
 533 removeXMLNS =
 534   HM.filterWithKey $ \an _av ->
 535     case an of
 536      QName "" "xmlns" -> False
 537      QName ns _l -> ns /= xmlns_xmlns
 538
 539 removeSpaces :: UnSource src => Trees src -> Trees src
 540 removeSpaces xs =
 541   if (`all` xs) $ \case
 542    TS.Tree nod _ts
 543     | NodeText (EscapedText et) <- unSource nod ->
 544     all (\case
 545      EscapedPlain t -> TL.all Char.isSpace t
 546      _ -> False) et
 547    _ -> True
 548   then (`Seq.filter` xs) $ \case
 549    TS.Tree nod _ts
 550     | NodeText EscapedText{} <- unSource nod -> False
 551    _ -> True
 552   else xs
 553
 554 -- | @readNested v xs@ returns a 'Read' parsing @xs@ entirely with @v@,
 555 -- updating 'P.stateOffset' and re-raising any exception.
 556 readNested ::
 557  Ord err =>
 558  ReadConstraints src =>
 559  Read src err f a ->
 560  ReadStream src ->
 561  Read src err f a
 562 readNested (Read p) stateInput = Read $ do
 563   st <- P.getParserState
 564   (st', res) <- lift $ P.runParserT' (p <* P.eof) st
 565    { P.stateInput
 566    , P.stateOffset = P.stateOffset st
 567    }
 568   P.updateParserState (\s -> s{P.stateOffset = P.stateOffset st'})
 569   case res of
 570    Right a -> return a
 571    Left (P.ParseErrorBundle errs _) ->
 572     case NonEmpty.head errs of
 573      P.TrivialError _o us es -> P.failure us es
 574      P.FancyError _o es -> P.fancyFailure es
 575
 576 -- * Class 'DecodeText'
 577 class DecodeText a where
 578   decodeText :: P.Parsec Void TL.Text a
 579 instance DecodeText String where
 580   decodeText = TL.unpack . fst <$>
 581     P.match (P.skipMany P.anySingle)
 582 instance DecodeText Text.Text where
 583   decodeText = TL.toStrict . fst <$>
 584     P.match (P.skipMany P.anySingle)
 585 instance DecodeText TL.Text where
 586   decodeText = fst <$>
 587     P.match (P.skipMany P.anySingle)
 588 instance DecodeText Bool where
 589   decodeText =
 590     False <$ (P.string "false" <|> P.string "0") <|>
 591     True  <$ (P.string "true"  <|> P.string "1")
 592 instance DecodeText Integer where
 593   decodeText = P.signed (return ()) P.decimal
 594 instance DecodeText Natural where
 595   decodeText = P.optional (P.char '+') *> P.decimal
 596
 597 -- * Megaparsec adaptations
 598 -- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'node's.
 599 parseErrorTextPretty ::
 600  P.ShowErrorComponent err =>
 601  P.ParseError (ReadStream FileSourced) err -> String
 602 parseErrorTextPretty (P.TrivialError o us ps) =
 603   if isNothing us && Set.null ps
 604   then "unknown parse error\n"
 605   else
 606     (case us of
 607      Just P.Tokens{} -> ""
 608      _ ->
 609       -- FIXME: this is not informative enough,
 610       -- but P.EndOfInput can not carry a source location,
 611       -- and retraversing the XML tree cannot be done
 612       -- exactly as the parser did only knowing the Offset,
 613       -- because of attributes being permutable.
 614       "node #"<>show o<>"\n"
 615     ) <>
 616     messageItemsPretty "unexpected "
 617      (showErrorItem px <$> maybeToList us) <>
 618     messageItemsPretty "expecting "
 619      (showErrorItem px <$> Set.toAscList ps)
 620   where px = Proxy :: Proxy s
 621 parseErrorTextPretty err = P.parseErrorTextPretty err
 622
 623 messageItemsPretty :: String -> [String] -> String
 624 messageItemsPretty prefix ts
 625  | null ts = ""
 626  | otherwise = prefix <> orList ts <> "\n"
 627
 628 orList :: IsString s => Monoid s => [s] -> s
 629 orList [] = mempty
 630 orList [x] = x
 631 orList [x,y] = x <> " or " <> y
 632 orList xs = mconcat (List.intersperse ", " (List.init xs)) <> ", or " <> List.last xs
 633
 634 showErrorItem ::
 635  (s ~ ReadStream (Sourced (FileSource Offset))) =>
 636  Proxy s -> P.ErrorItem (P.Token s) -> String
 637 showErrorItem px = \case
 638  P.Tokens ts   -> P.showTokens px ts
 639  P.Label label -> NonEmpty.toList label
 640  P.EndOfInput  -> "end-of-node"