Language/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 Language.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 qualified Data.Char as Char
  25 import qualified Data.Sequence as Seq
  26 import qualified Data.Set as Set
  27 import qualified Data.Text.Lazy as TL
  28 import qualified Text.Megaparsec as P
  29
  30 import Language.Symantic.XML (XMLs)
  31 import qualified Language.Symantic.XML as XML
  32 import qualified Language.Symantic.RNC.Sym as RNC
  33
  34 validateXML ::
  35  Ord e => P.Parsec e XMLs a -> XMLs ->
  36  Either (P.ParseErrorBundle XMLs e) a
  37 validateXML p stateInput =
  38         snd $
  39         P.runParser' p P.State
  40          { P.stateInput
  41          , P.stateOffset = 0
  42          , P.statePosState = error "[BUG] validateXML: getSourcePos is not helpful here, please use annotated source locations"
  43           -- NOTE: reporting the node number is less helpful
  44                 -- than the source text line and number where the node is;
  45                 -- P.statePosState is only used by P.getSourcePos.
  46          }
  47
  48 -- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
  49 p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
  50 p_satisfyMaybe = (`P.token` Set.empty)
  51
  52 instance Ord e => RNC.Sym_RNC (P.Parsec e XMLs) where
  53         {-
  54         none = P.label "none" $ P.eof
  55         -}
  56         namespace _p _n = pure ()
  57         element n p = do
  58                 ts <- P.token check $ Set.singleton $ P.Tokens $ pure expected
  59                 XML.subParser p ts
  60                 where
  61                 expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty
  62                 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
  63                  | e == n
  64                  = Just $ removePI $ removeXMLNS $ removeSpaces ts
  65                         where
  66                         removePI xs =
  67                                 (`Seq.filter` xs) $ \case
  68                                          XML.Tree (XML.unSourced -> XML.NodePI{}) _ts -> False
  69                                          _ -> True
  70                         removeSpaces xs =
  71                                 if (`all` xs) $ \case
  72                                  XML.Tree (XML.unSourced -> XML.NodeText (XML.EscapedText et)) _ts ->
  73                                         all (\case
  74                                          XML.EscapedPlain t -> TL.all Char.isSpace t
  75                                          _ -> False) et
  76                                  _ -> True
  77                                 then (`Seq.filter` xs) $ \case
  78                                          XML.Tree (XML.unSourced -> XML.NodeText{}) _ts -> False
  79                                          _ -> True
  80                                 else xs
  81                         removeXMLNS xs =
  82                                 let (attrs,rest) = (`Seq.spanl` xs) $ \case
  83                                          XML.Tree (XML.unSourced -> XML.NodeAttr{}) _ts -> True
  84                                          _ -> False in
  85                                 let attrs' = (`Seq.filter` attrs) $ \case
  86                                          XML.Tree (XML.unSourced -> XML.NodeAttr a) _ts ->
  87                                                 case a of
  88                                                  XML.QName "" "xmlns" -> False
  89                                                  XML.QName ns _l -> ns /= XML.xmlns_xmlns
  90                                          _ -> True in
  91                                 attrs' <> rest
  92                 check _t = Nothing
  93         attribute n p = do
  94                 v <- P.token check $ Set.singleton $ P.Tokens $ pure expected
  95                 XML.subParser p v
  96                 where
  97                 expected = XML.Tree0 (XML.notSourced $ XML.NodeAttr n)
  98                 check (XML.Tree (XML.unSourced -> XML.NodeAttr k)
  99                       v@(toList -> [XML.Tree0 (XML.unSourced -> XML.NodeText _v)])) | k == n =
 100                         Just v
 101                 check _t = Nothing
 102         any  = P.label "any" $ p_satisfyMaybe $ const $ Just ()
 103         anyElem ns p = P.label "anyElem" $ do
 104                 (n,ts) <- P.token check $ Set.singleton $ P.Tokens $ pure expected
 105                 XML.subParser (p $ XML.qNameLocal n) ts
 106                 where
 107                 expected = XML.Tree (XML.notSourced $ XML.NodeElem $ XML.QName ns $ XML.NCName "*") mempty
 108                 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
 109                  | XML.qNameSpace e == ns
 110                  = Just $ (e,ts)
 111                 check _t = Nothing
 112         {-
 113         comment = do
 114                 s <- P.getInput
 115                 case Seq.viewl s of
 116                  XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do
 117                         P.setInput ts
 118                         c <$ XML.setFilePosToNextNode
 119                  t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
 120                  EmptyL -> P.failure Nothing ex
 121                 where
 122                 ex = Set.singleton $ P.Tokens $ pure expected
 123                 expected = XML.Tree0 (XML.notSourced $ XML.NodeComment "")
 124         -}
 125         escapedText = do
 126                 P.token check $ Set.singleton $ P.Tokens $ pure expected
 127                 where
 128                 expected = XML.Tree0 (XML.notSourced $ XML.NodeText $ XML.EscapedText mempty)
 129                 check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Just t
 130                 check _t = Nothing
 131         optional = P.optional
 132         option   = P.option
 133         choice   = P.choice
 134         try      = P.try
 135         fail     = P.label "fail" $ P.failure Nothing mempty
 136
 137 instance Ord e => RNC.Sym_Permutation (P.ParsecT e XMLs m) where
 138         runPermutation (P value parser) = optional parser >>= f
 139                 where
 140                 -- NOTE: copy Control.Applicative.Permutations.runPermutation
 141                 -- to replace the commented empty below so that P.TrivialError
 142                 -- has the unexpected token.
 143                 f  Nothing = maybe {-empty-}(P.token (const Nothing) Set.empty) pure value
 144                 f (Just p) = RNC.runPermutation p
 145         toPermutation p = P Nothing $ pure <$> p
 146         toPermutationWithDefault v p = P (Just v) $ pure <$> p
 147
 148 -- | Unprivatized 'Control.Applicative.Permutations.Permutation' to fix 'runPermutation'.
 149 -- so that the 'P.TrivialError' has an unexpected token
 150 -- which is an 'XML.Node' containing a 'XML.FileSource' useful when reporting errors.
 151 data Permutation m a = P (Maybe a) (m (Permutation m a))
 152 type instance RNC.Permutation (P.ParsecT e XMLs m) = Permutation (P.ParsecT e XMLs m)
 153 instance Functor m => Functor (Permutation m) where
 154         fmap f (P v p) = P (f <$> v) (fmap f <$> p)
 155 instance Alternative m => Applicative (Permutation m) where
 156         pure value = P (Just value) empty
 157         lhs@(P f v) <*> rhs@(P g w) = P (f <*> g) (lhsAlt <|> rhsAlt)
 158                 where
 159                 lhsAlt = (<*> rhs) <$> v
 160                 rhsAlt = (lhs <*>) <$> w
 161
 162 instance Ord e => RNC.Sym_Rule (P.ParsecT e XMLs m) where
 163         -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
 164         rule _n = id
 165         arg _n = pure ()