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
9 import Control.Applicative (Applicative(..))
10 import Control.Monad (Monad(..))
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
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
36 -- | Whether the given 'XML.Node' must be ignored by the parser.
37 isIgnoredNode :: XML.Node -> Bool
39 XML.NodeComment{} -> True
41 XML.NodeCDATA{} -> True
44 instance P.Stream XMLs where
46 type Tokens XMLs = XMLs
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 =
58 t :< _ -> P.positionAt1 s pos t
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)
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
81 showTree :: XML -> String
82 showTree (XML.Tree a _ts) =
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[["
91 showCell (XML.Sourced path@(XML.FileRange{XML.fileRange_file} :| _) a) f =
92 if null fileRange_file
94 else f a <> foldMap (\p -> "\n in "<>show p) path
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.
101 -- This is needed because the end of a 'FileRange'
102 -- is not necessarily the begin of the next 'FileRange'.
104 -- type Parser = S.StateT State (P.Parsec ErrorRead XMLs)
106 setFilePosToNextNode :: P.MonadParsec e XMLs m => m ()
107 setFilePosToNextNode = do
110 , P.statePos = pos :| _
111 } <- P.getParserState
112 case Seq.viewl inp of
114 t :< _ -> P.setPosition $ P.positionAt1 (Proxy::Proxy XMLs) pos t
116 -- | @runParserT st pos p xs@ runs a 'Parser' @p@ to parse @xs@,
117 -- using state @st@ from position @pos@.
121 P.ParsecT err XMLs m a ->
122 NonEmpty P.SourcePos ->
124 m (Either (P.ParseError (P.Token XMLs) err) a)
125 runParserT p pos inp =
127 P.runParserT' p P.State
130 case Seq.viewl inp of
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
141 -- | Like 'runParser', but using 'Identity' as the inner-monad of 'P.ParsecT'.
144 P.Parsec err XMLs a ->
145 NonEmpty P.SourcePos ->
147 Either (P.ParseError (P.Token XMLs) err) a
148 runParser p pos xs = runIdentity $ runParserT p pos xs
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
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}
161 Left (P.FancyError statePos errs) -> do
162 s <- P.getParserState
163 P.setParserState s{P.statePos}
165 Right a -> a <$ setFilePosToNextNode
167 -- | @stateParser p xs@ returns a stateful parser parsing @xs@ with @p@,
168 -- applying 'setFilePosToNextNode' in case of success.
171 S.StateT st (P.Parsec err XMLs) a ->
173 S.StateT st (P.Parsec err XMLs) a
174 stateParser p xs = do
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}
183 Left (P.FancyError statePos errs) -> do
184 -- NOTE: just re-raising exception.
185 s <- P.getParserState
186 P.setParserState s{P.statePos}
190 a <$ setFilePosToNextNode