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.statePosState = P.PosState
  86                 { P.pstateInput      = StreamCell s
  87                 , P.pstateOffset     = 0
  88                 , P.pstateSourcePos  = P.SourcePos inp (lineNum bp) (colNum bp)
  89                 , P.pstateTabWidth   = colNum bp
  90                 , P.pstateLinePrefix = ""
  91                 }
  92          }
  93
  94
  95
  96
  97
  98 -- * Type 'StreamCell'
  99 -- | Wrap 'TL.Text' to have a 'P.Stream' instance
 100 -- whose 'P.advance1' method abuses the tab width state
 101 -- to instead pass the line indent.
 102 -- This in order to report correct 'P.SourcePos'
 103 -- when parsing a 'Cell' containing newlines.
 104 newtype StreamCell = StreamCell { unStreamCell :: TL.Text }
 105  deriving (IsString,Eq,Ord)
 106
 107
 108 {-
 109 instance P.Stream TL.Text where
 110         type Token TL.Text  = Char
 111         type Tokens TL.Text = TL.Text
 112         tokenToChunk _s = TL.singleton
 113         tokensToChunk _s = TL.pack
 114         chunkToTokens _s = TL.unpack
 115         chunkLength _s = fromIntegral . TL.length
 116         chunkEmpty _s = TL.null
 117         take1_ = TL.uncons
 118         takeN_ n s
 119          | n <= 0    = Just (TL.empty, s)
 120          | TL.null s = Nothing
 121          | otherwise = Just (TL.splitAt (fromIntegral n) s)
 122         takeWhile_ = TL.span
 123         showTokens _s = stringPretty
 124 -}
 125
 126 data St = St P.SourcePos ShowS
 127 instance P.Stream StreamCell where
 128         type Token  StreamCell = Char
 129         type Tokens StreamCell = TL.Text
 130         take1_       (StreamCell t) = (StreamCell <$>) <$> P.take1_ t
 131         takeN_     n (StreamCell t) = (StreamCell <$>) <$> P.takeN_ n t
 132         takeWhile_ f (StreamCell t) = StreamCell <$> P.takeWhile_ f t
 133         tokensToChunk _s = TL.pack
 134         chunkToTokens _s = TL.unpack
 135         chunkLength   _s = fromIntegral . TL.length
 136         reachOffset o P.PosState {..} =
 137                 ( case {- expandTab pstateTabWidth . -}
 138                           addPrefix . f . fromToks . fst $
 139                           P.takeWhile_ (/= '\n') post of
 140                          "" -> "<empty line>"
 141                          xs -> xs
 142                 , P.PosState
 143                  { pstateInput      = StreamCell post
 144                  , pstateOffset     = max pstateOffset o
 145                  , pstateSourcePos  = spos
 146                  , pstateTabWidth   = pstateTabWidth
 147                  , pstateLinePrefix =
 148                         if sameLine
 149                         -- NOTE We don't use difference lists here because it's
 150                         -- desirable for 'P.PosState' to be an instance of 'Eq' and
 151                         -- 'Show'. So we just do appending here. Fortunately several
 152                         -- parse errors on the same line should be relatively rare.
 153                         then pstateLinePrefix <> f ""
 154                         else f ""
 155                  }
 156                 )
 157                 where
 158                 addPrefix xs = if sameLine then pstateLinePrefix <> xs else xs
 159                 sameLine = P.sourceLine spos == P.sourceLine pstateSourcePos
 160                 (pre, post) = TL.splitAt (fromIntegral $ o - pstateOffset) $ unStreamCell pstateInput
 161                 St spos f = TL.foldl' go (St pstateSourcePos id) pre
 162                 fromToks = TL.unpack
 163                 fromTok = id
 164                 w = 4
 165                 go (St (P.SourcePos n l c) g) = \case
 166                          '\n' -> St (P.SourcePos n (l <> P.pos1) pstateTabWidth) id
 167                          ch@'\t' -> St (P.SourcePos n l (P.mkPos $ P.unPos c + w - ((P.unPos c - 1) `rem` w))) (g . (fromTok ch :))
 168                          ch -> St (P.SourcePos n l (c <> P.pos1)) (g . (fromTok ch :))
 169         reachOffsetNoLine o P.PosState{..} =
 170                 ( P.PosState
 171                  { pstateInput      = StreamCell post
 172                  , pstateOffset     = max pstateOffset o
 173                  , pstateSourcePos  = spos
 174                  , pstateTabWidth   = pstateTabWidth
 175                  , pstateLinePrefix = pstateLinePrefix
 176                  }
 177                 )
 178                 where
 179                 spos = TL.foldl' go pstateSourcePos pre
 180                 (pre, post) = TL.splitAt (fromIntegral $ o - pstateOffset) $ unStreamCell pstateInput
 181                 w = 4
 182                 go (P.SourcePos n l c) = \case
 183                          '\n' -> P.SourcePos n (l <> P.pos1) pstateTabWidth
 184                          '\t' -> P.SourcePos n l $ P.mkPos $ P.unPos c + w - ((P.unPos c - 1) `rem` w)
 185                          _    -> P.SourcePos n l (c <> P.pos1)
 186         showTokens _s = P.showTokens (Proxy::Proxy TL.Text)