Language/Symantic/XML/Parser.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Language.Symantic.XML.Parser where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Control.Monad (Monad(..))
  10 import Data.Bool
  11 import Data.Either (Either(..))
  12 import Data.Foldable (Foldable(..))
  13 import Data.Function (($), (.))
  14 import Data.Functor ((<$>))
  15 import Data.Maybe (Maybe(..))
  16 import Data.Monoid (Monoid(..))
  17 import Data.Ord (Ord(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.Sequence (ViewL(..))
  20 import Prelude (error)
  21 import Text.Show (Show(..))
  22 import qualified Data.List as List
  23 import qualified Data.List.NonEmpty as NonEmpty
  24 import qualified Data.Sequence as Seq
  25 import qualified Text.Megaparsec as P
  26
  27 import Language.Symantic.XML.Document (XML, XMLs)
  28 import qualified Language.Symantic.XML.Document as XML
  29
  30 -- | Whether the given 'XML.Node' must be ignored by the parser.
  31 isIgnoredNode :: XML.Node -> Bool
  32 isIgnoredNode = \case
  33  XML.NodeComment{} -> True
  34  XML.NodePI{}      -> True
  35  XML.NodeCDATA{}   -> True
  36  _ -> False
  37
  38 instance Ord src => P.Stream (XMLs src) where
  39         type Token  (XMLs src) = XML src
  40         type Tokens (XMLs src) = XMLs src
  41         take1_ s =
  42                 case Seq.viewl s of
  43                  EmptyL -> Nothing
  44                  t@(XML.Tree XML.Sourced{XML.unSourced=n} _) :< ts
  45                   | isIgnoredNode n -> P.take1_ ts
  46                   | otherwise       -> Just (t, ts)
  47         takeN_ n s | n <= 0    = Just (mempty, s)
  48                    | null s    = Nothing
  49                    | otherwise =
  50                 let (ns,rs) = Seq.splitAt n s in
  51                 let (ko,ok) = Seq.partition (isIgnoredNode . XML.unSourced . XML.unTree) ns in
  52                 case P.takeN_ (Seq.length ko) rs of
  53                  Nothing -> Just (ok, rs)
  54                  Just (ns',rs') -> Just (ok<>ns', rs')
  55         tokensToChunk _s  = Seq.fromList
  56         chunkToTokens _s  = toList
  57         chunkLength _s    = Seq.length
  58         takeWhile_        = Seq.spanl
  59         -- | NOTE: unimplemented: useless since each 'XML.Node' is annotated with its 'FileSource'.
  60         reachOffset       = error "[BUG] P.Stream XMLs: reachOffset is not helpful, please use annotated source locations"
  61         -- | NOTE: useless since each 'XML.Node' is annotated with its 'FileSource'.
  62         reachOffsetNoLine = error "[BUG] P.Stream XMLs: reachOffsetNoLine is not helpful, please use annotated source locations"
  63         showTokens _s toks = List.intercalate ", " $ toList $ showTree <$> toks
  64                 where
  65                 showTree (XML.Tree (XML.Sourced _src a) _ts) =
  66                         case a of
  67                          XML.NodeElem n     -> "element "<>show n<>""
  68                          XML.NodeAttr n     -> "attribute "<>show n<>""
  69                          XML.NodeText _t    -> "text"
  70                          XML.NodeComment _c -> "comment"
  71                          XML.NodePI n _t    -> "processing-instruction "<>show n<>""
  72                          XML.NodeCDATA _t   -> "cdata"
  73
  74 -- | @subParser p xs@ returns a parser parsing @xs@ entirely with @p@,
  75 -- updating 'P.stateOffset' and re-raising any exception.
  76 subParser ::
  77  Ord err => Ord src =>
  78  P.Parsec err (XMLs src) a -> XMLs src -> P.Parsec err (XMLs src) a
  79 subParser p xs = do
  80         st <- P.getParserState
  81         let (st', res) = P.runParser' (p <* P.eof) st
  82                  { P.stateInput = xs
  83                  , P.stateOffset = P.stateOffset st
  84                  }
  85         P.updateParserState (\s -> s{P.stateOffset = P.stateOffset st'})
  86         case res of
  87          Right a -> return a
  88          Left (P.ParseErrorBundle errs _) ->
  89                 case NonEmpty.head errs of
  90                  P.TrivialError _o us es -> P.failure us es
  91                  P.FancyError _o es -> P.fancyFailure es