Validate.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module 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 Data.Sequence (Seq)
import qualified Data.Char as Char
import qualified Data.List.NonEmpty as NonEmpty
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 Symantic.XML (XMLs)
import qualified Symantic.XML as XML
import qualified Symantic.RNC.Sym as RNC

validateXML ::
 Ord e => P.Parsec e (XMLs src) a -> XMLs src ->
 Either (P.ParseErrorBundle (XMLs src) 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.
	 }

instance
 ( Ord err
 , Ord src
 , XML.NoSource src
 , P.Stream (Seq (XML.XML src))
 , P.Token  (Seq (XML.XML src)) ~ XML.Tree (XML.Sourced src XML.Node)
 ) => RNC.Sym_RNC (P.Parsec err (XMLs src)) 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
		p_XMLs 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
		p_XMLs 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.token (const $ Just ())  Set.empty
	anyElem ns p = P.label "anyElem" $ do
		(n,ts) <- P.token check $ Set.singleton $ P.Tokens $ pure expected
		p_XMLs (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

-- | @p_XMLs p xs@ returns a parser parsing @xs@ entirely with @p@,
-- updating 'P.stateOffset' and re-raising any exception.
p_XMLs ::
 Ord err => Ord src =>
 P.Stream (Seq (XML.XML src)) =>
 P.Parsec err (XMLs src) a -> XMLs src -> P.Parsec err (XMLs src) a
p_XMLs p stateInput = do
	st <- P.getParserState
	let (st', res) = P.runParser' (p <* P.eof) st
		 { P.stateInput  = stateInput
		 , P.stateOffset = P.stateOffset st
		 }
	P.updateParserState (\s -> s{P.stateOffset = P.stateOffset st'})
	case res of
	 Right a -> return a
	 Left (P.ParseErrorBundle errs _) ->
		case NonEmpty.head errs of
		 P.TrivialError _o us es -> P.failure us es
		 P.FancyError _o es -> P.fancyFailure es

-- | Whether the given 'XML.Node' must be ignored by the RNC parser.
isIgnoredNode :: XML.Node -> Bool
isIgnoredNode = \case
 XML.NodeComment{} -> True
 XML.NodePI{}      -> True
 XML.NodeCDATA{}   -> True
 _ -> False

instance
 ( Ord err
 , Ord src
 , P.Stream (Seq (XML.XML src))
 ) => RNC.Sym_Permutation (P.ParsecT err (XMLs src) m) where
	runPermutation (Perm 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 = Perm Nothing $ pure <$> p
	toPermutationWithDefault v p = Perm (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 Perm m a = Perm (Maybe a) (m (Perm m a))
type instance RNC.Permutation (P.ParsecT err (XMLs src) m) = Perm (P.ParsecT err (XMLs src) m)
instance Functor m => Functor (Perm m) where
	fmap f (Perm v p) = Perm (f <$> v) (fmap f <$> p)
instance Alternative m => Applicative (Perm m) where
	pure value = Perm (Just value) empty
	lhs@(Perm f v) <*> rhs@(Perm g w) = Perm (f <*> g) (lhsAlt <|> rhsAlt)
		where
		lhsAlt = (<*> rhs) <$> v
		rhsAlt = (lhs <*>) <$> w

instance
 ( Ord err
 , Ord src
 , P.Stream (Seq (XML.XML src))
 ) => RNC.Sym_Rule (P.ParsecT err (XMLs src) m) where
	-- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
	rule _n = id
	arg _n = pure ()