Language/TCT/Read/Cell.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 module Language.TCT.Read.Cell where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Data.Char (Char)
  10 import Data.Either (Either(..))
  11 import Data.Eq (Eq)
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.List.NonEmpty (NonEmpty(..))
  15 import Data.Maybe (Maybe(..))
  16 import Data.Ord (Ord)
  17 import Data.Proxy (Proxy(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.String (String, IsString)
  20 import Data.Tuple (snd)
  21 import System.FilePath (FilePath)
  22 import Text.Show (Show)
  23 import qualified Data.Set as Set
  24 import qualified Data.Text.Lazy as TL
  25 import qualified Text.Megaparsec as P
  26
  27 import Language.TCT.Cell
  28
  29 -- * Type 'Parser'
  30 -- | Convenient alias.
  31 type Parser   e s a =
  32      Parsable e s a =>
  33      P.Parsec e s a
  34
  35 -- ** Type 'Parsable'
  36 type Parsable e s a =
  37  ( P.Stream s
  38  , P.Token s ~ Char
  39  , Ord e
  40  , IsString (P.Tokens s)
  41  , P.ShowErrorComponent e
  42  )
  43
  44 -- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
  45 p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
  46 p_satisfyMaybe f = check `P.token` Nothing
  47         where
  48         check c =
  49                 case f c of
  50                  Just a  -> Right a
  51                  Nothing -> Left (Just $ P.Tokens $ c:|[], Set.empty)
  52
  53 p_Position :: Parser e s Pos
  54 p_Position = (<$> P.getPosition) $ \p ->
  55         Pos
  56          { pos_line   = P.unPos $ P.sourceLine p
  57          , pos_column = P.unPos $ P.sourceColumn p
  58          }
  59
  60 p_Cell :: Parser e s a -> Parser e s (Cell a)
  61 p_Cell pa =
  62         (\b a e -> Cell b e a)
  63          <$> p_Position
  64          <*> pa
  65          <*> p_Position
  66
  67 p_LineNum :: Parser e s LineNum
  68 p_LineNum = P.unPos . P.sourceLine <$> P.getPosition
  69
  70 p_ColNum :: Parser e s ColNum
  71 p_ColNum = P.unPos . P.sourceColumn <$> P.getPosition
  72
  73 -- | Wrapper around |P.runParser'|
  74 -- to use given 'Cell' as starting position.
  75 runParserOnCell ::
  76  Parsable e StreamCell a =>
  77  FilePath ->
  78  Parser e StreamCell a ->
  79  Cell TL.Text ->
  80  Either (P.ParseError (P.Token StreamCell) e) a
  81 runParserOnCell inp p (Cell bp _ep s) =
  82         snd $ P.runParser' (p <* P.eof)
  83          P.State
  84          { P.stateInput    = StreamCell s
  85          , P.statePos      = pure $ P.SourcePos inp (P.mkPos $ pos_line bp) indent
  86          , P.stateTabWidth = indent
  87          , P.stateTokensProcessed = 0
  88          }
  89         where indent = P.mkPos $ pos_column bp
  90
  91 -- * Type 'StreamCell'
  92 -- | Wrap 'TL.Text' to have a 'P.Stream' instance
  93 -- whose 'P.advance1' method abuses the tab width state
  94 -- to instead pass the line indent.
  95 -- This in order to report correct 'P.SourcePos'
  96 -- when parsing a 'Cell' containing newlines.
  97 newtype StreamCell = StreamCell { unStreamCell :: TL.Text }
  98  deriving (IsString,Eq,Ord)
  99 instance P.Stream StreamCell where
 100         type Token  StreamCell = Char
 101         type Tokens StreamCell = TL.Text
 102         take1_       (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
 103         takeN_     n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t
 104         takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t
 105         tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text)
 106         chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text)
 107         chunkLength   _s = P.chunkLength   (Proxy::Proxy TL.Text)
 108         advance1 _s indent (P.SourcePos n line col) c =
 109                 case c of
 110                  '\n' -> P.SourcePos n (line <> P.pos1) indent
 111                  _    -> P.SourcePos n line (col <> P.pos1)
 112         advanceN s indent = TL.foldl' (P.advance1 s indent)
 113
 114
 115 -- * Debug
 116 pdbg :: Show a => String -> Parser e s a -> Parser e s a
 117 pdbg = P.dbg
 118 -- pdbg _m p = p
 119 {-# INLINE pdbg #-}