]> Git — Sourcephile - haskell/symantic-xml.git/blob - Language/Symantic/RNC/Validate.hs
RNC: fix Permutation: many -> some.
[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(..), Alternative(..), optional)
11 import Control.Monad (Monad(..))
12 import Data.Bool
13 import Data.Either (Either(..))
14 import Data.Eq (Eq(..))
15 import Data.Foldable (Foldable(..), all)
16 import Data.Function (($), const, id)
17 import Data.Functor (Functor(..), (<$>))
18 import Data.Maybe (Maybe(..), maybe)
19 import Data.Monoid (Monoid(..))
20 import Data.Ord (Ord(..))
21 import Data.Semigroup (Semigroup(..))
22 import Data.Tuple (snd)
23 import Prelude (error)
24 import Data.Sequence (Seq)
25 import qualified Data.Char as Char
26 import qualified Data.List.NonEmpty as NonEmpty
27 import qualified Data.Sequence as Seq
28 import qualified Data.Set as Set
29 import qualified Data.Text.Lazy as TL
30 import qualified Text.Megaparsec as P
31
32 import Language.Symantic.XML (XMLs)
33 import qualified Language.Symantic.XML as XML
34 import qualified Language.Symantic.RNC.Sym as RNC
35
36 validateXML ::
37 Ord e => P.Parsec e (XMLs src) a -> XMLs src ->
38 Either (P.ParseErrorBundle (XMLs src) e) a
39 validateXML p stateInput =
40 snd $
41 P.runParser' p P.State
42 { P.stateInput
43 , P.stateOffset = 0
44 , P.statePosState = error "[BUG] validateXML: getSourcePos is not helpful here, please use annotated source locations"
45 -- NOTE: reporting the node number is less helpful
46 -- than the source text line and number where the node is;
47 -- P.statePosState is only used by P.getSourcePos.
48 }
49
50 instance
51 ( Ord err
52 , Ord src
53 , XML.NoSource src
54 , P.Stream (Seq (XML.XML src))
55 , P.Token (Seq (XML.XML src)) ~ XML.Tree (XML.Sourced src XML.Node)
56 ) => RNC.Sym_RNC (P.Parsec err (XMLs src)) where
57 {-
58 none = P.label "none" $ P.eof
59 -}
60 namespace _p _n = pure ()
61 element n p = do
62 ts <- P.token check $ Set.singleton $ P.Tokens $ pure expected
63 p_XMLs p ts
64 where
65 expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty
66 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
67 | e == n
68 = Just $ removePI $ removeXMLNS $ removeSpaces ts
69 where
70 removePI xs =
71 (`Seq.filter` xs) $ \case
72 XML.Tree (XML.unSourced -> XML.NodePI{}) _ts -> False
73 _ -> True
74 removeSpaces xs =
75 if (`all` xs) $ \case
76 XML.Tree (XML.unSourced -> XML.NodeText (XML.EscapedText et)) _ts ->
77 all (\case
78 XML.EscapedPlain t -> TL.all Char.isSpace t
79 _ -> False) et
80 _ -> True
81 then (`Seq.filter` xs) $ \case
82 XML.Tree (XML.unSourced -> XML.NodeText{}) _ts -> False
83 _ -> True
84 else xs
85 removeXMLNS xs =
86 let (attrs,rest) = (`Seq.spanl` xs) $ \case
87 XML.Tree (XML.unSourced -> XML.NodeAttr{}) _ts -> True
88 _ -> False in
89 let attrs' = (`Seq.filter` attrs) $ \case
90 XML.Tree (XML.unSourced -> XML.NodeAttr a) _ts ->
91 case a of
92 XML.QName "" "xmlns" -> False
93 XML.QName ns _l -> ns /= XML.xmlns_xmlns
94 _ -> True in
95 attrs' <> rest
96 check _t = Nothing
97 attribute n p = do
98 v <- P.token check $ Set.singleton $ P.Tokens $ pure expected
99 p_XMLs p v
100 where
101 expected = XML.Tree0 (XML.notSourced $ XML.NodeAttr n)
102 check (XML.Tree (XML.unSourced -> XML.NodeAttr k)
103 v@(toList -> [XML.Tree0 (XML.unSourced -> XML.NodeText _v)])) | k == n =
104 Just v
105 check _t = Nothing
106 any = P.label "any" $
107 P.token (const $ Just ()) Set.empty
108 anyElem ns p = P.label "anyElem" $ do
109 (n,ts) <- P.token check $ Set.singleton $ P.Tokens $ pure expected
110 p_XMLs (p $ XML.qNameLocal n) ts
111 where
112 expected = XML.Tree (XML.notSourced $ XML.NodeElem $ XML.QName ns $ XML.NCName "*") mempty
113 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
114 | XML.qNameSpace e == ns
115 = Just $ (e,ts)
116 check _t = Nothing
117 {-
118 comment = do
119 s <- P.getInput
120 case Seq.viewl s of
121 XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do
122 P.setInput ts
123 c <$ XML.setFilePosToNextNode
124 t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
125 EmptyL -> P.failure Nothing ex
126 where
127 ex = Set.singleton $ P.Tokens $ pure expected
128 expected = XML.Tree0 (XML.notSourced $ XML.NodeComment "")
129 -}
130 escapedText = do
131 P.token check $ Set.singleton $ P.Tokens $ pure expected
132 where
133 expected = XML.Tree0 (XML.notSourced $ XML.NodeText $ XML.EscapedText mempty)
134 check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Just t
135 check _t = Nothing
136 optional = P.optional
137 option = P.option
138 choice = P.choice
139 try = P.try
140 fail = P.label "fail" $ P.failure Nothing mempty
141
142 -- | @p_XMLs p xs@ returns a parser parsing @xs@ entirely with @p@,
143 -- updating 'P.stateOffset' and re-raising any exception.
144 p_XMLs ::
145 Ord err => Ord src =>
146 P.Stream (Seq (XML.XML src)) =>
147 P.Parsec err (XMLs src) a -> XMLs src -> P.Parsec err (XMLs src) a
148 p_XMLs p stateInput = do
149 st <- P.getParserState
150 let (st', res) = P.runParser' (p <* P.eof) st
151 { P.stateInput = stateInput
152 , P.stateOffset = P.stateOffset st
153 }
154 P.updateParserState (\s -> s{P.stateOffset = P.stateOffset st'})
155 case res of
156 Right a -> return a
157 Left (P.ParseErrorBundle errs _) ->
158 case NonEmpty.head errs of
159 P.TrivialError _o us es -> P.failure us es
160 P.FancyError _o es -> P.fancyFailure es
161
162 -- | Whether the given 'XML.Node' must be ignored by the RNC parser.
163 isIgnoredNode :: XML.Node -> Bool
164 isIgnoredNode = \case
165 XML.NodeComment{} -> True
166 XML.NodePI{} -> True
167 XML.NodeCDATA{} -> True
168 _ -> False
169
170 instance
171 ( Ord err
172 , Ord src
173 , P.Stream (Seq (XML.XML src))
174 ) => RNC.Sym_Permutation (P.ParsecT err (XMLs src) m) where
175 runPermutation (Perm value parser) = optional parser >>= f
176 where
177 -- NOTE: copy Control.Applicative.Permutations.runPermutation
178 -- to replace the commented empty below so that P.TrivialError
179 -- has the unexpected token.
180 f Nothing = maybe {-empty-}(P.token (const Nothing) Set.empty) pure value
181 f (Just p) = RNC.runPermutation p
182 toPermutation p = Perm Nothing $ pure <$> p
183 toPermutationWithDefault v p = Perm (Just v) $ pure <$> p
184
185 -- | Unprivatized 'Control.Applicative.Permutations.Permutation' to fix 'runPermutation'.
186 -- so that the 'P.TrivialError' has an unexpected token
187 -- which is an 'XML.Node' containing a 'XML.FileSource' useful when reporting errors.
188 data Perm m a = Perm (Maybe a) (m (Perm m a))
189 type instance RNC.Permutation (P.ParsecT err (XMLs src) m) = Perm (P.ParsecT err (XMLs src) m)
190 instance Functor m => Functor (Perm m) where
191 fmap f (Perm v p) = Perm (f <$> v) (fmap f <$> p)
192 instance Alternative m => Applicative (Perm m) where
193 pure value = Perm (Just value) empty
194 lhs@(Perm f v) <*> rhs@(Perm g w) = Perm (f <*> g) (lhsAlt <|> rhsAlt)
195 where
196 lhsAlt = (<*> rhs) <$> v
197 rhsAlt = (lhs <*>) <$> w
198
199 instance
200 ( Ord err
201 , Ord src
202 , P.Stream (Seq (XML.XML src))
203 ) => RNC.Sym_Rule (P.ParsecT err (XMLs src) m) where
204 -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
205 rule _n = id
206 arg _n = pure ()