symantic-xml 1.0.0.20190223 → 2.0.0.20200523

raw patch · 34 files changed

+3704/−2706 lines, 34 filesdep +symantic-basedep −data-default-classdep −filepathdep −safedep ~megaparsecPVP ok

version bump matches the API change (PVP)

Dependencies added: symantic-base

Dependencies removed: data-default-class, filepath, safe

Dependency ranges changed: megaparsec

API changes (from Hackage documentation)

Files

• Symantic/RNC.hs +0/−14
• Symantic/RNC/Sym.hs +0/−100
• Symantic/RNC/Validate.hs +0/−206
• Symantic/RNC/Write.hs +0/−165
• Symantic/RNC/Write/Fixity.hs +0/−110
• Symantic/RNC/Write/Namespaces.hs +0/−127
• Symantic/XML.hs +0/−11
• Symantic/XML/Document.hs +0/−432
• Symantic/XML/Read.hs +0/−478
• Symantic/XML/Read/Parser.hs +0/−240
• Symantic/XML/Write.hs +0/−274
• src/Symantic/XML.hs +11/−0
• src/Symantic/XML/Language.hs +76/−0
• src/Symantic/XML/Namespace.hs +180/−0
• src/Symantic/XML/Read.hs +640/−0
• src/Symantic/XML/RelaxNG.hs +7/−0
• src/Symantic/XML/RelaxNG/Compact/Write.hs +429/−0
• src/Symantic/XML/RelaxNG/Language.hs +119/−0
• src/Symantic/XML/Text.hs +164/−0
• src/Symantic/XML/Tree.hs +11/−0
• src/Symantic/XML/Tree/Data.hs +197/−0
• src/Symantic/XML/Tree/Read.hs +628/−0
• src/Symantic/XML/Tree/Source.hs +142/−0
• src/Symantic/XML/Tree/Write.hs +199/−0
• src/Symantic/XML/Write.hs +334/−0
• stack.yaml +3/−8
• stack.yaml.lock +12/−0
• symantic-xml.cabal +43/−42
• test/Golden.hs +80/−79
• test/Main.hs +7/−5
• test/RNC/Commoning.hs +0/−350
• test/RNC/Parser.hs +0/−65
• test/RelaxNG/Commoning.hs +375/−0
• test/RelaxNG/Whatever.hs +47/−0

@@ -1,14 +0,0 @@-module Symantic.RNC- ( module Symantic.RNC.Sym- , module Symantic.RNC.Validate- , module Symantic.RNC.Write- , Functor(..)- , Applicative(..)- , Alternative((<|>))- ) where-import Data.Functor-import Control.Applicative--import Symantic.RNC.Sym-import Symantic.RNC.Write-import Symantic.RNC.Validate

