{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} module Hdoc.TCT.Read.Cell where import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..)) import Control.Monad.Trans.Class (MonadTrans(..)) 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 qualified Control.Monad.Trans.Reader as R import qualified Data.Set as Set import qualified Data.Text.Lazy as TL import qualified Text.Megaparsec as P import Hdoc.TCT.Cell -- * Type 'Parser' -- | Convenient alias. type Parser e s a = Parsable e s a => P.ParsecT e s (R.Reader [FileRange]) 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_FilePos :: Parser e s FilePos p_FilePos = do pos :| _ <- P.statePos <$> P.getParserState return $ FilePos (P.unPos $ P.sourceLine pos) (P.unPos $ P.sourceColumn pos) p_Cell :: Parser e s a -> Parser e s (Cell a) p_Cell pa = do path <- lift R.ask b :| _ <- P.statePos <$> P.getParserState a <- pa fileRange_end <- p_FilePos let fileRange_begin = FilePos (P.unPos $ P.sourceLine b) (P.unPos $ P.sourceColumn b) let fileRange = FileRange {fileRange_file=P.sourceName b, fileRange_begin, fileRange_end} return $ Sourced (fileRange:|path) a -- | Wrapper around |P.runParserT'| -- to use given 'Sourced' as starting position. runParserOnCell :: Parsable e StreamCell a => Parser e StreamCell a -> Cell TL.Text -> Either (P.ParseError (P.Token StreamCell) e) a runParserOnCell p (Sourced (FileRange inp bp _ep :| path) s) = snd $ (`R.runReader` path) $ P.runParserT' (p <* P.eof) P.State { P.stateInput = StreamCell s , P.statePos = pure $ P.SourcePos inp (P.mkPos $ filePos_line bp) indent , P.stateTabWidth = indent , P.stateTokensProcessed = 0 } where indent = P.mkPos $ filePos_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)