Hdoc/TCT/Read/Cell.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 module Hdoc.TCT.Read.Cell where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Control.Monad (Monad(..))
  10 import Control.Monad.Trans.Class (MonadTrans(..))
  11 import Data.Char (Char)
  12 import Data.Either (Either(..))
  13 import Data.Eq (Eq)
  14 import Data.Function (($))
  15 import Data.Functor ((<$>))
  16 import Data.List.NonEmpty (NonEmpty(..))
  17 import Data.Maybe (Maybe(..))
  18 import Data.Ord (Ord)
  19 import Data.Proxy (Proxy(..))
  20 import Data.Semigroup (Semigroup(..))
  21 import Data.String (IsString)
  22 import Data.Tuple (snd)
  23 import qualified Control.Monad.Trans.Reader as R
  24 import qualified Data.Set as Set
  25 import qualified Data.Text.Lazy as TL
  26 import qualified Text.Megaparsec as P
  27
  28 import Hdoc.TCT.Cell
  29
  30 -- * Type 'Parser'
  31 -- | Convenient alias.
  32 type Parser   e s a =
  33      Parsable e s a =>
  34      P.ParsecT e s (R.Reader [Span]) a
  35
  36 -- ** Type 'Parsable'
  37 type Parsable e s a =
  38  ( P.Stream s
  39  , P.Token s ~ Char
  40  , Ord e
  41  , IsString (P.Tokens s)
  42  , P.ShowErrorComponent e
  43  )
  44
  45 -- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
  46 p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
  47 p_satisfyMaybe f = check `P.token` Nothing
  48         where
  49         check c =
  50                 case f c of
  51                  Just a  -> Right a
  52                  Nothing -> Left (Just $ P.Tokens $ c:|[], Set.empty)
  53
  54 p_Position :: Parser e s Pos
  55 p_Position = do
  56         pos :| _  <- P.statePos <$> P.getParserState
  57         return $ Pos (P.unPos $ P.sourceLine pos) (P.unPos $ P.sourceColumn pos)
  58
  59 p_Cell :: Parser e s a -> Parser e s (Cell a)
  60 p_Cell pa = do
  61         path <- lift R.ask
  62         b :| _ <- P.statePos <$> P.getParserState
  63         a <- pa
  64         span_end <- p_Position
  65         let span_begin = Pos (P.unPos $ P.sourceLine b) (P.unPos $ P.sourceColumn b)
  66         let span = Span {span_file=P.sourceName b, span_begin, span_end}
  67         return $ Cell (span:|path) a
  68
  69 -- | Wrapper around |P.runParserT'|
  70 -- to use given 'Cell' as starting position.
  71 runParserOnCell ::
  72  Parsable e StreamCell a =>
  73  Parser e StreamCell a ->
  74  Cell TL.Text ->
  75  Either (P.ParseError (P.Token StreamCell) e) a
  76 runParserOnCell p (Cell (Span inp bp _ep :| path) s) =
  77         snd $
  78         (`R.runReader` path) $
  79         P.runParserT' (p <* P.eof)
  80          P.State
  81          { P.stateInput    = StreamCell s
  82          , P.statePos      = pure $ P.SourcePos inp (P.mkPos $ pos_line bp) indent
  83          , P.stateTabWidth = indent
  84          , P.stateTokensProcessed = 0
  85          }
  86         where indent = P.mkPos $ pos_column bp
  87
  88 -- * Type 'StreamCell'
  89 -- | Wrap 'TL.Text' to have a 'P.Stream' instance
  90 -- whose 'P.advance1' method abuses the tab width state
  91 -- to instead pass the line indent.
  92 -- This in order to report correct 'P.SourcePos'
  93 -- when parsing a 'Cell' containing newlines.
  94 newtype StreamCell = StreamCell { unStreamCell :: TL.Text }
  95  deriving (IsString,Eq,Ord)
  96 instance P.Stream StreamCell where
  97         type Token  StreamCell = Char
  98         type Tokens StreamCell = TL.Text
  99         take1_       (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
 100         takeN_     n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t
 101         takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t
 102         tokensToChunk _s = P.tokensToChunk (Proxy::Proxy TL.Text)
 103         chunkToTokens _s = P.chunkToTokens (Proxy::Proxy TL.Text)
 104         chunkLength   _s = P.chunkLength   (Proxy::Proxy TL.Text)
 105         advance1 _s indent (P.SourcePos n line col) c =
 106                 case c of
 107                  '\n' -> P.SourcePos n (line <> P.pos1) indent
 108                  _    -> P.SourcePos n line (col <> P.pos1)
 109         advanceN s indent = TL.foldl' (P.advance1 s indent)