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 -- * 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_SourceFile :: Parser e s FilePath
  54 p_SourceFile = P.sourceName <$> P.getPosition
  55
  56 p_Position :: Parser e s Pos
  57 p_Position = (<$> P.getPosition) $ \p ->
  58         Pos
  59          { pos_line   = P.unPos $ P.sourceLine p
  60          , pos_column = P.unPos $ P.sourceColumn p
  61          }
  62
  63 p_Cell :: Parser e s a -> Parser e s (Cell a)
  64 p_Cell pa =
  65         (\b a e -> Cell b e a)
  66          <$> p_Position
  67          <*> pa
  68          <*> p_Position
  69
  70 p_LineNum :: Parser e s LineNum
  71 p_LineNum = P.unPos . P.sourceLine <$> P.getPosition
  72
  73 p_ColNum :: Parser e s ColNum
  74 p_ColNum = P.unPos . P.sourceColumn <$> P.getPosition
  75
  76 -- | Wrapper around |P.runParser'|
  77 -- to use given 'Cell' as starting position.
  78 runParserOnCell ::
  79  Parsable e StreamCell a =>
  80  FilePath ->
  81  Parser e StreamCell a ->
  82  Cell TL.Text ->
  83  Either (P.ParseError (P.Token StreamCell) e) a
  84 runParserOnCell inp p (Cell bp _ep s) =
  85         snd $ P.runParser' (p <* P.eof)
  86          P.State
  87          { P.stateInput    = StreamCell s
  88          , P.statePos      = pure $ P.SourcePos inp (P.mkPos $ pos_line bp) indent
  89          , P.stateTabWidth = indent
  90          , P.stateTokensProcessed = 0
  91          }
  92         where indent = debug0 "runParserOnCell: indent" $ P.mkPos $ pos_column bp
  93
  94 -- * Type 'StreamCell'
  95 -- | Wrap 'TL.Text' to have a 'P.Stream' instance
  96 -- whose 'P.advance1' method abuses the tab width state
  97 -- to instead pass the line indent.
  98 -- This in order to report correct 'P.SourcePos'
  99 -- when parsing a 'Cell' containing newlines.
 100 newtype StreamCell = StreamCell { unStreamCell :: TL.Text }
 101  deriving (IsString,Eq,Ord)
 102 instance P.Stream StreamCell where
 103         type Token  StreamCell = Char
 104         type Tokens StreamCell = TL.Text
 105         take1_       (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
 106         takeN_     n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t
 107         takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t
 108         tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text)
 109         chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text)
 110         chunkLength   _s = P.chunkLength   (Proxy::Proxy TL.Text)
 111         advance1 _s indent (P.SourcePos n line col) c =
 112                 case c of
 113                  '\n' -> P.SourcePos n (line <> P.pos1) indent
 114                  _    -> P.SourcePos n line (col <> P.pos1)
 115         advanceN s indent = TL.foldl' (P.advance1 s indent)