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 (Traversable(..))
  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 readTreeCell ::
  31  FilePath -> Text ->
  32  Either (P.ParseError (P.Token Text) P.Dec)
  33         (Trees (Cell Key) (Cell Tokens))
  34 readTreeCell inp txt = do
  35         tct <- P.runParser (p_Trees <* P.eof) inp txt
  36         (`traverse` 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{})   -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
  41                          Just (unCell -> KeyLower{}) -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
  42                          Just (unCell -> KeyEqual{}) -> Right $ Cell pos posEnd $ tokens [TokenPlain t]
  43                          -- Token Keys
  44                          _ ->
  45                                 Cell pos posEnd <$>
  46                                         P.runParser (do
  47                                                 P.setTabWidth $ P.unsafePos $ fromIntegral $ columnPos pos
  48                                                 P.setPosition $ P.SourcePos inp
  49                                                  (P.unsafePos $ fromIntegral $ linePos   pos)
  50                                                  (P.unsafePos $ fromIntegral $ columnPos pos)
  51                                                 p_Tokens <* P.eof
  52                                          ) inp (StreamCell t)
  53
  54 readTree ::
  55  FilePath -> Text ->
  56  Either (P.ParseError (P.Token Text) P.Dec)
  57         (Trees Key Tokens)
  58 readTree inp txt = do
  59         tct <- P.runParser (p_Trees <* P.eof) inp txt
  60         (`traverse` tct) $ \tr ->
  61                 sequence $ (\f -> mapTreeKey unCell f tr) $ \key (Cell pos _posEnd t) ->
  62                         case unCell <$> key of
  63                          -- Verbatim Keys
  64                          Just KeyBar{}   -> Right $ tokens [TokenPlain t]
  65                          Just KeyLower{} -> Right $ tokens [TokenPlain t]
  66                          Just KeyEqual{} -> Right $ tokens [TokenPlain t]
  67                          -- Token Keys
  68                          _ ->
  69                                 P.runParser (do
  70                                         P.setTabWidth $ P.unsafePos $ fromIntegral $ columnPos pos
  71                                         P.setPosition $ P.SourcePos inp
  72                                          (P.unsafePos $ fromIntegral $ linePos   pos)
  73                                          (P.unsafePos $ fromIntegral $ columnPos pos)
  74                                         p_Tokens <* P.eof
  75                                  ) inp (StreamCell t)
  76
  77 -- * Type 'StreamCell'
  78 -- | Wrap 'Text' to have a 'P.Stream' instance
  79 -- whose 'P.updatePos' method abuses the tab width state
  80 -- to instead pass the line indent.
  81 -- This in order to report correct 'P.SourcePos'
  82 -- when parsing a 'Cell' containing newlines.
  83 newtype StreamCell = StreamCell Text
  84 instance P.Stream StreamCell where
  85         type Token StreamCell = Char
  86         uncons (StreamCell t) = (StreamCell <$>) <$> P.uncons t
  87         updatePos _s indent apos@(P.SourcePos n l c) ch = (apos, npos)
  88                 where
  89                 u = P.unsafePos 1
  90                 npos =
  91                         case ch of
  92                          '\n' -> P.SourcePos n (l <> u) indent
  93                          _    -> P.SourcePos n l (c <> u)