@@ -1,100 +0,0 @@-{-# LANGUAGE TypeFamilyDependencies #-}-module Symantic.RNC.Sym- ( module Symantic.RNC.Sym- , Functor(..), (<$>)- , Applicative(..)- , Alternative(..)- ) where--import Control.Applicative (Applicative(..), Alternative(..))-import Data.Eq (Eq)-import Data.Function ((.), id)-import Data.Functor (Functor(..), (<$>))-import Data.Maybe (Maybe(..))-import Data.Sequence (Seq)-import Data.String (String)-import Text.Show (Show(..))-import qualified Data.Sequence as Seq-import qualified Data.Text.Lazy as TL--import qualified Symantic.XML as XML---- * Class 'Sym_RNC'-class- ( Applicative repr- , Alternative repr- , Sym_Rule repr- , Sym_Permutation repr- ) => Sym_RNC repr where-	namespace   :: Maybe XML.NCName -> XML.Namespace -> repr ()-	element     :: XML.QName -> repr a -> repr a-	attribute   :: XML.QName -> repr a -> repr a-	any         :: repr ()-	anyElem     :: XML.Namespace -> (XML.NCName -> repr a) -> repr a-	escapedText :: repr XML.EscapedText-	text        :: repr TL.Text-	text = XML.unescapeText <$> escapedText-	fail        :: repr a-	try         :: repr a -> repr a-	option      :: a -> repr a -> repr a-	optional    :: repr a -> repr (Maybe a)-	choice      :: [repr a] -> repr a-	intermany   :: [repr a] -> repr [a]-	intermany = many . choice . (try <$>)-	manySeq :: repr a -> repr (Seq a)-	manySeq r = Seq.fromList <$> many r-	someSeq :: repr a -> repr (Seq a)-	someSeq r = Seq.fromList <$> some r---- * Class 'Sym_Rule'-class Sym_Rule repr where-	rule :: Show a => String -> repr a -> repr a-	rule _n = id-	arg :: String -> repr ()---- ** Type 'RuleMode'-data RuleMode- =   RuleMode_Body -- ^ Request to generate the body of the rule.- |   RuleMode_Ref  -- ^ Request to generate a reference to the rule.- |   RuleMode_Def  -- ^ Request to generate a definition of the rule.- deriving (Eq, Show)---- * Class 'Sym_Permutation'-class (Alternative repr, Applicative (Permutation repr)) => Sym_Permutation repr where-	runPermutation :: Permutation repr a -> repr a-	toPermutation :: repr a -> Permutation repr a-	toPermutationWithDefault :: a -> repr a -> Permutation repr a-	-	(<$$>) :: (a -> b) -> repr a -> Permutation repr b-	(<$?>) :: (a -> b) -> (a, repr a) -> Permutation repr b-	(<$*>) :: ([a] -> b) -> repr a -> Permutation repr b-	(<$:>) :: (Seq a -> b) -> repr a -> Permutation repr b-	infixl 2 <$$>, <$?>, <$*>, <$:>-	{-# INLINE (<$$>) #-}-	{-# INLINE (<$?>) #-}-	{-# INLINE (<$*>) #-}-	{-# INLINE (<$:>) #-}-	-	(<||>) :: Permutation repr (a -> b) -> repr a -> Permutation repr b-	(<|?>) :: Permutation repr (a -> b) -> (a, repr a) -> Permutation repr b-	(<|*>) :: Permutation repr ([a] -> b) -> repr a -> Permutation repr b-	(<|:>) :: Permutation repr (Seq a -> b) -> repr a -> Permutation repr b-	infixl 1 <||>, <|?>, <|*>, <|:>-	{-# INLINE (<||>) #-}-	{-# INLINE (<|?>) #-}-	{-# INLINE (<|*>) #-}-	{-# INLINE (<|:>) #-}-	-	f <$$> x = f <$> toPermutation x-	f <$?> (d,x) = f <$> toPermutationWithDefault d x-	f <$*> x = f <$> toPermutationWithDefault [] (some x)-	f <$:> x = f . Seq.fromList <$> toPermutationWithDefault [] (some x)-	-	f <||> x = f <*> toPermutation x-	f <|?> (d,x) = f <*> toPermutationWithDefault d x-	f <|*> x = f <*> toPermutationWithDefault [] (some x)-	f <|:> x = f <*> toPermutationWithDefault Seq.empty (Seq.fromList <$> some x)---- ** Type family 'Permutation'--- | Type of permutations, depending on the representation.-type family Permutation (repr:: * -> *) = (r :: * -> *) | r -> repr

@@ -1,206 +0,0 @@-{-# 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 ()

@@ -1,165 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-module Symantic.RNC.Write- ( module Symantic.RNC.Write- , module Symantic.RNC.Write.Fixity- , module Symantic.RNC.Write.Namespaces- ) where--import Control.Applicative (Applicative(..), Alternative(..))-import Control.Monad-import Data.Bool-import Data.Function (($), (.), id)-import Data.Functor ((<$>))-import Data.Functor.Compose (Compose(..))-import Data.Semigroup (Semigroup(..))-import Data.String (IsString(..))-import Text.Show (Show(..))-import qualified Data.HashMap.Strict as HM-import qualified Data.List as List-import qualified Data.Text.Lazy as TL--- import qualified Data.Text.Lazy.Builder as TLB--import Symantic.RNC.Sym-import Symantic.RNC.Write.Fixity-import Symantic.RNC.Write.Namespaces-import qualified Symantic.XML as XML---- | Get textual rendition of given 'RuleWriter'.-writeRNC :: [NS a] -> [Writer a] -> TL.Text-writeRNC ns ws =-	let namespaces@XML.Namespaces{..} = runNS ns in-	TL.unlines $ List.concat-	 [ [ "default namespace = \""<>XML.unNamespace namespaces_default<>"\""-		 | not $ TL.null $ XML.unNamespace namespaces_default-		 ]-	 , [ "namespace "<>p<>" = \""<>n<>"\""-		 | (XML.Namespace n, XML.NCName p) <- HM.toList namespaces_prefixes-		 ]-	 , runWriter namespaces <$> ws-	 ]---- * Type 'Writer'-newtype Writer a- = Writer { unWriter :: XML.Namespaces XML.NCName ->-                        RuleMode ->-                        (Infix, Side) ->-                        Pair -> TL.Text }---- | Get textual rendition of given 'Writer'.-runWriter :: XML.Namespaces XML.NCName -> Writer a -> TL.Text-runWriter ns (Writer w) =-	w ns RuleMode_Def (infixN0, SideL) pairParen--coerceWriter :: Writer a -> Writer b-coerceWriter = Writer . unWriter-{-# INLINE coerceWriter #-}--{--instance Show (Writer a) where-	show = TL.unpack . runWriter--}-instance Functor Writer where-	fmap _f (Writer x) = Writer x-instance Applicative Writer where-	pure _ = writeText $ "\"\""-	Writer f <*> Writer x = Writer $ \ns rm po pp ->-		pairIfNeeded pp po op $-		TL.intercalate ", " $-		List.filter (not . TL.null) $-		 [ f ns rm (op, SideL) pairParen-		 , x ns rm (op, SideR) pairParen ]-		where op = infixB SideL 2-instance Alternative Writer where-	empty = writeText "empty"-	Writer wl <|> Writer wr = Writer $ \ns rm po pp ->-		pairIfNeeded pp po op $-		wl ns rm (op, SideL) pairParen <> " | " <> wr ns rm (op, SideR) pairParen-		where op = infixB SideL 2-	many (Writer w) = Writer $ \ns rm po pp ->-		pairIfNeeded pp po op $-		w ns rm (op, SideL) pairParen <> "*"-		where op = infixN 9-	some (Writer w) = Writer $ \ns rm po pp ->-		pairIfNeeded pp po op $-		w ns rm (op, SideL) pairParen <> "+"-		where op = infixN 9-instance Sym_Rule Writer where-	rule n wr@(Writer w) = Writer $ \ns rm po pp ->-		case rm of-		 RuleMode_Ref ->-			pairIfNeeded pp po op $-			fromString n-			where op = infixN 10-		 RuleMode_Body -> w ns RuleMode_Ref po pp-		 RuleMode_Def ->-			TL.intercalate " "-			 [ fromString n-			 , "="-			 , unWriter (rule n wr) ns RuleMode_Body (infixN0, SideR) pp-			 ]-	arg n =-		Writer $ \_ns rm _po _pp ->-			case rm of-			 RuleMode_Ref  -> fromString n-			 RuleMode_Body -> ""-			 RuleMode_Def  -> ""-type instance Permutation Writer = Compose [] Writer-instance Sym_Permutation Writer where-	runPermutation (Compose []) = writeText "empty"-	runPermutation (Compose [Writer w]) = Writer w-	runPermutation (Compose l@(_:_)) = Writer $ \ns rm po pp ->-		pairIfNeeded pp po op $-		TL.intercalate " & " $-		List.filter (not . TL.null) $-		(unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen-		where op = infixB SideL 1-	toPermutation = Compose . pure-	toPermutationWithDefault _ = Compose . pure-instance Sym_RNC Writer where-	namespace _p _n = writeText ""-	element n (Writer w) = Writer $ \ns rm po pp ->-		pairIfNeeded pp po op $-		"element "<>TL.pack (show $ XML.prefixifyQName ns n)-		 <>" "<>w ns rm (op,SideR) pairBrace-		where op = infixN 10-	anyElem (XML.Namespace n) f = Writer $ \ns rm po pp ->-		pairIfNeeded pp po op $-		(if TL.null n then "" else n<>":") <>-		"* "<>w ns rm (op,SideR) pairBrace-		where-		op = infixN 0-		Writer w = f ""-	attribute n (Writer w) = Writer $ \ns rm po pp ->-		pairIfNeeded pp po op $-		"attribute "<>TL.pack (show $ XML.prefixifyQName ns n)-		 <>" "<>w ns rm (op,SideR) pairBrace-		where op = infixN 10-	try         = id-	fail        = writeText "fail"-	escapedText = writeText "text"-	text        = writeText "text"-	any         = writeText "any"-	choice []   = writeText "empty"-	choice [w]  = w-	choice l@(_:_) = Writer $ \ns rm po pp ->-		pairIfNeeded pp po op $-		TL.intercalate " | " $-		(unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen-		where op = infixB SideL 2-	option _x (Writer w) = Writer $ \ns rm po pp ->-		pairIfNeeded pp po op $-		w ns rm (op, SideL) pairParen <> "?"-		where op = infixN 9-	optional (Writer w) = Writer $ \ns rm po pp ->-		pairIfNeeded pp po op $-		w ns rm (op, SideL) pairParen <> "?"-		where op = infixN 9-	manySeq = coerceWriter . many-	someSeq = coerceWriter . some---- | 'Writer' returns a constant rendition.-writeText :: TL.Text -> Writer a-writeText t = Writer $ \_ns _rm po pp ->-	pairIfNeeded pp po op t-	where op = infixN 10

@@ -1,110 +0,0 @@-module Symantic.RNC.Write.Fixity where--import Data.Bool-import Data.Eq (Eq(..))-import Data.Function ((.))-import Data.Int (Int)-import Data.Maybe (Maybe(..))-import Data.Ord (Ord(..))-import Data.Semigroup-import Data.String (String, IsString(..))-import Text.Show (Show(..))---- * Type 'Fixity'-data Fixity- =   Fixity1 Unifix- |   Fixity2 Infix- deriving (Eq, Show)---- ** Type 'Unifix'-data Unifix- =   Prefix  { unifix_precedence :: Precedence }- |   Postfix { unifix_precedence :: Precedence }- deriving (Eq, Show)---- ** Type 'Infix'-data Infix- =   Infix- {   infix_associativity :: Maybe Associativity- ,   infix_precedence    :: Precedence- } deriving (Eq, Show)--infixL :: Precedence -> Infix-infixL = Infix (Just AssocL)--infixR :: Precedence -> Infix-infixR = Infix (Just AssocR)--infixB :: Side -> Precedence -> Infix-infixB = Infix . Just . AssocB--infixN :: Precedence -> Infix-infixN = Infix Nothing--infixN0 :: Infix-infixN0 = infixN 0--infixN5 :: Infix-infixN5 = infixN 5---- | Given 'Precedence' and 'Associativity' of its parent operator,--- and the operand 'Side' it is in,--- return whether an 'Infix' operator--- needs to be enclosed by a 'Pair'.-isPairNeeded :: (Infix, Side) -> Infix -> Bool-isPairNeeded (po, lr) op =-	infix_precedence op < infix_precedence po-	|| infix_precedence op == infix_precedence po-	&& not associate-	where-	associate =-		case (lr, infix_associativity po) of-		 (_, Just AssocB{})   -> True-		 (SideL, Just AssocL) -> True-		 (SideR, Just AssocR) -> True-		 _ -> False---- | If 'isPairNeeded' is 'True',--- enclose the given 'IsString' by given 'Pair',--- otherwise returns the same 'IsString'.-pairIfNeeded ::- Semigroup s => IsString s =>- Pair -> (Infix, Side) -> Infix ->- s -> s-pairIfNeeded (o,c) po op s =-	if isPairNeeded po op-	then fromString o <> s <> fromString c-	else s---- * Type 'Precedence'-type Precedence = Int---- ** Class 'PrecedenceOf'-class PrecedenceOf a where-	precedence :: a -> Precedence-instance PrecedenceOf Fixity where-	precedence (Fixity1 uni) = precedence uni-	precedence (Fixity2 inf) = precedence inf-instance PrecedenceOf Unifix where-	precedence = unifix_precedence-instance PrecedenceOf Infix where-	precedence = infix_precedence---- * Type 'Associativity'-data Associativity- =   AssocL      -- ^ Associate to the left:  @a ¹ b ² c == (a ¹ b) ² c@- |   AssocR      -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@- |   AssocB Side -- ^ Associate to both sides, but to 'Side' when reading.- deriving (Eq, Show)---- ** Type 'Side'-data Side- =   SideL -- ^ Left- |   SideR -- ^ Right- deriving (Eq, Show)---- ** Type 'Pair'-type Pair = (String, String)-pairParen, pairBrace :: Pair-pairParen = ("(",")")-pairBrace = ("{","}")

@@ -1,127 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-module Symantic.RNC.Write.Namespaces where--import Control.Applicative (Applicative(..), Alternative(..), (<$>))-import Control.Monad (Monad(..), forM, sequence)-import Data.Default.Class (Default(..))-import Data.Function (($), (.), id)-import Data.Functor (Functor(..))-import Data.Maybe (Maybe(..), maybe, isNothing)-import Data.Monoid (Monoid(..))-import Data.Semigroup (Semigroup(..))-import Text.Show (Show(..))-import Data.String (String)-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import qualified Control.Monad.Trans.State.Strict as S--import qualified Symantic.XML as XML-import Symantic.RNC.Sym---- | Collect 'XML.Namespace's used and get them a dedicated prefix.-runNS :: forall a. [NS a] -> XML.Namespaces XML.NCName-runNS ns =-	namespaces-	 { XML.namespaces_prefixes =-		(`S.evalState` HS.empty) $-			let prefixesByNamespace =-				HM.delete "" $ -- NOTE: no prefix when there is no namespace.-				HM.update -- NOTE: no prefix when this is the default namespace.-				 (\p -> if isNothing p then Nothing else Just p)-				 (XML.namespaces_default namespaces) $-				XML.namespaces_prefixes namespaces in-			forM prefixesByNamespace $ \mp -> do-				usedPrefixes <- S.get-				let fp = maybe-					 (XML.freshNCName usedPrefixes)-					 (XML.freshifyNCName usedPrefixes)-					 mp-				S.modify' $ HS.insert fp-				return fp-	 }-	where-	namespaces :: XML.Namespaces (Maybe XML.NCName)-	namespaces = mconcat $ (`S.evalState` def) $ sequence $ unNS <$> ns--coerceNS :: NS a -> NS b-coerceNS = NS . unNS-{-# INLINE coerceNS #-}---- * Type 'NS'--- | Collect 'XML.Namespaces's and any prefixes associated with it,--- using 'State' to avoid recurring into already visited 'rule's.-newtype NS a = NS { unNS :: S.State State (XML.Namespaces (Maybe XML.NCName)) }---- ** Type 'State'-newtype State = State- { state_rules :: {-!-}(HS.HashSet String)- } deriving (Show)-instance Default State where-	def = State-	 { state_rules = HS.empty-	 }--instance Show (NS a) where-	showsPrec p = showsPrec p . runNS . pure-instance Semigroup (NS a) where-	NS x <> NS y = NS $ (<>) <$> x <*> y-instance Monoid (NS a) where-	mempty  = NS $ return mempty-	mappend = (<>)-instance Functor NS where-	fmap _f = coerceNS-instance Applicative NS where-	pure _ = mempty-	NS f <*> NS x = NS f <> NS x-	NS f <*  NS x = NS f <> NS x-	NS f  *> NS x = NS f <> NS x-instance Alternative NS where-	empty = mempty-	NS f <|> NS x = NS f <> NS x-	many = coerceNS-	some = coerceNS-instance Sym_Rule NS where-	rule n (NS ns) = NS $ do-		-- NOTE: avoid infinite loops-		-- by not reentering into already visited rules.-		st@State{..} <- S.get-		if HS.member n state_rules-		 then return mempty-		 else do-			S.put $ st{state_rules = HS.insert n state_rules}-			ns-	arg _n = mempty-type instance Permutation NS = NS-instance Sym_Permutation NS where-	runPermutation = coerceNS-	toPermutation = id-	toPermutationWithDefault _def = id-instance Sym_RNC NS where-	-- namespace n ns =-	-- 	NS $ return $ HM.singleton ns $ HS.singleton n-	namespace mp n =-		NS $ return $-		case mp of-		 Just p  -> XML.Namespaces{XML.namespaces_prefixes = HM.singleton n $ Just p, XML.namespaces_default = ""}-		 Nothing -> def{XML.namespaces_default = n}-	element XML.QName{..} (NS nsM) =-		NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =-			HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}-	attribute XML.QName{..} (NS nsM) =-		NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =-			HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}-	anyElem qNameSpace f =-		let NS nsM = f $ XML.NCName "*" in-		NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes =-			HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns}-	try         = id-	fail        = mempty-	escapedText = mempty-	text        = mempty-	any         = mempty-	choice      = mconcat-	option _def = coerceNS-	optional    = coerceNS-	manySeq     = coerceNS-	someSeq     = coerceNS

@@ -1,11 +0,0 @@-module Symantic.XML- ( module Symantic.XML.Document- , readXML- , readFile- , writeXML- , writeXMLIndented- , writeFile- ) where-import Symantic.XML.Document-import Symantic.XML.Read-import Symantic.XML.Write

@@ -1,432 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Symantic.XML.Document- ( module Symantic.XML.Document- , TS.Tree(..)- , TS.Trees- , TS.tree0- ) where--import Control.Applicative (Alternative(..))-import Data.Bool-import Data.Char (Char)-import Data.Default.Class (Default(..))-import Data.Eq (Eq(..))-import Data.Foldable (Foldable(..), all)-import Data.Function (($), (.), id)-import Data.Functor (Functor(..), (<$>))-import Data.Hashable (Hashable(..))-import Data.Int (Int)-import Data.List.NonEmpty (NonEmpty(..))-import Data.Maybe (Maybe(..), fromMaybe)-import Data.Monoid (Monoid(..))-import Data.Ord (Ord(..))-import Data.Semigroup (Semigroup(..))-import Data.Sequence (Seq)-import Data.String (String, IsString(..))-import GHC.Generics (Generic)-import Prelude ((+), error)-import System.IO (FilePath)-import Text.Show (Show(..), showsPrec, showChar, showParen, showString)-import qualified Data.Char.Properties.XMLCharProps as XC-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import qualified Data.List as List-import qualified Data.Sequence as Seq-import qualified Data.Text.Lazy as TL-import qualified Data.TreeSeq.Strict as TS---- * Type 'XML'-type XML src = TS.Tree (Sourced src Node)-type XMLs src = Seq (XML src)---- | Unify two 'XMLs', merging border 'NodeText's if any.-union :: Semigroup (Sourced src EscapedText) => XMLs src -> XMLs src -> XMLs src-union x y =-	case (Seq.viewr x, Seq.viewl y) of-	 (xs Seq.:> x0, y0 Seq.:< ys) ->-		case (x0,y0) of-		 (  Tree0 (Sourced sx (NodeText tx))-		  , Tree0 (Sourced sy (NodeText ty)) ) ->-			xs `union`-			Seq.singleton (Tree0 $ (NodeText <$>) $ Sourced sx tx <> Sourced sy ty) `union`-			ys-		 _ -> x <> y-	 (Seq.EmptyR, _) -> y-	 (_, Seq.EmptyL) -> x--unions ::- Semigroup (Sourced src EscapedText) =>- Foldable f => f (XMLs src) -> XMLs src-unions = foldl' union mempty--pattern Tree0 :: a -> TS.Tree a-pattern Tree0 a <- TS.Tree a (null -> True)-	where Tree0 a = TS.Tree a Seq.empty---- ** Type 'Node'-data Node- =   NodeElem    QName         -- ^ Node with some 'NodeAttr' and then other 'Node's as children.- |   NodeAttr    QName         -- ^ Node with a 'NodeText' child.- |   NodePI      PName TL.Text -- ^ Leaf (except for @<?xml?>@ which has 'NodeAttr's.- |   NodeText    EscapedText   -- ^ Leaf.- |   NodeComment TL.Text       -- ^ Leaf.- |   NodeCDATA   TL.Text       -- ^ Leaf.- deriving (Eq, Ord, Show)---- ** Type 'EscapedText'-newtype EscapedText = EscapedText (Seq Escaped)- deriving (Eq, Ord, Show)--escapeText :: TL.Text -> EscapedText-escapeText s =-	EscapedText $-	case TL.span (`List.notElem` ("<>&'\""::String)) s of-	 (t, r) | TL.null t -> escape r-	        | otherwise -> EscapedPlain t Seq.<| escape r-	where-	escape t = case TL.uncons t of-	 Nothing -> mempty-	 Just (c, cs) -> escapeChar c Seq.<| et where EscapedText et = escapeText cs--escapeChar :: Char -> Escaped-escapeChar c =-	case c of-	 '<'  -> EscapedEntityRef entityRef_lt-	 '>'  -> EscapedEntityRef entityRef_gt-	 '&'  -> EscapedEntityRef entityRef_amp-	 '\'' -> EscapedEntityRef entityRef_apos-	 '"'  -> EscapedEntityRef entityRef_quot-	 _    -> EscapedPlain $ TL.singleton c--unescapeText :: EscapedText -> TL.Text-unescapeText (EscapedText et) = (`foldMap` et) $ \case- EscapedPlain t -> t- EscapedEntityRef EntityRef{..} -> entityRef_value- EscapedCharRef (CharRef c) -> TL.singleton c--instance Semigroup EscapedText where- EscapedText x <> EscapedText y =-		case (x,y) of-		 (xl Seq.:|> EscapedPlain xr, EscapedPlain yl Seq.:<|yr) ->-			(EscapedText $ xl Seq.|> EscapedPlain (xr<>yl)) <> EscapedText yr-		 _ -> EscapedText $ x <> y-instance Monoid EscapedText where-	mempty  = EscapedText mempty-	mappend = (<>)---- *** Type 'Escaped'--- | 'EscapedText' lexemes.-data Escaped-  =  EscapedPlain     TL.Text-  |  EscapedEntityRef EntityRef-  |  EscapedCharRef   CharRef-  deriving (Eq, Ord, Show)---- *** Type 'EntityRef'-data EntityRef = EntityRef- { entityRef_name  :: NCName- , entityRef_value :: TL.Text- } deriving (Eq, Ord, Show)--entityRef_lt, entityRef_gt, entityRef_amp, entityRef_quot, entityRef_apos :: EntityRef-entityRef_lt   = EntityRef (NCName "lt") "<"-entityRef_gt   = EntityRef (NCName "gt") ">"-entityRef_amp  = EntityRef (NCName "amp") "&"-entityRef_quot = EntityRef (NCName "quot") "\""-entityRef_apos = EntityRef (NCName "apos") "'"---- *** Type 'CharRef'-newtype CharRef = CharRef Char- deriving (Eq, Ord, Show)---- ** Type 'Name'-newtype Name = Name { unName :: TL.Text }- deriving (Eq, Ord, Hashable)-instance Show Name where-	showsPrec _p = showString . TL.unpack . unName-instance IsString Name where-	fromString s-	 | c:cs <- s-	 , XC.isXmlNameStartChar c-	 && all XC.isXmlNameChar cs-	 = Name (TL.pack s)-	 | otherwise = error $ "Invalid XML Name: "<>show s---- ** Type 'Namespace'-newtype Namespace = Namespace { unNamespace :: TL.Text }- deriving (Eq, Ord, Show, Hashable)-instance IsString Namespace where-	fromString s =-		if all (\c -> XC.isXmlChar c && c `List.notElem` ("'\"<&"::String)) s-		then Namespace (fromString s)-		else error $ "Invalid XML Namespace: "<>show s--xmlns_xml, xmlns_xmlns, xmlns_empty :: Namespace-xmlns_xml   = Namespace "http://www.w3.org/XML/1998/namespace"-xmlns_xmlns = Namespace "http://www.w3.org/2000/xmlns/"-xmlns_empty = Namespace ""---- * Type 'Namespaces'-data Namespaces prefix = Namespaces- { namespaces_prefixes :: (HM.HashMap Namespace prefix)- , namespaces_default  :: Namespace- } deriving (Show)-instance Default (Namespaces NCName) where-	def = Namespaces-	 { namespaces_prefixes = HM.fromList-		 [ (xmlns_xml  , "xml")-		 , (xmlns_xmlns, "xmlns")-		 ]-	 , namespaces_default  = ""-	 }-instance Default (Namespaces (Maybe NCName)) where-	def = Namespaces-	 { namespaces_prefixes = HM.fromList-		 [ (xmlns_xml  , Just "xml")-		 , (xmlns_xmlns, Just "xmlns")-		 ]-	 , namespaces_default  = ""-	 }-instance Semigroup (Namespaces NCName) where-	x <> y = Namespaces-	 { namespaces_prefixes = namespaces_prefixes x <> namespaces_prefixes y-	 , namespaces_default  = namespaces_default x-	 }-instance Semigroup (Namespaces (Maybe NCName)) where-	x <> y = Namespaces-	 { namespaces_prefixes = HM.unionWith (<|>) (namespaces_prefixes x) (namespaces_prefixes y)-	 , namespaces_default  = namespaces_default x-	 }-instance Monoid (Namespaces NCName) where-	mempty  = def-	mappend = (<>)-instance Monoid (Namespaces (Maybe NCName)) where-	mempty  = def-	mappend = (<>)--prefixifyQName :: Namespaces NCName -> QName -> PName-prefixifyQName Namespaces{..} QName{..} =-	PName-	 { pNameSpace =-		if qNameSpace == namespaces_default-		then Nothing-		else HM.lookup qNameSpace namespaces_prefixes-	 , pNameLocal = qNameLocal-	 }---- ** Type 'NCName'--- | Non-colonized name.-newtype NCName = NCName { unNCName :: TL.Text }- deriving (Eq, Ord, Hashable)-instance Show NCName where-	showsPrec _p = showString . TL.unpack . unNCName-instance IsString NCName where-	fromString s =-		fromMaybe (error $ "Invalid XML NCName: "<>show s) $-		ncName (TL.pack s)--ncName :: TL.Text -> Maybe NCName-ncName t =-	case TL.uncons t of-	 Just (c, cs)-	  | XC.isXmlNCNameStartChar c-	  , TL.all XC.isXmlNCNameChar cs-	  -> Just (NCName t)-	 _ -> Nothing--poolNCNames :: [NCName]-poolNCNames =-	[ NCName $ TL.pack ("ns"<>show i)-	| i <- [1 :: Int ..]-	]--freshNCName :: HS.HashSet NCName -> NCName-freshNCName ps = List.head $ poolNCNames List.\\ HS.toList ps--freshifyNCName :: HS.HashSet NCName -> NCName -> NCName-freshifyNCName ns (NCName n) =-	let ints = [1..] :: [Int] in-	List.head-	 [ fresh-	 | suffix <- mempty : (show <$> ints)-	 , fresh <- [ NCName $ n <> TL.pack suffix]-	 , not $ fresh `HS.member` ns-	 ]---- ** Type 'PName'--- | Prefixed name.-data PName = PName- { pNameSpace :: (Maybe NCName) -- ^ eg. Just "xml"- , pNameLocal :: NCName         -- ^ eg. "stylesheet"- } deriving (Eq, Ord, Generic)-instance Show PName where-	showsPrec p PName{pNameSpace=Nothing, ..} =-		showsPrec p pNameLocal-	showsPrec _p PName{pNameSpace=Just p, ..} =-		showsPrec 10 p .-		showChar ':' .-		showsPrec 10 pNameLocal-instance IsString PName where-	fromString "" = PName Nothing "" -- NOTE: NCName's fromString will raise an error.-	fromString s =-		case List.break (== ':') s of-		 (_, "")    -> PName Nothing $ fromString s-		 (p, local) -> PName (Just $ fromString p) (fromString $ List.drop 1 local)-instance Hashable PName--pName :: NCName -> PName-pName = PName Nothing-{-# INLINE pName #-}---- ** Type 'QName'--- | Qualified name.-data QName = QName- { qNameSpace :: Namespace -- ^ eg. "http://www.w3.org/1999/XSL/Transform"- , qNameLocal :: NCName    -- ^ eg. "stylesheet"- } deriving (Eq, Ord, Generic)-instance Show QName where-	showsPrec _p QName{..} =-		(if TL.null $ unNamespace qNameSpace then id-		else showChar '{' . showString (TL.unpack $ unNamespace qNameSpace) . showChar '}'-		) . showsPrec 10 qNameLocal-instance IsString QName where-	fromString "" = QName "" "" -- NOTE: NCName's fromString will raise an error.-	fromString full@('{':rest) =-		case List.break (== '}') rest of-		 (_, "")     -> error $ "Invalid XML Clark notation: "<>show full-		 (ns, local) -> QName (fromString ns) $ fromString $ List.drop 1 local-	fromString local = QName "" $ fromString local-instance Hashable QName--qName :: NCName -> QName-qName = QName (Namespace "")-{-# INLINE qName #-}---- * Type 'Sourced'-data Sourced src a- =   Sourced- {   source  :: src- , unSourced :: a- } deriving (Eq, Ord, Functor)-instance (Show src, Show a) => Show (Sourced src a) where-	showsPrec p Sourced{..} =-		showParen (p > 10) $-		showsPrec 11 unSourced .-		showString " @" . showsPrec 10 source-instance Semigroup a => Semigroup (Sourced (FileSource Offset) a) where-	(<>)-	 (Sourced rx@(FileRange xf xb xe :|  xs) x)-	 (Sourced    (FileRange yf yb ye :| _ys) y)-	 | xf == yf && xe == yb = Sourced (FileRange xf xb ye :| xs) $ x<>y-	 | otherwise = Sourced rx (x<>y)-{--instance (FromPad a, Semigroup a) => Semigroup (Sourced (FileSource LineCol) a) where-	(<>)-	 (Sourced rx@(FileRange xf xb xe :|  xs) x)-	 (Sourced    (FileRange yf yb ye :| _ys) y)-	 | xf == yf  = Sourced (FileRange xf xb ye :| xs) $ x<>fromPad (LineColumn l c)<>y-	 | otherwise = Sourced rx (x<>y)-	where-	l = lineNum yb - lineNum xe-	c = colNum  yb - colNum (if l <= 0 then xe else xb)---- ** Class 'FromPad'-class FromPad a where-	fromPad :: LineColumn -> a-instance FromPad T.Text where-	fromPad LineColumn{..} =-		T.replicate lineNum   "\n" <>-		T.replicate colNum " "-instance FromPad TL.Text where-	fromPad LineColumn{..} =-		TL.replicate (fromIntegral lineNum)   "\n" <>-		TL.replicate (fromIntegral colNum) " "-instance FromPad EscapedText where-	fromPad = EscapedText . pure . fromPad-instance FromPad Escaped where-	fromPad = EscapedPlain . fromPad--}---- ** Class 'NoSource'-class NoSource src where-	noSource :: src-instance Default pos => NoSource (FileSource pos) where-	noSource = noSource :| []-instance Default pos => NoSource (FileRange pos) where-	noSource = FileRange "" def def-instance NoSource Offset where-	noSource = Offset def-{--instance (FromPad a, Semigroup a, Monoid a) => Monoid (Sourced a) where-	mempty  = sourced0 mempty-	mappend = (<>)--}--notSourced :: NoSource src => a -> Sourced src a-notSourced = Sourced noSource---- * Type 'FileSource'-type FileSource pos = NonEmpty (FileRange pos)---- ** Type 'FileSourced'-type FileSourced = Sourced (FileSource Offset)---- ** Type 'FileRange'-data FileRange pos- =   FileRange- {   fileRange_file  :: FilePath- ,   fileRange_begin :: pos- ,   fileRange_end   :: pos- } deriving (Eq, Ord)-instance Default (FileRange Offset) where-	def = FileRange "" def def-instance Default (FileRange LineColumn) where-	def = FileRange "" def def-instance Show (FileRange Offset) where-	showsPrec _p FileRange{..} =-		showString fileRange_file .-		showChar '@' . showsPrec 10 fileRange_begin .-		showChar '-' . showsPrec 10 fileRange_end-instance Show (FileRange LineColumn) where-	showsPrec _p FileRange{..} =-		showString fileRange_file .-		showChar '#' . showsPrec 10 fileRange_begin .-		showChar '-' . showsPrec 10 fileRange_end---- *** Type 'Offset'-newtype Offset = Offset Int- deriving (Eq, Ord)-instance Show Offset where-	showsPrec p (Offset o) = showsPrec p o-instance Default Offset where-	def = Offset 0-instance Semigroup Offset where-	Offset x <> Offset y = Offset (x+y)-instance Monoid Offset where-	mempty  = def-	mappend = (<>)---- *** Type 'LineColumn'--- | Absolute text file position.-data LineColumn = LineColumn- { lineNum :: {-# UNPACK #-} Offset- , colNum  :: {-# UNPACK #-} Offset- } deriving (Eq, Ord)-instance Default LineColumn where-	def = LineColumn def def-instance Show LineColumn where-	showsPrec _p LineColumn{..} =-		showsPrec 11 lineNum .-		showChar ':' .-		showsPrec 11 colNum--filePos1 :: LineColumn-filePos1 = def

@@ -1,478 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Symantic.XML.Read- ( module Symantic.XML.Read.Parser- , module Symantic.XML.Read- ) where--import Control.Arrow (left)-import Control.Applicative (Applicative(..), Alternative(..))-import Control.Monad (Monad(..), void, unless, forM, join)-import Data.Bool-import Data.Char (Char)-import Data.Default.Class (Default(..))-import Data.Either (Either(..))-import Data.Eq (Eq(..))-import Data.Foldable (Foldable(..))-import Data.Function (($), (.), const)-import Data.Functor ((<$>), (<$))-import Data.Maybe (Maybe(..), maybe)-import Data.Monoid (Monoid(..))-import Data.Ord (Ord(..))-import Data.Semigroup (Semigroup(..))-import Data.String (String)-import Data.TreeSeq.Strict (Tree(..))-import Data.Tuple (snd)-import Prelude (Num(..), Enum(..), Bounded(..), Integer, toInteger)-import System.IO (FilePath, IO)-import Text.Megaparsec ((<?>))-import Text.Show (Show(..))-import qualified Control.Exception as Exn-import qualified Control.Monad.Trans.Reader as R-import qualified Data.ByteString.Lazy as BSL-import qualified Data.Char as Char-import qualified Data.Char.Properties.XMLCharProps as XC-import qualified Data.HashMap.Strict as HM-import qualified Data.List as List-import qualified Data.Sequence as Seq-import qualified Data.Text.Encoding.Error as TL-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import qualified Data.TreeSeq.Strict as TS-import qualified System.IO.Error as IO-import qualified Text.Megaparsec as P-import qualified Text.Megaparsec.Char as P--import Symantic.XML.Document hiding (XML, XMLs)-import Symantic.XML.Read.Parser--readXML :: FilePath -> TL.Text -> Either (P.ParseErrorBundle TL.Text Error) XMLs-readXML filePath stateInput =-	snd $-	P.runParser'-	 (R.runReaderT p_document def)-	 P.State-	 { P.stateInput-	 , P.stateOffset = 0-	 , P.statePosState = P.PosState-		 { P.pstateInput      = stateInput-		 , P.pstateOffset     = 0-		 , P.pstateSourcePos  = P.initialPos filePath-		 , P.pstateTabWidth   = P.pos1-		 , P.pstateLinePrefix = ""-		 }-	 }--readFile :: FilePath -> IO (Either ErrorRead TL.Text)-readFile fp =-	(left ErrorRead_Unicode . TL.decodeUtf8' <$> BSL.readFile fp)-	`Exn.catch` \e ->-		if IO.isAlreadyInUseError e-		|| IO.isDoesNotExistError e-		|| IO.isPermissionError   e-		then return $ Left $ ErrorRead_IO e-		else IO.ioError e---- * Type 'ErrorRead'-data ErrorRead- =   ErrorRead_IO IO.IOError- |   ErrorRead_Unicode TL.UnicodeException- deriving (Show)---- * Document-p_document :: P.Tokens s ~ TL.Text => Parser Error s XMLs-p_document = do-	ps <- p_prolog-	e  <- p_Element-	ms <- P.many p_Misc-	P.eof-	return (ps <> pure e <> join (Seq.fromList ms))---- ** Prolog-p_prolog :: P.Tokens s ~ TL.Text => Parser Error s XMLs-p_prolog = do-	xmlDecl <- P.option Seq.empty $ pure <$> p_XMLDecl-	ms <- P.many p_Misc-	return (xmlDecl <> join (Seq.fromList ms))---- ** Misc-p_Misc :: P.Tokens s ~ TL.Text => Parser Error s XMLs-p_Misc =-	P.try (pure <$> p_Comment)-	 <|> P.try (pure <$> p_PI)-	 <|> pure <$> p_S---- ** XMLDecl-p_XMLDecl :: P.Tokens s ~ TL.Text => Parser Error s XML-p_XMLDecl = P.label "XMLDecl" $ do-	Sourced src as <- p_Sourced $ P.between (P.string "<?xml") (P.string "?>") $ do-		vi <- pure <$> p_VersionInfo-		ed <- P.option Seq.empty $ pure <$> p_EncodingDecl-		sd <- P.option Seq.empty $ pure <$> p_SDDecl-		p_Spaces-		return $ vi <> ed <> sd-	return $ Tree (Sourced src $ NodePI "xml" "") as--p_VersionInfo :: P.Tokens s ~ TL.Text => Parser Error s XML-p_VersionInfo = P.label "VersionInfo" $ do-	Sourced c v <- p_Sourced $ do-		P.try (() <$ p_Spaces1 <* P.string "version")-		p_Eq-		p_quoted $ const $ p_Sourced $-			(<>)-			 <$> P.string "1."-			 <*> P.takeWhile1P Nothing Char.isDigit-	return $ Tree (Sourced c $ NodeAttr "version") $ pure $-		TS.tree0 $ NodeText . EscapedText . pure . EscapedPlain <$> v--p_EncodingDecl :: P.Tokens s ~ TL.Text => Parser Error s XML-p_EncodingDecl = P.label "EncodingDecl" $ do-	Sourced c v <- p_Sourced $ do-		P.try (() <$ p_Spaces1 <* P.string "encoding")-		p_Eq-		p_quoted $ const $ p_Sourced p_EncName-	return $ Tree (Sourced c $ NodeAttr "encoding") $ pure $-		TS.tree0 $ NodeText . EscapedText . pure . EscapedPlain <$> v--p_EncName :: P.Tokens s ~ TL.Text => Parser Error s TL.Text-p_EncName = P.label "EncName" $ do-	P.notFollowedBy (P.satisfy $ not . isAlpha)-	P.takeWhile1P Nothing $ \c ->-		isAlpha c || Char.isDigit c ||-		c=='.' || c=='_' || c=='-'-	where isAlpha c = Char.isAsciiLower c || Char.isAsciiUpper c---- *** SDDecl-p_SDDecl :: P.Tokens s ~ TL.Text => Parser Error s XML-p_SDDecl = P.label "SDDecl" $ do-	p_SourcedBegin $ do-		Sourced ca () <- P.try (p_Sourced $ () <$ p_Spaces1 <* P.string "standalone")-		p_Eq-		v <- p_quoted $ const $ p_Sourced $ P.string "yes" <|> P.string "no"-		return $ Tree (Sourced ca $ NodeAttr "standalone") $ pure $-			TS.tree0 $ NodeText . EscapedText . pure . EscapedPlain <$> v---- ** CharData-p_CharData :: P.Tokens s ~ TL.Text => Parser e s EscapedText-p_CharData =-	escapeText-	 <$> p_until1 (\c -> XC.isXmlChar c && c/='<' && c/='&') (']',"]>")---- ** Comment-p_Comment :: P.Tokens s ~ TL.Text => Parser Error s XML-p_Comment = p_SourcedBegin $ P.string "<!--" *> p_Comment__-p_Comment_ :: P.Tokens s ~ TL.Text => Parser Error s XML-p_Comment_ = P.string "--" *> p_Comment__-p_Comment__:: P.Tokens s ~ TL.Text => Parser Error s XML-p_Comment__ = P.label "Comment" $ do-	c <- p_until XC.isXmlChar ('-', "-")-	void $ P.string "-->"-	cell <- p_SourcedEnd-	return $ TS.tree0 (cell $ NodeComment c)---- ** CDATA-p_CDSect :: P.Tokens s ~ TL.Text => Parser Error s XML-p_CDSect = p_SourcedBegin $ P.string "<![CDATA[" *> p_CDSect__-p_CDSect_ :: P.Tokens s ~ TL.Text => Parser Error s XML-p_CDSect_ = P.string "[CDATA[" *> p_CDSect__-p_CDSect__ :: P.Tokens s ~ TL.Text => Parser Error s XML-p_CDSect__ = P.label "CDSect" $ do-	c <- p_until XC.isXmlChar (']', "]>")-	void $ P.string "]]>"-	cell <- p_SourcedEnd-	return $ TS.tree0 $ cell $ NodeCDATA c---- ** PI-p_PI :: P.Tokens s ~ TL.Text => Parser Error s XML-p_PI = p_SourcedBegin $ P.string "<?" *> p_PI__-p_PI_ :: P.Tokens s ~ TL.Text => Parser Error s XML-p_PI_ = P.char '?' *> p_PI__-p_PI__ :: P.Tokens s ~ TL.Text => Parser Error s XML-p_PI__ = P.label "PI" $ do-	n <- p_PITarget-	v <- P.option "" $ P.try $ p_Spaces1 *> p_until XC.isXmlChar ('?', ">")-	void $ P.string "?>"-	cell <- p_SourcedEnd-	return $ TS.tree0 $ cell $ NodePI n v-p_PITarget :: P.Tokens s ~ TL.Text => Parser Error s PName-p_PITarget = do-	n <- p_PName-	case n of-	 PName{pNameSpace=Nothing, pNameLocal=NCName l}-	  | "xml" == TL.toLower l -> p_error $ Error_PI_reserved n-	 _ -> return n---- ** Element-p_Element :: P.Tokens s ~ TL.Text => Parser Error s XML-p_Element = p_SourcedBegin $ (P.char '<' *> p_Element_)-p_Element_ :: P.Tokens s ~ TL.Text => Parser Error s XML-p_Element_ = P.label "Element" p_STag---- *** STag-p_STag :: P.Tokens s ~ TL.Text => Parser Error s XML-p_STag = do-	n  <- p_PName-	as <- P.many $ P.try $ p_Spaces1 *> p_Attribute-	p_Spaces-	ro <- R.ask-	elemNS :: HM.HashMap NCName Namespace <--		(HM.fromList . List.concat <$>) $ forM as $ \case-		 Sourced _ (PName{..}, Sourced _ av)-		  | ns <- Namespace $ unescapeText av-		  , Nothing        <- pNameSpace-		  , NCName "xmlns" <- pNameLocal ->-			-- NOTE: default namespace declaration.-			case ns of-			 _ |  ns == xmlns_xml   -- DOC: it MUST NOT be declared as the default namespace-			   || ns == xmlns_xmlns -- DOC: it MUST NOT be declared as the default namespace-			   -> p_error $ Error_Namespace_reserved ns-			 _ -> return [(NCName "" , ns)]-		  | ns <- Namespace $ unescapeText av-		  , Just (NCName "xmlns") <- pNameSpace ->-			-- NOTE: namespace prefix declaration.-			case unNCName pNameLocal of-			 "xml" -- DOC: It MAY, but need not, be declared,-			       -- and MUST NOT be bound to any other namespace name.-			       | ns == xmlns_xml -> return []-			       | otherwise -> p_error $ Error_Namespace_reserved_prefix pNameLocal-			 "xmlns" -- DOC: It MUST NOT be declared-			         -> p_error $ Error_Namespace_reserved_prefix pNameLocal-			 local | "xml" <- TL.toLower $ TL.take 3 local -> return []-			       -- DOC: All other prefixes beginning with the three-letter-			       -- sequence x, m, l, in any case combination, are reserved.-			       -- This means that: processors MUST NOT treat them as fatal errors.-			 _ |  ns == xmlns_xml   -- DOC: Other prefixes MUST NOT be bound to this namespace name.-			   || ns == xmlns_xmlns -- DOC: Other prefixes MUST NOT be bound to this namespace name.-			   -> p_error $ Error_Namespace_reserved ns-			 _ -> return [(pNameLocal, ns)]-		  | otherwise -> return []-	let scopeNS = elemNS <> reader_ns_scope ro-	let defaultNS = HM.lookupDefault (reader_ns_default ro) (NCName "") scopeNS-	let lookupNamePrefix prefix =-		maybe (p_error $ Error_Namespace_prefix_unknown prefix) return $-		HM.lookup prefix scopeNS-	elemName :: QName <--		-- NOTE: expand element's QName.-		case pNameSpace n of-		 Nothing -> return QName{qNameSpace=defaultNS, qNameLocal=pNameLocal n}-		  -- DOC: If there is a default namespace declaration in scope,-		  -- the expanded name corresponding to an unprefixed element name-		  -- has the URI of the default namespace as its namespace name.-		 Just prefix-		  | NCName "xmlns" <- prefix ->-			-- DOC: Element names MUST NOT have the prefix xmlns.-			p_error $ Error_Namespace_reserved_prefix prefix-		  | otherwise -> do-			ns <- lookupNamePrefix prefix-			return QName{qNameSpace=ns, qNameLocal=pNameLocal n}-	elemAttrs :: [FileSourced (QName, FileSourced EscapedText)] <--		-- NOTE: expand attributes' PName into QName.-		forM as $ \s@Sourced{unSourced=(an, av)} -> do-			ns <- maybe (return "") lookupNamePrefix $ pNameSpace an-			let qn = QName{qNameSpace=ns, qNameLocal=pNameLocal an}-			return s{unSourced=(qn, av)}-	-- NOTE: check for attribute collision.-	let attrsByQName :: HM.HashMap QName [FileSourced (QName, FileSourced EscapedText)] =-		HM.fromListWith (<>) $ (<$> elemAttrs) $ \a@(Sourced _c (an, _av)) -> (an, [a])-	case HM.toList $ HM.filter (\x -> length x > 1) attrsByQName of-	 (an, _):_ -> p_error $ Error_Attribute_collision an-	 _ -> return ()-	elemAttrsXML :: XMLs <- (Seq.fromList <$>) $-		forM elemAttrs $ \(Sourced sa (an, av)) -> do-			return $ TS.Tree (Sourced sa $ NodeAttr an) $-				pure $ TS.tree0 $ NodeText <$> av-	content :: XMLs <--		elemAttrsXML <$ P.string "/>" <|>-		R.local-		 (const ro-			 { reader_ns_scope   = scopeNS-			 , reader_ns_default = defaultNS-			 })-		 ((elemAttrsXML <>) <$ P.char '>' <*> p_content <* p_ETag elemName)-	cell <- p_SourcedEnd-	return $ Tree (cell $ NodeElem elemName) content---- *** Attribute-p_Attribute :: P.Tokens s ~ TL.Text => Parser Error s (FileSourced (PName, FileSourced EscapedText))-p_Attribute = p_Sourced $ (,) <$> p_PName <* p_Eq <*> p_AttValue--p_AttValue :: P.Tokens s ~ TL.Text => Parser Error s (FileSourced EscapedText)-p_AttValue = P.label "AttValue" $ p_quoted p_AttValueText--p_AttValueText :: P.Tokens s ~ TL.Text => Char -> Parser Error s (FileSourced EscapedText)-p_AttValueText q = p_Sourced $-	EscapedText . Seq.fromList <$> P.many-	 ( p_Reference-	 <|> EscapedPlain <$> P.takeWhile1P Nothing (\c ->-		XC.isXmlChar c &&-		c `List.notElem` (q:"<&'\">"))-	 <|> EscapedEntityRef entityRef_gt <$ P.char '>'-	 <|> (if q == '\''-		then EscapedEntityRef entityRef_quot <$ P.char '"'-		else EscapedEntityRef entityRef_apos <$ P.char '\'')-	 )---- * content-p_content :: P.Tokens s ~ TL.Text => Parser Error s XMLs-p_content =-	(Seq.fromList <$>) $ P.many $-		(p_SourcedBegin $ do-			P.try $ P.char '<' *> P.notFollowedBy (P.char '/')-			p_Element_ <|> p_PI_ <|> (P.char '!' *> (p_Comment_ <|> p_CDSect_))-		)-		<|> ((tree0 <$>) $ p_Sourced $ NodeText . mconcat-			 <$> P.some (p_CharData <|> EscapedText . pure <$> p_Reference))---- *** ETag-p_ETag :: P.Tokens s ~ TL.Text => QName -> Parser Error s ()-p_ETag expected = do-	got <- P.string "</" *> p_QName <* p_Spaces <* P.char '>'-	unless (got == expected) $-		p_error $ Error_Closing_tag_unexpected got expected---- * Name-p_Name :: P.Tokens s ~ TL.Text => Parser Error s Name-p_Name = P.label "Name" $-	Name-	 <$  P.notFollowedBy (P.satisfy $ not . XC.isXmlNameStartChar)-	 <*> P.takeWhile1P Nothing XC.isXmlNameChar---- * PName-p_PName :: P.Tokens s ~ TL.Text => Parser e s PName-p_PName = P.label "PName" $ do-	n <- p_NCName-	s <- P.optional $ P.try $ P.char ':' *> p_NCName-	return $ case s of-	 Nothing -> PName{pNameSpace=Nothing, pNameLocal=n}-	 Just l  -> PName{pNameSpace=Just n , pNameLocal=l}---- * QName-p_QName :: P.Tokens s ~ TL.Text => Parser Error s QName-p_QName = P.label "QName" $ do-	n <- p_NCName-	s <- P.optional $ P.try $ P.char ':' *> p_NCName-	Reader{..} <- R.ask-	case s of-	 Nothing -> return QName{qNameSpace=reader_ns_default, qNameLocal=n}-	 Just l ->-		case HM.lookup n reader_ns_scope of-		 Nothing -> p_error $ Error_Namespace_prefix_unknown n-		 Just ns -> return QName{qNameSpace=ns, qNameLocal=l}---- ** NCName-p_NCName :: P.Tokens s ~ TL.Text => Parser e s NCName-p_NCName = P.label "NCName" $-	NCName-	 <$  P.notFollowedBy (P.satisfy $ not . XC.isXmlNCNameStartChar)-	 <*> P.takeWhile1P Nothing XC.isXmlNCNameChar---- * Reference-p_Reference :: P.Tokens s ~ TL.Text => Parser Error s Escaped-p_Reference =-	EscapedCharRef <$> p_CharRef <|>-	EscapedEntityRef <$> p_EntityRef---- ** EntityRef-p_EntityRef :: P.Tokens s ~ TL.Text => Parser Error s EntityRef-p_EntityRef = P.label "EntityRef" $ do-	ref <- P.char '&' *> p_NCName <* P.char ';'-	EntityRef ref <$> lookupEntityRef ref-	where-	lookupEntityRef (NCName "lt"  ) = pure "<"-	lookupEntityRef (NCName "gt"  ) = pure ">"-	lookupEntityRef (NCName "amp" ) = pure "&"-	lookupEntityRef (NCName "apos") = pure "'"-	lookupEntityRef (NCName "quot") = pure "\""-	lookupEntityRef n = p_error $ Error_EntityRef_unknown n---- ** CharRef-p_CharRef :: P.Tokens s ~ TL.Text => Parser Error s CharRef-p_CharRef = P.label "CharRef" $-	do-		ref <- readHexadecimal-		 <$  P.string "&#x"-		 <*> P.some P.hexDigitChar-		 <*  P.char ';'-		check ref-	<|> do-		ref <- readDecimal-		 <$  P.string "&#"-		 <*> P.some P.digitChar-		 <*  P.char ';'-		check ref-	where-	check i =-		let c = toEnum (fromInteger i) in-		if i <= toInteger (fromEnum (maxBound::Char))-		&& XC.isXmlChar c-		then pure $ CharRef c-		else p_error $ Error_CharRef_invalid i--readInt :: Integer -> String -> Integer-readInt base digits =-	sign * List.foldl' acc 0 (List.concatMap digToInt digits1)-	where-	acc q r = q*base + r-	(sign, digits1) =-		case digits of-		 [] -> (1, digits)-		 c:ds | c == '-'  -> (-1, ds)-		      | c == '+'  -> ( 1, ds)-		      | otherwise -> ( 1, digits)-	ord = toInteger . Char.ord-	digToInt c-	 | Char.isDigit c      = [ord c - ord '0']-	 | Char.isAsciiLower c = [ord c - ord 'a' + 10]-	 | Char.isAsciiUpper c = [ord c - ord 'A' + 10]-	 | otherwise           = []--readDecimal :: String -> Integer-readDecimal = readInt 10--readHexadecimal :: String -> Integer-readHexadecimal = readInt 16---- * Char-p_Char :: P.Tokens s ~ TL.Text => Parser e s Char-p_Char = P.label "Char" $ P.satisfy XC.isXmlCharCR <|> p_CRLF-{-# INLINE p_Char #-}---- ** Space--- | Map '\r' and '\r\n' to '\n'.-p_CRLF :: P.Tokens s ~ TL.Text => Parser e s Char-p_CRLF = P.label "CRLF" $-	P.char '\r' *> P.option '\n' (P.char '\n')--p_Space :: P.Tokens s ~ TL.Text => Parser e s Char-p_Space = P.label "Space" $-	P.satisfy XC.isXmlSpaceCharCR <|> p_CRLF-{-# INLINE p_Space #-}--p_Spaces :: P.Tokens s ~ TL.Text => Parser e s ()-p_Spaces = P.label "Spaces" $-	void $ P.takeWhileP Nothing XC.isXmlSpaceChar-{-# INLINE p_Spaces #-}--p_S :: P.Tokens s ~ TL.Text => Parser Error s XML-p_S = P.label "Spaces" $-	(\ts -> TS.tree0 (NodeText . EscapedText . pure . EscapedPlain . TL.concat <$> ts))-	 <$> p_Sourced (P.some $-		P.takeWhile1P Nothing XC.isXmlSpaceCharCR <|>-		TL.singleton <$> p_CRLF)--p_Spaces1 :: P.Tokens s ~ TL.Text => Parser e s ()-p_Spaces1 = P.label "Spaces1" $-	void $ P.takeWhile1P Nothing XC.isXmlSpaceChar-{-# INLINE p_Spaces1 #-}---- * Eq-p_separator :: P.Tokens s ~ TL.Text => Char -> Parser e s ()-p_separator c = P.try (() <$ p_Spaces <* P.char c) <* p_Spaces <?> [c]--p_Eq :: P.Tokens s ~ TL.Text => Parser e s ()-p_Eq = p_separator '=' <?> "Eq"

@@ -1,240 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE TypeFamilies #-}-module Symantic.XML.Read.Parser where--import Control.Applicative (Applicative(..), Alternative(..))-import Control.Monad (Monad(..))-import Data.Bool-import Data.Char (Char)-import Data.Default.Class (Default(..))-import Data.Eq (Eq(..))-import Data.Function (($), (.))-import Data.Functor ((<$>))-import Data.List.NonEmpty (NonEmpty(..))-import Data.Maybe (Maybe(..))-import Data.Ord (Ord(..))-import Data.String (IsString)-import Prelude (Integer)-import Text.Show (Show(..))-import qualified Control.Monad.Trans.Reader as R-import qualified Data.HashMap.Strict as HM-import qualified Data.Set as Set-import qualified Data.Text.Lazy as TL-import qualified Text.Megaparsec as P-import qualified Text.Megaparsec.Char as P--import Symantic.XML.Document hiding (XML, XMLs)-import qualified Symantic.XML.Document as XML---- | Specify |XML.XML|'s 'src' type parameter for parsing.-type XML = XML.XML (FileSource Offset)--- | Specify |XML.XMLs|'s 'src' type parameter for parsing.-type XMLs = XML.XMLs (FileSource Offset)---- * Type 'Parser'--- | Convenient alias.-type Parser   e s a =-     Parsable e s a =>-     R.ReaderT Reader (P.Parsec e s) a---- ** Type 'Parsable'-type Parsable e s a =- ( P.Stream s- , P.Token s ~ Char- , Ord e- , IsString (P.Tokens s)- , P.ShowErrorComponent e- )---- ** Type 'Reader'-data Reader = Reader- { reader_source     :: FileSource Offset- , reader_ns_scope   :: HM.HashMap NCName Namespace- , reader_ns_default :: Namespace- } deriving (Show)-instance Default Reader where-	def = Reader-	 { reader_source     = pure def-	 , reader_ns_scope   = HM.fromList-		 [ ("xml"  , xmlns_xml)-		 , ("xmlns", xmlns_xmlns)-		 ]-	 , reader_ns_default = ""-	 }--p_Offset :: Parser e s Offset-p_Offset = Offset <$> P.getOffset-{-# INLINE p_Offset #-}--p_Sourced :: Parser e s a -> Parser e s (Sourced (FileSource Offset) a)-p_Sourced pa = do-	Reader{reader_source} <- R.ask-	b <- P.getParserState-	let fileRange_file = P.sourceName $ P.pstateSourcePos $ P.statePosState b-	let fileRange_begin = Offset $ P.stateOffset b-	a <- pa-	e <- P.getParserState-	let fileRange_end = Offset $ P.stateOffset e-	return $ Sourced (setSource FileRange{..} reader_source) a--setSource :: FileRange pos -> FileSource pos -> FileSource pos-setSource fileRange (_curr:|next) = fileRange :| next---- | Like 'p_Sourced' but uncoupled (through the use of 'p_SourcedEnd') for more flexibility.-p_SourcedBegin :: Parser e s a -> Parser e s a-p_SourcedBegin pa = do-	b <- P.getParserState-	let fileRange_file  = P.sourceName $ P.pstateSourcePos $ P.statePosState b-	let fileRange_begin = Offset $ P.stateOffset b-	let fileRange_end   = fileRange_begin-	(`R.local` pa) $ \ro@Reader{..} ->-		ro{ reader_source = setSource FileRange{..} reader_source }---- | WARNING: Only to be used within a 'p_SourcedBegin'.-p_SourcedEnd :: Parser e s (a -> Sourced (FileSource Offset) a)-p_SourcedEnd = do-	Reader{..} <- R.ask-	e <- P.getParserState-	let fileRange_end = Offset $ P.stateOffset e-	return $ Sourced $-		 (\(curr:|path) -> curr{fileRange_end}:|path)-		 reader_source--{---- ** Type 'StreamSourced'--- | Wrap 'TL.Text' to have a 'P.Stream' instance--- whose 'P.advance1' method abuses the tab width state--- to instead pass the line indent.--- This in order to report correct 'P.SourcePos'--- when parsing a 'Sourced' containing newlines.-newtype StreamSourced = StreamSourced { unStreamSourced :: TL.Text }- deriving (IsString,Eq,Ord)-instance P.Stream StreamSourced where-	type Token  StreamSourced = Char-	type Tokens StreamSourced = TL.Text-	take1_       (StreamSourced t) = (StreamSourced <$>) <$> P.take1_ t-	takeN_     n (StreamSourced t) = (StreamSourced <$>) <$> P.takeN_ n t-	takeWhile_ f (StreamSourced t) = StreamSourced <$> P.takeWhile_ f t-	tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text)-	chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text)-	chunkLength   _s = P.chunkLength   (Proxy::Proxy TL.Text)-	{--	advance1 _s indent (P.SourcePos n line col) c =-		case c of-		 '\n' -> P.SourcePos n (line <> P.pos1) indent-		 _    -> P.SourcePos n line (col <> P.pos1)-	advanceN s indent = TL.foldl' (P.advance1 s indent)-	-}---- | Wrapper around |P.runParser'|--- to use given 'Sourced' as starting position.-runParserOnSourced ::- Parsable e StreamSourced a =>- Parser e StreamSourced a ->- Sourced FileSource TL.Text ->- Either (P.ParseError (P.Token StreamSourced) e) a-runParserOnSourced p (Sourced (FileRange inp bp _ep :| path) s) =-	snd $-	P.runParser' (R.runReaderT p ro <* P.eof)-	 P.State-	 { P.stateInput    = StreamSourced s-	 , P.statePos      = pure $ P.SourcePos inp (P.mkPos $ filePos_line bp) indent-	 , P.stateTabWidth = indent-	 , P.stateTokensProcessed = 0-	 }-	where-	indent = P.mkPos $ filePos_column bp-	ro     = def{ reader_source = fromMaybe (pure def) $ nonEmpty path }--}---- * Type 'Error'-data Error- =   Error_CharRef_invalid Integer-     -- ^ Well-formedness constraint: Legal Character.-     ---     -- Characters referred to using character references MUST match the production for Char.- |   Error_EntityRef_unknown NCName-     -- ^ Well-formedness constraint: Entity Declared-     ---     -- In a document without any DTD, a document with only an internal DTD-     -- subset which contains no parameter entity references, or a document-     -- with " standalone='yes' ", for an entity reference that does not occur-     -- within the external subset or a parameter entity, the Name given in the-     -- entity reference MUST match that in an entity declaration that does not-     -- occur within the external subset or a parameter entity, except that-     -- well-formed documents need not declare any of the following entities:-     -- amp, lt, gt, apos, quot. The declaration of a general entity MUST-     -- precede any reference to it which appears in a default value in an-     -- attribute-list declaration.-     ---     -- Note that non-validating processors are not obligated to read and-     -- process entity declarations occurring in parameter entities or in the-     -- external subset; for such documents, the rule that an entity must be-     -- declared is a well-formedness constraint only if standalone='yes'.- |   Error_Closing_tag_unexpected QName QName-     -- ^ Well-formedness constraint: Element Type Match.-     ---     -- The Name in an element's end-tag MUST match the element type in the start-tag.- |   Error_Attribute_collision QName-     -- ^ Well-formedness constraint: Unique Att Spec.-     ---     -- An attribute name MUST NOT appear more than once in the same start-tag or empty-element tag.- |   Error_PI_reserved PName-     -- ^ The target names " XML ", " xml ", and so on are reserved for standardization.- |   Error_Namespace_prefix_unknown NCName-     -- ^ Namespace constraint: Prefix Declared-     ---     -- The namespace prefix, unless it is xml or xmlns, MUST have been declared in a namespace declaration attribute in either the start-tag of the element where the prefix is used or in an ancestor element (i.e., an element in whose content the prefixed markup occurs). - |   Error_Namespace_empty NCName-     -- ^ Namespace constraint: No Prefix Undeclaring-     ---     -- In a namespace declaration for a prefix (i.e., where the NSAttName is a PrefixedAttName), the attribute value MUST NOT be empty.- |   Error_Namespace_reserved Namespace- |   Error_Namespace_reserved_prefix NCName-     -- ^ Namespace constraint: Reserved Prefixes and Namespace Names-     ---     -- The prefix xml is by definition bound to the namespace name-     -- http://www.w3.org/XML/1998/namespace. It MAY, but need not, be-     -- declared, and MUST NOT be bound to any other namespace name. Other-     -- prefixes MUST NOT be bound to this namespace name, and it MUST NOT be-     -- declared as the default namespace.-     ---     -- The prefix xmlns is used only to declare namespace bindings and is by-     -- definition bound to the namespace name http://www.w3.org/2000/xmlns/.-     -- It MUST NOT be declared . Other prefixes MUST NOT be bound to this-     -- namespace name, and it MUST NOT be declared as the default namespace.-     -- Element names MUST NOT have the prefix xmlns.-     ---     -- All other prefixes beginning with the three-letter sequence x, m, l, in-     -- any case combination, are reserved. This means that:-     ---     -- - users SHOULD NOT use them except as defined by later specifications-     -- - processors MUST NOT treat them as fatal errors.- deriving (Eq,Ord,Show)-instance P.ShowErrorComponent Error where-	showErrorComponent = show---- * Helpers-p_error :: e -> Parser e s a-p_error = P.fancyFailure . Set.singleton . P.ErrorCustom--p_quoted :: P.Tokens s ~ TL.Text => (Char -> Parser e s a) -> Parser e s a-p_quoted p =-	P.between (P.char '"') (P.char '"') (p '"') <|>-	P.between (P.char '\'') (P.char '\'') (p '\'')--p_until :: P.Tokens s ~ TL.Text => (Char -> Bool) -> (Char, TL.Text) -> Parser e s TL.Text-p_until content (end, end_) =-	(TL.concat <$>) $ P.many $-		P.takeWhile1P Nothing (\c -> content c && c /= end) <|>-		P.try (TL.singleton <$> P.char end <* P.notFollowedBy (P.string end_))--p_until1 :: P.Tokens s ~ TL.Text => (Char -> Bool) -> (Char, TL.Text) -> Parser e s TL.Text-p_until1 content (end, end_) =-	(TL.concat <$>) $ P.some $-		P.takeWhile1P Nothing (\c -> content c && c /= end) <|>-		P.try (TL.singleton <$> P.char end <* P.notFollowedBy (P.string end_))

@@ -1,274 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}-module Symantic.XML.Write where--import Control.Applicative (Applicative(..), liftA2)-import Control.Monad (Monad(..))-import Data.Bool-import Data.Default.Class (Default(..))-import Data.Eq (Eq(..))-import Data.Foldable (Foldable(..), all)-import Data.Function (($), (.), const)-import Data.Maybe (Maybe(..))-import Data.Monoid (Monoid(..))-import Data.Semigroup (Semigroup(..))-import Data.String (String, IsString(..))-import Data.Traversable (Traversable(..))-import System.IO (IO, FilePath)-import Text.Show (Show(..))-import qualified Control.Monad.Trans.Reader as R-import qualified Control.Monad.Trans.State as S-import qualified Data.ByteString.Lazy as BSL-import qualified Data.Char as Char-import qualified Data.HashMap.Strict as HM-import qualified Data.HashSet as HS-import qualified Data.Sequence as Seq-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB-import qualified Data.Text.Lazy.Encoding as TL--import Symantic.XML.Document as XML--writeXML :: NoSource src => XMLs src -> TL.Text-writeXML xs = TLB.toLazyText $ write xs `R.runReader` def--writeXMLIndented :: NoSource src => TL.Text -> XMLs src -> TL.Text-writeXMLIndented ind xs =-	TLB.toLazyText $-	write xs `R.runReader` def-	 { reader_indent       = if TL.null ind then mempty else "\n"-	 , reader_indent_delta = ind-	 }--writeFile :: FilePath -> TL.Text -> IO ()-writeFile fp t = BSL.writeFile fp $ TL.encodeUtf8 t---- * Type 'Write'-type Write = R.Reader Reader TLB.Builder-instance Semigroup Write where-	(<>) = liftA2 (<>)-instance Monoid Write where-	mempty = return ""-	mappend = (<>)-instance IsString Write where-	fromString = return . fromString---- ** Type 'Reader'-data Reader = Reader- { reader_ns_scope     :: Namespaces NCName- , reader_indent       :: TLB.Builder- , reader_indent_delta :: TL.Text- , reader_no_text      :: Bool- }-instance Default Reader where-	def = Reader-	 { reader_ns_scope     = def-	 , reader_indent       = ""-	 , reader_indent_delta = ""-	 , reader_no_text      = False-	 }---- * Class 'Buildable'-class Buildable a where-	build :: a -> TLB.Builder-instance Buildable Char.Char where-	build = TLB.singleton-instance Buildable String where-	build = TLB.fromString-instance Buildable TL.Text where-	build = TLB.fromLazyText-instance Buildable NCName where-	build = build . unNCName-instance Buildable Name where-	build = build . unName-instance Buildable PName where-	build PName{..} =-		case pNameSpace of-		 Nothing -> build pNameLocal-		 Just p -> build p<>":"<> build pNameLocal-instance Buildable Namespace where-	build = build . unNamespace-instance Buildable EntityRef where-	build EntityRef{..} = "&"<>build entityRef_name<>";"-instance Buildable CharRef where-	build (CharRef c) = "&#"<>build (show (Char.ord c))<>";"-instance Buildable EscapedText where-	build (EscapedText et) = (`foldMap` et) $ \case-	 EscapedPlain     t -> build t-	 EscapedEntityRef r -> build r-	 EscapedCharRef   r -> build r---- * Class 'Writable'-class Writeable a where-	write :: a -> Write-instance Writeable NCName where-	write = return . TLB.fromLazyText . unNCName-instance NoSource src => Writeable (XMLs src) where-	write xs = do-		ro <- R.ask-		if TL.null (reader_indent_delta ro)-		 then foldMap write xs-		 else-			R.local (const ro{reader_no_text}) $-				foldMap write xs-			where reader_no_text =-				(`all` xs) $ \case-				 Tree (Sourced _ (NodeText (EscapedText et))) _ts ->-					all (\case-					 EscapedPlain t -> TL.all Char.isSpace t-					 _ -> False) et-				 _ -> True-instance NoSource src => Writeable (XML src) where-	write (Tree (Sourced _src nod) xs) = do-		ro <- R.ask-		case nod of-			NodeAttr an-			 | [Tree (Sourced _ (NodeText av)) _] <- toList xs -> do-				return $ " "<>buildAttr (prefixifyQName (reader_ns_scope ro) an) av-			 | otherwise -> mempty-			NodeCDATA t ->-				return $-					reader_indent ro <>-					"<[CDATA[["<>build t<>"]]>"-			NodeComment t ->-				return $-					reader_indent ro <>-					"<!--"<>build t<>"-->"-			NodeElem elemQName -> do-				let (elemAttrs, elemChilds) =-					(`Seq.spanl` xs) $ \case-						 Tree (Sourced _ NodeAttr{}) _ -> True-						 _ -> False-				let (usedNS, declNS) ::-					( HS.HashSet Namespace-					, Namespaces NCName-					) =-					foldl' go (initUsedNS, initDeclNS) elemAttrs-					where-					initUsedNS-					 | qNameSpace elemQName == xmlns_empty = mempty-					 | otherwise                           = HS.singleton $ qNameSpace elemQName-					initDeclNS = def{namespaces_default = namespaces_default $ reader_ns_scope ro}-					go (!uNS, !dNS) = \case-						Tree (Sourced _ (NodeAttr QName{..})) vs-						 -- xmlns:prefix="namespace"-						 | qNameSpace == xmlns_xmlns-						 , [Tree (Sourced _ (NodeText t)) _] <- toList vs ->-							let n = unescapeText t in-							(uNS,) dNS-							 { namespaces_prefixes =-								(if TL.null n-								then HM.delete-								-- NOTE: empty namespace means removal of the prefix from scope.-								else (`HM.insert` qNameLocal))-								 (Namespace n)-								 (namespaces_prefixes dNS)-							 }-						 -- xmlns="namespace"-						 | qNameSpace == xmlns_empty-						 , qNameLocal == NCName "xmlns"-						 , [Tree (Sourced _ (NodeText t)) _] <- toList vs ->-							(uNS,)-							dNS{namespaces_default = Namespace $ unescapeText t}-						 -- name="value"-						 | qNameSpace == xmlns_empty -> (uNS, dNS)-						 -- {namespace}name="value"-						 | otherwise -> (HS.insert qNameSpace uNS, dNS)-						_ -> (uNS, dNS)-				let inhNS =-					-- NOTE: the inherited namespaces,-					-- including those declared at this element.-					HM.union-					 (namespaces_prefixes declNS)-					 (namespaces_prefixes (reader_ns_scope ro))-				let autoNS =-					-- NOTE: the namespaces used but not declared nor default,-					-- with fresh prefixes.-					HM.delete (namespaces_default declNS) $-					(`S.evalState` HS.empty) $-					traverse-					 (\() -> S.gets freshNCName)-					 (HS.toMap usedNS `HM.difference` inhNS)-				let autoAttrs =-					-- NOTE: XMLify autoNS-					HM.foldlWithKey'-					 (\acc (Namespace v) p ->-						(acc Seq.|>) $-							Tree (notSourced $ NodeAttr QName{qNameSpace=xmlns_xmlns, qNameLocal=p}) $-								pure $ tree0 $ notSourced $ NodeText $ EscapedText $ pure $ EscapedPlain v-					 ) mempty autoNS-				let scopeNS = declNS { namespaces_prefixes = autoNS <> inhNS }-				return $-					let build_elemPName = build $ prefixifyQName scopeNS elemQName in-					let build_elemAttrs =-						(`foldMap` (autoAttrs <> elemAttrs)) $ \case-						 Tree (Sourced _ (NodeAttr an)) vs-						  | [Tree (Sourced _ (NodeText av)) _] <- toList vs ->-							" "<>buildAttr (prefixifyQName scopeNS{namespaces_default=""} an) av-						 _ -> mempty in-					reader_indent ro-					 <> "<"<>build_elemPName-					 <> build_elemAttrs <>-					let build_elemChilds = write elemChilds-						`R.runReader` ro-						 { reader_ns_scope = scopeNS-						 , reader_indent   = reader_indent ro <> build (reader_indent_delta ro)-						 } in-					if null elemChilds-					then "/>"-					else ">"-						 <> build_elemChilds-						 <> (-							if TL.null (reader_indent_delta ro)-							|| noIndent elemChilds-							then mempty-							else reader_indent ro-						 )-						 <> "</"<>build_elemPName<>">"-					where-					noIndent =-						all $ \case-						 Tree (Sourced _ (NodeText _txt)) _ts -> True-						 _ -> False-			NodePI pn pv-			 | pn == "xml" -> do-				write_xs <- write xs-				return $-					"<?"<>build pn<>s<>write_xs<>"?>"-			 | otherwise ->-				return $-					reader_indent ro <>-					"<?"<>build pn<>s<>build pv<>"?>"-				where s | TL.null pv = ""-				        | otherwise  = " "-			NodeText t -> do-				return $-					if reader_no_text ro-					 then mempty-					 else build t--buildAttr :: PName -> EscapedText -> TLB.Builder-buildAttr n v = build n<>"=\""<>buildAttrValue v<>"\""--buildAttrValue :: EscapedText -> TLB.Builder-buildAttrValue (EscapedText et) = (`foldMap` et) $ \case- EscapedPlain p -> build p- EscapedEntityRef EntityRef{..} ->-	build $ TL.replace "\"" "&quot;" entityRef_value- EscapedCharRef (CharRef c)-	| c == '\"' -> "&quot;"-	| otherwise -> build c--removeSpaces :: XMLs src -> XMLs src-removeSpaces xs =-	if (`all` xs) $ \case-	 Tree (Sourced _ (NodeText (EscapedText et))) _ts ->-		all (\case-		 EscapedPlain t -> TL.all Char.isSpace t-		 _ -> False) et-	 _ -> True-	then (`Seq.filter` xs) $ \case-		 Tree (Sourced _ NodeText{}) _ts -> False-		 _ -> True-	else xs

@@ -0,0 +1,11 @@+module Symantic.XML+ ( module Symantic.XML.Language+ , module Symantic.XML.Read+ , module Symantic.XML.Tree+ , module Symantic.XML.Write+ ) where++import Symantic.XML.Language+import Symantic.XML.Read+import Symantic.XML.Tree+import Symantic.XML.Write

@@ -0,0 +1,76 @@+{-# LANGUAGE UndecidableInstances #-}+module Symantic.XML.Language+ ( module Symantic.XML.Language+ , module Symantic.XML.Namespace+ , module Symantic.XML.Text+ , module Symantic.Base.Composable+ , module Symantic.Base.Algebrable+ , module Symantic.Base.Permutable+ ) where++import Data.Function ((.))+import Data.Maybe (Maybe)+import Data.Kind (Constraint)+import qualified Data.Text.Lazy as TL++import Symantic.XML.Namespace+import Symantic.XML.Text+import Symantic.Base.Algebrable+import Symantic.Base.Composable+import Symantic.Base.Permutable++-- * Class 'XML'+class+ ( Composable repr+ , Tupable repr+ , Eitherable repr+ , Textable repr+ ) => XML repr where+  --xmlPI ::  -> repr a k+  -- | @('namespace' p ns)@ declares a namespace prefix @(p)@+  -- to be used for the 'Namespace' @(ns)@.+  -- Or make @(ns)@ the default namespace if @(p)@ is 'Nothing'.+  namespace :: Maybe NCName -> Namespace -> repr k k+  default namespace ::+   Transformable repr => XML (UnTrans repr) =>+   Maybe NCName -> Namespace -> repr k k+  namespace n ns = noTrans (namespace n ns)+  +  default element :: Transformable repr => XML (UnTrans repr) =>+             QName -> repr a k -> repr a k+  element :: QName -> repr a k -> repr a k+  element n x = noTrans (element n (unTrans x))+  +  default attribute :: Transformable repr => XML (UnTrans repr) =>+               QName -> repr a k -> repr a k+  attribute :: QName -> repr a k -> repr a k+  attribute n x = noTrans (attribute n (unTrans x))+  +  default pi :: Transformable repr => XML (UnTrans repr) =>+        PName -> repr (TL.Text -> k) k+  pi :: PName -> repr (TL.Text -> k) k+  pi n = noTrans (pi n)+  +  default literal :: Transformable repr => XML (UnTrans repr) =>+             TL.Text -> repr k k+  literal :: TL.Text -> repr k k+  literal = noTrans . literal+  +  default comment :: Transformable repr => XML (UnTrans repr) =>+             repr (TL.Text -> k) k+  comment :: repr (TL.Text -> k) k+  comment = noTrans comment+  +  default cdata :: Transformable repr => XML (UnTrans repr) =>+           repr (TL.Text -> k) k+  cdata :: repr (TL.Text -> k) k+  cdata = noTrans cdata++-- ** Class 'Textable'+class Textable repr where+  type TextConstraint repr a :: Constraint+  type TextConstraint repr a = TextConstraint (UnTrans repr) a+  default text :: Transformable repr => XML (UnTrans repr) =>+          TextConstraint (UnTrans repr) a => repr (a -> k) k+  text :: TextConstraint repr a => repr (a -> k) k+  text = noTrans text

@@ -0,0 +1,180 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Symantic.XML.Namespace where++import Control.Applicative (Alternative(..))+import Data.Bool+import Data.Eq (Eq(..))+import Data.Foldable (all)+import Data.Function (($), (.), id)+import Data.Functor (Functor(..), (<$>))+import Data.Hashable (Hashable(..))+import Data.Int (Int)+import Data.Maybe (Maybe(..), fromMaybe)+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String, IsString(..))+import GHC.Generics (Generic)+import Prelude (error)+import Text.Show (Show(..), showsPrec, showChar, showString)+import qualified Data.Char.Properties.XMLCharProps as XC+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.Text.Lazy as TL++-- * Type 'QName'+-- | Qualified name.+data QName+ =   QName+ {   qNameSpace :: Namespace -- ^ eg. "http://www.w3.org/1999/XSL/Transform"+ ,   qNameLocal :: NCName    -- ^ eg. "stylesheet"+ } deriving (Eq, Ord, Generic)+instance Show QName where+  showsPrec _p QName{..} =+    (if TL.null $ unNamespace qNameSpace then id+    else showChar '{' . showString (TL.unpack $ unNamespace qNameSpace) . showChar '}'+    ) . showsPrec 10 qNameLocal+instance IsString QName where+  -- NCName's fromString will raise an error.+  fromString "" = QName "" ""+  fromString full@('{':rest) =+    case List.break (== '}') rest of+     (_, "")     -> error $ "Invalid XML Clark notation: "<>show full+     (ns, local) -> QName (fromString ns) $ fromString $ List.drop 1 local+  fromString local = QName "" $ fromString local+instance Hashable QName++qName :: NCName -> QName+qName = QName (Namespace "")+{-# INLINE qName #-}++-- ** Type 'Namespace'+newtype Namespace = Namespace { unNamespace :: TL.Text }+ deriving (Eq, Ord, Show, Hashable)+instance IsString Namespace where+  fromString s =+    if all (\c -> XC.isXmlChar c && c `List.notElem` ("'\"<&"::String)) s+    then Namespace (fromString s)+    else error $ "Invalid XML Namespace: "<>show s++xmlns_xml, xmlns_xmlns, xmlns_xsd, xmlns_empty :: Namespace+xmlns_xml   = Namespace "http://www.w3.org/XML/1998/namespace"+xmlns_xmlns = Namespace "http://www.w3.org/2000/xmlns/"+xmlns_xsd   = Namespace "http://www/w3/org/2001/XMLSchema-datatypes"+xmlns_empty = Namespace ""++-- *** Type 'Namespaces'+data Namespaces prefix+ =   Namespaces+ {   namespaces_prefixes :: HM.HashMap Namespace prefix+ ,   namespaces_default  :: Namespace+ } deriving (Show)+instance Functor Namespaces where+  fmap f (Namespaces ps d) = Namespaces (fmap f ps) d+instance Semigroup (Namespaces NCName) where+  x <> y = Namespaces+   { namespaces_prefixes = namespaces_prefixes x <> namespaces_prefixes y+   , namespaces_default  = namespaces_default x+   }+instance Semigroup (Namespaces (Maybe NCName)) where+  x <> y = Namespaces+   { namespaces_prefixes = HM.unionWith (<|>) (namespaces_prefixes x) (namespaces_prefixes y)+   , namespaces_default  = namespaces_default x+   }+instance Monoid (Namespaces NCName) where+  mempty  = Namespaces HM.empty xmlns_empty+  mappend = (<>)+instance Monoid (Namespaces (Maybe NCName)) where+  mempty  = Namespaces HM.empty xmlns_empty+  mappend = (<>)++defaultNamespaces :: IsString prefix => Namespaces prefix+defaultNamespaces = Namespaces+ { namespaces_prefixes = HM.fromList+   [ (xmlns_xml  , "xml")+   , (xmlns_xmlns, "xmlns")+   ]+ , namespaces_default = xmlns_empty+ }++prefixifyQName :: Namespaces NCName -> QName -> PName+prefixifyQName Namespaces{..} QName{..} = PName+ { pNameSpace =+  if qNameSpace == namespaces_default+  then Nothing+  else HM.lookup qNameSpace namespaces_prefixes+ , pNameLocal = qNameLocal+ }++-- ** Type 'PName'+-- | Prefixed 'NCName'+data PName+ =   PName+ {   pNameSpace :: Maybe NCName -- ^ eg. Just "xml"+ ,   pNameLocal :: NCName       -- ^ eg. "stylesheet"+ } deriving (Eq, Ord, Generic)+instance Show PName where+  showsPrec p PName{pNameSpace=Nothing, ..} =+    showsPrec p pNameLocal+  showsPrec _p PName{pNameSpace=Just p, ..} =+    showsPrec 10 p .+    showChar ':' .+    showsPrec 10 pNameLocal+instance IsString PName where+  fromString "" = PName Nothing "" -- NCName's fromString will raise an error.+  fromString s =+    case List.break (== ':') s of+     (_, "")    -> PName Nothing $ fromString s+     (p, local) -> PName (Just $ fromString p) (fromString $ List.drop 1 local)++pName :: NCName -> PName+pName = PName Nothing+{-# INLINE pName #-}++-- ** Type 'NCName'+-- | Non-colonized name.+newtype NCName = NCName { unNCName :: TL.Text }+ deriving (Eq, Ord, Hashable)+instance Show NCName where+  showsPrec _p = showString . TL.unpack . unNCName+instance IsString NCName where+  fromString s =+    fromMaybe (error $ "Invalid XML NCName: "<>show s) $+    ncName (TL.pack s)++ncName :: TL.Text -> Maybe NCName+ncName t =+  case TL.uncons t of+   Just (c, cs)+    | XC.isXmlNCNameStartChar c+    , TL.all XC.isXmlNCNameChar cs+    -> Just (NCName t)+   _ -> Nothing++poolNCNames :: [NCName]+poolNCNames =+  [ NCName $ TL.pack ("ns"<>show i)+  | i <- [1 :: Int ..]+  ]++freshNCName :: HS.HashSet NCName -> NCName+freshNCName ps = List.head $ poolNCNames List.\\ HS.toList ps++freshifyNCName :: HS.HashSet NCName -> NCName -> NCName+freshifyNCName ns (NCName n) =+  let ints = [1..] :: [Int] in+  List.head+   [ fresh+   | suffix <- mempty : (show <$> ints)+   , fresh <- [ NCName $ n <> TL.pack suffix]+   , not $ fresh `HS.member` ns+   ]

