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