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)