test/RNC/Parser.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module RNC.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 Symantic.XML.Document (XML, XMLs)
  28 import qualified Symantic.XML.Document as XML
  29 import qualified Symantic.RNC.Validate as RNC
  30
  31 instance Ord src => P.Stream (XMLs src) where
  32         type Token  (XMLs src) = XML src
  33         type Tokens (XMLs src) = XMLs src
  34         take1_ s =
  35                 case Seq.viewl s of
  36                  EmptyL -> Nothing
  37                  t@(XML.Tree XML.Sourced{XML.unSourced=n} _) :< ts
  38                   | RNC.isIgnoredNode n -> P.take1_ ts
  39                   | otherwise       -> Just (t, ts)
  40         takeN_ n s | n <= 0    = Just (mempty, s)
  41                    | null s    = Nothing
  42                    | otherwise =
  43                 let (ns,rs) = Seq.splitAt n s in
  44                 let (ko,ok) = Seq.partition (RNC.isIgnoredNode . XML.unSourced . XML.unTree) ns in
  45                 case P.takeN_ (Seq.length ko) rs of
  46                  Nothing -> Just (ok, rs)
  47                  Just (ns',rs') -> Just (ok<>ns', rs')
  48         tokensToChunk _s  = Seq.fromList
  49         chunkToTokens _s  = toList
  50         chunkLength _s    = Seq.length
  51         takeWhile_        = Seq.spanl
  52         -- | NOTE: unimplemented: useless since each 'XML.Node' is annotated with its 'FileSource'.
  53         reachOffset       = error "[BUG] P.Stream XMLs: reachOffset is not helpful, please use annotated source locations"
  54         -- | NOTE: useless since each 'XML.Node' is annotated with its 'FileSource'.
  55         reachOffsetNoLine = error "[BUG] P.Stream XMLs: reachOffsetNoLine is not helpful, please use annotated source locations"
  56         showTokens _s toks = List.intercalate ", " $ toList $ showTree <$> toks
  57                 where
  58                 showTree (XML.Tree (XML.Sourced _src a) _ts) =
  59                         case a of
  60                          XML.NodeElem n     -> "element "<>show n<>""
  61                          XML.NodeAttr n     -> "attribute "<>show n<>""
  62                          XML.NodeText _t    -> "text"
  63                          XML.NodeComment _c -> "comment"
  64                          XML.NodePI n _t    -> "processing-instruction "<>show n<>""
  65                          XML.NodeCDATA _t   -> "cdata"