--- /dev/null
+- arguments: [
+ -XHaskell2010
+ -XNoCPP
+ -XTypeApplications
+]
+- ignore: {name: Avoid lambda using `infix`}
+- ignore: {name: Move brackets to avoid $}
+- ignore: {name: Reduce duplication}
+- ignore: {name: Redundant $}
+- ignore: {name: Redundant bracket}
+- ignore: {name: Redundant do}
+- ignore: {name: Redundant lambda}
+- ignore: {name: Use camelCase}
+- ignore: {name: Use const}
+- ignore: {name: Use fmap}
+- ignore: {name: Use if}
+- ignore: {name: Use import/export shortcut}
+- ignore: {name: Use list literal pattern}
+- ignore: {name: Use list literal}
+
+# BEGIN: generated hints
+# END: generated hints
%.html/view: %.html
sensible-browser $*.html
-HLint.hs: $(shell find . -name '*.hs' -not -name 'HLint.hs')
- sed -i -e '/^-- BEGIN: generated hints/,/^-- END: Generated by hlint/d' HLint.hs
- echo '-- BEGIN: generated hints' >> HLint.hs
- hlint --find . | sed -ne 's/^- infix: \(.*\)/\1/p' | sort -u >>HLint.hs
- echo '-- END: generated hints' >> HLint.hs
+.hlint.yaml: $(shell find src -name '*.hs' -not -name 'HLint.hs')
+ sed -i -e '/^# BEGIN: generated hints/,/^# END: Generated by hlint/d' $@
+ echo >>$@ '# BEGIN: generated hints'
+ hlint --find . | grep -- '- fixity:' | sort -u >>$@
+ echo >>$@ '# END: generated hints'
-lint: HLint.hs
- if hlint --quiet --report=hlint.html -XNoCPP \
- $(shell cabal-cargs --format=ghc --only=default_extensions --sourcefile=$(cabal)) $(HLINT_FLAGS) .; \
+lint: .hlint.yaml
+ if hlint --quiet --report=hlint.html -XNoCPP $(HLINT_FLAGS) .; \
then rm -f hlint.html; \
else sensible-browser ./hlint.html & fi
+++ /dev/null
-import "hint" HLint.HLint
-ignore "Move brackets to avoid $"
-ignore "Reduce duplication"
-ignore "Redundant $"
-ignore "Redundant bracket"
-ignore "Redundant do"
-ignore "Use camelCase"
-ignore "Use const"
-ignore "Use fmap"
-ignore "Use if"
-ignore "Use import/export shortcut"
-ignore "Use list literal pattern"
-ignore "Use list literal"
-
--- BEGIN: generated hints
--- END: generated hints
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-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
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# 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
+++ /dev/null
-{-# 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 ()
+++ /dev/null
-{-# 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
+++ /dev/null
-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 = ("{","}")
+++ /dev/null
-{-# 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
+++ /dev/null
-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
+++ /dev/null
-{-# 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
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# 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"
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# 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_))
+++ /dev/null
-{-# 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 "\"" """ entityRef_value
- EscapedCharRef (CharRef c)
- | c == '\"' -> """
- | 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
--- /dev/null
+cradle:
+ stack:
+ - path: "./"
+ component: "symantic-xml:lib"
+ - path: "./test"
+ component: "symantic-xml:test:symantic-xml-test"
--- /dev/null
+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
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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
+ ]
--- /dev/null
+{-# 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"
--- /dev/null
+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
--- /dev/null
+{-# 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"
--- /dev/null
+{-# 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
--- /dev/null
+{-# 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
--- /dev/null
+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
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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 '='
--- /dev/null
+{-# 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)
--- /dev/null
+{-# 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 "]]>" "]]>" t)<>"]]>"<>nl inh
+ NodeComment t ->
+ writeInh_indent inh <>
+ "<!--"<>textify (TL.replace "-->" "-->" 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
+ }
--- /dev/null
+{-# 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 "?>" "?>" v) <>
+ "?>"<>nl inh
+ }
+ comment = Write $ \k v ->
+ k mempty{ writeSyn_result = \inh ->
+ Just $
+ writeInh_indent inh <>
+ "<!--"<>textify (TL.replace "-->" "-->" v)<>"-->"<>nl inh
+ }
+ cdata = Write $ \k v ->
+ k mempty{ writeSyn_result = \inh ->
+ Just $
+ writeInh_indent inh <>
+ "<[CDATA[["<>textify (TL.replace "]]>" "]]>" 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
-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
--- /dev/null
+# 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
-- PVP: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 1.0.0.201902 23
-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.202005 23
+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
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
hs-source-dirs: test
main-is: Main.hs
other-modules:
- RNC.Parser
- RNC.Commoning
+ RelaxNG.Commoning
+ RelaxNG.Whatever
Golden
-- HUnit
-- QuickCheck
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
-{-# 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 inputFil e expectedExt =
- goldenVsStringDiff inputFile diffGolden (inputFil e <> expectedExt)
- . (>>= unLeft)
+testGolden testNam e expectedExt =
+ goldenVsStringDiff testName diffGolden (testNam e <> expectedExt)
+ . (>>= unLeft)
diffGolden :: FilePath -> FilePath -> [String]
diffGolden ref new = ["diff", "-u", ref, new]
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
--- /dev/null
+default namespace = "2018/commoning.rnc"
+namespace xsd = "http://www/w3/org/2001/XMLSchema-datatypes"
+namespace ns1 = "2018/commoning.rnc"
+commoning = element commoning {persons & opinions & groups & operations & resources}
+field = element field {attribute name {text}, text}
+fields = element fields {attribute name {text}, ( field | fields )*}
+grade = element grade {attribute name {text}, ( attribute abbrev {text} )?, ( attribute color {text} )?}
+gradeRange = attribute grade {text} | attribute gradeMin {text} | attribute gradeMax {text} | ( attribute gradeMin {text}, attribute gradeMax {text} )
+grades = element grades {attribute id {xsd:id}, ( attribute name {text} )?, grade*}
+group = element group {attribute id {xsd:id}, ( attribute name {text} )?, fields*, members, group*}
+groups = element groups {group*}
+member = element member {attribute person {xsd:id}}
+members = member*
+operation = element operation {attribute id {xsd:id}, operation*}
+operations = element operations {operation*}
+opinions = element opinions {grades*}
+person = element person {attribute id {xsd:id}, fields*}
+persons = element persons {person*}
+policy = element policy {attribute operation {text}, attribute by {xsd:id}, ( attribute toward {xsd:id} )?, rule*}
+resource = element resource {attribute name {text}, policy*, resource*}
+resources = element resources {resource*}
+rule = element rule {attribute grades {xsd:id}, gradeRange}
-<commoning xmlns="http://commonsoft.org/xml/ 2018/commoning.rnc">
+<commoning xmlns="2018/commoning.rnc">
<persons>
</persons>
<groups>
--- /dev/null
+<ns1:commoning xmlns:ns1="2018/commoning.rnc">
+ <ns1:persons/>
+ <ns1:opinions/>
+ <ns1:groups/>
+ <ns1:operations/>
+ <ns1:resources/>
+</ns1:commoning>
-<commoning xmlns="http://commonsoft.org/xml/ 2018/commoning.rnc">
+<commoning xmlns="2018/commoning.rnc">
<persons>
<person id="julm"/>
</persons>
--- /dev/null
+<ns1:commoning xmlns:ns1="2018/commoning.rnc">
+ <ns1:persons>
+ <ns1:person id="julm"/>
+ </ns1:persons>
+ <ns1:opinions>
+ <ns1:grades id="Règlementation">
+ <ns1:grade abbrev="NE-PEUT-PAS" color="black" name="Ne peut pas"/>
+ <ns1:grade abbrev="NE-DOIT-PAS" color="red" name="Ne doit pas"/>
+ <ns1:grade abbrev="NE-DEVRAIT-PAS" color="orange" name="Ne devrait pas"/>
+ <ns1:grade abbrev="NON-RÈGLEMENTÉ" color="#888" name="Non-règlementé"/>
+ <ns1:grade abbrev="PEUT" color="#FFD700" name="Peut"/>
+ <ns1:grade abbrev="DEVRAIT" color="green" name="Devrait"/>
+ <ns1:grade abbrev="DOIT" color="blue" name="Doit"/>
+ </ns1:grades>
+ </ns1:opinions>
+ <ns1:groups>
+ <ns1:group id="Public"/>
+ </ns1:groups>
+ <ns1:operations>
+ <ns1:operation id="Écrire">
+ <ns1:operation id="Lire"/>
+ </ns1:operation>
+ </ns1:operations>
+ <ns1:resources>
+ <ns1:resource name="Financières">
+ <ns1:resource name="Compte courant">
+ <ns1:policy by="Finances" operation="Lire">
+ <ns1:rule grade="DOIT" grades="Règlementation"/>
+ </ns1:policy>
+ <ns1:policy by="Administration" operation="Lire">
+ <ns1:rule gradeMin="PEUT" grades="Règlementation"/>
+ </ns1:policy>
+ </ns1:resource>
+ </ns1:resource>
+ </ns1:resources>
+</ns1:commoning>
-<commoning xmlns="http://commonsoft.org/xml/ 2018/commoning.rnc">
+<commoning xmlns="2018/commoning.rnc">
<persons>
<person id="julm"/>
<person id="john"/>
<grade abbrev="B" name="Bon" color="green"/>
<grade abbrev="TB" name="Très Bon" color="blue"/>
</grades>
- <grades id="R�� glementation">
+ <grades id="R�� glementation">
<grade abbrev="NE-PEUT-PAS" name="Ne peut pas" color="black"/>
<grade abbrev="NE-DOIT-PAS" name="Ne doit pas" color="red"/>
<grade abbrev="NE-DEVRAIT-PAS" name="Ne devrait pas" color="orange"/>
- <grade abbrev="NON-R��GLEMENTÉ" name="Non-rè glementé" color="#888"/>
+ <grade abbrev="NON-R��GLEMENTÉ" name="Non-ré glementé" color="#888"/>
<grade abbrev="PEUT" name="Peut" color="#FFD700"/>
<grade abbrev="DEVRAIT" name="Devrait" color="green"/>
<grade abbrev="DOIT" name="Doit" color="blue"/>
-Commoning {commoning_persons = [Person {person_id = Ident "julm", person_fields = fromList []},Person {person_id = Ident "john", person_fields = fromList []}], commoning_opinions = [Grades {grades_id = Ident "Adh\233sion", grades_name = Nothing, grades_list = [Grade {grade_name = Name "Fortement Contre", grade_abbrev = Just (Name "FC"), grade_color = Just "black"},Grade {grade_name = Name "Contre", grade_abbrev = Just (Name "C"), grade_color = Just "red"},Grade {grade_name = Name "Plut\244t Contre", grade_abbrev = Just (Name "PC"), grade_color = Just "orange"},Grade {grade_name = Name "Partag\233\183e", grade_abbrev = Just (Name "p"), grade_color = Just "#888"},Grade {grade_name = Name "Plut\244t Pour", grade_abbrev = Just (Name "PP"), grade_color = Just "#FFD700"},Grade {grade_name = Name "Pour", grade_abbrev = Just (Name "P"), grade_color = Just "green"},Grade {grade_name = Name "Fortement Pour", grade_abbrev = Just (Name "FP"), grade_color = Just "blue"}]},Grades {grades_id = Ident "Qualit\233", grades_name = Nothing, grades_list = [Grade {grade_name = Name "Tr\232s Mauvais", grade_abbrev = Just (Name "TM"), grade_color = Just "black"},Grade {grade_name = Name "Mauvais", grade_abbrev = Just (Name "M"), grade_color = Just "red"},Grade {grade_name = Name "Plut\244t Mauvais", grade_abbrev = Just (Name "PM"), grade_color = Just "orange"},Grade {grade_name = Name "Moyen", grade_abbrev = Just (Name "m"), grade_color = Just "#888"},Grade {grade_name = Name "Plut\244t Bon", grade_abbrev = Just (Name "PB"), grade_color = Just "#FFD700"},Grade {grade_name = Name "Bon", grade_abbrev = Just (Name "B"), grade_color = Just "green"},Grade {grade_name = Name "Tr\232s Bon", grade_abbrev = Just (Name "TB"), grade_color = Just "blue"}]},Grades {grades_id = Ident "R\232glementation", grades_name = Nothing, grades_list = [Grade {grade_name = Name "Ne peut pas", grade_abbrev = Just (Name "NE-PEUT-PAS"), grade_color = Just "black"},Grade {grade_name = Name "Ne doit pas", grade_abbrev = Just (Name "NE-DOIT-PAS"), grade_color = Just "red"},Grade {grade_name = Name "Ne devrait pas", grade_abbrev = Just (Name "NE-DEVRAIT-PAS"), grade_color = Just "orange"},Grade {grade_name = Name "Non-r\232glement\233", grade_abbrev = Just (Name "NON-R\200 GLEMENT\201"), grade_color = Just "#888"},Grade {grade_name = Name "Peut", grade_abbrev = Just (Name "PEUT"), grade_color = Just "#FFD700"},Grade {grade_name = Name "Devrait", grade_abbrev = Just (Name "DEVRAIT"), grade_color = Just "green"},Grade {grade_name = Name "Doit", grade_abbrev = Just (Name "DOIT"), grade_color = Just "blue"}]}], commoning_groups = fromList [Tree {unTree = NodeGroup {group_id = Ident "Public", group_name = Nothing, group_fields = fromList [], group_members = []}, subTrees = fromList []},Tree {unTree = NodeGroup {group_id = Ident "Assembl\233e", group_name = Just (Name "Assembl\233e G\233n\233rale"), group_fields = fromList [], group_members = []}, subTrees = fromList [Tree {unTree = NodeGroup {group_id = Ident "Infra", group_name = Just (Name "Infrastructure"), group_fields = fromList [], group_members = []}, subTrees = fromList []},Tree {unTree = NodeGroup {group_id = Ident "Modo", group_name = Just (Name "Mod\233ration"), group_fields = fromList [], group_members = []}, subTrees = fromList []}]}], commoning_operations = fromList [Tree {unTree = NodeOperation {operation_id = Ident "\201crire"}, subTrees = fromList [Tree {unTree = NodeOperation {operation_id = Ident "Lire"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Commenter"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Proposer"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Ajouter"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Modifier"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Supprimer"}, subTrees = fromList []}]},Tree {unTree = NodeOperation {operation_id = Ident "Ex\233cuter"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Support"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Mod\233rer"}, subTrees = fromList []}], commoning_resources = fromList [Tree {unTree = NodeResource {resource_name = Name "Financi\232res", resource_policies = []}, subTrees = fromList [Tree {unTree = NodeResource {resource_name = Name "Compte courant", resource_policies = [Policy {policy_operation = Name "Lire", policy_by = Ident "Finances", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "DOIT")}]},Policy {policy_operation = Name "Lire", policy_by = Ident "Administration", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Min (Name "PEUT")}]}]}, subTrees = fromList []}]},Tree {unTree = NodeResource {resource_name = Name "Informatique", resource_policies = [Policy {policy_operation = Name "Support", policy_by = Ident "Infra", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "DOIT")}]}]}, subTrees = fromList [Tree {unTree = NodeResource {resource_name = Name "Ordinateurs", resource_policies = []}, subTrees = fromList []},Tree {unTree = NodeResource {resource_name = Name "Service", resource_policies = [Policy {policy_operation = Name "AdminSys", policy_by = Ident "Infra", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "DOIT")}]},Policy {policy_operation = Name "Mod\233rer", policy_by = Ident "Modo", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "DOIT")}]}]}, subTrees = fromList [Tree {unTree = NodeResource {resource_name = Name "DNS", resource_policies = [Policy {policy_operation = Name "Lire", policy_by = Ident "Public", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "PEUT")}]}]}, subTrees = fromList [Tree {unTree = NodeResource {resource_name = Name "example.coop", resource_policies = []}, subTrees = fromList []}]}]},Tree {unTree = NodeResource {resource_name = Name "Logiciels", resource_policies = [Policy {policy_operation = Name "Lire", policy_by = Ident "Public", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "PEUT")}]},Policy {policy_operation = Name "Commenter", policy_by = Ident "Public", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "PEUT")}]}]}, subTrees = fromList []}]}]}
\ No newline at end of file
+Commoning {commoning_persons = [Person {person_id = Ident "julm", person_fields = fromList []},Person {person_id = Ident "john", person_fields = fromList []}], commoning_opinions = [Grades {grades_id = Ident "Adh\233sion", grades_name = Nothing, grades_list = [Grade {grade_name = Name "Fortement Contre", grade_abbrev = Just (Name "FC"), grade_color = Just "black"},Grade {grade_name = Name "Contre", grade_abbrev = Just (Name "C"), grade_color = Just "red"},Grade {grade_name = Name "Plut\244t Contre", grade_abbrev = Just (Name "PC"), grade_color = Just "orange"},Grade {grade_name = Name "Partag\233\183e", grade_abbrev = Just (Name "p"), grade_color = Just "#888"},Grade {grade_name = Name "Plut\244t Pour", grade_abbrev = Just (Name "PP"), grade_color = Just "#FFD700"},Grade {grade_name = Name "Pour", grade_abbrev = Just (Name "P"), grade_color = Just "green"},Grade {grade_name = Name "Fortement Pour", grade_abbrev = Just (Name "FP"), grade_color = Just "blue"}]},Grades {grades_id = Ident "Qualit\233", grades_name = Nothing, grades_list = [Grade {grade_name = Name "Tr\232s Mauvais", grade_abbrev = Just (Name "TM"), grade_color = Just "black"},Grade {grade_name = Name "Mauvais", grade_abbrev = Just (Name "M"), grade_color = Just "red"},Grade {grade_name = Name "Plut\244t Mauvais", grade_abbrev = Just (Name "PM"), grade_color = Just "orange"},Grade {grade_name = Name "Moyen", grade_abbrev = Just (Name "m"), grade_color = Just "#888"},Grade {grade_name = Name "Plut\244t Bon", grade_abbrev = Just (Name "PB"), grade_color = Just "#FFD700"},Grade {grade_name = Name "Bon", grade_abbrev = Just (Name "B"), grade_color = Just "green"},Grade {grade_name = Name "Tr\232s Bon", grade_abbrev = Just (Name "TB"), grade_color = Just "blue"}]},Grades {grades_id = Ident "R\233glementation", grades_name = Nothing, grades_list = [Grade {grade_name = Name "Ne peut pas", grade_abbrev = Just (Name "NE-PEUT-PAS"), grade_color = Just "black"},Grade {grade_name = Name "Ne doit pas", grade_abbrev = Just (Name "NE-DOIT-PAS"), grade_color = Just "red"},Grade {grade_name = Name "Ne devrait pas", grade_abbrev = Just (Name "NE-DEVRAIT-PAS"), grade_color = Just "orange"},Grade {grade_name = Name "Non-r\233glement\233", grade_abbrev = Just (Name "NON-R\201 GLEMENT\201"), grade_color = Just "#888"},Grade {grade_name = Name "Peut", grade_abbrev = Just (Name "PEUT"), grade_color = Just "#FFD700"},Grade {grade_name = Name "Devrait", grade_abbrev = Just (Name "DEVRAIT"), grade_color = Just "green"},Grade {grade_name = Name "Doit", grade_abbrev = Just (Name "DOIT"), grade_color = Just "blue"}]}], commoning_groups = fromList [Tree {unTree = NodeGroup {group_id = Ident "Public", group_name = Nothing, group_fields = fromList [], group_members = []}, subTrees = fromList []},Tree {unTree = NodeGroup {group_id = Ident "Assembl\233e", group_name = Just (Name "Assembl\233e G\233n\233rale"), group_fields = fromList [], group_members = []}, subTrees = fromList [Tree {unTree = NodeGroup {group_id = Ident "Infra", group_name = Just (Name "Infrastructure"), group_fields = fromList [], group_members = []}, subTrees = fromList []},Tree {unTree = NodeGroup {group_id = Ident "Modo", group_name = Just (Name "Mod\233ration"), group_fields = fromList [], group_members = []}, subTrees = fromList []}]}], commoning_operations = fromList [Tree {unTree = NodeOperation {operation_id = Ident "\201crire"}, subTrees = fromList [Tree {unTree = NodeOperation {operation_id = Ident "Lire"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Commenter"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Proposer"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Ajouter"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Modifier"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Supprimer"}, subTrees = fromList []}]},Tree {unTree = NodeOperation {operation_id = Ident "Ex\233cuter"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Support"}, subTrees = fromList []},Tree {unTree = NodeOperation {operation_id = Ident "Mod\233rer"}, subTrees = fromList []}], commoning_resources = fromList [Tree {unTree = NodeResource {resource_name = Name "Financi\232res", resource_policies = []}, subTrees = fromList [Tree {unTree = NodeResource {resource_name = Name "Compte courant", resource_policies = [Policy {policy_operation = Name "Lire", policy_by = Ident "Finances", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "DOIT")}]},Policy {policy_operation = Name "Lire", policy_by = Ident "Administration", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Min (Name "PEUT")}]}]}, subTrees = fromList []}]},Tree {unTree = NodeResource {resource_name = Name "Informatique", resource_policies = [Policy {policy_operation = Name "Support", policy_by = Ident "Infra", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "DOIT")}]}]}, subTrees = fromList [Tree {unTree = NodeResource {resource_name = Name "Ordinateurs", resource_policies = []}, subTrees = fromList []},Tree {unTree = NodeResource {resource_name = Name "Service", resource_policies = [Policy {policy_operation = Name "AdminSys", policy_by = Ident "Infra", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "DOIT")}]},Policy {policy_operation = Name "Mod\233rer", policy_by = Ident "Modo", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "DOIT")}]}]}, subTrees = fromList [Tree {unTree = NodeResource {resource_name = Name "DNS", resource_policies = [Policy {policy_operation = Name "Lire", policy_by = Ident "Public", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "PEUT")}]}]}, subTrees = fromList [Tree {unTree = NodeResource {resource_name = Name "example.coop", resource_policies = []}, subTrees = fromList []}]}]},Tree {unTree = NodeResource {resource_name = Name "Logiciels", resource_policies = [Policy {policy_operation = Name "Lire", policy_by = Ident "Public", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "PEUT")}]},Policy {policy_operation = Name "Commenter", policy_by = Ident "Public", policy_toward = Nothing, policy_rules = [Rule {rule_grades = Ident "R\232glementation", rule_gradeRange = GradeRange_Single (Name "PEUT")}]}]}, subTrees = fromList []}]}]}
\ No newline at end of file
--- /dev/null
+<ns1:commoning xmlns:ns1="2018/commoning.rnc">
+ <ns1:persons>
+ <ns1:person id="julm"/>
+ <ns1:person id="john"/>
+ </ns1:persons>
+ <ns1:opinions>
+ <ns1:grades id="Adhésion">
+ <ns1:grade abbrev="FC" color="black" name="Fortement Contre"/>
+ <ns1:grade abbrev="C" color="red" name="Contre"/>
+ <ns1:grade abbrev="PC" color="orange" name="Plutôt Contre"/>
+ <ns1:grade abbrev="p" color="#888" name="Partagé·e"/>
+ <ns1:grade abbrev="PP" color="#FFD700" name="Plutôt Pour"/>
+ <ns1:grade abbrev="P" color="green" name="Pour"/>
+ <ns1:grade abbrev="FP" color="blue" name="Fortement Pour"/>
+ </ns1:grades>
+ <ns1:grades id="Qualité">
+ <ns1:grade abbrev="TM" color="black" name="Très Mauvais"/>
+ <ns1:grade abbrev="M" color="red" name="Mauvais"/>
+ <ns1:grade abbrev="PM" color="orange" name="Plutôt Mauvais"/>
+ <ns1:grade abbrev="m" color="#888" name="Moyen"/>
+ <ns1:grade abbrev="PB" color="#FFD700" name="Plutôt Bon"/>
+ <ns1:grade abbrev="B" color="green" name="Bon"/>
+ <ns1:grade abbrev="TB" color="blue" name="Très Bon"/>
+ </ns1:grades>
+ <ns1:grades id="Réglementation">
+ <ns1:grade abbrev="NE-PEUT-PAS" color="black" name="Ne peut pas"/>
+ <ns1:grade abbrev="NE-DOIT-PAS" color="red" name="Ne doit pas"/>
+ <ns1:grade abbrev="NE-DEVRAIT-PAS" color="orange" name="Ne devrait pas"/>
+ <ns1:grade abbrev="NON-RÉGLEMENTÉ" color="#888" name="Non-réglementé"/>
+ <ns1:grade abbrev="PEUT" color="#FFD700" name="Peut"/>
+ <ns1:grade abbrev="DEVRAIT" color="green" name="Devrait"/>
+ <ns1:grade abbrev="DOIT" color="blue" name="Doit"/>
+ </ns1:grades>
+ </ns1:opinions>
+ <ns1:groups>
+ <ns1:group id="Public"/>
+ <ns1:group id="Assemblée" name="Assemblée Générale">
+ <ns1:group id="Infra" name="Infrastructure"/>
+ <ns1:group id="Modo" name="Modération"/>
+ </ns1:group>
+ </ns1:groups>
+ <ns1:operations>
+ <ns1:operation id="Écrire">
+ <ns1:operation id="Lire"/>
+ <ns1:operation id="Commenter"/>
+ <ns1:operation id="Proposer"/>
+ <ns1:operation id="Ajouter"/>
+ <ns1:operation id="Modifier"/>
+ <ns1:operation id="Supprimer"/>
+ </ns1:operation>
+ <ns1:operation id="Exécuter"/>
+ <ns1:operation id="Support"/>
+ <ns1:operation id="Modérer"/>
+ </ns1:operations>
+ <ns1:resources>
+ <ns1:resource name="Financières">
+ <ns1:resource name="Compte courant">
+ <ns1:policy by="Finances" operation="Lire">
+ <ns1:rule grade="DOIT" grades="Règlementation"/>
+ </ns1:policy>
+ <ns1:policy by="Administration" operation="Lire">
+ <ns1:rule gradeMin="PEUT" grades="Règlementation"/>
+ </ns1:policy>
+ </ns1:resource>
+ </ns1:resource>
+ <ns1:resource name="Informatique">
+ <ns1:policy by="Infra" operation="Support">
+ <ns1:rule grade="DOIT" grades="Règlementation"/>
+ </ns1:policy>
+ <ns1:resource name="Ordinateurs"/>
+ <ns1:resource name="Service">
+ <ns1:policy by="Infra" operation="AdminSys">
+ <ns1:rule grade="DOIT" grades="Règlementation"/>
+ </ns1:policy>
+ <ns1:policy by="Modo" operation="Modérer">
+ <ns1:rule grade="DOIT" grades="Règlementation"/>
+ </ns1:policy>
+ <ns1:resource name="DNS">
+ <ns1:policy by="Public" operation="Lire">
+ <ns1:rule grade="PEUT" grades="Règlementation"/>
+ </ns1:policy>
+ <ns1:resource name="example.coop"/>
+ </ns1:resource>
+ </ns1:resource>
+ <ns1:resource name="Logiciels">
+ <ns1:policy by="Public" operation="Lire">
+ <ns1:rule grade="PEUT" grades="Règlementation"/>
+ </ns1:policy>
+ <ns1:policy by="Public" operation="Commenter">
+ <ns1:rule grade="PEUT" grades="Règlementation"/>
+ </ns1:policy>
+ </ns1:resource>
+ </ns1:resource>
+ </ns1:resources>
+</ns1:commoning>
--- /dev/null
+default namespace = "2020/whatever.rnc"
+namespace ns1 = ""
+namespace whatever = "2020/whatever.rnc"
+namespace xsd = "http://www/w3/org/2001/XMLSchema-datatypes"
+root = element root {attribute a {text}, element child {element sub-child {empty}}}
--- /dev/null
+<?xml version="1.0" encoding="utf-8" standalone="yes"?>
+<root xmlns="2020/whatever.rnc" a="<A&>'"">
+ <child>
+ <sub-child/>
+ </child>
+</root>
--- /dev/null
+Whatever {whatever_a = "<A&>'\""}
\ No newline at end of file
--- /dev/null
+<root xmlns="2020/whatever.rnc" xmlns:whatever="2020/whatever.rnc" a="<A&>'"">
+ <child xmlns:what="2020/whatever.rnc">
+ <what:sub-child xmlns=""/>
+ </child>
+</root>
+++ /dev/null
-(NodeElem root) @(test/Golden/XML/0001.xml#1:1-1:8 :| [])
-
-(NodeElem root) @(test/Golden/XML/0001.xml@0-7 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0001.xml@7-8 :| [])
+NodeElem root (fromList []) in test/Golden/XML/0001.xml at char position 0 to 7
-
-<root/>
\ No newline at end of file
+<root/>
+++ /dev/null
-(NodeElem root) @(test/Golden/XML/0002.xml#1:1-1:14 :| [])
-
-(NodeElem root) @(test/Golden/XML/0002.xml@0-13 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0002.xml@13-14 :| [])
+NodeElem root (fromList []) in test/Golden/XML/0002.xml at char position 0 to 13
-
-<root/>
\ No newline at end of file
+<root/>
+++ /dev/null
-(NodeElem root) @(test/Golden/XML/0003.xml#1:1-1:15 :| [])
-|
-`- (NodeAttr n) @(test/Golden/XML/0003.xml#1:7-1:12 :| [])
- |
- `- (NodeText "v") @(test/Golden/XML/0003.xml#1:10-1:11 :| [])
-
-(NodeElem root) @(test/Golden/XML/0003.xml@0-14 :| [])
-|
-`- (NodeAttr n) @(test/Golden/XML/0003.xml@6-11 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "v"]))) @(test/Golden/XML/0003.xml@9-10 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0003.xml@14-15 :| [])
+NodeElem root (fromList [(n,EscapedAttr (fromList [EscapedPlain "v"]) in test/Golden/XML/0003.xml at char position 5 to 11)]) in test/Golden/XML/0003.xml at char position 0 to 14
-
-<root n="v"/>
\ No newline at end of file
+<root n="v"/>
-(NodeElem doc) @(test/Golden/XML/0004.xml@0-33 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0004.xml at char position 0 to 33
|
-+- (NodeText (EscapedText (fromList [EscapedPlain "\r\n"]))) @(test/Golden/XML/0004.xml@5-7 :| [])
++- NodeText (EscapedText (fromList [EscapedPlain "\r\n"])) in test/Golden/XML/0004.xml at char position 5 to 7
|
-+- (NodeElem a) @(test/Golden/XML/0004.xml@7-25 :| [])
++- NodeElem a (fromList []) in test/Golden/XML/0004.xml at char position 7 to 25
| |
-| `- (NodeElem b) @(test/Golden/XML/0004.xml@10-21 :| [])
+| `- NodeElem b (fromList []) in test/Golden/XML/0004.xml at char position 10 to 21
| |
-| `- (NodeElem c) @(test/Golden/XML/0004.xml@13-17 :| [])
+| `- NodeElem c (fromList []) in test/Golden/XML/0004.xml at char position 13 to 17
|
-`- (NodeText (EscapedText (fromList [EscapedPlain "\r\n"]))) @(test/Golden/XML/0004.xml@25-27 :| [])
+`- NodeText (EscapedText (fromList [EscapedPlain "\r\n"])) in test/Golden/XML/0004.xml at char position 25 to 27
-<doc>\r
-<a><b><c/></b></a>\r
-</doc>
\ No newline at end of file
+<doc>
+ <a>
+ <b>
+ <c/>
+ </b>
+ </a>
+</doc>
-
<doc>
<a>
<b>
<c/>
</b>
</a>
-</doc>
\ No newline at end of file
+</doc>
-(NodeElem doc) @(test/Golden/XML/0005.xml@0-33 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0005.xml at char position 0 to 33
|
-+- (NodeText (EscapedText (fromList [EscapedPlain "\r\n"]))) @(test/Golden/XML/0005.xml@5-7 :| [])
++- NodeText (EscapedText (fromList [EscapedPlain "\r\n"])) in test/Golden/XML/0005.xml at char position 5 to 7
|
-+- (NodeElem a) @(test/Golden/XML/0005.xml@7-25 :| [])
++- NodeElem a (fromList []) in test/Golden/XML/0005.xml at char position 7 to 25
| |
-| `- (NodeElem b) @(test/Golden/XML/0005.xml@10-21 :| [])
+| `- NodeElem b (fromList []) in test/Golden/XML/0005.xml at char position 10 to 21
| |
-| `- (NodeElem c) @(test/Golden/XML/0005.xml@13-17 :| [])
+| `- NodeElem c (fromList []) in test/Golden/XML/0005.xml at char position 13 to 17
|
-`- (NodeText (EscapedText (fromList [EscapedPlain "\r\n"]))) @(test/Golden/XML/0005.xml@25-27 :| [])
+`- NodeText (EscapedText (fromList [EscapedPlain "\r\n"])) in test/Golden/XML/0005.xml at char position 25 to 27
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0005.xml@33-35 :| [])
+NodeComment " comment after document element" in test/Golden/XML/0005.xml at char position 35 to 73
-(NodeComment " comment after document element") @(test/Golden/XML/0005.xml@35-73 :| [])
+NodePI PI "after document element" in test/Golden/XML/0005.xml at char position 75 to 104
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0005.xml@73-75 :| [])
+NodeComment " comment after document element" in test/Golden/XML/0005.xml at char position 106 to 144
-(NodePI PI "after document element") @(test/Golden/XML/0005.xml@75-104 :| [])
+NodePI PI "after document element" in test/Golden/XML/0005.xml at char position 146 to 175
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0005.xml@104-106 :| [])
+NodeComment " comment after document element" in test/Golden/XML/0005.xml at char position 177 to 215
-(NodeComment " comment after document element") @(test/Golden/XML/0005.xml@106-144 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0005.xml@144-146 :| [])
-
-(NodePI PI "after document element") @(test/Golden/XML/0005.xml@146-175 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0005.xml@175-177 :| [])
-
-(NodeComment " comment after document element") @(test/Golden/XML/0005.xml@177-215 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0005.xml@215-217 :| [])
-
-(NodePI PI "after document element") @(test/Golden/XML/0005.xml@217-246 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0005.xml@246-248 :| [])
+NodePI PI "after document element" in test/Golden/XML/0005.xml at char position 217 to 246
-<doc>\r
-<a><b><c/></b></a>\r
+<doc>
+ <a>
+ <b>
+ <c/>
+ </b>
+ </a>
</doc>
<!-- comment after document element-->
<?PI after document element?>
-
<doc>
<a>
<b>
<!-- comment after document element-->
<?PI after document element?>
<!-- comment after document element-->
-<?PI after document element?>
\ No newline at end of file
+<?PI after document element?>
-(NodeText (EscapedText (fromList [EscapedPlain "\t\n "]))) @(test/Golden/XML/0006.xml@0-4 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0006.xml@4-10 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0006.xml at char position 4 to 10
-
- <doc/>
\ No newline at end of file
+<doc/>
-
-<doc/>
\ No newline at end of file
+<doc/>
-(NodeElem doc) @(test/Golden/XML/0007.xml@0-72 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0007.xml at char position 0 to 72
|
-+- (NodeText (EscapedText (fromList [EscapedPlain "\r\n"]))) @(test/Golden/XML/0007.xml@5-7 :| [])
++- NodeText (EscapedText (fromList [EscapedPlain "\r\n"])) in test/Golden/XML/0007.xml at char position 5 to 7
|
-+- (NodeElem A) @(test/Golden/XML/0007.xml@7-40 :| [])
-| |
-| `- (NodeAttr a) @(test/Golden/XML/0007.xml@10-38 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedPlain "asdf",EscapedEntityRef (EntityRef {entityRef_name = gt, entityRef_value = ">"}),EscapedEntityRef (EntityRef {entityRef_name = apos, entityRef_value = "'"}),EscapedCharRef (CharRef '"'),EscapedEntityRef (EntityRef {entityRef_name = gt, entityRef_value = ">"}),EscapedPlain "\r\nasdf\r\n\t?",EscapedEntityRef (EntityRef {entityRef_name = gt, entityRef_value = ">"}),EscapedPlain "%"]))) @(test/Golden/XML/0007.xml@13-37 :| [])
++- NodeElem A (fromList [(a,EscapedAttr (fromList [EscapedPlain "asdf>'",EscapedCharRef (CharRef '"'),EscapedPlain ">\r\nasdf\r\n\t?>%"]) in test/Golden/XML/0007.xml at char position 9 to 38)]) in test/Golden/XML/0007.xml at char position 7 to 40
|
-+- (NodeText (EscapedText (fromList [EscapedPlain "\r\n"]))) @(test/Golden/XML/0007.xml@40-42 :| [])
++- NodeText (EscapedText (fromList [EscapedPlain "\r\n"])) in test/Golden/XML/0007.xml at char position 40 to 42
|
-+- (NodeElem A) @(test/Golden/XML/0007.xml@42-64 :| [])
-| |
-| `- (NodeAttr a) @(test/Golden/XML/0007.xml@45-62 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedEntityRef (EntityRef {entityRef_name = quot, entityRef_value = "\""}),EscapedEntityRef (EntityRef {entityRef_name = quot, entityRef_value = "\""}),EscapedEntityRef (EntityRef {entityRef_name = gt, entityRef_value = ">"}),EscapedCharRef (CharRef '\''),EscapedCharRef (CharRef '"')]))) @(test/Golden/XML/0007.xml@48-61 :| [])
++- NodeElem A (fromList [(a,EscapedAttr (fromList [EscapedEntityRef (EntityRef {entityRef_name = quot, entityRef_value = "\""}),EscapedEntityRef (EntityRef {entityRef_name = quot, entityRef_value = "\""}),EscapedPlain ">",EscapedCharRef (CharRef '\''),EscapedCharRef (CharRef '"')]) in test/Golden/XML/0007.xml at char position 44 to 62)]) in test/Golden/XML/0007.xml at char position 42 to 64
|
-`- (NodeText (EscapedText (fromList [EscapedPlain "\r\n"]))) @(test/Golden/XML/0007.xml@64-66 :| [])
+`- NodeText (EscapedText (fromList [EscapedPlain "\r\n"])) in test/Golden/XML/0007.xml at char position 64 to 66
-<doc>\r
-<A a="asdf>'" ;>\r
+<doc>
+ <A a="asdf>'" ;>\r
asdf\r
- ?>%"/>\r
-<A a=""">'""/>\r
-</doc>
\ No newline at end of file
+ ?>%"/>
+ <A a=""">'""/>
+</doc>
-
<doc>
- <A a="asdf>'" ;>\r
+ <A a="asdf>'" ;>\r
asdf\r
?>%"/>
- <A a=""">'""/>
-</doc>
\ No newline at end of file
+ <A a=""">'""/>
+</doc>
-(NodeElem doc) @(test/Golden/XML/0008.xml@0-45 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0008.xml at char position 0 to 45
|
-`- (NodeText (EscapedText (fromList [EscapedPlain "a%b%",EscapedEntityRef (EntityRef {entityRef_name = lt, entityRef_value = "<"}),EscapedPlain "/doc",EscapedEntityRef (EntityRef {entityRef_name = gt, entityRef_value = ">"}),EscapedCharRef (CharRef '<'),EscapedPlain "/doc",EscapedEntityRef (EntityRef {entityRef_name = gt, entityRef_value = ">"}),EscapedPlain "]]",EscapedEntityRef (EntityRef {entityRef_name = lt, entityRef_value = "<"}),EscapedEntityRef (EntityRef {entityRef_name = amp, entityRef_value = "&"})]))) @(test/Golden/XML/0008.xml@5-39 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0008.xml@45-47 :| [])
+`- NodeText (EscapedText (fromList [EscapedPlain "a%b%",EscapedEntityRef (EntityRef {entityRef_name = lt, entityRef_value = "<"}),EscapedPlain "/doc",EscapedEntityRef (EntityRef {entityRef_name = gt, entityRef_value = ">"}),EscapedCharRef (CharRef '<'),EscapedPlain "/doc",EscapedEntityRef (EntityRef {entityRef_name = gt, entityRef_value = ">"}),EscapedPlain "]]",EscapedEntityRef (EntityRef {entityRef_name = lt, entityRef_value = "<"}),EscapedEntityRef (EntityRef {entityRef_name = amp, entityRef_value = "&"})])) in test/Golden/XML/0008.xml at char position 5 to 39
-
-<doc>a%b%</doc></doc>]]<&</doc>
\ No newline at end of file
+<doc>a%b%</doc></doc>]]<&</doc>
-(NodePI pitarget "'") @(test/Golden/XML/0009.xml@0-14 :| [])
+NodePI pitarget "'" in test/Golden/XML/0009.xml at char position 0 to 14
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0009.xml@14-16 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0009.xml@16-22 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0009.xml at char position 16 to 22
<?pitarget '?>
-<doc/>
\ No newline at end of file
+<doc/>
-
<?pitarget '?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI pitarget "\"") @(test/Golden/XML/0010.xml@0-14 :| [])
+NodePI pitarget "\"" in test/Golden/XML/0010.xml at char position 0 to 14
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0010.xml@14-16 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0010.xml@16-22 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0010.xml at char position 16 to 22
<?pitarget "?>
-<doc/>
\ No newline at end of file
+<doc/>
-
<?pitarget "?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodeElem doc) @(test/Golden/XML/0011.xml@0-6 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0011.xml@6-8 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0011.xml at char position 0 to 6
-
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0012.xml@0-21 :| [])
+NodePI xml "" in test/Golden/XML/0012.xml at char position 0 to 21
|
-`- (NodeAttr version) @(test/Golden/XML/0012.xml@5-19 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0012.xml@15-18 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0012.xml at char position 5 to 19
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0012.xml@21-23 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0012.xml@23-29 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0012.xml@29-31 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0012.xml at char position 23 to 29
<?xml version="1.0"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0013.xml@0-21 :| [])
+NodePI xml "" in test/Golden/XML/0013.xml at char position 0 to 21
|
-`- (NodeAttr version) @(test/Golden/XML/0013.xml@5-19 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0013.xml@15-18 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0013.xml at char position 5 to 19
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0013.xml@21-23 :| [])
+NodeComment "comment" in test/Golden/XML/0013.xml at char position 23 to 37
-(NodeComment "comment") @(test/Golden/XML/0013.xml@23-37 :| [])
+NodePI pi "" in test/Golden/XML/0013.xml at char position 38 to 44
-(NodeText (EscapedText (fromList [EscapedPlain " "]))) @(test/Golden/XML/0013.xml@37-38 :| [])
-
-(NodePI pi "") @(test/Golden/XML/0013.xml@38-44 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0013.xml@44-46 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0013.xml@46-52 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0013.xml@52-54 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0013.xml at char position 46 to 52
<?xml version="1.0"?>
-<!--comment--> <?pi?>
+<!--comment-->
+<?pi?>
<doc/>
<?xml version="1.0"?>
<!--comment-->
<?pi?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0014.xml@0-21 :| [])
+NodePI xml "" in test/Golden/XML/0014.xml at char position 0 to 21
|
-`- (NodeAttr version) @(test/Golden/XML/0014.xml@5-19 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0014.xml@15-18 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0014.xml at char position 5 to 19
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0014.xml@21-23 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0014.xml@23-29 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0014.xml@29-31 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0014.xml at char position 23 to 29
<?xml version="1.0"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0015.xml@0-38 :| [])
+NodePI xml "" in test/Golden/XML/0015.xml at char position 0 to 38
|
-+- (NodeAttr version) @(test/Golden/XML/0015.xml@5-19 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0015.xml@15-18 :| [])
++- NodePI version "1.0" in test/Golden/XML/0015.xml at char position 5 to 19
|
-`- (NodeAttr encoding) @(test/Golden/XML/0015.xml@19-36 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "UTF-8"]))) @(test/Golden/XML/0015.xml@30-35 :| [])
+`- NodePI encoding "UTF-8" in test/Golden/XML/0015.xml at char position 19 to 36
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0015.xml@38-40 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0015.xml@40-46 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0015.xml@46-48 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0015.xml at char position 40 to 46
<?xml version="1.0" encoding="UTF-8"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0016.xml@0-38 :| [])
+NodePI xml "" in test/Golden/XML/0016.xml at char position 0 to 38
|
-+- (NodeAttr version) @(test/Golden/XML/0016.xml@5-19 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0016.xml@15-18 :| [])
++- NodePI version "1.0" in test/Golden/XML/0016.xml at char position 5 to 19
|
-`- (NodeAttr standalone) @(test/Golden/XML/0016.xml@19-30 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "yes"]))) @(test/Golden/XML/0016.xml@32-35 :| [])
+`- NodePI standalone "yes" in test/Golden/XML/0016.xml at char position 19 to 36
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0016.xml@38-40 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0016.xml@40-46 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0016.xml@46-48 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0016.xml at char position 40 to 46
<?xml version="1.0" standalone="yes"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0017.xml@0-55 :| [])
+NodePI xml "" in test/Golden/XML/0017.xml at char position 0 to 55
|
-+- (NodeAttr version) @(test/Golden/XML/0017.xml@5-19 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0017.xml@15-18 :| [])
++- NodePI version "1.0" in test/Golden/XML/0017.xml at char position 5 to 19
|
-+- (NodeAttr encoding) @(test/Golden/XML/0017.xml@19-36 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedPlain "UTF-8"]))) @(test/Golden/XML/0017.xml@30-35 :| [])
++- NodePI encoding "UTF-8" in test/Golden/XML/0017.xml at char position 19 to 36
|
-`- (NodeAttr standalone) @(test/Golden/XML/0017.xml@36-47 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "yes"]))) @(test/Golden/XML/0017.xml@49-52 :| [])
+`- NodePI standalone "yes" in test/Golden/XML/0017.xml at char position 36 to 53
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0017.xml@55-57 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0017.xml@57-63 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0017.xml@63-65 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0017.xml at char position 57 to 63
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0018.xml@0-21 :| [])
+NodePI xml "" in test/Golden/XML/0018.xml at char position 0 to 21
|
-`- (NodeAttr version) @(test/Golden/XML/0018.xml@5-19 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0018.xml@15-18 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0018.xml at char position 5 to 19
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0018.xml@21-23 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0018.xml@23-29 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0018.xml@29-31 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0018.xml at char position 23 to 29
<?xml version="1.0"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0019.xml@0-21 :| [])
+NodePI xml "" in test/Golden/XML/0019.xml at char position 0 to 21
|
-`- (NodeAttr version) @(test/Golden/XML/0019.xml@5-19 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0019.xml@15-18 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0019.xml at char position 5 to 19
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0019.xml@21-23 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0019.xml@23-29 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0019.xml@29-31 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0019.xml at char position 23 to 29
<?xml version="1.0"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0020.xml@0-32 :| [])
+NodePI xml "" in test/Golden/XML/0020.xml at char position 0 to 32
|
-`- (NodeAttr version) @(test/Golden/XML/0020.xml@5-28 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0020.xml@24-27 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0020.xml at char position 5 to 28
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0020.xml@32-34 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0020.xml@34-40 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0020.xml@40-42 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0020.xml at char position 34 to 40
<?xml version="1.0"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0021.xml@0-23 :| [])
+NodePI xml "" in test/Golden/XML/0021.xml at char position 0 to 23
|
-`- (NodeAttr version) @(test/Golden/XML/0021.xml@5-21 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0021.xml@17-20 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0021.xml at char position 5 to 21
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0021.xml@23-25 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0021.xml@25-31 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0021.xml@31-33 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0021.xml at char position 25 to 31
<?xml version="1.0"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0022.xml@0-21 :| [])
+NodePI xml "" in test/Golden/XML/0022.xml at char position 0 to 21
|
-`- (NodeAttr version) @(test/Golden/XML/0022.xml@5-19 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0022.xml@15-18 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0022.xml at char position 5 to 19
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0022.xml@21-23 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0022.xml@23-29 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0022.xml@29-31 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0022.xml at char position 23 to 29
<?xml version="1.0"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0023.xml@0-37 :| [])
+NodePI xml "" in test/Golden/XML/0023.xml at char position 0 to 37
|
-`- (NodeAttr version) @(test/Golden/XML/0023.xml@5-35 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0023.xml@31-34 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0023.xml at char position 5 to 35
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0023.xml@37-39 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0023.xml@39-45 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0023.xml@45-47 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0023.xml at char position 39 to 45
<?xml version="1.0"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0024.xml@0-21 :| [])
+NodePI xml "" in test/Golden/XML/0024.xml at char position 0 to 21
|
-`- (NodeAttr version) @(test/Golden/XML/0024.xml@5-19 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0024.xml@15-18 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0024.xml at char position 5 to 19
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0024.xml@21-23 :| [])
+NodeComment "because we are testing conformace to XML 1.0, there can be no\r\n exhaustive tests of the VersionNum production. The only\r\n VersionNum a 1.0-compliant processor is required to pass\r\n is \"1.0\" " in test/Golden/XML/0024.xml at char position 23 to 230
-(NodeComment "because we are testing conformace to XML 1.0, there can be no\r\n exhaustive tests of the VersionNum production. The only\r\n VersionNum a 1.0-compliant processor is required to pass\r\n is \"1.0\" ") @(test/Golden/XML/0024.xml@23-230 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0024.xml@230-232 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0024.xml@232-238 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0024.xml@238-240 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0024.xml at char position 232 to 238
exhaustive tests of the VersionNum production. The only\r
VersionNum a 1.0-compliant processor is required to pass\r
is "1.0" -->
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0025.xml@0-21 :| [])
+NodePI xml "" in test/Golden/XML/0025.xml at char position 0 to 21
|
-`- (NodeAttr version) @(test/Golden/XML/0025.xml@5-19 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0025.xml@15-18 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0025.xml at char position 5 to 19
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0025.xml@21-23 :| [])
+NodeComment "Non-terminal Misc only appears as Misc*, so we cannot test the fact\r\n that Misc must match exactly one comment, PI, or S" in test/Golden/XML/0025.xml at char position 23 to 153
-(NodeComment "Non-terminal Misc only appears as Misc*, so we cannot test the fact\r\n that Misc must match exactly one comment, PI, or S") @(test/Golden/XML/0025.xml@23-153 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0025.xml@153-155 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0025.xml@155-161 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0025.xml@161-163 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0025.xml at char position 155 to 161
<?xml version="1.0"?>
<!--Non-terminal Misc only appears as Misc*, so we cannot test the fact\r
that Misc must match exactly one comment, PI, or S-->
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0026.xml@0-21 :| [])
+NodePI xml "" in test/Golden/XML/0026.xml at char position 0 to 21
|
-`- (NodeAttr version) @(test/Golden/XML/0026.xml@5-19 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0026.xml@15-18 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0026.xml at char position 5 to 19
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0026.xml@21-23 :| [])
+NodePI pi "" in test/Golden/XML/0026.xml at char position 23 to 29
-(NodePI pi "") @(test/Golden/XML/0026.xml@23-29 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0026.xml@29-31 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0026.xml@31-37 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0026.xml@37-39 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0026.xml at char position 31 to 37
<?xml version="1.0"?>
<?pi?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0027.xml@0-21 :| [])
+NodePI xml "" in test/Golden/XML/0027.xml at char position 0 to 21
|
-`- (NodeAttr version) @(test/Golden/XML/0027.xml@5-19 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0027.xml@15-18 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0027.xml at char position 5 to 19
-(NodeText (EscapedText (fromList [EscapedPlain "\n\n \t\n\n"]))) @(test/Golden/XML/0027.xml@21-31 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0027.xml@31-37 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0027.xml@37-39 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0027.xml at char position 31 to 37
<?xml version="1.0"?>
-
-
-
<doc/>
<?xml version="1.0"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0028.xml@0-21 :| [])
+NodePI xml "" in test/Golden/XML/0028.xml at char position 0 to 21
|
-`- (NodeAttr version) @(test/Golden/XML/0028.xml@5-19 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0028.xml@15-18 :| [])
+`- NodePI version "1.0" in test/Golden/XML/0028.xml at char position 5 to 19
-(NodePI pi "") @(test/Golden/XML/0028.xml@21-27 :| [])
+NodePI pi "" in test/Golden/XML/0028.xml at char position 21 to 27
-(NodeText (EscapedText (fromList [EscapedPlain "\n\n \t\n\n"]))) @(test/Golden/XML/0028.xml@27-37 :| [])
+NodeComment "comment" in test/Golden/XML/0028.xml at char position 37 to 51
-(NodeComment "comment") @(test/Golden/XML/0028.xml@37-51 :| [])
+NodePI pi "" in test/Golden/XML/0028.xml at char position 53 to 59
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0028.xml@51-53 :| [])
+NodeComment "comment" in test/Golden/XML/0028.xml at char position 69 to 83
-(NodePI pi "") @(test/Golden/XML/0028.xml@53-59 :| [])
+NodePI pi "" in test/Golden/XML/0028.xml at char position 85 to 91
-(NodeText (EscapedText (fromList [EscapedPlain "\n\n \t\n\n"]))) @(test/Golden/XML/0028.xml@59-69 :| [])
-
-(NodeComment "comment") @(test/Golden/XML/0028.xml@69-83 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0028.xml@83-85 :| [])
-
-(NodePI pi "") @(test/Golden/XML/0028.xml@85-91 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0028.xml@91-97 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0028.xml@97-99 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0028.xml at char position 91 to 97
-<?xml version="1.0"?><?pi?>
-
-
-
+<?xml version="1.0"?>
+<?pi?>
<!--comment-->
<?pi?>
-
-
-
<!--comment-->
-<?pi?><doc/>
+<?pi?>
+<doc/>
<?pi?>
<!--comment-->
<?pi?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0029.xml@0-38 :| [])
+NodePI xml "" in test/Golden/XML/0029.xml at char position 0 to 38
|
-+- (NodeAttr version) @(test/Golden/XML/0029.xml@5-19 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0029.xml@15-18 :| [])
++- NodePI version "1.0" in test/Golden/XML/0029.xml at char position 5 to 19
|
-`- (NodeAttr standalone) @(test/Golden/XML/0029.xml@19-30 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "yes"]))) @(test/Golden/XML/0029.xml@32-35 :| [])
+`- NodePI standalone "yes" in test/Golden/XML/0029.xml at char position 19 to 36
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0029.xml@38-40 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0029.xml@40-46 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0029.xml@46-48 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0029.xml at char position 40 to 46
<?xml version="1.0" standalone="yes"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodePI xml "") @(test/Golden/XML/0030.xml@0-37 :| [])
+NodePI xml "" in test/Golden/XML/0030.xml at char position 0 to 37
|
-+- (NodeAttr version) @(test/Golden/XML/0030.xml@5-19 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedPlain "1.0"]))) @(test/Golden/XML/0030.xml@15-18 :| [])
++- NodePI version "1.0" in test/Golden/XML/0030.xml at char position 5 to 19
|
-`- (NodeAttr standalone) @(test/Golden/XML/0030.xml@19-30 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "no"]))) @(test/Golden/XML/0030.xml@32-34 :| [])
+`- NodePI standalone "no" in test/Golden/XML/0030.xml at char position 19 to 35
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0030.xml@37-39 :| [])
-
-(NodeElem doc) @(test/Golden/XML/0030.xml@39-45 :| [])
-
-(NodeText (EscapedText (fromList [EscapedPlain "\n"]))) @(test/Golden/XML/0030.xml@45-47 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0030.xml at char position 39 to 45
<?xml version="1.0" standalone="no"?>
-<doc/>
\ No newline at end of file
+<doc/>
-(NodeElem doc) @(test/Golden/XML/0031.xml@0-6 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0031.xml at char position 0 to 6
-<doc/>
\ No newline at end of file
+<doc/>
-
-<doc/>
\ No newline at end of file
+<doc/>
-(NodeElem doc) @(test/Golden/XML/0032.xml@0-18 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0032.xml at char position 0 to 18
|
-`- (NodeText (EscapedText (fromList [EscapedPlain "content"]))) @(test/Golden/XML/0032.xml@5-12 :| [])
+`- NodeText (EscapedText (fromList [EscapedPlain "content"])) in test/Golden/XML/0032.xml at char position 5 to 12
-<doc>content</doc>
\ No newline at end of file
+<doc>content</doc>
-
-<doc>content</doc>
\ No newline at end of file
+<doc>content</doc>
-(NodeElem doc) @(test/Golden/XML/0033.xml@0-11 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0033.xml at char position 0 to 11
-<doc/>
\ No newline at end of file
+<doc/>
-
-<doc/>
\ No newline at end of file
+<doc/>
-(NodeElem doc) @(test/Golden/XML/0034.xml@0-16 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0034.xml at char position 0 to 16
-<doc/>
\ No newline at end of file
+<doc/>
-
-<doc/>
\ No newline at end of file
+<doc/>
-(NodeElem doc) @(test/Golden/XML/0035.xml@0-21 :| [])
-|
-`- (NodeAttr att) @(test/Golden/XML/0035.xml@5-14 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "val"]))) @(test/Golden/XML/0035.xml@10-13 :| [])
+NodeElem doc (fromList [(att,EscapedAttr (fromList [EscapedPlain "val"]) in test/Golden/XML/0035.xml at char position 4 to 14)]) in test/Golden/XML/0035.xml at char position 0 to 21
-<doc att="val"/>
\ No newline at end of file
+<doc att="val"/>
-
-<doc att="val"/>
\ No newline at end of file
+<doc att="val"/>
-(NodeElem doc) @(test/Golden/XML/0036.xml@0-48 :| [])
-|
-+- (NodeAttr att) @(test/Golden/XML/0036.xml@5-14 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedPlain "val"]))) @(test/Golden/XML/0036.xml@10-13 :| [])
-|
-+- (NodeAttr att2) @(test/Golden/XML/0036.xml@15-26 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedPlain "val2"]))) @(test/Golden/XML/0036.xml@21-25 :| [])
-|
-`- (NodeAttr att3) @(test/Golden/XML/0036.xml@28-39 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "val3"]))) @(test/Golden/XML/0036.xml@34-38 :| [])
+NodeElem doc (fromList [(att3,EscapedAttr (fromList [EscapedPlain "val3"]) in test/Golden/XML/0036.xml at char position 26 to 39),(att2,EscapedAttr (fromList [EscapedPlain "val2"]) in test/Golden/XML/0036.xml at char position 14 to 26),(att,EscapedAttr (fromList [EscapedPlain "val"]) in test/Golden/XML/0036.xml at char position 4 to 14)]) in test/Golden/XML/0036.xml at char position 0 to 48
-<doc att="val" att2="val2" att3="val3"/>
\ No newline at end of file
+<doc att="val" att2="val2" att3="val3"/>
-
-<doc att="val" att2="val2" att3="val3"/>
\ No newline at end of file
+<doc att="val" att2="val2" att3="val3"/>
-(NodeElem doc) @(test/Golden/XML/0037.xml@0-21 :| [])
-|
-`- (NodeAttr att) @(test/Golden/XML/0037.xml@5-14 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "val"]))) @(test/Golden/XML/0037.xml@10-13 :| [])
+NodeElem doc (fromList [(att,EscapedAttr (fromList [EscapedPlain "val"]) in test/Golden/XML/0037.xml at char position 4 to 14)]) in test/Golden/XML/0037.xml at char position 0 to 21
-<doc att="val"/>
\ No newline at end of file
+<doc att="val"/>
-
-<doc att="val"/>
\ No newline at end of file
+<doc att="val"/>
-(NodeElem doc) @(test/Golden/XML/0038.xml@0-28 :| [])
-|
-`- (NodeAttr att) @(test/Golden/XML/0038.xml@5-21 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "val"]))) @(test/Golden/XML/0038.xml@17-20 :| [])
+NodeElem doc (fromList [(att,EscapedAttr (fromList [EscapedPlain "val"]) in test/Golden/XML/0038.xml at char position 4 to 21)]) in test/Golden/XML/0038.xml at char position 0 to 28
-<doc att="val"/>
\ No newline at end of file
+<doc att="val"/>
-
-<doc att="val"/>
\ No newline at end of file
+<doc att="val"/>
-(NodeElem doc) @(test/Golden/XML/0039.xml@0-11 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0039.xml at char position 0 to 11
-<doc/>
\ No newline at end of file
+<doc/>
-
-<doc/>
\ No newline at end of file
+<doc/>
-(NodeElem doc) @(test/Golden/XML/0040.xml@0-15 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0040.xml at char position 0 to 15
-<doc/>
\ No newline at end of file
+<doc/>
-
-<doc/>
\ No newline at end of file
+<doc/>
-(NodeElem doc) @(test/Golden/XML/0041.xml@0-6 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0041.xml at char position 0 to 6
-<doc/>
\ No newline at end of file
+<doc/>
-
-<doc/>
\ No newline at end of file
+<doc/>
-(NodeElem doc) @(test/Golden/XML/0042.xml@0-16 :| [])
-|
-`- (NodeAttr att) @(test/Golden/XML/0042.xml@5-14 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "val"]))) @(test/Golden/XML/0042.xml@10-13 :| [])
+NodeElem doc (fromList [(att,EscapedAttr (fromList [EscapedPlain "val"]) in test/Golden/XML/0042.xml at char position 4 to 14)]) in test/Golden/XML/0042.xml at char position 0 to 16
-<doc att="val"/>
\ No newline at end of file
+<doc att="val"/>
-
-<doc att="val"/>
\ No newline at end of file
+<doc att="val"/>
-(NodeElem doc) @(test/Golden/XML/0043.xml@0-22 :| [])
-|
-`- (NodeAttr att) @(test/Golden/XML/0043.xml@5-14 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "val"]))) @(test/Golden/XML/0043.xml@10-13 :| [])
+NodeElem doc (fromList [(att,EscapedAttr (fromList [EscapedPlain "val"]) in test/Golden/XML/0043.xml at char position 4 to 14)]) in test/Golden/XML/0043.xml at char position 0 to 22
-<doc att="val"/>
\ No newline at end of file
+<doc att="val"/>
-
-<doc att="val"/>
\ No newline at end of file
+<doc att="val"/>
-(NodeElem doc) @(test/Golden/XML/0044.xml@0-12 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0044.xml at char position 0 to 12
-<doc/>
\ No newline at end of file
+<doc/>
-
-<doc/>
\ No newline at end of file
+<doc/>
-(NodeElem doc) @(test/Golden/XML/0045.xml@0-41 :| [])
-|
-+- (NodeAttr att) @(test/Golden/XML/0045.xml@5-14 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedPlain "val"]))) @(test/Golden/XML/0045.xml@10-13 :| [])
-|
-+- (NodeAttr att2) @(test/Golden/XML/0045.xml@16-27 :| [])
-| |
-| `- (NodeText (EscapedText (fromList [EscapedPlain "val2"]))) @(test/Golden/XML/0045.xml@22-26 :| [])
-|
-`- (NodeAttr att3) @(test/Golden/XML/0045.xml@28-39 :| [])
- |
- `- (NodeText (EscapedText (fromList [EscapedPlain "val3"]))) @(test/Golden/XML/0045.xml@34-38 :| [])
+NodeElem doc (fromList [(att3,EscapedAttr (fromList [EscapedPlain "val3"]) in test/Golden/XML/0045.xml at char position 27 to 39),(att2,EscapedAttr (fromList [EscapedPlain "val2"]) in test/Golden/XML/0045.xml at char position 14 to 27),(att,EscapedAttr (fromList [EscapedPlain "val"]) in test/Golden/XML/0045.xml at char position 4 to 14)]) in test/Golden/XML/0045.xml at char position 0 to 41
-<doc att="val" att2="val2" att3="val3"/>
\ No newline at end of file
+<doc att="val" att2="val2" att3="val3"/>
-
-<doc att="val" att2="val2" att3="val3"/>
\ No newline at end of file
+<doc att="val" att2="val2" att3="val3"/>
-(NodeElem doc) @(test/Golden/XML/0046.xml@0-81 :| [])
+NodeElem doc (fromList []) in test/Golden/XML/0046.xml at char position 0 to 81
|
-`- (NodeText (EscapedText (fromList [EscapedPlain "\r\n",EscapedCharRef (CharRef 'A'),EscapedCharRef (CharRef '\t'),EscapedCharRef (CharRef 'A'),EscapedCharRef (CharRef 'O'),EscapedCharRef (CharRef 'O'),EscapedCharRef (CharRef '\t'),EscapedPlain "\r\n",EscapedCharRef (CharRef '\1110764'),EscapedCharRef (CharRef '\n'),EscapedPlain "\r\n"]))) @(test/Golden/XML/0046.xml@5-75 :| [])
+`- NodeText (EscapedText (fromList [EscapedPlain "\r\n",EscapedCharRef (CharRef 'A'),EscapedCharRef (CharRef '\t'),EscapedCharRef (CharRef 'A'),EscapedCharRef (CharRef 'O'),EscapedCharRef (CharRef 'O'),EscapedCharRef (CharRef '\t'),EscapedPlain "\r\n",EscapedCharRef (CharRef '\1110764'),EscapedCharRef (CharRef '\n'),EscapedPlain "\r\n"])) in test/Golden/XML/0046.xml at char position 5 to 75
<doc>\r
A	AOO	\r
􏋬 \r
-</doc>
\ No newline at end of file
+</doc>
-
<doc>\r
A	AOO	\r
􏋬 \r
-</doc>
\ No newline at end of file
+</doc>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<plist version="1.0">
+<dict>
+ <!-- these aren't the droids you're looking for -->
+ <!---><!-->
+ <key>platform-application</key>
+ <true/>
+ <key>com.apple.private.security.no-container</key>
+ <true/>
+ <key>task_for_pid-allow</key>
+ <true/>
+ <!-- -->
+</dict>
+</plist>
--- /dev/null
+NodePI xml "" in test/Golden/XML/0047.xml at char position 0 to 38
+|
++- NodePI version "1.0" in test/Golden/XML/0047.xml at char position 5 to 19
+|
+`- NodePI encoding "UTF-8" in test/Golden/XML/0047.xml at char position 19 to 36
+
+NodeElem plist (fromList [(version,EscapedAttr (fromList [EscapedPlain "1.0"]) in test/Golden/XML/0047.xml at char position 45 to 59)]) in test/Golden/XML/0047.xml at char position 39 to 330
+|
++- NodeText (EscapedText (fromList [EscapedPlain "\n"])) in test/Golden/XML/0047.xml at char position 60 to 61
+|
++- NodeElem dict (fromList []) in test/Golden/XML/0047.xml at char position 61 to 321
+| |
+| +- NodeText (EscapedText (fromList [EscapedPlain "\n "])) in test/Golden/XML/0047.xml at char position 67 to 72
+| |
+| +- NodeComment " these aren't the droids you're looking for " in test/Golden/XML/0047.xml at char position 72 to 123
+| |
+| +- NodeText (EscapedText (fromList [EscapedPlain "\n "])) in test/Golden/XML/0047.xml at char position 123 to 128
+| |
+| +- NodeComment "-><!" in test/Golden/XML/0047.xml at char position 128 to 139
+| |
+| +- NodeText (EscapedText (fromList [EscapedPlain "\n "])) in test/Golden/XML/0047.xml at char position 139 to 144
+| |
+| +- NodeElem key (fromList []) in test/Golden/XML/0047.xml at char position 144 to 175
+| | |
+| | `- NodeText (EscapedText (fromList [EscapedPlain "platform-application"])) in test/Golden/XML/0047.xml at char position 149 to 169
+| |
+| +- NodeText (EscapedText (fromList [EscapedPlain "\n "])) in test/Golden/XML/0047.xml at char position 175 to 180
+| |
+| +- NodeElem true (fromList []) in test/Golden/XML/0047.xml at char position 180 to 187
+| |
+| +- NodeText (EscapedText (fromList [EscapedPlain "\n "])) in test/Golden/XML/0047.xml at char position 187 to 192
+| |
+| +- NodeElem key (fromList []) in test/Golden/XML/0047.xml at char position 192 to 242
+| | |
+| | `- NodeText (EscapedText (fromList [EscapedPlain "com.apple.private.security.no-container"])) in test/Golden/XML/0047.xml at char position 197 to 236
+| |
+| +- NodeText (EscapedText (fromList [EscapedPlain "\n "])) in test/Golden/XML/0047.xml at char position 242 to 247
+| |
+| +- NodeElem true (fromList []) in test/Golden/XML/0047.xml at char position 247 to 254
+| |
+| +- NodeText (EscapedText (fromList [EscapedPlain "\n "])) in test/Golden/XML/0047.xml at char position 254 to 259
+| |
+| +- NodeElem key (fromList []) in test/Golden/XML/0047.xml at char position 259 to 288
+| | |
+| | `- NodeText (EscapedText (fromList [EscapedPlain "task_for_pid-allow"])) in test/Golden/XML/0047.xml at char position 264 to 282
+| |
+| +- NodeText (EscapedText (fromList [EscapedPlain "\n "])) in test/Golden/XML/0047.xml at char position 288 to 293
+| |
+| +- NodeElem true (fromList []) in test/Golden/XML/0047.xml at char position 293 to 300
+| |
+| +- NodeText (EscapedText (fromList [EscapedPlain "\n "])) in test/Golden/XML/0047.xml at char position 300 to 305
+| |
+| +- NodeComment " " in test/Golden/XML/0047.xml at char position 305 to 313
+| |
+| `- NodeText (EscapedText (fromList [EscapedPlain "\n"])) in test/Golden/XML/0047.xml at char position 313 to 314
+|
+`- NodeText (EscapedText (fromList [EscapedPlain "\n"])) in test/Golden/XML/0047.xml at char position 321 to 322
+
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<plist version="1.0">
+ <dict>
+ <!-- these aren't the droids you're looking for -->
+ <!---><!-->
+ <key>platform-application</key>
+ <true/>
+ <key>com.apple.private.security.no-container</key>
+ <true/>
+ <key>task_for_pid-allow</key>
+ <true/>
+ <!-- -->
+ </dict>
+</plist>
--- /dev/null
+<?xml version="1.0" encoding="UTF-8"?>
+<plist version="1.0">
+ <dict>
+ <!-- these aren't the droids you're looking for -->
+ <!---><!-->
+ <key>platform-application</key>
+ <true/>
+ <key>com.apple.private.security.no-container</key>
+ <true/>
+ <key>task_for_pid-allow</key>
+ <true/>
+ <!-- -->
+ </dict>
+</plist>
2 | <.doc></.doc>\r
| ^
unexpected '.'
-expecting '!', '?', or Element
+expecting '!', '?', or NCName
1 | <doc><? ?></doc>\r
| ^
unexpected space
-expecting PI
+expecting NCName
-test/Golden/XML/Error/0018.xml:1:6 :
+test/Golden/XML/Error/0018.xml:1:8 :
|
1 | <doc a1></doc>\r
- | ^ ^
-unexpected "a1"
-expecting "/>" or '> '
+ | ^
+unexpected '>'
+expecting ':' or '= '
-test/Golden/XML/Error/0019.xml:1:6 :
+test/Golden/XML/Error/0019.xml:1:9 :
|
1 | <doc a1=v1></doc>\r
- | ^ ^
-unexpected "a1"
-expecting "/>" or '> '
+ | ^
+unexpected 'v'
+expecting '"' or '' '
-test/Golden/XML/Error/0020.xml:1:6 :
+test/Golden/XML/Error/0020.xml:1:14 :
|
1 | <doc a1="v1'></doc>\r
- | ^ ^
-unexpected "a1"
-expecting "/>" or '>'
+ | ^
+unexpected '<'
+expecting "&#", "&#x", '"', '&', or [^<&"]
-test/Golden/XML/Error/0021.xml:1:6 :
+test/Golden/XML/Error/0021.xml:1:10 :
|
1 | <doc a1="<foo>"></doc>\r
- | ^ ^
-unexpected "a1"
-expecting "/>" or '>'
+ | ^
+unexpected '<'
+expecting "&#", "&#x", '"', '&', or [^<&"]
-test/Golden/XML/Error/0022.xml:1:6 :
+test/Golden/XML/Error/0022.xml:1:9 :
|
1 | <doc a1=></doc>\r
- | ^ ^
-unexpected "a1"
-expecting "/>" or '> '
+ | ^
+unexpected '>'
+expecting '"' or '' '
1 | <doc></>\r
| ^
unexpected '>'
-expecting Q Name
+expecting NC Name
-test/Golden/XML/Error/0027.xml:1:6 :
+test/Golden/XML/Error/0027.xml:1:13 :
|
1 | <doc a1="A & B"></doc>\r
- | ^ ^
-unexpected "a1"
-expecting "/>" or '>'
+ | ^
+unexpected space
+expecting NCName
-test/Golden/XML/Error/0028.xml:1:6 :
+test/Golden/XML/Error/0028.xml:1:13 :
|
1 | <doc a1="a&b"></doc>\r
- | ^ ^
-unexpected "a1"
-expecting "/>" or '> '
+ | ^
+unexpected '"'
+expecting '; '
-test/Golden/XML/Error/0029.xml:1:6 :
+test/Golden/XML/Error/0029.xml:1:15 :
|
1 | <doc a1="{:"></doc>\r
- | ^ ^
-unexpected "a1"
-expecting "/>" or '>'
+ | ^
+unexpected ':'
+expecting ';' or digit
2 | <123></123>\r
| ^
unexpected '1'
-expecting '!', '?', or Element
+expecting '!', '?', or NCName
1 | <doc>A form feed (\f ) is not legal in data</doc>\r
| ^^
unexpected "<form feed>)"
-expecting "</", '<', ']', CharRef, or EntityRef
+expecting "&#", "&#x", "</", '&', '<', ']', or [^<&]
1 | <doc>abc\e def</doc>\r
| ^^
unexpected "<escape>d"
-expecting "</", '<', ']', CharRef, or EntityRef
+expecting "&#", "&#x", "</", '&', '<', ']', or [^<&]
1 | <doc\f >A form-feed is not white space or a name character</doc\f >\r
| ^^
unexpected "<form feed>>"
-expecting "/>", ':', '>', or Spaces1
+expecting "/>", ':', '>', or spaces
1 | <doc>1 < 2 but not in XML</doc>\r
| ^
unexpected space
-expecting '!', '?', or Element
+expecting '!', '?', or NCName
2 | Illegal data\r
| ^
unexpected 'I'
-expecting "<!--", "<?", CRLF, Spaces, or end of input
+expecting "<!--", "<?", end of input, or spaces
2 |  \r
| ^
unexpected '&'
-expecting "<!--", "<?", CRLF, Spaces, or end of input
+expecting "<!--", "<?", end of input, or spaces
2 | <doc></doc>\r
| ^
unexpected '<'
-expecting "<!--", "<?", CRLF, Spaces, or end of input
+expecting "<!--", "<?", end of input, or spaces
2 | <doc></doc>\r
| ^
unexpected '<'
-expecting "<!--", "<?", CRLF, Spaces, or end of input
+expecting "<!--", "<?", end of input, or spaces
1 | <doc/></doc/>\r
| ^
unexpected '<'
-expecting "<!--", "<?", Spaces, or end of input
+expecting "<!--", "<?", end of input, or spaces
2 | Illegal data\r
| ^
unexpected 'I'
-expecting "<!--", "<?", CRLF, Spaces, or end of input
+expecting "<!--", "<?", end of input, or spaces
1 | <doc/><doc/>\r
| ^
unexpected '<'
-expecting "<!--", "<?", Spaces, or end of input
+expecting "<!--", "<?", end of input, or spaces
2 | <a/\r
| ^^
unexpected "/<carriage return>"
-expecting "/>", ':', '>', or Spaces1
+expecting "/>", ':', '>', or spaces
2 | <a/</a>\r
| ^^
unexpected "/<"
-expecting "/>", ':', '>', or Spaces1
+expecting "/>", ':', '>', or spaces
3 | <![CDATA[]]>\r
| ^
unexpected '<'
-expecting "<!--", "<?", CRLF, Spaces, or end of input
+expecting "<!--", "<?", end of input, or spaces
1 | <empty line>
| ^
unexpected end of input
-expecting "<!--", "<?", '<', Spaces, or XMLDecl
+expecting "<!--", "<?", "<?xml", '<', or spaces
2 | <![CDATA[]]>\r
| ^
unexpected '!'
-expecting Element
+expecting NCName
2 |  \r
| ^
unexpected '&'
-expecting "<!--", "<?", '<', CRLF, or S paces
+expecting "<!--", "<?", '<', or s paces
-test/Golden/XML/Error/0061.xml:1:2 :
+test/Golden/XML/Error/0061.xml:1:41 :
|
1 | <!-- a comment ending with three dashes --->\r
- | ^
-unexpected '!'
-expecting Element
+ | ^^ ^
+unexpected "---"
+expecting "-->"
-test/Golden/XML/Error/0063.xml:1:6 :
+test/Golden/XML/Error/0063.xml:1:14 :
|
1 | <doc a="&foo;"></doc>\r
- | ^^
-unexpected "a="
-expecting "/>" or '>'
+ | ^
+Error_EntityRef_unknown foo
1 | <?xml VERSION="1.0"?>\r
| ^^^^^^^
unexpected "VERSION"
-expecting VersionInfo
+expecting "version"
1 | <?xml encoding="UTF-8" version="1.0"?>\r
| ^^^^^^^
unexpected "encodin"
-expecting VersionInfo
+expecting "version"
1 | <?xml version="1.0"encoding="UTF-8" ?>\r
| ^^
unexpected "en"
-expecting "?>", EncodingDecl, or SDDecl
+expecting "?>" or spaces
2 | <![CDATA[]]>\r
| ^
unexpected '!'
-expecting Element
+expecting NCName
2 |  <doc></doc>\r
| ^
unexpected '&'
-expecting "<!--", "<?", '<', CRLF, or S paces
+expecting "<!--", "<?", '<', or s paces
-test/Golden/XML/Error/0078.xml:2:2 :
+test/Golden/XML/Error/0078.xml:2:6 :
|
2 | <?xml version="1.0"?>\r
- | ^
-unexpected '?'
-expecting Element
+ | ^
+Error_PI_reserved xml
-test/Golden/XML/Error/0079.xml:2:2 :
+test/Golden/XML/Error/0079.xml:2:6 :
|
2 | <?xml version="1.0"?>\r
- | ^
-unexpected '?'
-expecting Element
+ | ^
+Error_PI_reserved xml
-test/Golden/XML/Error/0081.xml:3:1 :
+test/Golden/XML/Error/0081.xml:3:6 :
|
3 | <?xml version="1.0"?>\r
- | ^
-unexpected '<'
-expecting CRLF or end of input
+ | ^
+Error_PI_reserved xml
1 | <?xml encoding="UTF-8"?>\r
| ^^^^^^^
unexpected "encodin"
-expecting VersionInfo
+expecting "version"
-test/Golden/XML/Error/0083.xml:1:2 :
+test/Golden/XML/Error/0083.xml:1:6 :
|
1 | <?XML version="1.0"?>\r
- | ^
-unexpected '?'
-expecting Element
+ | ^
+Error_PI_reserved XML
-test/Golden/XML/Error/0084.xml:1:2 :
+test/Golden/XML/Error/0084.xml:1:6 :
|
1 | <?xmL version="1.0"?>\r
- | ^
-unexpected '?'
-expecting Element
+ | ^
+Error_PI_reserved xmL
Content-type: text/html
]>
Git — Sourcephile - haskell/symantic-xml.git/commitdiff
sourcephile / git / haskell / symantic-xml.git / commitdiff