trifecta 0.28 → 0.29
raw patch · 15 files changed
+436/−287 lines, 15 files
Files
- Text/Trifecta/ByteSet.hs +64/−0
- Text/Trifecta/CharSet.hs +68/−56
- Text/Trifecta/CharSet/AsciiSet.hs +0/−96
- Text/Trifecta/Diagnostic/Prim.hs +29/−16
- Text/Trifecta/Diagnostic/Rendering/Prim.hs +14/−7
- Text/Trifecta/Parser.hs +2/−0
- Text/Trifecta/Parser/ByteString.hs +76/−0
- Text/Trifecta/Parser/Char.hs +73/−18
- Text/Trifecta/Parser/Class.hs +30/−22
- Text/Trifecta/Parser/Combinators.hs +6/−1
- Text/Trifecta/Parser/Prim.hs +24/−18
- Text/Trifecta/Parser/Step.hs +4/−4
- Text/Trifecta/Rope/Delta.hs +38/−42
- Text/Trifecta/Rope/Prim.hs +5/−5
- trifecta.cabal +3/−2
+ Text/Trifecta/ByteSet.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE BangPatterns, MagicHash #-}+-----------------------------------------------------------------------------+-- |+-- Module : Text.Trifecta.ByteSet+-- Copyright : Edward Kmett 2011+-- Bryan O'Sullivan 2008+-- License : BSD3+-- +-- Maintainer : ekmett@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- Fast set membership tests for byte values, The set representation is +-- unboxed for efficiency and uses a lookup table. This is a fairly minimal+-- API. You probably want to use CharSet.+-----------------------------------------------------------------------------+module Text.Trifecta.ByteSet+ (+ -- * Data type+ ByteSet(..)+ -- * Construction+ , fromList+ -- * Lookup+ , member+ ) where++import Data.Bits ((.&.), (.|.))+import Foreign.Storable (peekByteOff, pokeByteOff)+import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#)+import GHC.Word (Word8(W8#))+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as I+import qualified Data.ByteString.Unsafe as U++newtype ByteSet = ByteSet B.ByteString deriving (Eq, Ord, Show)++data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8++shiftR :: Int -> Int -> Int+shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#)++shiftL :: Word8 -> Int -> Word8+shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#))++index :: Int -> I+index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7))+{-# INLINE index #-}++fromList :: [Word8] -> ByteSet+fromList s0 = ByteSet $ I.unsafeCreate 32 $ \t -> do+ _ <- I.memset t 0 32+ let go [] = return ()+ go (c:cs) = do+ prev <- peekByteOff t byte :: IO Word8+ pokeByteOff t byte (prev .|. bit)+ go cs+ where I byte bit = index (fromIntegral c)+ go s0 ++-- | Check the set for membership.+member :: Word8 -> ByteSet -> Bool+member w (ByteSet t) = U.unsafeIndex t byte .&. bit /= 0+ where + I byte bit = index (fromIntegral w)
Text/Trifecta/CharSet.hs view
@@ -18,15 +18,17 @@ -- -- Designed to be imported qualified: -- --- > import Text.Trifecta.CharSet.Prim (CharSet)--- > import qualified Text.Trifecta.CharSet.Prim as CharSet+-- > import Text.Trifecta.CharSet (CharSet)+-- > import qualified Text.Trifecta.CharSet as CharSet --+ -------------------------------------------------------------------------------+-- ------------------------------------------------------------------------------- module Text.Trifecta.CharSet ( -- * Set type- CharSet+ CharSet(..) -- * Operators , (\\) -- * Query@@ -75,8 +77,11 @@ import Data.Data import Data.Function (on) import Data.IntSet (IntSet)-import Text.Trifecta.CharSet.AsciiSet (AsciiSet)-import qualified Text.Trifecta.CharSet.AsciiSet as AsciiSet+import Text.Trifecta.ByteSet (ByteSet)+import qualified Text.Trifecta.ByteSet as ByteSet+import Data.Bits hiding (complement)+import Data.Word+import Data.ByteString.Internal (c2w) import Data.Monoid (Monoid(..)) import qualified Data.IntSet as I import qualified Data.List as L@@ -84,11 +89,18 @@ import qualified Prelude as P import Text.Read -data CharSet = S !Bool AsciiSet !IntSet +data CharSet = CharSet !Bool {-# UNPACK #-} !ByteSet !IntSet charSet :: Bool -> IntSet -> CharSet-charSet b s = S b (AsciiSet.fromList (fmap toEnum (takeWhile (<= 0x7f) (I.toAscList s)))) s+charSet b s = CharSet b (ByteSet.fromList (fmap headByte (I.toAscList s))) s +headByte :: Int -> Word8+headByte i + | i <= 0x7f = toEnum i + | i <= 0x7ff = toEnum $ 0x80 + (i `shiftR` 6)+ | i <= 0xffff = toEnum $ 0xe0 + (i `shiftR` 12)+ | otherwise = toEnum $ 0xf0 + (i `shiftR` 18)+ pos :: IntSet -> CharSet pos = charSet True @@ -103,23 +115,23 @@ {-# INLINE build #-} map :: (Char -> Char) -> CharSet -> CharSet-map f (S True _ i) = pos (I.map (fromEnum . f . toEnum) i)-map f (S False _ i) = fromList $ P.map f $ P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh] +map f (CharSet True _ i) = pos (I.map (fromEnum . f . toEnum) i)+map f (CharSet False _ i) = fromList $ P.map f $ P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh] {-# INLINE map #-} isComplemented :: CharSet -> Bool-isComplemented (S True _ _) = False-isComplemented (S False _ _) = True+isComplemented (CharSet True _ _) = False+isComplemented (CharSet False _ _) = True {-# INLINE isComplemented #-} toList :: CharSet -> String-toList (S True _ i) = P.map toEnum (I.toList i)-toList (S False _ i) = P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh]+toList (CharSet True _ i) = P.map toEnum (I.toList i)+toList (CharSet False _ i) = P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh] {-# INLINE toList #-} toAscList :: CharSet -> String-toAscList (S True _ i) = P.map toEnum (I.toAscList i)-toAscList (S False _ i) = P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh]+toAscList (CharSet True _ i) = P.map toEnum (I.toAscList i)+toAscList (CharSet False _ i) = P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh] {-# INLINE toAscList #-} empty :: CharSet@@ -134,19 +146,19 @@ -- | /O(n)/ worst case null :: CharSet -> Bool-null (S True _ i) = I.null i-null (S False _ i) = I.size i == numChars+null (CharSet True _ i) = I.null i+null (CharSet False _ i) = I.size i == numChars {-# INLINE null #-} -- | /O(n)/ size :: CharSet -> Int-size (S True _ i) = I.size i-size (S False _ i) = numChars - I.size i+size (CharSet True _ i) = I.size i+size (CharSet False _ i) = numChars - I.size i {-# INLINE size #-} insert :: Char -> CharSet -> CharSet-insert c (S True _ i) = pos (I.insert (fromEnum c) i)-insert c (S False _ i) = neg (I.delete (fromEnum c) i)+insert c (CharSet True _ i) = pos (I.insert (fromEnum c) i)+insert c (CharSet False _ i) = neg (I.delete (fromEnum c) i) {-# INLINE insert #-} range :: Char -> Char -> CharSet@@ -155,42 +167,42 @@ | otherwise = empty delete :: Char -> CharSet -> CharSet-delete c (S True _ i) = pos (I.delete (fromEnum c) i)-delete c (S False _ i) = neg (I.insert (fromEnum c) i)+delete c (CharSet True _ i) = pos (I.delete (fromEnum c) i)+delete c (CharSet False _ i) = neg (I.insert (fromEnum c) i) {-# INLINE delete #-} complement :: CharSet -> CharSet-complement (S True s i) = S False s i-complement (S False s i) = S True s i+complement (CharSet True s i) = CharSet False s i+complement (CharSet False s i) = CharSet True s i {-# INLINE complement #-} union :: CharSet -> CharSet -> CharSet-union (S True _ i) (S True _ j) = pos (I.union i j)-union (S True _ i) (S False _ j) = neg (I.difference j i)-union (S False _ i) (S True _ j) = neg (I.difference i j)-union (S False _ i) (S False _ j) = neg (I.intersection i j)+union (CharSet True _ i) (CharSet True _ j) = pos (I.union i j)+union (CharSet True _ i) (CharSet False _ j) = neg (I.difference j i)+union (CharSet False _ i) (CharSet True _ j) = neg (I.difference i j)+union (CharSet False _ i) (CharSet False _ j) = neg (I.intersection i j) {-# INLINE union #-} intersection :: CharSet -> CharSet -> CharSet-intersection (S True _ i) (S True _ j) = pos (I.intersection i j)-intersection (S True _ i) (S False _ j) = pos (I.difference i j)-intersection (S False _ i) (S True _ j) = pos (I.difference j i)-intersection (S False _ i) (S False _ j) = neg (I.union i j)+intersection (CharSet True _ i) (CharSet True _ j) = pos (I.intersection i j)+intersection (CharSet True _ i) (CharSet False _ j) = pos (I.difference i j)+intersection (CharSet False _ i) (CharSet True _ j) = pos (I.difference j i)+intersection (CharSet False _ i) (CharSet False _ j) = neg (I.union i j) {-# INLINE intersection #-} difference :: CharSet -> CharSet -> CharSet -difference (S True _ i) (S True _ j) = pos (I.difference i j)-difference (S True _ i) (S False _ j) = pos (I.intersection i j)-difference (S False _ i) (S True _ j) = neg (I.union i j)-difference (S False _ i) (S False _ j) = pos (I.difference j i)+difference (CharSet True _ i) (CharSet True _ j) = pos (I.difference i j)+difference (CharSet True _ i) (CharSet False _ j) = pos (I.intersection i j)+difference (CharSet False _ i) (CharSet True _ j) = neg (I.union i j)+difference (CharSet False _ i) (CharSet False _ j) = pos (I.difference j i) {-# INLINE difference #-} member :: Char -> CharSet -> Bool-member c (S True b i)- | c <= toEnum 0x7f = AsciiSet.member c b+member c (CharSet True b i)+ | c <= toEnum 0x7f = ByteSet.member (c2w c) b | otherwise = I.member (fromEnum c) i-member c (S False b i) - | c <= toEnum 0x7f = not (AsciiSet.member c b)+member c (CharSet False b i) + | c <= toEnum 0x7f = not (ByteSet.member (c2w c) b) | otherwise = I.notMember (fromEnum c) i {-# INLINE member #-} @@ -199,34 +211,34 @@ {-# INLINE notMember #-} fold :: (Char -> b -> b) -> b -> CharSet -> b-fold f z (S True _ i) = I.fold (f . toEnum) z i-fold f z (S False _ i) = foldr f z $ P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh]+fold f z (CharSet True _ i) = I.fold (f . toEnum) z i+fold f z (CharSet False _ i) = foldr f z $ P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh] {-# INLINE fold #-} filter :: (Char -> Bool) -> CharSet -> CharSet -filter p (S True _ i) = pos (I.filter (p . toEnum) i)-filter p (S False _ i) = neg $ foldr (I.insert) i $ P.filter (\x -> (x `I.notMember` i) && not (p (toEnum x))) [ol..oh]+filter p (CharSet True _ i) = pos (I.filter (p . toEnum) i)+filter p (CharSet False _ i) = neg $ foldr (I.insert) i $ P.filter (\x -> (x `I.notMember` i) && not (p (toEnum x))) [ol..oh] {-# INLINE filter #-} partition :: (Char -> Bool) -> CharSet -> (CharSet, CharSet)-partition p (S True _ i) = (pos l, pos r)+partition p (CharSet True _ i) = (pos l, pos r) where (l,r) = I.partition (p . toEnum) i-partition p (S False _ i) = (neg (foldr I.insert i l), neg (foldr I.insert i r))+partition p (CharSet False _ i) = (neg (foldr I.insert i l), neg (foldr I.insert i r)) where (l,r) = L.partition (p . toEnum) $ P.filter (\x -> x `I.notMember` i) [ol..oh] {-# INLINE partition #-} overlaps :: CharSet -> CharSet -> Bool-overlaps (S True _ i) (S True _ j) = not (I.null (I.intersection i j))-overlaps (S True _ i) (S False _ j) = not (I.isSubsetOf j i)-overlaps (S False _ i) (S True _ j) = not (I.isSubsetOf i j)-overlaps (S False _ i) (S False _ j) = any (\x -> I.notMember x i && I.notMember x j) [ol..oh] -- not likely+overlaps (CharSet True _ i) (CharSet True _ j) = not (I.null (I.intersection i j))+overlaps (CharSet True _ i) (CharSet False _ j) = not (I.isSubsetOf j i)+overlaps (CharSet False _ i) (CharSet True _ j) = not (I.isSubsetOf i j)+overlaps (CharSet False _ i) (CharSet False _ j) = any (\x -> I.notMember x i && I.notMember x j) [ol..oh] -- not likely {-# INLINE overlaps #-} isSubsetOf :: CharSet -> CharSet -> Bool-isSubsetOf (S True _ i) (S True _ j) = I.isSubsetOf i j-isSubsetOf (S True _ i) (S False _ j) = I.null (I.intersection i j)-isSubsetOf (S False _ i) (S True _ j) = all (\x -> I.member x i && I.member x j) [ol..oh] -- not bloody likely-isSubsetOf (S False _ i) (S False _ j) = I.isSubsetOf j i+isSubsetOf (CharSet True _ i) (CharSet True _ j) = I.isSubsetOf i j+isSubsetOf (CharSet True _ i) (CharSet False _ j) = I.null (I.intersection i j)+isSubsetOf (CharSet False _ i) (CharSet True _ j) = all (\x -> I.member x i && I.member x j) [ol..oh] -- not bloody likely+isSubsetOf (CharSet False _ i) (CharSet False _ j) = I.isSubsetOf j i {-# INLINE isSubsetOf #-} fromList :: String -> CharSet @@ -299,7 +311,7 @@ -- returns an intset and if the charSet is positive fromCharSet :: CharSet -> (Bool, IntSet)-fromCharSet (S b _ i) = (b, i)+fromCharSet (CharSet b _ i) = (b, i) {-# INLINE fromCharSet #-} toCharSet :: IntSet -> CharSet
− Text/Trifecta/CharSet/AsciiSet.hs
@@ -1,96 +0,0 @@-{-# LANGUAGE BangPatterns, MagicHash #-}--------------------------------------------------------------------------------- |--- Module : Text.Trifecta.CharSet.AsciiSet--- Copyright : Edward Kmett 2011--- Bryan O'Sullivan 2008--- License : BSD3--- --- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : unknown------ Fast set membership tests for ASCII values, The--- set representation is unboxed for efficiency. For small sets, we--- test for membership using a binary search. For larger sets, we use--- a lookup table. -------------------------------------------------------------------------------module Text.Trifecta.CharSet.AsciiSet- (- -- * Data type- AsciiSet- -- * Construction- , fromList- -- * Lookup- , member- ) where--import Data.Bits ((.&.), (.|.))-import Foreign.Storable (peekByteOff, pokeByteOff)-import GHC.Base (Int(I#), iShiftRA#, narrow8Word#, shiftL#)-import GHC.Word (Word8(W8#))-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Internal as I-import qualified Data.ByteString.Unsafe as U--data AsciiSet - = Sorted !B.ByteString- | Table !B.ByteString- deriving (Eq, Ord, Show)---- | The lower bound on the size of a lookup table. We choose this to--- balance table density against performance.-tableCutoff :: Int-tableCutoff = 8---- | Create a set.-fromList :: [Char] -> AsciiSet-fromList s - | B.length bs < tableCutoff = Sorted (B.sort bs)- | otherwise = Table (mkTable bs)- where- bs = B8.pack (filter (<= toEnum 0x7f) s)---- | Check the set for membership.-member :: Char -> AsciiSet -> Bool-member c (Table t) = U.unsafeIndex t byte .&. bit /= 0- where - i = fromEnum c- I byte bit = index i-member c (Sorted s) = search 0 (B.length s - 1)- where - w = I.c2w c- search lo hi- | hi < lo = False- | otherwise = let mid = (lo + hi) `div` 2 in- case compare w (U.unsafeIndex s mid) of- GT -> search (mid + 1) hi- LT -> search lo (mid - 1)- _ -> True--data I = I {-# UNPACK #-} !Int {-# UNPACK #-} !Word8--shiftR :: Int -> Int -> Int-shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#)--shiftL :: Word8 -> Int -> Word8-shiftL (W8# x#) (I# i#) = W8# (narrow8Word# (x# `shiftL#` i#))--index :: Int -> I-index i = I (i `shiftR` 3) (1 `shiftL` (i .&. 7))-{-# INLINE index #-}--mkTable :: B.ByteString -> B.ByteString-mkTable s = I.unsafeCreate 32 $ \t -> do- _ <- I.memset t 0 32- U.unsafeUseAsCStringLen s $ \(p, l) ->- let loop n - | n == l = return ()- | otherwise = do- c <- peekByteOff p n :: IO Word8- let I byte bit = index (fromIntegral c)- prev <- peekByteOff t byte :: IO Word8- pokeByteOff t byte (prev .|. bit)- loop (n + 1)- in loop 0
Text/Trifecta/Diagnostic/Prim.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} module Text.Trifecta.Diagnostic.Prim ( Diagnostic(..) , tellDiagnostic@@ -7,6 +7,7 @@ import Control.Applicative import Control.Comonad import Control.Monad (guard)+import Control.Exception import Control.Monad.Writer.Class import Data.Functor.Apply import Data.Foldable@@ -24,21 +25,24 @@ import Text.PrettyPrint.Free import System.Console.Terminfo.PrettyPrint import Prelude hiding (log)+import Data.Typeable -data Diagnostic m = Diagnostic !Rendering !DiagnosticLevel m [Diagnostic m]- deriving Show+data Diagnostic m = Diagnostic !(Either String Rendering) !DiagnosticLevel m [Diagnostic m]+ deriving (Show, Typeable) +instance (Typeable m, Show m) => Exception (Diagnostic m)+ tellDiagnostic :: (MonadWriter t m, Reducer (Diagnostic e) t) => Diagnostic e -> m () tellDiagnostic = tell . unit instance Renderable (Diagnostic m) where- render (Diagnostic r _ _ _) = r+ render (Diagnostic r _ _ _) = either (const emptyRendering) id r instance HasDelta (Diagnostic m) where- delta (Diagnostic r _ _ _) = delta r+ delta (Diagnostic r _ _ _) = either (const mempty) delta r instance HasBytes (Diagnostic m) where- bytes = bytes . delta+ bytes (Diagnostic r _ _ _) = either (const 0) (bytes . delta) r instance Extend Diagnostic where extend f d@(Diagnostic r l _ xs) = Diagnostic r l (f d) (map (extend f) xs)@@ -47,17 +51,28 @@ extract (Diagnostic _ _ m _) = m instance Pretty m => Pretty (Diagnostic m) where- pretty (Diagnostic r l m xs) = vsep $- [ pretty (delta r) <> char ':' <+> pretty l <> char ':' <+> nest 4 (pretty m) ] - <> (pretty r <$ guard (not (nullRendering r)))- <> (indent 2 (prettyList xs) <$ guard (not (null xs)))+ pretty (Diagnostic src l m xs) = case src of + Left p -> vsep $ [pretty p <> msg]+ <|> children+ Right r -> vsep $ [pretty (delta r) <> msg]+ <|> pretty r <$ guard (not (nullRendering r))+ <|> children+ where + msg = char ':' <+> pretty l <> char ':' <+> nest 4 (pretty m) + children = indent 2 (prettyList xs) <$ guard (not (null xs))+ prettyList = vsep . Prelude.map pretty instance PrettyTerm m => PrettyTerm (Diagnostic m) where- prettyTerm (Diagnostic r l m xs) = vsep $ - [ prettyTerm (delta r) <> char ':' <+> prettyTerm l <> char ':' <+> nest 4 (prettyTerm m) ]- <> (prettyTerm r <$ guard (not (nullRendering r)))- <> (indent 2 (prettyTermList xs) <$ guard (not (null xs)))+ prettyTerm (Diagnostic src l m xs) = case src of + Left p -> vsep $ [prettyTerm p <> msg]+ <|> children+ Right r -> vsep $ [prettyTerm (delta r) <> msg]+ <|> prettyTerm r <$ guard (not (nullRendering r))+ <|> children+ where + msg = char ':' <+> prettyTerm l <> char ':' <+> nest 4 (prettyTerm m) + children = indent 2 (prettyTermList xs) <$ guard (not (null xs)) prettyTermList = vsep . Prelude.map prettyTerm instance Functor Diagnostic where@@ -78,5 +93,3 @@ traverse1 f (Diagnostic r l m (x:xs)) = (\fm (y:|ys) -> Diagnostic r l fm (y:ys)) <$> f m <.> traverse1 (traverse1 f) (x:|xs)--
Text/Trifecta/Diagnostic/Rendering/Prim.hs view
@@ -32,6 +32,7 @@ import Data.Traversable import Prelude as P import Prelude hiding (span)+import System.Console.Terminfo.Color import System.Console.Terminfo.PrettyPrint import Text.PrettyPrint.Free hiding (column) import Text.Trifecta.Rope.Bytes@@ -108,15 +109,21 @@ render = id class Source t where- source :: t -> (Int, Lines -> Lines)+ source :: t -> (Int, Lines -> Lines) {- return whether to append EOF, the number of bytes, and the the line -} instance Source String where- source s = (P.length s', draw [] 0 0 s') where - s' = go 0 s- go n ('\t':xs) = let t = 8 - mod n 8 in P.replicate t ' ' ++ go (n + t) xs- go _ ('\n':_) = []- go n (x:xs) = x : go (n + 1) xs- go _ [] = []+ source s + | Prelude.elem '\n' s = ( ls, draw [] 0 0 s') + | otherwise = ( ls + Prelude.length end, draw [soft (Foreground Blue), soft Bold] 0 ls end . draw [] 0 0 s') + where+ end = "<EOF>" + -- end = "\xabEOF\bb"+ s' = go 0 s+ ls = Prelude.length s' + go n ('\t':xs) = let t = 8 - mod n 8 in P.replicate t ' ' ++ go (n + t) xs+ go _ ('\n':_) = []+ go n (x:xs) = x : go (n + 1) xs+ go _ [] = [] instance Source ByteString where source = source . UTF8.toString
Text/Trifecta/Parser.hs view
@@ -1,5 +1,6 @@ module Text.Trifecta.Parser ( module Text.Trifecta.Parser.Prim+ , module Text.Trifecta.Parser.ByteString , module Text.Trifecta.Parser.Class , module Text.Trifecta.Parser.Char , module Text.Trifecta.Parser.Combinators@@ -17,6 +18,7 @@ ) where import Text.Trifecta.Parser.Prim+import Text.Trifecta.Parser.ByteString import Text.Trifecta.Parser.Class import Text.Trifecta.Parser.Char import Text.Trifecta.Parser.Combinators
+ Text/Trifecta/Parser/ByteString.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Text.Trifecta.Parser.ByteString+-- Copyright : (c) Edward Kmett 2011+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : ekmett@gmail.com+-- Stability : experimental+-- Portability : non-portable (mptcs, fundeps)+-- +-- Loading a file as a strict bytestring in one step.+--+-----------------------------------------------------------------------------+++module Text.Trifecta.Parser.ByteString+ ( parseFromFile+ , parseFromFileEx+ ) where++import Control.Applicative+import Control.Monad (unless)+import Data.Monoid+import Data.Foldable+import qualified Data.ByteString as B+import System.Console.Terminfo.PrettyPrint+import Text.Trifecta.Diagnostic.Prim+import Text.Trifecta.Parser.Class+import Text.Trifecta.Parser.Prim+import Text.Trifecta.Parser.Step+import Text.Trifecta.Rope.Delta+import Text.Trifecta.Parser.Result+import Data.Sequence as Seq+import qualified Data.ByteString.UTF8 as UTF8+import Text.Trifecta.Rope.Prim+import qualified Data.FingerTree as F+++-- | @parseFromFile p filePath@ runs a parser @p@ on the+-- input read from @filePath@ using 'ByteString.readFile'. All diagnostic messages+-- emitted over the course of the parse attempt are shown to the user on the console.+--+-- > main = do{ result <- parseFromFile numbers "digits.txt"+-- > ; case result of+-- > Nothing -> return ()+-- > Just a -> print $ sum a+-- > }++parseFromFile :: Show a => Parser String a -> String -> IO (Maybe a)+parseFromFile p fn = do + (xs, result) <- parseFromFileEx p fn+ unless (Seq.null xs) $ displayLn $ toList xs+ return result++-- | @parseFromFileEx p filePath@ runs a parser @p@ on the+-- input read from @filePath@ using 'ByteString.readFile'. Returns all diagnostic messages+-- emitted over the course of the parse and the answer if the parse was successful.+--+-- > main = do{ (xs, result) <- parseFromFileEx numbers "digits.txt"+-- > ; unless (Seq.null xs) $ displayLn (toList xs)+-- > ; case result of+-- > Nothing -> return ()+-- > Just a -> print $ sum a+-- > }++parseFromFileEx :: Show a => Parser String a -> String -> IO (Seq (Diagnostic TermDoc), Maybe a)+parseFromFileEx p fn = do+ i <- B.readFile fn+ case starve+ $ feed (rope (F.fromList [LineDirective (UTF8.fromString fn) 0, strand i]))+ $ stepParser (fmap prettyTerm) (why prettyTerm) (release (Directed n 0 0 0 0) *> p) mempty mempty mempty of+ Success xs a -> return (xs, Just a )+ Failure xs e -> return (xs |> e, Nothing)+ where n = UTF8.fromString fn
Text/Trifecta/Parser/Char.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, FlexibleInstances, FlexibleContexts, PatternGuards #-}+{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-} module Text.Trifecta.Parser.Char ( oneOf -- :: MonadParser m => [Char] -> m Char , noneOf -- :: MonadParser m => [Char] -> m Char--- , spaces -- :: MonadParser m => m ()+ , oneOfSet -- :: MonadParser m => CharSet -> m Char+ , noneOfSet -- :: MonadParser m => CharSet -> m Char+ , spaces -- :: MonadParser m => m () , space -- :: MonadParser m => m Char , newline -- :: MonadParser m => m Char , tab -- :: MonadParser m => m Char@@ -14,6 +17,7 @@ , hexDigit -- :: MonadParser m => m Char , octDigit -- :: MonadParser m => m Char , char -- :: MonadParser m => Char -> m Char+ , notChar -- :: MonadParser m => Char -> m Char , anyChar -- :: MonadParser m => m Char , string -- :: MonadParser m => String -> m String , byteString -- :: MonadParser m => ByteString -> m ByteString@@ -24,7 +28,12 @@ import Control.Monad (guard) import Text.Trifecta.Parser.Class import Text.Trifecta.Rope.Delta-import Data.ByteString as Strict hiding (empty, all, elem)+import qualified Data.IntSet as IntSet+import Text.Trifecta.CharSet (CharSet(..))+import qualified Text.Trifecta.CharSet as CharSet+import qualified Text.Trifecta.ByteSet as ByteSet+import qualified Data.ByteString as Strict+import Data.ByteString.Internal (w2c,c2w) import Data.ByteString.UTF8 as UTF8 -- | @oneOf cs@ succeeds if the current character is in the supplied@@ -33,8 +42,8 @@ -- -- > vowel = oneOf "aeiou" oneOf :: MonadParser m => [Char] -> m Char-oneOf cs | all ((< 0x80) . fromEnum) cs = satisfyAscii (\c -> elem c cs)- | otherwise = satisfy (\c -> elem c cs)+oneOf xs = oneOfSet (CharSet.fromList xs)+{-# INLINE oneOf #-} -- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current -- character /not/ in the supplied list of characters @cs@. Returns the@@ -42,71 +51,117 @@ -- -- > consonant = noneOf "aeiou" noneOf :: MonadParser m => [Char] -> m Char-noneOf cs | all ((< 0x80) . fromEnum) cs = satisfyAscii (\c -> not (elem c cs))- | otherwise = satisfy (\c -> not (elem c cs))+noneOf xs = noneOfSet (CharSet.fromList xs)+{-# INLINE noneOf #-} --- | Skips /zero/ or more white space characters. See also 'skipMany'.--- spaces :: MonadParser m => m ()--- spaces = skipMany space <?> "white space"+-- | @oneOfSet cs@ succeeds if the current character is in the supplied+-- set of characters @cs@. Returns the parsed character. See also+-- 'satisfy'.+-- +-- > vowel = oneOf "aeiou"+oneOfSet :: MonadParser m => CharSet -> m Char+oneOfSet (CharSet True bs is)+ | (_,r) <- IntSet.split 0x80 is, IntSet.null r = w2c <$> satisfy8 (\w -> ByteSet.member w bs)+ | otherwise = satisfy (\c -> IntSet.member (fromEnum c) is)+oneOfSet (CharSet False bs is) + | (_,r) <- IntSet.split 0x80 is, not (IntSet.null r) = satisfy (\c -> not (IntSet.member (fromEnum c) is))+ | otherwise = satisfyAscii (\c -> not (ByteSet.member (c2w c) bs))+{-# INLINE oneOfSet #-}+ +-- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current+-- character /not/ in the supplied list of characters @cs@. Returns the+-- parsed character.+--+-- > consonant = noneOf "aeiou"+noneOfSet :: MonadParser m => CharSet -> m Char+noneOfSet s = oneOfSet (CharSet.complement s)+{-# INLINE noneOfSet #-} +-- | Skips /zero/ or more white space characters. See also 'skipMany' and+-- 'whiteSpace'.+spaces :: MonadParser m => m ()+spaces = skipMany space <?> "white space"+ -- | Parses a white space character (any character which satisfies 'isSpace') -- Returns the parsed character. space :: MonadParser m => m Char space = satisfy isSpace <?> "space"+{-# INLINE space #-} -- | Parses a newline character (\'\\n\'). Returns a newline character. newline :: MonadParser m => m Char newline = char '\n' <?> "new-line"+{-# INLINE newline #-} -- | Parses a tab character (\'\\t\'). Returns a tab character. tab :: MonadParser m => m Char tab = char '\t' <?> "tab"+{-# INLINE tab #-} -- | Parses an upper case letter (a character between \'A\' and \'Z\'). -- Returns the parsed character. upper :: MonadParser m => m Char upper = satisfy isUpper <?> "uppercase letter"+{-# INLINE upper #-} -- | Parses a lower case character (a character between \'a\' and \'z\'). -- Returns the parsed character. lower :: MonadParser m => m Char lower = satisfy isLower <?> "lowercase letter"+{-# INLINE lower #-} -- | Parses a letter or digit (a character between \'0\' and \'9\'). -- Returns the parsed character. alphaNum :: MonadParser m => m Char alphaNum = satisfy isAlphaNum <?> "letter or digit"+{-# INLINE alphaNum #-} -- | Parses a letter (an upper case or lower case character). Returns the -- parsed character. letter :: MonadParser m => m Char letter = satisfy isAlpha <?> "letter"+{-# INLINE letter #-} -- | Parses a digit. Returns the parsed character. digit :: MonadParser m => m Char digit = satisfy isDigit <?> "digit"+{-# INLINE digit #-} -- | Parses a hexadecimal digit (a digit or a letter between \'a\' and -- \'f\' or \'A\' and \'F\'). Returns the parsed character. hexDigit :: MonadParser m => m Char hexDigit = satisfy isHexDigit <?> "hexadecimal digit"+{-# INLINE hexDigit #-} -- | Parses an octal digit (a character between \'0\' and \'7\'). Returns -- the parsed character. octDigit :: MonadParser m => m Char-octDigit = satisfy isOctDigit <?> "octal digit"+octDigit = satisfy isOctDigit <?> "octal digit"+{-# INLINE octDigit #-} -- | @char c@ parses a single character @c@. Returns the parsed -- character (i.e. @c@). -- -- > semiColon = char ';' char :: MonadParser m => Char -> m Char-char c | fromEnum c <= 0x7f = satisfyAscii (c ==) <?> show [c]- | otherwise = satisfy (c ==) <?> show [c]+char c + | c <= w2c 0x7f, w <- c2w c = w2c <$> satisfy8 (w ==) <?> show [c]+ | otherwise = satisfy (c ==) <?> show [c]+{-# INLINE char #-} +-- | @char c@ parses a single character @c@. Returns the parsed+-- character (i.e. @c@).+--+-- > semiColon = char ';'+notChar :: MonadParser m => Char -> m Char+notChar c + | fromEnum c <= 0x7f = satisfyAscii (c /=)+ | otherwise = satisfy (c /=)+{-# INLINE notChar #-}+ -- | This parser succeeds for any character. Returns the parsed character. anyChar :: MonadParser m => m Char anyChar = satisfy (const True)@@ -117,24 +172,24 @@ -- > divOrMod = string "div" -- > <|> string "mod" string :: MonadParser m => String -> m String-string s = s <$ byteString (UTF8.fromString s)+string s = s <$ byteString (UTF8.fromString s) <?> show s -- | @byteString s@ parses a sequence of bytes given by @s@. Returns -- the parsed byteString (i.e. @s@). -- -- > divOrMod = string "div" -- > <|> string "mod"-byteString :: MonadParser m => ByteString -> m ByteString+byteString :: MonadParser m => Strict.ByteString -> m Strict.ByteString byteString bs = do r <- restOfLine let lr = Strict.length r lbs = Strict.length bs guard $ lr > 0 case compare lbs lr of- LT | bs `isPrefixOf` r -> bs <$ skipping (delta bs)+ LT | bs `Strict.isPrefixOf` r -> bs <$ skipping (delta bs) | otherwise -> empty EQ | bs == r -> bs <$ skipping (delta bs) | otherwise -> empty- GT | r `isPrefixOf` bs -> bs <$ skipping (delta r) *> byteString (Strict.drop lr bs)+ GT | r `Strict.isPrefixOf` bs -> bs <$ skipping (delta r) *> byteString (Strict.drop lr bs) | otherwise -> empty- <?> UTF8.toString bs+ <?> show (UTF8.toString bs)
Text/Trifecta/Parser/Class.hs view
@@ -13,6 +13,7 @@ ----------------------------------------------------------------------------- module Text.Trifecta.Parser.Class ( MonadParser(..)+ , satisfyAscii , restOfLine , (<?>) , skipping@@ -33,9 +34,11 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Identity import Data.Monoid+import Data.Word -- import Control.Monad.Trans.Maybe.Strict as Strict -- import Control.Monad.Trans.Either.Strict as Strict import Data.ByteString as Strict+import Data.ByteString.Internal (w2c) import Data.Semigroup import Data.Set as Set import Text.Trifecta.Rope.Delta@@ -56,16 +59,12 @@ skipMany :: m a -> m () skipMany p = () <$ many p - -- actions that definitely commit- release :: Delta -> m ()- satisfy :: (Char -> Bool) -> m Char-- satisfyAscii :: (Char -> Bool) -> m Char- satisfyAscii f = toEnum . fromEnum <$> satisfy (f . toEnum . fromEnum)+ release :: Delta -> m ()+ satisfy :: (Char -> Bool) -> m Char+ satisfy8 :: (Word8 -> Bool) -> m Word8 instance MonadParser m => MonadParser (Lazy.StateT s m) where- satisfy = lift . satisfy try (Lazy.StateT m) = Lazy.StateT $ try . m labels (Lazy.StateT m) ss = Lazy.StateT $ \s -> labels (m s) ss line = lift line@@ -73,10 +72,10 @@ mark = lift mark release = lift . release unexpected = lift . unexpected- satisfyAscii = lift . satisfyAscii+ satisfy = lift . satisfy+ satisfy8 = lift . satisfy8 instance MonadParser m => MonadParser (Strict.StateT s m) where- satisfy = lift . satisfy try (Strict.StateT m) = Strict.StateT $ try . m labels (Strict.StateT m) ss = Strict.StateT $ \s -> labels (m s) ss line = lift line@@ -84,10 +83,10 @@ mark = lift mark release = lift . release unexpected = lift . unexpected- satisfyAscii = lift . satisfyAscii+ satisfy = lift . satisfy+ satisfy8 = lift . satisfy8 instance MonadParser m => MonadParser (ReaderT e m) where- satisfy = lift . satisfy try (ReaderT m) = ReaderT $ try . m labels (ReaderT m) ss = ReaderT $ \s -> labels (m s) ss line = lift line@@ -95,10 +94,10 @@ mark = lift mark release = lift . release unexpected = lift . unexpected- satisfyAscii = lift . satisfyAscii+ satisfy = lift . satisfy+ satisfy8 = lift . satisfy8 instance (MonadParser m, Monoid w) => MonadParser (Strict.WriterT w m) where- satisfy = lift . satisfy try (Strict.WriterT m) = Strict.WriterT $ try m labels (Strict.WriterT m) ss = Strict.WriterT $ labels m ss line = lift line@@ -106,10 +105,10 @@ mark = lift mark release = lift . release unexpected = lift . unexpected- satisfyAscii = lift . satisfyAscii+ satisfy = lift . satisfy+ satisfy8 = lift . satisfy8 instance (MonadParser m, Monoid w) => MonadParser (Lazy.WriterT w m) where- satisfy = lift . satisfy try (Lazy.WriterT m) = Lazy.WriterT $ try m labels (Lazy.WriterT m) ss = Lazy.WriterT $ labels m ss line = lift line@@ -117,10 +116,10 @@ mark = lift mark release = lift . release unexpected = lift . unexpected- satisfyAscii = lift . satisfyAscii+ satisfy = lift . satisfy+ satisfy8 = lift . satisfy8 instance (MonadParser m, Monoid w) => MonadParser (Lazy.RWST r w s m) where- satisfy = lift . satisfy try (Lazy.RWST m) = Lazy.RWST $ \r s -> try (m r s) labels (Lazy.RWST m) ss = Lazy.RWST $ \r s -> labels (m r s) ss line = lift line@@ -128,10 +127,10 @@ mark = lift mark release = lift . release unexpected = lift . unexpected- satisfyAscii = lift . satisfyAscii+ satisfy = lift . satisfy+ satisfy8 = lift . satisfy8 instance (MonadParser m, Monoid w) => MonadParser (Strict.RWST r w s m) where- satisfy = lift . satisfy try (Strict.RWST m) = Strict.RWST $ \r s -> try (m r s) labels (Strict.RWST m) ss = Strict.RWST $ \r s -> labels (m r s) ss line = lift line@@ -139,10 +138,10 @@ mark = lift mark release = lift . release unexpected = lift . unexpected- satisfyAscii = lift . satisfyAscii+ satisfy = lift . satisfy+ satisfy8 = lift . satisfy8 instance MonadParser m => MonadParser (IdentityT m) where- satisfy = lift . satisfy try (IdentityT m) = IdentityT $ try m labels (IdentityT m) = IdentityT . labels m line = lift line@@ -150,8 +149,13 @@ mark = lift mark release = lift . release unexpected = lift . unexpected- satisfyAscii = lift . satisfyAscii+ satisfy = lift . satisfy+ satisfy8 = lift . satisfy8 +satisfyAscii :: MonadParser m => (Char -> Bool) -> m Char+satisfyAscii p = w2c <$> satisfy8 (\w -> w <= 0x7f && p (w2c w))+{-# INLINE satisfyAscii #-}+ -- instance (MonadParser m, Monoid w) => MonadParser (MaybeT m) where -- instance (Error e, MonadParser m, Monoid w) => MonadParser (ErrorT e m) where @@ -160,12 +164,14 @@ skipping d = do m <- mark release (m <> d)+{-# INLINE skipping #-} -- | grab the remainder of the current line restOfLine :: MonadParser m => m ByteString restOfLine = do m <- mark Strict.drop (columnByte m) <$> line+{-# INLINE restOfLine #-} -- | label a parser with a name (<?>) :: MonadParser m => m a -> String -> m a@@ -178,6 +184,7 @@ a <- pa r <- mark liftIt $ f a <$> sliceIt m r+{-# INLINE slicedWith #-} -- | run a parser, grabbing all of the text between its start and end points and discarding the original result sliced :: MonadParser m => m a -> m ByteString@@ -185,3 +192,4 @@ rend :: MonadParser m => m Rendering rend = rendering <$> mark <*> line+{-# INLINE rend #-}
Text/Trifecta/Parser/Combinators.hs view
@@ -40,6 +40,8 @@ import Data.Traversable import Control.Applicative+import Control.Monad+import qualified Data.ByteString as B import Text.Trifecta.Parser.Class -- | @choice ps@ tries to apply the parsers in the list @ps@ in order,@@ -188,7 +190,10 @@ -- -- > eof = notFollowedBy anyChar <?> "end of input" eof :: MonadParser m => m ()-eof = notFollowedBy (satisfy (const True)) <?> "end of input"+eof = do+ l <- restOfLine + guard $ B.null l+ <?> "end of input" -- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser -- does not consume any input. This parser can be used to implement the
Text/Trifecta/Parser/Prim.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, Rank2Types, FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, Rank2Types, FlexibleInstances, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Text.Trifecta.Parser.Prim@@ -18,6 +18,7 @@ , manyAccum ) where + import Control.Applicative import Control.Monad.Error.Class import Control.Monad.Writer.Class@@ -155,7 +156,7 @@ errWith ds rs e = Parser $ \_ ee _ _ -> ee mempty { errMessage = Err rs Error e ds } logWith v ds rs e = Parser $ \eo _ _ _ l d bs -> - eo () mempty (l |> Diagnostic (addCaret d $ Prelude.foldr (<>) (rendering d bs) rs) v e ds) d bs+ eo () mempty (l |> Diagnostic (Right $ addCaret d $ Prelude.foldr (<>) (rendering d bs) rs) v e ds) d bs instance MonadError (ErrState e) (Parser e) where throwError m = Parser $ \_ ee _ _ -> ee m@@ -201,20 +202,22 @@ Nothing -> ee mempty { errMessage = FailErr "unexpected EOF" } l d bs Just (c, xs) | not (f c) -> ee mempty l d bs- | Strict.null xs -> let ddc = d <> delta c in- join $ fillIt (co c mempty l ddc bs) (co c mempty l) ddc+ | Strict.null xs -> let !ddc = d <> delta c + !bs' = if c == '\n' then mempty else bs+ in join $ fillIt (co c mempty l ddc bs') (co c mempty l) ddc | otherwise -> co c mempty l (d <> delta c) bs {-# INLINE satisfy #-}- satisfyAscii f = Parser $ \ _ ee co _ l d bs ->+ satisfy8 f = Parser $ \ _ ee co _ l d bs -> let b = columnByte d in if b >= 0 && b < Strict.length bs then case toEnum $ fromEnum $ Strict.index bs b of c | not (f c) -> ee mempty l d bs- | b == Strict.length bs - 1 -> let ddc = d <> delta c in - join $ fillIt (co c mempty l ddc bs) (co c mempty l) ddc+ | b == Strict.length bs - 1 -> let !ddc = d <> delta c+ !bs' = if c == 10 then mempty else bs+ in join $ fillIt (co c mempty l ddc bs') (co c mempty l) ddc | otherwise -> co c mempty l (d <> delta c) bs else ee mempty { errMessage = FailErr "unexpected EOF" } l d bs- {-# INLINE satisfyAscii #-}+ {-# INLINE satisfy8 #-} data St e a = JuSt a !(ErrState e) !(ErrLog e) !Delta !ByteString | NoSt !(ErrState e) !(ErrLog e) !Delta !ByteString@@ -236,20 +239,23 @@ why :: Pretty e => (e -> Doc t) -> ErrState e -> Delta -> ByteString -> Diagnostic (Doc t) why pp (ErrState ss m) d bs - | Set.null ss = explicate m - | otherwise = expected <$> explicate m+ | Set.null ss = explicateWith empty m + | knownErr m = explicateWith (char ',' <+> ex) m+ | otherwise = Diagnostic r Error ex [] where- expected doc = doc <> text ", expected" <+> fillSep (punctuate (char ',') $ text <$> toList ss)- r = addCaret d $ rendering d bs- explicate EmptyErr = Diagnostic r Error (text "unspecified error") []- explicate (FailErr s) = Diagnostic r Error (fillSep $ text <$> words s) []- explicate (PanicErr s) = Diagnostic r Fatal (fillSep $ text <$> words s) []- explicate (Err rs l e es) = Diagnostic (addCaret d $ Prelude.foldr (<>) (rendering d bs) rs) l (pp e) (fmap (fmap pp) es)+ ex = text "expected" <+> fillSep (punctuate (char ',') $ text <$> toList ss) -- for once I wish I was writing this in Inform 7+ r = Right $ addCaret d $ rendering d bs+ explicateWith x EmptyErr = Diagnostic r Error ((text "unspecified error") <> x) []+ explicateWith x (FailErr s) = Diagnostic r Error ((fillSep $ text <$> words s) <> x) []+ explicateWith x (PanicErr s) = Diagnostic r Panic ((fillSep $ text <$> words s) <> x) []+ explicateWith x (Err rs l e es) = Diagnostic r' l (pp e <> x) (fmap (fmap pp) es)+ where r' = Right $ addCaret d $ Prelude.foldr (<>) (rendering d bs) rs parseTest :: Show a => Parser String a -> String -> IO ()-parseTest p s = case starve $ feed st $ UTF8.fromString s of+parseTest p s = case starve + $ feed (UTF8.fromString s) + $ stepParser (fmap prettyTerm) (why prettyTerm) (release mempty *> p) mempty mempty mempty of Failure xs e -> displayLn $ prettyTerm $ toList (xs |> e) Success xs a -> do unless (Seq.null xs) $ displayLn $ prettyTerm $ toList xs print a- where st = stepParser (fmap prettyTerm) (why prettyTerm) (release mempty *> p) mempty mempty mempty
Text/Trifecta/Parser/Step.hs view
@@ -36,10 +36,10 @@ bimap f _ (StepFail r xs e) = StepFail r (fmap (fmap f) xs) (fmap f e) bimap f g (StepCont r z k) = StepCont r (bimap f g z) (bimap f g . k) -feed :: Reducer t Rope => Step e r -> t -> Step e r-feed (StepDone r xs a) t = StepDone (snoc r t) xs a-feed (StepFail r xs e) t = StepFail (snoc r t) xs e-feed (StepCont r _ k) t = k (snoc r t)+feed :: Reducer t Rope => t -> Step e r -> Step e r+feed t (StepDone r xs a) = StepDone (snoc r t) xs a+feed t (StepFail r xs e) = StepFail (snoc r t) xs e+feed t (StepCont r _ k) = k (snoc r t) starve :: Step e a -> Result e a starve (StepDone _ xs a) = Success xs a
Text/Trifecta/Rope/Delta.hs view
@@ -38,12 +38,6 @@ {-# UNPACK #-} !Int -- the number of bytes since the last newline deriving (Eq, Ord, Show) -columnByte :: Delta -> Int-columnByte (Columns _ b) = b-columnByte (Tab _ _ b) = b-columnByte (Lines _ _ _ b) = b-columnByte (Directed _ _ _ _ b) = b- instance (HasDelta l, HasDelta r) => HasDelta (Either l r) where delta = either delta delta @@ -57,11 +51,7 @@ Lines l c _ _ -> k f l c Directed fn l c _ _ -> k (UTF8.toString fn) l c where - k fn ln cn = bold (string fn) - <> char ':' - <> bold (int (ln + 1)) - <> char ':' - <> bold (int (cn + 1))+ k fn ln cn = bold (string fn) <> char ':' <> bold (int (ln+1)) <> char ':' <> bold (int (cn+1)) f = "(interactive)" column :: HasDelta t => t -> Int@@ -70,7 +60,15 @@ Tab b a _ -> nextTab b + a Lines _ c _ _ -> c Directed _ _ c _ _ -> c+{-# INLINE column #-} +columnByte :: Delta -> Int+columnByte (Columns _ b) = b+columnByte (Tab _ _ b) = b+columnByte (Lines _ _ _ b) = b+columnByte (Directed _ _ _ _ b) = b+{-# INLINE columnByte #-}+ instance HasBytes Delta where bytes (Columns _ b) = b bytes (Tab _ _ b) = b@@ -88,40 +86,36 @@ mappend = (<>) instance Semigroup Delta where- Columns c a <> Columns d b = Columns (c + d) (a + b)- Columns c a <> Tab x y b = Tab (c + x) y (a + b)- Columns _ a <> Lines l c t a' = Lines l c (t + a) a'- Columns _ a <> Directed p l c t a' = Directed p l c (t + a) a'- Lines l c t a <> Columns d b = Lines l (c + d) (t + b) (a + b)- Lines l c t a <> Tab x y b = Lines l (nextTab (c + x) + y) (t + b) (a + b)- Lines l _ t _ <> Lines m d t' b = Lines (l + m) d (t + t') b- Lines _ _ t _ <> Directed p l c t' a = Directed p l c (t + t') a- Tab x y a <> Columns d b = Tab x (y + d) (a + b)- Tab x y a <> Tab x' y' b = Tab x (nextTab (y + x') + y') (a + b) - Tab _ _ a <> Lines l c t a' = Lines l c (t + a) a'- Tab _ _ a <> Directed p l c t a' = Directed p l c (t + a) a' - Directed p l c t a <> Columns d b = Directed p l (c + d) (t + b) (a + b)- Directed p l c t a <> Tab x y b = Directed p l (nextTab (c + x) + y) (t + b) (a + b)- Directed p l _ t a <> Lines m d t' b = Directed p (l + m) d (t + t') (a + b)- Directed _ _ _ t _ <> Directed p' l' c' t' b = Directed {- p + l + -} p' l' c' (t + t') b+ Columns c a <> Columns d b = Columns (c + d) (a + b)+ Columns c a <> Tab x y b = Tab (c + x) y (a + b)+ Columns _ a <> Lines l c t a' = Lines l c (t + a) a'+ Columns _ a <> Directed p l c t a' = Directed p l c (t + a) a'+ Lines l c t a <> Columns d b = Lines l (c + d) (t + b) (a + b)+ Lines l c t a <> Tab x y b = Lines l (nextTab (c + x) + y) (t + b) (a + b)+ Lines l _ t _ <> Lines m d t' b = Lines (l + m) d (t + t') b+ Lines _ _ t _ <> Directed p l c t' a = Directed p l c (t + t') a+ Tab x y a <> Columns d b = Tab x (y + d) (a + b)+ Tab x y a <> Tab x' y' b = Tab x (nextTab (y + x') + y') (a + b) + Tab _ _ a <> Lines l c t a' = Lines l c (t + a ) a'+ Tab _ _ a <> Directed p l c t a' = Directed p l c (t + a ) a' + Directed p l c t a <> Columns d b = Directed p l (c + d) (t + b ) (a + b)+ Directed p l c t a <> Tab x y b = Directed p l (nextTab (c + x) + y) (t + b ) (a + b)+ Directed p l _ t _ <> Lines m d t' b = Directed p (l + m) d (t + t') b+ Directed _ _ _ t _ <> Directed p l c t' b = Directed p l c (t + t') b nextTab :: Int -> Int nextTab x = x + (8 - mod x 8)+{-# INLINE nextTab #-} rewind :: Delta -> Delta rewind (Lines n _ b d) = Lines n 0 (b - d) 0 rewind (Directed p n _ b d) = Directed p n 0 (b - d) 0 rewind _ = Columns 0 0 +{-# INLINE rewind #-} near :: (HasDelta s, HasDelta t) => s -> t -> Bool-near s t = case (delta s, delta t) of- (Directed p l _ _ _, Directed p' l' _ _ _) -> p == p' && l == l'- (Lines l _ _ _, Lines l' _ _ _) -> l == l'- (Columns _ _, Columns _ _) -> True- (Columns _ _, Tab _ _ _) -> True- (Tab _ _ _, Columns _ _) -> True- (Tab _ _ _, Tab _ _ _) -> True- _ -> False+near s t = rewind (delta s) == rewind (delta t)+{-# INLINE near #-} class HasDelta t where delta :: t -> Delta@@ -132,18 +126,20 @@ instance HasDelta Char where delta '\t' = Tab 0 0 1 delta '\n' = Lines 1 0 1 0- delta c | o <= 0x7f = Columns 1 1- | o <= 0x7ff = Columns 1 2- | o <= 0xffff = Columns 1 3- | otherwise = Columns 1 4+ delta c + | o <= 0x7f = Columns 1 1+ | o <= 0x7ff = Columns 1 2+ | o <= 0xffff = Columns 1 3+ | otherwise = Columns 1 4 where o = fromEnum c instance HasDelta Word8 where delta 9 = Tab 0 0 1 delta 10 = Lines 1 0 1 0- delta n | n <= 0x7f = Columns 1 1- | n >= 0xc0 && n <= 0xf4 = Columns 1 1- | otherwise = Columns 0 1+ delta n + | n <= 0x7f = Columns 1 1+ | n >= 0xc0 && n <= 0xf4 = Columns 1 1+ | otherwise = Columns 0 1 instance HasDelta ByteString where delta = foldMap delta . unpack
Text/Trifecta/Rope/Prim.hs view
@@ -56,11 +56,11 @@ -- | grab a the contents of a rope from a given location up to a newline grabRest :: Delta -> Rope -> r -> (Delta -> Lazy.ByteString -> r) -> r-grabRest i t kf ks = trim (toList r) (delta l) (bytes i - bytes l) where- trim (p@LineDirective{} : xs) j k = trim xs (j <> delta p) k- trim (Strand h _ : xs) j 0 = go j h xs- trim (Strand h _ : xs) _ k = go i (Strict.drop k h) xs- trim [] _ _ = kf+grabRest i t kf ks = trim (delta l) (bytes i - bytes l) (toList r) where+ trim j 0 (Strand h _ : xs) = go j h xs+ trim _ k (Strand h _ : xs) = go i (Strict.drop k h) xs+ trim j k (p : xs) = trim (j <> delta p) k xs + trim _ _ [] = kf go j h s = ks j $ Lazy.fromChunks $ h : [ a | Strand a _ <- s ] (l, r) = FingerTree.split (\b -> bytes b > bytes i) $ strands t
trifecta.cabal view
@@ -1,6 +1,6 @@ name: trifecta category: Text, Parsing, Diagnostics, Pretty Printer, Logging-version: 0.28+version: 0.29 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE@@ -20,6 +20,7 @@ library exposed-modules: Text.Trifecta+ Text.Trifecta.ByteSet Text.Trifecta.CharSet Text.Trifecta.CharSet.Common Text.Trifecta.CharSet.Posix@@ -45,6 +46,7 @@ Text.Trifecta.Diagnostic.Rendering.Fixit Text.Trifecta.Diagnostic.Rendering.Span Text.Trifecta.Parser+ Text.Trifecta.Parser.ByteString Text.Trifecta.Parser.Char Text.Trifecta.Parser.Class Text.Trifecta.Parser.Combinators@@ -63,7 +65,6 @@ other-modules: Text.Trifecta.Util- Text.Trifecta.CharSet.AsciiSet ghc-options: -Wall