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 -- | Read DTC from TCT.
9 module Hdoc.DTC.Read.TCT where
11 import Control.Applicative (Applicative(..))
12 import Control.Monad (Monad(..))
14 import Data.Default.Class (Default(..))
15 import Data.Either (Either(..))
16 import Data.Eq (Eq(..))
17 import Data.Foldable (Foldable(..))
18 import Data.Function (($), (.), const, id)
19 import Data.Functor ((<$>), (<$))
21 import Data.List.NonEmpty (NonEmpty(..))
22 import Data.Maybe (Maybe(..), maybe)
23 import Data.Monoid (Monoid(..), First(..))
24 import Data.Ord (Ord(..))
25 import Data.Proxy (Proxy(..))
26 import Data.Semigroup (Semigroup(..))
27 import Data.Sequence (ViewL(..), (|>))
28 import Data.String (String)
29 import Data.Tuple (snd)
30 import Prelude (Num(..))
31 import Text.Read (readMaybe)
32 import Text.Show (Show(..))
33 import qualified Control.Monad.Trans.State as S
34 import qualified Data.List as List
35 import qualified Data.Map.Strict as Map
36 import qualified Data.Sequence as Seq
37 import qualified Data.Set as Set
38 import qualified Data.Text.Lazy as TL
39 import qualified Text.Megaparsec as P
40 import qualified Text.Megaparsec.Perm as P
42 import Hdoc.TCT hiding (Parser, ErrorRead)
44 import qualified Hdoc.DTC.Document as DTC
45 import qualified Hdoc.DTC.Sym as DTC
46 import qualified Hdoc.RNC.Sym as RNC
52 -- type Parser = P.Parsec ErrorRead XMLs
53 type Parser = S.StateT State (P.Parsec ErrorRead XMLs)
55 instance RNC.Sym_Rule Parser where
56 -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
58 instance RNC.Sym_RNC Parser where
59 none = P.label "none" $ P.eof
60 fail = P.label "fail" $ P.failure Nothing mempty
61 any = P.label "any" $ p_satisfyMaybe $ const $ Just ()
62 anyElem p = P.label "anyElem" $ do
63 (n,ts) <- P.token check $ Just expected
66 expected = Tree (cell0 $ XmlElem "*") mempty
67 check (Tree (unCell -> XmlElem e) ts) = Right (e,ts)
69 ( Just $ P.Tokens $ pure t
70 , Set.singleton $ P.Tokens $ pure expected )
72 ts <- P.token check $ Just expected
76 -- NOTE: special case renaming the current DTC.Pos
77 -- using the @type attribute to have positions like this:
85 , Just ty <- getFirst $ (`foldMap` ts) $ \case
86 Tree0 (unCell -> XmlAttr "type" ty) -> First $ Just ty
90 let anc name = maybe 1 (+1) $ Map.lookup name $ DTC.posPrecedingsSiblings pos
92 { DTC.posAncestors = DTC.posAncestors pos |> (n,anc n)
93 , DTC.posAncestorsWithFigureNames =
94 DTC.posAncestorsWithFigureNames pos |>
95 (nameOrFigureName,anc nameOrFigureName)
96 , DTC.posPrecedingsSiblings = mempty
98 res <- parserXMLs p ts
100 { DTC.posPrecedingsSiblings=
101 (if n /= nameOrFigureName
102 then Map.insertWith (\_new old -> old + 1) nameOrFigureName 1
104 Map.insertWith (\_new old -> old + 1) n 1 $
105 DTC.posPrecedingsSiblings pos
109 expected = Tree (cell0 $ XmlElem n) mempty
110 check (Tree (unCell -> XmlElem e) ts) | e == n = Right ts
112 ( Just $ P.Tokens $ pure t
113 , Set.singleton $ P.Tokens $ pure expected )
115 v <- P.token check $ Just expected
118 expected = Tree0 (cell0 $ XmlAttr n "")
119 check (Tree0 (Cell sp (XmlAttr k v))) | k == n =
120 Right $ Seq.singleton $ Tree0 $ Cell sp $ XmlText v
122 ( Just $ P.Tokens $ pure t
123 , Set.singleton $ P.Tokens $ pure expected )
127 Tree0 (unCell -> XmlComment c) :< ts -> do
130 t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
131 EmptyL -> P.failure Nothing ex
133 ex = Set.singleton $ P.Tokens $ pure expected
134 expected = Tree0 (cell0 $ XmlComment "")
136 P.token check (Just expected)
139 expected = Tree0 (cell0 $ XmlText "")
140 check (Tree0 (unCell -> XmlText t)) = Right t
142 ( Just $ P.Tokens $ pure t
143 , Set.singleton $ P.Tokens $ pure expected )
144 int = RNC.rule "int" $ RNC.text >>= \t ->
145 case readMaybe (TL.unpack t) of
147 Nothing -> P.fancyFailure $
148 Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Int t
149 nat = RNC.rule "nat" $ RNC.int >>= \i ->
152 else P.fancyFailure $ Set.singleton $
153 P.ErrorCustom $ ErrorRead_Not_Nat i
154 nat1 = RNC.rule "nat1" $ RNC.int >>= \i ->
157 else P.fancyFailure $ Set.singleton $
158 P.ErrorCustom $ ErrorRead_Not_Nat1 i
162 optional = P.optional
166 type instance RNC.Perm Parser = P.PermParser XMLs Parser
167 instance RNC.Sym_Interleaved Parser where
168 interleaved = P.makePermParser
173 f <$*> a = f P.<$?> ([],P.some a)
174 f <|*> a = f P.<|?> ([],P.some a)
175 instance DTC.Sym_DTC Parser where
179 DTC.Sym_DTC Parser =>
181 Either (P.ParseError (P.Token XMLs) ErrorRead) DTC.Document
182 readDTC = parseXMLs def (P.initialPos "") DTC.document
185 DTC.Sym_DTC Parser =>
187 P.SourcePos -> Parser a -> XMLs ->
188 Either (P.ParseError (P.Token XMLs) ErrorRead) a
189 parseXMLs st pos p i =
191 P.runParser' ((`S.evalStateT` st) $ p <* RNC.none)
194 , P.statePos = pure $
196 Tree (Cell (Span{span_begin=bp}:|_) _) _ :< _ ->
197 P.SourcePos "" -- FIXME: put a FilePath
198 (P.mkPos $ pos_line bp)
199 (P.mkPos $ pos_column bp)
201 , P.stateTabWidth = P.pos1
202 , P.stateTokensProcessed = 0
205 -- | @parserXMLs st pos p xs@ returns a 'Parser' parsing @xs@ with @p@ from state @st@.
207 DTC.Sym_DTC Parser =>
208 Parser a -> XMLs -> Parser a
212 case parseXMLs st pos p xs of
213 Left (P.TrivialError (posErr:|_) un ex) -> do
216 Left (P.FancyError (posErr:|_) errs) -> do
219 Right a -> a <$ fixPos
221 -- | Adjust the current 'P.SourcePos'
222 -- to be the begining of the following-sibling 'XML' node
223 -- so that on error 'P.toHints' keeps expected 'P.Token's in the list,
224 -- and thus makes useful error messages.
226 -- This is needed because the end of a 'Cell'
227 -- is not necessarily the begin of the next 'Cell'.
232 , P.statePos = pos :| _
233 } <- P.getParserState
234 case Seq.viewl inp of
236 t :< _ -> P.setPosition $
237 P.positionAt1 (Proxy::Proxy XMLs) pos t
239 instance P.Stream XMLs where
240 type Token XMLs = XML
241 type Tokens XMLs = XMLs
244 Tree (unCell -> XmlComment{}) _ :< ts -> P.take1_ ts
247 positionAt1 _s pos (Tree (Cell (Span{span_begin=Pos l c}:|_) _n) _ts) =
248 P.SourcePos (P.sourceName pos) (P.mkPos l) (P.mkPos c)
249 positionAtN s pos ts =
251 t :< _ -> P.positionAt1 s pos t
253 advance1 _s _indent pos (Tree (Cell (Span{span_end=Pos l c}:|_) _n) _ts) =
254 -- WARNING: the end of a 'Cell' is not necessarily
255 -- the beginning of the next 'Cell'.
256 P.SourcePos (P.sourceName pos) (P.mkPos l) (P.mkPos c)
257 advanceN s = foldl' . P.advance1 s
258 takeN_ n s | n <= 0 = Just (mempty, s)
260 | otherwise = Just (Seq.splitAt n s) -- FIXME: handle XmlComment and XmlInclude
261 tokensToChunk _s = Seq.fromList
262 chunkToTokens _s = toList
263 chunkLength _s = Seq.length
264 takeWhile_ = Seq.spanl
265 instance P.ShowToken XML where
266 showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
268 showTree :: XML -> String
269 showTree (Tree a _ts) =
271 XmlElem n -> "<"<>show n<>">"
272 XmlAttr n _v -> show n<>"="
274 XmlComment _c -> "comment"
276 showCell (Cell path@(Span{span_file} :| _) a) f =
279 else f a <> foldMap (\p -> "\n in "<>show p) path
281 -- ** Type 'ErrorRead'
283 = ErrorRead_EndOfInput
284 | ErrorRead_Not_Int TL.Text
285 | ErrorRead_Not_Nat Int
286 | ErrorRead_Not_Nat1 Int
287 -- | ErrorRead_Unexpected P.sourcePos XML
288 deriving (Eq,Ord,Show)
289 instance P.ShowErrorComponent ErrorRead where
290 showErrorComponent = show