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 txt) _ts ->
  79                                         all (\case
  80                                          XML.EscapedPlain t -> TL.all Char.isSpace t
  81                                          _ -> False) txt
  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 [])
 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