@@ -0,0 +1,640 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Symantic.XML.Read where++import Control.Applicative as Alternative (Applicative(..), Alternative(..), optional)+import Control.Monad (Monad(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Data.Bool+import Data.Either (Either(..))+import Data.Eq (Eq(..))+import Data.Foldable (Foldable(..), all)+import Data.Function (($), (.), const, id, flip)+import Data.Functor (Functor(..), (<$>))+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (Maybe(..), maybe, isNothing, maybeToList)+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..))+import Data.Proxy (Proxy(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String, IsString(..))+import Data.Tuple (fst)+import Data.Void (Void)+import Numeric.Natural (Natural)+import Prelude ((+), Integer, undefined)+import System.IO (IO, FilePath)+import Text.Show (Show(..))+import qualified Data.Char as Char+import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.TreeSeq.Strict as TS+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P+import qualified Text.Megaparsec.Char.Lexer as P+import qualified Text.Megaparsec.Internal as P++import Symantic.Base+import Symantic.XML.Language+import Symantic.XML.RelaxNG.Language+import Symantic.XML.Tree++-- | Main reading function.+read ::+ Read FileSourced Void (x->x) a ->+ FilePath ->+ IO (Either String a)+read rng path =+  readTree path >>= \case+   Left  err -> return $ Left err+   Right xml -> return $ runRead rng xml++-- | Like 'readWithRelaxNG' but on a 'FileSourcedTrees'.+runRead ::+ Read FileSourced Void (x->x) a ->+ FileSourcedTrees ->+ Either String a+runRead rng xml =+  case P.runParser (unRead rng) "" (mempty, xml) of+   Left err -> Left $ foldMap parseErrorTextPretty $ P.bundleErrors err+   Right a -> Right $ a id++-- * Type 'ReadStream'+type ReadStream src =+ ( HM.HashMap QName (src EscapedAttr)+ , Trees src+ )++-- | Take one 'Node' from the 'ReadStream',+-- or fallback to an attribute, or 'Nothing'.+-- +-- Use 'pTokenAttr' to take only attributes.+take1_ ::+ UnSource src =>+ (Node (src EscapedAttr) -> Bool) ->+ ReadStream src ->+ Maybe ( P.Token (ReadStream src)+       , ReadStream src )+take1_ isIgnoredNode s@(attrs, trees) =+  go trees+  where+  go trs =+    case Seq.viewl trs of+     Seq.EmptyL+      | null attrs -> Nothing+      | otherwise -> Just (Left attrs, s)+     t Seq.:< ts ->+      case unSource (TS.unTree t) of+       n | isIgnoredNode n -> go ts+         | otherwise -> Just (Right t, (attrs, ts))+        -- Note that having an ignored node+        -- can split a text into two 'NodeText's.+        -- Not sure if it would be better to unify them.++-- ** Type 'ReadConstraints'+-- | Convenient alias to be less verbose.+type ReadConstraints src =+ ( Ord (src (Node (src EscapedAttr)))+ , Ord (src EscapedAttr)+ , UnSource src+ , NoSource src+ , SourceOf src+ , Show (Source src)+ , Show (src String)+ , Functor src+ )++instance ReadConstraints src => P.Stream (ReadStream src) where+  type Token (ReadStream src) = Either+   (HM.HashMap QName (src EscapedAttr))+   (Tree src)+  type Tokens (ReadStream src) = ReadStream src+  take1_ = take1_ isIgnoredNode+    where+    isIgnoredNode = \case+     NodeComment{} -> True+     NodePI{}      -> True+     _ -> False+  showTokens _s toks =+    orList $+    mconcat $+    toList $ showTree <$> toks+    where+    showSource :: src String -> String+    showSource sa =+      let src = sourceOf sa in+      if nullSource @src src+      then unSource sa+      else unSource sa<>" at "<>show src+    showTree = \case+     Left as ->+      (\(an, av) -> showSource $ ("(attribute "<>show an<>")") <$ av)+       <$> List.sortOn fst (HM.toList as)+     Right (TS.Tree nod ts) ->+      pure $+      showSource . (<$ nod) $+      case unSource nod of+       NodeElem n _as -> "(element "<>show n<>")"+       NodeText{} ->+        case Seq.viewl ts of+         TS.Tree tn _ Seq.:< _+          | NodeText lit <- unSource tn ->+          -- Abuse the encoding to detect expected 'literal'+          -- using nested 'NodeText'+          "\""<>TL.unpack (unescapeText lit)<>"\""+         _ -> "text"+       NodeComment _c -> "comment"+       NodePI n _t    -> "(processing-instruction "<>show n<>")"+       NodeCDATA _t   -> "cdata"+  -- Useless methods for validating an XML AST+  takeN_ = undefined+  tokensToChunk = undefined+  chunkToTokens = undefined+  chunkLength = undefined+  takeWhile_ = undefined+  reachOffset = undefined+  reachOffsetNoLine = undefined++-- * Type 'Read'+newtype Read src e f k+ =      Read+ {    unRead :: P.Parsec e (ReadStream src) (f->k) }++instance+ ( Ord err+ , ReadConstraints src+ ) => Emptyable (Read src err) where+  empty = Read $ id <$ P.eof+instance+ ( Ord err+ , ReadConstraints src+ ) => Unitable (Read src err) where+  unit = Read $ return ($ ())+instance+ ( Ord err+ , ReadConstraints src+ ) => Voidable (Read src err) where+  void _a (Read x) = Read $+    (\a2b2k b -> a2b2k (\_a -> b)) <$> x+instance+ ( Ord err+ , ReadConstraints src+ ) => Constant (Read src err) where+  constant a = Read $ return ($ a)+instance+ ( Ord err+ , ReadConstraints src+ ) => Permutable (Read src err) where+  type Permutation (Read src err) =+    ReadPerm src err+  permutable (ReadPerm ma p) = Read $ do+    r <- Alternative.optional p+    unRead $+      case r of+       Just perms -> permutable perms+       Nothing ->+        Read $ maybe+         -- Not 'empty' here so that 'P.TrivialError'+         -- has the unexpected token.+         (P.token (const Nothing) Set.empty)+         return ma+  noPerm = ReadPerm Nothing Alternative.empty+  perm (Read x) =+    ReadPerm Nothing $ (<$> x) $ \a ->+      ReadPerm (Just a) Alternative.empty+  permWithDefault d (Read x) =+    ReadPerm (Just ($ d)) $ (<$> x) $ \a ->+      ReadPerm (Just a) Alternative.empty+instance+ ( Ord err+ , ReadConstraints src+ ) => Composable (Read src err) where+  Read x <.> Read y = Read $+    x >>= \a2b -> (. a2b) <$> y+instance+ ( Ord err+ , ReadConstraints src+ ) => Tupable (Read src err) where+  Read x <:> Read y = Read $+    consCont (,) <$> x <*> y+instance+ ( Ord err+ , ReadConstraints src+ ) => Eitherable (Read src err) where+  Read x <+> Read y = Read $+    mapCont Left <$> P.try x <|>+    mapCont Right <$> y+{-+instance+ ( Ord err+ , ReadConstraints src+ ) => Routable (Read src err) where+  Read x <!> Read y = Read $+    (\a2k (a:!:_b) -> a2k a) <$> P.try x <|>+    (\b2k (_a:!:b) -> b2k b) <$> y+-}+instance+ ( Ord err+ , ReadConstraints src+ ) => Optionable (Read src err) where+  option (Read x) = Read $+    P.try x <|> return id+  optional (Read x) = Read $+    mapCont Just <$> P.try x <|>+    return ($ Nothing)+instance+ ( Ord err+ , ReadConstraints src+ ) => Repeatable (Read src err) where+  many0 (Read x) = Read $ concatCont <$> many x+  many1 (Read x) = Read $ concatCont <$> some x+instance+ ( Ord err+ , ReadConstraints src+ ) => Dimapable (Read src err) where+  dimap a2b _b2a (Read r) =+    Read $ (\k b2k -> k (b2k . a2b)) <$> r+instance+ ( Ord err+ , ReadConstraints src+ ) => Dicurryable (Read src err) where+  dicurry (_::proxy args) constr _destr (Read x) = Read $ do+    f <- x+    return $ \r2k ->+      f (mapresultN @args r2k constr)+instance+ ( Ord err+ , ReadConstraints src+ , Textable (Read src err)+ ) => XML (Read src err) where+  namespace _nm _ns = Read (return id)+  element n p = Read $ do+    s <- P.token check $ Set.singleton $+      P.Tokens $ pure expected+    unRead $ readNested p s+    where+    expected = Right $ TS.tree0 $ noSource $ NodeElem n mempty+    check = \case+     Right (TS.Tree nod ts)+      | NodeElem e as <- unSource nod+      , e == n+      -> Just (removeXMLNS as, removeSpaces ts)+     _ -> Nothing+  attribute n p = Read $ do+    v <- pTokenAttr n $ Set.singleton $+      P.Tokens $ pure expected+    unRead $ readNested p+     (mempty, pure (TS.tree0 (NodeText . EscapedText . unEscapedAttr <$> v)))+    -- Cast 'EscapedAttr' into 'EscapedText'+    -- because it will be read, not written,+    -- hence only given to 'unescapeText'+    -- which is the same than 'unescapeAttr'.+    where+    expected = Left $ HM.singleton n $ noSource ""+  literal lit = Read $ do+    P.token check $ Set.singleton $ P.Tokens $ pure expected+    where+    expected = Right $+      TS.Tree (noSource $ NodeText "")+       (pure $ TS.tree0 (noSource $ NodeText $ escapeText lit))+    check = \case+     Right (Tree0 nod)+      | NodeText t <- unSource nod+      , unescapeText t == lit+      -> Just id+     _ -> Nothing+  pi n = Read $ do+    v <- pTokenPI n $ Set.singleton $+      P.Tokens $ pure expected+    return ($ v)+    where+    expected = Right $ TS.tree0 $ noSource $ NodePI n mempty+  cdata = Read $+    P.token check $ Set.singleton $+      P.Tokens $ pure expected+    where+    expected = Right $ TS.tree0 $ noSource $ NodeCDATA mempty+    check = \case+     Right (Tree0 nod)+      | NodeCDATA v <- unSource nod+      -> Just ($ v)+     _ -> Nothing+  comment = Read $+    P.token check $ Set.singleton $+      P.Tokens $ pure expected+    where+    expected = Right $ TS.tree0 $ noSource $ NodeComment mempty+    check = \case+     Right (Tree0 nod)+      | NodeComment v <- unSource nod+      -> Just ($ v)+     _ -> Nothing+instance Ord err => Textable (Read FileSourced err) where+  type TextConstraint (Read FileSourced err) a =+    DecodeText a+  text :: forall a k repr.+   repr ~ Read FileSourced err =>+   TextConstraint repr a => repr (a->k) k+  text = Read $ do+    Sourced (FileSource (src :| _)) txt <-+      P.token check $ Set.singleton $ P.Tokens $ pure expected+    case P.runParser @Void (decodeText @a <* P.eof) "" (unescapeText txt) of+     Right a -> return ($ a)+     Left errs -> P.fancyFailure $ Set.singleton $ P.ErrorFail $+      (`foldMap` P.bundleErrors errs) $ \err ->+        fileRange_path src <> ":" <>+        show (fileRange_begin src <> Offset (P.errorOffset err)) <> "\n" <>+        P.parseErrorTextPretty err+    where+    expected = Right $ TS.tree0 $ noSource $ NodeText $ EscapedText mempty+    check = \case+     Right (Tree0 nod)+      | NodeText t <- unSource nod+      -> Just (t <$ nod)+     _ -> Nothing+instance+ ( Ord err+ , ReadConstraints src+ , Textable (Read src err)+ , Definable (Read src err)+ ) => RelaxNG (Read src err) where+  elementMatch nc p = Read $ do+    (n,s) <- P.token check $ Set.singleton $+      P.Tokens $ pure expected+    ((\a2k n2a -> a2k (n2a n)) <$>) $+      unRead (readNested p s)+    where+    expected = Right $ TS.tree0 $ noSource $+      NodeElem (qName (NCName (TLB.toLazyText+       (textify (mempty::Namespaces NCName,(infixN0,SideL),nc)))))+       mempty+    check = \case+     Right (TS.Tree nod ts)+      | NodeElem n as <- unSource nod+      , matchNameClass nc n+      -> Just (n, (removeXMLNS as, removeSpaces ts))+     _ -> Nothing+  attributeMatch nc p = Read $ do+    (an,av) <- pTokenAttrNameClass nc $ Set.singleton $+      P.Tokens $ pure expected+    ((\a2k n2a -> a2k (n2a an)) <$>) $+      unRead $ readNested p+       (mempty, pure (TS.tree0 (NodeText . EscapedText . unEscapedAttr <$> av)))+    -- See comment in 'attribute' about the cast to 'EscapedText' here.+    where+    expected = Left $ HM.singleton (qName (NCName n)) $ noSource ""+      where n = TLB.toLazyText $ textify (mempty::Namespaces NCName,(infixN0,SideL),nc)+instance Ord err => Definable (Read FileSourced err) where+  define n = Read . P.label n . unRead++-- ** Type 'ReadPerm'+data ReadPerm (src :: * -> *) err a k+ =   ReadPerm+ {   readPerm_result :: !(Maybe (a->k))+ ,   readPerm_parser :: P.Parsec err (ReadStream src) (ReadPerm src err a k)+ }++instance+ (Ord err, ReadConstraints src) =>+ Dimapable (ReadPerm src err) where+  dimap a2b b2a (ReadPerm a ma) =+    ReadPerm (merge <$> a)+    (dimap a2b b2a `fmap` ma)+    where merge = \a2k2k b2k -> a2k2k $ b2k . a2b+instance+ (Ord err, ReadConstraints src) =>+ Dicurryable (ReadPerm src err) where+  dicurry ::+   forall args r k proxy.+   CurryN args =>+   proxy args ->+   (args-..->r) -> -- construction+   (r->Tuples args) -> -- destruction+   ReadPerm src err (args-..->k) k ->+   ReadPerm src err (r->k) k+  dicurry px constr destr (ReadPerm a ma) =+    ReadPerm (merge <$> a)+     (dicurry px constr destr `fmap` ma)+    where+    merge args2k2k = \r2k ->+      args2k2k $ mapresultN @args r2k constr+instance+ (Ord err, ReadConstraints src) =>+ Composable (ReadPerm src err) where+  lhs@(ReadPerm da pa) <.> rhs@(ReadPerm db pb) =+    ReadPerm a $+      lhsAlt <|> rhsAlt+    where+    lhsAlt = (<.> rhs) <$> pa+    rhsAlt = (lhs <.>) <$> pb+    a = flip (.) <$> da <*> db+instance+ (Ord err, ReadConstraints src) =>+ Tupable (ReadPerm src err) where+  lhs@(ReadPerm da pa) <:> rhs@(ReadPerm db pb) =+    ReadPerm a (lhsAlt <|> rhsAlt)+    where+    lhsAlt = (<:> rhs) <$> pa+    rhsAlt = (lhs <:>) <$> pb+    a = consCont (,) <$> da <*> db+instance Definable (ReadPerm src err) where+  define _n = id++-- * Utils++concatCont :: [(a->k)->k] -> ([a]->k)->k+concatCont = List.foldr (consCont (:)) ($ [])+{-# INLINE concatCont #-}++consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k+consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)+{-# INLINE consCont #-}++mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)+mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)+{-# INLINE mapCont #-}++-- | An adaptation of megaparsec's 'pToken',+-- to handle 'attribute' properly.+pTokenAttr ::+ forall e m src.+ ReadConstraints src =>+ QName ->+ Set.Set (P.ErrorItem (P.Token (ReadStream src))) ->+ P.ParsecT e (ReadStream src) m (src EscapedAttr)+pTokenAttr an ps = P.ParsecT $ \st@(P.State s@(attrs,trees) o pst de) cok _ _ eerr ->+  case HM.lookup an attrs of+   Just av -> cok av (P.State (HM.delete an attrs, trees) (o+1) pst de) mempty+   Nothing -> eerr (P.TrivialError o us ps) st+    where+    us = case P.take1_ s of+     Nothing -> pure P.EndOfInput+     Just (t,_ts) -> (Just . P.Tokens . pure) t+{-# INLINE pTokenAttr #-}++-- | An adaptation of megaparsec's 'pToken',+-- to handle 'attributeMatch' properly.+pTokenAttrNameClass ::+ forall e m src.+ ReadConstraints src =>+ NameClass ->+ Set.Set (P.ErrorItem (P.Token (ReadStream src))) ->+ P.ParsecT e (ReadStream src) m (QName, src EscapedAttr)+pTokenAttrNameClass nc ps = P.ParsecT $ \st@(P.State s@(attrs,trees) o pst de) cok _ _ eerr ->+  case HM.toList attrs of+   a@(an,_av):_ | matchNameClass nc an -> cok a (P.State (HM.delete an attrs, trees) (o+1) pst de) mempty+   _ -> eerr (P.TrivialError o us ps) st+    where+    us = case P.take1_ s of+     Nothing -> pure P.EndOfInput+     Just (t,_ts) -> (Just . P.Tokens . pure) t+{-# INLINE pTokenAttrNameClass #-}++-- | An adaptation of megaparsec's 'pToken',+-- to handle 'pi' since 'NodePI' is ignored by 'P.take1_'.+pTokenPI ::+ forall e m src.+ UnSource src =>+ PName ->+ Set.Set (P.ErrorItem (P.Token (ReadStream src))) ->+ P.ParsecT e (ReadStream src) m TL.Text+pTokenPI n ps = P.ParsecT $ \st@(P.State s o pst de) cok _ _ eerr ->+  case take1 s of+   Nothing -> eerr (P.TrivialError o us ps) st+    where us = pure P.EndOfInput+   Just (c, cs)+    | Right (TS.Tree nod _) <- c+    , NodePI pn pv <- unSource nod+    , pn == n -> cok pv (P.State cs (o+1) pst de) mempty+    | otherwise -> eerr (P.TrivialError o us ps) st+      where+      us = case take1 s of+       Nothing -> pure P.EndOfInput+       Just (t,_ts) -> (Just . P.Tokens . pure) t+  where+  take1 = take1_ isIgnoredNode+    where+    isIgnoredNode = \case+     NodeComment{} -> True+     _ -> False++removeXMLNS ::+ HM.HashMap QName (src EscapedAttr) ->+ HM.HashMap QName (src EscapedAttr)+removeXMLNS =+  HM.filterWithKey $ \an _av ->+    case an of+     QName "" "xmlns" -> False+     QName ns _l -> ns /= xmlns_xmlns++removeSpaces :: UnSource src => Trees src -> Trees src+removeSpaces xs =+  if (`all` xs) $ \case+   TS.Tree nod _ts+    | NodeText (EscapedText et) <- unSource nod ->+    all (\case+     EscapedPlain t -> TL.all Char.isSpace t+     _ -> False) et+   _ -> True+  then (`Seq.filter` xs) $ \case+   TS.Tree nod _ts+    | NodeText EscapedText{} <- unSource nod -> False+   _ -> True+  else xs++-- | @readNested v xs@ returns a 'Read' parsing @xs@ entirely with @v@,+-- updating 'P.stateOffset' and re-raising any exception.+readNested ::+ Ord err =>+ ReadConstraints src =>+ Read src err f a ->+ ReadStream src ->+ Read src err f a+readNested (Read p) stateInput = Read $ do+  st <- P.getParserState+  (st', res) <- lift $ P.runParserT' (p <* P.eof) st+   { P.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++-- * Class 'DecodeText'+class DecodeText a where+  decodeText :: P.Parsec Void TL.Text a+instance DecodeText String where+  decodeText = TL.unpack . fst <$>+    P.match (P.skipMany P.anySingle)+instance DecodeText Text.Text where+  decodeText = TL.toStrict . fst <$>+    P.match (P.skipMany P.anySingle)+instance DecodeText TL.Text where+  decodeText = fst <$>+    P.match (P.skipMany P.anySingle)+instance DecodeText Bool where+  decodeText =+    False <$ (P.string "false" <|> P.string "0") <|>+    True  <$ (P.string "true"  <|> P.string "1")+instance DecodeText Integer where+  decodeText = P.signed (return ()) P.decimal+instance DecodeText Natural where+  decodeText = P.optional (P.char '+') *> P.decimal++-- * Megaparsec adaptations+-- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'node's.+parseErrorTextPretty ::+ P.ShowErrorComponent err =>+ P.ParseError (ReadStream FileSourced) err -> String+parseErrorTextPretty (P.TrivialError o us ps) =+  if isNothing us && Set.null ps+  then "unknown parse error\n"+  else+    (case us of+     Just P.Tokens{} -> ""+     _ ->+      -- FIXME: this is not informative enough,+      -- but P.EndOfInput can not carry a source location,+      -- and retraversing the XML tree cannot be done+      -- exactly as the parser did only knowing the Offset,+      -- because of attributes being permutable.+      "node #"<>show o<>"\n"+    ) <>+    messageItemsPretty "unexpected "+     (showErrorItem px <$> maybeToList us) <>+    messageItemsPretty "expecting "+     (showErrorItem px <$> Set.toAscList ps)+  where px = Proxy :: Proxy s+parseErrorTextPretty err = P.parseErrorTextPretty err++messageItemsPretty :: String -> [String] -> String+messageItemsPretty prefix ts+ | null ts = ""+ | otherwise = prefix <> orList ts <> "\n"++orList :: IsString s => Monoid s => [s] -> s+orList [] = mempty+orList [x] = x+orList [x,y] = x <> " or " <> y+orList xs = mconcat (List.intersperse ", " (List.init xs)) <> ", or " <> List.last xs++showErrorItem ::+ (s ~ ReadStream (Sourced (FileSource Offset))) =>+ Proxy s -> P.ErrorItem (P.Token s) -> String+showErrorItem px = \case+ P.Tokens ts   -> P.showTokens px ts+ P.Label label -> NonEmpty.toList label+ P.EndOfInput  -> "end-of-node"

@@ -0,0 +1,7 @@+module Symantic.XML.RelaxNG+ ( module Symantic.XML.RelaxNG.Language+ , module Symantic.XML.RelaxNG.Compact.Write+ ) where++import Symantic.XML.RelaxNG.Language+import Symantic.XML.RelaxNG.Compact.Write

@@ -0,0 +1,429 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE OverloadedStrings #-}+module Symantic.XML.RelaxNG.Compact.Write where++import Control.Applicative (Applicative(..), Alternative(..))+import Control.Monad (forM)+import Data.Bool+import Data.Eq (Eq(..))+import Data.Foldable (Foldable(..))+import Data.Function (($), (.), id, const)+import Data.Functor ((<$>))+import Data.Int (Int)+import Data.Maybe (Maybe(..), maybe, catMaybes, isNothing)+import Data.Monoid (Monoid(..))+import Data.Semigroup (Semigroup(..))+import Data.String (IsString(..), String)+import Numeric.Natural (Natural)+import Prelude (Integer)+import qualified Control.Monad.Trans.State.Strict as S+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB++import Symantic.Base.Fixity+import Symantic.XML.Language+import Symantic.XML.RelaxNG.Language++-- | Get textual rendition of given 'RNCWriteSyn'.+writeRNC :: RNCWriteSyn a k -> TL.Text+writeRNC = TLB.toLazyText . runRNCWriteSyn++-- | Get textual rendition of given 'RNCWriteSyn'.+runRNCWriteSyn :: RNCWriteSyn a k -> TLB.Builder+runRNCWriteSyn RNCWriteSyn{..} =+  mconcat $+  List.concat+   [ [ "default namespace = \""<>textify (namespaces_default rncWriteInh_namespaces)<>"\"\n"+     | not $ TL.null $ unNamespace (namespaces_default rncWriteInh_namespaces)+     ]+   , [ "namespace "<>textify p<>" = \""<>textify n<>"\"\n"+     | (Namespace n, NCName p) <-+      HM.toList (namespaces_prefixes rncWriteInh_namespaces)+     ]+   , Map.foldrWithKey+     (\n v -> ((textify n<>" = "<>v<>"\n") :)) []+     defs+   ]+  where+  RNCWriteState{..} = rncWriteSyn_state $ RNCWriteState mempty mempty+  defs :: Map.Map DefineName TLB.Builder+  defs = Map.mapMaybe ($ inh) rncWriteState_defines+  inh = RNCWriteInh+   { rncWriteInh_namespaces+   , rncWriteInh_op = (infixN0, SideL)+   , rncWriteInh_pair = pairParen+   }+  rncWriteInh_namespaces :: Namespaces NCName+  rncWriteInh_namespaces = rncWriteState_namespaces+   { namespaces_prefixes =+    (`S.evalState` HS.empty) $+      forM prefixByNamespace $ \mp -> do+        usedPrefixes <- S.get+        let+         freshPrefix = maybe+           (freshNCName usedPrefixes)+           (freshifyNCName usedPrefixes)+           mp+        S.modify' $ HS.insert freshPrefix+        pure freshPrefix+   }+  prefixByNamespace :: HM.HashMap Namespace (Maybe NCName)+  prefixByNamespace =+    -- Add default prefixes if their 'Namespace' is used.+    HM.union+     (HM.intersectionWith (<|>)+       (namespaces_prefixes rncWriteState_namespaces)+       (Just <$> namespaces_prefixes defaultNamespaces)) $+    namespaces_prefixes rncWriteState_namespaces++-- * Type 'RNCWriteState'+-- | Chained values.+data RNCWriteState+ =   RNCWriteState+ {   rncWriteState_namespaces :: Namespaces (Maybe NCName)+     -- ^ The 'Namespaces' used throughout the 'RelaxNG' schema.+ ,   rncWriteState_defines    :: Map.Map DefineName (RNCWriteInh -> Maybe TLB.Builder)+     -- ^ Used to avoid infinite recursion,+     -- by looking up the 'DefineName' of 'define'.+ }++-- * Type 'RNCWriteSyn'+-- | Synthetized (bottom-up) values.+data RNCWriteSyn a k+ =   RNCWriteSyn+ {   rncWriteSyn_state  :: Chained RNCWriteState+ ,   rncWriteSyn_schema :: RNCWriteInh -> Maybe TLB.Builder+ }+instance IsString (RNCWriteSyn a k) where+  fromString s = RNCWriteSyn+   { rncWriteSyn_state = id+   , rncWriteSyn_schema = const $+    if List.null s then Nothing+    else Just (textify s)+   }++-- | Like the @State st ()@ monad, but without @()@.+-- The name comme from chained-attribute from Attribute Grammar.+type Chained a = a -> a++coerceRNCWriteSyn :: RNCWriteSyn a k -> RNCWriteSyn a' k'+coerceRNCWriteSyn RNCWriteSyn{..} = RNCWriteSyn{..}+{-# INLINE coerceRNCWriteSyn #-}++pairRNCWriteInh ::+ Semigroup s => IsString s =>+ RNCWriteInh -> Infix -> Maybe s -> Maybe s+pairRNCWriteInh inh op s =+  if isPairNeeded (rncWriteInh_op inh) op+  then Just (fromString o<>" ")<>s<>Just (" "<>fromString c)+  else s+  where (o,c) = rncWriteInh_pair inh++-- ** Type 'RNCWriteInh'+-- Inherited (top-down) values.+data RNCWriteInh+ =   RNCWriteInh+ {   rncWriteInh_namespaces :: Namespaces NCName+ ,   rncWriteInh_op :: (Infix, Side)+ ,   rncWriteInh_pair :: Pair+ }++instance Emptyable RNCWriteSyn where+  empty = "empty"+instance Unitable RNCWriteSyn where+  unit = ""+instance Voidable RNCWriteSyn where+  void _a = coerceRNCWriteSyn+instance Constant RNCWriteSyn where+  constant _a = ""+instance Composable RNCWriteSyn where+  x <.> y = RNCWriteSyn+   (rncWriteSyn_state x . rncWriteSyn_state y) $ \inh ->+    let+     inh' side = inh+      { rncWriteInh_op   = (op, side)+      , rncWriteInh_pair = pairParen+      } in+    case rncWriteSyn_schema x (inh' SideL) of+     Nothing -> rncWriteSyn_schema y (inh' SideR)+     Just xw ->+      case rncWriteSyn_schema y (inh' SideR) of+       Nothing -> Just xw+       Just yw ->+        pairRNCWriteInh inh op $+          Just $ xw <> ", " <> yw+    where+    op = infixB SideL 2+instance Tupable RNCWriteSyn where+  x <:> y = coerceRNCWriteSyn x <.> coerceRNCWriteSyn y+instance Eitherable RNCWriteSyn where+  x <+> y = RNCWriteSyn+   (rncWriteSyn_state x . rncWriteSyn_state y) $ \inh ->+    pairRNCWriteInh inh op $+    rncWriteSyn_schema x inh+     { rncWriteInh_op   = (op, SideL)+     , rncWriteInh_pair = pairParen+     } <>+    Just " | " <>+    rncWriteSyn_schema y inh+     { rncWriteInh_op   = (op, SideR)+     , rncWriteInh_pair = pairParen+     }+    where op = infixB SideL 3+instance Optionable RNCWriteSyn where+  option = coerceRNCWriteSyn . optional . coerceRNCWriteSyn+  optional w = w{ rncWriteSyn_schema = \inh ->+    pairRNCWriteInh inh op $+    rncWriteSyn_schema w inh+     { rncWriteInh_op   = (op, SideL)+     , rncWriteInh_pair = pairParen+     } <> Just "?"+    }+    where op = infixN 9+instance Dimapable RNCWriteSyn where+  dimap _a2b _b2a = coerceRNCWriteSyn+instance Dicurryable RNCWriteSyn where+  dicurry _args _constr _destr = coerceRNCWriteSyn+instance Repeatable RNCWriteSyn where+  many0 w = w{ rncWriteSyn_schema = \inh ->+    pairRNCWriteInh inh op $+    rncWriteSyn_schema w inh+     { rncWriteInh_op   = (op, SideL)+     , rncWriteInh_pair = pairParen+     } <> Just "*"+    }+    where op = infixN 9+  many1 w = w{ rncWriteSyn_schema = \inh ->+    pairRNCWriteInh inh op $+    rncWriteSyn_schema w inh+     { rncWriteInh_op   = (op, SideL)+     , rncWriteInh_pair = pairParen+     } <> Just "+"+    }+    where op = infixN 9+instance Textable RNCWriteSyn where+  type TextConstraint RNCWriteSyn a = RNCText a+  text :: forall a k. TextConstraint RNCWriteSyn a => RNCWriteSyn (a -> k) k+  text = RNCWriteSyn+   { rncWriteSyn_state = \st ->+    case HM.lookup+     (qNameSpace (rncText_qname @a))+     (namespaces_prefixes (rncWriteState_namespaces st)) of+     Just{} -> st+     Nothing ->+      let ns = qNameSpace (rncText_qname @a) in+      if ns == xmlns_empty then st else st+       { rncWriteState_namespaces = (rncWriteState_namespaces st)+        { namespaces_prefixes =+        HM.insertWith (<|>) ns Nothing $+        namespaces_prefixes (rncWriteState_namespaces st) } }+   , rncWriteSyn_schema = \inh ->+    let n = rncText_qname @a in+    let t = if TL.null (unNamespace (qNameSpace n))+            then textify (qNameLocal n)+            else textify (prefixifyQName (rncWriteInh_namespaces inh) n)+    in if null (rncText_params @a)+    then Just t+    else+      pairRNCWriteInh inh (infixN 8) $+      Just $+      t<>" {"<>Map.foldMapWithKey+       (\k v -> " "<>textify k<>" = \""<>textify v<>"\"")+       (rncText_params @a)<>" }"+   }+instance XML RNCWriteSyn where+  namespace mp ns = RNCWriteSyn+   { rncWriteSyn_state = \st -> st+    { rncWriteState_namespaces =+      let nss = rncWriteState_namespaces st in+      Namespaces+       { namespaces_prefixes =+        HM.insertWith (<|>) ns mp (namespaces_prefixes nss)+       , namespaces_default =+        if isNothing mp+        then ns+        else namespaces_default nss+       }+    }+   , rncWriteSyn_schema = const Nothing+   }+  element n w = w+   { rncWriteSyn_state = \st ->+    rncWriteSyn_state w $ st+     { rncWriteState_namespaces = (rncWriteState_namespaces st)+       { namespaces_prefixes =+        -- Insert this 'qNameSpace' even if this is the default namespace,+        -- because the default namespace here may not end up+        -- being the global default namespace+        -- if there is a default 'namespace' declaration after this one.+        -- at worse this will just add a superfluous ns# declaration+        -- in the schema rendering.+        HM.insertWith (<|>) (qNameSpace n) Nothing+         (namespaces_prefixes (rncWriteState_namespaces st)) } }+   , rncWriteSyn_schema = \inh ->+    pairRNCWriteInh inh (infixN 8) $+    Just ("element "+     <> textify (prefixifyQName (rncWriteInh_namespaces inh) n)+     <> " {")+    <> rncWriteSyn_schema w inh+     { rncWriteInh_op   = (infixN0, SideR)+     , rncWriteInh_pair = pairBrace+     }+    <> Just "}"+   }+  attribute n w = w+   { rncWriteSyn_state = \st ->+    rncWriteSyn_state w $+    if qNameSpace n == xmlns_empty then st else st+     { rncWriteState_namespaces = (rncWriteState_namespaces st)+       { namespaces_prefixes =+        HM.insertWith (<|>) (qNameSpace n) Nothing+         (namespaces_prefixes (rncWriteState_namespaces st)) } }+   , rncWriteSyn_schema = \inh ->+    pairRNCWriteInh inh (infixN 8) $+    Just ("attribute "+     -- The namespace name for an unprefixed attribute name always has no value.+     <> textify (prefixifyQName (rncWriteInh_namespaces inh){namespaces_default=xmlns_empty} n)+     <> " {")+    <> rncWriteSyn_schema w inh+     { rncWriteInh_op   = (infixN0, SideR)+     , rncWriteInh_pair = pairBrace+     }+    <> Just "}"+   }+  literal lit = RNCWriteSyn+   { rncWriteSyn_state = id+   , rncWriteSyn_schema = \_inh -> Just ("\""<>textify lit<>"\"")+   }+  pi _n   = ""+  comment = ""+  cdata   = ""+instance Definable RNCWriteSyn where+  define n w = w+   { rncWriteSyn_state = \st ->+    let defs = rncWriteState_defines st in+    case Map.lookup n defs of+     Nothing ->+      rncWriteSyn_state w $ st+       { rncWriteState_defines =+        Map.insert n (rncWriteSyn_schema w) defs+       }+     Just{} -> st+   , rncWriteSyn_schema = const $ Just $ textify n+   }+instance Permutable RNCWriteSyn where+  type Permutation RNCWriteSyn = RNCWriteSynPerm+  permutable (RNCWriteSynPerm ps) = RNCWriteSyn+   { rncWriteSyn_state = List.foldl' (.) id (rncWriteSyn_state <$> ps)+   , rncWriteSyn_schema = case ps of+     [] -> const Nothing+     _ -> \inh ->+      case+        List.intersperse " & " $+        catMaybes $ (<$> ps) $ \w ->+          rncWriteSyn_schema w inh{rncWriteInh_op=(op, SideL)}+      of+       [] -> Nothing+       [x] -> Just x+       xs -> pairRNCWriteInh inh op $ Just $ mconcat xs+   }+    where op = infixR 3+  perm = RNCWriteSynPerm . pure+  noPerm = RNCWriteSynPerm []+  permWithDefault _def p = RNCWriteSynPerm+   [coerceRNCWriteSyn (optional p)]+instance RelaxNG RNCWriteSyn where+  elementMatch nc w = w+   { rncWriteSyn_state = \st ->+    rncWriteSyn_state w $ st+     { rncWriteState_namespaces = (rncWriteState_namespaces st)+       { namespaces_prefixes =+        namespacesNameClass nc <>+        namespaces_prefixes (rncWriteState_namespaces st)+       } }+   , rncWriteSyn_schema = \inh ->+    pairRNCWriteInh inh (infixN 8) $+    Just ("element "+     <> textify (rncWriteInh_namespaces inh, (infixN0,SideL), nc)+     <> " ")+    <> rncWriteSyn_schema w inh+     { rncWriteInh_op = (infixN 9, SideR)+     , rncWriteInh_pair = pairBrace+     }+   }+  attributeMatch nc w = w+   { rncWriteSyn_state = \st ->+    let nss = HM.delete xmlns_empty $ namespacesNameClass nc in+    rncWriteSyn_state w $+    if null nss then st else st+     { rncWriteState_namespaces = (rncWriteState_namespaces st)+       { namespaces_prefixes =+        HM.unionWith (<|>) nss $+        namespaces_prefixes (rncWriteState_namespaces st)+       } }+   , rncWriteSyn_schema = \inh ->+    pairRNCWriteInh inh (infixN 8) $+    Just ("attribute "+     <> textify ( (rncWriteInh_namespaces inh){namespaces_default=xmlns_empty}+              , (infixN0,SideL)+              , nc )+     <> " ")+    <> rncWriteSyn_schema w inh+     { rncWriteInh_op   = (infixN 9, SideR)+     , rncWriteInh_pair = pairBrace+     }+   }++-- ** Type 'RNCWriteSynPerm'+newtype RNCWriteSynPerm a k+ =      RNCWriteSynPerm+ {      rncWriteSynPerm_alternatives :: [RNCWriteSyn a k]+        -- ^ Collect alternatives for rendering+        -- them all at once in 'runPermutation'.+ }+instance Composable RNCWriteSynPerm where+  RNCWriteSynPerm x <.> RNCWriteSynPerm y =+    RNCWriteSynPerm $+      (coerceRNCWriteSyn <$> x) <>+      (coerceRNCWriteSyn <$> y)+instance Dimapable RNCWriteSynPerm where+  dimap _a2b _b2a (RNCWriteSynPerm x) =+    RNCWriteSynPerm (coerceRNCWriteSyn <$> x)+instance Tupable RNCWriteSynPerm where+  RNCWriteSynPerm x <:> RNCWriteSynPerm y =+    RNCWriteSynPerm $+      (coerceRNCWriteSyn <$> x) <>+      (coerceRNCWriteSyn <$> y)+instance Definable RNCWriteSynPerm where+  define n (RNCWriteSynPerm ps) =+    RNCWriteSynPerm $ pure $+      coerceRNCWriteSyn $ define n $+        permutable $ RNCWriteSynPerm $+          coerceRNCWriteSyn <$> ps++-- * Class 'RNCText'+class RNCText a where+  rncText_qname  :: QName+  rncText_params :: Map.Map TL.Text TL.Text+  rncText_params = mempty+instance RNCText String where+  rncText_qname = QName (Namespace "") "text"+instance RNCText Text.Text where+  rncText_qname = QName (Namespace "") "text"+instance RNCText TL.Text where+  rncText_qname = QName (Namespace "") "text"+instance RNCText Bool where+  rncText_qname = QName xmlns_xsd "boolean"+instance RNCText Int where+  rncText_qname = QName xmlns_xsd "int"+instance RNCText Integer where+  rncText_qname = QName xmlns_xsd "integer"+instance RNCText Natural where+  rncText_qname = QName xmlns_xsd "nonNegativeInteger"

@@ -0,0 +1,119 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}+module Symantic.XML.RelaxNG.Language where++import Data.Bool+import Data.Eq (Eq(..))+import Data.Function (($), (.))+import Data.Maybe (Maybe(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String, IsString(..))+import Prelude (error)+import Text.Show (Show(..))+import qualified Data.List as List+import qualified Data.HashMap.Strict as HM++import Symantic.Base.Fixity+import Symantic.XML.Language++-- * Class 'RelaxNG'+class+ ( XML repr+ , Permutable repr+ , Definable repr+ ) => RelaxNG repr where+  default elementMatch ::+                  Transformable repr =>+                  RelaxNG (UnTrans repr) =>+                  NameClass -> repr a k -> repr (QName -> a) k+  -- | Like 'element' but with a matching pattern+  -- instead of a specific 'QName'.+  elementMatch :: NameClass -> repr a k -> repr (QName -> a) k+  elementMatch nc = noTrans . elementMatch nc . unTrans+  default attributeMatch ::+                  Transformable repr =>+                  RelaxNG (UnTrans repr) =>+                  NameClass -> repr a k -> repr (QName -> a) k+  -- | Like 'attribute' but with a matching pattern+  -- instead of a specific 'QName'.+  attributeMatch :: NameClass -> repr a k -> repr (QName -> a) k+  attributeMatch nc = noTrans . attributeMatch nc . unTrans++-- * Type 'Definable'+class Definable repr where+  -- | @(define name expr)@ declares a rule named @(name)@+  -- and matching the 'RelaxNG' schema @(expr)@.+  --+  -- Useful for rendering the 'RelaxNG' schema,+  -- and necessary to avoid infinite recursion when+  -- printing a 'RelaxNG' schema calling itself recursively.+  --+  -- WARNING: 'DefineName's must be unique inside+  -- a whole 'RelaxNG' schema.+  define :: DefineName -> repr a k -> repr a k+  default define ::+   Transformable repr => RelaxNG (UnTrans repr) =>+   DefineName -> repr f k -> repr f k+  define n = noTrans . define n . unTrans++-- ** Type 'DefineName'+type DefineName = String++-- * Type 'NameClass'+data NameClass+ =   NameClass_Any+ |   (:::) Namespace NCName+ |   (:*) Namespace+ |   (:-:) NameClass NameClass+ |   (:|:) NameClass NameClass++infix 9 :::+infixr 2 :|:+infixl 6 :-:++(*:*) :: NameClass+(*:*) = NameClass_Any++-- | @('matchNameClass' nc q)@ returns 'True' iif. the 'NameClass' @(nc)@ matches the 'QName' @(q)@.+matchNameClass :: NameClass -> QName -> Bool+matchNameClass NameClass_Any _q = True+matchNameClass (ns:::nl) q = qNameSpace q == ns && qNameLocal q == nl+matchNameClass ((:*) ns) q = qNameSpace q == ns+matchNameClass (x:|:y) q = matchNameClass x q || matchNameClass y q+matchNameClass (x:-:y) q = matchNameClass x q && not (matchNameClass y q)++-- | Return the namespaces used by the given 'NameClass'+namespacesNameClass :: NameClass -> HM.HashMap Namespace (Maybe NCName)+namespacesNameClass = \case+ NameClass_Any -> HM.empty+ ns ::: _ -> HM.singleton ns Nothing+ (:*) ns -> HM.singleton ns Nothing+ x :|: y -> namespacesNameClass x <> namespacesNameClass y+ x :-: y -> namespacesNameClass x <> namespacesNameClass y++-- | Only parses "*", "{some-namespace}*", or "{some-namespace}some-localname".+instance IsString NameClass where+  fromString = \case+   "*" -> NameClass_Any+   full@('{':rest) ->+    case List.break (== '}') rest of+     (_, "") -> error $ "Invalid XML Clark notation: "<>show full+     (ns, "*") -> (:*) (fromString ns)+     (ns, local) -> fromString ns ::: fromString (List.drop 1 local)+   s -> let QName ns nl = fromString s in ns:::nl+instance Textify (Namespaces NCName, (Infix,Side), NameClass) where+  textify (nss,po,nc) = case nc of+   NameClass_Any -> textify '*'+   ns:::nl ->+    textify (prefixifyQName nss (QName ns nl))+   (:*) ns ->+    case HM.lookup ns (namespaces_prefixes nss) of+     Nothing -> "{"<>textify ns<>"}*"+     Just p -> textify p <> ":*"+   x :|: y -> pairIfNeeded pairParen po op $+    textify (nss,(op,SideL),x) <> " | " <> textify (nss,(op,SideR),y)+    where op = infixR 2+   x :-: y ->+    pairIfNeeded pairParen po op $+    textify (nss,(op,SideL),x) <> " - " <> textify (nss,(op,SideR),y)+    where op = infixL 6

@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+module Symantic.XML.Text where++import Data.Bool+import Data.Char (Char)+import Data.Eq (Eq(..))+import Data.Foldable (Foldable(..))+import Data.Function (($), (.))+import Data.Maybe (Maybe(..))+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..))+import Data.Semigroup (Semigroup(..))+import Data.Sequence (Seq)+import Data.String (IsString(..), String)+import Text.Show (Show(..))+import qualified Data.Char as Char+import qualified Data.List as List+import qualified Data.Sequence as Seq+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB++import Symantic.XML.Namespace++-- * Type 'Escaped'+-- | 'EscapedText' lexemes.+data Escaped+ =   EscapedPlain     TL.Text+ |   EscapedEntityRef EntityRef+ |   EscapedCharRef   CharRef+ deriving (Eq, Ord, Show)++-- ** Type 'EntityRef'+data EntityRef+ =   EntityRef+ {   entityRef_name  :: NCName+ ,   entityRef_value :: TL.Text+ } deriving (Eq, Ord, Show)++entityRef_lt,+ entityRef_gt,+ entityRef_amp,+ entityRef_quot,+ entityRef_apos :: EntityRef+entityRef_lt   = EntityRef (NCName "lt") "<"+entityRef_gt   = EntityRef (NCName "gt") ">"+entityRef_amp  = EntityRef (NCName "amp") "&"+entityRef_quot = EntityRef (NCName "quot") "\""+entityRef_apos = EntityRef (NCName "apos") "'"++-- ** Type 'CharRef'+newtype CharRef = CharRef Char+ deriving (Eq, Ord, Show)++-- * Type 'EscapedText'+newtype EscapedText = EscapedText (Seq Escaped)+ deriving (Eq, Ord, Show)++instance IsString EscapedText where+  fromString = escapeText . fromString++unEscapedText :: EscapedText -> Seq Escaped+unEscapedText (EscapedText et) = et+{-# INLINE unEscapedText #-}++escapeText :: TL.Text -> EscapedText+escapeText s =+  EscapedText $+  -- Add '>' to escape "]]>" without adding a 'TL.replace'.+  case TL.span (`List.notElem` ("<&>"::String)) s of+   (t, r) | TL.null t -> escape r+          | otherwise -> EscapedPlain t Seq.<| escape r+  where+  escape t = case TL.uncons t of+   Nothing -> mempty+   Just (c, cs) -> escapeTextChar c Seq.<| et+     where EscapedText et = escapeText cs++escapeTextChar :: Char -> Escaped+escapeTextChar = \case+ '<'  -> EscapedEntityRef entityRef_lt+ '&'  -> EscapedEntityRef entityRef_amp+  -- Add '>' to escape "]]>".+ '>'  -> EscapedEntityRef entityRef_gt+ c    -> EscapedPlain $ TL.singleton c++unescapeText :: EscapedText -> TL.Text+unescapeText (EscapedText et) = (`foldMap` et) $ \case+ EscapedPlain t -> t+ EscapedEntityRef EntityRef{..} -> entityRef_value+ EscapedCharRef (CharRef c) -> TL.singleton c++-- * Type 'EscapedAttr'+newtype EscapedAttr = EscapedAttr (Seq Escaped)+ deriving (Eq, Ord, Show)++instance IsString EscapedAttr where+  fromString = escapeAttr . fromString++unEscapedAttr :: EscapedAttr -> Seq Escaped+unEscapedAttr (EscapedAttr et) = et+{-# INLINE unEscapedAttr #-}++escapeAttr :: TL.Text -> EscapedAttr+escapeAttr s =+  EscapedAttr $+  case TL.span (`List.notElem` ("<&\""::String)) s of+   (t, r) | TL.null t -> escape r+          | otherwise -> EscapedPlain t Seq.<| escape r+  where+  escape t = case TL.uncons t of+   Nothing -> mempty+   Just (c, cs) -> escapeAttrChar c Seq.<| et+     where EscapedAttr et = escapeAttr cs++escapeAttrChar :: Char -> Escaped+escapeAttrChar = \case+ '<'  -> EscapedEntityRef entityRef_lt+ '&'  -> EscapedEntityRef entityRef_amp+ -- Remove '\'' because 'textifyAttr' uses '"' for quoting.+ -- '\'' -> EscapedEntityRef entityRef_apos+ '"'  -> EscapedEntityRef entityRef_quot+ c    -> EscapedPlain $ TL.singleton c++unescapeAttr :: EscapedAttr -> TL.Text+unescapeAttr (EscapedAttr et) = unescapeText (EscapedText et)++-- * Class 'Textify'+class Textify a where+  textify :: a -> TLB.Builder+instance Textify Char.Char where+  textify = TLB.singleton+instance Textify String where+  textify = TLB.fromString+instance Textify TL.Text where+  textify = TLB.fromLazyText+instance Textify NCName where+  textify = textify . unNCName+instance Textify PName where+  textify PName{..} =+    case pNameSpace of+     Nothing -> textify pNameLocal+     Just p -> textify p<>":"<> textify pNameLocal+instance Textify Namespace where+  textify = textify . unNamespace+instance Textify EntityRef where+  textify EntityRef{..} = "&"<>textify entityRef_name<>";"+instance Textify CharRef where+  textify (CharRef c) = "&#"<>textify (show (Char.ord c))<>";"+instance Textify EscapedText where+  textify (EscapedText et) = (`foldMap` et) $ \case+   EscapedPlain     t -> textify t+   EscapedEntityRef r -> textify r+   EscapedCharRef   r -> textify r+instance Textify EscapedAttr where+  textify (EscapedAttr et) = "\""<>txt<>"\""+    where+    txt = (`foldMap` et) $ \case+     EscapedPlain     t -> textify t+     EscapedEntityRef r -> textify r+     EscapedCharRef   r -> textify r++textifyAttr :: PName -> EscapedAttr -> TLB.Builder+textifyAttr n v = " "<>textify n<>"="<>textify v

@@ -0,0 +1,11 @@+module Symantic.XML.Tree+ ( module Symantic.XML.Tree.Source+ , module Symantic.XML.Tree.Data+ , module Symantic.XML.Tree.Read+ , module Symantic.XML.Tree.Write+ ) where++import Symantic.XML.Tree.Source+import Symantic.XML.Tree.Data+import Symantic.XML.Tree.Read+import Symantic.XML.Tree.Write

@@ -0,0 +1,197 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Symantic.XML.Tree.Data+ ( module Symantic.XML.Tree.Data+ , TS.unTree+ , TS.subTrees+ ) where++import Control.Applicative (Applicative(..))+import Data.Bool+import Data.Either (Either(..))+import Data.Eq (Eq(..))+import Data.Foldable (Foldable(..))+import Data.Function (($), id)+import Data.Functor ((<$>))+import Data.Functor.Identity (Identity(..))+import Data.Maybe (Maybe(..))+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..))+import Data.Semigroup (Semigroup(..))+import Prelude (error)+import Text.Show (Show(..))+import qualified Data.HashMap.Strict as HM+import qualified Data.Sequence as Seq+import qualified Data.Text.Lazy as TL+import qualified Data.TreeSeq.Strict as TS++import Symantic.Base+import Symantic.XML.Language+import Symantic.XML.RelaxNG.Language+import Symantic.XML.Write+import Symantic.XML.Tree.Source++-- * Type 'Tree'+type Tree src = TS.Tree (src (Node (src EscapedAttr)))++-- ** Type 'Trees'+type Trees src = TS.Trees (src (Node (src EscapedAttr)))++pattern Tree0 :: a -> TS.Tree a+pattern Tree0 a <- TS.Tree a (null -> True)+  where Tree0 a = TS.Tree a Seq.empty++-- ** Type 'Node'+data Node attr+   = NodeElem    QName (HM.HashMap QName attr) -- ^ Node.+   | NodePI      PName TL.Text -- ^ Leaf (except for @<?xml?>@ which has 'NodePI' children.+   | NodeText    EscapedText   -- ^ Leaf.+   | NodeComment TL.Text       -- ^ Leaf.+   | NodeCDATA   TL.Text       -- ^ Leaf.+   deriving (Eq, Ord, Show)++-- * Type 'TreeData'+newtype TreeData params k+ =      TreeData+ {    unTreeData :: ( HM.HashMap QName (Identity EscapedAttr) ->+                      TL.Text ->+                      Trees Identity -> k+                    ) -> params }++tree :: TreeData callers (Trees Identity) -> callers+tree (TreeData callers) = callers (\_as _txt ts -> ts)++type SourcedTree  src = Tree  (Sourced src)+type SourcedTrees src = Trees (Sourced src)+type FileSourcedTree  = SourcedTree  (FileSource Offset)+type FileSourcedTrees = SourcedTrees (FileSource Offset)++-- | Unify two 'Trees', merging border 'NodeText's if any.+union ::+ Semigroup (Sourced src EscapedText) =>+ SourcedTrees src -> SourcedTrees src -> SourcedTrees src+union x y =+  case (Seq.viewr x, Seq.viewl y) of+   (xs Seq.:> x0, y0 Seq.:< ys) ->+    case (x0,y0) of+     (  Tree0 (Sourced sx (NodeText tx))+      , Tree0 (Sourced sy (NodeText ty)) ) ->+      xs `union`+      Seq.singleton (Tree0 $ (NodeText <$>) $+        Sourced sx tx <> Sourced sy ty) `union`+      ys+     _ -> x <> y+   (Seq.EmptyR, _) -> y+   (_, Seq.EmptyL) -> x++unions ::+ Semigroup (Sourced src EscapedText) =>+ Foldable f => f (SourcedTrees src) -> SourcedTrees src+unions = foldl' union mempty++instance Emptyable TreeData where+  empty = TreeData (\k -> k mempty mempty mempty)+instance Unitable TreeData where+  unit = TreeData (\k () -> k mempty mempty mempty)+instance Voidable TreeData where+  void a (TreeData x) = TreeData (`x` a)+instance Dimapable TreeData where+  dimap _a2b b2a (TreeData x) = TreeData $ \k b ->+    x k (b2a b)+instance Dicurryable TreeData where+  dicurry (_::proxy args) _construct destruct (TreeData x) = TreeData $ \k r ->+    uncurryN @args (x k) (destruct r)+instance Composable TreeData where+  TreeData x <.> TreeData y = TreeData $ \k ->+    x (\ax vx tx -> y (\ay vy ty -> k (ax<>ay) (vx<>vy) (tx<>ty)))+instance Tupable TreeData where+  TreeData x <:> TreeData y = TreeData $ \k (a,b) ->+    x (\ax vx tx -> y (\ay vy ty -> k (ax<>ay) (vx<>vy) (tx<>ty)) b) a+instance Eitherable TreeData where+  TreeData x <+> TreeData y = TreeData $ \k -> \case+   Left  a -> x k a+   Right b -> y k b+instance Constant TreeData where+  constant _a = TreeData $ \k _a -> k mempty mempty mempty+instance Optionable TreeData where+  option = id+  optional (TreeData x) = TreeData $ \k ->+    \case+     Nothing -> k mempty mempty mempty+     Just a -> x k a+{-+instance Routable TreeData where+  TreeData x <!> TreeData y = TreeData $ \k ->+    x k :!: y k+-}+instance Repeatable TreeData where+  many0 (TreeData x) = TreeData $ \k -> \case+   [] -> k mempty mempty mempty+   a:as -> x (\ax vx tx ->+    unTreeData (many0 (TreeData x))+     (\aas vas tas -> k (ax<>aas) (vx<>vas) (tx<>tas)) as) a+  many1 (TreeData x) = TreeData $ \k -> \case+   [] -> k mempty mempty mempty+   a:as -> x (\ax vx tx ->+    unTreeData (many1 (TreeData x))+     (\aas vas tas -> k (ax<>aas) (vx<>vas) (tx<>tas)) as) a+instance Textable TreeData where+  type TextConstraint TreeData a = EncodeText a+  text = TreeData $ \k v ->+    let t = encodeText v in+    k mempty t $ pure $+      TS.Tree (Identity (NodeText (escapeText t))) mempty+instance XML TreeData where+  namespace _nm _ns = empty+  element n (TreeData x) = TreeData $ \k ->+    x $ \as _txt ts ->+      k mempty mempty $ pure $+        TS.Tree (Identity (NodeElem n as)) ts+  attribute n (TreeData x) = TreeData $ \k ->+    x $ \as txt _ts ->+      k (HM.insert n (Identity (escapeAttr txt)) as) mempty mempty+  literal lit = TreeData $ \k ->+    k mempty lit $ pure $+      TS.Tree (Identity (NodeText (escapeText lit))) mempty+  pi n = TreeData $ \k v ->+    k mempty mempty $ pure $+      TS.Tree (Identity (NodePI n v)) mempty+  comment = TreeData $ \k v ->+    k mempty mempty $ pure $+      TS.Tree (Identity (NodeComment v)) mempty+  cdata = TreeData $ \k v ->+    k mempty mempty $ pure $+      TS.Tree (Identity (NodeCDATA v)) mempty+instance Permutable TreeData where+  type Permutation TreeData = TreeDataPerm TreeData+  permutable = unTreeDataPerm+  perm = TreeDataPerm+  noPerm = TreeDataPerm empty+  permWithDefault _a = TreeDataPerm+instance Definable TreeData where+  define _n = id+instance RelaxNG TreeData where+  elementMatch nc x = TreeData $ \k n ->+    if matchNameClass nc n+    then error "elementMatch: given QName does not match expected NameClass"+    else unTreeData (element n x) k+  attributeMatch nc x = TreeData $ \k n ->+    if matchNameClass nc n+    then error "attributeMatch: given QName does not match expected NameClass"+    else unTreeData (attribute n x) k++-- ** Type 'TreeDataPerm'+newtype TreeDataPerm repr xml k+ =      TreeDataPerm+ {    unTreeDataPerm :: repr xml k }+instance Transformable (TreeDataPerm repr) where+  type UnTrans (TreeDataPerm repr) = repr+  noTrans = TreeDataPerm+  unTrans = unTreeDataPerm+instance Dimapable (TreeDataPerm TreeData)+instance Composable (TreeDataPerm TreeData)+instance Tupable (TreeDataPerm TreeData)

@@ -0,0 +1,628 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Symantic.XML.Tree.Read where++import Control.Arrow (left)+import Control.Applicative (Applicative(..), Alternative(..))+import Control.Monad (Monad(..), void, unless, forM)+import Data.Bool+import Data.Char (Char)+import Data.Either (Either(..))+import Data.Eq (Eq(..))+import Data.Foldable (Foldable(..))+import Data.Function (($), (.), const)+import Data.Functor ((<$>), (<$))+import Data.Maybe (Maybe(..), maybe, catMaybes)+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..))+import Data.Semigroup (Semigroup(..))+import Data.List.NonEmpty (NonEmpty(..))+import Data.String (String, IsString(..))+import Prelude (Num(..), Enum(..), Bounded(..), Integer, toInteger)+import System.IO (FilePath, IO)+import Text.Show (Show(..))+import qualified Control.Exception as Exn+import qualified Control.Monad.Trans.Reader as R+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Char as Char+import qualified Data.Char.Properties.XMLCharProps as XC+import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import qualified Data.Set as Set+import qualified Data.Sequence as Seq+import qualified Data.Text.Encoding.Error as TL+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.TreeSeq.Strict as TS+import qualified System.IO.Error as IO+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P++import Symantic.Base ()+import Symantic.XML.Language hiding (void)+import Symantic.XML.Tree.Source+import Symantic.XML.Tree.Data++readTree :: FilePath -> IO (Either String FileSourcedTrees)+readTree path =+  readUtf8 path >>= \case+   Left err -> return $ Left $ show err+   Right txt -> return $+    case runReadTree path txt of+     Right a -> Right a+     Left err -> Left $ P.errorBundlePretty err++runReadTree ::+ FilePath -> TL.Text ->+ Either (P.ParseErrorBundle TL.Text Error)+        FileSourcedTrees+runReadTree = P.runParser $ R.runReaderT p_document defaultReadTreeInh++-- * Type 'ErrorRead'+data ErrorRead+ =   ErrorRead_IO IO.IOError+ |   ErrorRead_Unicode TL.UnicodeException+ deriving (Show)+readUtf8 :: FilePath -> IO (Either ErrorRead TL.Text)+readUtf8 path =+  (left ErrorRead_Unicode . TL.decodeUtf8' <$> BSL.readFile path)+  `Exn.catch` \e ->+    if IO.isAlreadyInUseError e+    || IO.isDoesNotExistError e+    || IO.isPermissionError   e+    then return $ Left $ ErrorRead_IO e+    else IO.ioError e++-- * Type 'ReadTree'+-- | Convenient alias.+type ReadTree e s a =+ ReadTreeConstraints e s a =>+ R.ReaderT ReadTreeInh (P.Parsec e s) a++-- ** Type 'ReadTreeConstraints'+type ReadTreeConstraints e s a =+ ( P.Stream s+ , P.Token s ~ Char+ , Ord e+ , IsString (P.Tokens s)+ , P.ShowErrorComponent e+ )++-- ** Type 'ReadTreeInh'+data ReadTreeInh+ =   ReadTreeInh+ {   readTreeInh_source     :: FileSource Offset+ ,   readTreeInh_ns_scope   :: HM.HashMap NCName Namespace+ ,   readTreeInh_ns_default :: Namespace+ } deriving (Show)++defaultReadTreeInh :: ReadTreeInh+defaultReadTreeInh = ReadTreeInh+ { readTreeInh_source = FileSource $ pure $+  FileRange mempty mempty mempty+ , readTreeInh_ns_scope = HM.fromList+   [ ("xml"  , xmlns_xml)+   , ("xmlns", xmlns_xmlns)+   ]+ , readTreeInh_ns_default = ""+ }++p_Offset :: ReadTree e s Offset+p_Offset = Offset <$> P.getOffset+{-# INLINE p_Offset #-}++p_Sourced :: ReadTree e s a -> ReadTree e s (Sourced (FileSource Offset) a)+p_Sourced pa = do+  ReadTreeInh{readTreeInh_source} <- R.ask+  b <- P.getParserState+  let fileRange_path = P.sourceName $ P.pstateSourcePos $ P.statePosState b+  let fileRange_begin = Offset $ P.stateOffset b+  a <- pa+  e <- P.getParserState+  let fileRange_end = Offset $ P.stateOffset e+  return $ Sourced (setSource FileRange{..} readTreeInh_source) a++setSource :: FileRange pos -> FileSource pos -> FileSource pos+setSource fileRange (FileSource (_curr:|next)) = FileSource (fileRange:|next)++-- | Like 'p_Sourced' but uncoupled (through the use of 'p_SourcedEnd') for more flexibility.+p_SourcedBegin :: ReadTree e s a -> ReadTree e s a+p_SourcedBegin pa = do+  b <- P.getParserState+  let fileRange_path  = P.sourceName $ P.pstateSourcePos $ P.statePosState b+  let fileRange_begin = Offset $ P.stateOffset b+  let fileRange_end   = fileRange_begin+  (`R.local` pa) $ \inh@ReadTreeInh{..} ->+    inh{ readTreeInh_source = setSource FileRange{..} readTreeInh_source }++-- | WARNING: only to be used within a 'p_SourcedBegin'.+p_SourcedEnd :: ReadTree e s (a -> Sourced (FileSource Offset) a)+p_SourcedEnd = do+  ReadTreeInh{..} <- R.ask+  e <- P.getParserState+  let fileRange_end = Offset $ P.stateOffset e+  return $ Sourced $+     (\(FileSource (curr:|path)) -> FileSource (curr{fileRange_end}:|path))+     readTreeInh_source++-- * Type 'Error'+data Error+ =   Error_CharRef_invalid Integer+     -- ^ Well-formedness constraint: Legal Character.+     --+     -- Characters referred to using character references MUST match the production for Char.+ |   Error_EntityRef_unknown NCName+     -- ^ Well-formedness constraint: Entity Declared+     --+     -- In a document without any DTD, a document with only an internal DTD+     -- subset which contains no parameter entity references, or a document+     -- with " standalone='yes' ", for an entity reference that does not occur+     -- within the external subset or a parameter entity, the Name given in the+     -- entity reference MUST match that in an entity declaration that does not+     -- occur within the external subset or a parameter entity, except that+     -- well-formed documents need not declare any of the following entities:+     -- amp, lt, gt, apos, quot. The declaration of a general entity MUST+     -- precede any reference to it which appears in a default value in an+     -- attribute-list declaration.+     --+     -- Note that non-validating processors are not obligated to read and+     -- process entity declarations occurring in parameter entities or in the+     -- external subset; for such documents, the define that an entity must be+     -- declared is a well-formedness constraint only if standalone='yes'.+ |   Error_Closing_tag_unexpected QName QName+     -- ^ Well-formedness constraint: Element Type Match.+     --+     -- The Name in an element's end-tag MUST match the element type in the start-tag.+ |   Error_Attribute_collision QName+     -- ^ Well-formedness constraint: Unique Att Spec.+     --+     -- An attribute name MUST NOT appear more than once in the same start-tag or empty-element tag.+ |   Error_PI_reserved PName+     -- ^ The target names " XML ", " xml ", and so on are reserved for standardization.+ |   Error_Namespace_prefix_unknown NCName+     -- ^ Namespace constraint: Prefix Declared+     --+     -- The namespace prefix, unless it is xml or xmlns, MUST have been declared in a namespace declaration attribute in either the start-tag of the element where the prefix is used or in an ancestor element (i.e., an element in whose content the prefixed markup occurs). + |   Error_Namespace_empty NCName+     -- ^ Namespace constraint: No Prefix Undeclaring+     --+     -- In a namespace declaration for a prefix (i.e., where the NSAttName is a PrefixedAttName), the attribute value MUST NOT be empty.+ |   Error_Namespace_reserved Namespace+ |   Error_Namespace_reserved_prefix NCName+     -- ^ Namespace constraint: Reserved Prefixes and Namespace Names+     --+     -- The prefix xml is by definition bound to the namespace name+     -- http://www.w3.org/XML/1998/namespace. It MAY, but need not, be+     -- declared, and MUST NOT be bound to any other namespace name. Other+     -- prefixes MUST NOT be bound to this namespace name, and it MUST NOT be+     -- declared as the default namespace.+     --+     -- The prefix xmlns is used only to declare namespace bindings and is by+     -- definition bound to the namespace name http://www.w3.org/2000/xmlns/.+     -- It MUST NOT be declared . Other prefixes MUST NOT be bound to this+     -- namespace name, and it MUST NOT be declared as the default namespace.+     -- Element names MUST NOT have the prefix xmlns.+     --+     -- All other prefixes beginning with the three-letter sequence x, m, l, in+     -- any case combination, are reserved. This means that:+     --+     -- - users SHOULD NOT use them except as defined by later specifications+     -- - processors MUST NOT treat them as fatal errors.+ deriving (Eq,Ord,Show)+instance P.ShowErrorComponent Error where+  showErrorComponent = show++-- * Helpers+p_error :: e -> ReadTree e s a+p_error = P.fancyFailure . Set.singleton . P.ErrorCustom++p_quoted :: P.Tokens s ~ TL.Text => (Char -> ReadTree e s a) -> ReadTree e s a+p_quoted p =+  P.between (P.char '"') (P.char '"') (p '"') <|>+  P.between (P.char '\'') (P.char '\'') (p '\'')++p_until ::+ P.Tokens s ~ TL.Text =>+ (Char -> Bool) -> (Char, TL.Text) -> ReadTree e s TL.Text+p_until content (end, end_) =+  (TL.concat <$>) $ P.many $+    P.takeWhile1P Nothing (\c -> content c && c /= end) <|>+    P.try (TL.singleton <$> P.char end <* P.notFollowedBy (P.string end_))++p_until1 ::+ P.Tokens s ~ TL.Text =>+ (Char -> Bool) -> (Char, TL.Text) -> ReadTree e s TL.Text+p_until1 content (end, end_) =+  (TL.concat <$>) $ P.some $+    P.takeWhile1P Nothing (\c -> content c && c /= end) <|>+    P.try (TL.singleton <$> P.char end <* P.notFollowedBy (P.string end_))++-- * Document+p_document :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTrees+p_document = do+  ps <- p_prolog+  e  <- p_Element+  m  <- p_Miscs+  P.eof+  return (ps <> pure e <> m)++-- ** Prolog+p_prolog :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTrees+p_prolog = (<>)+ <$> P.option Seq.empty (pure <$> p_XMLDecl)+ <*> p_Miscs++-- ** Misc+p_Miscs :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTrees+p_Miscs = (Seq.fromList . catMaybes <$>) $ P.many $+  Just <$> p_Comment <|>+  Just <$> p_PI <|>+  Nothing <$ p_Spaces1++-- ** XMLDecl+p_XMLDecl :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_XMLDecl = do+  Sourced src as <- p_Sourced $ P.between (P.string "<?xml") (P.string "?>") $ do+    vi <- pure <$> p_VersionInfo+    ed <- P.option Seq.empty $ pure <$> p_EncodingDecl+    sd <- P.option Seq.empty $ pure <$> p_SDDecl+    p_Spaces+    return $ vi <> ed <> sd+  return $ TS.Tree (Sourced src $ NodePI "xml" "") as++p_VersionInfo :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_VersionInfo = do+  Sourced src v <- p_Sourced $ do+    P.try $ p_Spaces1 <* P.string "version"+    p_Eq+    p_quoted $ const $+      (<>)+       <$> P.string "1."+       <*> P.takeWhile1P Nothing Char.isDigit+  return $ TS.tree0 $ Sourced src $ NodePI "version" v++p_EncodingDecl :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_EncodingDecl = do+  Sourced src v <- p_Sourced $ do+    P.try $ p_Spaces1 <* P.string "encoding"+    p_Eq+    p_quoted $ const p_EncName+  return $ TS.tree0 $ Sourced src $ NodePI "encoding" v++p_EncName :: P.Tokens s ~ TL.Text => ReadTree Error s TL.Text+p_EncName = P.label "EncName" $ do+  P.notFollowedBy (P.satisfy $ not . isAlpha)+  P.takeWhile1P Nothing $ \c ->+    isAlpha c || Char.isDigit c ||+    c=='.' || c=='_' || c=='-'+  where isAlpha c = Char.isAsciiLower c || Char.isAsciiUpper c++-- *** SDDecl+p_SDDecl :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_SDDecl = do+  Sourced src v <- p_Sourced $ do+    P.try $ p_Spaces1 <* P.string "standalone"+    p_Eq+    p_quoted $ const $ P.string "yes" <|> P.string "no"+  return $ TS.tree0 $ Sourced src $ NodePI "standalone" v++-- ** CharData+p_CharData :: P.Tokens s ~ TL.Text => ReadTree e s EscapedText+p_CharData = P.label "[^<&]" $ escapeText <$>+  p_until1 (\c -> XC.isXmlChar c && c/='<' && c/='&') (']',"]>")++-- ** Comment+p_Comment :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_Comment = p_SourcedBegin $ P.string "<!--" *> p_Comment__+p_Comment_ :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_Comment_ = P.string "--" *> p_Comment__+p_Comment__:: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_Comment__ = do+  c <- p_until XC.isXmlChar ('-', "-")+  void $ P.string "-->"+  src <- p_SourcedEnd+  return $ TS.tree0 $ src $ NodeComment c++-- ** CDATA+p_CDSect :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_CDSect = p_SourcedBegin $ P.string "<![CDATA[" *> p_CDSect__+p_CDSect_ :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_CDSect_ = P.string "[CDATA[" *> p_CDSect__+p_CDSect__ :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_CDSect__ = do+  c <- p_until XC.isXmlChar (']', "]>")+  void $ P.string "]]>"+  src <- p_SourcedEnd+  return $ TS.tree0 $ src $ NodeCDATA c++-- ** PI+p_PI :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_PI = p_SourcedBegin $ P.string "<?" *> p_PI__+p_PI_ :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_PI_ = P.char '?' *> p_PI__+p_PI__ :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_PI__ = do+  n <- p_PITarget+  v <- P.option "" $ p_Spaces1 *> p_until XC.isXmlChar ('?', ">")+  void $ P.string "?>"+  src <- p_SourcedEnd+  return $ TS.tree0 $ src $ NodePI n v+p_PITarget :: P.Tokens s ~ TL.Text => ReadTree Error s PName+p_PITarget = do+  n <- p_PName+  case n of+   PName{pNameSpace=Nothing, pNameLocal=NCName l}+    | "xml" == TL.toLower l -> p_error $ Error_PI_reserved n+   _ -> return n++-- ** Element+p_Element :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_Element = p_SourcedBegin $ (P.char '<' *> p_Element_)+p_Element_ :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_Element_ = p_STag++-- *** STag+p_STag :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree+p_STag = do+  n  <- p_PName+  attrs <- P.many $ p_Attribute+  p_Spaces+  ro <- R.ask+  elemNS :: HM.HashMap NCName Namespace <-+    (HM.fromList . List.concat <$>) $ forM attrs $ \case+     (PName{..}, Sourced _ av)+      | ns <- Namespace $ unescapeAttr av+      , Nothing        <- pNameSpace+      , NCName "xmlns" <- pNameLocal ->+      -- Default namespace declaration+      case ns of+       _ |  ns == xmlns_xml   -- DOC: it MUST NOT be declared as the default namespace+         || ns == xmlns_xmlns -- DOC: it MUST NOT be declared as the default namespace+         -> p_error $ Error_Namespace_reserved ns+       _ -> return [(NCName "" , ns)]+      | ns <- Namespace $ unescapeAttr av+      , Just (NCName "xmlns") <- pNameSpace ->+      -- Namespace prefix declaration+      case unNCName pNameLocal of+       "xml" -- DOC: It MAY, but need not, be declared,+             -- and MUST NOT be bound to any other namespace name.+             | ns == xmlns_xml -> return []+             | otherwise -> p_error $ Error_Namespace_reserved_prefix pNameLocal+       "xmlns" -- DOC: It MUST NOT be declared+               -> p_error $ Error_Namespace_reserved_prefix pNameLocal+       local | "xml" <- TL.toLower $ TL.take 3 local -> return []+             -- DOC: All other prefixes beginning with the three-letter+             -- sequence x, m, l, in any case combination, are reserved.+             -- This means that: processors MUST NOT treat them as fatal errors.+       _ |  ns == xmlns_xml   -- DOC: Other prefixes MUST NOT be bound to this namespace name.+         || ns == xmlns_xmlns -- DOC: Other prefixes MUST NOT be bound to this namespace name.+         -> p_error $ Error_Namespace_reserved ns+       _ -> return [(pNameLocal, ns)]+      | otherwise -> return []+  let scopeNS = elemNS <> readTreeInh_ns_scope ro+  let defaultNS = HM.lookupDefault (readTreeInh_ns_default ro) (NCName "") scopeNS+  let+   lookupNamePrefix prefix =+    maybe (p_error $ Error_Namespace_prefix_unknown prefix) return $+    HM.lookup prefix scopeNS+  elemName :: QName <-+    -- Expand element's QName+    case pNameSpace n of+     Nothing -> return QName{qNameSpace=defaultNS, qNameLocal=pNameLocal n}+      -- DOC: If there is a default namespace declaration in scope,+      -- the expanded name corresponding to an unprefixed element name+      -- has the URI of the default namespace as its namespace name.+     Just prefix+      | NCName "xmlns" <- prefix ->+      -- DOC: Element names MUST NOT have the prefix xmlns.+      p_error $ Error_Namespace_reserved_prefix prefix+      | otherwise -> do+      ns <- lookupNamePrefix prefix+      return QName{qNameSpace=ns, qNameLocal=pNameLocal n}+  elemAttrs :: [(QName, FileSourced EscapedAttr)] <-+    -- Expand attributes' PName into QName+    forM attrs $ \(an, av) -> do+      ns <- maybe (return "") lookupNamePrefix $ pNameSpace an+      let qn = QName{qNameSpace=ns, qNameLocal=pNameLocal an}+      return (qn, av)+  -- Check for attribute collision+  let+   attrsByQName :: HM.HashMap QName [FileSourced EscapedAttr] =+    HM.fromListWith (<>) $ (<$> elemAttrs) $+     \(an, av) -> (an, [av])+  case HM.toList $ HM.filter (\x -> length x > 1) attrsByQName of+   (an, _):_ -> p_error $ Error_Attribute_collision an+   _ -> return ()+  content :: FileSourcedTrees <-+    mempty <$ P.string "/>" <|>+    R.local+     (const ro+       { readTreeInh_ns_scope   = scopeNS+       , readTreeInh_ns_default = defaultNS+       })+     (P.char '>' *> p_content <* p_ETag elemName)+  src <- p_SourcedEnd+  return $ TS.Tree (src $ NodeElem elemName (List.head <$> attrsByQName)) content++-- *** Attribute+-- | Note: despite the type, the returned 'FileSource'+-- encompasses also the attribute 'PName'.+-- It is pushed in the attribute value to fit the insertion+-- of the attribute into a 'HM.HashMap'.+p_Attribute :: P.Tokens s ~ TL.Text => ReadTree Error s (PName, FileSourced EscapedAttr)+p_Attribute =+  p_SourcedBegin $ do+    an <- P.try $ p_Spaces1 *> p_PName+    void p_Eq+    av <- p_AttrValue+    src <- p_SourcedEnd+    return (an, src av)++p_AttrValue :: P.Tokens s ~ TL.Text => ReadTree Error s EscapedAttr+p_AttrValue = p_quoted p_AttrValueText++p_AttrValueText :: P.Tokens s ~ TL.Text => Char -> ReadTree Error s EscapedAttr+p_AttrValueText q =+  EscapedAttr . Seq.fromList <$> P.many (+    p_Reference <|>+    -- Supplementary alternative to always escape the quote+    -- as expected by 'EscapedAttr'.+    (if q /= '\"' then EscapedEntityRef entityRef_quot <$ P.char '"' else P.empty) <|>+    EscapedPlain <$> P.label ("[^<&"<>[q]<>"]")+      (P.takeWhile1P Nothing $ \c ->+        XC.isXmlChar c &&+        c `List.notElem` (q:"<&")+      )+  )++-- * content+p_content :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTrees+p_content =+  (Seq.fromList <$>) $ P.many $+    (p_SourcedBegin $ do+      P.try $ P.char '<' *> P.notFollowedBy (P.char '/')+      p_Element_ <|> p_PI_ <|> (P.char '!' *> (p_Comment_ <|> p_CDSect_))+    )+    <|> (+    (TS.tree0 <$>) $+      p_Sourced $ NodeText . EscapedText . foldMap unEscapedText+       <$> P.some (+        p_CharData <|>+        EscapedText . pure <$> p_Reference+      )+    )++-- *** ETag+p_ETag :: P.Tokens s ~ TL.Text => QName -> ReadTree Error s ()+p_ETag expected = do+  got <- P.string "</" *> p_QName <* p_Spaces <* P.char '>'+  unless (got == expected) $+    p_error $ Error_Closing_tag_unexpected got expected++-- * PName+p_PName :: P.Tokens s ~ TL.Text => ReadTree e s PName+p_PName = do+  n <- p_NCName+  s <- P.optional $ P.try $ P.char ':' *> p_NCName+  return $ case s of+   Nothing -> PName{pNameSpace=Nothing, pNameLocal=n}+   Just l  -> PName{pNameSpace=Just n , pNameLocal=l}++-- * QName+p_QName :: P.Tokens s ~ TL.Text => ReadTree Error s QName+p_QName = do+  n <- p_NCName+  s <- P.optional $ P.try $ P.char ':' *> p_NCName+  ReadTreeInh{..} <- R.ask+  case s of+   Nothing -> return QName{qNameSpace=readTreeInh_ns_default, qNameLocal=n}+   Just l ->+    case HM.lookup n readTreeInh_ns_scope of+     Nothing -> p_error $ Error_Namespace_prefix_unknown n+     Just ns -> return QName{qNameSpace=ns, qNameLocal=l}++-- ** NCName+p_NCName :: P.Tokens s ~ TL.Text => ReadTree e s NCName+p_NCName = P.label "NCName" $ NCName+ <$  P.notFollowedBy (P.satisfy (not . XC.isXmlNCNameStartChar))+ <*> P.takeWhile1P Nothing XC.isXmlNCNameChar++-- * Reference+p_Reference :: P.Tokens s ~ TL.Text => ReadTree Error s Escaped+p_Reference =+  EscapedCharRef   <$> p_CharRef <|>+  EscapedEntityRef <$> p_EntityRef++-- ** EntityRef+p_EntityRef :: P.Tokens s ~ TL.Text => ReadTree Error s EntityRef+p_EntityRef = do+  ref <- P.char '&' *> p_NCName <* P.char ';'+  EntityRef ref <$> lookupEntityRef ref+  where+  -- Because entities are declared in the (unimplemented) DTD,+  -- only builtins entities are supported for now.+  lookupEntityRef (NCName "lt"  ) = pure "<"+  lookupEntityRef (NCName "gt"  ) = pure ">"+  lookupEntityRef (NCName "amp" ) = pure "&"+  lookupEntityRef (NCName "apos") = pure "'"+  lookupEntityRef (NCName "quot") = pure "\""+  lookupEntityRef n = p_error $ Error_EntityRef_unknown n++-- ** CharRef+p_CharRef :: P.Tokens s ~ TL.Text => ReadTree Error s CharRef+p_CharRef =+  do+    ref <- readHexadecimal+     <$  P.string "&#x"+     <*> P.some P.hexDigitChar+     <*  P.char ';'+    check ref+  <|> do+    ref <- readDecimal+     <$  P.string "&#"+     <*> P.some P.digitChar+     <*  P.char ';'+    check ref+  where+  check i =+    let c = toEnum (fromInteger i) in+    if i <= toInteger (fromEnum (maxBound::Char))+    && XC.isXmlChar c+    then pure $ CharRef c+    else p_error $ Error_CharRef_invalid i++readInt :: Integer -> String -> Integer+readInt base digits =+  sign * List.foldl' acc 0 (List.concatMap digToInt digits1)+  where+  acc q r = q*base + r+  (sign, digits1) =+    case digits of+     [] -> (1, digits)+     c:ds | c == '-'  -> (-1, ds)+          | c == '+'  -> ( 1, ds)+          | otherwise -> ( 1, digits)+  ord = toInteger . Char.ord+  digToInt c+   | Char.isDigit c      = [ord c - ord '0']+   | Char.isAsciiLower c = [ord c - ord 'a' + 10]+   | Char.isAsciiUpper c = [ord c - ord 'A' + 10]+   | otherwise           = []++readDecimal :: String -> Integer+readDecimal = readInt 10++readHexadecimal :: String -> Integer+readHexadecimal = readInt 16++-- * Char+p_Char :: P.Tokens s ~ TL.Text => ReadTree e s Char+p_Char = P.label "XmlChar" $ P.satisfy XC.isXmlCharCR <|> p_CRLF+{-# INLINE p_Char #-}++-- ** Space+-- | Map '\r' and '\r\n' to '\n'.+-- See: https://www.w3.org/TR/xml/#sec-line-ends+p_CRLF :: P.Tokens s ~ TL.Text => ReadTree e s Char+p_CRLF = P.char '\r' *> P.option '\n' (P.char '\n')++p_Space :: P.Tokens s ~ TL.Text => ReadTree e s Char+p_Space = P.label "space" $ P.satisfy XC.isXmlSpaceCharCR <|> p_CRLF+{-# INLINE p_Space #-}++p_Spaces :: P.Tokens s ~ TL.Text => ReadTree e s ()+p_Spaces = P.label "spaces" $ void $ P.takeWhileP Nothing XC.isXmlSpaceChar+{-# INLINE p_Spaces #-}++p_Spaces1 :: P.Tokens s ~ TL.Text => ReadTree e s ()+p_Spaces1 = P.label "spaces" $ void $ P.takeWhile1P Nothing XC.isXmlSpaceChar+{-# INLINE p_Spaces1 #-}++-- * Eq+p_separator :: P.Tokens s ~ TL.Text => Char -> ReadTree e s ()+p_separator c = P.try (() <$ p_Spaces <* P.char c) <* p_Spaces++p_Eq :: P.Tokens s ~ TL.Text => ReadTree e s ()+p_Eq = p_separator '='

@@ -0,0 +1,142 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Symantic.XML.Tree.Source where++import Control.Applicative (Applicative(..))+import Data.Bool+import Data.Eq (Eq(..))+import Data.Function (($), (.), const)+import Data.Functor (Functor)+import Data.Functor.Identity (Identity(..))+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..))+import Data.Semigroup (Semigroup(..))+import Data.List.NonEmpty (NonEmpty(..))+import Prelude (Num(..), Int)+import System.IO (FilePath)+import Text.Show (Show(..), shows, showChar, showParen, showString)++-- * Type family 'Source'+type family Source (src :: * -> *) :: *+type instance Source (Sourced src) = src+type instance Source Identity = ()++-- * Class 'NoSource'+class NoSource src where+  noSource :: a -> src a+  nullSource :: Source src -> Bool+  default nullSource ::+   Eq (Source src) =>+   SourceOf src =>+   Source src -> Bool+  nullSource = (==) (sourceOf @src (noSource @src ()))+instance NoSource Identity where+  noSource = Identity+  nullSource = const True++-- * Class 'UnSource'+class UnSource src where+  unSource :: src a -> a+instance UnSource Identity where+  unSource = runIdentity++-- * Class 'SourceOf'+class SourceOf src where+  sourceOf :: src a -> Source src+instance SourceOf Identity where+  sourceOf _ = ()++-- * Type 'FileSource'+newtype FileSource pos+ =      FileSource (NonEmpty (FileRange pos))+ deriving (Eq)+instance Show (FileRange pos) => Show (FileSource pos) where+  showsPrec _p (FileSource (s:|[])) = shows s+  showsPrec _p (FileSource (s:|s1:ss)) =+    shows s . showString "\n in " .+    shows (FileSource (s1:|ss))++-- ** Type 'FileSourced'+type FileSourced = Sourced (FileSource Offset)++-- ** Type 'FileRange'+data FileRange pos+ =   FileRange+ {   fileRange_path  :: FilePath+ ,   fileRange_begin :: pos+ ,   fileRange_end   :: pos+ } deriving (Eq, Ord)+instance Show (FileRange Offset) where+  showsPrec _p FileRange{..} =+    showString fileRange_path . showString " at char position " .+    showsPrec 10 fileRange_begin . showString " to " .+    showsPrec 10 fileRange_end+instance Show (FileRange LineColumn) where+  showsPrec _p FileRange{..} =+    showString fileRange_path . showString " at line:column position " .+    showsPrec 10 fileRange_begin . showString " to " .+    showsPrec 10 fileRange_end++-- *** Type 'Offset'+newtype Offset = Offset Int+ deriving (Eq, Ord)+instance Show Offset where+  showsPrec p (Offset o) = showsPrec p o+instance Semigroup Offset where+  Offset x <> Offset y = Offset (x+y)+instance Monoid Offset where+  mempty  = Offset 0+  mappend = (<>)++-- *** Type 'LineColumn'+-- | Absolute text file position.+data LineColumn = LineColumn+ { lineNum :: {-# UNPACK #-} Offset+ , colNum  :: {-# UNPACK #-} Offset+ } deriving (Eq, Ord)+instance Show LineColumn where+  showsPrec _p LineColumn{..} =+    showsPrec 11 lineNum .+    showChar ':' .+    showsPrec 11 colNum++-- * Type 'Sourced'+data Sourced src a+ =   Sourced+ {   source  :: src+ , unSourced :: a+ } deriving (Functor)+instance UnSource (Sourced src) where+  unSource = unSourced+instance NoSource (Sourced (FileSource Offset)) where+  noSource = Sourced $ FileSource $ pure $ FileRange mempty mempty mempty+instance SourceOf (Sourced src) where+  sourceOf (Sourced src _a) = src+-- | Ignore 'src'+instance Eq a => Eq (Sourced src a) where+  x == y = unSourced x == unSourced y+-- | Ignore 'src'+instance Ord a => Ord (Sourced src a) where+  x `compare` y = unSourced x `compare` unSourced y+instance+ (Show src, Show a, NoSource (Sourced src)) =>+ Show (Sourced src a) where+  showsPrec p (Sourced src a)+   | nullSource @(Sourced src) src = showsPrec p a+   | otherwise =+    showParen (p > 10) $+    showsPrec 10 a .+    showString " in " . showsPrec 10 src+instance Semigroup a => Semigroup (Sourced (FileSource Offset) a) where+  (<>)+   (Sourced rx@(FileSource (FileRange xf xb xe :|  xs)) x)+   (Sourced    (FileSource (FileRange yf yb ye :| _ys)) y)+   | xf == yf && xe == yb =+    Sourced (FileSource (FileRange xf xb ye :| xs)) $ x<>y+   | otherwise = Sourced rx (x<>y)

@@ -0,0 +1,199 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+module Symantic.XML.Tree.Write where++import Data.Bool+import Data.Eq (Eq(..))+import Data.Foldable (Foldable(..), all)+import Data.Function (($), (.), const)+import Data.Maybe (Maybe(..))+import Data.Monoid (Monoid(..))+import Data.Semigroup (Semigroup(..))+import Data.String (IsString(..))+import Data.Traversable (Traversable(..))+import Data.Tuple (fst)+import System.IO (IO, FilePath)+import qualified Control.Monad.Trans.State as S+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Char as Char+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.TreeSeq.Strict as TS++import Symantic.XML.Language+import Symantic.XML.Tree.Source+import Symantic.XML.Tree.Data+import Symantic.XML.Write++writeTree :: UnSource src => Trees src -> TL.Text+writeTree ts = TLB.toLazyText $ unTreeWrite (write_Trees ts) defaultWriteInh++writeTreeIndented :: UnSource src => TL.Text -> Trees src -> TL.Text+writeTreeIndented ind xs =+  TLB.toLazyText $+  unTreeWrite (write_Trees xs) defaultWriteInh+   { writeInh_indent_delta = ind }++writeFile :: FilePath -> TL.Text -> IO ()+writeFile fp = BSL.writeFile fp . TL.encodeUtf8++-- * Type 'TreeWrite'+newtype TreeWrite+ =      TreeWrite+ {    unTreeWrite :: WriteInh -> TLB.Builder+ }+instance Semigroup TreeWrite where+  TreeWrite x <> TreeWrite y = TreeWrite (x <> y)+instance Monoid TreeWrite where+  mempty = TreeWrite (const "")+  mappend = (<>)+instance IsString TreeWrite where+  fromString = TreeWrite . const . fromString++write_Trees :: UnSource src => Trees src -> TreeWrite+write_Trees = foldMap write_Tree++write_Tree :: UnSource src => Tree src -> TreeWrite+write_Tree (TS.Tree node elemChilds) = TreeWrite $ \inh ->+ case unSource node of+  NodeText et@(EscapedText t)+   -- Remove spaces when indenting+   | not $ TL.null (writeInh_indent_delta inh)+   , all (\case+     EscapedPlain p -> TL.all Char.isSpace p+     _ -> False+    ) t -> mempty+   | otherwise -> textify et+  NodePI pn pv ->+    writeInh_indent inh <>+    "<?"<>textify pn<>+    (case pn of+     -- Special case: the value of the "xml" PI is parsed+     -- as children NodePI+     "xml" -> foldMap (\case+       TS.Tree nod _ ->+        case unSource nod of+         NodePI n v -> " "<>textify n<>"=\""<>textify v<>"\""+         _ -> mempty+      ) elemChilds+     _ -> s<>textify pv+    ) <> "?>" <> nl inh+    where s | TL.null pv = ""+            | otherwise  = " "+  NodeCDATA t ->+    writeInh_indent inh <>+    "<[CDATA[["<>textify (TL.replace "]]>" "]]&gt;" t)<>"]]>"<>nl inh+  NodeComment t ->+    writeInh_indent inh <>+    "<!--"<>textify (TL.replace "-->" "--&gt;" t)<>"-->"<>nl inh+  NodeElem elemQName elemAttrs ->+    writeInh_indent inh+     <> "<"+     <> write_elemPName+     <> write_xmlnsAttrs+     <> write_elemAttrs+     <> if noChild+    then "/>" <> nl inh+    else ">"+     <> (if hasIndenting then nl inh else mempty)+     <> write_elemChilds+     <> (if hasIndenting then writeInh_indent inh else mempty)+     <> "</"<>write_elemPName<>">"+     <> nl inh+    where+    -- Empty NodeText do not count as a child+    noChild =+      all (\case+       TS.Tree n _ts+        | NodeText (EscapedText t) <- unSource n ->+          all (\case+           EscapedPlain p -> TL.null p+           _ -> False+          ) t+        | otherwise -> False+      ) elemChilds+    -- Follow xmllint --format rules to detect indenting:+    -- if there is any NodeText it should only contain whites+    hasIndenting =+      (`all` elemChilds) $ \case+       TS.Tree n _ts+        | NodeText (EscapedText t) <- unSource n ->+          all (\case+           EscapedPlain p -> TL.all Char.isSpace p+           _ -> False+          ) t+        | otherwise -> True+    (usedNS, declNS) =+      HM.foldlWithKey' go (initUsedNS, initDeclNS) elemAttrs+      where+      initUsedNS = HS.singleton $ qNameSpace elemQName+      initDeclNS = (writeInh_namespaces inh){namespaces_prefixes=mempty}+      go acc@(uNS, dNS) an sav =+        case unSource sav of+         av+         -- xmlns:prefix="namespace"+          | qNameSpace an == xmlns_xmlns ->+          let ns = unescapeAttr av in+          (uNS, dNS+           { namespaces_prefixes =+            (if TL.null ns+            then HM.delete+            -- Empty namespace means removal+            -- of the prefix from scope.+            else (`HM.insert` qNameLocal an))+             (Namespace ns)+             (namespaces_prefixes dNS)+           })+         -- xmlns="namespace"+          | qNameSpace an == xmlns_empty+          , qNameLocal an == NCName "xmlns" ->+          (uNS, dNS{namespaces_default = Namespace (unescapeAttr av)})+         -- name="value"+          | qNameSpace an == xmlns_empty -> acc+         -- {namespace}name="value"+          | otherwise -> (HS.insert (qNameSpace an) uNS, dNS)+    -- The inherited namespaces,+    -- including those declared at this element.+    inhNS =+      HM.union+       (namespaces_prefixes declNS)+       (namespaces_prefixes (writeInh_namespaces inh))+    -- The namespaces used but not declared nor default,+    -- with fresh prefixes.+    autoNS =+      HM.delete (namespaces_default declNS) $+      (`S.evalState` HS.empty) $+      traverse+       (\() -> S.gets freshNCName)+       (HS.toMap usedNS `HM.difference` inhNS)+    write_xmlnsAttrs =+      foldMap (\(Namespace ns, qNameLocal) ->+        textifyAttr (PName (Just "xmlns") qNameLocal) (escapeAttr ns)) $+      List.sortOn fst $+      HM.toList autoNS+    scopeNS = declNS{ namespaces_prefixes = autoNS <> inhNS }+    write_elemPName = textify $ prefixifyQName scopeNS elemQName+    write_elemAttrs =+      foldMap (\(an, av) -> textifyAttr+       (prefixifyQName scopeNS{namespaces_default=xmlns_empty} an)+       (unSource av)) $+      List.sortOn fst $ -- This makes the rendition more predictible, but this is useless.+      HM.toList elemAttrs+    write_elemChilds = unTreeWrite (write_Trees elemChilds) inh+     { writeInh_namespaces = scopeNS+     -- Disable indenting unless hasIndenting.+     , writeInh_indent =+      if hasIndenting+      then+        writeInh_indent inh <>+        textify (writeInh_indent_delta inh)+      else mempty+     , writeInh_indent_delta =+      if hasIndenting+      then writeInh_indent_delta inh+      else mempty+     }

@@ -0,0 +1,334 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE UndecidableInstances #-}+module Symantic.XML.Write where++import Control.Applicative (Applicative(..), Alternative((<|>)))+import Data.Bool+import Data.Either (Either(..))+import Data.Eq (Eq(..))+import Data.Foldable (Foldable(..))+import Data.Function (($), (.), id)+import Data.Functor ((<$>), (<$))+import Data.Int (Int)+import Data.Maybe (Maybe(..), fromMaybe)+import Data.Monoid (Monoid(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String)+import Data.Traversable (Traversable(..))+import Data.Tuple (fst)+import Numeric.Natural (Natural)+import Prelude (Integer, error)+import System.IO (IO, FilePath)+import Text.Show (Show(..))+import qualified Control.Exception as Exn+import qualified Control.Monad.Trans.State as S+import qualified Data.ByteString.Lazy as BSL+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Lazy.Encoding as TL+import qualified System.IO.Error as IO++import Symantic.Base.CurryN+import Symantic.XML.Language+import Symantic.XML.RelaxNG.Language++-- * Type 'Write'+newtype Write params k+ =      Write+ {    unWrite :: (WriteSyn -> k) -> params+ }++write :: Write params BSL.ByteString -> params+write = runWrite defaultWriteInh++runWrite :: WriteInh -> Write params BSL.ByteString -> params+runWrite def (Write params) = params $ \syn ->+  TL.encodeUtf8 $ TLB.toLazyText $+  fromMaybe mempty $ writeSyn_result syn def++writeUtf8 :: FilePath -> Write params (IO (Maybe ErrorWrite)) -> params+writeUtf8 path (Write params) = params $ \syn ->+  let txt =+       TL.encodeUtf8 $ TLB.toLazyText $+       fromMaybe mempty $+       writeSyn_result syn defaultWriteInh in+  (Nothing <$ BSL.writeFile path txt)+  `Exn.catch` \e ->+    if IO.isAlreadyInUseError e+    || IO.isPermissionError   e+    then pure $ Just e+    else IO.ioError e++-- ** Type 'Write'+type ErrorWrite = IO.IOError++-- ** Type 'WriteInh'+-- | Top-down inheritage.+data WriteInh+ =   WriteInh+ {   writeInh_namespaces   :: Namespaces NCName+     -- ^ 'Namespaces' from the parent element.+ ,   writeInh_indent       :: TLB.Builder+ ,   writeInh_indent_delta :: TL.Text+ }++defaultWriteInh :: WriteInh+defaultWriteInh = WriteInh+ { writeInh_namespaces   = defaultNamespaces+ , writeInh_indent       = mempty+ , writeInh_indent_delta = "  "+ }++-- ** Type 'WriteSyn'+-- | Bottom-up synthesis to build 'element' or 'attribute'.+data WriteSyn+ =   WriteSyn+ {   writeSyn_attrs :: HM.HashMap QName TL.Text+ ,   writeSyn_attr :: TL.Text+ ,   writeSyn_namespaces_default :: Maybe Namespace+ ,   writeSyn_namespaces_prefixes :: HM.HashMap Namespace NCName+ ,   writeSyn_result :: WriteInh -> Maybe TLB.Builder+ }++instance Semigroup WriteSyn where+  x <> y = WriteSyn+   { writeSyn_attrs = writeSyn_attrs x <> writeSyn_attrs y+   , writeSyn_attr = writeSyn_attr x <> writeSyn_attr y+   , writeSyn_namespaces_default = writeSyn_namespaces_default x <|> writeSyn_namespaces_default y+   , writeSyn_namespaces_prefixes = writeSyn_namespaces_prefixes x <> writeSyn_namespaces_prefixes y+   , writeSyn_result = writeSyn_result x <> writeSyn_result y+   }+instance Monoid WriteSyn where+  mempty = WriteSyn+   { writeSyn_attrs = mempty+   , writeSyn_attr = mempty+   , writeSyn_namespaces_default = Nothing+   , writeSyn_namespaces_prefixes = mempty+   , writeSyn_result = mempty+   }++instance Emptyable Write where+  empty = Write (\k -> k mempty)+instance Unitable Write where+  unit = Write (\k () -> k mempty)+instance Voidable Write where+  void a (Write x) = Write (\k -> x k a)+instance Dimapable Write where+  dimap _a2b b2a (Write x) = Write $ \k b ->+    x k (b2a b)+instance Dicurryable Write where+  dicurry (_::proxy args) _construct destruct (Write x) =+    Write $ \k r ->+      uncurryN @args (x k) (destruct r)+instance Composable Write where+  Write x <.> Write y = Write $ \k ->+    x (\mx -> y $ \my -> k (mx<>my))+instance Tupable Write where+  Write x <:> Write y = Write $ \k (a,b) ->+    x (\mx -> y (\my -> k (mx<>my)) b) a+instance Eitherable Write where+  Write x <+> Write y = Write $ \k -> \case+   Left  a -> x k a+   Right b -> y k b+instance Constant Write where+  constant _a = Write $ \k _a -> k mempty+instance Optionable Write where+  option = id+  optional (Write x) = Write $ \k ->+    \case+     Nothing -> k mempty+     Just a -> x k a+{-+instance Routable Write where+  Write x <!> Write y = Write $ \k ->+    x k :!: y k+-}+instance Repeatable Write where+  many0 (Write x) = Write $ \k -> \case+   [] -> k mempty+   a:as -> x (\ma ->+    unWrite (many0 (Write x))+     (\mas -> k (ma<>mas)) as) a+  many1 (Write x) = Write $ \k -> \case+   [] -> k mempty+   a:as -> x (\ma ->+    unWrite (many0 (Write x))+     (\mas -> k (ma<>mas)) as) a+instance Textable Write where+  type TextConstraint Write a = EncodeText a+  text = Write $ \k v ->+    let t = encodeText v in+    k mempty+     { writeSyn_attr = t+     , writeSyn_result = \_inh -> Just $ textify $ escapeText t+     }+instance XML Write where+  namespace nm ns = Write $ \k ->+    k $ case nm of+     Nothing -> mempty{writeSyn_namespaces_default=Just ns}+     Just p  -> mempty{writeSyn_namespaces_prefixes=HM.singleton ns p}+  element elemQName (Write x) = Write $ \k ->+    x $ \syn ->+      k mempty{ writeSyn_result = \inh ->+      let+        hasIndenting = not $ TL.null $ writeInh_indent_delta inh+        defNS = fromMaybe+         (namespaces_default (writeInh_namespaces inh))+         (writeSyn_namespaces_default syn)+        usedNS =+          HS.singleton (qNameSpace elemQName) <>+          HS.delete xmlns_empty (HS.fromList (qNameSpace <$> HM.keys (writeSyn_attrs syn)))+        -- The inherited namespaces,+        -- including those declared at this element.+        inhNS =+          HM.union+           (writeSyn_namespaces_prefixes syn)+           (namespaces_prefixes (writeInh_namespaces inh))+        -- The namespaces used but not declared nor default,+        -- with fresh prefixes.+        autoNS =+          -- HM.delete defNS $+          (`S.evalState` HS.empty) $+          traverse+           (\() -> S.gets freshNCName)+           (HS.toMap usedNS `HM.difference` inhNS)+        write_xmlnsAttrs =+          (if defNS == namespaces_default (writeInh_namespaces inh)+          then mempty+          else textifyAttr (PName Nothing "xmlns") (escapeAttr (unNamespace defNS))) <>+          HM.foldrWithKey (\(Namespace ns) qNameLocal acc ->+            textifyAttr (PName (Just "xmlns") qNameLocal) (escapeAttr ns) <> acc+           ) mempty+           (autoNS <> writeSyn_namespaces_prefixes syn)+        scopeNS = Namespaces+         { namespaces_prefixes = autoNS <> inhNS+         , namespaces_default = defNS+         }+        write_elemPName = textify $ prefixifyQName scopeNS elemQName+        write_elemAttrs =+          foldMap (\(an, av) -> textifyAttr+           (prefixifyQName scopeNS{namespaces_default=xmlns_empty} an)+           (escapeAttr av)) $+          List.sortOn fst $ -- This makes the rendition more predictible, but this is useless.+          HM.toList (writeSyn_attrs syn)+        write_elemChilds = writeSyn_result syn inh+         { writeInh_namespaces = scopeNS+         -- Disable indenting unless hasIndenting.+         , writeInh_indent =+          if hasIndenting+          then+            writeInh_indent inh <>+            textify (writeInh_indent_delta inh)+          else mempty+         , writeInh_indent_delta =+          if hasIndenting+          then writeInh_indent_delta inh+          else mempty+         }+      in Just $+      writeInh_indent inh+       <> "<"+       <> write_elemPName+       <> write_xmlnsAttrs+       <> write_elemAttrs+       <> case write_elemChilds of+       Nothing -> "/>" <> nl inh+       Just w -> ">"+         <> nl inh+         <> w+         <> (if hasIndenting then writeInh_indent inh else mempty)+         <> "</"<>write_elemPName<>">"+         <> nl inh+      }+  attribute n@(QName ans aln) (Write x) = Write $ \k ->+    x $ \syn ->+      if ans == xmlns_xmlns+      then unWrite (namespace (Just aln) (Namespace (writeSyn_attr syn))) k+      else if ans == xmlns_empty && aln == NCName "xmlns"+      then unWrite (namespace Nothing (Namespace (writeSyn_attr syn))) k+      else k mempty{writeSyn_attrs = HM.insert n (writeSyn_attr syn) (writeSyn_attrs syn)}+  literal lit = Write $ \k ->+    k mempty+     { writeSyn_attr = lit+     , writeSyn_result = \_inh ->+      Just $ textify $ escapeText lit+     }+  pi n = Write $ \k v ->+    k mempty{ writeSyn_result = \inh ->+      let s | TL.null v = ""+            | otherwise  = " " in+      Just $+      writeInh_indent inh <>+      "<?"<>textify n<>s <>+      textify (TL.replace "?>" "?&gt;" v) <>+      "?>"<>nl inh+    }+  comment = Write $ \k v ->+    k mempty{ writeSyn_result = \inh ->+      Just $+      writeInh_indent inh <>+      "<!--"<>textify (TL.replace "-->" "--&gt;" v)<>"-->"<>nl inh+    }+  cdata = Write $ \k v ->+    k mempty{ writeSyn_result = \inh ->+      Just $+      writeInh_indent inh <>+      "<[CDATA[["<>textify (TL.replace "]]>" "]]&gt;" v)<>"]]>"<>nl inh+    }+instance Permutable Write where+  type Permutation Write = WritePerm Write+  permutable = unWritePerm+  perm = WritePerm+  noPerm = WritePerm empty+  permWithDefault _a = WritePerm+instance Definable Write where+  define _n = id+instance RelaxNG Write where+  elementMatch nc x = Write $ \k n ->+    if matchNameClass nc n+    then error "elementMatch: given QName does not match expected NameClass"+    else unWrite (element n x) k+  attributeMatch nc x = Write $ \k n ->+    if matchNameClass nc n+    then error "attributeMatch: given QName does not match expected NameClass"+    else unWrite (attribute n x) k++-- ** Type 'WritePerm'+newtype WritePerm repr xml k+ =      WritePerm+ {    unWritePerm :: repr xml k }+instance Transformable (WritePerm repr) where+  type UnTrans (WritePerm repr) = repr+  noTrans = WritePerm+  unTrans = unWritePerm+instance Dimapable (WritePerm Write)+instance Composable (WritePerm Write)+instance Tupable (WritePerm Write)++nl :: WriteInh -> TLB.Builder+nl inh | TL.null (writeInh_indent_delta inh) = mempty+       | otherwise = "\n"++-- * Class 'EncodeText'+class EncodeText a where+  encodeText :: a -> TL.Text+  default encodeText :: Show a => a -> TL.Text+  encodeText = TL.pack . show+instance EncodeText String where+  encodeText = TL.pack+instance EncodeText Text.Text where+  encodeText = TL.fromStrict+instance EncodeText TL.Text where+  encodeText = id+instance EncodeText Bool where+  encodeText = \case+   False -> "0"+   True  -> "1"+instance EncodeText Int+instance EncodeText Integer+instance EncodeText Natural

@@ -1,9 +1,4 @@-resolver: lts-13.19-packages:-- '.'-- location: '../treeseq'-  extra-dep: true-- location: '../symantic/symantic-grammar'-  extra-dep: true+resolver: lts-15.4 extra-deps:-- megaparsec-7.0.4@sha256:a7397151601cbe6b8f831f8bdad1a10118dcd6d9a7ee50d6bbdcfbd1181b4ba2+- ../treeseq+- ../symantic-base

@@ -0,0 +1,12 @@+# This file was autogenerated by Stack.+# You should not edit this file by hand.+# For more information, please see the documentation at:+#   https://docs.haskellstack.org/en/stable/lock_files++packages: []+snapshots:+- completed:+    size: 491163+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/4.yaml+    sha256: bc60043a06b58902b533baa80fb566c0ec495c41e428bc0f8c1e8c15b2a4c468+  original: lts-15.4

@@ -2,62 +2,65 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 1.0.0.20190223-category: Data Structures-synopsis: Library for reading, validating and writing a subset of the XML format.-description: Symantics for an approximative implementation-             of XML (eXtensible Markup Language) and RNC (RelaxNG Compact).+version: 2.0.0.20200523+category: Text, XML+synopsis: Library for reading, validating and writing XML.+description: Symantics for XML (eXtensible Markup Language)+ and RNC (RelaxNG Compact).  .- Motivation: Other Haskell libraries do not fit my needs or are too heavy/complex.- I like the principle to parse XML using some symantics,- which can both generate a Megaparsec parser to validate the XML tree,- and a RNC rendition of the schema it validates.+ DISCLAIMER: This is an experimental library, use at your own risks.  .- DISCLAMER: My life being's too short, I'm NOT burning my brain- on seriously conforming to the too complex XML and RNC formats.- Still I try to respect a vague subset of those,- unless it makes the code more complex than I am comfortable with.+ Motivation: Writing a schema using Haskell combinators+ and deriving automatically a reader, a writer+ and a documentation from it.  .- WARNING: It's currently using an old symantic approach,- not the one developped in <https://hackage.haskell.org/package/symantic-http symantic-http>.- This may change when I'll get to it.+ Example:+ .+ * <symantic-atom https://hackage.haskell.org/package/symantic-atom> extra-doc-files: license: GPL-3 license-file: COPYING stability: experimental-author:      Julien Moutinho <julm+symantic-xml@autogeree.net>-maintainer:  Julien Moutinho <julm+symantic-xml@autogeree.net>-bug-reports: Julien Moutinho <julm+symantic-xml@autogeree.net>+author:      Julien Moutinho <julm+symantic-xml@sourcephile.fr>+maintainer:  Julien Moutinho <julm+symantic-xml@sourcephile.fr>+bug-reports: Julien Moutinho <julm+symantic-xml@sourcephile.fr> -- homepage:  build-type: Simple cabal-version: 1.24-tested-with: GHC==8.6.4+tested-with: GHC==8.8.3 extra-source-files:   stack.yaml+  stack.yaml.lock extra-tmp-files:  Source-Repository head-  location: git://git.autogeree.net/symantic-xml+  location: git://git.sourcephile.fr/haskell/symantic-xml   type:     git  Library+  hs-source-dirs: src   exposed-modules:-    Symantic.RNC-    Symantic.RNC.Sym-    Symantic.RNC.Validate-    Symantic.RNC.Write-    Symantic.RNC.Write.Fixity-    Symantic.RNC.Write.Namespaces     Symantic.XML-    Symantic.XML.Document+    Symantic.XML.Language+    Symantic.XML.Namespace     Symantic.XML.Read-    Symantic.XML.Read.Parser+    Symantic.XML.RelaxNG+    Symantic.XML.RelaxNG.Compact.Write+    Symantic.XML.RelaxNG.Language+    Symantic.XML.Text+    Symantic.XML.Tree+    Symantic.XML.Tree.Data+    Symantic.XML.Tree.Read+    Symantic.XML.Tree.Source+    Symantic.XML.Tree.Write     Symantic.XML.Write   default-language: Haskell2010   default-extensions:+    DefaultSignatures     FlexibleContexts     FlexibleInstances+    GeneralizedNewtypeDeriving     LambdaCase     MultiParamTypeClasses     NamedFieldPuns@@ -65,24 +68,22 @@     RecordWildCards     ScopedTypeVariables     TupleSections-    -- TypeFamilies+    TypeApplications+    TypeFamilies+    TypeOperators   ghc-options:     -Wall     -Wincomplete-uni-patterns     -Wincomplete-record-updates-    -fno-warn-tabs     -- -fhide-source-paths   build-depends:       base                 >= 4.10 && < 5     , bytestring           >= 0.10     , containers           >= 0.5-    , data-default-class   >= 0.1-    , filepath             >= 1.4     , hashable             >= 1.2.6     , hxt-charproperties   >= 9.2-    , megaparsec           >= 7.0.4-    -- , parser-combinators   >= 1.0-    , safe                 >= 0.3+    , megaparsec           >= 8.0+    , symantic-base        >= 0.0     , text                 >= 1.2     , transformers         >= 0.5     , treeseq              >= 1.0@@ -93,8 +94,8 @@   hs-source-dirs: test   main-is: Main.hs   other-modules:-    RNC.Parser-    RNC.Commoning+    RelaxNG.Commoning+    RelaxNG.Whatever     Golden     -- HUnit     -- QuickCheck@@ -104,28 +105,28 @@     NamedFieldPuns     NoImplicitPrelude     RecordWildCards+    TypeFamilies     ViewPatterns   ghc-options:     -Wall     -Wincomplete-uni-patterns     -Wincomplete-record-updates-    -fno-warn-tabs     -fhide-source-paths   build-depends:     symantic-xml+    , symantic-base >= 0.0     , base >= 4.10 && < 5     , bytestring >= 0.10     , containers >= 0.5-    , data-default-class   >= 0.1     , deepseq >= 1.4-    , filepath >= 1.4     , hashable >= 1.2.6     , megaparsec >= 7.0.4     , tasty >= 0.11     , tasty-golden >= 2.3+    -- , tasty-hunit     , text >= 1.2+    -- , time >= 1.9     , transformers >= 0.4     , treeseq >= 1.0     -- , QuickCheck >= 2.0-    -- , tasty-hunit     -- , tasty-quickcheck

@@ -1,41 +1,106 @@-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} module Golden where -import Control.Arrow (left) import Control.Monad (Monad(..), sequence) import Data.Bool import Data.Either (Either(..))-import Data.Foldable (Foldable(..)) import Data.Function (($), (.)) import Data.Functor ((<$>))+import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.String (String)-import Data.Void (Void)-import System.FilePath (FilePath)-import System.IO (IO)+import System.IO (IO, FilePath) import Text.Show (Show(..)) import qualified Data.ByteString.Lazy as BSL import qualified Data.List as List import qualified Data.Text.Lazy          as TL import qualified Data.Text.Lazy.Encoding as TL-import qualified Text.Megaparsec as P import qualified Data.TreeSeq.Strict as TS  import Test.Tasty import Test.Tasty.Golden -import Symantic.XML.Read.Parser (XMLs) import qualified Symantic.XML as XML-import qualified Symantic.RNC as RNC-import RNC.Parser ()-import qualified RNC.Commoning+import qualified Symantic.XML.RelaxNG as RelaxNG+import qualified RelaxNG.Commoning+import qualified RelaxNG.Whatever +goldensIO :: IO TestTree+goldensIO =+  testGroup "Golden" <$>+  sequence+   [ goldensXML+   , goldensRelaxNG+   ]++goldensXML :: IO TestTree+goldensXML = do+  inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/XML"+  return $ testGroup "XML"+   [ testGroup "Read"+     [ testGolden inputFile ".read" $+      XML.readTree inputFile >>= \ast ->+        return $ TL.encodeUtf8 . TL.pack . TS.prettyTrees <$> ast+     | inputFile <- inputFiles+     ]+   , testGroup "Write" $ List.concat+     [+       [ testGolden inputFile ".write" $+        XML.readTree inputFile >>= \ast ->+          return $ TL.encodeUtf8 . XML.writeTree <$> ast+       , testGolden inputFile ".write.indented" $+        XML.readTree inputFile >>= \ast ->+          return $ TL.encodeUtf8 . XML.writeTreeIndented (TL.pack "  ") <$> ast+       ]+     | inputFile <- inputFiles+     , not $ List.isInfixOf "/Error/" inputFile+     ]+   ]++goldensRelaxNG :: IO TestTree+goldensRelaxNG = do+  inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/RelaxNG"+  return $ testGroup "RelaxNG"+   [ testGroup "Validate"+     [ testGroup "Commoning" $ mconcat+       [+        let xml = XML.read RelaxNG.Commoning.schema inputFile in+        [ testGolden inputFile ".read" $+          ((TL.encodeUtf8 . TL.pack . show) <$>) <$> xml+        , testGolden inputFile ".write" $+          ((XML.write RelaxNG.Commoning.schema) <$>) <$> xml+        ]+       | inputFile <- inputFiles+       , "/Commoning/" `List.isInfixOf` inputFile+       ]+     , testGroup "Whatever" $ mconcat+       [+        let xml = XML.read RelaxNG.Whatever.schema inputFile in+        [ testGolden inputFile ".read" $+          ((TL.encodeUtf8 . TL.pack . show) <$>) <$> xml+        , testGolden inputFile ".write" $+          ((XML.write RelaxNG.Whatever.schema) <$>) <$> xml+        ]+       | inputFile <- inputFiles+       , "/Whatever/" `List.isInfixOf` inputFile+       ]+     ]+   , testGroup "Compact"+     [ testGroup "Write"+       [ testGolden "test/Golden/RelaxNG/Commoning" ".rnc" $+          return $ Right $ TL.encodeUtf8 $+            RelaxNG.writeRNC RelaxNG.Commoning.schema+       , testGolden "test/Golden/RelaxNG/Whatever" ".rnc" $+          return $ Right $ TL.encodeUtf8 $+            RelaxNG.writeRNC RelaxNG.Whatever.schema+       ]+     ]+   ]+ -- * Golden testing utilities testGolden :: TestName -> TestName -> IO (Either String BSL.ByteString) -> TestTree-testGolden inputFile expectedExt =-	goldenVsStringDiff inputFile diffGolden (inputFile <> expectedExt)-	 . (>>= unLeft)+testGolden testName expectedExt =+  goldenVsStringDiff testName diffGolden (testName <> expectedExt)+   . (>>= unLeft)  diffGolden :: FilePath -> FilePath -> [String] diffGolden ref new = ["diff", "-u", ref, new]@@ -44,67 +109,3 @@ unLeft = \case  Left err -> return $ TL.encodeUtf8 $ TL.pack err  Right a  -> return a--goldensIO :: IO TestTree-goldensIO =-	testGroup "Golden" <$>-	sequence-	 [ goldensXML-	 , goldensRNC-	 ]--goldensXML :: IO TestTree-goldensXML = do-	inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/XML"-	return $ testGroup "XML"-	 [ testGroup "Read"-		 [ testGolden inputFile ".read" $-			readXML inputFile >>= \ast ->-				return $ TL.encodeUtf8 . TL.pack . TS.prettyTrees <$> ast-		 | inputFile <- inputFiles-		 ]-	 , testGroup "Write" $ List.concat-		 [-			 [ testGolden inputFile ".write" $-				readXML inputFile >>= \ast ->-					return $ TL.encodeUtf8 . XML.writeXML <$> ast-			 , testGolden inputFile ".write.indented" $-				readXML inputFile >>= \ast ->-					return $ TL.encodeUtf8 . XML.writeXMLIndented (TL.pack "  ") <$> ast-			 ]-		 | inputFile <- inputFiles-		 , not $ List.isInfixOf "/Error/" inputFile-		 ]-	 ]--readXML :: FilePath -> IO (Either String XMLs)-readXML inputFile =-	XML.readFile inputFile >>= \case-	 Left err -> return $ Left $ show err-	 Right input ->-		return $ left P.errorBundlePretty $-			XML.readXML inputFile input--goldensRNC :: IO TestTree-goldensRNC = do-	inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/RNC"-	return $ testGroup "RNC"-	 [ testGroup "Validate"-		 [ testGolden inputFile ".read" $-			validateXML inputFile RNC.Commoning.commoning >>= \a ->-				return $ TL.encodeUtf8 . TL.pack . show <$> a-		 | inputFile <- inputFiles-		 , List.isInfixOf "/Commoning/" inputFile-		 ]-	 ]--validateXML :: FilePath -> P.Parsec Void XMLs a -> IO (Either String a)-validateXML inputFile rnc =-	(<$> readXML inputFile) $ \case-	 Left err -> Left err-	 Right xml -> do-		case RNC.validateXML rnc xml of-		 Right a -> Right a-		 Left err ->-			Left $ List.unlines $ toList $-				P.parseErrorTextPretty <$> P.bundleErrors err

@@ -5,11 +5,13 @@  import Test.Tasty import Golden+--import HUnit  main :: IO () main = do-	goldens <- goldensIO-	defaultMain $-		testGroup "Symantic"-		 [ goldens-		 ]+  goldens <- goldensIO+  defaultMain $+    testGroup ""+     [ goldens+     --, hunits+     ]

@@ -1,350 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE StrictData #-}-module RNC.Commoning where--import Control.Applicative (Applicative(..), Alternative(..))-import Control.Monad (Monad, void)-import Data.Default.Class (Default(..))-import Data.Eq (Eq)-import Data.Function (($), (.))-import Data.Functor ((<$>))-import Data.Hashable (Hashable)-import Data.Maybe (Maybe(..))-import Data.Ord (Ord)-import Data.Sequence (Seq)-import Text.Show (Show)-import qualified Data.Text.Lazy as TL-import qualified Data.TreeSeq.Strict as TS-import qualified Text.Megaparsec as P--import Symantic.RNC (Sym_Permutation(..))-import qualified Symantic.RNC as RNC-import qualified Symantic.XML as XML--import RNC.Parser---- * Type 'Commoning'-data Commoning = Commoning- { commoning_persons    :: Persons- , commoning_opinions   :: Opinions- , commoning_groups     :: Groups- , commoning_operations :: Operations- , commoning_resources  :: Resources- } deriving (Show)---- ** Type 'Person'-data Person = Person- { person_id     :: Ident- , person_fields :: Seq Fields- } deriving (Show)--- *** Type 'Persons'-type Persons = [Person]---- ** Type 'Group'-type Group = TS.Tree NodeGroup--- *** Type 'NodeGroup'-data NodeGroup = NodeGroup- { group_id      :: Ident- , group_name    :: Maybe Name- , group_fields  :: Seq Fields- , group_members :: Members- } deriving (Show)--- *** Type 'Groups'-type Groups = Seq Group---- ** Type 'Member'-newtype Member = Member- { member_person :: Ident- } deriving (Show)--- *** Type 'Members'-type Members = [Member]---- ** Type 'Resource'-type Resource = TS.Tree NodeResource--- *** Type 'NodeResource'-data NodeResource = NodeResource- { resource_name     :: Name- , resource_policies :: Policies- } deriving (Show)--- *** Type 'Resources'-type Resources = Seq Resource---- ** Type 'Policy'-data Policy = Policy- { policy_operation :: Name- , policy_by        :: Ident- , policy_toward    :: (Maybe Ident)- , policy_rules     :: Rules- } deriving (Show)--- *** Type 'Policies'-type Policies = [Policy]---- ** Type 'Rule'-data Rule = Rule- { rule_grades     :: Ident- , rule_gradeRange :: GradeRange- } deriving (Show)--- *** Type 'Rules'-type Rules = [Rule]---- *** Type 'GradeRange'-data GradeRange- = GradeRange_Single Name- | GradeRange_Min Name- | GradeRange_Max Name- | GradeRange Name Name- deriving (Show)---- * Type 'Opinions'-type Opinions = [Grades]---- ** Type 'Grade'-data Grade = Grade- { grade_name   :: Name- , grade_abbrev :: Maybe Name- , grade_color  :: Maybe Color- } deriving (Show)--- *** Type 'Grades'-data Grades = Grades- { grades_id   :: Ident- , grades_name :: Maybe Name- , grades_list :: [Grade]- } deriving (Show)--- *** Type 'Color'-type Color = TL.Text---- ** Type 'Operation'-type Operation = TS.Tree NodeOperation--- *** Type 'NodeOperation'-newtype NodeOperation = NodeOperation- { operation_id :: Ident- } deriving (Show)--- *** Type 'Operations'-type Operations = Seq Operation---- ** Type 'Field'-data Field = Field- { field_name  :: Name- , field_value :: TL.Text- } deriving (Show)--- *** Type 'Fields'-type Fields = TS.Tree NodeField--- **** Type 'NodeField'-data NodeField- = NodeField  Field- | NodeFields { fields_name :: Name }- deriving (Show)---- * Type 'Ident'-newtype Ident = Ident TL.Text- deriving (Eq,Ord,Show,Hashable)--- * Type 'Name'-newtype Name  = Name  TL.Text- deriving (Eq,Ord,Show,Hashable)---- * Class 'Sym_Commoning'-xmlns_commoning :: XML.Namespace-xmlns_commoning = "http://commonsoft.org/xml/2018/commoning.rnc"-element :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a-element = RNC.element . XML.QName xmlns_commoning-attribute :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a-attribute = RNC.attribute . XML.QName ""--class RNC.Sym_RNC repr => Sym_Commoning repr where-	commoning  :: repr Commoning-	persons    :: repr Persons-	person     :: repr Person-	opinions   :: repr Opinions-	grades     :: repr Grades-	grade      :: repr Grade-	fields     :: repr Fields-	field      :: repr Field-	groups     :: repr Groups-	group      :: repr Group-	members    :: repr Members-	member     :: repr Member-	operations :: repr Operations-	operation  :: repr Operation-	resources  :: repr Resources-	resource   :: repr Resource-	policy     :: repr Policy-	rule       :: repr Rule-	ident      :: repr Ident-	name       :: repr Name-	color      :: repr Color-	-	commoning = RNC.rule "commoning" $-		element "commoning" $-		runPermutation $-		Commoning-		 <$$> persons-		 <||> opinions-		 <||> groups-		 <||> operations-		 <||> resources-	persons = RNC.rule "persons" $-		element "persons" $ RNC.many person-	person  = RNC.rule "person" $-		element "person" $ attrs <*> RNC.manySeq fields-		where-		attrs =-			runPermutation $-			Person-			 <$$> attribute "id" ident-	opinions = RNC.rule "opinions" $-		element "opinions" $-			RNC.many grades-	grades = RNC.rule "grades" $-		element "grades" $ attrs <*> RNC.many grade-		where-		attrs =-			runPermutation $-			Grades-			 <$$> attribute "id" ident-			 <|?> (def, Just <$> attribute "name" name)-	grade = RNC.rule "grade" $-		element "grade" $ attrs-		where-		attrs =-			runPermutation $-			Grade-			 <$$> attribute "name" name-			 <|?> (def, Just <$> attribute "abbrev" name)-			 <|?> (def, Just <$> attribute "color" color)-	fields = RNC.rule "fields" $-		element "fields" $-			(TS.Tree <$> attrs <*>) $-			RNC.manySeq $-				TS.tree0 . NodeField <$> field-				<|> fields-		where-		attrs =-			runPermutation $-			NodeFields-			 <$$> attribute "name" name-	field = RNC.rule "field" $-		element "field" $ attrs <*> RNC.text-		where-		attrs =-			runPermutation $-			Field-			 <$$> attribute "name" name-	groups = RNC.rule "groups" $-		element "groups" $ RNC.manySeq group-	group = RNC.rule "group" $-		element "group" $-			(((TS.Tree <$>) $ attrs <*> RNC.manySeq fields <*> members) <*>) $-				RNC.manySeq group-		where-		attrs =-			runPermutation $-			NodeGroup-			 <$$> attribute "id" ident-			 <|?> (def, Just <$> attribute "name" name)-	members = RNC.rule "members" $ RNC.many member-	member = RNC.rule "member" $-		element "member" $ attrs-		where-		attrs =-			runPermutation $-			Member-			 <$$> attribute "person" ident-	operations = RNC.rule "operations" $-		element "operations" $ RNC.manySeq operation-	operation = RNC.rule "operation" $-		element "operation" $-			(((TS.Tree <$>) $ attrs) <*>) $-				RNC.manySeq operation-		where-		attrs =-			runPermutation $-			NodeOperation-			 <$$> attribute "id" ident-	resources = RNC.rule "resources" $-		element "resources" $ RNC.manySeq resource-	resource = RNC.rule "resource" $-		element "resource" $-			(((TS.Tree <$>) $ attrs <*> RNC.many policy) <*>) $-				RNC.manySeq resource-		where-		attrs =-			runPermutation $-			NodeResource-			 <$$> attribute "name" name-	policy = RNC.rule "policy" $-		element "policy" $ attrs-		where-		attrs =-			runPermutation $-			Policy-			 <$$> attribute "operation" name-			 <||> attribute "by" ident-			 <|?> (def, Just <$> attribute "toward" ident)-			 <|*> rule-	rule = RNC.rule "rule" $-		element "rule" $ attrs-		where-		attrs-		 =   RNC.try attrsGrade-		 <|> RNC.try attrsGradeMin-		 <|> attrsGradeMax-		attrsGrade =-			runPermutation $-			Rule-			 <$$> attribute "grades" ident-			 <||> (GradeRange_Single <$> attribute "grade" name)-		attrsGradeMin =-			runPermutation $-			(\gs gMin mgMax -> Rule gs $ case mgMax of-				 Nothing -> GradeRange_Min gMin-				 Just gMax -> GradeRange gMin gMax)-			 <$$> attribute "grades" ident-			 <||> attribute "gradeMin" name-			 <|?> (def, Just <$> attribute "gradeMax" name)-		attrsGradeMax =-			runPermutation $-			(\gs mgMin gMax -> Rule gs $ case mgMin of-				 Nothing -> GradeRange_Max gMax-				 Just gMin -> GradeRange gMin gMax)-			 <$$> attribute "grades" ident-			 <|?> (def, Just <$> attribute "gradeMin" name)-			 <||> attribute "gradeMax" name-	-	ident = RNC.rule "ident" $ Ident <$> RNC.text-	name  = RNC.rule "name" $ Name <$> RNC.text-	color = RNC.rule "color" $ RNC.text-instance Sym_Commoning RNC.NS-instance Sym_Commoning RNC.Writer-instance- ( Ord err- , Ord src- , XML.NoSource src- ) => Sym_Commoning (P.Parsec err (XML.XMLs src))---- newtype Forall cl a = Forall { unForall :: forall repr. cl repr => repr a }-rnc :: forall repr. Sym_Commoning repr => [repr ()]-rnc =- [ void $ RNC.namespace Nothing xmlns_commoning- , void $ commoning- , void $ persons- , void $ person- , void $ opinions- , void $ grades- , void $ grade- , void $ fields- , void $ field- , void $ groups- , void $ group- , void $ members- , void $ member- , void $ resources- , void $ resource- , void $ policy- , void $ rule- , void $ ident- , void $ name- , void $ color- ]

@@ -1,65 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module RNC.Parser where--import Control.Applicative (Applicative(..))-import Control.Monad (Monad(..))-import Data.Bool-import Data.Either (Either(..))-import Data.Foldable (Foldable(..))-import Data.Function (($), (.))-import Data.Functor ((<$>))-import Data.Maybe (Maybe(..))-import Data.Monoid (Monoid(..))-import Data.Ord (Ord(..))-import Data.Semigroup (Semigroup(..))-import Data.Sequence (ViewL(..))-import Prelude (error)-import Text.Show (Show(..))-import qualified Data.List as List-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Sequence as Seq-import qualified Text.Megaparsec as P--import Symantic.XML.Document (XML, XMLs)-import qualified Symantic.XML.Document as XML-import qualified Symantic.RNC.Validate as RNC--instance Ord src => P.Stream (XMLs src) where-	type Token  (XMLs src) = XML src-	type Tokens (XMLs src) = XMLs src-	take1_ s =-		case Seq.viewl s of-		 EmptyL -> Nothing-		 t@(XML.Tree XML.Sourced{XML.unSourced=n} _) :< ts-		  | RNC.isIgnoredNode n -> P.take1_ ts-		  | otherwise       -> Just (t, ts)-	takeN_ n s | n <= 0    = Just (mempty, s)-	           | null s    = Nothing-	           | otherwise =-		let (ns,rs) = Seq.splitAt n s in-		let (ko,ok) = Seq.partition (RNC.isIgnoredNode . XML.unSourced . XML.unTree) ns in-		case P.takeN_ (Seq.length ko) rs of-		 Nothing -> Just (ok, rs)-		 Just (ns',rs') -> Just (ok<>ns', rs')-	tokensToChunk _s  = Seq.fromList-	chunkToTokens _s  = toList-	chunkLength _s    = Seq.length-	takeWhile_        = Seq.spanl-	-- | NOTE: unimplemented: useless since each 'XML.Node' is annotated with its 'FileSource'.-	reachOffset       = error "[BUG] P.Stream XMLs: reachOffset is not helpful, please use annotated source locations"-	-- | NOTE: useless since each 'XML.Node' is annotated with its 'FileSource'.-	reachOffsetNoLine = error "[BUG] P.Stream XMLs: reachOffsetNoLine is not helpful, please use annotated source locations"-	showTokens _s toks = List.intercalate ", " $ toList $ showTree <$> toks-		where-		showTree (XML.Tree (XML.Sourced _src a) _ts) =-			case a of-			 XML.NodeElem n     -> "element "<>show n<>""-			 XML.NodeAttr n     -> "attribute "<>show n<>""-			 XML.NodeText _t    -> "text"-			 XML.NodeComment _c -> "comment"-			 XML.NodePI n _t    -> "processing-instruction "<>show n<>""-			 XML.NodeCDATA _t   -> "cdata"

@@ -0,0 +1,375 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module RelaxNG.Commoning where++import Data.Eq (Eq)+import Data.Either (Either(..))+import Data.Foldable (toList)+import Data.Functor ((<$>))+import Data.Function (($), (.))+import Data.Hashable (Hashable)+import Data.Maybe (Maybe(..))+import Data.Ord (Ord)+import Data.Sequence (Seq)+import Data.Tuple (fst)+import Text.Show (Show)+import GHC.Generics (Generic)+import qualified Data.Sequence as Seq+import qualified Data.Text.Lazy as TL+import qualified Data.TreeSeq.Strict as TS+import qualified Text.Megaparsec as P++import Symantic.XML as XML+import Symantic.XML.RelaxNG as RelaxNG++schema =+  namespace Nothing xmlns_commoning <.>+  namespace (Just "xsd") "http://www/w3/org/2001/XMLSchema-datatypes" <.>+  commoning++-- * Class 'Commonable'+xmlns_commoning :: Namespace+xmlns_commoning = "2018/commoning.rnc"+elem = element . QName xmlns_commoning+attr n = attribute (QName "" n) text+many0Seq = dimap Seq.fromList toList . many0++-- * Type 'Ident'+newtype Ident = Ident TL.Text+ deriving (Eq,Ord,Show,Hashable)++instance RNCText Ident where+  rncText_qname = QName xmlns_xsd "id"+instance EncodeText Ident where+  encodeText (Ident t) = t+instance DecodeText Ident where+  decodeText = Ident . fst <$> P.match (P.many P.anySingle)++-- * Type 'Name'+newtype Name = Name TL.Text+ deriving (Eq,Ord,Show,Hashable)+instance RNCText Name where+  rncText_qname  = rncText_qname  @TL.Text+  rncText_params = rncText_params @TL.Text++instance EncodeText Name where+  encodeText (Name t) = t+instance DecodeText Name where+  decodeText = Name . fst <$> P.match (P.many P.anySingle)++-- * Type 'Commoning'+data Commoning+ =   Commoning+ {   commoning_persons    :: Persons+ ,   commoning_opinions   :: Opinions+ ,   commoning_groups     :: Groups+ ,   commoning_operations :: Operations+ ,   commoning_resources  :: Resources+ } deriving (Show, Generic)++commoning =+  define "commoning" $+  elem "commoning" $+  adt @Commoning $+    permutable $+    persons <&>+    opinions <&>+    groups <&>+    operations <&>+    perm resources++-- ** Type 'Person'+data Person+ =   Person+ {   person_id     :: Ident+ ,   person_fields :: Seq Fields+ } deriving (Show, Generic)++person =+  define "person" $+  adt @Person $+  elem "person" $+    attr "id" <:>+    many0Seq fields++-- *** Type 'Persons'+type Persons = [Person]++persons =+  define "persons" $+  elem "persons" $+    many0 person++-- * Type 'Opinions'+type Opinions = [Grades]++opinions =+  define "opinions" $+  elem "opinions" $+    many0 grades++-- ** Type 'Grade'+data Grade+ =   Grade+ {   grade_name   :: Name+ ,   grade_abbrev :: Maybe Name+ ,   grade_color  :: Maybe Color+ } deriving (Show, Generic)++grade =+  define "grade" $+  elem "grade" $+  adt @Grade $+    attr "name" <:>+    optional (attr "abbrev") <:>+    optional (attr "color")++-- *** Type 'Color'+type Color = TL.Text++-- *** Type 'Grades'+data Grades+ =   Grades+ {   grades_id   :: Ident+ ,   grades_name :: Maybe Name+ ,   grades_list :: [Grade]+ } deriving (Show, Generic)++grades =+  define "grades" $+  elem "grades" $+  adt @Grades $+    attr "id" <:>+    optional (attr "name") <:>+    many0 grade++-- ** Type 'Field'+data Field+ =   Field+ {   field_name  :: Name+ ,   field_value :: TL.Text+ } deriving (Show, Generic)++-- *** Type 'Fields'+type Fields = TS.Tree NodeField++-- **** Type 'NodeField'+data NodeField+ =   NodeField Field+ |   NodeFields { fields_name :: Name }+ deriving (Show, Generic)++fields =+  define "fields" $+  elem "fields" $+  adt @(TS.Tree NodeField) $+    (dimap NodeFields fields_name $+      attr "name")+    <:>+    many0Seq (+      dimap+      (\case+       Left f -> TS.tree0 $ NodeField f+       Right fs -> fs)+      (\case+       TS.Tree (NodeField f) _ -> Left f+       fs -> Right fs) $+      field+      <+>+      fields+    )++field =+  define "field" $+  elem "field" $+  adt @Field $+    attr "name" <:>+    text++-- ** Type 'Group'+type Group = TS.Tree NodeGroup++-- *** Type 'NodeGroup'+data NodeGroup+ =   NodeGroup+ {   group_id      :: Ident+ ,   group_name    :: Maybe Name+ ,   group_fields  :: Seq Fields+ ,   group_members :: Members+ } deriving (Show, Generic)++-- *** Type 'Groups'+type Groups = Seq Group++groups =+  define "groups" $+  elem "groups" $+    many0Seq group++group =+  define "group" $+  elem "group" $+  adt @(TS.Tree NodeGroup) $+    (adt @NodeGroup $+      attr "id" <:>+      optional (attr "name") <:>+      many0Seq fields <:>+      members+    ) <:>+    many0Seq group++-- ** Type 'Member'+newtype Member+ =      Member+ {      member_person :: Ident+ } deriving (Show, Generic)++-- *** Type 'Members'+type Members = [Member]++members = define "members" $ many0 member+member =+  define "member" $+  elem "member" $+  adt @Member $+   attr "person"++-- ** Type 'Operation'+type Operation = TS.Tree NodeOperation+-- *** Type 'NodeOperation'+newtype NodeOperation+ =      NodeOperation+ {      operation_id :: Ident+ } deriving (Show, Generic)+-- *** Type 'Operations'+type Operations = Seq Operation++operations =+  define "operations" $+  elem "operations" $+  many0Seq operation++operation =+  define "operation" $+  elem "operation" $+  adt @(TS.Tree NodeOperation) $+    (adt $ attr "id") <:>+    many0Seq operation++-- ** Type 'Resource'+type Resource = TS.Tree NodeResource+-- *** Type 'NodeResource'+data NodeResource+ =   NodeResource+ {   resource_name     :: Name+ ,   resource_policies :: Policies+ } deriving (Show, Generic)++-- *** Type 'Resources'+type Resources = Seq Resource++resources =+  define "resources" $+  elem "resources" $+    many0Seq resource++resource =+  define "resource" $+  elem "resource" $+  adt @(TS.Tree NodeResource) $+    (adt $ attr "name" <:> many0 policy) <:>+    many0Seq resource++-- ** Type 'Policy'+data Policy+ =   Policy+ {   policy_operation :: Name+ ,   policy_by        :: Ident+ ,   policy_toward    :: Maybe Ident+ ,   policy_rules     :: Rules+ } deriving (Show, Generic)++policy =+  define "policy" $+  adt @Policy $+  elem "policy" $+    attr "operation" <:>+    attr "by" <:>+    optional (attr "toward") <:>+    many0 rule++-- *** Type 'Policies'+type Policies = [Policy]++-- ** Type 'Rule'+data Rule+ =   Rule+ {   rule_grades     :: Ident+ ,   rule_gradeRange :: GradeRange+ } deriving (Show, Generic)++rule =+  define "rule" $+  adt @Rule $+  elem "rule" $+    attr "grades" <:>+    gradeRange++-- *** Type 'Rules'+type Rules = [Rule]++-- *** Type 'GradeRange'+data GradeRange+ =   GradeRange_Single Name+ |   GradeRange_Min    Name+ |   GradeRange_Max    Name+ |   GradeRange        Name Name+ deriving (Show, Generic)++gradeRange =+  define "gradeRange" $+  adt @GradeRange $+    attr "grade" <+>+    attr "gradeMin" <+>+    attr "gradeMax" <+> (+      attr "gradeMin" <:>+      attr "gradeMax"+    )++{-+rule = define "rule" $+  element "rule" attrs+  where+  attrs+   =   attrsGrade+   <+> attrsGradeMin+   <+> attrsGradeMax+  attrsGrade =+    permutable $+    Rule+     <$> attribute "grades" ident+     <*> (GradeRange_Single <$> attribute "grade" name)+  attrsGradeMin =+    permutable $+    (\gs gMin mgMax -> Rule gs $ case mgMax of+       Nothing   -> GradeRange_Min gMin+       Just gMax -> GradeRange gMin gMax)+     <$> attribute "grades" ident+     <*> attribute "gradeMin" name+     <*> optionalPerm (attribute "gradeMax" name)+  attrsGradeMax =+    permutable $+    (\gs mgMin gMax -> Rule gs $ case mgMin of+       Nothing   -> GradeRange_Max gMax+       Just gMin -> GradeRange gMin gMax)+     <$> attribute "grades" ident+     <*> optionalPerm (attribute "gradeMin" name)+     <*> attribute "gradeMax" name+-}

@@ -0,0 +1,47 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module RelaxNG.Whatever where++import Data.Function (($), (.))+import Data.Maybe (Maybe(..))+import Text.Show (Show)+import GHC.Generics (Generic)+import qualified Data.Text.Lazy as TL++import Symantic.XML as XML+import Symantic.XML.RelaxNG as RelaxNG++schema =+  namespace Nothing xmlns_whatever <.>+  namespace (Just "xsd") "http://www/w3/org/2001/XMLSchema-datatypes" <.>+  whatever++xmlns_whatever :: Namespace+xmlns_whatever = "2020/whatever.rnc"+elem = element . QName xmlns_whatever+attr n = attribute (QName "" n) text++newtype Whatever+ =   Whatever+ {   whatever_a :: TL.Text+ } deriving (Generic, Show)+whatever =+  define "root" $+  adt @Whatever $+  elem "root" $+    namespace Nothing xmlns_whatever <.>+    namespace (Just "whatever") xmlns_whatever <.>+    attr "a" <.>+    elem "child" (+      namespace (Just "what") xmlns_whatever <.>+      elem "sub-child" (+        namespace Nothing xmlns_empty <.>+        empty+      )+    )