]> Git — Sourcephile - doclang.git/blob - Language/TCT/Read.hs
Add data strictness.
[doclang.git] / Language / TCT / Read.hs
1 {-# LANGUAGE TypeFamilies #-}
2 module Language.TCT.Read
3 ( module Language.TCT.Read.Tree
4 , module Language.TCT.Read.Token
5 , module Language.TCT.Read
6 ) where
7
8 import Control.Applicative (Applicative(..))
9 import Data.Char (Char)
10 import Data.Either (Either(..))
11 import Data.Function (($))
12 import Data.Functor ((<$>))
13 import Data.Maybe (Maybe(..))
14 import Data.Semigroup (Semigroup(..))
15 import Data.Text (Text)
16 import Data.Traversable (sequence)
17 import Data.Tuple (fst, snd)
18 import Prelude (fromIntegral)
19 import System.IO (FilePath)
20 import qualified Text.Megaparsec as P
21 import Text.Show (Show(..))
22
23 import Language.TCT.Tree
24 import Language.TCT.Token
25 import Language.TCT.Read.Tree
26 import Language.TCT.Read.Token
27
28 import Debug.Trace (trace)
29
30 readTCT ::
31 FilePath -> Text ->
32 Either (P.ParseError (P.Token Text) P.Dec)
33 (Trees (Cell Key) (Cell Tokens))
34 readTCT inp txt = do
35 tct <- P.runParser (p_Trees <* P.eof) inp txt
36 sequence $ (<$> tct) {-(<$> trace (show $ PrettyTree tct) tct)-} $ \tr ->
37 sequence $ (`mapTreeWithKey`tr) $ \key (Cell pos posEnd t) ->
38 case key of
39 -- Verbatim Keys
40 Just (unCell -> KeyBar{}) ->
41 Right $ Cell pos posEnd $ tokens [TokenPlain t]
42 Just (unCell -> KeyLower{}) ->
43 Right $ Cell pos posEnd $ tokens [TokenPlain t]
44 Just (unCell -> KeyEqual{}) ->
45 Right $ Cell pos posEnd $ tokens [TokenPlain t]
46 -- Token Keys
47 _ ->
48 Cell pos posEnd <$>
49 P.runParser (do
50 P.setTabWidth $ P.unsafePos $ fromIntegral $ columnPos pos
51 P.setPosition $ P.SourcePos inp
52 (P.unsafePos $ fromIntegral $ linePos pos)
53 (P.unsafePos $ fromIntegral $ columnPos pos)
54 p_Tokens <* P.eof
55 ) inp (StreamCell t)
56
57 -- * Type 'StreamCell'
58 -- | Wrap 'Text' to have a 'P.Stream' instance
59 -- whose 'P.updatePos' method abuses the tab width state
60 -- to instead pass the line indent.
61 -- This in order to report correct 'P.SourcePos'
62 -- when parsing a 'Cell' containing newlines.
63 newtype StreamCell = StreamCell Text
64 instance P.Stream StreamCell where
65 type Token StreamCell = Char
66 uncons (StreamCell t) = (StreamCell <$>) <$> P.uncons t
67 updatePos _s indent apos@(P.SourcePos n l c) ch = (apos, npos)
68 where
69 u = P.unsafePos 1
70 npos =
71 case ch of
72 '\n' -> P.SourcePos n (l <> u) indent
73 _ -> P.SourcePos n l (c <> u)