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 Control.Monad (Monad(..))
  12 import Data.Bool
  13 import Data.Default.Class (Default(..))
  14 import Data.Either (Either(..))
  15 import Data.Eq (Eq(..))
  16 import Data.Foldable (Foldable(..), all)
  17 import Data.Function (($), (.), const, id)
  18 import Data.Functor ((<$>), (<$))
  19 import Data.Int (Int)
  20 import Data.List.NonEmpty (NonEmpty(..))
  21 import Data.Maybe (Maybe(..), maybe)
  22 import Data.Monoid (Monoid(..), First(..))
  23 import Data.Ord (Ord(..))
  24 import Data.Proxy (Proxy(..))
  25 import Data.Ratio ((%))
  26 import Data.Semigroup (Semigroup(..))
  27 import Data.Sequence (ViewL(..), (|>))
  28 import Data.String (String)
  29 import Data.Tuple (fst, snd)
  30 import Text.Read (readMaybe, Read(..))
  31 import Text.Show (Show(..))
  32 import qualified Control.Monad.Trans.State as S
  33 import qualified Data.Char as Char
  34 import qualified Data.List as List
  35 import qualified Data.Map.Strict as Map
  36 import qualified Data.Ratio as Ratio
  37 import qualified Data.Sequence as Seq
  38 import qualified Data.Set as Set
  39 import qualified Data.Text.Lazy as TL
  40 import qualified GHC.Read as Read (expectP)
  41 import qualified Text.Megaparsec as P
  42 import qualified Text.Megaparsec.Perm as P
  43 import qualified Text.Read as Read
  44
  45 import           Language.Symantic.XML (XML, XMLs)
  46 import qualified Language.Symantic.XML as XML
  47 import qualified Language.Symantic.RNC.Sym as RNC
  48
  49 validateXML :: Ord e => P.Parsec e XMLs a -> XMLs -> Either (P.ParseError (P.Token XMLs) e) a
  50 validateXML p = XML.runParser p (P.initialPos "":|[])
  51
  52 type instance RNC.Perm (P.ParsecT e XMLs m) = P.PermParser XMLs (P.ParsecT e XMLs m)
  53 instance Ord e => RNC.Sym_Interleaved (P.ParsecT e XMLs m) where
  54         interleaved = P.makePermParser
  55         (<$$>) = (P.<$$>)
  56         (<||>) = (P.<||>)
  57         (<$?>) = (P.<$?>)
  58         (<|?>) = (P.<|?>)
  59         f <$*> a = f P.<$?> ([],P.some a)
  60         f <|*> a = f P.<|?> ([],P.some a)
  61 instance Ord e => RNC.Sym_Rule (P.ParsecT e XMLs m) where
  62         -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
  63         rule _n = id
  64         arg _n = pure ()
  65
  66 -- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
  67 p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
  68 p_satisfyMaybe f = check `P.token` Nothing
  69         where
  70         check c =
  71                 case f c of
  72                  Just a  -> Right a
  73                  Nothing -> Left (Just $ P.Tokens $ c:|[], Set.empty)
  74
  75 instance Ord e => RNC.Sym_RNC (P.Parsec e XMLs) where
  76         {-
  77         none = P.label "none" $ P.eof
  78         -}
  79         namespace _p _n = pure ()
  80         element n p = do
  81                 ts <- P.token check $ Just expected
  82                 parserElement n p ts
  83                 where
  84                 expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty
  85                 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
  86                  | e == n
  87                  = Right $ removePI $ removeXMLNS $ removeSpaces ts
  88                         where
  89                         removePI xs =
  90                                 (`Seq.filter` xs) $ \case
  91                                          XML.Tree (XML.unSourced -> XML.NodePI{}) _ts -> False
  92                                          _ -> True
  93                         removeSpaces xs =
  94                                 if (`all` xs) $ \case
  95                                  XML.Tree (XML.unSourced -> XML.NodeText txt) _ts ->
  96                                         TL.all Char.isSpace txt
  97                                  _ -> True
  98                                  then (`Seq.filter` xs) $ \case
  99                                          XML.Tree (XML.unSourced -> XML.NodeText{}) _ts -> False
 100                                          _ -> True
 101                                  else xs
 102                         removeXMLNS xs =
 103                                 let (attrs,rest) = (`Seq.spanl` xs) $ \case
 104                                          XML.Tree (XML.unSourced -> XML.NodeAttr{}) _ts -> True
 105                                          _ -> False in
 106                                 let attrs' = (`Seq.filter` attrs) $ \case
 107                                          XML.Tree (XML.unSourced -> XML.NodeAttr a) _ts ->
 108                                                 case a of
 109                                                  XML.QName "" "xmlns" -> False
 110                                                  XML.QName ns _l -> ns /= XML.xmlns_xmlns
 111                                          _ -> True in
 112                                 attrs' <> rest
 113                 check t = Left
 114                  ( Just $ P.Tokens $ pure t
 115                  , Set.singleton $ P.Tokens $ pure expected )
 116         attribute n p = do
 117                 v <- P.token check $ Just expected
 118                 XML.parser p v
 119                 where
 120                 expected = XML.Tree0 (XML.notSourced $ XML.NodeAttr n)
 121                 check (XML.Tree (XML.unSourced -> XML.NodeAttr k)
 122                       v@(toList -> [XML.Tree0 (XML.unSourced -> XML.NodeText _v)])) | k == n =
 123                         Right v
 124                 check t = Left
 125                  ( Just $ P.Tokens $ pure t
 126                  , Set.singleton $ P.Tokens $ pure expected )
 127         any  = P.label "any" $ p_satisfyMaybe $ const $ Just ()
 128         anyElem ns p = P.label "anyElem" $ do
 129                 (n,ts) <- P.token check $ Just expected
 130                 parserElement n (p $ XML.qNameLocal n) ts
 131                 where
 132                 expected = XML.Tree (XML.notSourced $ XML.NodeElem $ XML.QName ns $ XML.NCName "*") mempty
 133                 check (XML.Tree (XML.unSourced -> XML.NodeElem e) ts)
 134                  | XML.qNameSpace e == ns
 135                  = Right $ (e,ts)
 136                 check t = Left
 137                  ( Just $ P.Tokens $ pure t
 138                  , Set.singleton $ P.Tokens $ pure expected )
 139         {-
 140         comment = do
 141                 s <- P.getInput
 142                 case Seq.viewl s of
 143                  XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do
 144                         P.setInput ts
 145                         c <$ XML.setFilePosToNextNode
 146                  t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
 147                  EmptyL -> P.failure Nothing ex
 148                 where
 149                 ex = Set.singleton $ P.Tokens $ pure expected
 150                 expected = XML.Tree0 (XML.notSourced $ XML.NodeComment "")
 151         -}
 152         text = do
 153                 P.token check (Just expected)
 154                  <* XML.setFilePosToNextNode
 155                 where
 156                 expected = XML.Tree0 (XML.notSourced $ XML.NodeText "")
 157                 check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Right t
 158                 check t = Left
 159                  ( Just $ P.Tokens $ pure t
 160                  , Set.singleton $ P.Tokens $ pure expected )
 161         optional = P.optional
 162         option   = P.option
 163         choice   = P.choice
 164         try      = P.try
 165         fail     = P.label "fail" $ P.failure Nothing mempty
 166
 167 parserElement :: Ord e => XML.QName -> P.Parsec e XMLs a -> XMLs -> P.Parsec e XMLs a
 168 parserElement _n = XML.parser
 169 {-
 170
 171 -- * Type 'State'
 172 data State = State
 173  { state_posXML :: XML.Pos
 174  , state_source :: XML.FileSource
 175    -- ^ Unfortunately Megaparsec's 'P.statePos'
 176    -- is not a good fit to encode 'XML.Source'.
 177  } deriving (Eq,Show)
 178 instance Default State where
 179         def = State
 180          { state_posXML = def
 181          , state_source = def
 182          }
 183
 184 -- * Type 'Parser'
 185 type Parser = S.StateT State (P.Parsec ErrorRead XMLs)
 186
 187 instance RNC.Sym_Rule Parser where
 188         -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
 189         rule _n = id
 190 instance RNC.Sym_RNC Parser where
 191         {-
 192         none = P.label "none" $ P.eof
 193         -}
 194         fail = P.label "fail" $ P.failure Nothing mempty
 195         any  = P.label "any" $ p_satisfyMaybe $ const $ Just ()
 196         anyElem p = P.label "anyElem" $ do
 197                 XML.Sourced state_source (n,ts) <- P.token check $ Just expected
 198                 parserElement n (p n) (XML.Sourced state_source ts)
 199                 where
 200                 expected = XML.Tree (XML.notSourced $ XML.NodeElem "*") mempty
 201                 check (XML.Tree cell@(XML.unSourced -> XML.NodeElem e) ts) = Right $ (e,ts) <$ cell
 202                 check t = Left
 203                  ( Just $ P.Tokens $ pure t
 204                  , Set.singleton $ P.Tokens $ pure expected )
 205         element n p = do
 206                 ts <- P.token check $ Just expected
 207                 parserElement n p ts
 208                 where
 209                 expected = XML.Tree (XML.notSourced $ XML.NodeElem n) mempty
 210                 check (XML.Tree cell@(XML.unSourced -> XML.NodeElem e) ts) | e == n = Right (ts <$ cell)
 211                 check t = Left
 212                  ( Just $ P.Tokens $ pure t
 213                  , Set.singleton $ P.Tokens $ pure expected )
 214         attribute n p = do
 215                 v <- P.token check $ Just expected
 216                 stateParser p $ Seq.singleton $ Tree0 v
 217                 where
 218                 expected = Tree0 (XML.notSourced $ XML.NodeAttr n "")
 219                 check (XML.Tree0 cell@(XML.unSourced -> XML.NodeAttr k v)) | k == n =
 220                         Right $ XML.NodeText v <$ cell
 221                 check t = Left
 222                  ( Just $ P.Tokens $ pure t
 223                  , Set.singleton $ P.Tokens $ pure expected )
 224         {-
 225         comment = do
 226                 s <- P.getInput
 227                 case Seq.viewl s of
 228                  XML.Tree0 (XML.unSourced -> XML.NodeComment c) :< ts -> do
 229                         P.setInput ts
 230                         c <$ setFilePosToNextNode
 231                  t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
 232                  EmptyL -> P.failure Nothing ex
 233                 where
 234                 ex = Set.singleton $ P.Tokens $ pure expected
 235                 expected = Tree0 (XML.notSourced $ XML.NodeComment "")
 236         -}
 237         text = do
 238                 P.token check (Just expected)
 239                  <* setFilePosToNextNode
 240                 where
 241                 expected = Tree0 (XML.notSourced $ XML.NodeText "")
 242                 check (XML.Tree0 (XML.unSourced -> XML.NodeText t)) = Right t
 243                 check t = Left
 244                  ( Just $ P.Tokens $ pure t
 245                  , Set.singleton $ P.Tokens $ pure expected )
 246         optional = P.optional
 247         option   = P.option
 248         choice   = P.choice
 249         try      = P.try
 250
 251 parserElement :: XML.Name -> Parser a -> XML.Sourced XMLs -> Parser a
 252 parserElement n p (XML.Sourced state_source ts) = do
 253         let mayNameOrFigureName
 254                 | n == "aside" = Nothing
 255                 -- NOTE: skip aside.
 256                 | n == "figure"
 257                 -- NOTE: special case renaming the current XML.XmlPos
 258                 -- using the @type attribute to have positions like this:
 259                 --   section1.Quote1
 260                 --   section1.Example1
 261                 --   section1.Quote2
 262                 -- instead of:
 263                 --   section1.figure1
 264                 --   section1.figure2
 265                 --   section1.figure3
 266                 , Just ty <- getFirst $ (`foldMap` ts) $ \case
 267                  XML.Tree0 (XML.unSourced -> XML.NodeAttr "type" ty) -> First $ Just ty
 268                  _ -> First Nothing
 269                 = Just $ XML.qName $ ty
 270                 | otherwise = Just n
 271         case mayNameOrFigureName of
 272          Nothing -> do
 273                 st <- S.get
 274                 S.put st{state_source}
 275                 res <- stateParser p ts
 276                 S.put st
 277                 return res
 278          Just nameOrFigureName -> do
 279                 st@State{state_posXML} <- S.get
 280                 let incrPrecedingSibling name =
 281                         maybe (Nat1 1) succNat1 $
 282                         Map.lookup name $
 283                         XML.pos_precedingSiblings state_posXML
 284                 S.put State
 285                  { state_posXML = state_posXML
 286                          -- NOTE: in children, push current name incremented on ancestors
 287                          -- and reset preceding siblings.
 288                          { XML.pos_precedingSiblings = mempty
 289                          , XML.pos_ancestors = XML.pos_ancestors state_posXML |> (n, incrPrecedingSibling n)
 290                          , XML.pos_ancestorsWithFigureNames =
 291                                 XML.pos_ancestorsWithFigureNames state_posXML |>
 292                                 ( nameOrFigureName
 293                                 , incrPrecedingSibling nameOrFigureName )
 294                          }
 295                  , state_source
 296                  }
 297                 res <- stateParser p ts
 298                 S.put st
 299                  { state_posXML = state_posXML
 300                          -- NOTE: after current, increment current name
 301                          -- and reset ancestors.
 302                          { XML.pos_precedingSiblings =
 303                                 (if n == nameOrFigureName then id
 304                                 else Map.insertWith (const succNat1) nameOrFigureName (Nat1 1)) $
 305                                 Map.insertWith (const succNat1) n (Nat1 1) $
 306                                 XML.pos_precedingSiblings state_posXML
 307                          }
 308                  }
 309                 return res
 310
 311 type instance RNC.Perm Parser = P.PermParser XMLs Parser
 312 instance RNC.Sym_Interleaved Parser where
 313         interleaved = P.makePermParser
 314         (<$$>) = (P.<$$>)
 315         (<||>) = (P.<||>)
 316         (<$?>) = (P.<$?>)
 317         (<|?>) = (P.<|?>)
 318         f <$*> a = f P.<$?> ([],P.some a)
 319         f <|*> a = f P.<|?> ([],P.some a)
 320 {-
 321 instance DTC.Sym_DTC Parser where
 322         positionXML = S.gets state_posXML
 323         locationTCT = S.gets state_source
 324 -}
 325
 326
 327
 328
 329 -- ** Type 'ErrorRead'
 330 data ErrorRead
 331  =   ErrorRead_EndOfInput
 332  |   ErrorRead_Not_Bool TL.Text
 333  |   ErrorRead_Not_Int TL.Text
 334  |   ErrorRead_Not_Nat Int
 335  |   ErrorRead_Not_Nat1 Int
 336  |   ErrorRead_Not_Rational TL.Text
 337  |   ErrorRead_Not_Positive TL.Text
 338  {-     ErrorRead_Unexpected P.sourcePos XML -}
 339  deriving (Eq,Ord,Show)
 340 instance P.ShowErrorComponent ErrorRead where
 341         showErrorComponent = show
 342 -}