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.TextLexemePlain 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         text = 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
 154 {-
 155
 156 -- * Type 'State'
 157 data State = State
 158  { state_posXML :: XML.Pos
 159  , state_source :: XML.FileSource
 160    -- ^ Unfortunately Megaparsec's 'P.statePos'
 161    -- is not a good fit to encode 'XML.Source'.
 162  } deriving (Eq,Show)
 163 instance Default State where
 164         def = State
 165          { state_posXML = def
 166          , state_source = def
 167          }
 168
 169 -- * Type 'Parser'
 170 type Parser = S.StateT State (P.Parsec ErrorRead XMLs)
 171
 172 instance RNC.Sym_Rule Parser where
 173         -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
 174         rule _n = id
 175 instance RNC.Sym_RNC Parser where
 176         {-
 177         none = P.label "none" $ P.eof
 178         -}
 179         fail = P.label "fail" $ P.failure Nothing mempty
 180         any  = P.label "any" $ p_satisfyMaybe $ const $ Just ()
 181         anyElem p = P.label "anyElem" $ do
 182                 XML.Sourced state_source (n,ts) <- P.token check $ Just expected
 183                 parserElement n (p n) (XML.Sourced state_source ts)
 184                 where
 185                 expected = XML.Tree (XML.notSourced $ XML.NodeElem "*") mempty
 186                 check (XML.Tree cell@(XML.unSourced -> XML.NodeElem e) ts) = Right $ (e,ts) <$ cell
 187                 check t = Left
 188                  ( Just $ P.Tokens $ pure t
 189                  , Set.singleton $ P.Tokens $ pure expected )
 190         element n p = do
 191                 ts <- P.token check $ Just expected
 192                 parserElement n p ts
 193                 where
 194                 expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty
 195                 check (XML.Tree cell@(XML.unSourced -> XML.NodeElem e) ts) | e == n = Right (ts <$ cell)
 196                 check t = Left
 197                  ( Just $ P.Tokens $ pure t
 198                  , Set.singleton $ P.Tokens $ pure expected )
 199         attribute n p = do
 200                 v <- P.token check $ Just expected
 201                 stateParser p $ Seq.singleton $ Tree0 v
 202                 where
 203                 expected = Tree0 (XML.notSourced $ XML.NodeAttr n "")
 204                 check (XML.Tree0 cell@(XML.unSourced -> XML.NodeAttr k v)) | k == n =
 205                         Right $ XML.NodeText v <$ cell
 206                 check t = Left
 207                  ( Just $ P.Tokens $ pure t
 208                  , Set.singleton $ P.Tokens $ pure expected )
 209         {-
 210         comment = do
 211                 s <- P.getInput
 212                 case Seq.viewl s of
 213                  XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do
 214                         P.setInput ts
 215                         c <$ setFilePosToNextNode
 216                  t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
 217                  EmptyL -> P.failure Nothing ex
 218                 where
 219                 ex = Set.singleton $ P.Tokens $ pure expected
 220                 expected = Tree0 (XML.notSourced $ XML.NodeComment "")
 221         -}
 222         text = do
 223                 P.token check (Just expected)
 224                  <* setFilePosToNextNode
 225                 where
 226                 expected = Tree0 (XML.notSourced $ XML.NodeText "")
 227                 check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Right t
 228                 check t = Left
 229                  ( Just $ P.Tokens $ pure t
 230                  , Set.singleton $ P.Tokens $ pure expected )
 231         optional = P.optional
 232         option   = P.option
 233         choice   = P.choice
 234         try      = P.try
 235
 236 parserElement :: XML.Name -> Parser a -> XML.Sourced XMLs -> Parser a
 237 parserElement n p (XML.Sourced state_source ts) = do
 238         let mayNameOrFigureName
 239                 | n == "aside" = Nothing
 240                 -- NOTE: skip aside.
 241                 | n == "figure"
 242                 -- NOTE: special case renaming the current XML.XmlPos
 243                 -- using the @type attribute to have positions like this:
 244                 --   section1.Quote1
 245                 --   section1.Example1
 246                 --   section1.Quote2
 247                 -- instead of:
 248                 --   section1.figure1
 249                 --   section1.figure2
 250                 --   section1.figure3
 251                 , Just ty <- getFirst $ (`foldMap` ts) $ \case
 252                  XML.Tree0 (XML.unSourced -> XML.NodeAttr "type" ty) -> First $ Just ty
 253                  _ -> First Nothing
 254                 = Just $ XML.qName $ ty
 255                 | otherwise = Just n
 256         case mayNameOrFigureName of
 257          Nothing -> do
 258                 st <- S.get
 259                 S.put st{state_source}
 260                 res <- stateParser p ts
 261                 S.put st
 262                 return res
 263          Just nameOrFigureName -> do
 264                 st@State{state_posXML} <- S.get
 265                 let incrPrecedingSibling name =
 266                         maybe (Nat1 1) succNat1 $
 267                         Map.lookup name $
 268                         XML.pos_precedingSiblings state_posXML
 269                 S.put State
 270                  { state_posXML = state_posXML
 271                          -- NOTE: in children, push current name incremented on ancestors
 272                          -- and reset preceding siblings.
 273                          { XML.pos_precedingSiblings = mempty
 274                          , XML.pos_ancestors = XML.pos_ancestors state_posXML |> (n, incrPrecedingSibling n)
 275                          , XML.pos_ancestorsWithFigureNames =
 276                                 XML.pos_ancestorsWithFigureNames state_posXML |>
 277                                 ( nameOrFigureName
 278                                 , incrPrecedingSibling nameOrFigureName )
 279                          }
 280                  , state_source
 281                  }
 282                 res <- stateParser p ts
 283                 S.put st
 284                  { state_posXML = state_posXML
 285                          -- NOTE: after current, increment current name
 286                          -- and reset ancestors.
 287                          { XML.pos_precedingSiblings =
 288                                 (if n == nameOrFigureName then id
 289                                 else Map.insertWith (const succNat1) nameOrFigureName (Nat1 1)) $
 290                                 Map.insertWith (const succNat1) n (Nat1 1) $
 291                                 XML.pos_precedingSiblings state_posXML
 292                          }
 293                  }
 294                 return res
 295
 296 type instance RNC.Perm Parser = P.PermParser XMLs Parser
 297 instance RNC.Sym_Interleaved Parser where
 298         interleaved = P.makePermParser
 299         (<$$>) = (P.<$$>)
 300         (<||>) = (P.<||>)
 301         (<$?>) = (P.<$?>)
 302         (<|?>) = (P.<|?>)
 303         f <$*> a = f P.<$?> ([],P.some a)
 304         f <|*> a = f P.<|?> ([],P.some a)
 305 {-
 306 instance DTC.Sym_DTC Parser where
 307         positionXML = S.gets state_posXML
 308         locationTCT = S.gets state_source
 309 -}
 310
 311
 312
 313
 314 -- ** Type 'ErrorRead'
 315 data ErrorRead
 316  =   ErrorRead_EndOfInput
 317  |   ErrorRead_Not_Bool TL.Text
 318  |   ErrorRead_Not_Int TL.Text
 319  |   ErrorRead_Not_Nat Int
 320  |   ErrorRead_Not_Nat1 Int
 321  |   ErrorRead_Not_Rational TL.Text
 322  |   ErrorRead_Not_Positive TL.Text
 323  {-     ErrorRead_Unexpected P.sourcePos XML -}
 324  deriving (Eq,Ord,Show)
 325 instance P.ShowErrorComponent ErrorRead where
 326         showErrorComponent = show
 327 -}