]> Git — Sourcephile - doclang.git/blob - src/Textphile/TCT/Read/Cell.hs
Rename {hdoc => textphile}
[doclang.git] / src / Textphile / TCT / Read / Cell.hs
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE Rank2Types #-}
5 {-# LANGUAGE TypeFamilies #-}
6 module Textphile.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 (($), (.), id)
15 import Data.Functor ((<$>))
16 import Data.Int (Int)
17 import Data.List.NonEmpty (NonEmpty(..))
18 import Data.Maybe (Maybe(..))
19 import Data.Ord (Ord)
20 import Data.Proxy (Proxy(..))
21 import Data.Semigroup (Semigroup(..))
22 import Data.String (IsString)
23 import Data.Tuple (fst, snd)
24 import Text.Show (ShowS)
25 import Prelude (max, rem, (+), (-), fromIntegral)
26 import qualified Control.Monad.Trans.Reader as R
27 import qualified Data.Set as Set
28 import qualified Data.Text.Lazy as TL
29 import qualified Text.Megaparsec as P
30
31 import Textphile.TCT.Cell
32
33 -- * Type 'Parser'
34 -- | Convenient alias.
35 type Parser e s a =
36 Parsable e s a =>
37 P.ParsecT e s (R.Reader [FileRange LineColumn]) a
38
39 -- ** Type 'Offset'
40 type Offset = Int
41
42 -- ** Type 'Parsable'
43 type Parsable e s a =
44 ( P.Stream s
45 , P.Token s ~ Char
46 , Ord e
47 , IsString (P.Tokens s)
48 , P.ShowErrorComponent e
49 )
50
51 -- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
52 p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
53 p_satisfyMaybe = (`P.token` Set.empty)
54
55 p_LineColumn :: Parser e s LineColumn
56 p_LineColumn = do
57 P.SourcePos{..} <- P.getSourcePos
58 return $ LineColumn sourceLine sourceColumn
59
60 p_Cell :: Parser e s a -> Parser e s (Cell a)
61 p_Cell pa = do
62 path <- lift R.ask
63 b <- P.getSourcePos
64 a <- pa
65 e <- P.getSourcePos
66 let fileRange_begin = LineColumn (P.sourceLine b) (P.sourceColumn b)
67 let fileRange_end = LineColumn (P.sourceLine e) (P.sourceColumn e)
68 let fileRange = FileRange {fileRange_file=P.sourceName b, fileRange_begin, fileRange_end}
69 return $ Sourced (fileRange:|path) a
70
71 -- | Wrapper around |P.runParserT'|
72 -- to use given 'Sourced' as starting position.
73 runParserOnCell ::
74 Parsable e StreamCell a =>
75 Parser e StreamCell a ->
76 Cell TL.Text ->
77 Either (P.ParseErrorBundle StreamCell e) a
78 runParserOnCell p (Sourced (FileRange inp bp _ep :| path) s) =
79 snd $
80 (`R.runReader` path) $
81 P.runParserT' (p <* P.eof)
82 P.State
83 { P.stateInput = StreamCell s
84 , P.stateOffset = 0
85 , P.statePosState = P.PosState
86 { P.pstateInput = StreamCell s
87 , P.pstateOffset = 0
88 , P.pstateSourcePos = P.SourcePos inp (lineNum bp) (colNum bp)
89 , P.pstateTabWidth = colNum bp
90 , P.pstateLinePrefix = ""
91 }
92 }
93
94
95
96
97
98 -- * Type 'StreamCell'
99 -- | Wrap 'TL.Text' to have a 'P.Stream' instance
100 -- whose 'P.advance1' method abuses the tab width state
101 -- to instead pass the line indent.
102 -- This in order to report correct 'P.SourcePos'
103 -- when parsing a 'Cell' containing newlines.
104 newtype StreamCell = StreamCell { unStreamCell :: TL.Text }
105 deriving (IsString,Eq,Ord)
106
107
108 {-
109 instance P.Stream TL.Text where
110 type Token TL.Text = Char
111 type Tokens TL.Text = TL.Text
112 tokenToChunk _s = TL.singleton
113 tokensToChunk _s = TL.pack
114 chunkToTokens _s = TL.unpack
115 chunkLength _s = fromIntegral . TL.length
116 chunkEmpty _s = TL.null
117 take1_ = TL.uncons
118 takeN_ n s
119 | n <= 0 = Just (TL.empty, s)
120 | TL.null s = Nothing
121 | otherwise = Just (TL.splitAt (fromIntegral n) s)
122 takeWhile_ = TL.span
123 showTokens _s = stringPretty
124 -}
125
126 data St = St P.SourcePos ShowS
127 instance P.Stream StreamCell where
128 type Token StreamCell = Char
129 type Tokens StreamCell = TL.Text
130 take1_ (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
131 takeN_ n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t
132 takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t
133 tokensToChunk _s = TL.pack
134 chunkToTokens _s = TL.unpack
135 chunkLength _s = fromIntegral . TL.length
136 reachOffset o P.PosState {..} =
137 ( spos
138 , case {- expandTab pstateTabWidth . -}
139 addPrefix . f . fromToks . fst $
140 P.takeWhile_ (/= '\n') post of
141 "" -> "<empty line>"
142 xs -> xs
143 , P.PosState
144 { pstateInput = StreamCell post
145 , pstateOffset = max pstateOffset o
146 , pstateSourcePos = spos
147 , pstateTabWidth = pstateTabWidth
148 , pstateLinePrefix =
149 if sameLine
150 -- NOTE We don't use difference lists here because it's
151 -- desirable for 'P.PosState' to be an instance of 'Eq' and
152 -- 'Show'. So we just do appending here. Fortunately several
153 -- parse errors on the same line should be relatively rare.
154 then pstateLinePrefix <> f ""
155 else f ""
156 }
157 )
158 where
159 addPrefix xs = if sameLine then pstateLinePrefix <> xs else xs
160 sameLine = P.sourceLine spos == P.sourceLine pstateSourcePos
161 (pre, post) = TL.splitAt (fromIntegral $ o - pstateOffset) $ unStreamCell pstateInput
162 St spos f = TL.foldl' go (St pstateSourcePos id) pre
163 fromToks = TL.unpack
164 fromTok = id
165 w = 4
166 go (St (P.SourcePos n l c) g) = \case
167 '\n' -> St (P.SourcePos n (l <> P.pos1) pstateTabWidth) id
168 ch@'\t' -> St (P.SourcePos n l (P.mkPos $ P.unPos c + w - ((P.unPos c - 1) `rem` w))) (g . (fromTok ch :))
169 ch -> St (P.SourcePos n l (c <> P.pos1)) (g . (fromTok ch :))
170 reachOffsetNoLine o P.PosState{..} =
171 ( spos
172 , P.PosState
173 { pstateInput = StreamCell post
174 , pstateOffset = max pstateOffset o
175 , pstateSourcePos = spos
176 , pstateTabWidth = pstateTabWidth
177 , pstateLinePrefix = pstateLinePrefix
178 }
179 )
180 where
181 spos = TL.foldl' go pstateSourcePos pre
182 (pre, post) = TL.splitAt (fromIntegral $ o - pstateOffset) $ unStreamCell pstateInput
183 w = 4
184 go (P.SourcePos n l c) = \case
185 '\n' -> P.SourcePos n (l <> P.pos1) pstateTabWidth
186 '\t' -> P.SourcePos n l $ P.mkPos $ P.unPos c + w - ((P.unPos c - 1) `rem` w)
187 _ -> P.SourcePos n l (c <> P.pos1)
188 showTokens _s = P.showTokens (Proxy::Proxy TL.Text)