src/Textphile/TCT/Read/Cell.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 module Textphile.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 (($), (.), id)
  15 import Data.Functor ((<$>))
  16 import Data.Int (Int)
  17 import Data.List.NonEmpty (NonEmpty(..))
  18 import Data.Maybe (Maybe(..))
  19 import Data.Ord (Ord)
  20 import Data.Proxy (Proxy(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.String (IsString)
  23 import Data.Tuple (fst, snd)
  24 import Text.Show (ShowS)
  25 import Prelude (max, rem, (+), (-), fromIntegral)
  26 import qualified Control.Monad.Trans.Reader as R
  27 import qualified Data.Set as Set
  28 import qualified Data.Text.Lazy as TL
  29 import qualified Text.Megaparsec as P
  30
  31 import Textphile.TCT.Cell
  32
  33 -- * Type 'Parser'
  34 -- | Convenient alias.
  35 type Parser   e s a =
  36      Parsable e s a =>
  37      P.ParsecT e s (R.Reader [FileRange LineColumn]) a
  38
  39 -- ** Type 'Offset'
  40 type Offset = Int
  41
  42 -- ** Type 'Parsable'
  43 type Parsable e s a =
  44  ( P.Stream s
  45  , P.Token s ~ Char
  46  , Ord e
  47  , IsString (P.Tokens s)
  48  , P.ShowErrorComponent e
  49  )
  50
  51 -- | Like 'P.satisfy' but with a predicate returning 'Maybe' instead of 'Bool'.
  52 p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
  53 p_satisfyMaybe = (`P.token` Set.empty)
  54
  55 p_LineColumn :: Parser e s LineColumn
  56 p_LineColumn = do
  57         P.SourcePos{..} <- P.getSourcePos
  58         return $ LineColumn sourceLine sourceColumn
  59
  60 p_Cell :: Parser e s a -> Parser e s (Cell a)
  61 p_Cell pa = do
  62         path <- lift R.ask
  63         b <- P.getSourcePos
  64         a <- pa
  65         e <- P.getSourcePos
  66         let fileRange_begin = LineColumn (P.sourceLine b) (P.sourceColumn b)
  67         let fileRange_end   = LineColumn (P.sourceLine e) (P.sourceColumn e)
  68         let fileRange = FileRange {fileRange_file=P.sourceName b, fileRange_begin, fileRange_end}
  69         return $ Sourced (fileRange:|path) a
  70
  71 -- | Wrapper around |P.runParserT'|
  72 -- to use given 'Sourced' as starting position.
  73 runParserOnCell ::
  74  Parsable e StreamCell a =>
  75  Parser e StreamCell a ->
  76  Cell TL.Text ->
  77  Either (P.ParseErrorBundle StreamCell e) a
  78 runParserOnCell p (Sourced (FileRange inp bp _ep :| path) s) =
  79         snd $
  80         (`R.runReader` path) $
  81         P.runParserT' (p <* P.eof)
  82          P.State
  83          { P.stateInput    = StreamCell s
  84          , P.stateOffset   = 0
  85          , P.stateParseErrors = []
  86          , P.statePosState = P.PosState
  87                 { P.pstateInput      = StreamCell s
  88                 , P.pstateOffset     = 0
  89                 , P.pstateSourcePos  = P.SourcePos inp (lineNum bp) (colNum bp)
  90                 , P.pstateTabWidth   = colNum bp
  91                 , P.pstateLinePrefix = ""
  92                 }
  93          }
  94
  95
  96
  97
  98
  99 -- * Type 'StreamCell'
 100 -- | Wrap 'TL.Text' to have a 'P.Stream' instance
 101 -- whose 'P.advance1' method abuses the tab width state
 102 -- to instead pass the line indent.
 103 -- This in order to report correct 'P.SourcePos'
 104 -- when parsing a 'Cell' containing newlines.
 105 newtype StreamCell = StreamCell { unStreamCell :: TL.Text }
 106  deriving (IsString,Eq,Ord)
 107
 108
 109 {-
 110 instance P.Stream TL.Text where
 111         type Token TL.Text  = Char
 112         type Tokens TL.Text = TL.Text
 113         tokenToChunk _s = TL.singleton
 114         tokensToChunk _s = TL.pack
 115         chunkToTokens _s = TL.unpack
 116         chunkLength _s = fromIntegral . TL.length
 117         chunkEmpty _s = TL.null
 118         take1_ = TL.uncons
 119         takeN_ n s
 120          | n <= 0    = Just (TL.empty, s)
 121          | TL.null s = Nothing
 122          | otherwise = Just (TL.splitAt (fromIntegral n) s)
 123         takeWhile_ = TL.span
 124         showTokens _s = stringPretty
 125 -}
 126
 127 data St = St P.SourcePos ShowS
 128 instance P.Stream StreamCell where
 129         type Token  StreamCell = Char
 130         type Tokens StreamCell = TL.Text
 131         take1_       (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
 132         takeN_     n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t
 133         takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t
 134         tokensToChunk _s = TL.pack
 135         chunkToTokens _s = TL.unpack
 136         chunkLength   _s = fromIntegral . TL.length
 137         reachOffset o P.PosState {..} =
 138                 ( case {- expandTab pstateTabWidth . -}
 139                           addPrefix . f . fromToks . fst $
 140                           P.takeWhile_ (/= '\n') post of
 141                          "" -> "<empty line>"
 142                          xs -> xs
 143                 , P.PosState
 144                  { pstateInput      = StreamCell post
 145                  , pstateOffset     = max pstateOffset o
 146                  , pstateSourcePos  = spos
 147                  , pstateTabWidth   = pstateTabWidth
 148                  , pstateLinePrefix =
 149                         if sameLine
 150                         -- NOTE We don't use difference lists here because it's
 151                         -- desirable for 'P.PosState' to be an instance of 'Eq' and
 152                         -- 'Show'. So we just do appending here. Fortunately several
 153                         -- parse errors on the same line should be relatively rare.
 154                         then pstateLinePrefix <> f ""
 155                         else f ""
 156                  }
 157                 )
 158                 where
 159                 addPrefix xs = if sameLine then pstateLinePrefix <> xs else xs
 160                 sameLine = P.sourceLine spos == P.sourceLine pstateSourcePos
 161                 (pre, post) = TL.splitAt (fromIntegral $ o - pstateOffset) $ unStreamCell pstateInput
 162                 St spos f = TL.foldl' go (St pstateSourcePos id) pre
 163                 fromToks = TL.unpack
 164                 fromTok = id
 165                 w = 4
 166                 go (St (P.SourcePos n l c) g) = \case
 167                          '\n' -> St (P.SourcePos n (l <> P.pos1) pstateTabWidth) id
 168                          ch@'\t' -> St (P.SourcePos n l (P.mkPos $ P.unPos c + w - ((P.unPos c - 1) `rem` w))) (g . (fromTok ch :))
 169                          ch -> St (P.SourcePos n l (c <> P.pos1)) (g . (fromTok ch :))
 170         reachOffsetNoLine o P.PosState{..} =
 171                 ( P.PosState
 172                  { pstateInput      = StreamCell post
 173                  , pstateOffset     = max pstateOffset o
 174                  , pstateSourcePos  = spos
 175                  , pstateTabWidth   = pstateTabWidth
 176                  , pstateLinePrefix = pstateLinePrefix
 177                  }
 178                 )
 179                 where
 180                 spos = TL.foldl' go pstateSourcePos pre
 181                 (pre, post) = TL.splitAt (fromIntegral $ o - pstateOffset) $ unStreamCell pstateInput
 182                 w = 4
 183                 go (P.SourcePos n l c) = \case
 184                          '\n' -> P.SourcePos n (l <> P.pos1) pstateTabWidth
 185                          '\t' -> P.SourcePos n l $ P.mkPos $ P.unPos c + w - ((P.unPos c - 1) `rem` w)
 186                          _    -> P.SourcePos n l (c <> P.pos1)
 187         showTokens _s = P.showTokens (Proxy::Proxy TL.Text)