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.Elem
  24 import Language.TCT.Tree
  25 import Language.TCT.Token
  26 import Language.TCT.Read.Tree
  27 import Language.TCT.Read.Token
  28
  29 readTCT :: FilePath -> Text -> Either (P.ParseError (P.Token Text) P.Dec) (TCT (Cell Token))
  30 readTCT inp txt = do
  31         tct <- P.runParser (p_Trees <* P.eof) inp txt
  32         sequence $ (<$> trac (show $ PrettyTree tct) tct) $ \tr ->
  33                 sequence $ (`mapTreeWithKey`tr) $ \key (Cell pos posEnd t) ->
  34                         case key of
  35                          -- Verbatim Keys
  36                          Just (unCell -> KeyBar{}) ->
  37                                 Right $ Cell pos posEnd (TokenPlain t)
  38                          Just (unCell -> KeyLower{}) ->
  39                                 Right $ Cell pos posEnd (TokenPlain t)
  40                          Just (unCell -> KeyEqual{}) ->
  41                                 Right $ Cell pos posEnd (TokenPlain t)
  42                          -- Token Keys
  43                          _ ->
  44                                 Cell pos posEnd <$>
  45                                         P.runParser (do
  46                                                 P.setTabWidth $ P.unsafePos $ fromIntegral $ snd pos
  47                                                 P.setPosition $ P.SourcePos inp
  48                                                  (P.unsafePos $ fromIntegral $ fst pos)
  49                                                  (P.unsafePos $ fromIntegral $ snd pos)
  50                                                 p_Token <* P.eof
  51                                          ) inp (StreamCell t)
  52
  53 -- * Type 'StreamCell'
  54 -- | Wrap 'Text' to have a 'P.Stream' instance
  55 -- whose 'P.updatePos' method abuses the tab width state
  56 -- to instead pass the line indent.
  57 -- This in order to report correct 'P.SourcePos'
  58 -- when parsing a 'Cell' containing newlines.
  59 newtype StreamCell = StreamCell Text
  60 instance P.Stream StreamCell where
  61         type Token StreamCell = Char
  62         uncons (StreamCell t) = (StreamCell <$>) <$> P.uncons t
  63         updatePos _s indent apos@(P.SourcePos n l c) ch = (apos, npos)
  64                 where
  65                 u = P.unsafePos 1
  66                 npos =
  67                         case ch of
  68                          '\n' -> P.SourcePos n (l <> u) indent
  69                          _    -> P.SourcePos n l (c <> u)