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 (($), (.), 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 Hdoc.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                 ( spos
 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                 ( spos
 172                 , P.PosState
 173                  { pstateInput      = StreamCell post
 174                  , pstateOffset     = max pstateOffset o
 175                  , pstateSourcePos  = spos
 176                  , pstateTabWidth   = pstateTabWidth
 177                  , pstateLinePrefix = pstateLinePrefix
 178                  }
 179                 )
 180                 where
 181                 spos = TL.foldl' go pstateSourcePos pre
 182                 (pre, post) = TL.splitAt (fromIntegral $ o - pstateOffset) $ unStreamCell pstateInput
 183                 w = 4
 184                 go (P.SourcePos n l c) = \case
 185                          '\n' -> P.SourcePos n (l <> P.pos1) pstateTabWidth
 186                          '\t' -> P.SourcePos n l $ P.mkPos $ P.unPos c + w - ((P.unPos c - 1) `rem` w)
 187                          _    -> P.SourcePos n l (c <> P.pos1)
 188         showTokens _s = P.showTokens (Proxy::Proxy TL.Text)