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