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.mapWithKey`tr) $ \key c@(Cell pos _posEnd t) ->
  53                         case key of
  54                          -- Verbatim Keys
  55                          Just (unCell -> KeyBar{})   -> Right $ tokens [TokenPlain <$> c]
  56                          Just (unCell -> KeyLower{}) -> Right $ tokens [TokenPlain <$> c]
  57                          Just (unCell -> KeyEqual{}) -> Right $ tokens [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)