{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Symantic.RNC.Validate where import Control.Applicative (Applicative(..), Alternative(..), optional) import Control.Monad (Monad(..)) import Data.Bool import Data.Either (Either(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..), all) import Data.Function (($), const, id) import Data.Functor (Functor(..), (<$>)) import Data.Maybe (Maybe(..), maybe) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.Tuple (snd) import Prelude (error) import qualified Data.Char as Char import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text.Lazy as TL import qualified Text.Megaparsec as P import Language.Symantic.XML (XMLs) import qualified Language.Symantic.XML as XML import qualified Language.Symantic.RNC.Sym as RNC validateXML :: Ord e => P.Parsec e XMLs a -> XMLs -> Either (P.ParseErrorBundle XMLs e) a validateXML p stateInput = snd $ P.runParser' p P.State { P.stateInput , P.stateOffset = 0 , P.statePosState = error "[BUG] validateXML: getSourcePos is not helpful here, please use annotated source locations" -- NOTE: reporting the node number is less helpful -- than the source text line and number where the node is; -- P.statePosState is only used by P.getSourcePos. } -- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'. p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a p_satisfyMaybe = (`P.token` Set.empty) instance Ord e => RNC.Sym_RNC (P.Parsec e XMLs) where {- none = P.label "none" $ P.eof -} namespace _p _n = pure () element n p = do ts <- P.token check $ Set.singleton $ P.Tokens $ pure expected XML.subParser p ts where expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts) | e == n = Just $ removePI $ removeXMLNS $ removeSpaces ts where removePI xs = (`Seq.filter` xs) $ \case XML.Tree (XML.unSourced -> XML.NodePI{}) _ts -> False _ -> True removeSpaces xs = if (`all` xs) $ \case XML.Tree (XML.unSourced -> XML.NodeText (XML.EscapedText et)) _ts -> all (\case XML.EscapedPlain t -> TL.all Char.isSpace t _ -> False) et _ -> True then (`Seq.filter` xs) $ \case XML.Tree (XML.unSourced -> XML.NodeText{}) _ts -> False _ -> True else xs removeXMLNS xs = let (attrs,rest) = (`Seq.spanl` xs) $ \case XML.Tree (XML.unSourced -> XML.NodeAttr{}) _ts -> True _ -> False in let attrs' = (`Seq.filter` attrs) $ \case XML.Tree (XML.unSourced -> XML.NodeAttr a) _ts -> case a of XML.QName "" "xmlns" -> False XML.QName ns _l -> ns /= XML.xmlns_xmlns _ -> True in attrs' <> rest check _t = Nothing attribute n p = do v <- P.token check $ Set.singleton $ P.Tokens $ pure expected XML.subParser p v where expected = XML.Tree0 (XML.notSourced $ XML.NodeAttr n) check (XML.Tree (XML.unSourced -> XML.NodeAttr k) v@(toList -> [XML.Tree0 (XML.unSourced -> XML.NodeText _v)])) | k == n = Just v check _t = Nothing any = P.label "any" $ p_satisfyMaybe $ const $ Just () anyElem ns p = P.label "anyElem" $ do (n,ts) <- P.token check $ Set.singleton $ P.Tokens $ pure expected XML.subParser (p $ XML.qNameLocal n) ts where expected = XML.Tree (XML.notSourced $ XML.NodeElem $ XML.QName ns $ XML.NCName "*") mempty check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts) | XML.qNameSpace e == ns = Just $ (e,ts) check _t = Nothing {- comment = do s <- P.getInput case Seq.viewl s of XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do P.setInput ts c <$ XML.setFilePosToNextNode t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex EmptyL -> P.failure Nothing ex where ex = Set.singleton $ P.Tokens $ pure expected expected = XML.Tree0 (XML.notSourced $ XML.NodeComment "") -} escapedText = do P.token check $ Set.singleton $ P.Tokens $ pure expected where expected = XML.Tree0 (XML.notSourced $ XML.NodeText $ XML.EscapedText mempty) check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Just t check _t = Nothing optional = P.optional option = P.option choice = P.choice try = P.try fail = P.label "fail" $ P.failure Nothing mempty instance Ord e => RNC.Sym_Permutation (P.ParsecT e XMLs m) where runPermutation (P value parser) = optional parser >>= f where -- NOTE: copy Control.Applicative.Permutations.runPermutation -- to replace the commented empty below so that P.TrivialError -- has the unexpected token. f Nothing = maybe {-empty-}(P.token (const Nothing) Set.empty) pure value f (Just p) = RNC.runPermutation p toPermutation p = P Nothing $ pure <$> p toPermutationWithDefault v p = P (Just v) $ pure <$> p -- | Unprivatized 'Control.Applicative.Permutations.Permutation' to fix 'runPermutation'. -- so that the 'P.TrivialError' has an unexpected token -- which is an 'XML.Node' containing a 'XML.FileSource' useful when reporting errors. data Permutation m a = P (Maybe a) (m (Permutation m a)) type instance RNC.Permutation (P.ParsecT e XMLs m) = Permutation (P.ParsecT e XMLs m) instance Functor m => Functor (Permutation m) where fmap f (P v p) = P (f <$> v) (fmap f <$> p) instance Alternative m => Applicative (Permutation m) where pure value = P (Just value) empty lhs@(P f v) <*> rhs@(P g w) = P (f <*> g) (lhsAlt <|> rhsAlt) where lhsAlt = (<*> rhs) <$> v rhsAlt = (lhs <*>) <$> w instance Ord e => RNC.Sym_Rule (P.ParsecT e XMLs m) where -- rule n p = P.dbg s p {-(p P. s)-} where s = Text.unpack n rule _n = id arg _n = pure ()