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