Language/Symantic/XML/Parser.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Language.Symantic.XML.Parser where
   8
   9 import Control.Applicative (Applicative(..))
  10 import Control.Monad (Monad(..))
  11 import Data.Bool
  12 import Data.Either (Either(..))
  13 import Data.Foldable (Foldable(..))
  14 import Data.Function (($), (.))
  15 import Data.Functor ((<$>), (<$))
  16 import Data.Functor.Identity (Identity(..))
  17 import Data.List.NonEmpty (NonEmpty(..))
  18 import Data.Maybe (Maybe(..))
  19 import Data.Monoid (Monoid(..))
  20 import Data.Ord (Ord(..))
  21 import Data.Proxy (Proxy(..))
  22 import Data.Semigroup (Semigroup(..))
  23 import Data.Sequence (ViewL(..))
  24 import Data.String (String)
  25 import Data.Tuple (snd)
  26 import Text.Show (Show(..))
  27 import qualified Control.Monad.Trans.State as S
  28 import qualified Data.List as List
  29 import qualified Data.Sequence as Seq
  30 import qualified Text.Megaparsec as P
  31
  32 import           Language.Symantic.XML.Read.Parser (XML, XMLs)
  33 import qualified Language.Symantic.XML.Document as XML
  34 import qualified Language.Symantic.XML.Read as XML
  35
  36 -- | Whether the given 'XML.Node' must be ignored by the parser.
  37 isIgnoredNode :: XML.Node -> Bool
  38 isIgnoredNode = \case
  39  XML.NodeComment{} -> True
  40  XML.NodePI{}      -> True
  41  XML.NodeCDATA{}   -> True
  42  _ -> False
  43
  44 instance P.Stream XMLs where
  45         type Token  XMLs = XML
  46         type Tokens XMLs = XMLs
  47         take1_ s =
  48                 case Seq.viewl s of
  49                  EmptyL -> Nothing
  50                  t@(XML.Tree XML.Sourced{XML.unSourced=n} _) :< ts
  51                   | isIgnoredNode n -> P.take1_ ts
  52                   | otherwise       -> Just (t, ts)
  53         positionAt1 _s pos (XML.Tree (XML.Sourced (XML.FileRange{XML.fileRange_begin=XML.FilePos l c}:|_) _n) _ts) =
  54                 pos{ P.sourceLine   = P.mkPos l
  55                    , P.sourceColumn = P.mkPos c }
  56         positionAtN s pos ts =
  57                 case Seq.viewl ts of
  58                  t :< _ -> P.positionAt1 s pos t
  59                  EmptyL -> pos
  60         advance1 _s _indent pos (XML.Tree (XML.Sourced (XML.FileRange{XML.fileRange_end=XML.FilePos l c}:|_) _n) _ts) =
  61                 -- WARNING: the end of a 'FileRange' is not necessarily
  62                 -- the beginning of the next 'FileRange'.
  63                 pos{ P.sourceLine   = P.mkPos l
  64                    , P.sourceColumn = P.mkPos c }
  65         advanceN s = foldl' . P.advance1 s
  66         takeN_ n s | n <= 0    = Just (mempty, s)
  67                    | null s    = Nothing
  68                    | otherwise =
  69                 let (ns,rs) = Seq.splitAt n s in
  70                 let (ko,ok) = Seq.partition (isIgnoredNode . XML.unSourced . XML.unTree) ns in
  71                 case P.takeN_ (Seq.length ko) rs of
  72                  Nothing -> Just (ok, rs)
  73                  Just (ns',rs') -> Just (ok<>ns', rs')
  74         tokensToChunk _s = Seq.fromList
  75         chunkToTokens _s = toList
  76         chunkLength _s   = Seq.length
  77         takeWhile_       = Seq.spanl
  78 instance P.ShowToken XML where
  79         showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
  80                 where
  81                 showTree :: XML -> String
  82                 showTree (XML.Tree a _ts) =
  83                         showCell a $ \case
  84                          XML.NodeElem n     -> "<"<>show n
  85                          XML.NodeAttr n     -> show n<>"="
  86                          XML.NodeText _t    -> "text"
  87                          XML.NodeComment _c -> "<!--"
  88                          XML.NodePI n _t    -> "<?"<>show n
  89                          XML.NodeCDATA _t   -> "<[CDATA[["
  90
  91                 showCell (XML.Sourced path@(XML.FileRange{XML.fileRange_file} :| _) a) f =
  92                         if null fileRange_file
  93                         then f a
  94                         else f a <> foldMap (\p -> "\n in "<>show p) path
  95
  96 -- | Adjust the current 'P.SourcePos'
  97 -- to be the begining of the following-sibling 'XML' node
  98 -- so that on error 'P.toHints' keeps expected 'P.Token's in the list,
  99 -- and thus makes useful error messages.
 100 --
 101 -- This is needed because the end of a 'FileRange'
 102 -- is not necessarily the begin of the next 'FileRange'.
 103
 104 -- type Parser = S.StateT State (P.Parsec ErrorRead XMLs)
 105
 106 setFilePosToNextNode :: P.MonadParsec e XMLs m => m ()
 107 setFilePosToNextNode = do
 108         P.State
 109          { P.stateInput = inp
 110          , P.statePos   = pos :| _
 111          } <- P.getParserState
 112         case Seq.viewl inp of
 113          EmptyL -> return ()
 114          t :< _ -> P.setPosition $ P.positionAt1 (Proxy::Proxy XMLs) pos t
 115
 116 -- | @runParserT st pos p xs@ runs a 'Parser' @p@ to parse @xs@,
 117 -- using state @st@ from position @pos@.
 118 runParserT ::
 119  Ord err =>
 120  Monad m =>
 121  P.ParsecT err XMLs m a ->
 122  NonEmpty P.SourcePos ->
 123  XMLs ->
 124  m (Either (P.ParseError (P.Token XMLs) err) a)
 125 runParserT p pos inp =
 126         snd <$>
 127         P.runParserT' p P.State
 128          { P.stateInput = inp
 129          , P.statePos =
 130                 case Seq.viewl inp of
 131                  EmptyL -> pos
 132                  XML.Tree (XML.Sourced ss _) _ :< _ ->
 133                         (<$> ss) $ \XML.FileRange{fileRange_begin=bp, fileRange_file} ->
 134                                 P.SourcePos fileRange_file
 135                                  (P.mkPos $ XML.filePos_line bp)
 136                                  (P.mkPos $ XML.filePos_column bp)
 137          , P.stateTabWidth = P.pos1
 138          , P.stateTokensProcessed = 0
 139          }
 140
 141 -- | Like 'runParser', but using 'Identity' as the inner-monad of 'P.ParsecT'.
 142 runParser ::
 143  Ord err =>
 144  P.Parsec err XMLs a ->
 145  NonEmpty P.SourcePos ->
 146  XMLs ->
 147  Either (P.ParseError (P.Token XMLs) err) a
 148 runParser p pos xs = runIdentity $ runParserT p pos xs
 149
 150 -- | @parser p xs@ returns a parser parsing @xs@ entirely with @p@,
 151 -- applying 'setFilePosToNextNode' in case of success,
 152 -- or resetting 'P.statePos' and re-raising the exception in case of error.
 153 parser :: Ord err => P.Parsec err XMLs a -> XMLs -> P.Parsec err XMLs a
 154 parser p xs = do
 155         P.State{P.statePos=pos} <- P.getParserState
 156         case runParser (p <* P.eof) pos xs of
 157          Left (P.TrivialError statePos un ex) -> do
 158                 s <- P.getParserState
 159                 P.setParserState s{P.statePos}
 160                 P.failure un ex
 161          Left (P.FancyError statePos errs) -> do
 162                 s <- P.getParserState
 163                 P.setParserState s{P.statePos}
 164                 P.fancyFailure errs
 165          Right a -> a <$ setFilePosToNextNode
 166
 167 -- | @stateParser p xs@ returns a stateful parser parsing @xs@ with @p@,
 168 -- applying 'setFilePosToNextNode' in case of success.
 169 stateParser ::
 170  Ord err =>
 171  S.StateT st (P.Parsec err XMLs) a ->
 172  XMLs ->
 173  S.StateT st (P.Parsec err XMLs) a
 174 stateParser p xs = do
 175         st <- S.get
 176         P.State{P.statePos=pos} <- P.getParserState
 177         case runParser (S.runStateT (p <* P.eof) st) pos xs of
 178          Left (P.TrivialError statePos un ex) -> do
 179                 -- NOTE: just re-raising exception.
 180                 s <- P.getParserState
 181                 P.setParserState s{P.statePos}
 182                 P.failure un ex
 183          Left (P.FancyError statePos errs) -> do
 184                 -- NOTE: just re-raising exception.
 185                 s <- P.getParserState
 186                 P.setParserState s{P.statePos}
 187                 P.fancyFailure errs
 188          Right (a, st') -> do
 189                 S.put st'
 190                 a <$ setFilePosToNextNode