]> Git — Sourcephile - haskell/symantic-xml.git/blob - Language/Symantic/RNC/Validate.hs
XML: fix union of EscapedText
[haskell/symantic-xml.git] / Language / Symantic / RNC / Validate.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TypeFamilies #-}
6 {-# LANGUAGE ViewPatterns #-}
7 {-# OPTIONS_GHC -fno-warn-orphans #-}
8 module Language.Symantic.RNC.Validate where
9
10 import Control.Applicative (Applicative(..))
11 import Data.Bool
12 import Data.Either (Either(..))
13 import Data.Eq (Eq(..))
14 import Data.Foldable (Foldable(..), all)
15 import Data.Function (($), const, id)
16 import Data.List.NonEmpty (NonEmpty(..))
17 import Data.Maybe (Maybe(..))
18 import Data.Monoid (Monoid(..))
19 import Data.Ord (Ord(..))
20 import Data.Semigroup (Semigroup(..))
21 import qualified Data.Char as Char
22 import qualified Data.Sequence as Seq
23 import qualified Data.Set as Set
24 import qualified Data.Text.Lazy as TL
25 import qualified Text.Megaparsec as P
26 import qualified Text.Megaparsec.Perm as P
27
28 import Language.Symantic.XML (XMLs)
29 import qualified Language.Symantic.XML as XML
30 import qualified Language.Symantic.RNC.Sym as RNC
31
32 validateXML :: Ord e => P.Parsec e XMLs a -> XMLs -> Either (P.ParseError (P.Token XMLs) e) a
33 validateXML p = XML.runParser p (P.initialPos "":|[])
34
35 type instance RNC.Perm (P.ParsecT e XMLs m) = P.PermParser XMLs (P.ParsecT e XMLs m)
36 instance Ord e => RNC.Sym_Interleaved (P.ParsecT e XMLs m) where
37 interleaved = P.makePermParser
38 (<$$>) = (P.<$$>)
39 (<||>) = (P.<||>)
40 (<$?>) = (P.<$?>)
41 (<|?>) = (P.<|?>)
42 f <$*> a = f P.<$?> ([],P.some a)
43 f <|*> a = f P.<|?> ([],P.some a)
44 instance Ord e => RNC.Sym_Rule (P.ParsecT e XMLs m) where
45 -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
46 rule _n = id
47 arg _n = pure ()
48
49 -- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
50 p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
51 p_satisfyMaybe f = check `P.token` Nothing
52 where
53 check c =
54 case f c of
55 Just a -> Right a
56 Nothing -> Left (Just $ P.Tokens $ c:|[], Set.empty)
57
58 instance Ord e => RNC.Sym_RNC (P.Parsec e XMLs) where
59 {-
60 none = P.label "none" $ P.eof
61 -}
62 namespace _p _n = pure ()
63 element n p = do
64 ts <- P.token check $ Just expected
65 parserElement n p ts
66 where
67 expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty
68 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
69 | e == n
70 = Right $ removePI $ removeXMLNS $ removeSpaces ts
71 where
72 removePI xs =
73 (`Seq.filter` xs) $ \case
74 XML.Tree (XML.unSourced -> XML.NodePI{}) _ts -> False
75 _ -> True
76 removeSpaces xs =
77 if (`all` xs) $ \case
78 XML.Tree (XML.unSourced -> XML.NodeText (XML.EscapedText et)) _ts ->
79 all (\case
80 XML.EscapedPlain t -> TL.all Char.isSpace t
81 _ -> False) et
82 _ -> True
83 then (`Seq.filter` xs) $ \case
84 XML.Tree (XML.unSourced -> XML.NodeText{}) _ts -> False
85 _ -> True
86 else xs
87 removeXMLNS xs =
88 let (attrs,rest) = (`Seq.spanl` xs) $ \case
89 XML.Tree (XML.unSourced -> XML.NodeAttr{}) _ts -> True
90 _ -> False in
91 let attrs' = (`Seq.filter` attrs) $ \case
92 XML.Tree (XML.unSourced -> XML.NodeAttr a) _ts ->
93 case a of
94 XML.QName "" "xmlns" -> False
95 XML.QName ns _l -> ns /= XML.xmlns_xmlns
96 _ -> True in
97 attrs' <> rest
98 check t = Left
99 ( Just $ P.Tokens $ pure t
100 , Set.singleton $ P.Tokens $ pure expected )
101 attribute n p = do
102 v <- P.token check $ Just expected
103 XML.parser p v
104 where
105 expected = XML.Tree0 (XML.notSourced $ XML.NodeAttr n)
106 check (XML.Tree (XML.unSourced -> XML.NodeAttr k)
107 v@(toList -> [XML.Tree0 (XML.unSourced -> XML.NodeText _v)])) | k == n =
108 Right v
109 check t = Left
110 ( Just $ P.Tokens $ pure t
111 , Set.singleton $ P.Tokens $ pure expected )
112 any = P.label "any" $ p_satisfyMaybe $ const $ Just ()
113 anyElem ns p = P.label "anyElem" $ do
114 (n,ts) <- P.token check $ Just expected
115 parserElement n (p $ XML.qNameLocal n) ts
116 where
117 expected = XML.Tree (XML.notSourced $ XML.NodeElem $ XML.QName ns $ XML.NCName "*") mempty
118 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
119 | XML.qNameSpace e == ns
120 = Right $ (e,ts)
121 check t = Left
122 ( Just $ P.Tokens $ pure t
123 , Set.singleton $ P.Tokens $ pure expected )
124 {-
125 comment = do
126 s <- P.getInput
127 case Seq.viewl s of
128 XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do
129 P.setInput ts
130 c <$ XML.setFilePosToNextNode
131 t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
132 EmptyL -> P.failure Nothing ex
133 where
134 ex = Set.singleton $ P.Tokens $ pure expected
135 expected = XML.Tree0 (XML.notSourced $ XML.NodeComment "")
136 -}
137 escapedText = do
138 P.token check (Just expected)
139 <* XML.setFilePosToNextNode
140 where
141 expected = XML.Tree0 (XML.notSourced $ XML.NodeText $ XML.EscapedText mempty)
142 check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Right t
143 check t = Left
144 ( Just $ P.Tokens $ pure t
145 , Set.singleton $ P.Tokens $ pure expected )
146 optional = P.optional
147 option = P.option
148 choice = P.choice
149 try = P.try
150 fail = P.label "fail" $ P.failure Nothing mempty
151
152 parserElement :: Ord e => XML.QName -> P.Parsec e XMLs a -> XMLs -> P.Parsec e XMLs a
153 parserElement _n = XML.parser