Symantic/RNC/Validate.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# LANGUAGE ViewPatterns #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Symantic.RNC.Validate where
   9
  10 import Control.Applicative (Applicative(..), Alternative(..), optional)
  11 import Control.Monad (Monad(..))
  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)
  17 import Data.Functor (Functor(..), (<$>))
  18 import Data.Maybe (Maybe(..), maybe)
  19 import Data.Monoid (Monoid(..))
  20 import Data.Ord (Ord(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.Tuple (snd)
  23 import Prelude (error)
  24 import Data.Sequence (Seq)
  25 import qualified Data.Char as Char
  26 import qualified Data.List.NonEmpty as NonEmpty
  27 import qualified Data.Sequence as Seq
  28 import qualified Data.Set as Set
  29 import qualified Data.Text.Lazy as TL
  30 import qualified Text.Megaparsec as P
  31
  32 import Symantic.XML (XMLs)
  33 import qualified Symantic.XML as XML
  34 import qualified Symantic.RNC.Sym as RNC
  35
  36 validateXML ::
  37  Ord e => P.Parsec e (XMLs src) a -> XMLs src ->
  38  Either (P.ParseErrorBundle (XMLs src) e) a
  39 validateXML p stateInput =
  40         snd $
  41         P.runParser' p P.State
  42          { P.stateInput
  43          , P.stateOffset = 0
  44          , P.statePosState = error "[BUG] validateXML: getSourcePos is not helpful here, please use annotated source locations"
  45           -- NOTE: reporting the node number is less helpful
  46                 -- than the source text line and number where the node is;
  47                 -- P.statePosState is only used by P.getSourcePos.
  48          }
  49
  50 instance
  51  ( Ord err
  52  , Ord src
  53  , XML.NoSource src
  54  , P.Stream (Seq (XML.XML src))
  55  , P.Token  (Seq (XML.XML src)) ~ XML.Tree (XML.Sourced src XML.Node)
  56  ) => RNC.Sym_RNC (P.Parsec err (XMLs src)) where
  57         {-
  58         none = P.label "none" $ P.eof
  59         -}
  60         namespace _p _n = pure ()
  61         element n p = do
  62                 ts <- P.token check $ Set.singleton $ P.Tokens $ pure expected
  63                 p_XMLs p ts
  64                 where
  65                 expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty
  66                 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
  67                  | e == n
  68                  = Just $ removePI $ removeXMLNS $ removeSpaces ts
  69                         where
  70                         removePI xs =
  71                                 (`Seq.filter` xs) $ \case
  72                                          XML.Tree (XML.unSourced -> XML.NodePI{}) _ts -> False
  73                                          _ -> True
  74                         removeSpaces xs =
  75                                 if (`all` xs) $ \case
  76                                  XML.Tree (XML.unSourced -> XML.NodeText (XML.EscapedText et)) _ts ->
  77                                         all (\case
  78                                          XML.EscapedPlain t -> TL.all Char.isSpace t
  79                                          _ -> False) et
  80                                  _ -> True
  81                                 then (`Seq.filter` xs) $ \case
  82                                          XML.Tree (XML.unSourced -> XML.NodeText{}) _ts -> False
  83                                          _ -> True
  84                                 else xs
  85                         removeXMLNS xs =
  86                                 let (attrs,rest) = (`Seq.spanl` xs) $ \case
  87                                          XML.Tree (XML.unSourced -> XML.NodeAttr{}) _ts -> True
  88                                          _ -> False in
  89                                 let attrs' = (`Seq.filter` attrs) $ \case
  90                                          XML.Tree (XML.unSourced -> XML.NodeAttr a) _ts ->
  91                                                 case a of
  92                                                  XML.QName "" "xmlns" -> False
  93                                                  XML.QName ns _l -> ns /= XML.xmlns_xmlns
  94                                          _ -> True in
  95                                 attrs' <> rest
  96                 check _t = Nothing
  97         attribute n p = do
  98                 v <- P.token check $ Set.singleton $ P.Tokens $ pure expected
  99                 p_XMLs p v
 100                 where
 101                 expected = XML.Tree0 (XML.notSourced $ XML.NodeAttr n)
 102                 check (XML.Tree (XML.unSourced -> XML.NodeAttr k)
 103                       v@(toList -> [XML.Tree0 (XML.unSourced -> XML.NodeText _v)])) | k == n =
 104                         Just v
 105                 check _t = Nothing
 106         any  = P.label "any" $
 107                 P.token (const $ Just ())  Set.empty
 108         anyElem ns p = P.label "anyElem" $ do
 109                 (n,ts) <- P.token check $ Set.singleton $ P.Tokens $ pure expected
 110                 p_XMLs (p $ XML.qNameLocal n) ts
 111                 where
 112                 expected = XML.Tree (XML.notSourced $ XML.NodeElem $ XML.QName ns $ XML.NCName "*") mempty
 113                 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
 114                  | XML.qNameSpace e == ns
 115                  = Just $ (e,ts)
 116                 check _t = Nothing
 117         {-
 118         comment = do
 119                 s <- P.getInput
 120                 case Seq.viewl s of
 121                  XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do
 122                         P.setInput ts
 123                         c <$ XML.setFilePosToNextNode
 124                  t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
 125                  EmptyL -> P.failure Nothing ex
 126                 where
 127                 ex = Set.singleton $ P.Tokens $ pure expected
 128                 expected = XML.Tree0 (XML.notSourced $ XML.NodeComment "")
 129         -}
 130         escapedText = do
 131                 P.token check $ Set.singleton $ P.Tokens $ pure expected
 132                 where
 133                 expected = XML.Tree0 (XML.notSourced $ XML.NodeText $ XML.EscapedText mempty)
 134                 check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Just t
 135                 check _t = Nothing
 136         optional = P.optional
 137         option   = P.option
 138         choice   = P.choice
 139         try      = P.try
 140         fail     = P.label "fail" $ P.failure Nothing mempty
 141
 142 -- | @p_XMLs p xs@ returns a parser parsing @xs@ entirely with @p@,
 143 -- updating 'P.stateOffset' and re-raising any exception.
 144 p_XMLs ::
 145  Ord err => Ord src =>
 146  P.Stream (Seq (XML.XML src)) =>
 147  P.Parsec err (XMLs src) a -> XMLs src -> P.Parsec err (XMLs src) a
 148 p_XMLs p stateInput = do
 149         st <- P.getParserState
 150         let (st', res) = P.runParser' (p <* P.eof) st
 151                  { P.stateInput  = stateInput
 152                  , P.stateOffset = P.stateOffset st
 153                  }
 154         P.updateParserState (\s -> s{P.stateOffset = P.stateOffset st'})
 155         case res of
 156          Right a -> return a
 157          Left (P.ParseErrorBundle errs _) ->
 158                 case NonEmpty.head errs of
 159                  P.TrivialError _o us es -> P.failure us es
 160                  P.FancyError _o es -> P.fancyFailure es
 161
 162 -- | Whether the given 'XML.Node' must be ignored by the RNC parser.
 163 isIgnoredNode :: XML.Node -> Bool
 164 isIgnoredNode = \case
 165  XML.NodeComment{} -> True
 166  XML.NodePI{}      -> True
 167  XML.NodeCDATA{}   -> True
 168  _ -> False
 169
 170 instance
 171  ( Ord err
 172  , Ord src
 173  , P.Stream (Seq (XML.XML src))
 174  ) => RNC.Sym_Permutation (P.ParsecT err (XMLs src) m) where
 175         runPermutation (Perm value parser) = optional parser >>= f
 176                 where
 177                 -- NOTE: copy Control.Applicative.Permutations.runPermutation
 178                 -- to replace the commented empty below so that P.TrivialError
 179                 -- has the unexpected token.
 180                 f  Nothing = maybe {-empty-}(P.token (const Nothing) Set.empty) pure value
 181                 f (Just p) = RNC.runPermutation p
 182         toPermutation p = Perm Nothing $ pure <$> p
 183         toPermutationWithDefault v p = Perm (Just v) $ pure <$> p
 184
 185 -- | Unprivatized 'Control.Applicative.Permutations.Permutation' to fix 'runPermutation'.
 186 -- so that the 'P.TrivialError' has an unexpected token
 187 -- which is an 'XML.Node' containing a 'XML.FileSource' useful when reporting errors.
 188 data Perm m a = Perm (Maybe a) (m (Perm m a))
 189 type instance RNC.Permutation (P.ParsecT err (XMLs src) m) = Perm (P.ParsecT err (XMLs src) m)
 190 instance Functor m => Functor (Perm m) where
 191         fmap f (Perm v p) = Perm (f <$> v) (fmap f <$> p)
 192 instance Alternative m => Applicative (Perm m) where
 193         pure value = Perm (Just value) empty
 194         lhs@(Perm f v) <*> rhs@(Perm g w) = Perm (f <*> g) (lhsAlt <|> rhsAlt)
 195                 where
 196                 lhsAlt = (<*> rhs) <$> v
 197                 rhsAlt = (lhs <*>) <$> w
 198
 199 instance
 200  ( Ord err
 201  , Ord src
 202  , P.Stream (Seq (XML.XML src))
 203  ) => RNC.Sym_Rule (P.ParsecT err (XMLs src) m) where
 204         -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
 205         rule _n = id
 206         arg _n = pure ()