]> Git — Sourcephile - doclang.git/blob - Language/TCT/Read.hs
Use Tree for Token.
[doclang.git] / Language / TCT / Read.hs
1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE TypeFamilies #-}
3 {-# LANGUAGE ViewPatterns #-}
4 module Language.TCT.Read
5 ( module Language.TCT.Read.Tree
6 , module Language.TCT.Read.Token
7 , module Language.TCT.Read.Cell
8 , module Language.TCT.Read
9 ) where
10
11 import Control.Applicative (Applicative(..))
12 import Data.Char (Char)
13 import Data.Either (Either(..))
14 import Data.Eq (Eq(..))
15 import Data.Function (($))
16 import Data.Functor ((<$>))
17 import Data.Maybe (Maybe(..))
18 import Data.Ord (Ord(..))
19 import Data.Proxy (Proxy(..))
20 import Data.Semigroup (Semigroup(..))
21 import Data.Sequence (Seq)
22 import Data.String (IsString)
23 import Data.Text (Text)
24 import Data.Traversable (Traversable(..))
25 import Data.TreeSeq.Strict (Tree)
26 import Data.Tuple (snd)
27 import Data.Void (Void)
28 import System.IO (FilePath)
29 import qualified Data.Text as Text
30 import qualified Data.TreeSeq.Strict as TreeSeq
31 import qualified Text.Megaparsec as P
32
33 import Language.TCT.Tree
34 import Language.TCT.Token
35 import Language.TCT.Cell
36 import Language.TCT.Read.Cell
37 import Language.TCT.Read.Tree
38 import Language.TCT.Read.Token
39
40 -- * Type 'TCT'
41 type TCT = Tree (Cell Key) Tokens
42
43 -- * Type 'TCTs'
44 type TCTs = Seq TCT
45
46 readTCTs ::
47 FilePath -> Text ->
48 Either (P.ParseError (P.Token Text) (P.ErrorFancy Void)) TCTs
49 readTCTs inp txt = do
50 tct <- P.runParser (p_Trees <* P.eof) inp txt
51 (`traverse` tct) $ \tr ->
52 sequence $ (`TreeSeq.mapWithNode`tr) $ \key c@(Cell pos _posEnd t) ->
53 case key of
54 -- Verbatim Keys
55 Just (unCell -> KeyBar{}) -> Right $ tokens [Tree0 $ TokenPlain <$> c]
56 Just (unCell -> KeyLower{}) -> Right $ tokens [Tree0 $ TokenPlain <$> c]
57 Just (unCell -> KeyEqual{}) -> Right $ tokens [Tree0 $ TokenPlain <$> c]
58 -- Token Keys
59 _ ->
60 snd $ P.runParser'
61 (p_Tokens <* P.eof)
62 P.State
63 { P.stateInput = StreamCell t
64 , P.statePos = pure $ P.SourcePos inp
65 (P.mkPos $ linePos pos)
66 (P.mkPos $ columnPos pos)
67 , P.stateTabWidth = P.mkPos $ columnPos pos
68 , P.stateTokensProcessed = 0
69 }
70
71 -- * Type 'StreamCell'
72 -- | Wrap 'Text' to have a 'P.Stream' instance
73 -- whose 'P.advance1' method abuses the tab width state
74 -- to instead pass the line indent.
75 -- This in order to report correct 'P.SourcePos'
76 -- when parsing a 'Cell' containing newlines.
77 newtype StreamCell = StreamCell { unStreamCell :: Text }
78 deriving (IsString,Eq,Ord)
79 instance P.Stream StreamCell where
80 type Token StreamCell = Char
81 type Tokens StreamCell = StreamCell
82 take1_ (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
83 takeN_ n (StreamCell t) =
84 (\(ts,s) -> (StreamCell ts, StreamCell s)) <$>
85 P.takeN_ n t
86 takeWhile_ f (StreamCell t) =
87 (\(ts,s) -> (StreamCell ts, StreamCell s)) $
88 P.takeWhile_ f t
89 tokensToChunk _s ts = StreamCell (P.tokensToChunk (Proxy::Proxy Text) ts)
90 chunkToTokens _s (StreamCell ch) = P.chunkToTokens (Proxy::Proxy Text) ch
91 chunkLength _s (StreamCell ch) = P.chunkLength (Proxy::Proxy Text) ch
92 advance1 _s = advance1
93 advanceN _s indent pos (StreamCell t) = Text.foldl' (advance1 indent) pos t
94
95 advance1 :: P.Pos -> P.SourcePos -> Char -> P.SourcePos
96 advance1 indent (P.SourcePos n line col) c =
97 case c of
98 '\n' -> P.SourcePos n (line <> P.pos1) indent
99 _ -> P.SourcePos n line (col <> P.pos1)