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