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 Data.String (String)
  21 import Prelude (error)
  22 import Text.Show (Show(..))
  23 import qualified Data.List as List
  24 import qualified Data.List.NonEmpty as NonEmpty
  25 import qualified Data.Sequence as Seq
  26 import qualified Text.Megaparsec as P
  27
  28 import Language.Symantic.XML.Document (XML, XMLs)
  29 import qualified Language.Symantic.XML.Document as XML
  30
  31 -- | Whether the given 'XML.Node' must be ignored by the parser.
  32 isIgnoredNode :: XML.Node -> Bool
  33 isIgnoredNode = \case
  34  XML.NodeComment{} -> True
  35  XML.NodePI{}      -> True
  36  XML.NodeCDATA{}   -> True
  37  _ -> False
  38
  39 instance P.Stream XMLs where
  40         type Token  XMLs = XML
  41         type Tokens XMLs = XMLs
  42         take1_ s =
  43                 case Seq.viewl s of
  44                  EmptyL -> Nothing
  45                  t@(XML.Tree XML.Sourced{XML.unSourced=n} _) :< ts
  46                   | isIgnoredNode n -> P.take1_ ts
  47                   | otherwise       -> Just (t, ts)
  48         takeN_ n s | n <= 0    = Just (mempty, s)
  49                    | null s    = Nothing
  50                    | otherwise =
  51                 let (ns,rs) = Seq.splitAt n s in
  52                 let (ko,ok) = Seq.partition (isIgnoredNode . XML.unSourced . XML.unTree) ns in
  53                 case P.takeN_ (Seq.length ko) rs of
  54                  Nothing -> Just (ok, rs)
  55                  Just (ns',rs') -> Just (ok<>ns', rs')
  56         tokensToChunk _s  = Seq.fromList
  57         chunkToTokens _s  = toList
  58         chunkLength _s    = Seq.length
  59         takeWhile_        = Seq.spanl
  60         -- | NOTE: unimplemented: useless since each 'XML.Node' is annotated with its 'FileSource'.
  61         reachOffset       = error "[BUG] P.Stream XMLs: reachOffset is not helpful, please use annotated source locations"
  62         -- | NOTE: useless since each 'XML.Node' is annotated with its 'FileSource'.
  63         reachOffsetNoLine = error "[BUG] P.Stream XMLs: reachOffsetNoLine is not helpful, please use annotated source locations"
  64         showTokens _s toks = List.intercalate ", " $ toList $ showTree <$> toks
  65                 where
  66                 showTree :: XML -> String
  67                 showTree (XML.Tree a _ts) =
  68                         showCell a $ \case
  69                          XML.NodeElem n     -> "element "<>show n<>""
  70                          XML.NodeAttr n     -> "attribute "<>show n<>""
  71                          XML.NodeText _t    -> "text"
  72                          XML.NodeComment _c -> "comment"
  73                          XML.NodePI n _t    -> "processing-instruction "<>show n<>""
  74                          XML.NodeCDATA _t   -> "cdata"
  75
  76                 showCell (XML.Sourced path@(XML.FileRange{XML.fileRange_file} NonEmpty.:| _) a) f =
  77                         if null fileRange_file
  78                         then f a
  79                         else f a <> foldMap (\p -> "\n in "<>show p) path
  80
  81 -- | @subParser p xs@ returns a parser parsing @xs@ entirely with @p@,
  82 -- updating 'P.stateOffset' and re-raising any exception.
  83 subParser :: Ord err => P.Parsec err XMLs a -> XMLs -> P.Parsec err XMLs a
  84 subParser p xs = do
  85         st <- P.getParserState
  86         let (st', res) = P.runParser' (p <* P.eof) st
  87                  { P.stateInput = xs
  88                  , P.stateOffset = P.stateOffset st
  89                  }
  90         P.updateParserState (\s -> s{P.stateOffset = P.stateOffset st'})
  91         case res of
  92          Right a -> return a
  93          Left (P.ParseErrorBundle errs _) ->
  94                 case NonEmpty.head errs of
  95                  P.TrivialError _o us es -> P.failure us es
  96                  P.FancyError _o es -> P.fancyFailure es