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)