{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} module Language.TCT.Read.Cell where import Control.Applicative (Applicative(..)) import Data.Char (Char) import Data.Either (Either(..)) import Data.Eq (Eq) import Data.Function (($), (.)) import Data.Functor ((<$>)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (Maybe(..)) import Data.Ord (Ord) import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup(..)) import Data.String (IsString) import Data.Tuple (snd) import System.FilePath (FilePath) import qualified Data.Set as Set import qualified Data.Text.Lazy as TL import qualified Text.Megaparsec as P import Language.TCT.Cell import Language.TCT.Debug -- * Type 'Parser' -- | Convenient alias. type Parser e s a = Parsable e s a => P.Parsec e s a -- ** Type 'Parsable' type Parsable e s a = ( P.Stream s , P.Token s ~ Char , Ord e , IsString (P.Tokens s) , P.ShowErrorComponent e ) -- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'. p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a p_satisfyMaybe f = check `P.token` Nothing where check c = case f c of Just a -> Right a Nothing -> Left (Just $ P.Tokens $ c:|[], Set.empty) p_SourceFile :: Parser e s FilePath p_SourceFile = P.sourceName <$> P.getPosition p_Position :: Parser e s Pos p_Position = (<$> P.getPosition) $ \p -> Pos { pos_line = P.unPos $ P.sourceLine p , pos_column = P.unPos $ P.sourceColumn p } p_Cell :: Parser e s a -> Parser e s (Cell a) p_Cell pa = (\b a e -> Cell b e a) <$> p_Position <*> pa <*> p_Position p_LineNum :: Parser e s LineNum p_LineNum = P.unPos . P.sourceLine <$> P.getPosition p_ColNum :: Parser e s ColNum p_ColNum = P.unPos . P.sourceColumn <$> P.getPosition -- | Wrapper around |P.runParser'| -- to use given 'Cell' as starting position. runParserOnCell :: Parsable e StreamCell a => FilePath -> Parser e StreamCell a -> Cell TL.Text -> Either (P.ParseError (P.Token StreamCell) e) a runParserOnCell inp p (Cell bp _ep s) = snd $ P.runParser' (p <* P.eof) P.State { P.stateInput = StreamCell s , P.statePos = pure $ P.SourcePos inp (P.mkPos $ pos_line bp) indent , P.stateTabWidth = indent , P.stateTokensProcessed = 0 } where indent = debug0 "runParserOnCell: indent" $ P.mkPos $ pos_column bp -- * Type 'StreamCell' -- | Wrap 'TL.Text' to have a 'P.Stream' instance -- whose 'P.advance1' method abuses the tab width state -- to instead pass the line indent. -- This in order to report correct 'P.SourcePos' -- when parsing a 'Cell' containing newlines. newtype StreamCell = StreamCell { unStreamCell :: TL.Text } deriving (IsString,Eq,Ord) instance P.Stream StreamCell where type Token StreamCell = Char type Tokens StreamCell = TL.Text take1_ (StreamCell t) = (StreamCell <$>) <$> P.take1_ t takeN_ n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text) chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text) chunkLength _s = P.chunkLength (Proxy::Proxy TL.Text) advance1 _s indent (P.SourcePos n line col) c = case c of '\n' -> P.SourcePos n (line <> P.pos1) indent _ -> P.SourcePos n line (col <> P.pos1) advanceN s indent = TL.foldl' (P.advance1 s indent)