]> Git — Sourcephile - doclang.git/blob - Language/TCT/Read/Cell.hs
Fix href= in <toc>.
[doclang.git] / Language / TCT / Read / Cell.hs
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE Rank2Types #-}
5 {-# LANGUAGE TypeFamilies #-}
6 module Language.TCT.Read.Cell where
7
8 import Control.Applicative (Applicative(..))
9 import Control.Monad (Monad(..))
10 import Control.Monad.Trans.Class (MonadTrans(..))
11 import Data.Char (Char)
12 import Data.Either (Either(..))
13 import Data.Eq (Eq)
14 import Data.Function (($))
15 import Data.Functor ((<$>))
16 import Data.List.NonEmpty (NonEmpty(..))
17 import Data.Maybe (Maybe(..))
18 import Data.Ord (Ord)
19 import Data.Proxy (Proxy(..))
20 import Data.Semigroup (Semigroup(..))
21 import Data.String (IsString)
22 import Data.Tuple (snd)
23 import qualified Control.Monad.Trans.Reader as R
24 import qualified Data.Set as Set
25 import qualified Data.Text.Lazy as TL
26 import qualified Text.Megaparsec as P
27
28 import Language.TCT.Cell
29
30 -- * Type 'Parser'
31 -- | Convenient alias.
32 type Parser e s a =
33 Parsable e s a =>
34 P.ParsecT e s (R.Reader [Span]) a
35
36 -- ** Type 'Parsable'
37 type Parsable e s a =
38 ( P.Stream s
39 , P.Token s ~ Char
40 , Ord e
41 , IsString (P.Tokens s)
42 , P.ShowErrorComponent e
43 )
44
45 -- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
46 p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
47 p_satisfyMaybe f = check `P.token` Nothing
48 where
49 check c =
50 case f c of
51 Just a -> Right a
52 Nothing -> Left (Just $ P.Tokens $ c:|[], Set.empty)
53
54 p_Position :: Parser e s Pos
55 p_Position = do
56 pos :| _ <- P.statePos <$> P.getParserState
57 return $ Pos (P.unPos $ P.sourceLine pos) (P.unPos $ P.sourceColumn pos)
58
59 p_Cell :: Parser e s a -> Parser e s (Cell a)
60 p_Cell pa = do
61 path <- lift R.ask
62 b :| _ <- P.statePos <$> P.getParserState
63 a <- pa
64 span_end <- p_Position
65 let span_begin = Pos (P.unPos $ P.sourceLine b) (P.unPos $ P.sourceColumn b)
66 let span = Span {span_file=P.sourceName b, span_begin, span_end}
67 return $ Cell (span:|path) a
68
69 -- | Wrapper around |P.runParser'|
70 -- to use given 'Cell' as starting position.
71 runParserOnCell ::
72 Parsable e StreamCell a =>
73 Parser e StreamCell a ->
74 Cell TL.Text ->
75 Either (P.ParseError (P.Token StreamCell) e) a
76 runParserOnCell p (Cell (Span inp bp _ep :| path) s) =
77 snd $
78 (`R.runReader` path) $
79 P.runParserT' (p <* P.eof)
80 P.State
81 { P.stateInput = StreamCell s
82 , P.statePos = pure $ P.SourcePos inp (P.mkPos $ pos_line bp) indent
83 , P.stateTabWidth = indent
84 , P.stateTokensProcessed = 0
85 }
86 where indent = P.mkPos $ pos_column bp
87
88 -- * Type 'StreamCell'
89 -- | Wrap 'TL.Text' to have a 'P.Stream' instance
90 -- whose 'P.advance1' method abuses the tab width state
91 -- to instead pass the line indent.
92 -- This in order to report correct 'P.SourcePos'
93 -- when parsing a 'Cell' containing newlines.
94 newtype StreamCell = StreamCell { unStreamCell :: TL.Text }
95 deriving (IsString,Eq,Ord)
96 instance P.Stream StreamCell where
97 type Token StreamCell = Char
98 type Tokens StreamCell = TL.Text
99 take1_ (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
100 takeN_ n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t
101 takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t
102 tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text)
103 chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text)
104 chunkLength _s = P.chunkLength (Proxy::Proxy TL.Text)
105 advance1 _s indent (P.SourcePos n line col) c =
106 case c of
107 '\n' -> P.SourcePos n (line <> P.pos1) indent
108 _ -> P.SourcePos n line (col <> P.pos1)
109 advanceN s indent = TL.foldl' (P.advance1 s indent)