]> Git — Sourcephile - doclang.git/blob - Language/DTC/Read/TCT.hs
Add Plainify.
[doclang.git] / Language / DTC / Read / TCT.hs
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# LANGUAGE ViewPatterns #-}
8 {-# OPTIONS_GHC -fno-warn-orphans #-}
9 -- | Read DTC from TCT.
10 module Language.DTC.Read.TCT where
11
12 import Control.Applicative (Applicative(..))
13 import Control.Monad (Monad(..))
14 import Data.Bool
15 import Data.Default.Class (Default(..))
16 import Data.Either (Either(..))
17 import Data.Eq (Eq(..))
18 import Data.Foldable (Foldable(..))
19 import Data.Function (($), (.), const, id)
20 import Data.Functor ((<$>), (<$))
21 import Data.Int (Int)
22 import Data.List.NonEmpty (NonEmpty(..))
23 import Data.Maybe (Maybe(..), fromMaybe, maybe)
24 import Data.Monoid (Monoid(..), First(..))
25 import Data.Ord (Ord(..))
26 import Data.Proxy (Proxy(..))
27 import Data.Semigroup (Semigroup(..))
28 import Data.Sequence (ViewL(..), (|>))
29 import Data.String (String)
30 import Data.Text (Text)
31 import Data.Tuple (snd)
32 import Prelude (Num(..))
33 import Text.Read (readMaybe)
34 import Text.Show (Show(..))
35 import qualified Control.Monad.Trans.State as S
36 import qualified Data.List as List
37 import qualified Data.Map.Strict as Map
38 import qualified Data.Sequence as Seq
39 import qualified Data.Set as Set
40 import qualified Data.Text as Text
41 import qualified Text.Megaparsec as P
42 import qualified Text.Megaparsec.Perm as P
43
44 import Language.TCT hiding (Parser)
45 import Language.XML
46 import qualified Language.DTC.Document as DTC
47 import qualified Language.DTC.Sym as DTC
48 import qualified Language.RNC.Sym as RNC
49
50 -- * Type 'State'
51 type State = DTC.Pos
52
53 -- * Type 'Parser'
54 -- type Parser = P.Parsec Error XMLs
55 type Parser = S.StateT State (P.Parsec Error XMLs)
56
57 instance RNC.Sym_Rule Parser where
58 -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
59 rule _n = id
60 instance RNC.Sym_RNC Parser where
61 none = P.label "none" $ P.eof
62 any = P.label "any" $ p_satisfyMaybe $ const $ Just ()
63 anyElem p = P.label "anyElem" $ do
64 (n,ts) <- P.token check $ Just expected
65 parserXMLs (p n) ts
66 where
67 expected = TreeN (cell0 "") mempty
68 check (TreeN (unCell -> n) ts) = Right (n,ts)
69 check t = Left
70 ( Just $ P.Tokens $ pure t
71 , Set.singleton $ P.Tokens $ pure expected )
72 element n p = do
73 ts <- P.token check $ Just expected
74 xp <- S.get
75 let nameOrFigureName
76 | n == "figure"
77 -- NOTE: special case renaming the current DTC.Pos
78 -- using the @type attribute to have positions like this:
79 -- section1.Quote1
80 -- section1.Example1
81 -- section1.Quote2
82 -- instead of:
83 -- section1.figure1
84 -- section1.figure2
85 -- section1.figure3
86 , Just ty <- getFirst $ (`foldMap` ts) $ \case
87 Tree0 (unCell -> XmlAttr "type" ty) -> First $ Just ty
88 _ -> First Nothing
89 = xmlLocalName $ ty
90 | otherwise = n
91 let anc name = maybe 1 (+1) $ Map.lookup name $ DTC.posPrecedingsSiblings xp
92 S.put xp
93 { DTC.posAncestors = DTC.posAncestors xp |> (n,anc n)
94 , DTC.posAncestorsWithFigureNames =
95 DTC.posAncestorsWithFigureNames xp |>
96 (nameOrFigureName,anc nameOrFigureName)
97 , DTC.posPrecedingsSiblings = mempty
98 }
99 parserXMLs p ts <* S.put xp
100 { DTC.posPrecedingsSiblings=
101 (if n /= nameOrFigureName
102 then Map.insertWith (\_new old -> old + 1) nameOrFigureName 1
103 else id) $
104 Map.insertWith (\_new old -> old + 1) n 1 $
105 DTC.posPrecedingsSiblings xp
106 }
107 where
108 expected = TreeN (cell0 n) mempty
109 check (TreeN (unCell -> e) ts) | e == n = Right ts
110 check t = Left
111 ( Just $ P.Tokens $ pure t
112 , Set.singleton $ P.Tokens $ pure expected )
113 attribute n p = do
114 v <- P.token check $ Just expected
115 parserXMLs p v
116 where
117 expected = Tree0 (cell0 $ XmlAttr n "")
118 check (TreeN (unCell -> e) ts) | e == n = Right ts
119 check (Tree0 (Cell bp ep (XmlAttr k v))) | k == n =
120 Right $ Seq.singleton $ Tree0 $ Cell bp ep $ XmlText v
121 check t = Left
122 ( Just $ P.Tokens $ pure t
123 , Set.singleton $ P.Tokens $ pure expected )
124 comment = do
125 s <- P.getInput
126 case Seq.viewl s of
127 Tree0 (unCell -> XmlComment c) :< ts -> do
128 P.setInput ts
129 c <$ fixPos
130 t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
131 EmptyL -> P.failure Nothing ex
132 where
133 ex = Set.singleton $ P.Tokens $ pure expected
134 expected = Tree0 (cell0 $ XmlComment "")
135 text = do
136 P.token check (Just expected)
137 <* fixPos
138 where
139 expected = Tree0 (cell0 $ XmlText "")
140 check (Tree0 (unCell -> XmlText t)) = Right t
141 check t = Left
142 ( Just $ P.Tokens $ pure t
143 , Set.singleton $ P.Tokens $ pure expected )
144 int = RNC.rule "int" $ RNC.text >>= \t ->
145 case readMaybe (Text.unpack t) of
146 Just i -> return i
147 Nothing -> P.fancyFailure $
148 Set.singleton $ P.ErrorCustom $ Error_Not_Int t
149 nat = RNC.rule "nat" $ RNC.int >>= \i ->
150 if i >= 0
151 then return $ Nat i
152 else P.fancyFailure $ Set.singleton $
153 P.ErrorCustom $ Error_Not_Nat i
154 nat1 = RNC.rule "nat1" $ RNC.int >>= \i ->
155 if i > 0
156 then return $ Nat1 i
157 else P.fancyFailure $ Set.singleton $
158 P.ErrorCustom $ Error_Not_Nat1 i
159 (<|>) = (P.<|>)
160 many = P.many
161 some = P.some
162 optional = P.optional
163 option = P.option
164 choice = P.choice
165 try = P.try
166 type instance RNC.Perm Parser = P.PermParser XMLs Parser
167 instance RNC.Sym_Interleaved Parser where
168 interleaved = P.makePermParser
169 (<$$>) = (P.<$$>)
170 (<||>) = (P.<||>)
171 (<$?>) = (P.<$?>)
172 (<|?>) = (P.<|?>)
173 f <$*> a = f P.<$?> ([],P.some a)
174 f <|*> a = f P.<|?> ([],P.some a)
175 instance DTC.Sym_DTC Parser where
176 position = S.get
177
178 readDTC ::
179 DTC.Sym_DTC Parser =>
180 XMLs ->
181 Either (P.ParseError (P.Token XMLs) Error) DTC.Document
182 readDTC = parseXMLs def (P.initialPos "") DTC.document
183
184 parseXMLs ::
185 DTC.Sym_DTC Parser =>
186 State ->
187 P.SourcePos -> Parser a -> XMLs ->
188 Either (P.ParseError (P.Token XMLs) Error) a
189 parseXMLs st pos p i =
190 snd $
191 P.runParser' ((`S.evalStateT` st) $ p <* RNC.none)
192 P.State
193 { P.stateInput = i
194 , P.statePos = pure $
195 case Seq.viewl i of
196 Tree0 c :< _ -> sourcePosCell c
197 TreeN c _ :< _ -> sourcePosCell c
198 _ -> pos
199 , P.stateTabWidth = P.pos1
200 , P.stateTokensProcessed = 0
201 }
202
203 -- | @parserXMLs st pos p xs@ returns a 'Parser' parsing @xs@ with @p@ from state @st@.
204 parserXMLs ::
205 DTC.Sym_DTC Parser =>
206 Parser a -> XMLs -> Parser a
207 parserXMLs p xs = do
208 pos <- P.getPosition
209 st <- S.get
210 case parseXMLs st pos p xs of
211 Left (P.TrivialError (posErr:|_) un ex) -> do
212 P.setPosition posErr
213 P.failure un ex
214 Left (P.FancyError (posErr:|_) errs) -> do
215 P.setPosition posErr
216 P.fancyFailure errs
217 Right a -> a <$ fixPos
218
219 -- | Adjust the current 'P.SourcePos'
220 -- to be the begining of the following-sibling 'XML' node
221 -- so that on error 'P.toHints' keeps expected 'P.Token's in the list,
222 -- and thus makes useful error messages.
223 --
224 -- This is needed because the end of a 'Cell'
225 -- is not necessarily the begin of the next 'Cell'.
226 fixPos :: Parser ()
227 fixPos = do
228 P.State
229 { P.stateInput = inp
230 , P.statePos = pos :| _
231 } <- P.getParserState
232 case Seq.viewl inp of
233 EmptyL -> return ()
234 t :< _ -> P.setPosition $
235 P.positionAt1 (Proxy::Proxy XMLs) pos t
236
237 sourcePosCell :: Cell a -> P.SourcePos
238 sourcePosCell c =
239 P.SourcePos ""
240 (P.mkPos $ lineCell c)
241 (P.mkPos $ columnCell c)
242
243 sourcePos :: Pos -> Maybe P.SourcePos
244 sourcePos (Pos l c) | l>0 && c>0 = Just $ P.SourcePos "" (P.mkPos l) (P.mkPos c)
245 sourcePos _ = Nothing
246
247 instance P.Stream XMLs where
248 type Token XMLs = XML
249 type Tokens XMLs = XMLs
250 take1_ s =
251 case Seq.viewl s of
252 Tree0 (unCell -> XmlComment{}) :< ts -> P.take1_ ts
253 t:<ts -> Just (t,ts)
254 EmptyL -> Nothing
255 positionAt1 _s pos t =
256 fromMaybe pos $ sourcePos $
257 case t of
258 TreeN c _ -> posCell c
259 Tree0 c -> posCell c
260 positionAtN s pos ts =
261 case Seq.viewl ts of
262 t :< _ -> P.positionAt1 s pos t
263 _ -> pos
264 advance1 _s _indent pos t =
265 -- WARNING: the end of a 'Cell' is not necessarily
266 -- the beginning of the next 'Cell'.
267 fromMaybe pos $ sourcePos $
268 case t of
269 TreeN c _ -> posEndCell c
270 Tree0 c -> posEndCell c
271 advanceN s = foldl' . P.advance1 s
272 takeN_ n s
273 | n <= 0 = Just (mempty, s)
274 | null s = Nothing
275 | otherwise = Just (Seq.splitAt n s) -- FIXME: handle XmlComment
276 tokensToChunk _s = Seq.fromList
277 chunkToTokens _s = toList
278 chunkLength _s = Seq.length
279 takeWhile_ = Seq.spanl
280 instance P.ShowToken XML where
281 showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
282 where
283 showTree :: XML -> String
284 showTree = \case
285 Tree0 c -> showCell c showXmlLeaf
286 TreeN c _ts -> showCell c showXmlName
287
288 showCell (Cell (Pos 0 0) (Pos 0 0) a) f = f a
289 showCell (Cell bp ep a) f = f a<>" at "<>show bp<>"-"<>show ep
290
291 showXmlLeaf = \case
292 XmlAttr n _v -> show n<>"="
293 XmlText _t -> "text"
294 XmlComment _c -> "comment"
295 showXmlName n = "<"<>show n<>">"
296
297 -- ** Type 'Error'
298 data Error
299 = Error_EndOfInput
300 | Error_Not_Int Text
301 | Error_Not_Nat Int
302 | Error_Not_Nat1 Int
303 -- | Error_Unexpected P.sourcePos XML
304 deriving (Eq,Ord,Show)
305 instance P.ShowErrorComponent Error where
306 showErrorComponent = show