+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Language.TCT.Read
( module Language.TCT.Read.Tree
, module Language.TCT.Read.Token
+ , module Language.TCT.Read.Cell
, module Language.TCT.Read
) where
import Control.Applicative (Applicative(..))
import Data.Char (Char)
import Data.Either (Either(..))
+import Data.Eq (Eq(..))
import Data.Function (($))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
+import Data.Ord (Ord(..))
+import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
+import Data.Sequence (Seq)
+import Data.String (IsString)
import Data.Text (Text)
import Data.Traversable (Traversable(..))
-import Data.Tuple (fst, snd)
-import Prelude (fromIntegral)
+import Data.TreeSeq.Strict (Tree)
+import Data.Tuple (snd)
+import Data.Void (Void)
import System.IO (FilePath)
+import qualified Data.Text as Text
+import qualified Data.TreeSeq.Strict as TreeSeq
import qualified Text.Megaparsec as P
-import Text.Show (Show(..))
import Language.TCT.Tree
import Language.TCT.Token
+import Language.TCT.Cell
+import Language.TCT.Read.Cell
import Language.TCT.Read.Tree
import Language.TCT.Read.Token
-import Debug.Trace (trace)
+-- * Type 'TCT'
+type TCT = Tree (Cell Key) Tokens
-readTreeCell ::
- FilePath -> Text ->
- Either (P.ParseError (P.Token Text) P.Dec)
- (Trees (Cell Key) (Cell Tokens))
-readTreeCell inp txt = do
- tct <- P.runParser (p_Trees <* P.eof) inp txt
- (`traverse` tct) {- $ (<$> trace (show $ PrettyTree tct) tct)-} $ \tr ->
- sequence $ (`mapTreeWithKey`tr) $ \key (Cell pos posEnd t) ->
- case key of
- -- Verbatim Keys
- Just (unCell -> KeyBar{}) -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
- Just (unCell -> KeyLower{}) -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
- Just (unCell -> KeyEqual{}) -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
- -- Token Keys
- _ ->
- Cell pos posEnd <$>
- P.runParser (do
- P.setTabWidth $ P.unsafePos $ fromIntegral $ columnPos pos
- P.setPosition $ P.SourcePos inp
- (P.unsafePos $ fromIntegral $ linePos pos)
- (P.unsafePos $ fromIntegral $ columnPos pos)
- p_Tokens <* P.eof
- ) inp (StreamCell t)
+-- * Type 'TCTs'
+type TCTs = Seq TCT
-readTree ::
+readTCTs ::
FilePath -> Text ->
- Either (P.ParseError (P.Token Text) P.Dec)
- (Trees Key Tokens)
-readTree inp txt = do
+ Either (P.ParseError (P.Token Text) (P.ErrorFancy Void)) TCTs
+readTCTs inp txt = do
tct <- P.runParser (p_Trees <* P.eof) inp txt
(`traverse` tct) $ \tr ->
- sequence $ (\f -> mapTreeKey unCell f tr) $ \key (Cell pos _posEnd t) ->
- case unCell <$> key of
+ sequence $ (`TreeSeq.mapWithKey`tr) $ \key c@(Cell pos _posEnd t) ->
+ case key of
-- Verbatim Keys
- Just KeyBar{} -> Right $ tokens [TokenPlain t]
- Just KeyLower{} -> Right $ tokens [TokenPlain t]
- Just KeyEqual{} -> Right $ tokens [TokenPlain t]
+ Just (unCell -> KeyBar{}) -> Right $ tokens [TokenPlain <$> c]
+ Just (unCell -> KeyLower{}) -> Right $ tokens [TokenPlain <$> c]
+ Just (unCell -> KeyEqual{}) -> Right $ tokens [TokenPlain <$> c]
-- Token Keys
_ ->
- P.runParser (do
- P.setTabWidth $ P.unsafePos $ fromIntegral $ columnPos pos
- P.setPosition $ P.SourcePos inp
- (P.unsafePos $ fromIntegral $ linePos pos)
- (P.unsafePos $ fromIntegral $ columnPos pos)
- p_Tokens <* P.eof
- ) inp (StreamCell t)
+ snd $ P.runParser'
+ (p_Tokens <* P.eof)
+ P.State
+ { P.stateInput = StreamCell t
+ , P.statePos = pure $ P.SourcePos inp
+ (P.mkPos $ linePos pos)
+ (P.mkPos $ columnPos pos)
+ , P.stateTabWidth = P.mkPos $ columnPos pos
+ , P.stateTokensProcessed = 0
+ }
-- * Type 'StreamCell'
-- | Wrap 'Text' to have a 'P.Stream' instance
--- whose 'P.updatePos' method abuses the tab width state
+-- whose 'P.advance1' method abuses the tab width state
-- to instead pass the line indent.
-- This in order to report correct 'P.SourcePos'
-- when parsing a 'Cell' containing newlines.
-newtype StreamCell = StreamCell Text
+newtype StreamCell = StreamCell { unStreamCell :: Text }
+ deriving (IsString,Eq,Ord)
instance P.Stream StreamCell where
- type Token StreamCell = Char
- uncons (StreamCell t) = (StreamCell <$>) <$> P.uncons t
- updatePos _s indent apos@(P.SourcePos n l c) ch = (apos, npos)
- where
- u = P.unsafePos 1
- npos =
- case ch of
- '\n' -> P.SourcePos n (l <> u) indent
- _ -> P.SourcePos n l (c <> u)
+ type Token StreamCell = Char
+ type Tokens StreamCell = StreamCell
+ take1_ (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
+ takeN_ n (StreamCell t) =
+ (\(ts,s) -> (StreamCell ts, StreamCell s)) <$>
+ P.takeN_ n t
+ takeWhile_ f (StreamCell t) =
+ (\(ts,s) -> (StreamCell ts, StreamCell s)) $
+ P.takeWhile_ f t
+ tokensToChunk _s ts = StreamCell (P.tokensToChunk (Proxy::Proxy Text) ts)
+ chunkToTokens _s (StreamCell ch) = P.chunkToTokens (Proxy::Proxy Text) ch
+ chunkLength _s (StreamCell ch) = P.chunkLength (Proxy::Proxy Text) ch
+ advance1 _s = advance1
+ advanceN _s indent pos (StreamCell t) = Text.foldl' (advance1 indent) pos t
+
+advance1 :: P.Pos -> P.SourcePos -> Char -> P.SourcePos
+advance1 indent (P.SourcePos n line col) c =
+ case c of
+ '\n' -> P.SourcePos n (line <> P.pos1) indent
+ _ -> P.SourcePos n line (col <> P.pos1)
sourcephile / git / doclang.git / blobdiff