]> Git — Sourcephile - haskell/symantic-xml.git/blob - Language/Symantic/RNC/Validate.hs
Upgrade to megaparsec-7
[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 qualified Data.Char as Char
25 import qualified Data.Sequence as Seq
26 import qualified Data.Set as Set
27 import qualified Data.Text.Lazy as TL
28 import qualified Text.Megaparsec as P
29
30 import Language.Symantic.XML (XMLs)
31 import qualified Language.Symantic.XML as XML
32 import qualified Language.Symantic.RNC.Sym as RNC
33
34 validateXML ::
35 Ord e => P.Parsec e XMLs a -> XMLs ->
36 Either (P.ParseErrorBundle XMLs e) a
37 validateXML p stateInput =
38 snd $
39 P.runParser' p P.State
40 { P.stateInput
41 , P.stateOffset = 0
42 , P.statePosState = error "[BUG] validateXML: getSourcePos is not helpful here, please use annotated source locations"
43 -- NOTE: reporting the node number is less helpful
44 -- than the source text line and number where the node is;
45 -- P.statePosState is only used by P.getSourcePos.
46 }
47
48 -- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
49 p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
50 p_satisfyMaybe = (`P.token` Set.empty)
51
52 instance Ord e => RNC.Sym_RNC (P.Parsec e XMLs) where
53 {-
54 none = P.label "none" $ P.eof
55 -}
56 namespace _p _n = pure ()
57 element n p = do
58 ts <- P.token check $ Set.singleton $ P.Tokens $ pure expected
59 XML.subParser p ts
60 where
61 expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty
62 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
63 | e == n
64 = Just $ removePI $ removeXMLNS $ removeSpaces ts
65 where
66 removePI xs =
67 (`Seq.filter` xs) $ \case
68 XML.Tree (XML.unSourced -> XML.NodePI{}) _ts -> False
69 _ -> True
70 removeSpaces xs =
71 if (`all` xs) $ \case
72 XML.Tree (XML.unSourced -> XML.NodeText (XML.EscapedText et)) _ts ->
73 all (\case
74 XML.EscapedPlain t -> TL.all Char.isSpace t
75 _ -> False) et
76 _ -> True
77 then (`Seq.filter` xs) $ \case
78 XML.Tree (XML.unSourced -> XML.NodeText{}) _ts -> False
79 _ -> True
80 else xs
81 removeXMLNS xs =
82 let (attrs,rest) = (`Seq.spanl` xs) $ \case
83 XML.Tree (XML.unSourced -> XML.NodeAttr{}) _ts -> True
84 _ -> False in
85 let attrs' = (`Seq.filter` attrs) $ \case
86 XML.Tree (XML.unSourced -> XML.NodeAttr a) _ts ->
87 case a of
88 XML.QName "" "xmlns" -> False
89 XML.QName ns _l -> ns /= XML.xmlns_xmlns
90 _ -> True in
91 attrs' <> rest
92 check _t = Nothing
93 attribute n p = do
94 v <- P.token check $ Set.singleton $ P.Tokens $ pure expected
95 XML.subParser p v
96 where
97 expected = XML.Tree0 (XML.notSourced $ XML.NodeAttr n)
98 check (XML.Tree (XML.unSourced -> XML.NodeAttr k)
99 v@(toList -> [XML.Tree0 (XML.unSourced -> XML.NodeText _v)])) | k == n =
100 Just v
101 check _t = Nothing
102 any = P.label "any" $ p_satisfyMaybe $ const $ Just ()
103 anyElem ns p = P.label "anyElem" $ do
104 (n,ts) <- P.token check $ Set.singleton $ P.Tokens $ pure expected
105 XML.subParser (p $ XML.qNameLocal n) ts
106 where
107 expected = XML.Tree (XML.notSourced $ XML.NodeElem $ XML.QName ns $ XML.NCName "*") mempty
108 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
109 | XML.qNameSpace e == ns
110 = Just $ (e,ts)
111 check _t = Nothing
112 {-
113 comment = do
114 s <- P.getInput
115 case Seq.viewl s of
116 XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do
117 P.setInput ts
118 c <$ XML.setFilePosToNextNode
119 t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
120 EmptyL -> P.failure Nothing ex
121 where
122 ex = Set.singleton $ P.Tokens $ pure expected
123 expected = XML.Tree0 (XML.notSourced $ XML.NodeComment "")
124 -}
125 escapedText = do
126 P.token check $ Set.singleton $ P.Tokens $ pure expected
127 where
128 expected = XML.Tree0 (XML.notSourced $ XML.NodeText $ XML.EscapedText mempty)
129 check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Just t
130 check _t = Nothing
131 optional = P.optional
132 option = P.option
133 choice = P.choice
134 try = P.try
135 fail = P.label "fail" $ P.failure Nothing mempty
136
137 instance Ord e => RNC.Sym_Permutation (P.ParsecT e XMLs m) where
138 runPermutation (P value parser) = optional parser >>= f
139 where
140 -- NOTE: copy Control.Applicative.Permutations.runPermutation
141 -- to replace the commented empty below so that P.TrivialError
142 -- has the unexpected token.
143 f Nothing = maybe {-empty-}(P.token (const Nothing) Set.empty) pure value
144 f (Just p) = RNC.runPermutation p
145 toPermutation p = P Nothing $ pure <$> p
146 toPermutationWithDefault v p = P (Just v) $ pure <$> p
147
148 -- | Unprivatized 'Control.Applicative.Permutations.Permutation' to fix 'runPermutation'.
149 -- so that the 'P.TrivialError' has an unexpected token
150 -- which is an 'XML.Node' containing a 'XML.FileSource' useful when reporting errors.
151 data Permutation m a = P (Maybe a) (m (Permutation m a))
152 type instance RNC.Permutation (P.ParsecT e XMLs m) = Permutation (P.ParsecT e XMLs m)
153 instance Functor m => Functor (Permutation m) where
154 fmap f (P v p) = P (f <$> v) (fmap f <$> p)
155 instance Alternative m => Applicative (Permutation m) where
156 pure value = P (Just value) empty
157 lhs@(P f v) <*> rhs@(P g w) = P (f <*> g) (lhsAlt <|> rhsAlt)
158 where
159 lhsAlt = (<*> rhs) <$> v
160 rhsAlt = (lhs <*>) <$> w
161
162 instance Ord e => RNC.Sym_Rule (P.ParsecT e XMLs m) where
163 -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
164 rule _n = id
165 arg _n = pure ()