diff --git a/Symantic/RNC.hs b/Symantic/RNC.hs deleted file mode 100644 --- a/Symantic/RNC.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Symantic.RNC - ( module Symantic.RNC.Sym - , module Symantic.RNC.Validate - , module Symantic.RNC.Write - , Functor(..) - , Applicative(..) - , Alternative((<|>)) - ) where -import Data.Functor -import Control.Applicative - -import Symantic.RNC.Sym -import Symantic.RNC.Write -import Symantic.RNC.Validate diff --git a/Symantic/RNC/Sym.hs b/Symantic/RNC/Sym.hs deleted file mode 100644 --- a/Symantic/RNC/Sym.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE TypeFamilyDependencies #-} -module Symantic.RNC.Sym - ( module Symantic.RNC.Sym - , Functor(..), (<$>) - , Applicative(..) - , Alternative(..) - ) where - -import Control.Applicative (Applicative(..), Alternative(..)) -import Data.Eq (Eq) -import Data.Function ((.), id) -import Data.Functor (Functor(..), (<$>)) -import Data.Maybe (Maybe(..)) -import Data.Sequence (Seq) -import Data.String (String) -import Text.Show (Show(..)) -import qualified Data.Sequence as Seq -import qualified Data.Text.Lazy as TL - -import qualified Symantic.XML as XML - --- * Class 'Sym_RNC' -class - ( Applicative repr - , Alternative repr - , Sym_Rule repr - , Sym_Permutation repr - ) => Sym_RNC repr where - namespace :: Maybe XML.NCName -> XML.Namespace -> repr () - element :: XML.QName -> repr a -> repr a - attribute :: XML.QName -> repr a -> repr a - any :: repr () - anyElem :: XML.Namespace -> (XML.NCName -> repr a) -> repr a - escapedText :: repr XML.EscapedText - text :: repr TL.Text - text = XML.unescapeText <$> escapedText - fail :: repr a - try :: repr a -> repr a - option :: a -> repr a -> repr a - optional :: repr a -> repr (Maybe a) - choice :: [repr a] -> repr a - intermany :: [repr a] -> repr [a] - intermany = many . choice . (try <$>) - manySeq :: repr a -> repr (Seq a) - manySeq r = Seq.fromList <$> many r - someSeq :: repr a -> repr (Seq a) - someSeq r = Seq.fromList <$> some r - --- * Class 'Sym_Rule' -class Sym_Rule repr where - rule :: Show a => String -> repr a -> repr a - rule _n = id - arg :: String -> repr () - --- ** Type 'RuleMode' -data RuleMode - = RuleMode_Body -- ^ Request to generate the body of the rule. - | RuleMode_Ref -- ^ Request to generate a reference to the rule. - | RuleMode_Def -- ^ Request to generate a definition of the rule. - deriving (Eq, Show) - --- * Class 'Sym_Permutation' -class (Alternative repr, Applicative (Permutation repr)) => Sym_Permutation repr where - runPermutation :: Permutation repr a -> repr a - toPermutation :: repr a -> Permutation repr a - toPermutationWithDefault :: a -> repr a -> Permutation repr a - - (<$$>) :: (a -> b) -> repr a -> Permutation repr b - (<$?>) :: (a -> b) -> (a, repr a) -> Permutation repr b - (<$*>) :: ([a] -> b) -> repr a -> Permutation repr b - (<$:>) :: (Seq a -> b) -> repr a -> Permutation repr b - infixl 2 <$$>, <$?>, <$*>, <$:> - {-# INLINE (<$$>) #-} - {-# INLINE (<$?>) #-} - {-# INLINE (<$*>) #-} - {-# INLINE (<$:>) #-} - - (<||>) :: Permutation repr (a -> b) -> repr a -> Permutation repr b - (<|?>) :: Permutation repr (a -> b) -> (a, repr a) -> Permutation repr b - (<|*>) :: Permutation repr ([a] -> b) -> repr a -> Permutation repr b - (<|:>) :: Permutation repr (Seq a -> b) -> repr a -> Permutation repr b - infixl 1 <||>, <|?>, <|*>, <|:> - {-# INLINE (<||>) #-} - {-# INLINE (<|?>) #-} - {-# INLINE (<|*>) #-} - {-# INLINE (<|:>) #-} - - f <$$> x = f <$> toPermutation x - f <$?> (d,x) = f <$> toPermutationWithDefault d x - f <$*> x = f <$> toPermutationWithDefault [] (some x) - f <$:> x = f . Seq.fromList <$> toPermutationWithDefault [] (some x) - - f <||> x = f <*> toPermutation x - f <|?> (d,x) = f <*> toPermutationWithDefault d x - f <|*> x = f <*> toPermutationWithDefault [] (some x) - f <|:> x = f <*> toPermutationWithDefault Seq.empty (Seq.fromList <$> some x) - --- ** Type family 'Permutation' --- | Type of permutations, depending on the representation. -type family Permutation (repr:: * -> *) = (r :: * -> *) | r -> repr diff --git a/Symantic/RNC/Validate.hs b/Symantic/RNC/Validate.hs deleted file mode 100644 --- a/Symantic/RNC/Validate.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Symantic.RNC.Validate where - -import Control.Applicative (Applicative(..), Alternative(..), optional) -import Control.Monad (Monad(..)) -import Data.Bool -import Data.Either (Either(..)) -import Data.Eq (Eq(..)) -import Data.Foldable (Foldable(..), all) -import Data.Function (($), const, id) -import Data.Functor (Functor(..), (<$>)) -import Data.Maybe (Maybe(..), maybe) -import Data.Monoid (Monoid(..)) -import Data.Ord (Ord(..)) -import Data.Semigroup (Semigroup(..)) -import Data.Tuple (snd) -import Prelude (error) -import Data.Sequence (Seq) -import qualified Data.Char as Char -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Text.Lazy as TL -import qualified Text.Megaparsec as P - -import Symantic.XML (XMLs) -import qualified Symantic.XML as XML -import qualified Symantic.RNC.Sym as RNC - -validateXML :: - Ord e => P.Parsec e (XMLs src) a -> XMLs src -> - Either (P.ParseErrorBundle (XMLs src) e) a -validateXML p stateInput = - snd $ - P.runParser' p P.State - { P.stateInput - , P.stateOffset = 0 - , P.statePosState = error "[BUG] validateXML: getSourcePos is not helpful here, please use annotated source locations" - -- NOTE: reporting the node number is less helpful - -- than the source text line and number where the node is; - -- P.statePosState is only used by P.getSourcePos. - } - -instance - ( Ord err - , Ord src - , XML.NoSource src - , P.Stream (Seq (XML.XML src)) - , P.Token (Seq (XML.XML src)) ~ XML.Tree (XML.Sourced src XML.Node) - ) => RNC.Sym_RNC (P.Parsec err (XMLs src)) where - {- - none = P.label "none" $ P.eof - -} - namespace _p _n = pure () - element n p = do - ts <- P.token check $ Set.singleton $ P.Tokens $ pure expected - p_XMLs p ts - where - expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty - check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts) - | e == n - = Just $ removePI $ removeXMLNS $ removeSpaces ts - where - removePI xs = - (`Seq.filter` xs) $ \case - XML.Tree (XML.unSourced -> XML.NodePI{}) _ts -> False - _ -> True - removeSpaces xs = - if (`all` xs) $ \case - XML.Tree (XML.unSourced -> XML.NodeText (XML.EscapedText et)) _ts -> - all (\case - XML.EscapedPlain t -> TL.all Char.isSpace t - _ -> False) et - _ -> True - then (`Seq.filter` xs) $ \case - XML.Tree (XML.unSourced -> XML.NodeText{}) _ts -> False - _ -> True - else xs - removeXMLNS xs = - let (attrs,rest) = (`Seq.spanl` xs) $ \case - XML.Tree (XML.unSourced -> XML.NodeAttr{}) _ts -> True - _ -> False in - let attrs' = (`Seq.filter` attrs) $ \case - XML.Tree (XML.unSourced -> XML.NodeAttr a) _ts -> - case a of - XML.QName "" "xmlns" -> False - XML.QName ns _l -> ns /= XML.xmlns_xmlns - _ -> True in - attrs' <> rest - check _t = Nothing - attribute n p = do - v <- P.token check $ Set.singleton $ P.Tokens $ pure expected - p_XMLs p v - where - expected = XML.Tree0 (XML.notSourced $ XML.NodeAttr n) - check (XML.Tree (XML.unSourced -> XML.NodeAttr k) - v@(toList -> [XML.Tree0 (XML.unSourced -> XML.NodeText _v)])) | k == n = - Just v - check _t = Nothing - any = P.label "any" $ - P.token (const $ Just ()) Set.empty - anyElem ns p = P.label "anyElem" $ do - (n,ts) <- P.token check $ Set.singleton $ P.Tokens $ pure expected - p_XMLs (p $ XML.qNameLocal n) ts - where - expected = XML.Tree (XML.notSourced $ XML.NodeElem $ XML.QName ns $ XML.NCName "*") mempty - check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts) - | XML.qNameSpace e == ns - = Just $ (e,ts) - check _t = Nothing - {- - comment = do - s <- P.getInput - case Seq.viewl s of - XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do - P.setInput ts - c <$ XML.setFilePosToNextNode - t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex - EmptyL -> P.failure Nothing ex - where - ex = Set.singleton $ P.Tokens $ pure expected - expected = XML.Tree0 (XML.notSourced $ XML.NodeComment "") - -} - escapedText = do - P.token check $ Set.singleton $ P.Tokens $ pure expected - where - expected = XML.Tree0 (XML.notSourced $ XML.NodeText $ XML.EscapedText mempty) - check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Just t - check _t = Nothing - optional = P.optional - option = P.option - choice = P.choice - try = P.try - fail = P.label "fail" $ P.failure Nothing mempty - --- | @p_XMLs p xs@ returns a parser parsing @xs@ entirely with @p@, --- updating 'P.stateOffset' and re-raising any exception. -p_XMLs :: - Ord err => Ord src => - P.Stream (Seq (XML.XML src)) => - P.Parsec err (XMLs src) a -> XMLs src -> P.Parsec err (XMLs src) a -p_XMLs p stateInput = do - st <- P.getParserState - let (st', res) = P.runParser' (p <* P.eof) st - { P.stateInput = stateInput - , P.stateOffset = P.stateOffset st - } - P.updateParserState (\s -> s{P.stateOffset = P.stateOffset st'}) - case res of - Right a -> return a - Left (P.ParseErrorBundle errs _) -> - case NonEmpty.head errs of - P.TrivialError _o us es -> P.failure us es - P.FancyError _o es -> P.fancyFailure es - --- | Whether the given 'XML.Node' must be ignored by the RNC parser. -isIgnoredNode :: XML.Node -> Bool -isIgnoredNode = \case - XML.NodeComment{} -> True - XML.NodePI{} -> True - XML.NodeCDATA{} -> True - _ -> False - -instance - ( Ord err - , Ord src - , P.Stream (Seq (XML.XML src)) - ) => RNC.Sym_Permutation (P.ParsecT err (XMLs src) m) where - runPermutation (Perm value parser) = optional parser >>= f - where - -- NOTE: copy Control.Applicative.Permutations.runPermutation - -- to replace the commented empty below so that P.TrivialError - -- has the unexpected token. - f Nothing = maybe {-empty-}(P.token (const Nothing) Set.empty) pure value - f (Just p) = RNC.runPermutation p - toPermutation p = Perm Nothing $ pure <$> p - toPermutationWithDefault v p = Perm (Just v) $ pure <$> p - --- | Unprivatized 'Control.Applicative.Permutations.Permutation' to fix 'runPermutation'. --- so that the 'P.TrivialError' has an unexpected token --- which is an 'XML.Node' containing a 'XML.FileSource' useful when reporting errors. -data Perm m a = Perm (Maybe a) (m (Perm m a)) -type instance RNC.Permutation (P.ParsecT err (XMLs src) m) = Perm (P.ParsecT err (XMLs src) m) -instance Functor m => Functor (Perm m) where - fmap f (Perm v p) = Perm (f <$> v) (fmap f <$> p) -instance Alternative m => Applicative (Perm m) where - pure value = Perm (Just value) empty - lhs@(Perm f v) <*> rhs@(Perm g w) = Perm (f <*> g) (lhsAlt <|> rhsAlt) - where - lhsAlt = (<*> rhs) <$> v - rhsAlt = (lhs <*>) <$> w - -instance - ( Ord err - , Ord src - , P.Stream (Seq (XML.XML src)) - ) => RNC.Sym_Rule (P.ParsecT err (XMLs src) m) where - -- rule n p = P.dbg s p {-(p P. s)-} where s = Text.unpack n - rule _n = id - arg _n = pure () diff --git a/Symantic/RNC/Write.hs b/Symantic/RNC/Write.hs deleted file mode 100644 --- a/Symantic/RNC/Write.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -module Symantic.RNC.Write - ( module Symantic.RNC.Write - , module Symantic.RNC.Write.Fixity - , module Symantic.RNC.Write.Namespaces - ) where - -import Control.Applicative (Applicative(..), Alternative(..)) -import Control.Monad -import Data.Bool -import Data.Function (($), (.), id) -import Data.Functor ((<$>)) -import Data.Functor.Compose (Compose(..)) -import Data.Semigroup (Semigroup(..)) -import Data.String (IsString(..)) -import Text.Show (Show(..)) -import qualified Data.HashMap.Strict as HM -import qualified Data.List as List -import qualified Data.Text.Lazy as TL --- import qualified Data.Text.Lazy.Builder as TLB - -import Symantic.RNC.Sym -import Symantic.RNC.Write.Fixity -import Symantic.RNC.Write.Namespaces -import qualified Symantic.XML as XML - --- | Get textual rendition of given 'RuleWriter'. -writeRNC :: [NS a] -> [Writer a] -> TL.Text -writeRNC ns ws = - let namespaces@XML.Namespaces{..} = runNS ns in - TL.unlines $ List.concat - [ [ "default namespace = \""<>XML.unNamespace namespaces_default<>"\"" - | not $ TL.null $ XML.unNamespace namespaces_default - ] - , [ "namespace "<>p<>" = \""<>n<>"\"" - | (XML.Namespace n, XML.NCName p) <- HM.toList namespaces_prefixes - ] - , runWriter namespaces <$> ws - ] - --- * Type 'Writer' -newtype Writer a - = Writer { unWriter :: XML.Namespaces XML.NCName -> - RuleMode -> - (Infix, Side) -> - Pair -> TL.Text } - --- | Get textual rendition of given 'Writer'. -runWriter :: XML.Namespaces XML.NCName -> Writer a -> TL.Text -runWriter ns (Writer w) = - w ns RuleMode_Def (infixN0, SideL) pairParen - -coerceWriter :: Writer a -> Writer b -coerceWriter = Writer . unWriter -{-# INLINE coerceWriter #-} - -{- -instance Show (Writer a) where - show = TL.unpack . runWriter --} -instance Functor Writer where - fmap _f (Writer x) = Writer x -instance Applicative Writer where - pure _ = writeText $ "\"\"" - Writer f <*> Writer x = Writer $ \ns rm po pp -> - pairIfNeeded pp po op $ - TL.intercalate ", " $ - List.filter (not . TL.null) $ - [ f ns rm (op, SideL) pairParen - , x ns rm (op, SideR) pairParen ] - where op = infixB SideL 2 -instance Alternative Writer where - empty = writeText "empty" - Writer wl <|> Writer wr = Writer $ \ns rm po pp -> - pairIfNeeded pp po op $ - wl ns rm (op, SideL) pairParen <> " | " <> wr ns rm (op, SideR) pairParen - where op = infixB SideL 2 - many (Writer w) = Writer $ \ns rm po pp -> - pairIfNeeded pp po op $ - w ns rm (op, SideL) pairParen <> "*" - where op = infixN 9 - some (Writer w) = Writer $ \ns rm po pp -> - pairIfNeeded pp po op $ - w ns rm (op, SideL) pairParen <> "+" - where op = infixN 9 -instance Sym_Rule Writer where - rule n wr@(Writer w) = Writer $ \ns rm po pp -> - case rm of - RuleMode_Ref -> - pairIfNeeded pp po op $ - fromString n - where op = infixN 10 - RuleMode_Body -> w ns RuleMode_Ref po pp - RuleMode_Def -> - TL.intercalate " " - [ fromString n - , "=" - , unWriter (rule n wr) ns RuleMode_Body (infixN0, SideR) pp - ] - arg n = - Writer $ \_ns rm _po _pp -> - case rm of - RuleMode_Ref -> fromString n - RuleMode_Body -> "" - RuleMode_Def -> "" -type instance Permutation Writer = Compose [] Writer -instance Sym_Permutation Writer where - runPermutation (Compose []) = writeText "empty" - runPermutation (Compose [Writer w]) = Writer w - runPermutation (Compose l@(_:_)) = Writer $ \ns rm po pp -> - pairIfNeeded pp po op $ - TL.intercalate " & " $ - List.filter (not . TL.null) $ - (unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen - where op = infixB SideL 1 - toPermutation = Compose . pure - toPermutationWithDefault _ = Compose . pure -instance Sym_RNC Writer where - namespace _p _n = writeText "" - element n (Writer w) = Writer $ \ns rm po pp -> - pairIfNeeded pp po op $ - "element "<>TL.pack (show $ XML.prefixifyQName ns n) - <>" "<>w ns rm (op,SideR) pairBrace - where op = infixN 10 - anyElem (XML.Namespace n) f = Writer $ \ns rm po pp -> - pairIfNeeded pp po op $ - (if TL.null n then "" else n<>":") <> - "* "<>w ns rm (op,SideR) pairBrace - where - op = infixN 0 - Writer w = f "" - attribute n (Writer w) = Writer $ \ns rm po pp -> - pairIfNeeded pp po op $ - "attribute "<>TL.pack (show $ XML.prefixifyQName ns n) - <>" "<>w ns rm (op,SideR) pairBrace - where op = infixN 10 - try = id - fail = writeText "fail" - escapedText = writeText "text" - text = writeText "text" - any = writeText "any" - choice [] = writeText "empty" - choice [w] = w - choice l@(_:_) = Writer $ \ns rm po pp -> - pairIfNeeded pp po op $ - TL.intercalate " | " $ - (unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen - where op = infixB SideL 2 - option _x (Writer w) = Writer $ \ns rm po pp -> - pairIfNeeded pp po op $ - w ns rm (op, SideL) pairParen <> "?" - where op = infixN 9 - optional (Writer w) = Writer $ \ns rm po pp -> - pairIfNeeded pp po op $ - w ns rm (op, SideL) pairParen <> "?" - where op = infixN 9 - manySeq = coerceWriter . many - someSeq = coerceWriter . some - --- | 'Writer' returns a constant rendition. -writeText :: TL.Text -> Writer a -writeText t = Writer $ \_ns _rm po pp -> - pairIfNeeded pp po op t - where op = infixN 10 diff --git a/Symantic/RNC/Write/Fixity.hs b/Symantic/RNC/Write/Fixity.hs deleted file mode 100644 --- a/Symantic/RNC/Write/Fixity.hs +++ /dev/null @@ -1,110 +0,0 @@ -module Symantic.RNC.Write.Fixity where - -import Data.Bool -import Data.Eq (Eq(..)) -import Data.Function ((.)) -import Data.Int (Int) -import Data.Maybe (Maybe(..)) -import Data.Ord (Ord(..)) -import Data.Semigroup -import Data.String (String, IsString(..)) -import Text.Show (Show(..)) - --- * Type 'Fixity' -data Fixity - = Fixity1 Unifix - | Fixity2 Infix - deriving (Eq, Show) - --- ** Type 'Unifix' -data Unifix - = Prefix { unifix_precedence :: Precedence } - | Postfix { unifix_precedence :: Precedence } - deriving (Eq, Show) - --- ** Type 'Infix' -data Infix - = Infix - { infix_associativity :: Maybe Associativity - , infix_precedence :: Precedence - } deriving (Eq, Show) - -infixL :: Precedence -> Infix -infixL = Infix (Just AssocL) - -infixR :: Precedence -> Infix -infixR = Infix (Just AssocR) - -infixB :: Side -> Precedence -> Infix -infixB = Infix . Just . AssocB - -infixN :: Precedence -> Infix -infixN = Infix Nothing - -infixN0 :: Infix -infixN0 = infixN 0 - -infixN5 :: Infix -infixN5 = infixN 5 - --- | Given 'Precedence' and 'Associativity' of its parent operator, --- and the operand 'Side' it is in, --- return whether an 'Infix' operator --- needs to be enclosed by a 'Pair'. -isPairNeeded :: (Infix, Side) -> Infix -> Bool -isPairNeeded (po, lr) op = - infix_precedence op < infix_precedence po - || infix_precedence op == infix_precedence po - && not associate - where - associate = - case (lr, infix_associativity po) of - (_, Just AssocB{}) -> True - (SideL, Just AssocL) -> True - (SideR, Just AssocR) -> True - _ -> False - --- | If 'isPairNeeded' is 'True', --- enclose the given 'IsString' by given 'Pair', --- otherwise returns the same 'IsString'. -pairIfNeeded :: - Semigroup s => IsString s => - Pair -> (Infix, Side) -> Infix -> - s -> s -pairIfNeeded (o,c) po op s = - if isPairNeeded po op - then fromString o <> s <> fromString c - else s - --- * Type 'Precedence' -type Precedence = Int - --- ** Class 'PrecedenceOf' -class PrecedenceOf a where - precedence :: a -> Precedence -instance PrecedenceOf Fixity where - precedence (Fixity1 uni) = precedence uni - precedence (Fixity2 inf) = precedence inf -instance PrecedenceOf Unifix where - precedence = unifix_precedence -instance PrecedenceOf Infix where - precedence = infix_precedence - --- * Type 'Associativity' -data Associativity - = AssocL -- ^ Associate to the left: @a ¹ b ² c == (a ¹ b) ² c@ - | AssocR -- ^ Associate to the right: @a ¹ b ² c == a ¹ (b ² c)@ - | AssocB Side -- ^ Associate to both sides, but to 'Side' when reading. - deriving (Eq, Show) - --- ** Type 'Side' -data Side - = SideL -- ^ Left - | SideR -- ^ Right - deriving (Eq, Show) - --- ** Type 'Pair' -type Pair = (String, String) -pairParen, pairBrace :: Pair -pairParen = ("(",")") -pairBrace = ("{","}") diff --git a/Symantic/RNC/Write/Namespaces.hs b/Symantic/RNC/Write/Namespaces.hs deleted file mode 100644 --- a/Symantic/RNC/Write/Namespaces.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -module Symantic.RNC.Write.Namespaces where - -import Control.Applicative (Applicative(..), Alternative(..), (<$>)) -import Control.Monad (Monad(..), forM, sequence) -import Data.Default.Class (Default(..)) -import Data.Function (($), (.), id) -import Data.Functor (Functor(..)) -import Data.Maybe (Maybe(..), maybe, isNothing) -import Data.Monoid (Monoid(..)) -import Data.Semigroup (Semigroup(..)) -import Text.Show (Show(..)) -import Data.String (String) -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Control.Monad.Trans.State.Strict as S - -import qualified Symantic.XML as XML -import Symantic.RNC.Sym - --- | Collect 'XML.Namespace's used and get them a dedicated prefix. -runNS :: forall a. [NS a] -> XML.Namespaces XML.NCName -runNS ns = - namespaces - { XML.namespaces_prefixes = - (`S.evalState` HS.empty) $ - let prefixesByNamespace = - HM.delete "" $ -- NOTE: no prefix when there is no namespace. - HM.update -- NOTE: no prefix when this is the default namespace. - (\p -> if isNothing p then Nothing else Just p) - (XML.namespaces_default namespaces) $ - XML.namespaces_prefixes namespaces in - forM prefixesByNamespace $ \mp -> do - usedPrefixes <- S.get - let fp = maybe - (XML.freshNCName usedPrefixes) - (XML.freshifyNCName usedPrefixes) - mp - S.modify' $ HS.insert fp - return fp - } - where - namespaces :: XML.Namespaces (Maybe XML.NCName) - namespaces = mconcat $ (`S.evalState` def) $ sequence $ unNS <$> ns - -coerceNS :: NS a -> NS b -coerceNS = NS . unNS -{-# INLINE coerceNS #-} - --- * Type 'NS' --- | Collect 'XML.Namespaces's and any prefixes associated with it, --- using 'State' to avoid recurring into already visited 'rule's. -newtype NS a = NS { unNS :: S.State State (XML.Namespaces (Maybe XML.NCName)) } - --- ** Type 'State' -newtype State = State - { state_rules :: {-!-}(HS.HashSet String) - } deriving (Show) -instance Default State where - def = State - { state_rules = HS.empty - } - -instance Show (NS a) where - showsPrec p = showsPrec p . runNS . pure -instance Semigroup (NS a) where - NS x <> NS y = NS $ (<>) <$> x <*> y -instance Monoid (NS a) where - mempty = NS $ return mempty - mappend = (<>) -instance Functor NS where - fmap _f = coerceNS -instance Applicative NS where - pure _ = mempty - NS f <*> NS x = NS f <> NS x - NS f <* NS x = NS f <> NS x - NS f *> NS x = NS f <> NS x -instance Alternative NS where - empty = mempty - NS f <|> NS x = NS f <> NS x - many = coerceNS - some = coerceNS -instance Sym_Rule NS where - rule n (NS ns) = NS $ do - -- NOTE: avoid infinite loops - -- by not reentering into already visited rules. - st@State{..} <- S.get - if HS.member n state_rules - then return mempty - else do - S.put $ st{state_rules = HS.insert n state_rules} - ns - arg _n = mempty -type instance Permutation NS = NS -instance Sym_Permutation NS where - runPermutation = coerceNS - toPermutation = id - toPermutationWithDefault _def = id -instance Sym_RNC NS where - -- namespace n ns = - -- NS $ return $ HM.singleton ns $ HS.singleton n - namespace mp n = - NS $ return $ - case mp of - Just p -> XML.Namespaces{XML.namespaces_prefixes = HM.singleton n $ Just p, XML.namespaces_default = ""} - Nothing -> def{XML.namespaces_default = n} - element XML.QName{..} (NS nsM) = - NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes = - HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns} - attribute XML.QName{..} (NS nsM) = - NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes = - HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns} - anyElem qNameSpace f = - let NS nsM = f $ XML.NCName "*" in - NS $ (<$> nsM) $ \ns -> ns{XML.namespaces_prefixes = - HM.insert qNameSpace Nothing $ XML.namespaces_prefixes ns} - try = id - fail = mempty - escapedText = mempty - text = mempty - any = mempty - choice = mconcat - option _def = coerceNS - optional = coerceNS - manySeq = coerceNS - someSeq = coerceNS diff --git a/Symantic/XML.hs b/Symantic/XML.hs deleted file mode 100644 --- a/Symantic/XML.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Symantic.XML - ( module Symantic.XML.Document - , readXML - , readFile - , writeXML - , writeXMLIndented - , writeFile - ) where -import Symantic.XML.Document -import Symantic.XML.Read -import Symantic.XML.Write diff --git a/Symantic/XML/Document.hs b/Symantic/XML/Document.hs deleted file mode 100644 --- a/Symantic/XML/Document.hs +++ /dev/null @@ -1,432 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Symantic.XML.Document - ( module Symantic.XML.Document - , TS.Tree(..) - , TS.Trees - , TS.tree0 - ) where - -import Control.Applicative (Alternative(..)) -import Data.Bool -import Data.Char (Char) -import Data.Default.Class (Default(..)) -import Data.Eq (Eq(..)) -import Data.Foldable (Foldable(..), all) -import Data.Function (($), (.), id) -import Data.Functor (Functor(..), (<$>)) -import Data.Hashable (Hashable(..)) -import Data.Int (Int) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (Maybe(..), fromMaybe) -import Data.Monoid (Monoid(..)) -import Data.Ord (Ord(..)) -import Data.Semigroup (Semigroup(..)) -import Data.Sequence (Seq) -import Data.String (String, IsString(..)) -import GHC.Generics (Generic) -import Prelude ((+), error) -import System.IO (FilePath) -import Text.Show (Show(..), showsPrec, showChar, showParen, showString) -import qualified Data.Char.Properties.XMLCharProps as XC -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.List as List -import qualified Data.Sequence as Seq -import qualified Data.Text.Lazy as TL -import qualified Data.TreeSeq.Strict as TS - --- * Type 'XML' -type XML src = TS.Tree (Sourced src Node) -type XMLs src = Seq (XML src) - --- | Unify two 'XMLs', merging border 'NodeText's if any. -union :: Semigroup (Sourced src EscapedText) => XMLs src -> XMLs src -> XMLs src -union x y = - case (Seq.viewr x, Seq.viewl y) of - (xs Seq.:> x0, y0 Seq.:< ys) -> - case (x0,y0) of - ( Tree0 (Sourced sx (NodeText tx)) - , Tree0 (Sourced sy (NodeText ty)) ) -> - xs `union` - Seq.singleton (Tree0 $ (NodeText <$>) $ Sourced sx tx <> Sourced sy ty) `union` - ys - _ -> x <> y - (Seq.EmptyR, _) -> y - (_, Seq.EmptyL) -> x - -unions :: - Semigroup (Sourced src EscapedText) => - Foldable f => f (XMLs src) -> XMLs src -unions = foldl' union mempty - -pattern Tree0 :: a -> TS.Tree a -pattern Tree0 a <- TS.Tree a (null -> True) - where Tree0 a = TS.Tree a Seq.empty - --- ** Type 'Node' -data Node - = NodeElem QName -- ^ Node with some 'NodeAttr' and then other 'Node's as children. - | NodeAttr QName -- ^ Node with a 'NodeText' child. - | NodePI PName TL.Text -- ^ Leaf (except for @@ 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 diff --git a/Symantic/XML/Read.hs b/Symantic/XML/Read.hs deleted file mode 100644 --- a/Symantic/XML/Read.hs +++ /dev/null @@ -1,478 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Symantic.XML.Read - ( module Symantic.XML.Read.Parser - , module Symantic.XML.Read - ) where - -import Control.Arrow (left) -import Control.Applicative (Applicative(..), Alternative(..)) -import Control.Monad (Monad(..), void, unless, forM, join) -import Data.Bool -import Data.Char (Char) -import Data.Default.Class (Default(..)) -import Data.Either (Either(..)) -import Data.Eq (Eq(..)) -import Data.Foldable (Foldable(..)) -import Data.Function (($), (.), const) -import Data.Functor ((<$>), (<$)) -import Data.Maybe (Maybe(..), maybe) -import Data.Monoid (Monoid(..)) -import Data.Ord (Ord(..)) -import Data.Semigroup (Semigroup(..)) -import Data.String (String) -import Data.TreeSeq.Strict (Tree(..)) -import Data.Tuple (snd) -import Prelude (Num(..), Enum(..), Bounded(..), Integer, toInteger) -import System.IO (FilePath, IO) -import Text.Megaparsec (()) -import Text.Show (Show(..)) -import qualified Control.Exception as Exn -import qualified Control.Monad.Trans.Reader as R -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Char as Char -import qualified Data.Char.Properties.XMLCharProps as XC -import qualified Data.HashMap.Strict as HM -import qualified Data.List as List -import qualified Data.Sequence as Seq -import qualified Data.Text.Encoding.Error as TL -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.TreeSeq.Strict as TS -import qualified System.IO.Error as IO -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P - -import Symantic.XML.Document hiding (XML, XMLs) -import Symantic.XML.Read.Parser - -readXML :: FilePath -> TL.Text -> Either (P.ParseErrorBundle TL.Text Error) XMLs -readXML filePath stateInput = - snd $ - P.runParser' - (R.runReaderT p_document def) - P.State - { P.stateInput - , P.stateOffset = 0 - , P.statePosState = P.PosState - { P.pstateInput = stateInput - , P.pstateOffset = 0 - , P.pstateSourcePos = P.initialPos filePath - , P.pstateTabWidth = P.pos1 - , P.pstateLinePrefix = "" - } - } - -readFile :: FilePath -> IO (Either ErrorRead TL.Text) -readFile fp = - (left ErrorRead_Unicode . TL.decodeUtf8' <$> BSL.readFile fp) - `Exn.catch` \e -> - if IO.isAlreadyInUseError e - || IO.isDoesNotExistError e - || IO.isPermissionError e - then return $ Left $ ErrorRead_IO e - else IO.ioError e - --- * Type 'ErrorRead' -data ErrorRead - = ErrorRead_IO IO.IOError - | ErrorRead_Unicode TL.UnicodeException - deriving (Show) - --- * Document -p_document :: P.Tokens s ~ TL.Text => Parser Error s XMLs -p_document = do - ps <- p_prolog - e <- p_Element - ms <- P.many p_Misc - P.eof - return (ps <> pure e <> join (Seq.fromList ms)) - --- ** Prolog -p_prolog :: P.Tokens s ~ TL.Text => Parser Error s XMLs -p_prolog = do - xmlDecl <- P.option Seq.empty $ pure <$> p_XMLDecl - ms <- P.many p_Misc - return (xmlDecl <> join (Seq.fromList ms)) - --- ** Misc -p_Misc :: P.Tokens s ~ TL.Text => Parser Error s XMLs -p_Misc = - P.try (pure <$> p_Comment) - <|> P.try (pure <$> p_PI) - <|> pure <$> p_S - --- ** XMLDecl -p_XMLDecl :: P.Tokens s ~ TL.Text => Parser Error s XML -p_XMLDecl = P.label "XMLDecl" $ do - Sourced src as <- p_Sourced $ P.between (P.string "") $ 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 "" - 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 " 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" diff --git a/Symantic/XML/Read/Parser.hs b/Symantic/XML/Read/Parser.hs deleted file mode 100644 --- a/Symantic/XML/Read/Parser.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeFamilies #-} -module Symantic.XML.Read.Parser where - -import Control.Applicative (Applicative(..), Alternative(..)) -import Control.Monad (Monad(..)) -import Data.Bool -import Data.Char (Char) -import Data.Default.Class (Default(..)) -import Data.Eq (Eq(..)) -import Data.Function (($), (.)) -import Data.Functor ((<$>)) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (Maybe(..)) -import Data.Ord (Ord(..)) -import Data.String (IsString) -import Prelude (Integer) -import Text.Show (Show(..)) -import qualified Control.Monad.Trans.Reader as R -import qualified Data.HashMap.Strict as HM -import qualified Data.Set as Set -import qualified Data.Text.Lazy as TL -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P - -import Symantic.XML.Document hiding (XML, XMLs) -import qualified Symantic.XML.Document as XML - --- | Specify |XML.XML|'s 'src' type parameter for parsing. -type XML = XML.XML (FileSource Offset) --- | Specify |XML.XMLs|'s 'src' type parameter for parsing. -type XMLs = XML.XMLs (FileSource Offset) - --- * Type 'Parser' --- | Convenient alias. -type Parser e s a = - Parsable e s a => - R.ReaderT Reader (P.Parsec e s) a - --- ** Type 'Parsable' -type Parsable e s a = - ( P.Stream s - , P.Token s ~ Char - , Ord e - , IsString (P.Tokens s) - , P.ShowErrorComponent e - ) - --- ** Type 'Reader' -data Reader = Reader - { reader_source :: FileSource Offset - , reader_ns_scope :: HM.HashMap NCName Namespace - , reader_ns_default :: Namespace - } deriving (Show) -instance Default Reader where - def = Reader - { reader_source = pure def - , reader_ns_scope = HM.fromList - [ ("xml" , xmlns_xml) - , ("xmlns", xmlns_xmlns) - ] - , reader_ns_default = "" - } - -p_Offset :: Parser e s Offset -p_Offset = Offset <$> P.getOffset -{-# INLINE p_Offset #-} - -p_Sourced :: Parser e s a -> Parser e s (Sourced (FileSource Offset) a) -p_Sourced pa = do - Reader{reader_source} <- R.ask - b <- P.getParserState - let fileRange_file = P.sourceName $ P.pstateSourcePos $ P.statePosState b - let fileRange_begin = Offset $ P.stateOffset b - a <- pa - e <- P.getParserState - let fileRange_end = Offset $ P.stateOffset e - return $ Sourced (setSource FileRange{..} reader_source) a - -setSource :: FileRange pos -> FileSource pos -> FileSource pos -setSource fileRange (_curr:|next) = fileRange :| next - --- | Like 'p_Sourced' but uncoupled (through the use of 'p_SourcedEnd') for more flexibility. -p_SourcedBegin :: Parser e s a -> Parser e s a -p_SourcedBegin pa = do - b <- P.getParserState - let fileRange_file = P.sourceName $ P.pstateSourcePos $ P.statePosState b - let fileRange_begin = Offset $ P.stateOffset b - let fileRange_end = fileRange_begin - (`R.local` pa) $ \ro@Reader{..} -> - ro{ reader_source = setSource FileRange{..} reader_source } - --- | WARNING: Only to be used within a 'p_SourcedBegin'. -p_SourcedEnd :: Parser e s (a -> Sourced (FileSource Offset) a) -p_SourcedEnd = do - Reader{..} <- R.ask - e <- P.getParserState - let fileRange_end = Offset $ P.stateOffset e - return $ Sourced $ - (\(curr:|path) -> curr{fileRange_end}:|path) - reader_source - -{- --- ** Type 'StreamSourced' --- | Wrap 'TL.Text' to have a 'P.Stream' instance --- whose 'P.advance1' method abuses the tab width state --- to instead pass the line indent. --- This in order to report correct 'P.SourcePos' --- when parsing a 'Sourced' containing newlines. -newtype StreamSourced = StreamSourced { unStreamSourced :: TL.Text } - deriving (IsString,Eq,Ord) -instance P.Stream StreamSourced where - type Token StreamSourced = Char - type Tokens StreamSourced = TL.Text - take1_ (StreamSourced t) = (StreamSourced <$>) <$> P.take1_ t - takeN_ n (StreamSourced t) = (StreamSourced <$>) <$> P.takeN_ n t - takeWhile_ f (StreamSourced t) = StreamSourced <$> P.takeWhile_ f t - tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text) - chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text) - chunkLength _s = P.chunkLength (Proxy::Proxy TL.Text) - {- - advance1 _s indent (P.SourcePos n line col) c = - case c of - '\n' -> P.SourcePos n (line <> P.pos1) indent - _ -> P.SourcePos n line (col <> P.pos1) - advanceN s indent = TL.foldl' (P.advance1 s indent) - -} - --- | Wrapper around |P.runParser'| --- to use given 'Sourced' as starting position. -runParserOnSourced :: - Parsable e StreamSourced a => - Parser e StreamSourced a -> - Sourced FileSource TL.Text -> - Either (P.ParseError (P.Token StreamSourced) e) a -runParserOnSourced p (Sourced (FileRange inp bp _ep :| path) s) = - snd $ - P.runParser' (R.runReaderT p ro <* P.eof) - P.State - { P.stateInput = StreamSourced s - , P.statePos = pure $ P.SourcePos inp (P.mkPos $ filePos_line bp) indent - , P.stateTabWidth = indent - , P.stateTokensProcessed = 0 - } - where - indent = P.mkPos $ filePos_column bp - ro = def{ reader_source = fromMaybe (pure def) $ nonEmpty path } --} - --- * Type 'Error' -data Error - = Error_CharRef_invalid Integer - -- ^ Well-formedness constraint: Legal Character. - -- - -- Characters referred to using character references MUST match the production for Char. - | Error_EntityRef_unknown NCName - -- ^ Well-formedness constraint: Entity Declared - -- - -- In a document without any DTD, a document with only an internal DTD - -- subset which contains no parameter entity references, or a document - -- with " standalone='yes' ", for an entity reference that does not occur - -- within the external subset or a parameter entity, the Name given in the - -- entity reference MUST match that in an entity declaration that does not - -- occur within the external subset or a parameter entity, except that - -- well-formed documents need not declare any of the following entities: - -- amp, lt, gt, apos, quot. The declaration of a general entity MUST - -- precede any reference to it which appears in a default value in an - -- attribute-list declaration. - -- - -- Note that non-validating processors are not obligated to read and - -- process entity declarations occurring in parameter entities or in the - -- external subset; for such documents, the rule that an entity must be - -- declared is a well-formedness constraint only if standalone='yes'. - | Error_Closing_tag_unexpected QName QName - -- ^ Well-formedness constraint: Element Type Match. - -- - -- The Name in an element's end-tag MUST match the element type in the start-tag. - | Error_Attribute_collision QName - -- ^ Well-formedness constraint: Unique Att Spec. - -- - -- An attribute name MUST NOT appear more than once in the same start-tag or empty-element tag. - | Error_PI_reserved PName - -- ^ The target names " XML ", " xml ", and so on are reserved for standardization. - | Error_Namespace_prefix_unknown NCName - -- ^ Namespace constraint: Prefix Declared - -- - -- The namespace prefix, unless it is xml or xmlns, MUST have been declared in a namespace declaration attribute in either the start-tag of the element where the prefix is used or in an ancestor element (i.e., an element in whose content the prefixed markup occurs). - | Error_Namespace_empty NCName - -- ^ Namespace constraint: No Prefix Undeclaring - -- - -- In a namespace declaration for a prefix (i.e., where the NSAttName is a PrefixedAttName), the attribute value MUST NOT be empty. - | Error_Namespace_reserved Namespace - | Error_Namespace_reserved_prefix NCName - -- ^ Namespace constraint: Reserved Prefixes and Namespace Names - -- - -- The prefix xml is by definition bound to the namespace name - -- http://www.w3.org/XML/1998/namespace. It MAY, but need not, be - -- declared, and MUST NOT be bound to any other namespace name. Other - -- prefixes MUST NOT be bound to this namespace name, and it MUST NOT be - -- declared as the default namespace. - -- - -- The prefix xmlns is used only to declare namespace bindings and is by - -- definition bound to the namespace name http://www.w3.org/2000/xmlns/. - -- It MUST NOT be declared . Other prefixes MUST NOT be bound to this - -- namespace name, and it MUST NOT be declared as the default namespace. - -- Element names MUST NOT have the prefix xmlns. - -- - -- All other prefixes beginning with the three-letter sequence x, m, l, in - -- any case combination, are reserved. This means that: - -- - -- - users SHOULD NOT use them except as defined by later specifications - -- - processors MUST NOT treat them as fatal errors. - deriving (Eq,Ord,Show) -instance P.ShowErrorComponent Error where - showErrorComponent = show - --- * Helpers -p_error :: e -> Parser e s a -p_error = P.fancyFailure . Set.singleton . P.ErrorCustom - -p_quoted :: P.Tokens s ~ TL.Text => (Char -> Parser e s a) -> Parser e s a -p_quoted p = - P.between (P.char '"') (P.char '"') (p '"') <|> - P.between (P.char '\'') (P.char '\'') (p '\'') - -p_until :: P.Tokens s ~ TL.Text => (Char -> Bool) -> (Char, TL.Text) -> Parser e s TL.Text -p_until content (end, end_) = - (TL.concat <$>) $ P.many $ - P.takeWhile1P Nothing (\c -> content c && c /= end) <|> - P.try (TL.singleton <$> P.char end <* P.notFollowedBy (P.string end_)) - -p_until1 :: P.Tokens s ~ TL.Text => (Char -> Bool) -> (Char, TL.Text) -> Parser e s TL.Text -p_until1 content (end, end_) = - (TL.concat <$>) $ P.some $ - P.takeWhile1P Nothing (\c -> content c && c /= end) <|> - P.try (TL.singleton <$> P.char end <* P.notFollowedBy (P.string end_)) diff --git a/Symantic/XML/Write.hs b/Symantic/XML/Write.hs deleted file mode 100644 --- a/Symantic/XML/Write.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} -module Symantic.XML.Write where - -import Control.Applicative (Applicative(..), liftA2) -import Control.Monad (Monad(..)) -import Data.Bool -import Data.Default.Class (Default(..)) -import Data.Eq (Eq(..)) -import Data.Foldable (Foldable(..), all) -import Data.Function (($), (.), const) -import Data.Maybe (Maybe(..)) -import Data.Monoid (Monoid(..)) -import Data.Semigroup (Semigroup(..)) -import Data.String (String, IsString(..)) -import Data.Traversable (Traversable(..)) -import System.IO (IO, FilePath) -import Text.Show (Show(..)) -import qualified Control.Monad.Trans.Reader as R -import qualified Control.Monad.Trans.State as S -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Char as Char -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Sequence as Seq -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Text.Lazy.Encoding as TL - -import Symantic.XML.Document as XML - -writeXML :: NoSource src => XMLs src -> TL.Text -writeXML xs = TLB.toLazyText $ write xs `R.runReader` def - -writeXMLIndented :: NoSource src => TL.Text -> XMLs src -> TL.Text -writeXMLIndented ind xs = - TLB.toLazyText $ - write xs `R.runReader` def - { reader_indent = if TL.null ind then mempty else "\n" - , reader_indent_delta = ind - } - -writeFile :: FilePath -> TL.Text -> IO () -writeFile fp t = BSL.writeFile fp $ TL.encodeUtf8 t - --- * Type 'Write' -type Write = R.Reader Reader TLB.Builder -instance Semigroup Write where - (<>) = liftA2 (<>) -instance Monoid Write where - mempty = return "" - mappend = (<>) -instance IsString Write where - fromString = return . fromString - --- ** Type 'Reader' -data Reader = Reader - { reader_ns_scope :: Namespaces NCName - , reader_indent :: TLB.Builder - , reader_indent_delta :: TL.Text - , reader_no_text :: Bool - } -instance Default Reader where - def = Reader - { reader_ns_scope = def - , reader_indent = "" - , reader_indent_delta = "" - , reader_no_text = False - } - --- * Class 'Buildable' -class Buildable a where - build :: a -> TLB.Builder -instance Buildable Char.Char where - build = TLB.singleton -instance Buildable String where - build = TLB.fromString -instance Buildable TL.Text where - build = TLB.fromLazyText -instance Buildable NCName where - build = build . unNCName -instance Buildable Name where - build = build . unName -instance Buildable PName where - build PName{..} = - case pNameSpace of - Nothing -> build pNameLocal - Just p -> build p<>":"<> build pNameLocal -instance Buildable Namespace where - build = build . unNamespace -instance Buildable EntityRef where - build EntityRef{..} = "&"<>build entityRef_name<>";" -instance Buildable CharRef where - build (CharRef c) = "&#"<>build (show (Char.ord c))<>";" -instance Buildable EscapedText where - build (EscapedText et) = (`foldMap` et) $ \case - EscapedPlain t -> build t - EscapedEntityRef r -> build r - EscapedCharRef r -> build r - --- * Class 'Writable' -class Writeable a where - write :: a -> Write -instance Writeable NCName where - write = return . TLB.fromLazyText . unNCName -instance NoSource src => Writeable (XMLs src) where - write xs = do - ro <- R.ask - if TL.null (reader_indent_delta ro) - then foldMap write xs - else - R.local (const ro{reader_no_text}) $ - foldMap write xs - where reader_no_text = - (`all` xs) $ \case - Tree (Sourced _ (NodeText (EscapedText et))) _ts -> - all (\case - EscapedPlain t -> TL.all Char.isSpace t - _ -> False) et - _ -> True -instance NoSource src => Writeable (XML src) where - write (Tree (Sourced _src nod) xs) = do - ro <- R.ask - case nod of - NodeAttr an - | [Tree (Sourced _ (NodeText av)) _] <- toList xs -> do - return $ " "<>buildAttr (prefixifyQName (reader_ns_scope ro) an) av - | otherwise -> mempty - NodeCDATA t -> - return $ - reader_indent ro <> - "<[CDATA[["<>build t<>"]]>" - NodeComment t -> - return $ - reader_indent ro <> - "" - 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 diff --git a/src/Symantic/XML.hs b/src/Symantic/XML.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML.hs @@ -0,0 +1,11 @@ +module Symantic.XML + ( module Symantic.XML.Language + , module Symantic.XML.Read + , module Symantic.XML.Tree + , module Symantic.XML.Write + ) where + +import Symantic.XML.Language +import Symantic.XML.Read +import Symantic.XML.Tree +import Symantic.XML.Write diff --git a/src/Symantic/XML/Language.hs b/src/Symantic/XML/Language.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/Language.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE UndecidableInstances #-} +module Symantic.XML.Language + ( module Symantic.XML.Language + , module Symantic.XML.Namespace + , module Symantic.XML.Text + , module Symantic.Base.Composable + , module Symantic.Base.Algebrable + , module Symantic.Base.Permutable + ) where + +import Data.Function ((.)) +import Data.Maybe (Maybe) +import Data.Kind (Constraint) +import qualified Data.Text.Lazy as TL + +import Symantic.XML.Namespace +import Symantic.XML.Text +import Symantic.Base.Algebrable +import Symantic.Base.Composable +import Symantic.Base.Permutable + +-- * Class 'XML' +class + ( Composable repr + , Tupable repr + , Eitherable repr + , Textable repr + ) => XML repr where + --xmlPI :: -> repr a k + -- | @('namespace' p ns)@ declares a namespace prefix @(p)@ + -- to be used for the 'Namespace' @(ns)@. + -- Or make @(ns)@ the default namespace if @(p)@ is 'Nothing'. + namespace :: Maybe NCName -> Namespace -> repr k k + default namespace :: + Transformable repr => XML (UnTrans repr) => + Maybe NCName -> Namespace -> repr k k + namespace n ns = noTrans (namespace n ns) + + default element :: Transformable repr => XML (UnTrans repr) => + QName -> repr a k -> repr a k + element :: QName -> repr a k -> repr a k + element n x = noTrans (element n (unTrans x)) + + default attribute :: Transformable repr => XML (UnTrans repr) => + QName -> repr a k -> repr a k + attribute :: QName -> repr a k -> repr a k + attribute n x = noTrans (attribute n (unTrans x)) + + default pi :: Transformable repr => XML (UnTrans repr) => + PName -> repr (TL.Text -> k) k + pi :: PName -> repr (TL.Text -> k) k + pi n = noTrans (pi n) + + default literal :: Transformable repr => XML (UnTrans repr) => + TL.Text -> repr k k + literal :: TL.Text -> repr k k + literal = noTrans . literal + + default comment :: Transformable repr => XML (UnTrans repr) => + repr (TL.Text -> k) k + comment :: repr (TL.Text -> k) k + comment = noTrans comment + + default cdata :: Transformable repr => XML (UnTrans repr) => + repr (TL.Text -> k) k + cdata :: repr (TL.Text -> k) k + cdata = noTrans cdata + +-- ** Class 'Textable' +class Textable repr where + type TextConstraint repr a :: Constraint + type TextConstraint repr a = TextConstraint (UnTrans repr) a + default text :: Transformable repr => XML (UnTrans repr) => + TextConstraint (UnTrans repr) a => repr (a -> k) k + text :: TextConstraint repr a => repr (a -> k) k + text = noTrans text diff --git a/src/Symantic/XML/Namespace.hs b/src/Symantic/XML/Namespace.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/Namespace.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Symantic.XML.Namespace where + +import Control.Applicative (Alternative(..)) +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Foldable (all) +import Data.Function (($), (.), id) +import Data.Functor (Functor(..), (<$>)) +import Data.Hashable (Hashable(..)) +import Data.Int (Int) +import Data.Maybe (Maybe(..), fromMaybe) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (String, IsString(..)) +import GHC.Generics (Generic) +import Prelude (error) +import Text.Show (Show(..), showsPrec, showChar, showString) +import qualified Data.Char.Properties.XMLCharProps as XC +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.List as List +import qualified Data.Text.Lazy as TL + +-- * Type 'QName' +-- | Qualified name. +data QName + = QName + { qNameSpace :: Namespace -- ^ eg. "http://www.w3.org/1999/XSL/Transform" + , qNameLocal :: NCName -- ^ eg. "stylesheet" + } deriving (Eq, Ord, Generic) +instance Show QName where + showsPrec _p QName{..} = + (if TL.null $ unNamespace qNameSpace then id + else showChar '{' . showString (TL.unpack $ unNamespace qNameSpace) . showChar '}' + ) . showsPrec 10 qNameLocal +instance IsString QName where + -- NCName's fromString will raise an error. + fromString "" = QName "" "" + fromString full@('{':rest) = + case List.break (== '}') rest of + (_, "") -> error $ "Invalid XML Clark notation: "<>show full + (ns, local) -> QName (fromString ns) $ fromString $ List.drop 1 local + fromString local = QName "" $ fromString local +instance Hashable QName + +qName :: NCName -> QName +qName = QName (Namespace "") +{-# INLINE qName #-} + +-- ** Type 'Namespace' +newtype Namespace = Namespace { unNamespace :: TL.Text } + deriving (Eq, Ord, Show, Hashable) +instance IsString Namespace where + fromString s = + if all (\c -> XC.isXmlChar c && c `List.notElem` ("'\"<&"::String)) s + then Namespace (fromString s) + else error $ "Invalid XML Namespace: "<>show s + +xmlns_xml, xmlns_xmlns, xmlns_xsd, xmlns_empty :: Namespace +xmlns_xml = Namespace "http://www.w3.org/XML/1998/namespace" +xmlns_xmlns = Namespace "http://www.w3.org/2000/xmlns/" +xmlns_xsd = Namespace "http://www/w3/org/2001/XMLSchema-datatypes" +xmlns_empty = Namespace "" + +-- *** Type 'Namespaces' +data Namespaces prefix + = Namespaces + { namespaces_prefixes :: HM.HashMap Namespace prefix + , namespaces_default :: Namespace + } deriving (Show) +instance Functor Namespaces where + fmap f (Namespaces ps d) = Namespaces (fmap f ps) d +instance Semigroup (Namespaces NCName) where + x <> y = Namespaces + { namespaces_prefixes = namespaces_prefixes x <> namespaces_prefixes y + , namespaces_default = namespaces_default x + } +instance Semigroup (Namespaces (Maybe NCName)) where + x <> y = Namespaces + { namespaces_prefixes = HM.unionWith (<|>) (namespaces_prefixes x) (namespaces_prefixes y) + , namespaces_default = namespaces_default x + } +instance Monoid (Namespaces NCName) where + mempty = Namespaces HM.empty xmlns_empty + mappend = (<>) +instance Monoid (Namespaces (Maybe NCName)) where + mempty = Namespaces HM.empty xmlns_empty + mappend = (<>) + +defaultNamespaces :: IsString prefix => Namespaces prefix +defaultNamespaces = Namespaces + { namespaces_prefixes = HM.fromList + [ (xmlns_xml , "xml") + , (xmlns_xmlns, "xmlns") + ] + , namespaces_default = xmlns_empty + } + +prefixifyQName :: Namespaces NCName -> QName -> PName +prefixifyQName Namespaces{..} QName{..} = PName + { pNameSpace = + if qNameSpace == namespaces_default + then Nothing + else HM.lookup qNameSpace namespaces_prefixes + , pNameLocal = qNameLocal + } + +-- ** Type 'PName' +-- | Prefixed 'NCName' +data PName + = PName + { pNameSpace :: Maybe NCName -- ^ eg. Just "xml" + , pNameLocal :: NCName -- ^ eg. "stylesheet" + } deriving (Eq, Ord, Generic) +instance Show PName where + showsPrec p PName{pNameSpace=Nothing, ..} = + showsPrec p pNameLocal + showsPrec _p PName{pNameSpace=Just p, ..} = + showsPrec 10 p . + showChar ':' . + showsPrec 10 pNameLocal +instance IsString PName where + fromString "" = PName Nothing "" -- NCName's fromString will raise an error. + fromString s = + case List.break (== ':') s of + (_, "") -> PName Nothing $ fromString s + (p, local) -> PName (Just $ fromString p) (fromString $ List.drop 1 local) + +pName :: NCName -> PName +pName = PName Nothing +{-# INLINE pName #-} + +-- ** Type 'NCName' +-- | Non-colonized name. +newtype NCName = NCName { unNCName :: TL.Text } + deriving (Eq, Ord, Hashable) +instance Show NCName where + showsPrec _p = showString . TL.unpack . unNCName +instance IsString NCName where + fromString s = + fromMaybe (error $ "Invalid XML NCName: "<>show s) $ + ncName (TL.pack s) + +ncName :: TL.Text -> Maybe NCName +ncName t = + case TL.uncons t of + Just (c, cs) + | XC.isXmlNCNameStartChar c + , TL.all XC.isXmlNCNameChar cs + -> Just (NCName t) + _ -> Nothing + +poolNCNames :: [NCName] +poolNCNames = + [ NCName $ TL.pack ("ns"<>show i) + | i <- [1 :: Int ..] + ] + +freshNCName :: HS.HashSet NCName -> NCName +freshNCName ps = List.head $ poolNCNames List.\\ HS.toList ps + +freshifyNCName :: HS.HashSet NCName -> NCName -> NCName +freshifyNCName ns (NCName n) = + let ints = [1..] :: [Int] in + List.head + [ fresh + | suffix <- mempty : (show <$> ints) + , fresh <- [ NCName $ n <> TL.pack suffix] + , not $ fresh `HS.member` ns + ] diff --git a/src/Symantic/XML/Read.hs b/src/Symantic/XML/Read.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/Read.hs @@ -0,0 +1,640 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Symantic.XML.Read where + +import Control.Applicative as Alternative (Applicative(..), Alternative(..), optional) +import Control.Monad (Monad(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Data.Bool +import Data.Either (Either(..)) +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..), all) +import Data.Function (($), (.), const, id, flip) +import Data.Functor (Functor(..), (<$>)) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (Maybe(..), maybe, isNothing, maybeToList) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) +import Data.Proxy (Proxy(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (String, IsString(..)) +import Data.Tuple (fst) +import Data.Void (Void) +import Numeric.Natural (Natural) +import Prelude ((+), Integer, undefined) +import System.IO (IO, FilePath) +import Text.Show (Show(..)) +import qualified Data.Char as Char +import qualified Data.HashMap.Strict as HM +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.TreeSeq.Strict as TS +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import qualified Text.Megaparsec.Char.Lexer as P +import qualified Text.Megaparsec.Internal as P + +import Symantic.Base +import Symantic.XML.Language +import Symantic.XML.RelaxNG.Language +import Symantic.XML.Tree + +-- | Main reading function. +read :: + Read FileSourced Void (x->x) a -> + FilePath -> + IO (Either String a) +read rng path = + readTree path >>= \case + Left err -> return $ Left err + Right xml -> return $ runRead rng xml + +-- | Like 'readWithRelaxNG' but on a 'FileSourcedTrees'. +runRead :: + Read FileSourced Void (x->x) a -> + FileSourcedTrees -> + Either String a +runRead rng xml = + case P.runParser (unRead rng) "" (mempty, xml) of + Left err -> Left $ foldMap parseErrorTextPretty $ P.bundleErrors err + Right a -> Right $ a id + +-- * Type 'ReadStream' +type ReadStream src = + ( HM.HashMap QName (src EscapedAttr) + , Trees src + ) + +-- | Take one 'Node' from the 'ReadStream', +-- or fallback to an attribute, or 'Nothing'. +-- +-- Use 'pTokenAttr' to take only attributes. +take1_ :: + UnSource src => + (Node (src EscapedAttr) -> Bool) -> + ReadStream src -> + Maybe ( P.Token (ReadStream src) + , ReadStream src ) +take1_ isIgnoredNode s@(attrs, trees) = + go trees + where + go trs = + case Seq.viewl trs of + Seq.EmptyL + | null attrs -> Nothing + | otherwise -> Just (Left attrs, s) + t Seq.:< ts -> + case unSource (TS.unTree t) of + n | isIgnoredNode n -> go ts + | otherwise -> Just (Right t, (attrs, ts)) + -- Note that having an ignored node + -- can split a text into two 'NodeText's. + -- Not sure if it would be better to unify them. + +-- ** Type 'ReadConstraints' +-- | Convenient alias to be less verbose. +type ReadConstraints src = + ( Ord (src (Node (src EscapedAttr))) + , Ord (src EscapedAttr) + , UnSource src + , NoSource src + , SourceOf src + , Show (Source src) + , Show (src String) + , Functor src + ) + +instance ReadConstraints src => P.Stream (ReadStream src) where + type Token (ReadStream src) = Either + (HM.HashMap QName (src EscapedAttr)) + (Tree src) + type Tokens (ReadStream src) = ReadStream src + take1_ = take1_ isIgnoredNode + where + isIgnoredNode = \case + NodeComment{} -> True + NodePI{} -> True + _ -> False + showTokens _s toks = + orList $ + mconcat $ + toList $ showTree <$> toks + where + showSource :: src String -> String + showSource sa = + let src = sourceOf sa in + if nullSource @src src + then unSource sa + else unSource sa<>" at "<>show src + showTree = \case + Left as -> + (\(an, av) -> showSource $ ("(attribute "<>show an<>")") <$ av) + <$> List.sortOn fst (HM.toList as) + Right (TS.Tree nod ts) -> + pure $ + showSource . (<$ nod) $ + case unSource nod of + NodeElem n _as -> "(element "<>show n<>")" + NodeText{} -> + case Seq.viewl ts of + TS.Tree tn _ Seq.:< _ + | NodeText lit <- unSource tn -> + -- Abuse the encoding to detect expected 'literal' + -- using nested 'NodeText' + "\""<>TL.unpack (unescapeText lit)<>"\"" + _ -> "text" + NodeComment _c -> "comment" + NodePI n _t -> "(processing-instruction "<>show n<>")" + NodeCDATA _t -> "cdata" + -- Useless methods for validating an XML AST + takeN_ = undefined + tokensToChunk = undefined + chunkToTokens = undefined + chunkLength = undefined + takeWhile_ = undefined + reachOffset = undefined + reachOffsetNoLine = undefined + +-- * Type 'Read' +newtype Read src e f k + = Read + { unRead :: P.Parsec e (ReadStream src) (f->k) } + +instance + ( Ord err + , ReadConstraints src + ) => Emptyable (Read src err) where + empty = Read $ id <$ P.eof +instance + ( Ord err + , ReadConstraints src + ) => Unitable (Read src err) where + unit = Read $ return ($ ()) +instance + ( Ord err + , ReadConstraints src + ) => Voidable (Read src err) where + void _a (Read x) = Read $ + (\a2b2k b -> a2b2k (\_a -> b)) <$> x +instance + ( Ord err + , ReadConstraints src + ) => Constant (Read src err) where + constant a = Read $ return ($ a) +instance + ( Ord err + , ReadConstraints src + ) => Permutable (Read src err) where + type Permutation (Read src err) = + ReadPerm src err + permutable (ReadPerm ma p) = Read $ do + r <- Alternative.optional p + unRead $ + case r of + Just perms -> permutable perms + Nothing -> + Read $ maybe + -- Not 'empty' here so that 'P.TrivialError' + -- has the unexpected token. + (P.token (const Nothing) Set.empty) + return ma + noPerm = ReadPerm Nothing Alternative.empty + perm (Read x) = + ReadPerm Nothing $ (<$> x) $ \a -> + ReadPerm (Just a) Alternative.empty + permWithDefault d (Read x) = + ReadPerm (Just ($ d)) $ (<$> x) $ \a -> + ReadPerm (Just a) Alternative.empty +instance + ( Ord err + , ReadConstraints src + ) => Composable (Read src err) where + Read x <.> Read y = Read $ + x >>= \a2b -> (. a2b) <$> y +instance + ( Ord err + , ReadConstraints src + ) => Tupable (Read src err) where + Read x <:> Read y = Read $ + consCont (,) <$> x <*> y +instance + ( Ord err + , ReadConstraints src + ) => Eitherable (Read src err) where + Read x <+> Read y = Read $ + mapCont Left <$> P.try x <|> + mapCont Right <$> y +{- +instance + ( Ord err + , ReadConstraints src + ) => Routable (Read src err) where + Read x Read y = Read $ + (\a2k (a:!:_b) -> a2k a) <$> P.try x <|> + (\b2k (_a:!:b) -> b2k b) <$> y +-} +instance + ( Ord err + , ReadConstraints src + ) => Optionable (Read src err) where + option (Read x) = Read $ + P.try x <|> return id + optional (Read x) = Read $ + mapCont Just <$> P.try x <|> + return ($ Nothing) +instance + ( Ord err + , ReadConstraints src + ) => Repeatable (Read src err) where + many0 (Read x) = Read $ concatCont <$> many x + many1 (Read x) = Read $ concatCont <$> some x +instance + ( Ord err + , ReadConstraints src + ) => Dimapable (Read src err) where + dimap a2b _b2a (Read r) = + Read $ (\k b2k -> k (b2k . a2b)) <$> r +instance + ( Ord err + , ReadConstraints src + ) => Dicurryable (Read src err) where + dicurry (_::proxy args) constr _destr (Read x) = Read $ do + f <- x + return $ \r2k -> + f (mapresultN @args r2k constr) +instance + ( Ord err + , ReadConstraints src + , Textable (Read src err) + ) => XML (Read src err) where + namespace _nm _ns = Read (return id) + element n p = Read $ do + s <- P.token check $ Set.singleton $ + P.Tokens $ pure expected + unRead $ readNested p s + where + expected = Right $ TS.tree0 $ noSource $ NodeElem n mempty + check = \case + Right (TS.Tree nod ts) + | NodeElem e as <- unSource nod + , e == n + -> Just (removeXMLNS as, removeSpaces ts) + _ -> Nothing + attribute n p = Read $ do + v <- pTokenAttr n $ Set.singleton $ + P.Tokens $ pure expected + unRead $ readNested p + (mempty, pure (TS.tree0 (NodeText . EscapedText . unEscapedAttr <$> v))) + -- Cast 'EscapedAttr' into 'EscapedText' + -- because it will be read, not written, + -- hence only given to 'unescapeText' + -- which is the same than 'unescapeAttr'. + where + expected = Left $ HM.singleton n $ noSource "" + literal lit = Read $ do + P.token check $ Set.singleton $ P.Tokens $ pure expected + where + expected = Right $ + TS.Tree (noSource $ NodeText "") + (pure $ TS.tree0 (noSource $ NodeText $ escapeText lit)) + check = \case + Right (Tree0 nod) + | NodeText t <- unSource nod + , unescapeText t == lit + -> Just id + _ -> Nothing + pi n = Read $ do + v <- pTokenPI n $ Set.singleton $ + P.Tokens $ pure expected + return ($ v) + where + expected = Right $ TS.tree0 $ noSource $ NodePI n mempty + cdata = Read $ + P.token check $ Set.singleton $ + P.Tokens $ pure expected + where + expected = Right $ TS.tree0 $ noSource $ NodeCDATA mempty + check = \case + Right (Tree0 nod) + | NodeCDATA v <- unSource nod + -> Just ($ v) + _ -> Nothing + comment = Read $ + P.token check $ Set.singleton $ + P.Tokens $ pure expected + where + expected = Right $ TS.tree0 $ noSource $ NodeComment mempty + check = \case + Right (Tree0 nod) + | NodeComment v <- unSource nod + -> Just ($ v) + _ -> Nothing +instance Ord err => Textable (Read FileSourced err) where + type TextConstraint (Read FileSourced err) a = + DecodeText a + text :: forall a k repr. + repr ~ Read FileSourced err => + TextConstraint repr a => repr (a->k) k + text = Read $ do + Sourced (FileSource (src :| _)) txt <- + P.token check $ Set.singleton $ P.Tokens $ pure expected + case P.runParser @Void (decodeText @a <* P.eof) "" (unescapeText txt) of + Right a -> return ($ a) + Left errs -> P.fancyFailure $ Set.singleton $ P.ErrorFail $ + (`foldMap` P.bundleErrors errs) $ \err -> + fileRange_path src <> ":" <> + show (fileRange_begin src <> Offset (P.errorOffset err)) <> "\n" <> + P.parseErrorTextPretty err + where + expected = Right $ TS.tree0 $ noSource $ NodeText $ EscapedText mempty + check = \case + Right (Tree0 nod) + | NodeText t <- unSource nod + -> Just (t <$ nod) + _ -> Nothing +instance + ( Ord err + , ReadConstraints src + , Textable (Read src err) + , Definable (Read src err) + ) => RelaxNG (Read src err) where + elementMatch nc p = Read $ do + (n,s) <- P.token check $ Set.singleton $ + P.Tokens $ pure expected + ((\a2k n2a -> a2k (n2a n)) <$>) $ + unRead (readNested p s) + where + expected = Right $ TS.tree0 $ noSource $ + NodeElem (qName (NCName (TLB.toLazyText + (textify (mempty::Namespaces NCName,(infixN0,SideL),nc))))) + mempty + check = \case + Right (TS.Tree nod ts) + | NodeElem n as <- unSource nod + , matchNameClass nc n + -> Just (n, (removeXMLNS as, removeSpaces ts)) + _ -> Nothing + attributeMatch nc p = Read $ do + (an,av) <- pTokenAttrNameClass nc $ Set.singleton $ + P.Tokens $ pure expected + ((\a2k n2a -> a2k (n2a an)) <$>) $ + unRead $ readNested p + (mempty, pure (TS.tree0 (NodeText . EscapedText . unEscapedAttr <$> av))) + -- See comment in 'attribute' about the cast to 'EscapedText' here. + where + expected = Left $ HM.singleton (qName (NCName n)) $ noSource "" + where n = TLB.toLazyText $ textify (mempty::Namespaces NCName,(infixN0,SideL),nc) +instance Ord err => Definable (Read FileSourced err) where + define n = Read . P.label n . unRead + +-- ** Type 'ReadPerm' +data ReadPerm (src :: * -> *) err a k + = ReadPerm + { readPerm_result :: !(Maybe (a->k)) + , readPerm_parser :: P.Parsec err (ReadStream src) (ReadPerm src err a k) + } + +instance + (Ord err, ReadConstraints src) => + Dimapable (ReadPerm src err) where + dimap a2b b2a (ReadPerm a ma) = + ReadPerm (merge <$> a) + (dimap a2b b2a `fmap` ma) + where merge = \a2k2k b2k -> a2k2k $ b2k . a2b +instance + (Ord err, ReadConstraints src) => + Dicurryable (ReadPerm src err) where + dicurry :: + forall args r k proxy. + CurryN args => + proxy args -> + (args-..->r) -> -- construction + (r->Tuples args) -> -- destruction + ReadPerm src err (args-..->k) k -> + ReadPerm src err (r->k) k + dicurry px constr destr (ReadPerm a ma) = + ReadPerm (merge <$> a) + (dicurry px constr destr `fmap` ma) + where + merge args2k2k = \r2k -> + args2k2k $ mapresultN @args r2k constr +instance + (Ord err, ReadConstraints src) => + Composable (ReadPerm src err) where + lhs@(ReadPerm da pa) <.> rhs@(ReadPerm db pb) = + ReadPerm a $ + lhsAlt <|> rhsAlt + where + lhsAlt = (<.> rhs) <$> pa + rhsAlt = (lhs <.>) <$> pb + a = flip (.) <$> da <*> db +instance + (Ord err, ReadConstraints src) => + Tupable (ReadPerm src err) where + lhs@(ReadPerm da pa) <:> rhs@(ReadPerm db pb) = + ReadPerm a (lhsAlt <|> rhsAlt) + where + lhsAlt = (<:> rhs) <$> pa + rhsAlt = (lhs <:>) <$> pb + a = consCont (,) <$> da <*> db +instance Definable (ReadPerm src err) where + define _n = id + +-- * Utils + +concatCont :: [(a->k)->k] -> ([a]->k)->k +concatCont = List.foldr (consCont (:)) ($ []) +{-# INLINE concatCont #-} + +consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k +consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b) +{-# INLINE consCont #-} + +mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k) +mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b) +{-# INLINE mapCont #-} + +-- | An adaptation of megaparsec's 'pToken', +-- to handle 'attribute' properly. +pTokenAttr :: + forall e m src. + ReadConstraints src => + QName -> + Set.Set (P.ErrorItem (P.Token (ReadStream src))) -> + P.ParsecT e (ReadStream src) m (src EscapedAttr) +pTokenAttr an ps = P.ParsecT $ \st@(P.State s@(attrs,trees) o pst de) cok _ _ eerr -> + case HM.lookup an attrs of + Just av -> cok av (P.State (HM.delete an attrs, trees) (o+1) pst de) mempty + Nothing -> eerr (P.TrivialError o us ps) st + where + us = case P.take1_ s of + Nothing -> pure P.EndOfInput + Just (t,_ts) -> (Just . P.Tokens . pure) t +{-# INLINE pTokenAttr #-} + +-- | An adaptation of megaparsec's 'pToken', +-- to handle 'attributeMatch' properly. +pTokenAttrNameClass :: + forall e m src. + ReadConstraints src => + NameClass -> + Set.Set (P.ErrorItem (P.Token (ReadStream src))) -> + P.ParsecT e (ReadStream src) m (QName, src EscapedAttr) +pTokenAttrNameClass nc ps = P.ParsecT $ \st@(P.State s@(attrs,trees) o pst de) cok _ _ eerr -> + case HM.toList attrs of + a@(an,_av):_ | matchNameClass nc an -> cok a (P.State (HM.delete an attrs, trees) (o+1) pst de) mempty + _ -> eerr (P.TrivialError o us ps) st + where + us = case P.take1_ s of + Nothing -> pure P.EndOfInput + Just (t,_ts) -> (Just . P.Tokens . pure) t +{-# INLINE pTokenAttrNameClass #-} + +-- | An adaptation of megaparsec's 'pToken', +-- to handle 'pi' since 'NodePI' is ignored by 'P.take1_'. +pTokenPI :: + forall e m src. + UnSource src => + PName -> + Set.Set (P.ErrorItem (P.Token (ReadStream src))) -> + P.ParsecT e (ReadStream src) m TL.Text +pTokenPI n ps = P.ParsecT $ \st@(P.State s o pst de) cok _ _ eerr -> + case take1 s of + Nothing -> eerr (P.TrivialError o us ps) st + where us = pure P.EndOfInput + Just (c, cs) + | Right (TS.Tree nod _) <- c + , NodePI pn pv <- unSource nod + , pn == n -> cok pv (P.State cs (o+1) pst de) mempty + | otherwise -> eerr (P.TrivialError o us ps) st + where + us = case take1 s of + Nothing -> pure P.EndOfInput + Just (t,_ts) -> (Just . P.Tokens . pure) t + where + take1 = take1_ isIgnoredNode + where + isIgnoredNode = \case + NodeComment{} -> True + _ -> False + +removeXMLNS :: + HM.HashMap QName (src EscapedAttr) -> + HM.HashMap QName (src EscapedAttr) +removeXMLNS = + HM.filterWithKey $ \an _av -> + case an of + QName "" "xmlns" -> False + QName ns _l -> ns /= xmlns_xmlns + +removeSpaces :: UnSource src => Trees src -> Trees src +removeSpaces xs = + if (`all` xs) $ \case + TS.Tree nod _ts + | NodeText (EscapedText et) <- unSource nod -> + all (\case + EscapedPlain t -> TL.all Char.isSpace t + _ -> False) et + _ -> True + then (`Seq.filter` xs) $ \case + TS.Tree nod _ts + | NodeText EscapedText{} <- unSource nod -> False + _ -> True + else xs + +-- | @readNested v xs@ returns a 'Read' parsing @xs@ entirely with @v@, +-- updating 'P.stateOffset' and re-raising any exception. +readNested :: + Ord err => + ReadConstraints src => + Read src err f a -> + ReadStream src -> + Read src err f a +readNested (Read p) stateInput = Read $ do + st <- P.getParserState + (st', res) <- lift $ P.runParserT' (p <* P.eof) st + { P.stateInput + , P.stateOffset = P.stateOffset st + } + P.updateParserState (\s -> s{P.stateOffset = P.stateOffset st'}) + case res of + Right a -> return a + Left (P.ParseErrorBundle errs _) -> + case NonEmpty.head errs of + P.TrivialError _o us es -> P.failure us es + P.FancyError _o es -> P.fancyFailure es + +-- * Class 'DecodeText' +class DecodeText a where + decodeText :: P.Parsec Void TL.Text a +instance DecodeText String where + decodeText = TL.unpack . fst <$> + P.match (P.skipMany P.anySingle) +instance DecodeText Text.Text where + decodeText = TL.toStrict . fst <$> + P.match (P.skipMany P.anySingle) +instance DecodeText TL.Text where + decodeText = fst <$> + P.match (P.skipMany P.anySingle) +instance DecodeText Bool where + decodeText = + False <$ (P.string "false" <|> P.string "0") <|> + True <$ (P.string "true" <|> P.string "1") +instance DecodeText Integer where + decodeText = P.signed (return ()) P.decimal +instance DecodeText Natural where + decodeText = P.optional (P.char '+') *> P.decimal + +-- * Megaparsec adaptations +-- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'node's. +parseErrorTextPretty :: + P.ShowErrorComponent err => + P.ParseError (ReadStream FileSourced) err -> String +parseErrorTextPretty (P.TrivialError o us ps) = + if isNothing us && Set.null ps + then "unknown parse error\n" + else + (case us of + Just P.Tokens{} -> "" + _ -> + -- FIXME: this is not informative enough, + -- but P.EndOfInput can not carry a source location, + -- and retraversing the XML tree cannot be done + -- exactly as the parser did only knowing the Offset, + -- because of attributes being permutable. + "node #"<>show o<>"\n" + ) <> + messageItemsPretty "unexpected " + (showErrorItem px <$> maybeToList us) <> + messageItemsPretty "expecting " + (showErrorItem px <$> Set.toAscList ps) + where px = Proxy :: Proxy s +parseErrorTextPretty err = P.parseErrorTextPretty err + +messageItemsPretty :: String -> [String] -> String +messageItemsPretty prefix ts + | null ts = "" + | otherwise = prefix <> orList ts <> "\n" + +orList :: IsString s => Monoid s => [s] -> s +orList [] = mempty +orList [x] = x +orList [x,y] = x <> " or " <> y +orList xs = mconcat (List.intersperse ", " (List.init xs)) <> ", or " <> List.last xs + +showErrorItem :: + (s ~ ReadStream (Sourced (FileSource Offset))) => + Proxy s -> P.ErrorItem (P.Token s) -> String +showErrorItem px = \case + P.Tokens ts -> P.showTokens px ts + P.Label label -> NonEmpty.toList label + P.EndOfInput -> "end-of-node" diff --git a/src/Symantic/XML/RelaxNG.hs b/src/Symantic/XML/RelaxNG.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/RelaxNG.hs @@ -0,0 +1,7 @@ +module Symantic.XML.RelaxNG + ( module Symantic.XML.RelaxNG.Language + , module Symantic.XML.RelaxNG.Compact.Write + ) where + +import Symantic.XML.RelaxNG.Language +import Symantic.XML.RelaxNG.Compact.Write diff --git a/src/Symantic/XML/RelaxNG/Compact/Write.hs b/src/Symantic/XML/RelaxNG/Compact/Write.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/RelaxNG/Compact/Write.hs @@ -0,0 +1,429 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} +module Symantic.XML.RelaxNG.Compact.Write where + +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Monad (forM) +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..)) +import Data.Function (($), (.), id, const) +import Data.Functor ((<$>)) +import Data.Int (Int) +import Data.Maybe (Maybe(..), maybe, catMaybes, isNothing) +import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (IsString(..), String) +import Numeric.Natural (Natural) +import Prelude (Integer) +import qualified Control.Monad.Trans.State.Strict as S +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB + +import Symantic.Base.Fixity +import Symantic.XML.Language +import Symantic.XML.RelaxNG.Language + +-- | Get textual rendition of given 'RNCWriteSyn'. +writeRNC :: RNCWriteSyn a k -> TL.Text +writeRNC = TLB.toLazyText . runRNCWriteSyn + +-- | Get textual rendition of given 'RNCWriteSyn'. +runRNCWriteSyn :: RNCWriteSyn a k -> TLB.Builder +runRNCWriteSyn RNCWriteSyn{..} = + mconcat $ + List.concat + [ [ "default namespace = \""<>textify (namespaces_default rncWriteInh_namespaces)<>"\"\n" + | not $ TL.null $ unNamespace (namespaces_default rncWriteInh_namespaces) + ] + , [ "namespace "<>textify p<>" = \""<>textify n<>"\"\n" + | (Namespace n, NCName p) <- + HM.toList (namespaces_prefixes rncWriteInh_namespaces) + ] + , Map.foldrWithKey + (\n v -> ((textify n<>" = "<>v<>"\n") :)) [] + defs + ] + where + RNCWriteState{..} = rncWriteSyn_state $ RNCWriteState mempty mempty + defs :: Map.Map DefineName TLB.Builder + defs = Map.mapMaybe ($ inh) rncWriteState_defines + inh = RNCWriteInh + { rncWriteInh_namespaces + , rncWriteInh_op = (infixN0, SideL) + , rncWriteInh_pair = pairParen + } + rncWriteInh_namespaces :: Namespaces NCName + rncWriteInh_namespaces = rncWriteState_namespaces + { namespaces_prefixes = + (`S.evalState` HS.empty) $ + forM prefixByNamespace $ \mp -> do + usedPrefixes <- S.get + let + freshPrefix = maybe + (freshNCName usedPrefixes) + (freshifyNCName usedPrefixes) + mp + S.modify' $ HS.insert freshPrefix + pure freshPrefix + } + prefixByNamespace :: HM.HashMap Namespace (Maybe NCName) + prefixByNamespace = + -- Add default prefixes if their 'Namespace' is used. + HM.union + (HM.intersectionWith (<|>) + (namespaces_prefixes rncWriteState_namespaces) + (Just <$> namespaces_prefixes defaultNamespaces)) $ + namespaces_prefixes rncWriteState_namespaces + +-- * Type 'RNCWriteState' +-- | Chained values. +data RNCWriteState + = RNCWriteState + { rncWriteState_namespaces :: Namespaces (Maybe NCName) + -- ^ The 'Namespaces' used throughout the 'RelaxNG' schema. + , rncWriteState_defines :: Map.Map DefineName (RNCWriteInh -> Maybe TLB.Builder) + -- ^ Used to avoid infinite recursion, + -- by looking up the 'DefineName' of 'define'. + } + +-- * Type 'RNCWriteSyn' +-- | Synthetized (bottom-up) values. +data RNCWriteSyn a k + = RNCWriteSyn + { rncWriteSyn_state :: Chained RNCWriteState + , rncWriteSyn_schema :: RNCWriteInh -> Maybe TLB.Builder + } +instance IsString (RNCWriteSyn a k) where + fromString s = RNCWriteSyn + { rncWriteSyn_state = id + , rncWriteSyn_schema = const $ + if List.null s then Nothing + else Just (textify s) + } + +-- | Like the @State st ()@ monad, but without @()@. +-- The name comme from chained-attribute from Attribute Grammar. +type Chained a = a -> a + +coerceRNCWriteSyn :: RNCWriteSyn a k -> RNCWriteSyn a' k' +coerceRNCWriteSyn RNCWriteSyn{..} = RNCWriteSyn{..} +{-# INLINE coerceRNCWriteSyn #-} + +pairRNCWriteInh :: + Semigroup s => IsString s => + RNCWriteInh -> Infix -> Maybe s -> Maybe s +pairRNCWriteInh inh op s = + if isPairNeeded (rncWriteInh_op inh) op + then Just (fromString o<>" ")<>s<>Just (" "<>fromString c) + else s + where (o,c) = rncWriteInh_pair inh + +-- ** Type 'RNCWriteInh' +-- Inherited (top-down) values. +data RNCWriteInh + = RNCWriteInh + { rncWriteInh_namespaces :: Namespaces NCName + , rncWriteInh_op :: (Infix, Side) + , rncWriteInh_pair :: Pair + } + +instance Emptyable RNCWriteSyn where + empty = "empty" +instance Unitable RNCWriteSyn where + unit = "" +instance Voidable RNCWriteSyn where + void _a = coerceRNCWriteSyn +instance Constant RNCWriteSyn where + constant _a = "" +instance Composable RNCWriteSyn where + x <.> y = RNCWriteSyn + (rncWriteSyn_state x . rncWriteSyn_state y) $ \inh -> + let + inh' side = inh + { rncWriteInh_op = (op, side) + , rncWriteInh_pair = pairParen + } in + case rncWriteSyn_schema x (inh' SideL) of + Nothing -> rncWriteSyn_schema y (inh' SideR) + Just xw -> + case rncWriteSyn_schema y (inh' SideR) of + Nothing -> Just xw + Just yw -> + pairRNCWriteInh inh op $ + Just $ xw <> ", " <> yw + where + op = infixB SideL 2 +instance Tupable RNCWriteSyn where + x <:> y = coerceRNCWriteSyn x <.> coerceRNCWriteSyn y +instance Eitherable RNCWriteSyn where + x <+> y = RNCWriteSyn + (rncWriteSyn_state x . rncWriteSyn_state y) $ \inh -> + pairRNCWriteInh inh op $ + rncWriteSyn_schema x inh + { rncWriteInh_op = (op, SideL) + , rncWriteInh_pair = pairParen + } <> + Just " | " <> + rncWriteSyn_schema y inh + { rncWriteInh_op = (op, SideR) + , rncWriteInh_pair = pairParen + } + where op = infixB SideL 3 +instance Optionable RNCWriteSyn where + option = coerceRNCWriteSyn . optional . coerceRNCWriteSyn + optional w = w{ rncWriteSyn_schema = \inh -> + pairRNCWriteInh inh op $ + rncWriteSyn_schema w inh + { rncWriteInh_op = (op, SideL) + , rncWriteInh_pair = pairParen + } <> Just "?" + } + where op = infixN 9 +instance Dimapable RNCWriteSyn where + dimap _a2b _b2a = coerceRNCWriteSyn +instance Dicurryable RNCWriteSyn where + dicurry _args _constr _destr = coerceRNCWriteSyn +instance Repeatable RNCWriteSyn where + many0 w = w{ rncWriteSyn_schema = \inh -> + pairRNCWriteInh inh op $ + rncWriteSyn_schema w inh + { rncWriteInh_op = (op, SideL) + , rncWriteInh_pair = pairParen + } <> Just "*" + } + where op = infixN 9 + many1 w = w{ rncWriteSyn_schema = \inh -> + pairRNCWriteInh inh op $ + rncWriteSyn_schema w inh + { rncWriteInh_op = (op, SideL) + , rncWriteInh_pair = pairParen + } <> Just "+" + } + where op = infixN 9 +instance Textable RNCWriteSyn where + type TextConstraint RNCWriteSyn a = RNCText a + text :: forall a k. TextConstraint RNCWriteSyn a => RNCWriteSyn (a -> k) k + text = RNCWriteSyn + { rncWriteSyn_state = \st -> + case HM.lookup + (qNameSpace (rncText_qname @a)) + (namespaces_prefixes (rncWriteState_namespaces st)) of + Just{} -> st + Nothing -> + let ns = qNameSpace (rncText_qname @a) in + if ns == xmlns_empty then st else st + { rncWriteState_namespaces = (rncWriteState_namespaces st) + { namespaces_prefixes = + HM.insertWith (<|>) ns Nothing $ + namespaces_prefixes (rncWriteState_namespaces st) } } + , rncWriteSyn_schema = \inh -> + let n = rncText_qname @a in + let t = if TL.null (unNamespace (qNameSpace n)) + then textify (qNameLocal n) + else textify (prefixifyQName (rncWriteInh_namespaces inh) n) + in if null (rncText_params @a) + then Just t + else + pairRNCWriteInh inh (infixN 8) $ + Just $ + t<>" {"<>Map.foldMapWithKey + (\k v -> " "<>textify k<>" = \""<>textify v<>"\"") + (rncText_params @a)<>" }" + } +instance XML RNCWriteSyn where + namespace mp ns = RNCWriteSyn + { rncWriteSyn_state = \st -> st + { rncWriteState_namespaces = + let nss = rncWriteState_namespaces st in + Namespaces + { namespaces_prefixes = + HM.insertWith (<|>) ns mp (namespaces_prefixes nss) + , namespaces_default = + if isNothing mp + then ns + else namespaces_default nss + } + } + , rncWriteSyn_schema = const Nothing + } + element n w = w + { rncWriteSyn_state = \st -> + rncWriteSyn_state w $ st + { rncWriteState_namespaces = (rncWriteState_namespaces st) + { namespaces_prefixes = + -- Insert this 'qNameSpace' even if this is the default namespace, + -- because the default namespace here may not end up + -- being the global default namespace + -- if there is a default 'namespace' declaration after this one. + -- at worse this will just add a superfluous ns# declaration + -- in the schema rendering. + HM.insertWith (<|>) (qNameSpace n) Nothing + (namespaces_prefixes (rncWriteState_namespaces st)) } } + , rncWriteSyn_schema = \inh -> + pairRNCWriteInh inh (infixN 8) $ + Just ("element " + <> textify (prefixifyQName (rncWriteInh_namespaces inh) n) + <> " {") + <> rncWriteSyn_schema w inh + { rncWriteInh_op = (infixN0, SideR) + , rncWriteInh_pair = pairBrace + } + <> Just "}" + } + attribute n w = w + { rncWriteSyn_state = \st -> + rncWriteSyn_state w $ + if qNameSpace n == xmlns_empty then st else st + { rncWriteState_namespaces = (rncWriteState_namespaces st) + { namespaces_prefixes = + HM.insertWith (<|>) (qNameSpace n) Nothing + (namespaces_prefixes (rncWriteState_namespaces st)) } } + , rncWriteSyn_schema = \inh -> + pairRNCWriteInh inh (infixN 8) $ + Just ("attribute " + -- The namespace name for an unprefixed attribute name always has no value. + <> textify (prefixifyQName (rncWriteInh_namespaces inh){namespaces_default=xmlns_empty} n) + <> " {") + <> rncWriteSyn_schema w inh + { rncWriteInh_op = (infixN0, SideR) + , rncWriteInh_pair = pairBrace + } + <> Just "}" + } + literal lit = RNCWriteSyn + { rncWriteSyn_state = id + , rncWriteSyn_schema = \_inh -> Just ("\""<>textify lit<>"\"") + } + pi _n = "" + comment = "" + cdata = "" +instance Definable RNCWriteSyn where + define n w = w + { rncWriteSyn_state = \st -> + let defs = rncWriteState_defines st in + case Map.lookup n defs of + Nothing -> + rncWriteSyn_state w $ st + { rncWriteState_defines = + Map.insert n (rncWriteSyn_schema w) defs + } + Just{} -> st + , rncWriteSyn_schema = const $ Just $ textify n + } +instance Permutable RNCWriteSyn where + type Permutation RNCWriteSyn = RNCWriteSynPerm + permutable (RNCWriteSynPerm ps) = RNCWriteSyn + { rncWriteSyn_state = List.foldl' (.) id (rncWriteSyn_state <$> ps) + , rncWriteSyn_schema = case ps of + [] -> const Nothing + _ -> \inh -> + case + List.intersperse " & " $ + catMaybes $ (<$> ps) $ \w -> + rncWriteSyn_schema w inh{rncWriteInh_op=(op, SideL)} + of + [] -> Nothing + [x] -> Just x + xs -> pairRNCWriteInh inh op $ Just $ mconcat xs + } + where op = infixR 3 + perm = RNCWriteSynPerm . pure + noPerm = RNCWriteSynPerm [] + permWithDefault _def p = RNCWriteSynPerm + [coerceRNCWriteSyn (optional p)] +instance RelaxNG RNCWriteSyn where + elementMatch nc w = w + { rncWriteSyn_state = \st -> + rncWriteSyn_state w $ st + { rncWriteState_namespaces = (rncWriteState_namespaces st) + { namespaces_prefixes = + namespacesNameClass nc <> + namespaces_prefixes (rncWriteState_namespaces st) + } } + , rncWriteSyn_schema = \inh -> + pairRNCWriteInh inh (infixN 8) $ + Just ("element " + <> textify (rncWriteInh_namespaces inh, (infixN0,SideL), nc) + <> " ") + <> rncWriteSyn_schema w inh + { rncWriteInh_op = (infixN 9, SideR) + , rncWriteInh_pair = pairBrace + } + } + attributeMatch nc w = w + { rncWriteSyn_state = \st -> + let nss = HM.delete xmlns_empty $ namespacesNameClass nc in + rncWriteSyn_state w $ + if null nss then st else st + { rncWriteState_namespaces = (rncWriteState_namespaces st) + { namespaces_prefixes = + HM.unionWith (<|>) nss $ + namespaces_prefixes (rncWriteState_namespaces st) + } } + , rncWriteSyn_schema = \inh -> + pairRNCWriteInh inh (infixN 8) $ + Just ("attribute " + <> textify ( (rncWriteInh_namespaces inh){namespaces_default=xmlns_empty} + , (infixN0,SideL) + , nc ) + <> " ") + <> rncWriteSyn_schema w inh + { rncWriteInh_op = (infixN 9, SideR) + , rncWriteInh_pair = pairBrace + } + } + +-- ** Type 'RNCWriteSynPerm' +newtype RNCWriteSynPerm a k + = RNCWriteSynPerm + { rncWriteSynPerm_alternatives :: [RNCWriteSyn a k] + -- ^ Collect alternatives for rendering + -- them all at once in 'runPermutation'. + } +instance Composable RNCWriteSynPerm where + RNCWriteSynPerm x <.> RNCWriteSynPerm y = + RNCWriteSynPerm $ + (coerceRNCWriteSyn <$> x) <> + (coerceRNCWriteSyn <$> y) +instance Dimapable RNCWriteSynPerm where + dimap _a2b _b2a (RNCWriteSynPerm x) = + RNCWriteSynPerm (coerceRNCWriteSyn <$> x) +instance Tupable RNCWriteSynPerm where + RNCWriteSynPerm x <:> RNCWriteSynPerm y = + RNCWriteSynPerm $ + (coerceRNCWriteSyn <$> x) <> + (coerceRNCWriteSyn <$> y) +instance Definable RNCWriteSynPerm where + define n (RNCWriteSynPerm ps) = + RNCWriteSynPerm $ pure $ + coerceRNCWriteSyn $ define n $ + permutable $ RNCWriteSynPerm $ + coerceRNCWriteSyn <$> ps + +-- * Class 'RNCText' +class RNCText a where + rncText_qname :: QName + rncText_params :: Map.Map TL.Text TL.Text + rncText_params = mempty +instance RNCText String where + rncText_qname = QName (Namespace "") "text" +instance RNCText Text.Text where + rncText_qname = QName (Namespace "") "text" +instance RNCText TL.Text where + rncText_qname = QName (Namespace "") "text" +instance RNCText Bool where + rncText_qname = QName xmlns_xsd "boolean" +instance RNCText Int where + rncText_qname = QName xmlns_xsd "int" +instance RNCText Integer where + rncText_qname = QName xmlns_xsd "integer" +instance RNCText Natural where + rncText_qname = QName xmlns_xsd "nonNegativeInteger" diff --git a/src/Symantic/XML/RelaxNG/Language.hs b/src/Symantic/XML/RelaxNG/Language.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/RelaxNG/Language.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} +module Symantic.XML.RelaxNG.Language where + +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Function (($), (.)) +import Data.Maybe (Maybe(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (String, IsString(..)) +import Prelude (error) +import Text.Show (Show(..)) +import qualified Data.List as List +import qualified Data.HashMap.Strict as HM + +import Symantic.Base.Fixity +import Symantic.XML.Language + +-- * Class 'RelaxNG' +class + ( XML repr + , Permutable repr + , Definable repr + ) => RelaxNG repr where + default elementMatch :: + Transformable repr => + RelaxNG (UnTrans repr) => + NameClass -> repr a k -> repr (QName -> a) k + -- | Like 'element' but with a matching pattern + -- instead of a specific 'QName'. + elementMatch :: NameClass -> repr a k -> repr (QName -> a) k + elementMatch nc = noTrans . elementMatch nc . unTrans + default attributeMatch :: + Transformable repr => + RelaxNG (UnTrans repr) => + NameClass -> repr a k -> repr (QName -> a) k + -- | Like 'attribute' but with a matching pattern + -- instead of a specific 'QName'. + attributeMatch :: NameClass -> repr a k -> repr (QName -> a) k + attributeMatch nc = noTrans . attributeMatch nc . unTrans + +-- * Type 'Definable' +class Definable repr where + -- | @(define name expr)@ declares a rule named @(name)@ + -- and matching the 'RelaxNG' schema @(expr)@. + -- + -- Useful for rendering the 'RelaxNG' schema, + -- and necessary to avoid infinite recursion when + -- printing a 'RelaxNG' schema calling itself recursively. + -- + -- WARNING: 'DefineName's must be unique inside + -- a whole 'RelaxNG' schema. + define :: DefineName -> repr a k -> repr a k + default define :: + Transformable repr => RelaxNG (UnTrans repr) => + DefineName -> repr f k -> repr f k + define n = noTrans . define n . unTrans + +-- ** Type 'DefineName' +type DefineName = String + +-- * Type 'NameClass' +data NameClass + = NameClass_Any + | (:::) Namespace NCName + | (:*) Namespace + | (:-:) NameClass NameClass + | (:|:) NameClass NameClass + +infix 9 ::: +infixr 2 :|: +infixl 6 :-: + +(*:*) :: NameClass +(*:*) = NameClass_Any + +-- | @('matchNameClass' nc q)@ returns 'True' iif. the 'NameClass' @(nc)@ matches the 'QName' @(q)@. +matchNameClass :: NameClass -> QName -> Bool +matchNameClass NameClass_Any _q = True +matchNameClass (ns:::nl) q = qNameSpace q == ns && qNameLocal q == nl +matchNameClass ((:*) ns) q = qNameSpace q == ns +matchNameClass (x:|:y) q = matchNameClass x q || matchNameClass y q +matchNameClass (x:-:y) q = matchNameClass x q && not (matchNameClass y q) + +-- | Return the namespaces used by the given 'NameClass' +namespacesNameClass :: NameClass -> HM.HashMap Namespace (Maybe NCName) +namespacesNameClass = \case + NameClass_Any -> HM.empty + ns ::: _ -> HM.singleton ns Nothing + (:*) ns -> HM.singleton ns Nothing + x :|: y -> namespacesNameClass x <> namespacesNameClass y + x :-: y -> namespacesNameClass x <> namespacesNameClass y + +-- | Only parses "*", "{some-namespace}*", or "{some-namespace}some-localname". +instance IsString NameClass where + fromString = \case + "*" -> NameClass_Any + full@('{':rest) -> + case List.break (== '}') rest of + (_, "") -> error $ "Invalid XML Clark notation: "<>show full + (ns, "*") -> (:*) (fromString ns) + (ns, local) -> fromString ns ::: fromString (List.drop 1 local) + s -> let QName ns nl = fromString s in ns:::nl +instance Textify (Namespaces NCName, (Infix,Side), NameClass) where + textify (nss,po,nc) = case nc of + NameClass_Any -> textify '*' + ns:::nl -> + textify (prefixifyQName nss (QName ns nl)) + (:*) ns -> + case HM.lookup ns (namespaces_prefixes nss) of + Nothing -> "{"<>textify ns<>"}*" + Just p -> textify p <> ":*" + x :|: y -> pairIfNeeded pairParen po op $ + textify (nss,(op,SideL),x) <> " | " <> textify (nss,(op,SideR),y) + where op = infixR 2 + x :-: y -> + pairIfNeeded pairParen po op $ + textify (nss,(op,SideL),x) <> " - " <> textify (nss,(op,SideR),y) + where op = infixL 6 diff --git a/src/Symantic/XML/Text.hs b/src/Symantic/XML/Text.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/Text.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +module Symantic.XML.Text where + +import Data.Bool +import Data.Char (Char) +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..)) +import Data.Function (($), (.)) +import Data.Maybe (Maybe(..)) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Sequence (Seq) +import Data.String (IsString(..), String) +import Text.Show (Show(..)) +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Sequence as Seq +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB + +import Symantic.XML.Namespace + +-- * Type 'Escaped' +-- | 'EscapedText' lexemes. +data Escaped + = EscapedPlain TL.Text + | EscapedEntityRef EntityRef + | EscapedCharRef CharRef + deriving (Eq, Ord, Show) + +-- ** Type 'EntityRef' +data EntityRef + = EntityRef + { entityRef_name :: NCName + , entityRef_value :: TL.Text + } deriving (Eq, Ord, Show) + +entityRef_lt, + entityRef_gt, + entityRef_amp, + entityRef_quot, + entityRef_apos :: EntityRef +entityRef_lt = EntityRef (NCName "lt") "<" +entityRef_gt = EntityRef (NCName "gt") ">" +entityRef_amp = EntityRef (NCName "amp") "&" +entityRef_quot = EntityRef (NCName "quot") "\"" +entityRef_apos = EntityRef (NCName "apos") "'" + +-- ** Type 'CharRef' +newtype CharRef = CharRef Char + deriving (Eq, Ord, Show) + +-- * Type 'EscapedText' +newtype EscapedText = EscapedText (Seq Escaped) + deriving (Eq, Ord, Show) + +instance IsString EscapedText where + fromString = escapeText . fromString + +unEscapedText :: EscapedText -> Seq Escaped +unEscapedText (EscapedText et) = et +{-# INLINE unEscapedText #-} + +escapeText :: TL.Text -> EscapedText +escapeText s = + EscapedText $ + -- Add '>' to escape "]]>" without adding a 'TL.replace'. + case TL.span (`List.notElem` ("<&>"::String)) s of + (t, r) | TL.null t -> escape r + | otherwise -> EscapedPlain t Seq.<| escape r + where + escape t = case TL.uncons t of + Nothing -> mempty + Just (c, cs) -> escapeTextChar c Seq.<| et + where EscapedText et = escapeText cs + +escapeTextChar :: Char -> Escaped +escapeTextChar = \case + '<' -> EscapedEntityRef entityRef_lt + '&' -> EscapedEntityRef entityRef_amp + -- Add '>' to escape "]]>". + '>' -> EscapedEntityRef entityRef_gt + c -> EscapedPlain $ TL.singleton c + +unescapeText :: EscapedText -> TL.Text +unescapeText (EscapedText et) = (`foldMap` et) $ \case + EscapedPlain t -> t + EscapedEntityRef EntityRef{..} -> entityRef_value + EscapedCharRef (CharRef c) -> TL.singleton c + +-- * Type 'EscapedAttr' +newtype EscapedAttr = EscapedAttr (Seq Escaped) + deriving (Eq, Ord, Show) + +instance IsString EscapedAttr where + fromString = escapeAttr . fromString + +unEscapedAttr :: EscapedAttr -> Seq Escaped +unEscapedAttr (EscapedAttr et) = et +{-# INLINE unEscapedAttr #-} + +escapeAttr :: TL.Text -> EscapedAttr +escapeAttr s = + EscapedAttr $ + case TL.span (`List.notElem` ("<&\""::String)) s of + (t, r) | TL.null t -> escape r + | otherwise -> EscapedPlain t Seq.<| escape r + where + escape t = case TL.uncons t of + Nothing -> mempty + Just (c, cs) -> escapeAttrChar c Seq.<| et + where EscapedAttr et = escapeAttr cs + +escapeAttrChar :: Char -> Escaped +escapeAttrChar = \case + '<' -> EscapedEntityRef entityRef_lt + '&' -> EscapedEntityRef entityRef_amp + -- Remove '\'' because 'textifyAttr' uses '"' for quoting. + -- '\'' -> EscapedEntityRef entityRef_apos + '"' -> EscapedEntityRef entityRef_quot + c -> EscapedPlain $ TL.singleton c + +unescapeAttr :: EscapedAttr -> TL.Text +unescapeAttr (EscapedAttr et) = unescapeText (EscapedText et) + +-- * Class 'Textify' +class Textify a where + textify :: a -> TLB.Builder +instance Textify Char.Char where + textify = TLB.singleton +instance Textify String where + textify = TLB.fromString +instance Textify TL.Text where + textify = TLB.fromLazyText +instance Textify NCName where + textify = textify . unNCName +instance Textify PName where + textify PName{..} = + case pNameSpace of + Nothing -> textify pNameLocal + Just p -> textify p<>":"<> textify pNameLocal +instance Textify Namespace where + textify = textify . unNamespace +instance Textify EntityRef where + textify EntityRef{..} = "&"<>textify entityRef_name<>";" +instance Textify CharRef where + textify (CharRef c) = "&#"<>textify (show (Char.ord c))<>";" +instance Textify EscapedText where + textify (EscapedText et) = (`foldMap` et) $ \case + EscapedPlain t -> textify t + EscapedEntityRef r -> textify r + EscapedCharRef r -> textify r +instance Textify EscapedAttr where + textify (EscapedAttr et) = "\""<>txt<>"\"" + where + txt = (`foldMap` et) $ \case + EscapedPlain t -> textify t + EscapedEntityRef r -> textify r + EscapedCharRef r -> textify r + +textifyAttr :: PName -> EscapedAttr -> TLB.Builder +textifyAttr n v = " "<>textify n<>"="<>textify v diff --git a/src/Symantic/XML/Tree.hs b/src/Symantic/XML/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/Tree.hs @@ -0,0 +1,11 @@ +module Symantic.XML.Tree + ( module Symantic.XML.Tree.Source + , module Symantic.XML.Tree.Data + , module Symantic.XML.Tree.Read + , module Symantic.XML.Tree.Write + ) where + +import Symantic.XML.Tree.Source +import Symantic.XML.Tree.Data +import Symantic.XML.Tree.Read +import Symantic.XML.Tree.Write diff --git a/src/Symantic/XML/Tree/Data.hs b/src/Symantic/XML/Tree/Data.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/Tree/Data.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Symantic.XML.Tree.Data + ( module Symantic.XML.Tree.Data + , TS.unTree + , TS.subTrees + ) where + +import Control.Applicative (Applicative(..)) +import Data.Bool +import Data.Either (Either(..)) +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..)) +import Data.Function (($), id) +import Data.Functor ((<$>)) +import Data.Functor.Identity (Identity(..)) +import Data.Maybe (Maybe(..)) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) +import Prelude (error) +import Text.Show (Show(..)) +import qualified Data.HashMap.Strict as HM +import qualified Data.Sequence as Seq +import qualified Data.Text.Lazy as TL +import qualified Data.TreeSeq.Strict as TS + +import Symantic.Base +import Symantic.XML.Language +import Symantic.XML.RelaxNG.Language +import Symantic.XML.Write +import Symantic.XML.Tree.Source + +-- * Type 'Tree' +type Tree src = TS.Tree (src (Node (src EscapedAttr))) + +-- ** Type 'Trees' +type Trees src = TS.Trees (src (Node (src EscapedAttr))) + +pattern Tree0 :: a -> TS.Tree a +pattern Tree0 a <- TS.Tree a (null -> True) + where Tree0 a = TS.Tree a Seq.empty + +-- ** Type 'Node' +data Node attr + = NodeElem QName (HM.HashMap QName attr) -- ^ Node. + | NodePI PName TL.Text -- ^ Leaf (except for @@ 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) diff --git a/src/Symantic/XML/Tree/Read.hs b/src/Symantic/XML/Tree/Read.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/Tree/Read.hs @@ -0,0 +1,628 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Symantic.XML.Tree.Read where + +import Control.Arrow (left) +import Control.Applicative (Applicative(..), Alternative(..)) +import Control.Monad (Monad(..), void, unless, forM) +import Data.Bool +import Data.Char (Char) +import Data.Either (Either(..)) +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..)) +import Data.Function (($), (.), const) +import Data.Functor ((<$>), (<$)) +import Data.Maybe (Maybe(..), maybe, catMaybes) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.String (String, IsString(..)) +import Prelude (Num(..), Enum(..), Bounded(..), Integer, toInteger) +import System.IO (FilePath, IO) +import Text.Show (Show(..)) +import qualified Control.Exception as Exn +import qualified Control.Monad.Trans.Reader as R +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Char as Char +import qualified Data.Char.Properties.XMLCharProps as XC +import qualified Data.HashMap.Strict as HM +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Sequence as Seq +import qualified Data.Text.Encoding.Error as TL +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.TreeSeq.Strict as TS +import qualified System.IO.Error as IO +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P + +import Symantic.Base () +import Symantic.XML.Language hiding (void) +import Symantic.XML.Tree.Source +import Symantic.XML.Tree.Data + +readTree :: FilePath -> IO (Either String FileSourcedTrees) +readTree path = + readUtf8 path >>= \case + Left err -> return $ Left $ show err + Right txt -> return $ + case runReadTree path txt of + Right a -> Right a + Left err -> Left $ P.errorBundlePretty err + +runReadTree :: + FilePath -> TL.Text -> + Either (P.ParseErrorBundle TL.Text Error) + FileSourcedTrees +runReadTree = P.runParser $ R.runReaderT p_document defaultReadTreeInh + +-- * Type 'ErrorRead' +data ErrorRead + = ErrorRead_IO IO.IOError + | ErrorRead_Unicode TL.UnicodeException + deriving (Show) +readUtf8 :: FilePath -> IO (Either ErrorRead TL.Text) +readUtf8 path = + (left ErrorRead_Unicode . TL.decodeUtf8' <$> BSL.readFile path) + `Exn.catch` \e -> + if IO.isAlreadyInUseError e + || IO.isDoesNotExistError e + || IO.isPermissionError e + then return $ Left $ ErrorRead_IO e + else IO.ioError e + +-- * Type 'ReadTree' +-- | Convenient alias. +type ReadTree e s a = + ReadTreeConstraints e s a => + R.ReaderT ReadTreeInh (P.Parsec e s) a + +-- ** Type 'ReadTreeConstraints' +type ReadTreeConstraints e s a = + ( P.Stream s + , P.Token s ~ Char + , Ord e + , IsString (P.Tokens s) + , P.ShowErrorComponent e + ) + +-- ** Type 'ReadTreeInh' +data ReadTreeInh + = ReadTreeInh + { readTreeInh_source :: FileSource Offset + , readTreeInh_ns_scope :: HM.HashMap NCName Namespace + , readTreeInh_ns_default :: Namespace + } deriving (Show) + +defaultReadTreeInh :: ReadTreeInh +defaultReadTreeInh = ReadTreeInh + { readTreeInh_source = FileSource $ pure $ + FileRange mempty mempty mempty + , readTreeInh_ns_scope = HM.fromList + [ ("xml" , xmlns_xml) + , ("xmlns", xmlns_xmlns) + ] + , readTreeInh_ns_default = "" + } + +p_Offset :: ReadTree e s Offset +p_Offset = Offset <$> P.getOffset +{-# INLINE p_Offset #-} + +p_Sourced :: ReadTree e s a -> ReadTree e s (Sourced (FileSource Offset) a) +p_Sourced pa = do + ReadTreeInh{readTreeInh_source} <- R.ask + b <- P.getParserState + let fileRange_path = P.sourceName $ P.pstateSourcePos $ P.statePosState b + let fileRange_begin = Offset $ P.stateOffset b + a <- pa + e <- P.getParserState + let fileRange_end = Offset $ P.stateOffset e + return $ Sourced (setSource FileRange{..} readTreeInh_source) a + +setSource :: FileRange pos -> FileSource pos -> FileSource pos +setSource fileRange (FileSource (_curr:|next)) = FileSource (fileRange:|next) + +-- | Like 'p_Sourced' but uncoupled (through the use of 'p_SourcedEnd') for more flexibility. +p_SourcedBegin :: ReadTree e s a -> ReadTree e s a +p_SourcedBegin pa = do + b <- P.getParserState + let fileRange_path = P.sourceName $ P.pstateSourcePos $ P.statePosState b + let fileRange_begin = Offset $ P.stateOffset b + let fileRange_end = fileRange_begin + (`R.local` pa) $ \inh@ReadTreeInh{..} -> + inh{ readTreeInh_source = setSource FileRange{..} readTreeInh_source } + +-- | WARNING: only to be used within a 'p_SourcedBegin'. +p_SourcedEnd :: ReadTree e s (a -> Sourced (FileSource Offset) a) +p_SourcedEnd = do + ReadTreeInh{..} <- R.ask + e <- P.getParserState + let fileRange_end = Offset $ P.stateOffset e + return $ Sourced $ + (\(FileSource (curr:|path)) -> FileSource (curr{fileRange_end}:|path)) + readTreeInh_source + +-- * Type 'Error' +data Error + = Error_CharRef_invalid Integer + -- ^ Well-formedness constraint: Legal Character. + -- + -- Characters referred to using character references MUST match the production for Char. + | Error_EntityRef_unknown NCName + -- ^ Well-formedness constraint: Entity Declared + -- + -- In a document without any DTD, a document with only an internal DTD + -- subset which contains no parameter entity references, or a document + -- with " standalone='yes' ", for an entity reference that does not occur + -- within the external subset or a parameter entity, the Name given in the + -- entity reference MUST match that in an entity declaration that does not + -- occur within the external subset or a parameter entity, except that + -- well-formed documents need not declare any of the following entities: + -- amp, lt, gt, apos, quot. The declaration of a general entity MUST + -- precede any reference to it which appears in a default value in an + -- attribute-list declaration. + -- + -- Note that non-validating processors are not obligated to read and + -- process entity declarations occurring in parameter entities or in the + -- external subset; for such documents, the define that an entity must be + -- declared is a well-formedness constraint only if standalone='yes'. + | Error_Closing_tag_unexpected QName QName + -- ^ Well-formedness constraint: Element Type Match. + -- + -- The Name in an element's end-tag MUST match the element type in the start-tag. + | Error_Attribute_collision QName + -- ^ Well-formedness constraint: Unique Att Spec. + -- + -- An attribute name MUST NOT appear more than once in the same start-tag or empty-element tag. + | Error_PI_reserved PName + -- ^ The target names " XML ", " xml ", and so on are reserved for standardization. + | Error_Namespace_prefix_unknown NCName + -- ^ Namespace constraint: Prefix Declared + -- + -- The namespace prefix, unless it is xml or xmlns, MUST have been declared in a namespace declaration attribute in either the start-tag of the element where the prefix is used or in an ancestor element (i.e., an element in whose content the prefixed markup occurs). + | Error_Namespace_empty NCName + -- ^ Namespace constraint: No Prefix Undeclaring + -- + -- In a namespace declaration for a prefix (i.e., where the NSAttName is a PrefixedAttName), the attribute value MUST NOT be empty. + | Error_Namespace_reserved Namespace + | Error_Namespace_reserved_prefix NCName + -- ^ Namespace constraint: Reserved Prefixes and Namespace Names + -- + -- The prefix xml is by definition bound to the namespace name + -- http://www.w3.org/XML/1998/namespace. It MAY, but need not, be + -- declared, and MUST NOT be bound to any other namespace name. Other + -- prefixes MUST NOT be bound to this namespace name, and it MUST NOT be + -- declared as the default namespace. + -- + -- The prefix xmlns is used only to declare namespace bindings and is by + -- definition bound to the namespace name http://www.w3.org/2000/xmlns/. + -- It MUST NOT be declared . Other prefixes MUST NOT be bound to this + -- namespace name, and it MUST NOT be declared as the default namespace. + -- Element names MUST NOT have the prefix xmlns. + -- + -- All other prefixes beginning with the three-letter sequence x, m, l, in + -- any case combination, are reserved. This means that: + -- + -- - users SHOULD NOT use them except as defined by later specifications + -- - processors MUST NOT treat them as fatal errors. + deriving (Eq,Ord,Show) +instance P.ShowErrorComponent Error where + showErrorComponent = show + +-- * Helpers +p_error :: e -> ReadTree e s a +p_error = P.fancyFailure . Set.singleton . P.ErrorCustom + +p_quoted :: P.Tokens s ~ TL.Text => (Char -> ReadTree e s a) -> ReadTree e s a +p_quoted p = + P.between (P.char '"') (P.char '"') (p '"') <|> + P.between (P.char '\'') (P.char '\'') (p '\'') + +p_until :: + P.Tokens s ~ TL.Text => + (Char -> Bool) -> (Char, TL.Text) -> ReadTree e s TL.Text +p_until content (end, end_) = + (TL.concat <$>) $ P.many $ + P.takeWhile1P Nothing (\c -> content c && c /= end) <|> + P.try (TL.singleton <$> P.char end <* P.notFollowedBy (P.string end_)) + +p_until1 :: + P.Tokens s ~ TL.Text => + (Char -> Bool) -> (Char, TL.Text) -> ReadTree e s TL.Text +p_until1 content (end, end_) = + (TL.concat <$>) $ P.some $ + P.takeWhile1P Nothing (\c -> content c && c /= end) <|> + P.try (TL.singleton <$> P.char end <* P.notFollowedBy (P.string end_)) + +-- * Document +p_document :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTrees +p_document = do + ps <- p_prolog + e <- p_Element + m <- p_Miscs + P.eof + return (ps <> pure e <> m) + +-- ** Prolog +p_prolog :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTrees +p_prolog = (<>) + <$> P.option Seq.empty (pure <$> p_XMLDecl) + <*> p_Miscs + +-- ** Misc +p_Miscs :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTrees +p_Miscs = (Seq.fromList . catMaybes <$>) $ P.many $ + Just <$> p_Comment <|> + Just <$> p_PI <|> + Nothing <$ p_Spaces1 + +-- ** XMLDecl +p_XMLDecl :: P.Tokens s ~ TL.Text => ReadTree Error s FileSourcedTree +p_XMLDecl = do + Sourced src as <- p_Sourced $ P.between (P.string "") $ 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 "" + 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 " 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 '=' diff --git a/src/Symantic/XML/Tree/Source.hs b/src/Symantic/XML/Tree/Source.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/Tree/Source.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Symantic.XML.Tree.Source where + +import Control.Applicative (Applicative(..)) +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Function (($), (.), const) +import Data.Functor (Functor) +import Data.Functor.Identity (Identity(..)) +import Data.Monoid (Monoid(..)) +import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) +import Data.List.NonEmpty (NonEmpty(..)) +import Prelude (Num(..), Int) +import System.IO (FilePath) +import Text.Show (Show(..), shows, showChar, showParen, showString) + +-- * Type family 'Source' +type family Source (src :: * -> *) :: * +type instance Source (Sourced src) = src +type instance Source Identity = () + +-- * Class 'NoSource' +class NoSource src where + noSource :: a -> src a + nullSource :: Source src -> Bool + default nullSource :: + Eq (Source src) => + SourceOf src => + Source src -> Bool + nullSource = (==) (sourceOf @src (noSource @src ())) +instance NoSource Identity where + noSource = Identity + nullSource = const True + +-- * Class 'UnSource' +class UnSource src where + unSource :: src a -> a +instance UnSource Identity where + unSource = runIdentity + +-- * Class 'SourceOf' +class SourceOf src where + sourceOf :: src a -> Source src +instance SourceOf Identity where + sourceOf _ = () + +-- * Type 'FileSource' +newtype FileSource pos + = FileSource (NonEmpty (FileRange pos)) + deriving (Eq) +instance Show (FileRange pos) => Show (FileSource pos) where + showsPrec _p (FileSource (s:|[])) = shows s + showsPrec _p (FileSource (s:|s1:ss)) = + shows s . showString "\n in " . + shows (FileSource (s1:|ss)) + +-- ** Type 'FileSourced' +type FileSourced = Sourced (FileSource Offset) + +-- ** Type 'FileRange' +data FileRange pos + = FileRange + { fileRange_path :: FilePath + , fileRange_begin :: pos + , fileRange_end :: pos + } deriving (Eq, Ord) +instance Show (FileRange Offset) where + showsPrec _p FileRange{..} = + showString fileRange_path . showString " at char position " . + showsPrec 10 fileRange_begin . showString " to " . + showsPrec 10 fileRange_end +instance Show (FileRange LineColumn) where + showsPrec _p FileRange{..} = + showString fileRange_path . showString " at line:column position " . + showsPrec 10 fileRange_begin . showString " to " . + showsPrec 10 fileRange_end + +-- *** Type 'Offset' +newtype Offset = Offset Int + deriving (Eq, Ord) +instance Show Offset where + showsPrec p (Offset o) = showsPrec p o +instance Semigroup Offset where + Offset x <> Offset y = Offset (x+y) +instance Monoid Offset where + mempty = Offset 0 + mappend = (<>) + +-- *** Type 'LineColumn' +-- | Absolute text file position. +data LineColumn = LineColumn + { lineNum :: {-# UNPACK #-} Offset + , colNum :: {-# UNPACK #-} Offset + } deriving (Eq, Ord) +instance Show LineColumn where + showsPrec _p LineColumn{..} = + showsPrec 11 lineNum . + showChar ':' . + showsPrec 11 colNum + +-- * Type 'Sourced' +data Sourced src a + = Sourced + { source :: src + , unSourced :: a + } deriving (Functor) +instance UnSource (Sourced src) where + unSource = unSourced +instance NoSource (Sourced (FileSource Offset)) where + noSource = Sourced $ FileSource $ pure $ FileRange mempty mempty mempty +instance SourceOf (Sourced src) where + sourceOf (Sourced src _a) = src +-- | Ignore 'src' +instance Eq a => Eq (Sourced src a) where + x == y = unSourced x == unSourced y +-- | Ignore 'src' +instance Ord a => Ord (Sourced src a) where + x `compare` y = unSourced x `compare` unSourced y +instance + (Show src, Show a, NoSource (Sourced src)) => + Show (Sourced src a) where + showsPrec p (Sourced src a) + | nullSource @(Sourced src) src = showsPrec p a + | otherwise = + showParen (p > 10) $ + showsPrec 10 a . + showString " in " . showsPrec 10 src +instance Semigroup a => Semigroup (Sourced (FileSource Offset) a) where + (<>) + (Sourced rx@(FileSource (FileRange xf xb xe :| xs)) x) + (Sourced (FileSource (FileRange yf yb ye :| _ys)) y) + | xf == yf && xe == yb = + Sourced (FileSource (FileRange xf xb ye :| xs)) $ x<>y + | otherwise = Sourced rx (x<>y) diff --git a/src/Symantic/XML/Tree/Write.hs b/src/Symantic/XML/Tree/Write.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/Tree/Write.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +module Symantic.XML.Tree.Write where + +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..), all) +import Data.Function (($), (.), const) +import Data.Maybe (Maybe(..)) +import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (IsString(..)) +import Data.Traversable (Traversable(..)) +import Data.Tuple (fst) +import System.IO (IO, FilePath) +import qualified Control.Monad.Trans.State as S +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Char as Char +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.List as List +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.TreeSeq.Strict as TS + +import Symantic.XML.Language +import Symantic.XML.Tree.Source +import Symantic.XML.Tree.Data +import Symantic.XML.Write + +writeTree :: UnSource src => Trees src -> TL.Text +writeTree ts = TLB.toLazyText $ unTreeWrite (write_Trees ts) defaultWriteInh + +writeTreeIndented :: UnSource src => TL.Text -> Trees src -> TL.Text +writeTreeIndented ind xs = + TLB.toLazyText $ + unTreeWrite (write_Trees xs) defaultWriteInh + { writeInh_indent_delta = ind } + +writeFile :: FilePath -> TL.Text -> IO () +writeFile fp = BSL.writeFile fp . TL.encodeUtf8 + +-- * Type 'TreeWrite' +newtype TreeWrite + = TreeWrite + { unTreeWrite :: WriteInh -> TLB.Builder + } +instance Semigroup TreeWrite where + TreeWrite x <> TreeWrite y = TreeWrite (x <> y) +instance Monoid TreeWrite where + mempty = TreeWrite (const "") + mappend = (<>) +instance IsString TreeWrite where + fromString = TreeWrite . const . fromString + +write_Trees :: UnSource src => Trees src -> TreeWrite +write_Trees = foldMap write_Tree + +write_Tree :: UnSource src => Tree src -> TreeWrite +write_Tree (TS.Tree node elemChilds) = TreeWrite $ \inh -> + case unSource node of + NodeText et@(EscapedText t) + -- Remove spaces when indenting + | not $ TL.null (writeInh_indent_delta inh) + , all (\case + EscapedPlain p -> TL.all Char.isSpace p + _ -> False + ) t -> mempty + | otherwise -> textify et + NodePI pn pv -> + writeInh_indent inh <> + "textify pn<> + (case pn of + -- Special case: the value of the "xml" PI is parsed + -- as children NodePI + "xml" -> foldMap (\case + TS.Tree nod _ -> + case unSource nod of + NodePI n v -> " "<>textify n<>"=\""<>textify v<>"\"" + _ -> mempty + ) elemChilds + _ -> s<>textify pv + ) <> "?>" <> nl inh + where s | TL.null pv = "" + | otherwise = " " + NodeCDATA t -> + writeInh_indent inh <> + "<[CDATA[["<>textify (TL.replace "]]>" "]]>" t)<>"]]>"<>nl inh + NodeComment t -> + writeInh_indent inh <> + "" "-->" 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 + } diff --git a/src/Symantic/XML/Write.hs b/src/Symantic/XML/Write.hs new file mode 100644 --- /dev/null +++ b/src/Symantic/XML/Write.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE UndecidableInstances #-} +module Symantic.XML.Write where + +import Control.Applicative (Applicative(..), Alternative((<|>))) +import Data.Bool +import Data.Either (Either(..)) +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..)) +import Data.Function (($), (.), id) +import Data.Functor ((<$>), (<$)) +import Data.Int (Int) +import Data.Maybe (Maybe(..), fromMaybe) +import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) +import Data.String (String) +import Data.Traversable (Traversable(..)) +import Data.Tuple (fst) +import Numeric.Natural (Natural) +import Prelude (Integer, error) +import System.IO (IO, FilePath) +import Text.Show (Show(..)) +import qualified Control.Exception as Exn +import qualified Control.Monad.Trans.State as S +import qualified Data.ByteString.Lazy as BSL +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Lazy.Encoding as TL +import qualified System.IO.Error as IO + +import Symantic.Base.CurryN +import Symantic.XML.Language +import Symantic.XML.RelaxNG.Language + +-- * Type 'Write' +newtype Write params k + = Write + { unWrite :: (WriteSyn -> k) -> params + } + +write :: Write params BSL.ByteString -> params +write = runWrite defaultWriteInh + +runWrite :: WriteInh -> Write params BSL.ByteString -> params +runWrite def (Write params) = params $ \syn -> + TL.encodeUtf8 $ TLB.toLazyText $ + fromMaybe mempty $ writeSyn_result syn def + +writeUtf8 :: FilePath -> Write params (IO (Maybe ErrorWrite)) -> params +writeUtf8 path (Write params) = params $ \syn -> + let txt = + TL.encodeUtf8 $ TLB.toLazyText $ + fromMaybe mempty $ + writeSyn_result syn defaultWriteInh in + (Nothing <$ BSL.writeFile path txt) + `Exn.catch` \e -> + if IO.isAlreadyInUseError e + || IO.isPermissionError e + then pure $ Just e + else IO.ioError e + +-- ** Type 'Write' +type ErrorWrite = IO.IOError + +-- ** Type 'WriteInh' +-- | Top-down inheritage. +data WriteInh + = WriteInh + { writeInh_namespaces :: Namespaces NCName + -- ^ 'Namespaces' from the parent element. + , writeInh_indent :: TLB.Builder + , writeInh_indent_delta :: TL.Text + } + +defaultWriteInh :: WriteInh +defaultWriteInh = WriteInh + { writeInh_namespaces = defaultNamespaces + , writeInh_indent = mempty + , writeInh_indent_delta = " " + } + +-- ** Type 'WriteSyn' +-- | Bottom-up synthesis to build 'element' or 'attribute'. +data WriteSyn + = WriteSyn + { writeSyn_attrs :: HM.HashMap QName TL.Text + , writeSyn_attr :: TL.Text + , writeSyn_namespaces_default :: Maybe Namespace + , writeSyn_namespaces_prefixes :: HM.HashMap Namespace NCName + , writeSyn_result :: WriteInh -> Maybe TLB.Builder + } + +instance Semigroup WriteSyn where + x <> y = WriteSyn + { writeSyn_attrs = writeSyn_attrs x <> writeSyn_attrs y + , writeSyn_attr = writeSyn_attr x <> writeSyn_attr y + , writeSyn_namespaces_default = writeSyn_namespaces_default x <|> writeSyn_namespaces_default y + , writeSyn_namespaces_prefixes = writeSyn_namespaces_prefixes x <> writeSyn_namespaces_prefixes y + , writeSyn_result = writeSyn_result x <> writeSyn_result y + } +instance Monoid WriteSyn where + mempty = WriteSyn + { writeSyn_attrs = mempty + , writeSyn_attr = mempty + , writeSyn_namespaces_default = Nothing + , writeSyn_namespaces_prefixes = mempty + , writeSyn_result = mempty + } + +instance Emptyable Write where + empty = Write (\k -> k mempty) +instance Unitable Write where + unit = Write (\k () -> k mempty) +instance Voidable Write where + void a (Write x) = Write (\k -> x k a) +instance Dimapable Write where + dimap _a2b b2a (Write x) = Write $ \k b -> + x k (b2a b) +instance Dicurryable Write where + dicurry (_::proxy args) _construct destruct (Write x) = + Write $ \k r -> + uncurryN @args (x k) (destruct r) +instance Composable Write where + Write x <.> Write y = Write $ \k -> + x (\mx -> y $ \my -> k (mx<>my)) +instance Tupable Write where + Write x <:> Write y = Write $ \k (a,b) -> + x (\mx -> y (\my -> k (mx<>my)) b) a +instance Eitherable Write where + Write x <+> Write y = Write $ \k -> \case + Left a -> x k a + Right b -> y k b +instance Constant Write where + constant _a = Write $ \k _a -> k mempty +instance Optionable Write where + option = id + optional (Write x) = Write $ \k -> + \case + Nothing -> k mempty + Just a -> x k a +{- +instance Routable Write where + Write x Write y = Write $ \k -> + x k :!: y k +-} +instance Repeatable Write where + many0 (Write x) = Write $ \k -> \case + [] -> k mempty + a:as -> x (\ma -> + unWrite (many0 (Write x)) + (\mas -> k (ma<>mas)) as) a + many1 (Write x) = Write $ \k -> \case + [] -> k mempty + a:as -> x (\ma -> + unWrite (many0 (Write x)) + (\mas -> k (ma<>mas)) as) a +instance Textable Write where + type TextConstraint Write a = EncodeText a + text = Write $ \k v -> + let t = encodeText v in + k mempty + { writeSyn_attr = t + , writeSyn_result = \_inh -> Just $ textify $ escapeText t + } +instance XML Write where + namespace nm ns = Write $ \k -> + k $ case nm of + Nothing -> mempty{writeSyn_namespaces_default=Just ns} + Just p -> mempty{writeSyn_namespaces_prefixes=HM.singleton ns p} + element elemQName (Write x) = Write $ \k -> + x $ \syn -> + k mempty{ writeSyn_result = \inh -> + let + hasIndenting = not $ TL.null $ writeInh_indent_delta inh + defNS = fromMaybe + (namespaces_default (writeInh_namespaces inh)) + (writeSyn_namespaces_default syn) + usedNS = + HS.singleton (qNameSpace elemQName) <> + HS.delete xmlns_empty (HS.fromList (qNameSpace <$> HM.keys (writeSyn_attrs syn))) + -- The inherited namespaces, + -- including those declared at this element. + inhNS = + HM.union + (writeSyn_namespaces_prefixes syn) + (namespaces_prefixes (writeInh_namespaces inh)) + -- The namespaces used but not declared nor default, + -- with fresh prefixes. + autoNS = + -- HM.delete defNS $ + (`S.evalState` HS.empty) $ + traverse + (\() -> S.gets freshNCName) + (HS.toMap usedNS `HM.difference` inhNS) + write_xmlnsAttrs = + (if defNS == namespaces_default (writeInh_namespaces inh) + then mempty + else textifyAttr (PName Nothing "xmlns") (escapeAttr (unNamespace defNS))) <> + HM.foldrWithKey (\(Namespace ns) qNameLocal acc -> + textifyAttr (PName (Just "xmlns") qNameLocal) (escapeAttr ns) <> acc + ) mempty + (autoNS <> writeSyn_namespaces_prefixes syn) + scopeNS = Namespaces + { namespaces_prefixes = autoNS <> inhNS + , namespaces_default = defNS + } + write_elemPName = textify $ prefixifyQName scopeNS elemQName + write_elemAttrs = + foldMap (\(an, av) -> textifyAttr + (prefixifyQName scopeNS{namespaces_default=xmlns_empty} an) + (escapeAttr av)) $ + List.sortOn fst $ -- This makes the rendition more predictible, but this is useless. + HM.toList (writeSyn_attrs syn) + write_elemChilds = writeSyn_result syn inh + { writeInh_namespaces = scopeNS + -- Disable indenting unless hasIndenting. + , writeInh_indent = + if hasIndenting + then + writeInh_indent inh <> + textify (writeInh_indent_delta inh) + else mempty + , writeInh_indent_delta = + if hasIndenting + then writeInh_indent_delta inh + else mempty + } + in Just $ + writeInh_indent inh + <> "<" + <> write_elemPName + <> write_xmlnsAttrs + <> write_elemAttrs + <> case write_elemChilds of + Nothing -> "/>" <> nl inh + Just w -> ">" + <> nl inh + <> w + <> (if hasIndenting then writeInh_indent inh else mempty) + <> "write_elemPName<>">" + <> nl inh + } + attribute n@(QName ans aln) (Write x) = Write $ \k -> + x $ \syn -> + if ans == xmlns_xmlns + then unWrite (namespace (Just aln) (Namespace (writeSyn_attr syn))) k + else if ans == xmlns_empty && aln == NCName "xmlns" + then unWrite (namespace Nothing (Namespace (writeSyn_attr syn))) k + else k mempty{writeSyn_attrs = HM.insert n (writeSyn_attr syn) (writeSyn_attrs syn)} + literal lit = Write $ \k -> + k mempty + { writeSyn_attr = lit + , writeSyn_result = \_inh -> + Just $ textify $ escapeText lit + } + pi n = Write $ \k v -> + k mempty{ writeSyn_result = \inh -> + let s | TL.null v = "" + | otherwise = " " in + Just $ + writeInh_indent inh <> + "textify n<>s <> + textify (TL.replace "?>" "?>" v) <> + "?>"<>nl inh + } + comment = Write $ \k v -> + k mempty{ writeSyn_result = \inh -> + Just $ + writeInh_indent inh <> + "" "-->" 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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,4 @@ -resolver: lts-13.19 -packages: -- '.' -- location: '../treeseq' - extra-dep: true -- location: '../symantic/symantic-grammar' - extra-dep: true +resolver: lts-15.4 extra-deps: -- megaparsec-7.0.4@sha256:a7397151601cbe6b8f831f8bdad1a10118dcd6d9a7ee50d6bbdcfbd1181b4ba2 +- ../treeseq +- ../symantic-base diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,12 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 491163 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/4.yaml + sha256: bc60043a06b58902b533baa80fb566c0ec495c41e428bc0f8c1e8c15b2a4c468 + original: lts-15.4 diff --git a/symantic-xml.cabal b/symantic-xml.cabal --- a/symantic-xml.cabal +++ b/symantic-xml.cabal @@ -2,62 +2,65 @@ -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 1.0.0.20190223 -category: Data Structures -synopsis: Library for reading, validating and writing a subset of the XML format. -description: Symantics for an approximative implementation - of XML (eXtensible Markup Language) and RNC (RelaxNG Compact). +version: 2.0.0.20200523 +category: Text, XML +synopsis: Library for reading, validating and writing XML. +description: Symantics for XML (eXtensible Markup Language) + and RNC (RelaxNG Compact). . - Motivation: Other Haskell libraries do not fit my needs or are too heavy/complex. - I like the principle to parse XML using some symantics, - which can both generate a Megaparsec parser to validate the XML tree, - and a RNC rendition of the schema it validates. + DISCLAIMER: This is an experimental library, use at your own risks. . - DISCLAMER: My life being's too short, I'm NOT burning my brain - on seriously conforming to the too complex XML and RNC formats. - Still I try to respect a vague subset of those, - unless it makes the code more complex than I am comfortable with. + Motivation: Writing a schema using Haskell combinators + and deriving automatically a reader, a writer + and a documentation from it. . - WARNING: It's currently using an old symantic approach, - not the one developped in . - This may change when I'll get to it. + Example: + . + * extra-doc-files: license: GPL-3 license-file: COPYING stability: experimental -author: Julien Moutinho -maintainer: Julien Moutinho -bug-reports: Julien Moutinho +author: Julien Moutinho +maintainer: Julien Moutinho +bug-reports: Julien Moutinho -- homepage: build-type: Simple cabal-version: 1.24 -tested-with: GHC==8.6.4 +tested-with: GHC==8.8.3 extra-source-files: stack.yaml + stack.yaml.lock extra-tmp-files: Source-Repository head - location: git://git.autogeree.net/symantic-xml + location: git://git.sourcephile.fr/haskell/symantic-xml type: git Library + hs-source-dirs: src exposed-modules: - Symantic.RNC - Symantic.RNC.Sym - Symantic.RNC.Validate - Symantic.RNC.Write - Symantic.RNC.Write.Fixity - Symantic.RNC.Write.Namespaces Symantic.XML - Symantic.XML.Document + Symantic.XML.Language + Symantic.XML.Namespace Symantic.XML.Read - Symantic.XML.Read.Parser + Symantic.XML.RelaxNG + Symantic.XML.RelaxNG.Compact.Write + Symantic.XML.RelaxNG.Language + Symantic.XML.Text + Symantic.XML.Tree + Symantic.XML.Tree.Data + Symantic.XML.Tree.Read + Symantic.XML.Tree.Source + Symantic.XML.Tree.Write Symantic.XML.Write default-language: Haskell2010 default-extensions: + DefaultSignatures FlexibleContexts FlexibleInstances + GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns @@ -65,24 +68,22 @@ RecordWildCards ScopedTypeVariables TupleSections - -- TypeFamilies + TypeApplications + TypeFamilies + TypeOperators ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -fno-warn-tabs -- -fhide-source-paths build-depends: base >= 4.10 && < 5 , bytestring >= 0.10 , containers >= 0.5 - , data-default-class >= 0.1 - , filepath >= 1.4 , hashable >= 1.2.6 , hxt-charproperties >= 9.2 - , megaparsec >= 7.0.4 - -- , parser-combinators >= 1.0 - , safe >= 0.3 + , megaparsec >= 8.0 + , symantic-base >= 0.0 , text >= 1.2 , transformers >= 0.5 , treeseq >= 1.0 @@ -93,8 +94,8 @@ hs-source-dirs: test main-is: Main.hs other-modules: - RNC.Parser - RNC.Commoning + RelaxNG.Commoning + RelaxNG.Whatever Golden -- HUnit -- QuickCheck @@ -104,28 +105,28 @@ NamedFieldPuns NoImplicitPrelude RecordWildCards + TypeFamilies ViewPatterns ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates - -fno-warn-tabs -fhide-source-paths build-depends: symantic-xml + , symantic-base >= 0.0 , base >= 4.10 && < 5 , bytestring >= 0.10 , containers >= 0.5 - , data-default-class >= 0.1 , deepseq >= 1.4 - , filepath >= 1.4 , hashable >= 1.2.6 , megaparsec >= 7.0.4 , tasty >= 0.11 , tasty-golden >= 2.3 + -- , tasty-hunit , text >= 1.2 + -- , time >= 1.9 , transformers >= 0.4 , treeseq >= 1.0 -- , QuickCheck >= 2.0 - -- , tasty-hunit -- , tasty-quickcheck diff --git a/test/Golden.hs b/test/Golden.hs --- a/test/Golden.hs +++ b/test/Golden.hs @@ -1,41 +1,106 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Golden where -import Control.Arrow (left) import Control.Monad (Monad(..), sequence) import Data.Bool import Data.Either (Either(..)) -import Data.Foldable (Foldable(..)) import Data.Function (($), (.)) import Data.Functor ((<$>)) +import Data.Monoid (Monoid(..)) import Data.Semigroup (Semigroup(..)) import Data.String (String) -import Data.Void (Void) -import System.FilePath (FilePath) -import System.IO (IO) +import System.IO (IO, FilePath) import Text.Show (Show(..)) import qualified Data.ByteString.Lazy as BSL import qualified Data.List as List import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -import qualified Text.Megaparsec as P import qualified Data.TreeSeq.Strict as TS import Test.Tasty import Test.Tasty.Golden -import Symantic.XML.Read.Parser (XMLs) import qualified Symantic.XML as XML -import qualified Symantic.RNC as RNC -import RNC.Parser () -import qualified RNC.Commoning +import qualified Symantic.XML.RelaxNG as RelaxNG +import qualified RelaxNG.Commoning +import qualified RelaxNG.Whatever +goldensIO :: IO TestTree +goldensIO = + testGroup "Golden" <$> + sequence + [ goldensXML + , goldensRelaxNG + ] + +goldensXML :: IO TestTree +goldensXML = do + inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/XML" + return $ testGroup "XML" + [ testGroup "Read" + [ testGolden inputFile ".read" $ + XML.readTree inputFile >>= \ast -> + return $ TL.encodeUtf8 . TL.pack . TS.prettyTrees <$> ast + | inputFile <- inputFiles + ] + , testGroup "Write" $ List.concat + [ + [ testGolden inputFile ".write" $ + XML.readTree inputFile >>= \ast -> + return $ TL.encodeUtf8 . XML.writeTree <$> ast + , testGolden inputFile ".write.indented" $ + XML.readTree inputFile >>= \ast -> + return $ TL.encodeUtf8 . XML.writeTreeIndented (TL.pack " ") <$> ast + ] + | inputFile <- inputFiles + , not $ List.isInfixOf "/Error/" inputFile + ] + ] + +goldensRelaxNG :: IO TestTree +goldensRelaxNG = do + inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/RelaxNG" + return $ testGroup "RelaxNG" + [ testGroup "Validate" + [ testGroup "Commoning" $ mconcat + [ + let xml = XML.read RelaxNG.Commoning.schema inputFile in + [ testGolden inputFile ".read" $ + ((TL.encodeUtf8 . TL.pack . show) <$>) <$> xml + , testGolden inputFile ".write" $ + ((XML.write RelaxNG.Commoning.schema) <$>) <$> xml + ] + | inputFile <- inputFiles + , "/Commoning/" `List.isInfixOf` inputFile + ] + , testGroup "Whatever" $ mconcat + [ + let xml = XML.read RelaxNG.Whatever.schema inputFile in + [ testGolden inputFile ".read" $ + ((TL.encodeUtf8 . TL.pack . show) <$>) <$> xml + , testGolden inputFile ".write" $ + ((XML.write RelaxNG.Whatever.schema) <$>) <$> xml + ] + | inputFile <- inputFiles + , "/Whatever/" `List.isInfixOf` inputFile + ] + ] + , testGroup "Compact" + [ testGroup "Write" + [ testGolden "test/Golden/RelaxNG/Commoning" ".rnc" $ + return $ Right $ TL.encodeUtf8 $ + RelaxNG.writeRNC RelaxNG.Commoning.schema + , testGolden "test/Golden/RelaxNG/Whatever" ".rnc" $ + return $ Right $ TL.encodeUtf8 $ + RelaxNG.writeRNC RelaxNG.Whatever.schema + ] + ] + ] + -- * Golden testing utilities testGolden :: TestName -> TestName -> IO (Either String BSL.ByteString) -> TestTree -testGolden inputFile expectedExt = - goldenVsStringDiff inputFile diffGolden (inputFile <> expectedExt) - . (>>= unLeft) +testGolden testName expectedExt = + goldenVsStringDiff testName diffGolden (testName <> expectedExt) + . (>>= unLeft) diffGolden :: FilePath -> FilePath -> [String] diffGolden ref new = ["diff", "-u", ref, new] @@ -44,67 +109,3 @@ unLeft = \case Left err -> return $ TL.encodeUtf8 $ TL.pack err Right a -> return a - -goldensIO :: IO TestTree -goldensIO = - testGroup "Golden" <$> - sequence - [ goldensXML - , goldensRNC - ] - -goldensXML :: IO TestTree -goldensXML = do - inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/XML" - return $ testGroup "XML" - [ testGroup "Read" - [ testGolden inputFile ".read" $ - readXML inputFile >>= \ast -> - return $ TL.encodeUtf8 . TL.pack . TS.prettyTrees <$> ast - | inputFile <- inputFiles - ] - , testGroup "Write" $ List.concat - [ - [ testGolden inputFile ".write" $ - readXML inputFile >>= \ast -> - return $ TL.encodeUtf8 . XML.writeXML <$> ast - , testGolden inputFile ".write.indented" $ - readXML inputFile >>= \ast -> - return $ TL.encodeUtf8 . XML.writeXMLIndented (TL.pack " ") <$> ast - ] - | inputFile <- inputFiles - , not $ List.isInfixOf "/Error/" inputFile - ] - ] - -readXML :: FilePath -> IO (Either String XMLs) -readXML inputFile = - XML.readFile inputFile >>= \case - Left err -> return $ Left $ show err - Right input -> - return $ left P.errorBundlePretty $ - XML.readXML inputFile input - -goldensRNC :: IO TestTree -goldensRNC = do - inputFiles <- List.sort <$> findByExtension [".xml"] "test/Golden/RNC" - return $ testGroup "RNC" - [ testGroup "Validate" - [ testGolden inputFile ".read" $ - validateXML inputFile RNC.Commoning.commoning >>= \a -> - return $ TL.encodeUtf8 . TL.pack . show <$> a - | inputFile <- inputFiles - , List.isInfixOf "/Commoning/" inputFile - ] - ] - -validateXML :: FilePath -> P.Parsec Void XMLs a -> IO (Either String a) -validateXML inputFile rnc = - (<$> readXML inputFile) $ \case - Left err -> Left err - Right xml -> do - case RNC.validateXML rnc xml of - Right a -> Right a - Left err -> - Left $ List.unlines $ toList $ - P.parseErrorTextPretty <$> P.bundleErrors err diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -5,11 +5,13 @@ import Test.Tasty import Golden +--import HUnit main :: IO () main = do - goldens <- goldensIO - defaultMain $ - testGroup "Symantic" - [ goldens - ] + goldens <- goldensIO + defaultMain $ + testGroup "" + [ goldens + --, hunits + ] diff --git a/test/RNC/Commoning.hs b/test/RNC/Commoning.hs deleted file mode 100644 --- a/test/RNC/Commoning.hs +++ /dev/null @@ -1,350 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE StrictData #-} -module RNC.Commoning where - -import Control.Applicative (Applicative(..), Alternative(..)) -import Control.Monad (Monad, void) -import Data.Default.Class (Default(..)) -import Data.Eq (Eq) -import Data.Function (($), (.)) -import Data.Functor ((<$>)) -import Data.Hashable (Hashable) -import Data.Maybe (Maybe(..)) -import Data.Ord (Ord) -import Data.Sequence (Seq) -import Text.Show (Show) -import qualified Data.Text.Lazy as TL -import qualified Data.TreeSeq.Strict as TS -import qualified Text.Megaparsec as P - -import Symantic.RNC (Sym_Permutation(..)) -import qualified Symantic.RNC as RNC -import qualified Symantic.XML as XML - -import RNC.Parser - --- * Type 'Commoning' -data Commoning = Commoning - { commoning_persons :: Persons - , commoning_opinions :: Opinions - , commoning_groups :: Groups - , commoning_operations :: Operations - , commoning_resources :: Resources - } deriving (Show) - --- ** Type 'Person' -data Person = Person - { person_id :: Ident - , person_fields :: Seq Fields - } deriving (Show) --- *** Type 'Persons' -type Persons = [Person] - --- ** Type 'Group' -type Group = TS.Tree NodeGroup --- *** Type 'NodeGroup' -data NodeGroup = NodeGroup - { group_id :: Ident - , group_name :: Maybe Name - , group_fields :: Seq Fields - , group_members :: Members - } deriving (Show) --- *** Type 'Groups' -type Groups = Seq Group - --- ** Type 'Member' -newtype Member = Member - { member_person :: Ident - } deriving (Show) --- *** Type 'Members' -type Members = [Member] - --- ** Type 'Resource' -type Resource = TS.Tree NodeResource --- *** Type 'NodeResource' -data NodeResource = NodeResource - { resource_name :: Name - , resource_policies :: Policies - } deriving (Show) --- *** Type 'Resources' -type Resources = Seq Resource - --- ** Type 'Policy' -data Policy = Policy - { policy_operation :: Name - , policy_by :: Ident - , policy_toward :: (Maybe Ident) - , policy_rules :: Rules - } deriving (Show) --- *** Type 'Policies' -type Policies = [Policy] - --- ** Type 'Rule' -data Rule = Rule - { rule_grades :: Ident - , rule_gradeRange :: GradeRange - } deriving (Show) --- *** Type 'Rules' -type Rules = [Rule] - --- *** Type 'GradeRange' -data GradeRange - = GradeRange_Single Name - | GradeRange_Min Name - | GradeRange_Max Name - | GradeRange Name Name - deriving (Show) - --- * Type 'Opinions' -type Opinions = [Grades] - --- ** Type 'Grade' -data Grade = Grade - { grade_name :: Name - , grade_abbrev :: Maybe Name - , grade_color :: Maybe Color - } deriving (Show) --- *** Type 'Grades' -data Grades = Grades - { grades_id :: Ident - , grades_name :: Maybe Name - , grades_list :: [Grade] - } deriving (Show) --- *** Type 'Color' -type Color = TL.Text - --- ** Type 'Operation' -type Operation = TS.Tree NodeOperation --- *** Type 'NodeOperation' -newtype NodeOperation = NodeOperation - { operation_id :: Ident - } deriving (Show) --- *** Type 'Operations' -type Operations = Seq Operation - --- ** Type 'Field' -data Field = Field - { field_name :: Name - , field_value :: TL.Text - } deriving (Show) --- *** Type 'Fields' -type Fields = TS.Tree NodeField --- **** Type 'NodeField' -data NodeField - = NodeField Field - | NodeFields { fields_name :: Name } - deriving (Show) - --- * Type 'Ident' -newtype Ident = Ident TL.Text - deriving (Eq,Ord,Show,Hashable) --- * Type 'Name' -newtype Name = Name TL.Text - deriving (Eq,Ord,Show,Hashable) - --- * Class 'Sym_Commoning' -xmlns_commoning :: XML.Namespace -xmlns_commoning = "http://commonsoft.org/xml/2018/commoning.rnc" -element :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a -element = RNC.element . XML.QName xmlns_commoning -attribute :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a -attribute = RNC.attribute . XML.QName "" - -class RNC.Sym_RNC repr => Sym_Commoning repr where - commoning :: repr Commoning - persons :: repr Persons - person :: repr Person - opinions :: repr Opinions - grades :: repr Grades - grade :: repr Grade - fields :: repr Fields - field :: repr Field - groups :: repr Groups - group :: repr Group - members :: repr Members - member :: repr Member - operations :: repr Operations - operation :: repr Operation - resources :: repr Resources - resource :: repr Resource - policy :: repr Policy - rule :: repr Rule - ident :: repr Ident - name :: repr Name - color :: repr Color - - commoning = RNC.rule "commoning" $ - element "commoning" $ - runPermutation $ - Commoning - <$$> persons - <||> opinions - <||> groups - <||> operations - <||> resources - persons = RNC.rule "persons" $ - element "persons" $ RNC.many person - person = RNC.rule "person" $ - element "person" $ attrs <*> RNC.manySeq fields - where - attrs = - runPermutation $ - Person - <$$> attribute "id" ident - opinions = RNC.rule "opinions" $ - element "opinions" $ - RNC.many grades - grades = RNC.rule "grades" $ - element "grades" $ attrs <*> RNC.many grade - where - attrs = - runPermutation $ - Grades - <$$> attribute "id" ident - <|?> (def, Just <$> attribute "name" name) - grade = RNC.rule "grade" $ - element "grade" $ attrs - where - attrs = - runPermutation $ - Grade - <$$> attribute "name" name - <|?> (def, Just <$> attribute "abbrev" name) - <|?> (def, Just <$> attribute "color" color) - fields = RNC.rule "fields" $ - element "fields" $ - (TS.Tree <$> attrs <*>) $ - RNC.manySeq $ - TS.tree0 . NodeField <$> field - <|> fields - where - attrs = - runPermutation $ - NodeFields - <$$> attribute "name" name - field = RNC.rule "field" $ - element "field" $ attrs <*> RNC.text - where - attrs = - runPermutation $ - Field - <$$> attribute "name" name - groups = RNC.rule "groups" $ - element "groups" $ RNC.manySeq group - group = RNC.rule "group" $ - element "group" $ - (((TS.Tree <$>) $ attrs <*> RNC.manySeq fields <*> members) <*>) $ - RNC.manySeq group - where - attrs = - runPermutation $ - NodeGroup - <$$> attribute "id" ident - <|?> (def, Just <$> attribute "name" name) - members = RNC.rule "members" $ RNC.many member - member = RNC.rule "member" $ - element "member" $ attrs - where - attrs = - runPermutation $ - Member - <$$> attribute "person" ident - operations = RNC.rule "operations" $ - element "operations" $ RNC.manySeq operation - operation = RNC.rule "operation" $ - element "operation" $ - (((TS.Tree <$>) $ attrs) <*>) $ - RNC.manySeq operation - where - attrs = - runPermutation $ - NodeOperation - <$$> attribute "id" ident - resources = RNC.rule "resources" $ - element "resources" $ RNC.manySeq resource - resource = RNC.rule "resource" $ - element "resource" $ - (((TS.Tree <$>) $ attrs <*> RNC.many policy) <*>) $ - RNC.manySeq resource - where - attrs = - runPermutation $ - NodeResource - <$$> attribute "name" name - policy = RNC.rule "policy" $ - element "policy" $ attrs - where - attrs = - runPermutation $ - Policy - <$$> attribute "operation" name - <||> attribute "by" ident - <|?> (def, Just <$> attribute "toward" ident) - <|*> rule - rule = RNC.rule "rule" $ - element "rule" $ attrs - where - attrs - = RNC.try attrsGrade - <|> RNC.try attrsGradeMin - <|> attrsGradeMax - attrsGrade = - runPermutation $ - Rule - <$$> attribute "grades" ident - <||> (GradeRange_Single <$> attribute "grade" name) - attrsGradeMin = - runPermutation $ - (\gs gMin mgMax -> Rule gs $ case mgMax of - Nothing -> GradeRange_Min gMin - Just gMax -> GradeRange gMin gMax) - <$$> attribute "grades" ident - <||> attribute "gradeMin" name - <|?> (def, Just <$> attribute "gradeMax" name) - attrsGradeMax = - runPermutation $ - (\gs mgMin gMax -> Rule gs $ case mgMin of - Nothing -> GradeRange_Max gMax - Just gMin -> GradeRange gMin gMax) - <$$> attribute "grades" ident - <|?> (def, Just <$> attribute "gradeMin" name) - <||> attribute "gradeMax" name - - ident = RNC.rule "ident" $ Ident <$> RNC.text - name = RNC.rule "name" $ Name <$> RNC.text - color = RNC.rule "color" $ RNC.text -instance Sym_Commoning RNC.NS -instance Sym_Commoning RNC.Writer -instance - ( Ord err - , Ord src - , XML.NoSource src - ) => Sym_Commoning (P.Parsec err (XML.XMLs src)) - --- newtype Forall cl a = Forall { unForall :: forall repr. cl repr => repr a } -rnc :: forall repr. Sym_Commoning repr => [repr ()] -rnc = - [ void $ RNC.namespace Nothing xmlns_commoning - , void $ commoning - , void $ persons - , void $ person - , void $ opinions - , void $ grades - , void $ grade - , void $ fields - , void $ field - , void $ groups - , void $ group - , void $ members - , void $ member - , void $ resources - , void $ resource - , void $ policy - , void $ rule - , void $ ident - , void $ name - , void $ color - ] diff --git a/test/RNC/Parser.hs b/test/RNC/Parser.hs deleted file mode 100644 --- a/test/RNC/Parser.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module RNC.Parser where - -import Control.Applicative (Applicative(..)) -import Control.Monad (Monad(..)) -import Data.Bool -import Data.Either (Either(..)) -import Data.Foldable (Foldable(..)) -import Data.Function (($), (.)) -import Data.Functor ((<$>)) -import Data.Maybe (Maybe(..)) -import Data.Monoid (Monoid(..)) -import Data.Ord (Ord(..)) -import Data.Semigroup (Semigroup(..)) -import Data.Sequence (ViewL(..)) -import Prelude (error) -import Text.Show (Show(..)) -import qualified Data.List as List -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Sequence as Seq -import qualified Text.Megaparsec as P - -import Symantic.XML.Document (XML, XMLs) -import qualified Symantic.XML.Document as XML -import qualified Symantic.RNC.Validate as RNC - -instance Ord src => P.Stream (XMLs src) where - type Token (XMLs src) = XML src - type Tokens (XMLs src) = XMLs src - take1_ s = - case Seq.viewl s of - EmptyL -> Nothing - t@(XML.Tree XML.Sourced{XML.unSourced=n} _) :< ts - | RNC.isIgnoredNode n -> P.take1_ ts - | otherwise -> Just (t, ts) - takeN_ n s | n <= 0 = Just (mempty, s) - | null s = Nothing - | otherwise = - let (ns,rs) = Seq.splitAt n s in - let (ko,ok) = Seq.partition (RNC.isIgnoredNode . XML.unSourced . XML.unTree) ns in - case P.takeN_ (Seq.length ko) rs of - Nothing -> Just (ok, rs) - Just (ns',rs') -> Just (ok<>ns', rs') - tokensToChunk _s = Seq.fromList - chunkToTokens _s = toList - chunkLength _s = Seq.length - takeWhile_ = Seq.spanl - -- | NOTE: unimplemented: useless since each 'XML.Node' is annotated with its 'FileSource'. - reachOffset = error "[BUG] P.Stream XMLs: reachOffset is not helpful, please use annotated source locations" - -- | NOTE: useless since each 'XML.Node' is annotated with its 'FileSource'. - reachOffsetNoLine = error "[BUG] P.Stream XMLs: reachOffsetNoLine is not helpful, please use annotated source locations" - showTokens _s toks = List.intercalate ", " $ toList $ showTree <$> toks - where - showTree (XML.Tree (XML.Sourced _src a) _ts) = - case a of - XML.NodeElem n -> "element "<>show n<>"" - XML.NodeAttr n -> "attribute "<>show n<>"" - XML.NodeText _t -> "text" - XML.NodeComment _c -> "comment" - XML.NodePI n _t -> "processing-instruction "<>show n<>"" - XML.NodeCDATA _t -> "cdata" diff --git a/test/RelaxNG/Commoning.hs b/test/RelaxNG/Commoning.hs new file mode 100644 --- /dev/null +++ b/test/RelaxNG/Commoning.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module RelaxNG.Commoning where + +import Data.Eq (Eq) +import Data.Either (Either(..)) +import Data.Foldable (toList) +import Data.Functor ((<$>)) +import Data.Function (($), (.)) +import Data.Hashable (Hashable) +import Data.Maybe (Maybe(..)) +import Data.Ord (Ord) +import Data.Sequence (Seq) +import Data.Tuple (fst) +import Text.Show (Show) +import GHC.Generics (Generic) +import qualified Data.Sequence as Seq +import qualified Data.Text.Lazy as TL +import qualified Data.TreeSeq.Strict as TS +import qualified Text.Megaparsec as P + +import Symantic.XML as XML +import Symantic.XML.RelaxNG as RelaxNG + +schema = + namespace Nothing xmlns_commoning <.> + namespace (Just "xsd") "http://www/w3/org/2001/XMLSchema-datatypes" <.> + commoning + +-- * Class 'Commonable' +xmlns_commoning :: Namespace +xmlns_commoning = "2018/commoning.rnc" +elem = element . QName xmlns_commoning +attr n = attribute (QName "" n) text +many0Seq = dimap Seq.fromList toList . many0 + +-- * Type 'Ident' +newtype Ident = Ident TL.Text + deriving (Eq,Ord,Show,Hashable) + +instance RNCText Ident where + rncText_qname = QName xmlns_xsd "id" +instance EncodeText Ident where + encodeText (Ident t) = t +instance DecodeText Ident where + decodeText = Ident . fst <$> P.match (P.many P.anySingle) + +-- * Type 'Name' +newtype Name = Name TL.Text + deriving (Eq,Ord,Show,Hashable) +instance RNCText Name where + rncText_qname = rncText_qname @TL.Text + rncText_params = rncText_params @TL.Text + +instance EncodeText Name where + encodeText (Name t) = t +instance DecodeText Name where + decodeText = Name . fst <$> P.match (P.many P.anySingle) + +-- * Type 'Commoning' +data Commoning + = Commoning + { commoning_persons :: Persons + , commoning_opinions :: Opinions + , commoning_groups :: Groups + , commoning_operations :: Operations + , commoning_resources :: Resources + } deriving (Show, Generic) + +commoning = + define "commoning" $ + elem "commoning" $ + adt @Commoning $ + permutable $ + persons <&> + opinions <&> + groups <&> + operations <&> + perm resources + +-- ** Type 'Person' +data Person + = Person + { person_id :: Ident + , person_fields :: Seq Fields + } deriving (Show, Generic) + +person = + define "person" $ + adt @Person $ + elem "person" $ + attr "id" <:> + many0Seq fields + +-- *** Type 'Persons' +type Persons = [Person] + +persons = + define "persons" $ + elem "persons" $ + many0 person + +-- * Type 'Opinions' +type Opinions = [Grades] + +opinions = + define "opinions" $ + elem "opinions" $ + many0 grades + +-- ** Type 'Grade' +data Grade + = Grade + { grade_name :: Name + , grade_abbrev :: Maybe Name + , grade_color :: Maybe Color + } deriving (Show, Generic) + +grade = + define "grade" $ + elem "grade" $ + adt @Grade $ + attr "name" <:> + optional (attr "abbrev") <:> + optional (attr "color") + +-- *** Type 'Color' +type Color = TL.Text + +-- *** Type 'Grades' +data Grades + = Grades + { grades_id :: Ident + , grades_name :: Maybe Name + , grades_list :: [Grade] + } deriving (Show, Generic) + +grades = + define "grades" $ + elem "grades" $ + adt @Grades $ + attr "id" <:> + optional (attr "name") <:> + many0 grade + +-- ** Type 'Field' +data Field + = Field + { field_name :: Name + , field_value :: TL.Text + } deriving (Show, Generic) + +-- *** Type 'Fields' +type Fields = TS.Tree NodeField + +-- **** Type 'NodeField' +data NodeField + = NodeField Field + | NodeFields { fields_name :: Name } + deriving (Show, Generic) + +fields = + define "fields" $ + elem "fields" $ + adt @(TS.Tree NodeField) $ + (dimap NodeFields fields_name $ + attr "name") + <:> + many0Seq ( + dimap + (\case + Left f -> TS.tree0 $ NodeField f + Right fs -> fs) + (\case + TS.Tree (NodeField f) _ -> Left f + fs -> Right fs) $ + field + <+> + fields + ) + +field = + define "field" $ + elem "field" $ + adt @Field $ + attr "name" <:> + text + +-- ** Type 'Group' +type Group = TS.Tree NodeGroup + +-- *** Type 'NodeGroup' +data NodeGroup + = NodeGroup + { group_id :: Ident + , group_name :: Maybe Name + , group_fields :: Seq Fields + , group_members :: Members + } deriving (Show, Generic) + +-- *** Type 'Groups' +type Groups = Seq Group + +groups = + define "groups" $ + elem "groups" $ + many0Seq group + +group = + define "group" $ + elem "group" $ + adt @(TS.Tree NodeGroup) $ + (adt @NodeGroup $ + attr "id" <:> + optional (attr "name") <:> + many0Seq fields <:> + members + ) <:> + many0Seq group + +-- ** Type 'Member' +newtype Member + = Member + { member_person :: Ident + } deriving (Show, Generic) + +-- *** Type 'Members' +type Members = [Member] + +members = define "members" $ many0 member +member = + define "member" $ + elem "member" $ + adt @Member $ + attr "person" + +-- ** Type 'Operation' +type Operation = TS.Tree NodeOperation +-- *** Type 'NodeOperation' +newtype NodeOperation + = NodeOperation + { operation_id :: Ident + } deriving (Show, Generic) +-- *** Type 'Operations' +type Operations = Seq Operation + +operations = + define "operations" $ + elem "operations" $ + many0Seq operation + +operation = + define "operation" $ + elem "operation" $ + adt @(TS.Tree NodeOperation) $ + (adt $ attr "id") <:> + many0Seq operation + +-- ** Type 'Resource' +type Resource = TS.Tree NodeResource +-- *** Type 'NodeResource' +data NodeResource + = NodeResource + { resource_name :: Name + , resource_policies :: Policies + } deriving (Show, Generic) + +-- *** Type 'Resources' +type Resources = Seq Resource + +resources = + define "resources" $ + elem "resources" $ + many0Seq resource + +resource = + define "resource" $ + elem "resource" $ + adt @(TS.Tree NodeResource) $ + (adt $ attr "name" <:> many0 policy) <:> + many0Seq resource + +-- ** Type 'Policy' +data Policy + = Policy + { policy_operation :: Name + , policy_by :: Ident + , policy_toward :: Maybe Ident + , policy_rules :: Rules + } deriving (Show, Generic) + +policy = + define "policy" $ + adt @Policy $ + elem "policy" $ + attr "operation" <:> + attr "by" <:> + optional (attr "toward") <:> + many0 rule + +-- *** Type 'Policies' +type Policies = [Policy] + +-- ** Type 'Rule' +data Rule + = Rule + { rule_grades :: Ident + , rule_gradeRange :: GradeRange + } deriving (Show, Generic) + +rule = + define "rule" $ + adt @Rule $ + elem "rule" $ + attr "grades" <:> + gradeRange + +-- *** Type 'Rules' +type Rules = [Rule] + +-- *** Type 'GradeRange' +data GradeRange + = GradeRange_Single Name + | GradeRange_Min Name + | GradeRange_Max Name + | GradeRange Name Name + deriving (Show, Generic) + +gradeRange = + define "gradeRange" $ + adt @GradeRange $ + attr "grade" <+> + attr "gradeMin" <+> + attr "gradeMax" <+> ( + attr "gradeMin" <:> + attr "gradeMax" + ) + +{- +rule = define "rule" $ + element "rule" attrs + where + attrs + = attrsGrade + <+> attrsGradeMin + <+> attrsGradeMax + attrsGrade = + permutable $ + Rule + <$> attribute "grades" ident + <*> (GradeRange_Single <$> attribute "grade" name) + attrsGradeMin = + permutable $ + (\gs gMin mgMax -> Rule gs $ case mgMax of + Nothing -> GradeRange_Min gMin + Just gMax -> GradeRange gMin gMax) + <$> attribute "grades" ident + <*> attribute "gradeMin" name + <*> optionalPerm (attribute "gradeMax" name) + attrsGradeMax = + permutable $ + (\gs mgMin gMax -> Rule gs $ case mgMin of + Nothing -> GradeRange_Max gMax + Just gMin -> GradeRange gMin gMax) + <$> attribute "grades" ident + <*> optionalPerm (attribute "gradeMin" name) + <*> attribute "gradeMax" name +-} diff --git a/test/RelaxNG/Whatever.hs b/test/RelaxNG/Whatever.hs new file mode 100644 --- /dev/null +++ b/test/RelaxNG/Whatever.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module RelaxNG.Whatever where + +import Data.Function (($), (.)) +import Data.Maybe (Maybe(..)) +import Text.Show (Show) +import GHC.Generics (Generic) +import qualified Data.Text.Lazy as TL + +import Symantic.XML as XML +import Symantic.XML.RelaxNG as RelaxNG + +schema = + namespace Nothing xmlns_whatever <.> + namespace (Just "xsd") "http://www/w3/org/2001/XMLSchema-datatypes" <.> + whatever + +xmlns_whatever :: Namespace +xmlns_whatever = "2020/whatever.rnc" +elem = element . QName xmlns_whatever +attr n = attribute (QName "" n) text + +newtype Whatever + = Whatever + { whatever_a :: TL.Text + } deriving (Generic, Show) +whatever = + define "root" $ + adt @Whatever $ + elem "root" $ + namespace Nothing xmlns_whatever <.> + namespace (Just "whatever") xmlns_whatever <.> + attr "a" <.> + elem "child" ( + namespace (Just "what") xmlns_whatever <.> + elem "sub-child" ( + namespace Nothing xmlns_empty <.> + empty + ) + )