packages feed

trifecta 0.16.1 → 0.17

raw patch · 51 files changed

+2850/−1436 lines, 51 files

Files

LICENSE view
@@ -1,4 +1,5 @@-Copyright 2011 Edward Kmett+Copyright 2010-2011 Edward Kmett+Copyright 2008 Bryan O'Sullivan Copyright 2007 Paolo Martini Copyright 1999-2000 Daan Leijen
Text/Trifecta.hs view
@@ -1,63 +1,9 @@ module Text.Trifecta -  ( module Text.Trifecta.Bytes---  , module System.Console.Terminfo.Color+  ( module Text.Trifecta.Diagnostic+  , module Text.Trifecta.Parser   , module System.Console.Terminfo.PrettyPrint---  , module Text.PrettyPrint.Free-  , module Text.Trifecta.Delta-  , module Text.Trifecta.Diagnostic-  , module Text.Trifecta.Diagnostic.Level-  , module Text.Trifecta.Hunk-  , module Text.Trifecta.Parser.Char-  , module Text.Trifecta.Parser.Class-  , module Text.Trifecta.Parser.Combinators-  , module Text.Trifecta.Parser.Err-  , module Text.Trifecta.Parser.Err.State-  , module Text.Trifecta.Parser.It-  , module Text.Trifecta.Parser.Prim-  , module Text.Trifecta.Parser.Result-  , module Text.Trifecta.Parser.Step-  , module Text.Trifecta.Parser.Token.Class-  , module Text.Trifecta.Parser.Token.Combinators-  , module Text.Trifecta.Parser.Token.Prim-  , module Text.Trifecta.Parser.Token.Style-  , module Text.Trifecta.Parser.Expr-  , module Text.Trifecta.Path-  , module Text.Trifecta.Render.Caret-  , module Text.Trifecta.Render.Fixit-  , module Text.Trifecta.Render.Prim-  , module Text.Trifecta.Render.Span-  , module Text.Trifecta.Rope-  , module Text.Trifecta.Strand-  , module Text.Trifecta.Util.MaybePair   ) where -import Text.Trifecta.Bytes-import Text.Trifecta.Delta import Text.Trifecta.Diagnostic-import Text.Trifecta.Diagnostic.Level-import Text.Trifecta.Hunk-import Text.Trifecta.Parser.Char-import Text.Trifecta.Parser.Class-import Text.Trifecta.Parser.Combinators-import Text.Trifecta.Parser.Err-import Text.Trifecta.Parser.Err.State-import Text.Trifecta.Parser.It-import Text.Trifecta.Parser.Prim-import Text.Trifecta.Parser.Result-import Text.Trifecta.Parser.Step-import Text.Trifecta.Parser.Token.Class-import Text.Trifecta.Parser.Token.Combinators-import Text.Trifecta.Parser.Token.Prim-import Text.Trifecta.Parser.Token.Style-import Text.Trifecta.Parser.Expr-import Text.Trifecta.Path-import Text.Trifecta.Render.Caret-import Text.Trifecta.Render.Fixit-import Text.Trifecta.Render.Prim-import Text.Trifecta.Render.Span-import Text.Trifecta.Rope-import Text.Trifecta.Strand-import Text.Trifecta.Util.MaybePair--- import Text.PrettyPrint.Free hiding (column, char, line, string, space)+import Text.Trifecta.Parser import System.Console.Terminfo.PrettyPrint--- import System.Console.Terminfo.Color
− Text/Trifecta/Bytes.hs 
@@ -1,15 +0,0 @@-module Text.Trifecta.Bytes-  ( HasBytes(..)-  ) where--import Data.ByteString as Strict-import Data.FingerTree--class HasBytes t where-  bytes :: t -> Int--instance HasBytes ByteString where-  bytes = Strict.length--instance (Measured v a, HasBytes v) => HasBytes (FingerTree v a) where-  bytes = bytes . measure
+ Text/Trifecta/CharSet.hs view
@@ -0,0 +1,78 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.CharSet+-- Copyright   :  (c) Edward Kmett 2010-2011, +--                Bryan O'Sullivan 2008+-- License     :  BSD3+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (Data, BangPatterns, MagicHash)+--+-- Fast set membership tests for 'Char' values+--+-- Stored as a (possibly negated IntMap) and a fast set for the ASCII range.+--+-- The ASCII range is unboxed for efficiency. For small (complemented) sets, we+-- test for membership using a binary search. For larger (complemented) sets+-- we use a lookup table. +--+-- Designed to be imported qualified:+-- +-- > import Text.Trifecta.CharSet.Prim (CharSet)+-- > import qualified Text.Trifecta.CharSet.Prim as CharSet+--+-------------------------------------------------------------------------------++module Text.Trifecta.CharSet+    ( +    -- * Set type+      CharSet+    -- * Operators+    , (\\)+    -- * Query+    , null+    , size+    , member+    , notMember+    , overlaps, isSubsetOf+    , isComplemented +    -- * Construction+    , build+    , empty+    , singleton+    , full+    , insert+    , delete+    , complement+    , range+    -- * Combine+    , union+    , intersection+    , difference+    -- * Filter+    , filter+    , partition+    -- * Map+    , map+    -- * Fold+    , fold+    -- * Conversion+    -- ** List+    , toList+    , fromList+    -- ** Ordered list+    , toAscList+    , fromAscList+    , fromDistinctAscList+    -- ** IntMaps+    , fromCharSet+    , toCharSet+    -- ** Array+    , toArray+    , module Text.Trifecta.CharSet.Common+    ) where++import Text.Trifecta.CharSet.Prim+import Text.Trifecta.CharSet.Common+import Prelude ()+
+ Text/Trifecta/CharSet/AsciiSet.hs view
@@ -0,0 +1,96 @@+{-# 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/CharSet/Common.hs view
@@ -0,0 +1,65 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.CharSet.Common+-- Copyright   :  (c) Edward Kmett 2010-2011+-- License     :  BSD3+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- The various character classifications from "Data.Char" as 'CharSet's+-------------------------------------------------------------------------------++module Text.Trifecta.CharSet.Common+    ( +    -- ** Data.Char classes+      control+    , space+    , lower+    , upper+    , alpha+    , alphaNum+    , print+    , digit+    , octDigit+    , letter+    , mark+    , number+    , punctuation+    , symbol+    , separator+    , ascii+    , latin1+    , asciiUpper+    , asciiLower+    ) where++import Prelude ()+import Data.Char+import Text.Trifecta.CharSet.Prim++-- Haskell character classes from Data.Char+control, space, lower, upper, alpha, alphaNum, +  print, digit, octDigit, letter, mark, number, +  punctuation, symbol, separator, ascii, latin1+  , asciiUpper, asciiLower :: CharSet++control = build isControl+space = build isSpace+lower = build isLower+upper = build isUpper+alpha = build isAlpha+alphaNum = build isAlphaNum+print = build isPrint+digit = build isDigit+octDigit = build isOctDigit+letter = build isLetter+mark = build isMark+number = build isNumber+punctuation = build isPunctuation+symbol = build isSymbol+separator = build isSeparator+ascii = build isAscii+latin1 = build isLatin1+asciiUpper = build isAsciiUpper+asciiLower = build isAsciiLower
+ Text/Trifecta/CharSet/Posix/Ascii.hs view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.CharSet.Posix.Ascii+-- Copyright   :  (c) Edward Kmett 2010+-- License     :  BSD3+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-------------------------------------------------------------------------------++module Text.Trifecta.CharSet.Posix.Ascii+    ( posixAscii+    , lookupPosixAsciiCharSet+    -- * Traditional POSIX ASCII \"classes\"+    , alnum, alpha, ascii, blank, cntrl, digit, graph, print, word, punct, space, upper, lower, xdigit+    ) where++import Prelude hiding (print)+import Data.Char+import Text.Trifecta.CharSet.Prim+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap++alnum, alpha, ascii, blank, cntrl, digit, graph, print, word, punct, space, upper, lower, xdigit :: CharSet+alnum = alpha `union` digit+alpha = lower `union` upper+ascii = range '\x00' '\x7f'+blank = fromList " \t"+cntrl = insert '\x7f' $ range '\x00' '\x1f'+digit = range '0' '9'+lower = range 'a' 'z'+upper = range 'A' 'Z'+graph = range '\x21' '\x7e'+print = insert '\x20' graph+word  = insert '_' alnum+punct = fromList "-!\"#$%&'()*+,./:;<=>?@[\\]^_`{|}~"+space = fromList " \t\r\n\v\f"+xdigit = digit `union` range 'a' 'f' `union` range 'A' 'F'++-- :digit:, etc.+posixAscii :: HashMap String CharSet+posixAscii = HashMap.fromList+    [ ("alnum", alnum)+    , ("alpha", alpha)+    , ("ascii", ascii)+    , ("blank", blank)+    , ("cntrl", cntrl)+    , ("digit", digit)+    , ("graph", graph) +    , ("print", print)+    , ("word",  word)+    , ("punct", punct)+    , ("space", space)+    , ("upper", upper)+    , ("lower", lower)+    , ("xdigit", xdigit)+    ]++lookupPosixAsciiCharSet :: String -> Maybe CharSet+lookupPosixAsciiCharSet s = HashMap.lookup (Prelude.map toLower s) posixAscii
+ Text/Trifecta/CharSet/Posix/Unicode.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.CharSet.Posix.Unicode+-- Copyright   :  (c) Edward Kmett 2010+-- License     :  BSD3+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-------------------------------------------------------------------------------++module Text.Trifecta.CharSet.Posix.Unicode+    ( posixUnicode+    , lookupPosixUnicodeCharSet+    -- * POSIX ASCII \"classes\"+    , alnum, alpha, ascii, blank, cntrl, digit, graph, print, word, punct, space, upper, lower, xdigit+    ) where++import Prelude hiding (print)+import Data.Char+import Text.Trifecta.CharSet.Prim+import qualified Text.Trifecta.CharSet.Unicode.Category as Category+import qualified Text.Trifecta.CharSet.Unicode.Block as Block+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap++alnum, alpha, ascii, blank, cntrl, digit, graph, print, word, punct, space, upper, lower, xdigit :: CharSet+alnum = alpha `union` digit+ascii = Block.basicLatin+alpha = Category.letterAnd+blank = insert '\t' Category.space +cntrl = Category.control+digit = Category.decimalNumber+lower = Category.lowercaseLetter+upper = Category.uppercaseLetter+graph = complement (Category.separator `union` Category.other)+print = complement (Category.other)+word  = Category.letter `union` Category.number `union` Category.connectorPunctuation+punct = Category.punctuation `union` Category.symbol+space = fromList " \t\r\n\v\f" `union` Category.separator+xdigit = digit `union` range 'a' 'f' `union` range 'A' 'F'++-- :digit:, etc.+posixUnicode :: HashMap String CharSet+posixUnicode = HashMap.fromList+    [ ("alnum", alnum)+    , ("alpha", alpha)+    , ("ascii", ascii)+    , ("blank", blank)+    , ("cntrl", cntrl)+    , ("digit", digit)+    , ("graph", graph) +    , ("print", print)+    , ("word",  word)+    , ("punct", punct)+    , ("space", space)+    , ("upper", upper)+    , ("lower", lower)+    , ("xdigit", xdigit)+    ]++lookupPosixUnicodeCharSet :: String -> Maybe CharSet+lookupPosixUnicodeCharSet s = HashMap.lookup (Prelude.map toLower s) posixUnicode+
+ Text/Trifecta/CharSet/Prim.hs view
@@ -0,0 +1,339 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.CharSet.Prim+-- Copyright   :  (c) Edward Kmett 2010-2011+-- License     :  BSD3+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (Data, BangPatterns, MagicHash)+--+-- Fast set membership tests for 'Char' values+--+-- Stored as a (possibly negated IntMap) and a fast set for the ASCII range.+--+-- The ASCII range is unboxed for efficiency. For small (complemented) sets, we+-- test for membership using a binary search. For larger (complemented) sets+-- we use a lookup table. +--+-- Designed to be imported qualified:+-- +-- > import Text.Trifecta.CharSet.Prim (CharSet)+-- > import qualified Text.Trifecta.CharSet.Prim as CharSet+--+-------------------------------------------------------------------------------++module Text.Trifecta.CharSet.Prim+    ( +    -- * Set type+      CharSet+    -- * Operators+    , (\\)+    -- * Query+    , null+    , size+    , member+    , notMember+    , overlaps, isSubsetOf+    , isComplemented +    -- * Construction+    , build+    , empty+    , singleton+    , full+    , insert+    , delete+    , complement+    , range+    -- * Combine+    , union+    , intersection+    , difference+    -- * Filter+    , filter+    , partition+    -- * Map+    , map+    -- * Fold+    , fold+    -- * Conversion+    -- ** List+    , toList+    , fromList+    -- ** Ordered list+    , toAscList+    , fromAscList+    , fromDistinctAscList+    -- ** IntMaps+    , fromCharSet+    , toCharSet+    -- ** Array+    , toArray+    ) where++import Data.Array.Unboxed hiding (range)+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 Data.Monoid (Monoid(..))+import qualified Data.IntSet as I+import qualified Data.List as L+import Prelude hiding (filter, map, null)+import qualified Prelude as P+import Text.Read++data CharSet +  = Pos AsciiSet !IntSet +  | Neg AsciiSet !IntSet++pos :: IntSet -> CharSet+pos s = Pos (AsciiSet.fromList (fmap toEnum (takeWhile (<= 0x7f) (I.toAscList s)))) s++neg :: IntSet -> CharSet+neg s = Neg (AsciiSet.fromList (fmap toEnum (takeWhile (<= 0x7f) (I.toAscList s)))) s++(\\) :: CharSet -> CharSet -> CharSet+(\\) = difference++build :: (Char -> Bool) -> CharSet+build p = fromDistinctAscList $ P.filter p [minBound .. maxBound]+{-# INLINE build #-}++map :: (Char -> Char) -> CharSet -> CharSet+map f (Pos _ i) = pos (I.map (fromEnum . f . toEnum) i)+map f (Neg _ i) = fromList $ P.map f $ P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh] +{-# INLINE map #-}++isComplemented :: CharSet -> Bool+isComplemented (Pos _ _) = False+isComplemented (Neg _ _) = True+{-# INLINE isComplemented #-}++toList :: CharSet -> String+toList (Pos _ i) = P.map toEnum (I.toList i)+toList (Neg _ i) = P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh]+{-# INLINE toList #-}++toAscList :: CharSet -> String+toAscList (Pos _ i) = P.map toEnum (I.toAscList i)+toAscList (Neg _ i) = P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh]+{-# INLINE toAscList #-}+    +empty :: CharSet+empty = pos I.empty++singleton :: Char -> CharSet+singleton = pos . I.singleton . fromEnum+{-# INLINE singleton #-}++full :: CharSet+full = neg I.empty++-- | /O(n)/ worst case+null :: CharSet -> Bool+null (Pos _ i) = I.null i+null (Neg _ i) = I.size i == numChars+{-# INLINE null #-}++-- | /O(n)/+size :: CharSet -> Int+size (Pos _ i) = I.size i+size (Neg _ i) = numChars - I.size i+{-# INLINE size #-}++insert :: Char -> CharSet -> CharSet+insert c (Pos _ i) = pos (I.insert (fromEnum c) i)+insert c (Neg _ i) = neg (I.delete (fromEnum c) i)+{-# INLINE insert #-}++range :: Char -> Char -> CharSet+range a b +  | a <= b = fromDistinctAscList [a..b]+  | otherwise = empty++delete :: Char -> CharSet -> CharSet+delete c (Pos _ i) = pos (I.delete (fromEnum c) i)+delete c (Neg _ i) = neg (I.insert (fromEnum c) i)+{-# INLINE delete #-}++complement :: CharSet -> CharSet+complement (Pos s i) = Neg s i+complement (Neg s i) = Pos s i+{-# INLINE complement #-}++union :: CharSet -> CharSet -> CharSet+union (Pos _ i) (Pos _ j) = pos (I.union i j)+union (Pos _ i) (Neg _ j) = neg (I.difference j i)+union (Neg _ i) (Pos _ j) = neg (I.difference i j)+union (Neg _ i) (Neg _ j) = neg (I.intersection i j)+{-# INLINE union #-}++intersection :: CharSet -> CharSet -> CharSet+intersection (Pos _ i) (Pos _ j) = pos (I.intersection i j)+intersection (Pos _ i) (Neg _ j) = pos (I.difference i j)+intersection (Neg _ i) (Pos _ j) = pos (I.difference j i)+intersection (Neg _ i) (Neg _ j) = neg (I.union i j)+{-# INLINE intersection #-}++difference :: CharSet -> CharSet -> CharSet +difference (Pos _ i) (Pos _ j) = pos (I.difference i j)+difference (Pos _ i) (Neg _ j) = pos (I.intersection i j)+difference (Neg _ i) (Pos _ j) = neg (I.union i j)+difference (Neg _ i) (Neg _ j) = pos (I.difference j i)+{-# INLINE difference #-}++member :: Char -> CharSet -> Bool+member c (Pos b i)+  | c <= toEnum 0x7f = AsciiSet.member c b+  | otherwise        = I.member (fromEnum c) i+member c (Neg b i) +  | c <= toEnum 0x7f = not (AsciiSet.member c b)+  | otherwise        = I.notMember (fromEnum c) i+{-# INLINE member #-}++notMember :: Char -> CharSet -> Bool+notMember c s = not (member c s)+{-# INLINE notMember #-}++fold :: (Char -> b -> b) -> b -> CharSet -> b+fold f z (Pos _ i) = I.fold (f . toEnum) z i+fold f z (Neg _ i) = foldr f z $ P.filter (\x -> fromEnum x `I.notMember` i) [ul..uh]+{-# INLINE fold #-}++filter :: (Char -> Bool) -> CharSet -> CharSet +filter p (Pos _ i) = pos (I.filter (p . toEnum) i)+filter p (Neg _ 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 (Pos _ i) = (pos l, pos r)+    where (l,r) = I.partition (p . toEnum) i+partition p (Neg _ 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 (Pos _ i) (Pos _ j) = not (I.null (I.intersection i j))+overlaps (Pos _ i) (Neg _ j) = not (I.isSubsetOf j i)+overlaps (Neg _ i) (Pos _ j) = not (I.isSubsetOf i j)+overlaps (Neg _ i) (Neg _ j) = any (\x -> I.notMember x i && I.notMember x j) [ol..oh] -- not likely+{-# INLINE overlaps #-}++isSubsetOf :: CharSet -> CharSet -> Bool+isSubsetOf (Pos _ i) (Pos _ j) = I.isSubsetOf i j+isSubsetOf (Pos _ i) (Neg _ j) = I.null (I.intersection i j)+isSubsetOf (Neg _ i) (Pos _ j) = all (\x -> I.member x i && I.member x j) [ol..oh] -- not bloody likely+isSubsetOf (Neg _ i) (Neg _ j) = I.isSubsetOf j i+{-# INLINE isSubsetOf #-}++fromList :: String -> CharSet +fromList = pos . I.fromList . P.map fromEnum+{-# INLINE fromList #-}++fromAscList :: String -> CharSet+fromAscList = pos . I.fromAscList . P.map fromEnum+{-# INLINE fromAscList #-}++fromDistinctAscList :: String -> CharSet+fromDistinctAscList = pos . I.fromDistinctAscList . P.map fromEnum+{-# INLINE fromDistinctAscList #-}++-- isProperSubsetOf :: CharSet -> CharSet -> Bool+-- isProperSubsetOf (P i) (P j) = I.isProperSubsetOf i j+-- isProperSubsetOf (P i) (N j) = null (I.intersection i j) && ...+-- isProperSubsetOf (N i) (N j) = I.isProperSubsetOf j i++ul, uh :: Char+ul = minBound+uh = maxBound+{-# INLINE ul #-}+{-# INLINE uh #-}++ol, oh :: Int+ol = fromEnum ul+oh = fromEnum uh+{-# INLINE ol #-}+{-# INLINE oh #-}++numChars :: Int+numChars = oh - ol + 1+{-# INLINE numChars #-}++instance Typeable CharSet where+  typeOf _ = mkTyConApp charSetTyCon []++charSetTyCon :: TyCon+charSetTyCon = mkTyCon "Text.Trifecta.CharSet.CharSet"+{-# NOINLINE charSetTyCon #-}++instance Data CharSet where+  gfoldl k z set +    | isComplemented set = z complement `k` complement set+    | otherwise          = z fromList `k` toList set++  toConstr set +    | isComplemented set = complementConstr+    | otherwise = fromListConstr++  dataTypeOf _ = charSetDataType++  gunfold k z c = case constrIndex c of+    1 -> k (z fromList)+    2 -> k (z complement)+    _ -> error "gunfold"++fromListConstr :: Constr+fromListConstr   = mkConstr charSetDataType "fromList" [] Prefix+{-# NOINLINE fromListConstr #-}++complementConstr :: Constr+complementConstr = mkConstr charSetDataType "complement" [] Prefix+{-# NOINLINE complementConstr #-}++charSetDataType :: DataType+charSetDataType  = mkDataType "Text.Trifecta.CharSet.CharSet" [fromListConstr, complementConstr]+{-# NOINLINE charSetDataType #-}++-- returns an intset and if the intset should be complemented to obtain the contents of the CharSet+fromCharSet :: CharSet -> (Bool, IntSet)+fromCharSet (Pos _ i) = (False, i)+fromCharSet (Neg _ i) = (True, i) +{-# INLINE fromCharSet #-}++toCharSet :: IntSet -> CharSet+toCharSet = pos+{-# INLINE toCharSet #-}++instance Eq CharSet where+  (==) = (==) `on` toAscList++instance Ord CharSet where+  compare = compare `on` toAscList++instance Bounded CharSet where+  minBound = empty+  maxBound = full++-- TODO return a tighter bounded array perhaps starting from the least element present to the last element present?+toArray :: CharSet -> UArray Char Bool+toArray set = array (minBound, maxBound) $ fmap (\x -> (x, x `member` set)) [minBound .. maxBound]+ +instance Show CharSet where+  showsPrec d i+    | isComplemented i = showParen (d > 10) $ showString "complement " . showsPrec 11 (complement i)+    | otherwise        = showParen (d > 10) $ showString "fromDistinctAscList " . showsPrec 11 (toAscList i)++instance Read CharSet where+  readPrec = parens $ complemented +++ normal +    where+      complemented = prec 10 $ do +        Ident "complement" <- lexP+        complement `fmap` step readPrec+      normal = prec 10 $ do+        Ident "fromDistinctAscList" <- lexP+        fromDistinctAscList `fmap` step readPrec++instance Monoid CharSet where+  mempty = empty+  mappend = union
+ Text/Trifecta/CharSet/Unicode.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.CharSet.Unicode+-- Copyright   :  (c) Edward Kmett 2010+-- License     :  BSD3+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Provides unicode general categories, which are typically connoted by +-- @\p{Ll}@ or @\p{Modifier_Letter}@. Lookups can be constructed using 'categories'+-- or individual character sets can be used directly.+-------------------------------------------------------------------------------++module Text.Trifecta.CharSet.Unicode+    ( +    -- * Unicode General Category+      UnicodeCategory(..)+    -- * Lookup+    , unicodeCategories+    -- * CharSets by UnicodeCategory+    -- ** Letter+    , modifierLetter, otherLetter, letter+    -- *** Letter\&+    , lowercaseLetter, uppercaseLetter, titlecaseLetter, letterAnd+    -- ** Mark+    , nonSpacingMark, spacingCombiningMark, enclosingMark, mark+    -- ** Separator+    , space, lineSeparator, paragraphSeparator, separator+    -- ** Symbol+    , mathSymbol, currencySymbol, modifierSymbol, otherSymbol, symbol+    -- ** Number+    , decimalNumber, letterNumber, otherNumber, number+    -- ** Punctuation+    , dashPunctuation, openPunctuation, closePunctuation, initialQuote+    , finalQuote, connectorPunctuation, otherPunctuation, punctuation +    -- ** Other+    , control, format, privateUse, surrogate, notAssigned, other+    ) where++import Data.Char+import Data.Data+import Text.Trifecta.CharSet.Prim++data UnicodeCategory = UnicodeCategory String String CharSet String+    deriving (Show, Data, Typeable)++-- \p{Letter} or \p{Mc}+unicodeCategories :: [UnicodeCategory]+unicodeCategories =+    [ UnicodeCategory "Letter" "L" letter "any kind of letter from any language."+    ,     UnicodeCategory "Lowercase_Letter" "Ll" lowercaseLetter "a lowercase letter that has an uppercase variant"+    ,     UnicodeCategory "Uppercase_Letter" "Lu" uppercaseLetter "an uppercase letter that has a lowercase variant"+    ,     UnicodeCategory "Titlecase_Letter" "Lt" titlecaseLetter "a letter that appears at the start of a word when only the first letter of the word is capitalized"+    ,     UnicodeCategory "Letter&" "L&" letterAnd "a letter that exists in lowercase and uppercase variants (combination of Ll, Lu and Lt)"+    ,     UnicodeCategory "Modifier_Letter" "Lm" modifierLetter "a special character that is used like a letter"+    ,     UnicodeCategory "Other_Letter" "Lo" otherLetter "a letter or ideograph that does not have lowercase and uppercase variants"+    , UnicodeCategory "Mark" "M" mark "a character intended to be combined with another character (e.g. accents, umlauts, enclosing boxes, etc.)"+    ,     UnicodeCategory "Non_Spacing_Mark" "Mn" nonSpacingMark "a character intended to be combined with another character without taking up extra space (e.g. accents, umlauts, etc.)"+    ,     UnicodeCategory "Spacing_Combining_Mark" "Mc" spacingCombiningMark "a character intended to be combined with another character that takes up extra space (vowel signs in many Eastern languages)"+    ,     UnicodeCategory "Enclosing_Mark" "Me" enclosingMark "a character that encloses the character is is combined with (circle, square, keycap, etc.)"+    , UnicodeCategory "Separator" "Z" separator "any kind of whitespace or invisible separator"+    ,     UnicodeCategory "Space_Separator" "Zs" space "a whitespace character that is invisible, but does take up space"+    ,     UnicodeCategory "Line_Separator" "Zl" lineSeparator "line separator character U+2028"+    ,     UnicodeCategory "Paragraph_Separator" "Zp" paragraphSeparator "paragraph separator character U+2029"+    , UnicodeCategory "Symbol" "S" symbol "math symbols, currency signs, dingbats, box-drawing characters, etc."+    ,     UnicodeCategory "Math_Symbol" "Sm" mathSymbol "any mathematical symbol"+    ,     UnicodeCategory "Currency_Symbol" "Sc" currencySymbol "any currency sign"+    ,     UnicodeCategory "Modifier_Symbol" "Sk" modifierSymbol "a combining character (mark) as a full character on its own"+    ,     UnicodeCategory "Other_Symbol" "So" otherSymbol "various symbols that are not math symbols, currency signs, or combining characters"+    , UnicodeCategory "Number" "N" number "any kind of numeric character in any script"+    ,     UnicodeCategory "Decimal_Digit_Number" "Nd" decimalNumber "a digit zero through nine in any script except ideographic scripts"+    ,     UnicodeCategory "Letter_Number" "Nl" letterNumber "a number that looks like a letter, such as a Roman numeral"+    ,     UnicodeCategory "Other_Number" "No" otherNumber "a superscript or subscript digit, or a number that is not a digit 0..9 (excluding numbers from ideographic scripts)"+    , UnicodeCategory "Punctuation" "P" punctuation "any kind of punctuation character"+    ,     UnicodeCategory "Dash_Punctuation" "Pd" dashPunctuation "any kind of hyphen or dash"+    ,     UnicodeCategory "Open_Punctuation" "Ps" openPunctuation "any kind of opening bracket"+    ,     UnicodeCategory "Close_Punctuation" "Pe" closePunctuation "any kind of closing bracket"+    ,     UnicodeCategory "Initial_Punctuation" "Pi" initialQuote "any kind of opening quote"+    ,     UnicodeCategory "Final_Punctuation" "Pf" finalQuote "any kind of closing quote"+    ,     UnicodeCategory "Connector_Punctuation" "Pc" connectorPunctuation "a punctuation character such as an underscore that connects words"+    ,     UnicodeCategory "Other_Punctuation" "Po" otherPunctuation "any kind of punctuation character that is not a dash, bracket, quote or connector"+    , UnicodeCategory "Other" "C" other "invisible control characters and unused code points"+    ,     UnicodeCategory "Control" "Cc" control "an ASCII 0x00..0x1F or Latin-1 0x80..0x9F control character"+    ,     UnicodeCategory "Format" "Cf" format "invisible formatting indicator"+    ,     UnicodeCategory "Private_Use" "Co" privateUse "any code point reserved for private use"+    ,     UnicodeCategory "Surrogate" "Cs" surrogate "one half of a surrogate pair in UTF-16 encoding"+    ,     UnicodeCategory "Unassigned" "Cn" notAssigned "any code point to which no character has been assigned.properties" ]++cat :: GeneralCategory -> CharSet+cat category = build ((category ==) . generalCategory)++-- Letter+lowercaseLetter, uppercaseLetter, titlecaseLetter, letterAnd, modifierLetter, otherLetter, letter :: CharSet+lowercaseLetter = cat LowercaseLetter+uppercaseLetter = cat UppercaseLetter+titlecaseLetter = cat TitlecaseLetter+letterAnd = lowercaseLetter +    `union` uppercaseLetter +    `union` titlecaseLetter+modifierLetter  = cat ModifierLetter+otherLetter = cat OtherLetter+letter +          = letterAnd +    `union` modifierLetter +    `union` otherLetter++-- Marks+nonSpacingMark, spacingCombiningMark, enclosingMark, mark :: CharSet+nonSpacingMark = cat NonSpacingMark+spacingCombiningMark = cat SpacingCombiningMark+enclosingMark = cat EnclosingMark+mark +          = nonSpacingMark +    `union` spacingCombiningMark +    `union` enclosingMark++space, lineSeparator, paragraphSeparator, separator :: CharSet+space = cat Space+lineSeparator = cat LineSeparator+paragraphSeparator = cat ParagraphSeparator+separator +          = space +    `union` lineSeparator +    `union` paragraphSeparator++mathSymbol, currencySymbol, modifierSymbol, otherSymbol, symbol :: CharSet+mathSymbol = cat MathSymbol+currencySymbol = cat CurrencySymbol+modifierSymbol = cat ModifierSymbol+otherSymbol = cat OtherSymbol+symbol +          = mathSymbol +    `union` currencySymbol +    `union` modifierSymbol +    `union` otherSymbol++decimalNumber, letterNumber, otherNumber, number :: CharSet+decimalNumber = cat DecimalNumber+letterNumber = cat LetterNumber+otherNumber = cat OtherNumber+number +          = decimalNumber +    `union` letterNumber +    `union` otherNumber++dashPunctuation, openPunctuation, closePunctuation, initialQuote, +  finalQuote, connectorPunctuation, otherPunctuation, punctuation :: CharSet++dashPunctuation = cat DashPunctuation+openPunctuation = cat OpenPunctuation+closePunctuation = cat ClosePunctuation+initialQuote = cat InitialQuote+finalQuote = cat FinalQuote+connectorPunctuation  = cat ConnectorPunctuation+otherPunctuation = cat OtherPunctuation+punctuation +          = dashPunctuation +    `union` openPunctuation +    `union` closePunctuation +    `union` initialQuote +    `union` finalQuote +    `union` connectorPunctuation +    `union` otherPunctuation++control, format, privateUse, surrogate, notAssigned, other :: CharSet+control = cat Control+format = cat Format+privateUse = cat PrivateUse+surrogate = cat Surrogate+notAssigned = cat NotAssigned+other = control +    `union` format +    `union` privateUse +    `union` surrogate +    `union` notAssigned
+ Text/Trifecta/CharSet/Unicode/Block.hs view
@@ -0,0 +1,382 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.CharSet.Unicode.Block+-- Copyright   :  (c) Edward Kmett 2010-2011+-- License     :  BSD3+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Provides unicode general categories, which are typically connoted by +-- @\p{InBasicLatin}@ or @\p{InIPA_Extensions}@. Lookups can be constructed using 'categories'+-- or individual character sets can be used directly.+-------------------------------------------------------------------------------++module Text.Trifecta.CharSet.Unicode.Block+    ( +    -- * Unicode General Category+      Block(..)+    -- * Lookup+    , blocks+    , lookupBlock+    , lookupBlockCharSet+    -- * CharSets by Block+    , basicLatin+    , latin1Supplement+    , latinExtendedA+    , latinExtendedB+    , ipaExtensions+    , spacingModifierLetters+    , combiningDiacriticalMarks+    , greekAndCoptic+    , cyrillic+    , cyrillicSupplementary+    , armenian+    , hebrew+    , arabic+    , syriac+    , thaana+    , devanagari+    , bengali+    , gurmukhi+    , gujarati+    , oriya+    , tamil+    , telugu+    , kannada+    , malayalam+    , sinhala+    , thai+    , lao+    , tibetan+    , myanmar+    , georgian+    , hangulJamo+    , ethiopic+    , cherokee+    , unifiedCanadianAboriginalSyllabics+    , ogham+    , runic+    , tagalog+    , hanunoo+    , buhid+    , tagbanwa+    , khmer+    , mongolian+    , limbu+    , taiLe+    , khmerSymbols+    , phoneticExtensions+    , latinExtendedAdditional+    , greekExtended+    , generalPunctuation+    , superscriptsAndSubscripts+    , currencySymbols+    , combiningDiacriticalMarksForSymbols+    , letterlikeSymbols+    , numberForms+    , arrows+    , mathematicalOperators+    , miscellaneousTechnical+    , controlPictures+    , opticalCharacterRecognition+    , enclosedAlphanumerics+    , boxDrawing+    , blockElements+    , geometricShapes+    , miscellaneousSymbols+    , dingbats+    , miscellaneousMathematicalSymbolsA+    , supplementalArrowsA+    , braillePatterns+    , supplementalArrowsB+    , miscellaneousMathematicalSymbolsB+    , supplementalMathematicalOperators+    , miscellaneousSymbolsAndArrows+    , cjkRadicalsSupplement+    , kangxiRadicals+    , ideographicDescriptionCharacters+    , cjkSymbolsAndPunctuation+    , hiragana+    , katakana+    , bopomofo+    , hangulCompatibilityJamo+    , kanbun+    , bopomofoExtended+    , katakanaPhoneticExtensions+    , enclosedCjkLettersAndMonths+    , cjkCompatibility+    , cjkUnifiedIdeographsExtensionA+    , yijingHexagramSymbols+    , cjkUnifiedIdeographs+    , yiSyllables+    , yiRadicals+    , hangulSyllables+    , highSurrogates+    , highPrivateUseSurrogates+    , lowSurrogates+    , privateUseArea+    , cjkCompatibilityIdeographs+    , alphabeticPresentationForms+    , arabicPresentationFormsA+    , variationSelectors+    , combiningHalfMarks+    , cjkCompatibilityForms+    , smallFormVariants+    , arabicPresentationFormsB+    , halfwidthAndFullwidthForms+    , specials+    ) where++import Data.Char+import Text.Trifecta.CharSet.Prim+import Data.Data+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap++data Block = Block +    { blockName :: String+    , blockCharSet :: CharSet+    } deriving (Show, Data, Typeable)++blocks :: [Block]+blocks =+    [ Block "Basic_Latin" basicLatin+    , Block "Latin-1_Supplement" latin1Supplement+    , Block "Latin_Extended-A" latinExtendedA+    , Block "IPA_Extensions" ipaExtensions+    , Block "Spacing_Modifier_Letters" spacingModifierLetters++    , Block "Latin_Extended-A" latinExtendedA+    , Block "Latin_Extended-B" latinExtendedB+    , Block "IPA_Extensions" ipaExtensions+    , Block "Spacing_Modifier_Letters" spacingModifierLetters+    , Block "Combining_Diacritical_Marks" combiningDiacriticalMarks+    , Block "Greek_and_Coptic" greekAndCoptic+    , Block "Cyrillic" cyrillic+    , Block "Cyrillic_Supplementary" cyrillicSupplementary+    , Block "Armenian" armenian+    , Block "Hebrew" hebrew+    , Block "Arabic" arabic+    , Block "Syriac" syriac+    , Block "Thaana" thaana+    , Block "Devanagari" devanagari+    , Block "Bengali" bengali+    , Block "Gurmukhi" gurmukhi+    , Block "Gujarati" gujarati+    , Block "Oriya" oriya+    , Block "Tamil" tamil+    , Block "Telugu" telugu+    , Block "Kannada" kannada+    , Block "Malayalam" malayalam+    , Block "Sinhala" sinhala+    , Block "Thai" thai+    , Block "Lao" lao+    , Block "Tibetan" tibetan+    , Block "Myanmar" myanmar+    , Block "Georgian" georgian+    , Block "Hangul_Jamo" hangulJamo+    , Block "Ethiopic" ethiopic+    , Block "Cherokee" cherokee+    , Block "Unified_Canadian_Aboriginal_Syllabics" unifiedCanadianAboriginalSyllabics+    , Block "Ogham" ogham+    , Block "Runic" runic+    , Block "Tagalog" tagalog+    , Block "Hanunoo" hanunoo+    , Block "Buhid" buhid+    , Block "Tagbanwa" tagbanwa+    , Block "Khmer" khmer+    , Block "Mongolian" mongolian+    , Block "Limbu" limbu+    , Block "Tai_Le" taiLe+    , Block "Khmer_Symbols" khmerSymbols+    , Block "Phonetic_Extensions" phoneticExtensions+    , Block "Latin_Extended_Additional" latinExtendedAdditional+    , Block "Greek_Extended" greekExtended+    , Block "General_Punctuation" generalPunctuation+    , Block "Superscripts_and_Subscripts" superscriptsAndSubscripts+    , Block "Currency_Symbols" currencySymbols+    , Block "Combining_Diacritical_Marks_for_Symbols" combiningDiacriticalMarksForSymbols+    , Block "Letterlike_Symbols" letterlikeSymbols+    , Block "Number_Forms" numberForms+    , Block "Arrows" arrows+    , Block "Mathematical_Operators" mathematicalOperators+    , Block "Miscellaneous_Technical" miscellaneousTechnical+    , Block "Control_Pictures" controlPictures+    , Block "Optical_Character_Recognition" opticalCharacterRecognition+    , Block "Enclosed_Alphanumerics" enclosedAlphanumerics+    , Block "Box_Drawing" boxDrawing+    , Block "Block_Elements" blockElements+    , Block "Geometric_Shapes" geometricShapes+    , Block "Miscellaneous_Symbols" miscellaneousSymbols+    , Block "Dingbats" dingbats+    , Block "Miscellaneous_Mathematical_Symbols-A" miscellaneousMathematicalSymbolsA+    , Block "Supplemental_Arrows-A" supplementalArrowsA+    , Block "Braille_Patterns" braillePatterns+    , Block "Supplemental_Arrows-B" supplementalArrowsB+    , Block "Miscellaneous_Mathematical_Symbols-B" miscellaneousMathematicalSymbolsB+    , Block "Supplemental_Mathematical_Operators" supplementalMathematicalOperators+    , Block "Miscellaneous_Symbols_and_Arrows" miscellaneousSymbolsAndArrows+    , Block "CJK_Radicals_Supplement" cjkRadicalsSupplement+    , Block "Kangxi_Radicals" kangxiRadicals+    , Block "Ideographic_Description_Characters" ideographicDescriptionCharacters+    , Block "CJK_Symbols_and_Punctuation" cjkSymbolsAndPunctuation+    , Block "Hiragana" hiragana+    , Block "Katakana" katakana+    , Block "Bopomofo" bopomofo+    , Block "Hangul_Compatibility_Jamo" hangulCompatibilityJamo+    , Block "Kanbun" kanbun+    , Block "Bopomofo_Extended" bopomofoExtended+    , Block "Katakana_Phonetic_Extensions" katakanaPhoneticExtensions+    , Block "Enclosed_CJK_Letters_and_Months" enclosedCjkLettersAndMonths+    , Block "CJK_Compatibility" cjkCompatibility+    , Block "CJK_Unified_Ideographs_Extension_A" cjkUnifiedIdeographsExtensionA+    , Block "Yijing_Hexagram_Symbols" yijingHexagramSymbols+    , Block "CJK_Unified_Ideographs" cjkUnifiedIdeographs+    , Block "Yi_Syllables" yiSyllables+    , Block "Yi_Radicals" yiRadicals+    , Block "Hangul_Syllables" hangulSyllables+    , Block "High_Surrogates" highSurrogates+    , Block "High_Private_Use_Surrogates" highPrivateUseSurrogates+    , Block "Low_Surrogates" lowSurrogates+    , Block "Private_Use_Area" privateUseArea+    , Block "CJK_Compatibility_Ideographs" cjkCompatibilityIdeographs+    , Block "Alphabetic_Presentation_Forms" alphabeticPresentationForms+    , Block "Arabic_Presentation_Forms-A" arabicPresentationFormsA+    , Block "Variation_Selectors" variationSelectors+    , Block "Combining_Half_Marks" combiningHalfMarks+    , Block "CJK_Compatibility_Forms" cjkCompatibilityForms+    , Block "Small_Form_Variants" smallFormVariants+    , Block "Arabic_Presentation_Forms-B" arabicPresentationFormsB+    , Block "Halfwidth_and_Fullwidth_Forms" halfwidthAndFullwidthForms+    , Block "Specials" specials ]++lookupTable :: HashMap String Block+lookupTable = HashMap.fromList $ +              Prelude.map (\y@(Block x _) -> (canonicalize x, y))+              blocks++canonicalize :: String -> String+canonicalize s = case Prelude.map toLower s of+    'i': 'n' : xs -> go xs+    xs -> go xs+    where+        go ('-':xs) = go xs+        go ('_':xs) = go xs+        go (' ':xs) = go xs+        go (x:xs) = x : go xs+        go [] = []++lookupBlock :: String -> Maybe Block+lookupBlock s = HashMap.lookup (canonicalize s) lookupTable++lookupBlockCharSet :: String -> Maybe CharSet+lookupBlockCharSet = fmap blockCharSet . lookupBlock++basicLatin = range '\x0000' '\x007f'+latin1Supplement = range '\x0080' '\x00ff'+latinExtendedA = range '\x0100' '\x017F'+latinExtendedB = range '\x0180' '\x024F'+ipaExtensions = range '\x0250' '\x02AF'+spacingModifierLetters = range '\x02B0' '\x02FF'+combiningDiacriticalMarks = range '\x0300' '\x036F'+greekAndCoptic = range '\x0370' '\x03FF'+cyrillic = range '\x0400' '\x04FF'+cyrillicSupplementary = range '\x0500' '\x052F'+armenian = range '\x0530' '\x058F'+hebrew = range '\x0590' '\x05FF'+arabic = range '\x0600' '\x06FF'+syriac = range '\x0700' '\x074F'+thaana = range '\x0780' '\x07BF'+devanagari = range '\x0900' '\x097F'+bengali = range '\x0980' '\x09FF'+gurmukhi = range '\x0A00' '\x0A7F'+gujarati = range '\x0A80' '\x0AFF'+oriya = range '\x0B00' '\x0B7F'+tamil = range '\x0B80' '\x0BFF'+telugu = range '\x0C00' '\x0C7F'+kannada = range '\x0C80' '\x0CFF'+malayalam = range '\x0D00' '\x0D7F'+sinhala = range '\x0D80' '\x0DFF'+thai = range '\x0E00' '\x0E7F'+lao = range '\x0E80' '\x0EFF'+tibetan = range '\x0F00' '\x0FFF'+myanmar = range '\x1000' '\x109F'+georgian = range '\x10A0' '\x10FF'+hangulJamo = range '\x1100' '\x11FF'+ethiopic = range '\x1200' '\x137F'+cherokee = range '\x13A0' '\x13FF'+unifiedCanadianAboriginalSyllabics = range '\x1400' '\x167F'+ogham = range '\x1680' '\x169F'+runic = range '\x16A0' '\x16FF'+tagalog = range '\x1700' '\x171F'+hanunoo = range '\x1720' '\x173F'+buhid = range '\x1740' '\x175F'+tagbanwa = range '\x1760' '\x177F'+khmer = range '\x1780' '\x17FF'+mongolian = range '\x1800' '\x18AF'+limbu = range '\x1900' '\x194F'+taiLe = range '\x1950' '\x197F'+khmerSymbols = range '\x19E0' '\x19FF'+phoneticExtensions = range '\x1D00' '\x1D7F'+latinExtendedAdditional = range '\x1E00' '\x1EFF'+greekExtended = range '\x1F00' '\x1FFF'+generalPunctuation = range '\x2000' '\x206F'+superscriptsAndSubscripts = range '\x2070' '\x209F'+currencySymbols = range '\x20A0' '\x20CF'+combiningDiacriticalMarksForSymbols = range '\x20D0' '\x20FF'+letterlikeSymbols = range '\x2100' '\x214F'+numberForms = range '\x2150' '\x218F'+arrows = range '\x2190' '\x21FF'+mathematicalOperators = range '\x2200' '\x22FF'+miscellaneousTechnical = range '\x2300' '\x23FF'+controlPictures = range '\x2400' '\x243F'+opticalCharacterRecognition = range '\x2440' '\x245F'+enclosedAlphanumerics = range '\x2460' '\x24FF'+boxDrawing = range '\x2500' '\x257F'+blockElements = range '\x2580' '\x259F'+geometricShapes = range '\x25A0' '\x25FF'+miscellaneousSymbols = range '\x2600' '\x26FF'+dingbats = range '\x2700' '\x27BF'+miscellaneousMathematicalSymbolsA = range '\x27C0' '\x27EF'+supplementalArrowsA = range '\x27F0' '\x27FF'+braillePatterns = range '\x2800' '\x28FF'+supplementalArrowsB = range '\x2900' '\x297F'+miscellaneousMathematicalSymbolsB = range '\x2980' '\x29FF'+supplementalMathematicalOperators = range '\x2A00' '\x2AFF'+miscellaneousSymbolsAndArrows = range '\x2B00' '\x2BFF'+cjkRadicalsSupplement = range '\x2E80' '\x2EFF'+kangxiRadicals = range '\x2F00' '\x2FDF'+ideographicDescriptionCharacters = range '\x2FF0' '\x2FFF'+cjkSymbolsAndPunctuation = range '\x3000' '\x303F'+hiragana = range '\x3040' '\x309F'+katakana = range '\x30A0' '\x30FF'+bopomofo = range '\x3100' '\x312F'+hangulCompatibilityJamo = range '\x3130' '\x318F'+kanbun = range '\x3190' '\x319F'+bopomofoExtended = range '\x31A0' '\x31BF'+katakanaPhoneticExtensions = range '\x31F0' '\x31FF'+enclosedCjkLettersAndMonths = range '\x3200' '\x32FF'+cjkCompatibility = range '\x3300' '\x33FF'+cjkUnifiedIdeographsExtensionA = range '\x3400' '\x4DBF'+yijingHexagramSymbols = range '\x4DC0' '\x4DFF'+cjkUnifiedIdeographs = range '\x4E00' '\x9FFF'+yiSyllables = range '\xA000' '\xA48F'+yiRadicals = range '\xA490' '\xA4CF'+hangulSyllables = range '\xAC00' '\xD7AF'+highSurrogates = range '\xD800' '\xDB7F'+highPrivateUseSurrogates = range '\xDB80' '\xDBFF'+lowSurrogates = range '\xDC00' '\xDFFF'+privateUseArea = range '\xE000' '\xF8FF'+cjkCompatibilityIdeographs = range '\xF900' '\xFAFF'+alphabeticPresentationForms = range '\xFB00' '\xFB4F'+arabicPresentationFormsA = range '\xFB50' '\xFDFF'+variationSelectors = range '\xFE00' '\xFE0F'+combiningHalfMarks = range '\xFE20' '\xFE2F'+cjkCompatibilityForms = range '\xFE30' '\xFE4F'+smallFormVariants = range '\xFE50' '\xFE6F'+arabicPresentationFormsB = range '\xFE70' '\xFEFF'+halfwidthAndFullwidthForms = range '\xFF00' '\xFFEF'+specials = range '\xFFF0' '\xFFFF'
+ Text/Trifecta/CharSet/Unicode/Category.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.CharSet.Unicode.Category+-- Copyright   :  (c) Edward Kmett 2010-2011+-- License     :  BSD3+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Provides unicode general categories, which are typically connoted by +-- @\p{Ll}@ or @\p{Modifier_Letter}@. Lookups can be constructed using 'categories'+-- or individual character sets can be used directly.+-- +-- A case, @_@ and @-@ insensitive lookup is provided by 'lookupCategory'+-- and can be used to provide behavior similar to that of Perl or PCRE.+-------------------------------------------------------------------------------++module Text.Trifecta.CharSet.Unicode.Category+    ( +    -- * Unicode General Category+      Category(..)+    -- * Lookup+    , categories+    , lookupCategory+    , lookupCategoryCharSet+    -- * CharSets by Category+    -- ** Letter+    , modifierLetter, otherLetter, letter+    -- *** Letter\&+    , lowercaseLetter, uppercaseLetter, titlecaseLetter, letterAnd+    -- ** Mark+    , nonSpacingMark, spacingCombiningMark, enclosingMark, mark+    -- ** Separator+    , space, lineSeparator, paragraphSeparator, separator+    -- ** Symbol+    , mathSymbol, currencySymbol, modifierSymbol, otherSymbol, symbol+    -- ** Number+    , decimalNumber, letterNumber, otherNumber, number+    -- ** Punctuation+    , dashPunctuation, openPunctuation, closePunctuation, initialQuote+    , finalQuote, connectorPunctuation, otherPunctuation, punctuation +    -- ** Other+    , control, format, privateUse, surrogate, notAssigned, other+    ) where++import Data.Char+import Text.Trifecta.CharSet.Prim+import Data.Data+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap++data Category = Category +    { categoryName :: String+    , categoryAbbreviation :: String+    , categoryCharSet :: CharSet+    , categoryDescription :: String+    } deriving (Show, Data, Typeable)++-- \p{Letter} or \p{Mc}+categories :: [Category]+categories =+    [ Category "Letter" "L" letter "any kind of letter from any language."+    ,     Category "Lowercase_Letter" "Ll" lowercaseLetter "a lowercase letter that has an uppercase variant"+    ,     Category "Uppercase_Letter" "Lu" uppercaseLetter "an uppercase letter that has a lowercase variant"+    ,     Category "Titlecase_Letter" "Lt" titlecaseLetter "a letter that appears at the start of a word when only the first letter of the word is capitalized"+    ,     Category "Letter&" "L&" letterAnd "a letter that exists in lowercase and uppercase variants (combination of Ll, Lu and Lt)"+    ,     Category "Modifier_Letter" "Lm" modifierLetter "a special character that is used like a letter"+    ,     Category "Other_Letter" "Lo" otherLetter "a letter or ideograph that does not have lowercase and uppercase variants"+    , Category "Mark" "M" mark "a character intended to be combined with another character (e.g. accents, umlauts, enclosing boxes, etc.)"+    ,     Category "Non_Spacing_Mark" "Mn" nonSpacingMark "a character intended to be combined with another character without taking up extra space (e.g. accents, umlauts, etc.)"+    ,     Category "Spacing_Combining_Mark" "Mc" spacingCombiningMark "a character intended to be combined with another character that takes up extra space (vowel signs in many Eastern languages)"+    ,     Category "Enclosing_Mark" "Me" enclosingMark "a character that encloses the character is is combined with (circle, square, keycap, etc.)"+    , Category "Separator" "Z" separator "any kind of whitespace or invisible separator"+    ,     Category "Space_Separator" "Zs" space "a whitespace character that is invisible, but does take up space"+    ,     Category "Line_Separator" "Zl" lineSeparator "line separator character U+2028"+    ,     Category "Paragraph_Separator" "Zp" paragraphSeparator "paragraph separator character U+2029"+    , Category "Symbol" "S" symbol "math symbols, currency signs, dingbats, box-drawing characters, etc."+    ,     Category "Math_Symbol" "Sm" mathSymbol "any mathematical symbol"+    ,     Category "Currency_Symbol" "Sc" currencySymbol "any currency sign"+    ,     Category "Modifier_Symbol" "Sk" modifierSymbol "a combining character (mark) as a full character on its own"+    ,     Category "Other_Symbol" "So" otherSymbol "various symbols that are not math symbols, currency signs, or combining characters"+    , Category "Number" "N" number "any kind of numeric character in any script"+    ,     Category "Decimal_Digit_Number" "Nd" decimalNumber "a digit zero through nine in any script except ideographic scripts"+    ,     Category "Letter_Number" "Nl" letterNumber "a number that looks like a letter, such as a Roman numeral"+    ,     Category "Other_Number" "No" otherNumber "a superscript or subscript digit, or a number that is not a digit 0..9 (excluding numbers from ideographic scripts)"+    , Category "Punctuation" "P" punctuation "any kind of punctuation character"+    ,     Category "Dash_Punctuation" "Pd" dashPunctuation "any kind of hyphen or dash"+    ,     Category "Open_Punctuation" "Ps" openPunctuation "any kind of opening bracket"+    ,     Category "Close_Punctuation" "Pe" closePunctuation "any kind of closing bracket"+    ,     Category "Initial_Punctuation" "Pi" initialQuote "any kind of opening quote"+    ,     Category "Final_Punctuation" "Pf" finalQuote "any kind of closing quote"+    ,     Category "Connector_Punctuation" "Pc" connectorPunctuation "a punctuation character such as an underscore that connects words"+    ,     Category "Other_Punctuation" "Po" otherPunctuation "any kind of punctuation character that is not a dash, bracket, quote or connector"+    , Category "Other" "C" other "invisible control characters and unused code points"+    ,     Category "Control" "Cc" control "an ASCII 0x00..0x1F or Latin-1 0x80..0x9F control character"+    ,     Category "Format" "Cf" format "invisible formatting indicator"+    ,     Category "Private_Use" "Co" privateUse "any code point reserved for private use"+    ,     Category "Surrogate" "Cs" surrogate "one half of a surrogate pair in UTF-16 encoding"+    ,     Category "Unassigned" "Cn" notAssigned "any code point to which no character has been assigned.properties" ]++lookupTable :: HashMap String Category+lookupTable = HashMap.fromList +  [ (canonicalize x, category) +  | category@(Category l s _ _) <- categories+  , x <- [l,s] +  ]++lookupCategory :: String -> Maybe Category+lookupCategory s = HashMap.lookup (canonicalize s) lookupTable++lookupCategoryCharSet :: String -> Maybe CharSet+lookupCategoryCharSet = fmap categoryCharSet . lookupCategory++canonicalize :: String -> String+canonicalize s = case Prelude.map toLower s of+  'i' : 's' : xs -> go xs+  xs -> go xs+  where+    go ('-':xs) = go xs+    go ('_':xs) = go xs+    go (' ':xs) = go xs+    go (x:xs) = x : go xs+    go [] = []++cat :: GeneralCategory -> CharSet+cat category = build ((category ==) . generalCategory)++-- Letter+lowercaseLetter, uppercaseLetter, titlecaseLetter, letterAnd, modifierLetter, otherLetter, letter :: CharSet+lowercaseLetter = cat LowercaseLetter+uppercaseLetter = cat UppercaseLetter+titlecaseLetter = cat TitlecaseLetter+letterAnd = lowercaseLetter +    `union` uppercaseLetter +    `union` titlecaseLetter+modifierLetter  = cat ModifierLetter+otherLetter = cat OtherLetter+letter +          = letterAnd +    `union` modifierLetter +    `union` otherLetter++-- Marks+nonSpacingMark, spacingCombiningMark, enclosingMark, mark :: CharSet+nonSpacingMark = cat NonSpacingMark+spacingCombiningMark = cat SpacingCombiningMark+enclosingMark = cat EnclosingMark+mark +          = nonSpacingMark +    `union` spacingCombiningMark +    `union` enclosingMark++space, lineSeparator, paragraphSeparator, separator :: CharSet+space = cat Space+lineSeparator = cat LineSeparator+paragraphSeparator = cat ParagraphSeparator+separator +          = space +    `union` lineSeparator +    `union` paragraphSeparator++mathSymbol, currencySymbol, modifierSymbol, otherSymbol, symbol :: CharSet+mathSymbol = cat MathSymbol+currencySymbol = cat CurrencySymbol+modifierSymbol = cat ModifierSymbol+otherSymbol = cat OtherSymbol+symbol +          = mathSymbol +    `union` currencySymbol +    `union` modifierSymbol +    `union` otherSymbol++decimalNumber, letterNumber, otherNumber, number :: CharSet+decimalNumber = cat DecimalNumber+letterNumber = cat LetterNumber+otherNumber = cat OtherNumber+number +          = decimalNumber +    `union` letterNumber +    `union` otherNumber++dashPunctuation, openPunctuation, closePunctuation, initialQuote, +  finalQuote, connectorPunctuation, otherPunctuation, punctuation :: CharSet++dashPunctuation = cat DashPunctuation+openPunctuation = cat OpenPunctuation+closePunctuation = cat ClosePunctuation+initialQuote = cat InitialQuote+finalQuote = cat FinalQuote+connectorPunctuation  = cat ConnectorPunctuation+otherPunctuation = cat OtherPunctuation+punctuation +          = dashPunctuation +    `union` openPunctuation +    `union` closePunctuation +    `union` initialQuote +    `union` finalQuote +    `union` connectorPunctuation +    `union` otherPunctuation++control, format, privateUse, surrogate, notAssigned, other :: CharSet+control = cat Control+format = cat Format+privateUse = cat PrivateUse+surrogate = cat Surrogate+notAssigned = cat NotAssigned+other = control +    `union` format +    `union` privateUse +    `union` surrogate +    `union` notAssigned
− Text/Trifecta/Delta.hs 
@@ -1,155 +0,0 @@-module Text.Trifecta.Delta -  ( Delta(..) -  , HasDelta(..)-  , nextTab-  , rewind-  , near-  , column-  , columnByte-  ) where--import Control.Applicative-import Data.Monoid-import Data.Semigroup-import Data.Hashable-import Data.Word-import Data.Interned-import Data.Foldable-import Data.FingerTree hiding (empty)-import Data.ByteString hiding (empty)-import Text.Trifecta.Path-import Text.Trifecta.Bytes-import Text.PrettyPrint.Free hiding (column)-import System.Console.Terminfo.PrettyPrint--data Delta-  = Columns   {-# UNPACK #-} !Int  -- the number of characters-              {-# UNPACK #-} !Int  -- the number of bytes-  | Tab       {-# UNPACK #-} !Int  -- the number of characters before the tab-              {-# UNPACK #-} !Int  -- the number of characters after the tab-              {-# UNPACK #-} !Int  -- the number of bytes-  | Lines     {-# UNPACK #-} !Int  -- the number of newlines contained-              {-# UNPACK #-} !Int  -- the number of characters since the last newline-              {-# UNPACK #-} !Int  -- number of bytes-              {-# UNPACK #-} !Int  -- the number of bytes since the last newline-  | Directed                 !Path -- the sequence of #line directives since the start of the file-              {-# UNPACK #-} !Int  -- the number of lines since the last line directive-              {-# UNPACK #-} !Int  -- the number of characters since the last newline-              {-# UNPACK #-} !Int  -- number of bytes-              {-# 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--instance Pretty Delta where-  pretty p = prettyTerm p *> empty--instance PrettyTerm Delta where-  prettyTerm d = case d of-    Columns c _ -> k "-" 1 c-    Tab x y _ -> k "-" 1 (nextTab x + y)-    Lines l c _ _ -> k "-" l c-    Directed (Path _ _ _ fn _ _) l c _ _ -> k (maybeFileName "-" unintern fn) l c  -- TODO: add include path-    where -      k fn ln cn = bold (string fn)           -                <> char ':' -                <> bold (int ln)         -                <> char ':' -                <> bold (int (cn + 1))--column :: HasDelta t => t -> Int-column t = case delta t of -  Columns c _ -> c-  Tab b a _ -> nextTab b + a-  Lines _ c _ _ -> c-  Directed _ _ c _ _ -> c--instance HasBytes Delta where-  bytes (Columns _ b) = b-  bytes (Tab _ _ b) = b-  bytes (Lines _ _ b _) = b-  bytes (Directed _ _ _ b _) = b--instance Hashable Delta where-  hash (Columns c a)        = 0 `hashWithSalt` c `hashWithSalt` a-  hash (Tab x y a)          = 1 `hashWithSalt` x `hashWithSalt` y `hashWithSalt` a-  hash (Lines l c b a)      = 2 `hashWithSalt` l `hashWithSalt` c `hashWithSalt` b `hashWithSalt` a-  hash (Directed p l c b a) = 3 `hashWithSalt` p `hashWithSalt` l `hashWithSalt` c `hashWithSalt` b `hashWithSalt` a--instance Monoid Delta where-  mempty = Columns 0 0-  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 p l _ t _ <> Directed p' l' c' t' b = Directed (appendPath p l p') l' c' (t + t') b-  -nextTab :: Int -> Int-nextTab x = x + (8 - mod x 8)--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 --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--class HasDelta t where-  delta :: t -> Delta--instance HasDelta Delta where-  delta = id--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-    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--instance HasDelta ByteString where-  delta = foldMap delta . unpack--instance HasDelta Path where-  delta p = Directed p 0 0 0 0--instance (Measured v a, HasDelta v) => HasDelta (FingerTree v a) where-  delta = delta . measure
Text/Trifecta/Diagnostic.hs view
@@ -1,82 +1,15 @@-{-# LANGUAGE FlexibleContexts #-} module Text.Trifecta.Diagnostic    ( Diagnostic(..)   , tellDiagnostic+  , DiagnosticLevel(..)+  , Renderable(..)+  , Source+  , rendering+  , Caret(..), Careted(..)+  , Span(..), Spanned(..)+  , Fixit(..), Rendered(..)   ) where -import Control.Applicative-import Control.Comonad-import Control.Monad (guard)-import Control.Monad.Writer.Class-import Data.Functor.Apply-import Data.Foldable-import Data.Traversable-import Data.Monoid-import Data.List.NonEmpty hiding (map)-import Data.Semigroup-import Data.Semigroup.Reducer-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Text.Trifecta.Bytes-import Text.Trifecta.Delta-import Text.Trifecta.Render.Prim+import Text.Trifecta.Diagnostic.Prim import Text.Trifecta.Diagnostic.Level-import Text.PrettyPrint.Free-import System.Console.Terminfo.PrettyPrint-import Prelude hiding (log)--data Diagnostic m = Diagnostic !Render !DiagnosticLevel m [Diagnostic m]-  deriving Show--tellDiagnostic :: (MonadWriter t m, Reducer (Diagnostic e) t) => Diagnostic e -> m ()-tellDiagnostic = tell . unit--instance Renderable (Diagnostic m) where-  render (Diagnostic r _ _ _) = r--instance HasDelta (Diagnostic m) where-  delta (Diagnostic r _ _ _) = delta r--instance HasBytes (Diagnostic m) where-  bytes = bytes . delta--instance Extend Diagnostic where-  extend f d@(Diagnostic r l _ xs) = Diagnostic r l (f d) (map (extend f) xs)--instance Comonad Diagnostic where-  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 (nullRender r)))-     <> (indent 2 (prettyList xs) <$ guard (not (null xs)))-  prettyList = Prelude.foldr ((<>) . pretty) empty--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 (nullRender r)))-     <> (indent 2 (prettyTermList xs) <$ guard (not (null xs)))-  prettyTermList = Prelude.foldr ((<>) . prettyTerm) empty--instance Functor Diagnostic where-  fmap f (Diagnostic r l m xs) = Diagnostic r l (f m) $ map (fmap f) xs--instance Foldable Diagnostic where-  foldMap f (Diagnostic _ _ m xs) = f m `mappend` foldMap (foldMap f) xs--instance Traversable Diagnostic where-  traverse f (Diagnostic r l m xs) = Diagnostic r l <$> f m <*> traverse (traverse f) xs--instance Foldable1 Diagnostic where-  foldMap1 f (Diagnostic _ _ m []) = f m-  foldMap1 f (Diagnostic _ _ m (x:xs)) = f m <> foldMap1 (foldMap1 f) (x:|xs)--instance Traversable1 Diagnostic where-  traverse1 f (Diagnostic r l m [])     = fmap (\fm -> Diagnostic r l fm []) (f m)-  traverse1 f (Diagnostic r l m (x:xs)) = (\fm (y:|ys) -> Diagnostic r l fm (y:ys)) -                                      <$> f m -                                      <.> traverse1 (traverse1 f) (x:|xs)--+import Text.Trifecta.Diagnostic.Rendering
+ Text/Trifecta/Diagnostic/Err.hs view
@@ -0,0 +1,82 @@+module Text.Trifecta.Diagnostic.Err+  ( Err(..)+  , diagnose+  , knownErr+  ) where++import Control.Applicative+import Control.Comonad+import Data.Semigroup+import Data.Monoid+import Data.Functor.Plus+import Text.Trifecta.Diagnostic.Prim+import Text.Trifecta.Diagnostic.Level+import Text.Trifecta.Diagnostic.Rendering.Prim+import Text.PrettyPrint.Free+import System.Console.Terminfo.PrettyPrint++-- | unlocated error messages+data Err e+  = EmptyErr+  | FailErr String +  | UnexpectedErr String+  | EndOfFileErr+  | RichErr (Rendering -> Diagnostic e)++instance Show (Err e) where+  showsPrec _ EmptyErr = showString "EmptyErr"+  showsPrec d (FailErr s) = showParen (d > 10) $+    showString "FailErr " . showsPrec 11 s+  showsPrec d (UnexpectedErr s) = showParen (d > 10) $+    showString "UnexpectedErr " . showsPrec 11 s+  showsPrec _ EndOfFileErr = showString "EndOfFileErr"+  showsPrec d (RichErr _) = showParen (d > 10) $ +    showString "RichErr ..."++knownErr :: Err e -> Bool+knownErr EmptyErr = False+knownErr _ = True++diagnose :: (t -> Doc e) -> Rendering -> Err t -> Diagnostic (Doc e)+diagnose _ r EmptyErr          = Diagnostic r Error (text "unexpected") []+diagnose _ r (FailErr m)       = Diagnostic r Error (fillSep $ text <$> words m) []+diagnose _ r (UnexpectedErr s) = Diagnostic r Error (fillSep $ fmap text $ "unexpected" : words s) []+diagnose _ r EndOfFileErr      = Diagnostic r Error (text "unexpected EOF") []+diagnose k r (RichErr f)       = fmap k (f r)++diagnose0 :: Pretty t => Err t -> Diagnostic (Doc e)+diagnose0 = diagnose pretty emptyRendering++diagnoseTerm0 :: PrettyTerm t => Err t -> Diagnostic TermDoc+diagnoseTerm0 = diagnose prettyTerm emptyRendering++instance Pretty t => Pretty (Err t) where+  pretty = pretty . extract . diagnose0+  prettyList = prettyList . map (extract . diagnose0)++instance PrettyTerm t => PrettyTerm (Err t) where+  prettyTerm = prettyTerm . diagnoseTerm0+  prettyTermList = prettyTermList . map diagnoseTerm0+  +instance Functor Err where+  fmap _ EmptyErr = EmptyErr+  fmap _ (FailErr s) = FailErr s+  fmap _ EndOfFileErr = EndOfFileErr+  fmap _ (UnexpectedErr s) = UnexpectedErr s +  fmap f (RichErr k) = RichErr (fmap f . k)++instance Alt Err where+  EmptyErr <!> a = a+  a        <!> _ = a+  {-# INLINE (<!>) #-}++instance Plus Err where+  zero = EmptyErr++instance Semigroup (Err t) where+  (<>) = (<!>)+  replicate1p _ = id++instance Monoid (Err t) where+  mempty = EmptyErr+  mappend = (<!>)
+ Text/Trifecta/Diagnostic/Err/State.hs view
@@ -0,0 +1,34 @@+module Text.Trifecta.Diagnostic.Err.State +  ( ErrState(..)+  ) where++import Data.Functor.Plus+import Data.Set as Set+import Data.Sequence as Seq+import Data.Semigroup+import Data.Monoid+import Text.Trifecta.Diagnostic.Err+import Text.Trifecta.Diagnostic++data ErrState e = ErrState+ { errExpected :: !(Set String)+ , errMessage  :: !(Err e)+ , errLog      :: !(Seq (Diagnostic e))+ }++instance Functor ErrState where+  fmap f (ErrState a b c) = ErrState a (fmap f b) (fmap (fmap f) c)++instance Alt ErrState where+  ErrState a b c <!> ErrState a' b' c' = ErrState (a <> a') (b <!> b') (c <!> c')+  {-# INLINE (<!>) #-}++instance Plus ErrState where+  zero = ErrState mempty zero zero+ +instance Semigroup (ErrState e) where+  (<>) = (<!>) ++instance Monoid (ErrState e) where+  mempty = zero+  mappend = (<!>)
+ Text/Trifecta/Diagnostic/Prim.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE FlexibleContexts #-}+module Text.Trifecta.Diagnostic.Prim+  ( Diagnostic(..)+  , tellDiagnostic+  ) where++import Control.Applicative+import Control.Comonad+import Control.Monad (guard)+import Control.Monad.Writer.Class+import Data.Functor.Apply+import Data.Foldable+import Data.Traversable+import Data.Monoid+import Data.List.NonEmpty hiding (map)+import Data.Semigroup+import Data.Semigroup.Reducer+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Text.Trifecta.Rope.Bytes+import Text.Trifecta.Rope.Delta+import Text.Trifecta.Diagnostic.Rendering.Prim+import Text.Trifecta.Diagnostic.Level+import Text.PrettyPrint.Free+import System.Console.Terminfo.PrettyPrint+import Prelude hiding (log)++data Diagnostic m = Diagnostic !Rendering !DiagnosticLevel m [Diagnostic m]+  deriving Show++tellDiagnostic :: (MonadWriter t m, Reducer (Diagnostic e) t) => Diagnostic e -> m ()+tellDiagnostic = tell . unit++instance Renderable (Diagnostic m) where+  render (Diagnostic r _ _ _) = r++instance HasDelta (Diagnostic m) where+  delta (Diagnostic r _ _ _) = delta r++instance HasBytes (Diagnostic m) where+  bytes = bytes . delta++instance Extend Diagnostic where+  extend f d@(Diagnostic r l _ xs) = Diagnostic r l (f d) (map (extend f) xs)++instance Comonad Diagnostic where+  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)))+  prettyList = Prelude.foldr ((<>) . pretty) empty++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)))+  prettyTermList = Prelude.foldr ((<>) . prettyTerm) empty++instance Functor Diagnostic where+  fmap f (Diagnostic r l m xs) = Diagnostic r l (f m) $ map (fmap f) xs++instance Foldable Diagnostic where+  foldMap f (Diagnostic _ _ m xs) = f m `mappend` foldMap (foldMap f) xs++instance Traversable Diagnostic where+  traverse f (Diagnostic r l m xs) = Diagnostic r l <$> f m <*> traverse (traverse f) xs++instance Foldable1 Diagnostic where+  foldMap1 f (Diagnostic _ _ m []) = f m+  foldMap1 f (Diagnostic _ _ m (x:xs)) = f m <> foldMap1 (foldMap1 f) (x:|xs)++instance Traversable1 Diagnostic where+  traverse1 f (Diagnostic r l m [])     = fmap (\fm -> Diagnostic r l fm []) (f m)+  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.hs view
@@ -0,0 +1,12 @@+module Text.Trifecta.Diagnostic.Rendering+  ( Renderable(..)+  , Source, rendering+  , Caret(..), Careted(..)+  , Span(..), Spanned(..)+  , Fixit(..), Rendered(..)+  ) where++import Text.Trifecta.Diagnostic.Rendering.Prim+import Text.Trifecta.Diagnostic.Rendering.Caret+import Text.Trifecta.Diagnostic.Rendering.Span+import Text.Trifecta.Diagnostic.Rendering.Fixit
+ Text/Trifecta/Diagnostic/Rendering/Caret.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Text.Trifecta.Diagnostic.Rendering.Caret+  ( Caret(..)+  , caret+  , Careted(..)+  , careted+  -- * Internals+  , drawCaret+  , addCaret+  , caretEffects+  ) where++import Control.Applicative+import Control.Comonad+import Data.ByteString (ByteString)+import Data.Foldable+import Data.Functor.Bind+import Data.Hashable+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Semigroup.Reducer+import Data.Traversable+import Prelude hiding (span)+import System.Console.Terminfo.Color+import System.Console.Terminfo.PrettyPrint+import Text.Trifecta.Rope.Bytes+import Text.Trifecta.Rope.Delta+import Text.Trifecta.Parser.Class+import Text.Trifecta.Diagnostic.Rendering.Prim++-- |+-- > In file included from baz.c:9+-- > In file included from bar.c:4+-- > foo.c:8:36: note+-- > int main(int argc, char ** argv) { int; }+-- >                                    ^+data Caret = Caret !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show)++instance Hashable Caret where+  hash (Caret d bs) = hash d `hashWithSalt` bs++caretEffects :: [ScopedEffect]+caretEffects = [soft (Foreground Green), soft Bold]++drawCaret :: Delta -> Delta -> Lines -> Lines+drawCaret p = ifNear p $ draw caretEffects 1 (column p) "^"++addCaret :: Delta -> Rendering -> Rendering+addCaret p r = drawCaret p .# r++caret :: MonadParser m => m Caret+caret = Caret <$> mark <*> line+  +careted :: MonadParser m => m a -> m (Careted a)+careted p = do+  m <- mark+  l <- line+  a <- p+  return $ a :^ Caret m l++instance HasBytes Caret where+  bytes = bytes . delta++instance HasDelta Caret where+  delta (Caret d _) = d++instance Renderable Caret where+  render (Caret d bs) = addCaret d $ rendering d bs++instance Reducer Caret Rendering where+  unit = render++instance Semigroup Caret where+  a <> _ = a++data Careted a = a :^ Caret deriving (Eq,Ord,Show)++instance Functor Careted where+  fmap f (a :^ s) = f a :^ s++instance Extend Careted where+  extend f as@(_ :^ s) = f as :^ s++instance Comonad Careted where+  extract (a :^ _) = a++instance Foldable Careted where+  foldMap f (a :^ _) = f a++instance Traversable Careted where+  traverse f (a :^ s) = (:^ s) <$> f a++instance Foldable1 Careted where+  foldMap1 f (a :^ _) = f a++instance Traversable1 Careted where+  traverse1 f (a :^ s) = (:^ s) <$> f a++instance Renderable (Careted a) where+  render (_ :^ a) = render a++instance Reducer (Careted a) Rendering where+  unit = render++instance Hashable a => Hashable (Careted a) where+
+ Text/Trifecta/Diagnostic/Rendering/Fixit.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Text.Trifecta.Diagnostic.Rendering.Fixit+  ( Fixit(..)+  , drawFixit+  , addFixit+  , fixit+  ) where++import Data.Functor+import Data.Hashable+import Data.ByteString (ByteString)+import qualified Data.ByteString as Strict+import qualified Data.ByteString.UTF8 as UTF8+import Data.Semigroup.Reducer+import Text.Trifecta.Rope.Bytes+import Text.Trifecta.Rope.Delta+import Text.Trifecta.Diagnostic.Rendering.Prim+import Text.Trifecta.Diagnostic.Rendering.Span+import Text.Trifecta.Parser.Class+import Text.Trifecta.Util+import System.Console.Terminfo.Color+import System.Console.Terminfo.PrettyPrint+import Prelude hiding (span)++-- |+-- > int main(int argc char ** argv) { int; }+-- >                  ^+-- >                  ,+drawFixit :: Delta -> Delta -> String -> Delta -> Lines -> Lines+drawFixit s e rpl d a = ifNear l (draw [soft (Foreground Blue)] 2 (column l) rpl) d +                      $ drawSpan s e d a+  where l = argmin bytes s e++addFixit :: Delta -> Delta -> String -> Rendering -> Rendering+addFixit s e rpl r = drawFixit s e rpl .# r++data Fixit = Fixit +  { fixitSpan        :: {-# UNPACK #-} !Span+  , fixitReplacement  :: {-# UNPACK #-} !ByteString +  } deriving (Eq,Ord,Show)++instance Hashable Fixit where+  hash (Fixit s b) = hash s `hashWithSalt` b++instance Reducer Fixit Rendering where+  unit = render++instance Renderable Fixit where+  render (Fixit (Span s e bs) r) = addFixit s e (UTF8.toString r) $ rendering s bs++fixit :: MonadParser m => m Strict.ByteString -> m Fixit+fixit p = (\(r :~ s) -> Fixit s r) <$> spanned p
+ Text/Trifecta/Diagnostic/Rendering/Prim.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE TypeSynonymInstances #-}++-- | Diagnostics rendering+module Text.Trifecta.Diagnostic.Rendering.Prim +  ( Rendering(..)+  , nullRendering+  , emptyRendering+  , Source(..)+  , rendering+  , Renderable(..)+  , Rendered(..)+  -- * Lower level drawing primitives+  , Lines+  , draw+  , ifNear+  , (.#)+  ) where++import Control.Applicative+import Control.Comonad+import Control.Monad.State+import Data.Array+import Data.ByteString hiding (groupBy, empty, any)+import Data.Foldable+import Data.Monoid+import Data.Function (on)+import Data.Functor.Bind+import Data.List (groupBy)+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Traversable+import Prelude as P+import Prelude hiding (span)+import System.Console.Terminfo.PrettyPrint+import Text.PrettyPrint.Free hiding (column)+import Text.Trifecta.Rope.Bytes+import Text.Trifecta.Rope.Delta+import qualified Data.ByteString.UTF8 as UTF8 ++outOfRangeEffects :: [ScopedEffect] -> [ScopedEffect]+outOfRangeEffects xs = soft Bold : xs++type Lines = Array (Int,Int) ([ScopedEffect], Char)++(///) :: Ix i => Array i e -> [(i, e)] -> Array i e+a /// xs = a // P.filter (inRange (bounds a) . fst) xs+++grow :: Int -> Lines -> Lines+grow y a +  | inRange (t,b) y = a+  | otherwise = array new [ (i, if inRange old i then a ! i else ([],' ')) | i <- range new ]+  where old@((t,lo),(b,hi)) = bounds a+        new = ((min t y,lo),(max b y,hi))++draw :: [ScopedEffect] -> Int -> Int -> String -> Lines -> Lines+draw e y n xs a0 +  | Prelude.null xs = a0+  | otherwise = gt $ lt (a /// out) +  where +    a = grow y a0+    ((_,lo),(_,hi)) = bounds a+    out = P.zipWith (\i c -> ((y,i),(e,c))) [n..] xs+    lt | Prelude.any (\el -> snd (fst el) < lo) out = (// [((y,lo),(outOfRangeEffects e,'<'))])+       | otherwise = id+    gt | Prelude.any (\el -> snd (fst el) > hi) out = (// [((y,hi),(outOfRangeEffects e,'>'))])+       | otherwise = id++data Rendering = Rendering+  { renderingDelta    :: !Delta                  -- focus, the render will keep this visible+  , renderingLineLen  :: {-# UNPACK #-} !Int     -- actual line length+  , renderingLine     :: Lines -> Lines+  , renderingOverlays :: Delta -> Lines -> Lines+  }++instance Show Rendering where+  showsPrec d (Rendering p ll _ _) = showParen (d > 10) $ +    showString "Rendering " . showsPrec 11 p . showChar ' ' . showsPrec 11 ll . showString " ... ..."++nullRendering :: Rendering -> Bool+nullRendering (Rendering (Columns 0 0) 0 _ _) = True+nullRendering _ = False++emptyRendering :: Rendering+emptyRendering = rendering (Columns 0 0) ""++instance Semigroup Rendering where+  -- an unprincipled hack+  Rendering (Columns 0 0) 0 _ f <> Rendering del len doc g = Rendering del len doc $ \d l -> f d (g d l)+  Rendering del len doc f <> Rendering _ _ _ g = Rendering del len doc $ \d l -> f d (g d l)++instance Monoid Rendering where+  mappend = (<>) +  mempty = emptyRendering+  +ifNear :: Delta -> (Lines -> Lines) -> Delta -> Lines -> Lines+ifNear d f d' l | near d d' = f l +                | otherwise = l++instance HasDelta Rendering where+  delta = renderingDelta++class Renderable t where+  render :: t -> Rendering++instance Renderable Rendering where+  render = id++class Source t where+  source :: t -> (Int, Lines -> Lines)++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 _ []        = []++instance Source ByteString where+  source = source . UTF8.toString++-- | create a drawing surface+rendering :: Source s => Delta -> s -> Rendering+rendering del s = case source s of +  (len, doc) -> Rendering del len doc (\_ l -> l)++(.#) :: (Delta -> Lines -> Lines) -> Rendering -> Rendering+f .# Rendering d ll s g = Rendering d ll s $ \e l -> f e $ g e l ++instance Pretty Rendering where+  pretty r = prettyTerm r >>= const empty++instance PrettyTerm Rendering where+  prettyTerm (Rendering d ll l f) = nesting $ \k -> columns $ \n -> go (n - k) where+    go cols = align (vsep (P.map ln [t..b])) where +      (lo, hi) = window (column d) ll (cols - 2)+      a = f d $ l $ array ((0,lo),(-1,hi)) []+      ((t,_),(b,_)) = bounds a+      ln y = hcat +           $ P.map (\g -> P.foldr with (string (P.map snd g)) (fst (P.head g)))+           $ groupBy ((==) `on` fst) +           [ a ! (y,i) | i <- [lo..hi] ] ++window :: Int -> Int -> Int -> (Int, Int)+window c l w +  | c <= w2     = (0, min w l)+  | c + w2 >= l = if l > w then (l-w, l) else (0, w)+  | otherwise   = (c-w2,c + w2)+  where w2 = div w 2++data Rendered a = a :@ Rendering+  deriving Show++instance Functor Rendered where+  fmap f (a :@ s) = f a :@ s++instance HasDelta (Rendered a) where+  delta = delta . render++instance HasBytes (Rendered a) where+  bytes = bytes . delta++instance Extend Rendered where+  extend f as@(_ :@ s) = f as :@ s++instance Comonad Rendered where+  extract (a :@ _) = a++instance Apply Rendered where+  (f :@ s) <.> (a :@ t) = f a :@ (s <> t)++instance Bind Rendered where+  (a :@ s) >>- f = case f a of+     b :@ t -> b :@ (s <> t)++instance Foldable Rendered where+  foldMap f (a :@ _) = f a ++instance Traversable Rendered where+  traverse f (a :@ s) = (:@ s) <$> f a++instance Foldable1 Rendered where+  foldMap1 f (a :@ _) = f a ++instance Traversable1 Rendered where+  traverse1 f (a :@ s) = (:@ s) <$> f a++instance Renderable (Rendered a) where+  render (_ :@ s) = s
+ Text/Trifecta/Diagnostic/Rendering/Span.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Text.Trifecta.Diagnostic.Rendering.Span+  ( Span(..)+  , span+  , Spanned(..)+  , spanned+  -- * Internals+  , spanEffects+  , drawSpan+  , addSpan+  ) where++import Control.Applicative+import Data.Hashable+import Data.Semigroup+import Data.Semigroup.Reducer+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import Data.Foldable+import Data.Traversable+import Control.Comonad+import Data.Functor.Bind+import Data.ByteString (ByteString)+import Text.Trifecta.Rope.Bytes+import Text.Trifecta.Rope.Delta+import Text.Trifecta.Diagnostic.Rendering.Prim+import Text.Trifecta.Util+import Text.Trifecta.Parser.Class+import Data.Array+import System.Console.Terminfo.Color+import System.Console.Terminfo.PrettyPrint+import Prelude as P hiding (span)++spanEffects :: [ScopedEffect]+spanEffects  = [soft (Foreground Green)]++drawSpan :: Delta -> Delta -> Delta -> Lines -> Lines+drawSpan s e d a+  | nl && nh  = go (column l) (P.replicate (max (column h   - column l + 1) 0) '~') a+  | nl        = go (column l) (P.replicate (max (snd (snd (bounds a)) - column l + 2) 0) '~') a+  |       nh  = go (-1)       (P.replicate (max (column h + 1) 0) '~') a+  | otherwise = a+  where+    go = draw spanEffects 1+    l = argmin bytes s e+    h = argmax bytes s e+    nl = near l d+    nh = near h d++-- |+-- > int main(int argc, char ** argv) { int; }+-- >                                    ^~~+addSpan :: Delta -> Delta -> Rendering -> Rendering+addSpan s e r = drawSpan s e .# r++data Span = Span !Delta !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show)++instance Renderable Span where+  render (Span s e bs) = addSpan s e $ rendering s bs++instance Semigroup Span where+  Span s _ b <> Span _ e _ = Span s e b++instance Reducer Span Rendering where+  unit = render++data Spanned a = a :~ Span deriving (Eq,Ord,Show)++instance Functor Spanned where+  fmap f (a :~ s) = f a :~ s++instance Extend Spanned where+  extend f as@(_ :~ s) = f as :~ s++instance Comonad Spanned where+  extract (a :~ _) = a++instance Apply Spanned where+  (f :~ s) <.> (a :~ t) = f a :~ (s <> t)++instance Bind Spanned where+  (a :~ s) >>- f = case f a of+     b :~ t -> b :~ (s <> t)++instance Foldable Spanned where+  foldMap f (a :~ _) = f a ++instance Traversable Spanned where+  traverse f (a :~ s) = (:~ s) <$> f a++instance Foldable1 Spanned where+  foldMap1 f (a :~ _) = f a ++instance Traversable1 Spanned where+  traverse1 f (a :~ s) = (:~ s) <$> f a++instance Reducer (Spanned a) Rendering where+  unit = render++instance Renderable (Spanned a) where+  render (_ :~ s) = render s++instance Hashable Span where+  hash (Span s e bs) = hash s `hashWithSalt` e `hashWithSalt` bs++instance Hashable a => Hashable (Spanned a) where+  hash (a :~ s) = hash a `hashWithSalt` s++span :: MonadParser m => m a -> m Span +span p = (\s l e -> Span s e l) <$> mark <*> line <*> (p *> mark)+  +spanned :: MonadParser m => m a -> m (Spanned a)+spanned p = (\s l a e -> a :~ Span s e l) <$> mark <*> line <*> p <*> mark
− Text/Trifecta/Hunk.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-}-module Text.Trifecta.Hunk -  ( Hunk(..)-  , hunk-  ) where--import Data.ByteString-import qualified Data.ByteString.UTF8 as UTF8-import Data.FingerTree as FingerTree-import Data.Function (on)-import Data.Hashable-import Data.Interned-import Data.String-import Text.Trifecta.Delta--data Hunk = Hunk {-# UNPACK #-} !Id !Delta {-# UNPACK #-} !ByteString-  deriving Show--hunk :: ByteString -> Hunk-hunk = intern ---- instance Show Hunk where showsPrec d (Hunk _ _ b) = showsPrec d b--instance IsString Hunk where-  fromString = hunk . UTF8.fromString--instance Eq Hunk where-  (==) = (==) `on` identity--instance Hashable Hunk where-  hash = hash . identity--instance Ord Hunk where-  compare = compare `on` identity--instance HasDelta Hunk where-  delta (Hunk _ d _) = d--instance Interned Hunk where-  type Uninterned Hunk = ByteString-  data Description Hunk = Describe {-# UNPACK #-} !ByteString deriving (Eq)-  describe = Describe-  identify i bs = Hunk i (delta bs) bs-  identity (Hunk i _ _) = i-  cache = hunkCache--instance Uninternable Hunk where-  unintern (Hunk _ _ bs) = bs--instance Hashable (Description Hunk) where-  hash (Describe bs) = hash bs--hunkCache :: Cache Hunk-hunkCache = mkCache -{-# NOINLINE hunkCache #-}--instance Measured Delta Hunk where-  measure = delta
Text/Trifecta/Parser/Class.hs view
@@ -28,8 +28,8 @@ import Data.ByteString as Strict import Data.Semigroup import Data.Set as Set-import Text.Trifecta.Delta-import Text.Trifecta.Rope+import Text.Trifecta.Rope.Delta+import Text.Trifecta.Rope.Prim import Text.Trifecta.Parser.It  infix 0 <?>
Text/Trifecta/Parser/Combinators.hs view
@@ -216,4 +216,3 @@   m <- mark   p <* release m -
− Text/Trifecta/Parser/Err.hs 
@@ -1,82 +0,0 @@-module Text.Trifecta.Parser.Err-  ( Err(..)-  , diagnose-  , knownErr-  ) where--import Control.Applicative-import Control.Comonad-import Data.Semigroup-import Data.Monoid-import Data.Functor.Plus-import Text.Trifecta.Render.Prim-import Text.Trifecta.Diagnostic-import Text.Trifecta.Diagnostic.Level-import Text.PrettyPrint.Free-import System.Console.Terminfo.PrettyPrint---- | unlocated error messages-data Err e-  = EmptyErr-  | FailErr String -  | UnexpectedErr String-  | EndOfFileErr-  | RichErr (Render -> Diagnostic e)--instance Show (Err e) where-  showsPrec _ EmptyErr = showString "EmptyErr"-  showsPrec d (FailErr s) = showParen (d > 10) $-    showString "FailErr " . showsPrec 11 s-  showsPrec d (UnexpectedErr s) = showParen (d > 10) $-    showString "UnexpectedErr " . showsPrec 11 s-  showsPrec _ EndOfFileErr = showString "EndOfFileErr"-  showsPrec d (RichErr _) = showParen (d > 10) $ -    showString "RichErr ..."--knownErr :: Err e -> Bool-knownErr EmptyErr = False-knownErr _ = True--diagnose :: (t -> Doc e) -> Render -> Err t -> Diagnostic (Doc e)-diagnose _ r EmptyErr          = Diagnostic r Error (text "unexpected") []-diagnose _ r (FailErr m)       = Diagnostic r Error (fillSep $ text <$> words m) []-diagnose _ r (UnexpectedErr s) = Diagnostic r Error (fillSep $ fmap text $ "unexpected" : words s) []-diagnose _ r EndOfFileErr      = Diagnostic r Error (text "unexpected EOF") []-diagnose k r (RichErr f)       = fmap k (f r)--diagnose0 :: Pretty t => Err t -> Diagnostic (Doc e)-diagnose0 = diagnose pretty emptyRender--diagnoseTerm0 :: PrettyTerm t => Err t -> Diagnostic TermDoc-diagnoseTerm0 = diagnose prettyTerm emptyRender--instance Pretty t => Pretty (Err t) where-  pretty = pretty . extract . diagnose0-  prettyList = prettyList . map (extract . diagnose0)--instance PrettyTerm t => PrettyTerm (Err t) where-  prettyTerm = prettyTerm . diagnoseTerm0-  prettyTermList = prettyTermList . map diagnoseTerm0-  -instance Functor Err where-  fmap _ EmptyErr = EmptyErr-  fmap _ (FailErr s) = FailErr s-  fmap _ EndOfFileErr = EndOfFileErr-  fmap _ (UnexpectedErr s) = UnexpectedErr s -  fmap f (RichErr k) = RichErr (fmap f . k)--instance Alt Err where-  EmptyErr <!> a = a-  a        <!> _ = a-  {-# INLINE (<!>) #-}--instance Plus Err where-  zero = EmptyErr--instance Semigroup (Err t) where-  (<>) = (<!>)-  replicate1p _ = id--instance Monoid (Err t) where-  mempty = EmptyErr-  mappend = (<!>)
− Text/Trifecta/Parser/Err/State.hs 
@@ -1,34 +0,0 @@-module Text.Trifecta.Parser.Err.State -  ( ErrState(..)-  ) where--import Data.Functor.Plus-import Data.Set as Set-import Data.Sequence as Seq-import Data.Semigroup-import Data.Monoid-import Text.Trifecta.Parser.Err-import Text.Trifecta.Diagnostic--data ErrState e = ErrState- { errExpected :: !(Set String)- , errMessage  :: !(Err e)- , errLog      :: !(Seq (Diagnostic e))- }--instance Functor ErrState where-  fmap f (ErrState a b c) = ErrState a (fmap f b) (fmap (fmap f) c)--instance Alt ErrState where-  ErrState a b c <!> ErrState a' b' c' = ErrState (a <> a') (b <!> b') (c <!> c')-  {-# INLINE (<!>) #-}--instance Plus ErrState where-  zero = ErrState mempty zero zero- -instance Semigroup (ErrState e) where-  (<>) = (<!>) --instance Monoid (ErrState e) where-  mempty = zero-  mappend = (<!>)
Text/Trifecta/Parser/It.hs view
@@ -22,12 +22,11 @@ import Data.Functor.Plus import Data.Profunctor import Data.Key as Key-import Text.Trifecta.Rope as Rope-import Text.Trifecta.Delta-import Text.Trifecta.Bytes-import Text.Trifecta.Util as Util-import Text.Trifecta.Util.MaybePair+import Text.Trifecta.Rope.Prim as Rope+import Text.Trifecta.Rope.Delta+import Text.Trifecta.Rope.Bytes import Text.Trifecta.Parser.Step+import Text.Trifecta.Util as Util  data It r a   = Pure a @@ -113,10 +112,10 @@ -- * Rope specifics  -- | Given a position, go there, and grab the text forward from that point-fillIt :: Delta -> It Rope (MaybePair Delta Strict.ByteString)-fillIt n = wantIt NothingPair $ \r -> +fillIt :: r -> (Delta -> Strict.ByteString -> r) -> Delta -> It Rope r+fillIt kf ks n = wantIt kf $ \r ->    (# bytes n < bytes (rewind (delta r))-  ,  grabLine n r NothingPair JustPair #) +  ,  grabLine n r kf ks #)   stepIt :: It Rope a -> Step e a stepIt = go mempty where@@ -136,4 +135,3 @@   where     bi = bytes i     bj = bytes j-
Text/Trifecta/Parser/Prim.hs view
@@ -25,25 +25,24 @@ import Data.Semigroup import Data.Foldable import Data.Monoid-import Data.Functor.Bind+import Data.Functor.Bind (Apply(..), Bind((>>-))) import Data.Set as Set hiding (empty, toList) import Data.ByteString as Strict hiding (empty) import Data.Sequence as Seq hiding (empty) import Data.ByteString.UTF8 as UTF8 import Data.Bifunctor import Text.PrettyPrint.Free-import Text.Trifecta.Delta-import Text.Trifecta.Diagnostic-import Text.Trifecta.Render.Prim-import Text.Trifecta.Render.Caret-import Text.Trifecta.Rope+import Text.Trifecta.Rope.Delta+import Text.Trifecta.Rope.Prim+import Text.Trifecta.Diagnostic.Prim+import Text.Trifecta.Diagnostic.Err+import Text.Trifecta.Diagnostic.Err.State+import Text.Trifecta.Diagnostic.Rendering.Prim+import Text.Trifecta.Diagnostic.Rendering.Caret import Text.Trifecta.Parser.Class import Text.Trifecta.Parser.It-import Text.Trifecta.Parser.Err-import Text.Trifecta.Parser.Err.State import Text.Trifecta.Parser.Step import Text.Trifecta.Parser.Result-import Text.Trifecta.Util.MaybePair import System.Console.Terminfo.PrettyPrint  data Parser e a = Parser @@ -164,9 +163,8 @@       Nothing             -> ee mempty { errMessage = EndOfFileErr } d bs       Just (c, xs)          | not (f c)       -> ee mempty d bs-        | Strict.null xs  -> fillIt (d <> delta c) >>= \dbs -> case dbs of-          JustPair d' bs' -> co c mempty d' bs'-          NothingPair     -> co c mempty (d <> delta c) bs -- END OF LINE+        | Strict.null xs  -> let ddc = d <> delta c in+                             join $ fillIt (co c mempty ddc bs) (co c mempty) ddc         | otherwise       -> co c mempty (d <> delta c) bs    {-# INLINE satisfy #-}   satisfyAscii f = Parser $ \ _ ee co _ d bs ->@@ -174,9 +172,8 @@     if b >= 0 && b < Strict.length bs      then case toEnum $ fromEnum $ Strict.index bs b of       c | not (f c)                 -> ee mempty d bs-        | b == Strict.length bs - 1 -> fillIt (d <> delta c) >>= \dbs -> case dbs of-          JustPair d' bs'           -> co c mempty d' bs'-          NothingPair               -> co c mempty (d <> delta c) bs+        | b == Strict.length bs - 1 -> let ddc = d <> delta c in +                                       join $ fillIt (co c mempty ddc bs) (co c mempty) ddc         | otherwise                 -> co c mempty (d <> delta c) bs     else ee mempty { errMessage = EndOfFileErr } d bs   {-# INLINE satisfyAscii #-}@@ -205,8 +202,8 @@  why :: Pretty e => (e -> Doc t) -> ErrState e -> Delta -> ByteString -> Diagnostic (Doc t) why pp (ErrState ss _m _) d bs -  | Set.null ss = diagnose pp (addCaret d $ surface d bs) m-  | otherwise   = expected <$> diagnose pp (addCaret d $ surface d bs) m +  | Set.null ss = diagnose pp (addCaret d $ rendering d bs) m+  | otherwise   = expected <$> diagnose pp (addCaret d $ rendering d bs) m    where     m = EmptyErr     expected doc = doc <> text ", expected" <+> fillSep (punctuate (char ',') $ text <$> toList ss)
Text/Trifecta/Parser/Result.hs view
@@ -11,7 +11,7 @@ import Data.Traversable import Data.Bifunctor import Data.Sequence-import Text.Trifecta.Diagnostic+import Text.Trifecta.Diagnostic.Prim import Text.PrettyPrint.Free import System.Console.Terminfo.PrettyPrint
Text/Trifecta/Parser/Step.hs view
@@ -9,8 +9,8 @@ import Data.Bifunctor import Data.Semigroup.Reducer import Data.Sequence-import Text.Trifecta.Rope-import Text.Trifecta.Diagnostic+import Text.Trifecta.Rope.Prim+import Text.Trifecta.Diagnostic.Prim import Text.Trifecta.Parser.Result  data Step e a
+ Text/Trifecta/Parser/Token.hs view
@@ -0,0 +1,16 @@+++module Text.Trifecta.Parser.Token+  ( module Text.Trifecta.Parser.Token.Class+  , module Text.Trifecta.Parser.Token.Combinators+  , module Text.Trifecta.Parser.Token.Identifier+  ) where++import Text.Trifecta.Parser.Token.Class+import Text.Trifecta.Parser.Token.Combinators+import Text.Trifecta.Parser.Token.Identifier++-- expected to be imported manually++-- import Text.Trifecta.Parser.Token.Style+-- import Text.Trifecta.Parser.Token.Identifier.Style
+ Text/Trifecta/Parser/Token/Identifier.hs view
@@ -0,0 +1,52 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.Parser.Token.Identifier+-- Copyright   :  (c) Edward Kmett 2011+-- License     :  BSD3+-- +-- Maintainer  :  ekmett@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+-- +-----------------------------------------------------------------------------+module Text.Trifecta.Parser.Token.Identifier+  ( IdentifierStyle(..)+  , ident+  , reserved+  , reservedByteString+  ) where++import Data.ByteString as Strict hiding (map, zip, foldl, foldr)+import Data.ByteString.UTF8 as UTF8+import Data.HashSet as HashSet+import Control.Applicative+import Control.Monad (when)+import Text.Trifecta.Parser.Class+import Text.Trifecta.Parser.Char+import Text.Trifecta.Parser.Combinators+import Text.Trifecta.Parser.Token.Class++data IdentifierStyle m = IdentifierStyle+  { styleName         :: String+  , styleStart        :: m ()+  , styleLetter       :: m ()+  , styleReserved     :: HashSet ByteString+  }++-- | parse a reserved operator or identifier+reserved :: MonadTokenParser m => IdentifierStyle m -> String -> m ()+reserved s name = reservedByteString s $! UTF8.fromString name++-- | parse a reserved operator or identifier specified by bytestring+reservedByteString :: MonadTokenParser m => IdentifierStyle m -> ByteString -> m ()+reservedByteString s name = lexeme $ try $ do+   _ <- byteString name +   notFollowedBy (styleLetter s) <?> "end of " ++ show name++-- | parse an non-reserved identifier or symbol+ident :: MonadTokenParser m => IdentifierStyle m -> m ByteString+ident s = lexeme $ try $ do+  name <- sliced (styleStart s *> skipMany (styleLetter s)) <?> styleName s+  when (member name (styleReserved s)) $ unexpected $ "reserved " ++ styleName s ++ " " ++ show name+  return name+
+ Text/Trifecta/Parser/Token/Identifier/Style.hs view
@@ -0,0 +1,65 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Trifecta.Parser.Token.Identifier.Style+-- Copyright   :  (c) Edward Kmett 2011+-- License     :  BSD3+-- +-- Maintainer  :  ekmett@gmail.com+-- Stability   :  provisional+-- Portability :  non-portable+-- +-----------------------------------------------------------------------------+module Text.Trifecta.Parser.Token.Identifier.Style+  ( +  -- identifier styles+    emptyIdents, haskellIdents, haskell98Idents+  -- operator styles+  , emptyOps, haskellOps, haskell98Ops+  ) where++import Data.ByteString as Strict hiding (map, zip, foldl, foldr)+import Data.ByteString.UTF8 as UTF8+import Data.HashSet as HashSet+import Data.Monoid+import Control.Applicative+import Text.Trifecta.Parser.Char+import Text.Trifecta.Parser.Token.Class+import Text.Trifecta.Parser.Token.Identifier++set :: [String] -> HashSet ByteString+set = HashSet.fromList . fmap UTF8.fromString++emptyOps, haskell98Ops, haskellOps :: MonadTokenParser m => IdentifierStyle m+emptyOps = IdentifierStyle+  { styleName     = "operator"+  , styleStart    = styleLetter emptyOps+  , styleLetter   = () <$ oneOf ":!#$%&*+./<=>?@\\^|-~"+  , styleReserved = mempty+  }+haskell98Ops = emptyOps +  { styleReserved = set ["::","..","=","\\","|","<-","->","@","~","=>"]+  }+haskellOps = haskell98Ops++emptyIdents, haskell98Idents, haskellIdents :: MonadTokenParser m => IdentifierStyle m+emptyIdents = IdentifierStyle+  { styleName     = "identifier"+  , styleStart    = () <$ (letter <|> char '_')+  , styleLetter   = () <$ (alphaNum <|> oneOf "_'")+  , styleReserved = set [] }++haskell98Idents = emptyIdents+  { styleReserved = set haskell98ReservedIdents }+haskellIdents = haskell98Idents+  { styleLetter	  = styleLetter haskell98Idents <|> () <$ char '#'+  , styleReserved = set $ haskell98ReservedIdents +++      ["foreign","import","export","primitive","_ccall_","_casm_" ,"forall"]+  }++haskell98ReservedIdents :: [String]+haskell98ReservedIdents = +  ["let","in","case","of","if","then","else","data","type"+  ,"class","default","deriving","do","import","infix"+  ,"infixl","infixr","instance","module","newtype"+  ,"where","primitive" -- "as","qualified","hiding"+  ]
− Text/Trifecta/Parser/Token/Prim.hs 
@@ -1,71 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Text.Trifecta.Parser.Token.Prim--- Copyright   :  (c) Edward Kmett 2011--- License     :  BSD3--- --- Maintainer  :  ekmett@gmail.com--- Stability   :  provisional--- Portability :  non-portable--- -------------------------------------------------------------------------------module Text.Trifecta.Parser.Token.Prim-  ( CommentStyle(..)-  , emptyCommentStyle-  , javaCommentStyle-  , haskellCommentStyle-  , buildWhiteSpaceParser-  ) where--import Data.Char (isSpace)-import Control.Applicative-import Data.List (nub)-import Text.Trifecta.Parser.Class-import Text.Trifecta.Parser.Char-import Text.Trifecta.Parser.Combinators--data CommentStyle = CommentStyle -  { commentStart   :: String-  , commentEnd     :: String-  , commentLine    :: String-  , commentNesting :: Bool-  } --emptyCommentStyle, javaCommentStyle, haskellCommentStyle :: CommentStyle-emptyCommentStyle   = CommentStyle "" "" "" True-javaCommentStyle    = CommentStyle "/*" "*/" "//" True-haskellCommentStyle = CommentStyle "{-" "-}" "--" True---- | Use this to easily build the definition of whiteSpace for your MonadTokenParser-buildWhiteSpaceParser :: MonadParser m => CommentStyle -> m ()-buildWhiteSpaceParser (CommentStyle startStyle endStyle lineStyle nestingStyle)-  | noLine && noMulti  = skipMany (simpleSpace <?> "")-  | noLine             = skipMany (simpleSpace <|> multiLineComment <?> "")-  | noMulti            = skipMany (simpleSpace <|> oneLineComment <?> "")-  | otherwise          = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")-  where-    noLine  = null lineStyle-    noMulti = null startStyle-    simpleSpace = skipSome (satisfy isSpace)-    oneLineComment = do-      _ <- try $ string lineStyle-      skipMany (satisfyAscii (/= '\n')) -- TODO: use skipping/restOfLine and fiddle with the last byte-      return ()-    multiLineComment = do-      _ <- try $ string startStyle-      inComment-    inComment-      | nestingStyle = inCommentMulti-      | otherwise    = inCommentSingle-    inCommentMulti-      =   () <$ try (string endStyle)-      <|> multiLineComment *> inCommentMulti-      <|> skipSome (noneOf startEnd) *> inCommentMulti-      <|> oneOf startEnd *> inCommentMulti-      <?> "end of comment"-    startEnd = nub (endStyle ++ startStyle)-    inCommentSingle-      =   () <$ try (string endStyle)-      <|> skipSome (noneOf startEnd) *> inCommentSingle-      <|> oneOf startEnd *> inCommentSingle-      <?> "end of comment"
Text/Trifecta/Parser/Token/Style.hs view
@@ -10,89 +10,62 @@ --  ----------------------------------------------------------------------------- module Text.Trifecta.Parser.Token.Style-  ( Style(..)- -  -- identifier styles-  , emptyIdents, haskellIdents, haskell98Idents--  -- operator styles-  , emptyOps, haskellOps, haskell98Ops--  -- reading identifiers-  , ident-  , reserved-  , reservedByteString+  ( CommentStyle(..)+  , emptyCommentStyle+  , javaCommentStyle+  , haskellCommentStyle+  , buildWhiteSpaceParser   ) where -import Data.ByteString as Strict hiding (map, zip, foldl, foldr)-import Data.ByteString.UTF8 as UTF8-import Data.HashSet as HashSet-import Data.Monoid+import Data.Char (isSpace) import Control.Applicative-import Control.Monad (when)+import Data.List (nub) import Text.Trifecta.Parser.Class import Text.Trifecta.Parser.Char import Text.Trifecta.Parser.Combinators-import Text.Trifecta.Parser.Token.Class -data Style m = Style-  { styleName         :: String-  , styleStart        :: m ()-  , styleLetter       :: m ()-  , styleReserved     :: HashSet ByteString-  }---- | parse a reserved operator or identifier-reserved :: MonadTokenParser m => Style m -> String -> m ()-reserved s name = reservedByteString s $! UTF8.fromString name---- | parse a reserved operator or identifier specified by bytestring-reservedByteString :: MonadTokenParser m => Style m -> ByteString -> m ()-reservedByteString s name = lexeme $ try $ do-   _ <- byteString name -   notFollowedBy (styleLetter s) <?> "end of " ++ show name---- | parse an non-reserved identifier or symbol-ident :: MonadTokenParser m => Style m -> m ByteString-ident s = lexeme $ try $ do-  name <- sliced (styleStart s *> skipMany (styleLetter s)) <?> styleName s-  when (member name (styleReserved s)) $ unexpected $ "reserved " ++ styleName s ++ " " ++ show name-  return name--set :: [String] -> HashSet ByteString-set = HashSet.fromList . fmap UTF8.fromString--emptyOps, haskell98Ops, haskellOps :: MonadTokenParser m => Style m-emptyOps = Style-  { styleName     = "operator"-  , styleStart    = styleLetter emptyOps-  , styleLetter   = () <$ oneOf ":!#$%&*+./<=>?@\\^|-~"-  , styleReserved = mempty-  }-haskell98Ops = emptyOps -  { styleReserved = set ["::","..","=","\\","|","<-","->","@","~","=>"]-  }-haskellOps = haskell98Ops--emptyIdents, haskell98Idents, haskellIdents :: MonadTokenParser m => Style m-emptyIdents = Style-  { styleName     = "identifier"-  , styleStart    = () <$ (letter <|> char '_')-  , styleLetter   = () <$ (alphaNum <|> oneOf "_'")-  , styleReserved = set [] }+data CommentStyle = CommentStyle +  { commentStart   :: String+  , commentEnd     :: String+  , commentLine    :: String+  , commentNesting :: Bool+  }  -haskell98Idents = emptyIdents-  { styleReserved = set haskell98ReservedIdents }-haskellIdents = haskell98Idents-  { styleLetter	  = styleLetter haskell98Idents <|> () <$ char '#'-  , styleReserved = set $ haskell98ReservedIdents ++-      ["foreign","import","export","primitive","_ccall_","_casm_" ,"forall"]-  }+emptyCommentStyle, javaCommentStyle, haskellCommentStyle :: CommentStyle+emptyCommentStyle   = CommentStyle "" "" "" True+javaCommentStyle    = CommentStyle "/*" "*/" "//" True+haskellCommentStyle = CommentStyle "{-" "-}" "--" True -haskell98ReservedIdents :: [String]-haskell98ReservedIdents = -  ["let","in","case","of","if","then","else","data","type"-  ,"class","default","deriving","do","import","infix"-  ,"infixl","infixr","instance","module","newtype"-  ,"where","primitive" -- "as","qualified","hiding"-  ]+-- | Use this to easily build the definition of whiteSpace for your MonadTokenParser+buildWhiteSpaceParser :: MonadParser m => CommentStyle -> m ()+buildWhiteSpaceParser (CommentStyle startStyle endStyle lineStyle nestingStyle)+  | noLine && noMulti  = skipMany (simpleSpace <?> "")+  | noLine             = skipMany (simpleSpace <|> multiLineComment <?> "")+  | noMulti            = skipMany (simpleSpace <|> oneLineComment <?> "")+  | otherwise          = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")+  where+    noLine  = null lineStyle+    noMulti = null startStyle+    simpleSpace = skipSome (satisfy isSpace)+    oneLineComment = do+      _ <- try $ string lineStyle+      skipMany (satisfyAscii (/= '\n')) -- TODO: use skipping/restOfLine and fiddle with the last byte+      return ()+    multiLineComment = do+      _ <- try $ string startStyle+      inComment+    inComment+      | nestingStyle = inCommentMulti+      | otherwise    = inCommentSingle+    inCommentMulti+      =   () <$ try (string endStyle)+      <|> multiLineComment *> inCommentMulti+      <|> skipSome (noneOf startEnd) *> inCommentMulti+      <|> oneOf startEnd *> inCommentMulti+      <?> "end of comment"+    startEnd = nub (endStyle ++ startStyle)+    inCommentSingle+      =   () <$ try (string endStyle)+      <|> skipSome (noneOf startEnd) *> inCommentSingle+      <|> oneOf startEnd *> inCommentSingle+      <?> "end of comment"
− Text/Trifecta/Path.hs 
@@ -1,103 +0,0 @@-{-# LANGUAGE TypeFamilies, FlexibleInstances, BangPatterns #-}-module Text.Trifecta.Path-  ( FileName-  , Path(..), History(..)-  , file-  , snocPath-  , path-  , appendPath-  , comparablePath-  -- * Internals-  , MaybeFileName(..)-  , maybeFileName-  ) where--import Data.Hashable-import Data.Interned-import Data.Interned.String-import Data.Function (on)-import Data.Semigroup-import Data.IntSet as IntSet--type FileName = InternedString--data Path = Path {-# UNPACK #-} !Id !IntSet !History !MaybeFileName {-# UNPACK #-} !Int [Int]-  deriving Show--pathIds :: Path -> IntSet-pathIds (Path _ is _ _ _ _) = is--comparablePath :: Path -> Path -> Bool-comparablePath x y = identity x `IntSet.member` pathIds y-                  || identity y `IntSet.member` pathIds x--instance Eq Path where-  (==) = (==) `on` identity--instance Ord Path where-  compare = compare `on` identity--data History = Continue !Path {-# UNPACK #-} !Int | Complete deriving (Eq, Show)--data MaybeFileName = JustFileName !FileName | NothingFileName deriving (Eq, Show)--maybeFileName :: r -> (FileName -> r) -> MaybeFileName -> r-maybeFileName n _ NothingFileName  = n-maybeFileName _ f (JustFileName a) = f a--file :: String -> Path -file !n = path Complete (JustFileName (intern n)) 0 []--snocPath :: Path -> Int -> MaybeFileName -> Int -> [Int] -> Path-snocPath d l jf l' flags = path (Continue d l) jf l' flags--path :: History -> MaybeFileName -> Int -> [Int] -> Path-path !h !mf l flags = intern (UPath h mf l flags)--appendPath :: Path -> Int -> Path -> Path-appendPath p dl (Path _ _ Complete          mf l flags) = snocPath p dl mf l flags-appendPath p dl (Path _ _ (Continue p' dl') mf l flags) = snocPath (appendPath p dl p') dl' mf l flags--instance Semigroup Path where-  p <> p' = appendPath p 0 p'--data UninternedPath = UPath !History !MaybeFileName {-# UNPACK #-} !Int [Int]-data DHistory = DContinue {-# UNPACK #-} !Id {-# UNPACK #-} !Int | DComplete deriving Eq--instance Hashable DHistory where-  hash (DContinue x y) = y `hashWithSalt` x-  hash DComplete       = 0--instance Hashable Path where-  hash = hash . identity--instance Interned Path where-  type Uninterned Path = UninternedPath-  data Description Path = DPath !(Maybe Id) {-# UNPACK #-} !Int [Int] !DHistory deriving Eq-  describe (UPath h mf l flags) = DPath mi l flags $ case h of-    Continue p dl -> DContinue (identity p) dl-    Complete      -> DComplete -    where -      mi = case mf of -        JustFileName f -> Just (identity f)-        NothingFileName -> Nothing-                     -  identify i (UPath h mf l flags) = Path i m h mf l flags -    where -      m = case h of -        Complete -> IntSet.singleton i-        Continue (Path _ m' _ _ _ _) _ -> IntSet.insert i m'-                 -  identity (Path i _ _ _ _ _) = i-  cache = pathCache--instance Uninternable Path where-  unintern (Path _ _ h mf l flags) = UPath h mf l flags--instance Hashable (Description Path) where-  hash (DPath mi l flags dh) = l `hashWithSalt` mi `hashWithSalt` flags `hashWithSalt` dh--pathCache :: Cache Path-pathCache = mkCache-{-# NOINLINE pathCache #-}-
− Text/Trifecta/Render/Caret.hs 
@@ -1,104 +0,0 @@-module Text.Trifecta.Render.Caret-  ( Caret(..)-  , HasCaret(..)-  , Careted(..)-  , careted-  -- * Internals-  , drawCaret-  , addCaret-  , caretEffects-  ) where--import Control.Applicative-import Control.Comonad-import Data.ByteString (ByteString)-import Data.Foldable-import Data.Functor.Bind-import Data.Hashable-import Data.Semigroup-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.Traversable-import Prelude hiding (span)-import System.Console.Terminfo.Color-import System.Console.Terminfo.PrettyPrint-import Text.Trifecta.Bytes-import Text.Trifecta.Delta-import Text.Trifecta.Parser.Class-import Text.Trifecta.Render.Prim---- |--- > In file included from baz.c:9--- > In file included from bar.c:4--- > foo.c:8:36: note--- > int main(int argc, char ** argv) { int; }--- >                                    ^-data Caret = Caret !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show)--instance Hashable Caret where-  hash (Caret d bs) = hash d `hashWithSalt` bs--caretEffects :: [ScopedEffect]-caretEffects = [soft (Foreground Green), soft Bold]--drawCaret :: Delta -> Delta -> Lines -> Lines-drawCaret p = ifNear p $ draw caretEffects 1 (column p) "^"--addCaret :: Delta -> Render -> Render-addCaret p r = drawCaret p .# r--class HasCaret t where-  caret :: t -> Caret--instance HasCaret Caret where-  caret = id--instance HasBytes Caret where-  bytes = bytes . delta--instance HasDelta Caret where-  delta (Caret d _) = d--instance Renderable Caret where-  render (Caret d bs) = addCaret d $ surface d bs--instance Semigroup Caret where-  a <> _ = a--data Careted a = a :^ Caret deriving (Eq,Ord,Show)--instance Functor Careted where-  fmap f (a :^ s) = f a :^ s--instance Extend Careted where-  extend f as@(_ :^ s) = f as :^ s--instance Comonad Careted where-  extract (a :^ _) = a--instance Foldable Careted where-  foldMap f (a :^ _) = f a--instance Traversable Careted where-  traverse f (a :^ s) = (:^ s) <$> f a--instance Foldable1 Careted where-  foldMap1 f (a :^ _) = f a--instance Traversable1 Careted where-  traverse1 f (a :^ s) = (:^ s) <$> f a--instance Renderable (Careted a) where-  render = render . caret--instance HasCaret (Careted a) where-  caret (_ :^ c) = c--instance Hashable a => Hashable (Careted a) where-  -careted :: MonadParser m => m a -> m (Careted a)-careted p = do-  m <- mark-  l <- line-  a <- p-  return $ a :^ Caret m l
− Text/Trifecta/Render/Fixit.hs 
@@ -1,57 +0,0 @@-module Text.Trifecta.Render.Fixit-  ( Fixit(..)-  , drawFixit-  , addFixit-  , fixit-  ) where--import Data.Functor-import Data.Hashable-import Data.ByteString (ByteString)-import qualified Data.ByteString as Strict-import qualified Data.ByteString.UTF8 as UTF8-import Text.Trifecta.Bytes-import Text.Trifecta.Delta-import Text.Trifecta.Render.Prim-import Text.Trifecta.Render.Span-import Text.Trifecta.Render.Caret-import Text.Trifecta.Parser.Class-import Text.Trifecta.Util-import System.Console.Terminfo.Color-import System.Console.Terminfo.PrettyPrint-import Prelude hiding (span)---- |--- > int main(int argc char ** argv) { int; }--- >                  ^--- >                  ,-drawFixit :: Delta -> Delta -> String -> Delta -> Lines -> Lines-drawFixit s e rpl d a = ifNear l (draw [soft (Foreground Blue)] 2 (column l) rpl) d -                      $ drawSpan s e d a-  where l = argmin bytes s e--addFixit :: Delta -> Delta -> String -> Render -> Render-addFixit s e rpl r = drawFixit s e rpl .# r--data Fixit = Fixit -  { fixitSpan        :: {-# UNPACK #-} !Span-  , fixitReplacement  :: {-# UNPACK #-} !ByteString -  } deriving (Eq,Ord,Show)--instance HasSpan Fixit where-  span (Fixit s _) = s--instance HasDelta Fixit where-  delta = delta . caret--instance HasCaret Fixit where-  caret = caret . span--instance Hashable Fixit where-  hash (Fixit s b) = hash s `hashWithSalt` b--instance Renderable Fixit where-  render (Fixit (Span s e bs) r) = addFixit s e (UTF8.toString r) $ surface s bs--fixit :: MonadParser m => m Strict.ByteString -> m Fixit-fixit p = (\(r :~ s) -> Fixit s r) <$> spanned p
− Text/Trifecta/Render/Prim.hs 
@@ -1,191 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}--- | Diagnostics rendering-module Text.Trifecta.Render.Prim -  ( Render(..)-  , Renderable(..)-  , Source(..)-  , Rendered(..)-  , surface-  , nullRender-  , emptyRender-  -- * Lower level drawing primitives-  , Lines-  , draw-  , ifNear-  , (.#)-  ) where--import Control.Applicative-import Control.Comonad-import Control.Monad.State-import Data.Array-import Data.ByteString hiding (groupBy, empty, any)-import Data.Foldable-import Data.Monoid-import Data.Function (on)-import Data.Functor.Bind-import Data.List (groupBy)-import Data.Semigroup-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.Traversable-import Prelude as P-import Prelude hiding (span)-import System.Console.Terminfo.PrettyPrint-import Text.PrettyPrint.Free hiding (column)-import Text.Trifecta.Bytes-import Text.Trifecta.Delta-import qualified Data.ByteString.UTF8 as UTF8 --outOfRangeEffects :: [ScopedEffect] -> [ScopedEffect]-outOfRangeEffects xs = soft Bold : xs--type Lines = Array (Int,Int) ([ScopedEffect], Char)--(///) :: Ix i => Array i e -> [(i, e)] -> Array i e-a /// xs = a // P.filter (inRange (bounds a) . fst) xs---grow :: Int -> Lines -> Lines-grow y a -  | inRange (t,b) y = a-  | otherwise = array new [ (i, if inRange old i then a ! i else ([],' ')) | i <- range new ]-  where old@((t,lo),(b,hi)) = bounds a-        new = ((min t y,lo),(max b y,hi))--draw :: [ScopedEffect] -> Int -> Int -> String -> Lines -> Lines-draw e y n xs a0 -  | Prelude.null xs = a0-  | otherwise = gt $ lt (a /// out) -  where -    a = grow y a0-    ((_,lo),(_,hi)) = bounds a-    out = P.zipWith (\i c -> ((y,i),(e,c))) [n..] xs-    lt | Prelude.any (\el -> snd (fst el) < lo) out = (// [((y,lo),(outOfRangeEffects e,'<'))])-       | otherwise = id-    gt | Prelude.any (\el -> snd (fst el) > hi) out = (// [((y,hi),(outOfRangeEffects e,'>'))])-       | otherwise = id--data Render = Render -  { rDelta     :: !Delta                  -- focus, the render will keep this visible-  , rLineLen   :: {-# UNPACK #-} !Int     -- actual line length-  , rLine      :: Lines -> Lines-  , rDraw      :: Delta -> Lines -> Lines-  }--instance Show Render where-  showsPrec d (Render p ll _ _) = showParen (d > 10) $ -    showString "Render " . showsPrec 11 p . showChar ' ' . showsPrec 11 ll . showString " ... ..."--nullRender :: Render -> Bool-nullRender (Render (Columns 0 0) 0 _ _) = True-nullRender _ = False--emptyRender :: Render -emptyRender = surface (Columns 0 0) ""--instance Semigroup Render where-  -- an unprincipled hack-  Render (Columns 0 0) 0 _ f <> Render del len doc g = Render del len doc $ \d l -> f d (g d l)-  Render del len doc f <> Render _ _ _ g = Render del len doc $ \d l -> f d (g d l)--instance Monoid Render where-  mappend = (<>) -  mempty = emptyRender-  -ifNear :: Delta -> (Lines -> Lines) -> Delta -> Lines -> Lines-ifNear d f d' l | near d d' = f l -                | otherwise = l--instance HasDelta Render where-  delta = rDelta--class Renderable t where-  render :: t -> Render --instance Renderable Render where-  render = id--class Source t where-  source :: t -> (Int, Lines -> Lines)--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 _ []        = []--instance Source ByteString where-  source = source . UTF8.toString---- | create a drawing surface-surface :: Source s => Delta -> s -> Render-surface del s = case source s of -  (len, doc) -> Render del len doc (\_ l -> l)--(.#) :: (Delta -> Lines -> Lines) -> Render -> Render-f .# Render d ll s g = Render d ll s $ \e l -> f e $ g e l --instance Pretty Render where-  pretty r = prettyTerm r >>= const empty--instance PrettyTerm Render where-  prettyTerm (Render d ll l f) = nesting $ \k -> columns $ \n -> go (n - k) where-    go cols = align (vsep (P.map ln [t..b])) where -      (lo, hi) = window (column d) ll (cols - 2)-      a = f d $ l $ array ((0,lo),(-1,hi)) []-      ((t,_),(b,_)) = bounds a-      ln y = hcat -           $ P.map (\g -> P.foldr with (string (P.map snd g)) (fst (P.head g)))-           $ groupBy ((==) `on` fst) -           [ a ! (y,i) | i <- [lo..hi] ] --window :: Int -> Int -> Int -> (Int, Int)-window c l w -  | c <= w2     = (0, min w l)-  | c + w2 >= l = if l > w then (l-w, l) else (0, w)-  | otherwise   = (c-w2,c + w2)-  where w2 = div w 2--data Rendered a = a :@ Render-  deriving Show---instance Functor Rendered where-  fmap f (a :@ s) = f a :@ s--instance HasDelta (Rendered a) where-  delta = delta . render--instance HasBytes (Rendered a) where-  bytes = bytes . delta--instance Extend Rendered where-  extend f as@(_ :@ s) = f as :@ s--instance Comonad Rendered where-  extract (a :@ _) = a--instance Apply Rendered where-  (f :@ s) <.> (a :@ t) = f a :@ (s <> t)--instance Bind Rendered where-  (a :@ s) >>- f = case f a of-     b :@ t -> b :@ (s <> t)--instance Foldable Rendered where-  foldMap f (a :@ _) = f a --instance Traversable Rendered where-  traverse f (a :@ s) = (:@ s) <$> f a--instance Foldable1 Rendered where-  foldMap1 f (a :@ _) = f a --instance Traversable1 Rendered where-  traverse1 f (a :@ s) = (:@ s) <$> f a--instance Renderable (Rendered a) where-  render (_ :@ s) = s
− Text/Trifecta/Render/Span.hs 
@@ -1,124 +0,0 @@-module Text.Trifecta.Render.Span-  ( Span(..)-  , HasSpan(..)-  , Spanned(..)-  , spanned-  -- * Internals-  , spanEffects-  , drawSpan-  , addSpan-  ) where--import Control.Applicative-import Data.Hashable-import Data.Semigroup-import Data.Semigroup.Foldable-import Data.Semigroup.Traversable-import Data.Foldable-import Data.Traversable-import Control.Comonad-import Data.Functor.Bind-import Data.ByteString (ByteString)-import Text.Trifecta.Bytes-import Text.Trifecta.Delta-import Text.Trifecta.Render.Prim-import Text.Trifecta.Render.Caret-import Text.Trifecta.Util-import Text.Trifecta.Parser.Class-import Data.Array-import System.Console.Terminfo.Color-import System.Console.Terminfo.PrettyPrint-import Prelude as P hiding (span)--spanEffects :: [ScopedEffect]-spanEffects  = [soft (Foreground Green)]--drawSpan :: Delta -> Delta -> Delta -> Lines -> Lines-drawSpan s e d a-  | nl && nh  = go (column l) (P.replicate (max (column h   - column l + 1) 0) '~') a-  | nl        = go (column l) (P.replicate (max (snd (snd (bounds a)) - column l + 2) 0) '~') a-  |       nh  = go (-1)       (P.replicate (max (column h + 1) 0) '~') a-  | otherwise = a-  where-    go = draw spanEffects 1-    l = argmin bytes s e-    h = argmax bytes s e-    nl = near l d-    nh = near h d---- |--- > int main(int argc, char ** argv) { int; }--- >                                    ^~~-addSpan :: Delta -> Delta -> Render -> Render-addSpan s e r = drawSpan s e .# r--data Span = Span !Delta !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show)--instance HasCaret Span where-  caret (Span s _ b) = Caret s b--instance Renderable Span where-  render (Span s e bs) = addSpan s e $ surface s bs--class HasSpan t where-  span :: t -> Span--instance HasSpan Span where-  span = id--instance Semigroup Span where-  Span s _ b <> Span _ e _ = Span s e b---data Spanned a = a :~ Span deriving (Eq,Ord,Show)--instance Functor Spanned where-  fmap f (a :~ s) = f a :~ s--instance Extend Spanned where-  extend f as@(_ :~ s) = f as :~ s--instance Comonad Spanned where-  extract (a :~ _) = a--instance Apply Spanned where-  (f :~ s) <.> (a :~ t) = f a :~ (s <> t)--instance Bind Spanned where-  (a :~ s) >>- f = case f a of-     b :~ t -> b :~ (s <> t)--instance Foldable Spanned where-  foldMap f (a :~ _) = f a --instance Traversable Spanned where-  traverse f (a :~ s) = (:~ s) <$> f a--instance Foldable1 Spanned where-  foldMap1 f (a :~ _) = f a --instance Traversable1 Spanned where-  traverse1 f (a :~ s) = (:~ s) <$> f a--instance HasSpan (Spanned a) where-  span (_ :~ c) = c--instance Renderable (Spanned a) where-  render = render . span--instance HasCaret (Spanned a) where-  caret = caret . span--instance Hashable Span where-  hash (Span s e bs) = hash s `hashWithSalt` e `hashWithSalt` bs--instance Hashable a => Hashable (Spanned a) where-  hash (a :~ s) = hash a `hashWithSalt` s--spanned :: MonadParser m => m a -> m (Spanned a)-spanned p = do-  m <- mark-  l <- line-  a <- p-  r <- mark-  return $ a :~ Span m r l
− Text/Trifecta/Rope.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, BangPatterns, PatternGuards #-}-module Text.Trifecta.Rope-  ( Rope(..)-  , rope-  , strands-  , grabRest-  , grabLine-  ) where--import Data.Monoid-import Data.Semigroup-import Data.Semigroup.Reducer-import qualified Data.ByteString as Strict-import qualified Data.ByteString.Lazy as Lazy-import Data.FingerTree as FingerTree-import Data.Foldable (toList)-import Text.Trifecta.Hunk-import Text.Trifecta.Path-import Text.Trifecta.Delta-import Text.Trifecta.Bytes-import Text.Trifecta.Strand-import Text.Trifecta.Util as Util--data Rope = Rope !Delta !(FingerTree Delta Strand) deriving Show--rope :: FingerTree Delta Strand -> Rope-rope r = Rope (measure r) r--strands :: Rope -> FingerTree Delta Strand-strands (Rope _ r) = r---- | 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 (PathStrand p            : xs) j k = trim xs (j <> delta p) k-  trim (HunkStrand (Hunk _ _ h) : xs) j 0 = go j h xs-  trim (HunkStrand (Hunk _ _ h) : xs) _ k = go i (Strict.drop k h) xs-  trim [] _ _ = kf-  go j h s = ks j $ Lazy.fromChunks $ h : [ a | HunkStrand (Hunk _ _ a) <- s ]-  (l, r) = FingerTree.split (\b -> bytes b > bytes i) $ strands t---- | grab a the contents of a rope from a given location up to a newline-grabLine :: Delta -> Rope -> r -> (Delta -> Strict.ByteString -> r) -> r-grabLine i t kf ks = grabRest i t kf $ \c -> ks c . Util.fromLazy . Util.takeLine--instance HasBytes Rope where-  bytes = bytes . measure--instance HasDelta Rope where-  delta = measure--instance Measured Delta Rope where-  measure (Rope s _) = s--instance Monoid Rope where-  mempty = Rope mempty mempty-  mappend = (<>)--instance Semigroup Rope where-  Rope mx x <> Rope my y = Rope (mx <> my) (x `mappend` y)--instance Reducer Rope Rope where-  unit = id--instance Reducer Strand Rope where-  unit s = rope (singleton s)-  cons s (Rope mt t) = Rope (delta s `mappend` mt) (s <| t)-  snoc (Rope mt t) !s = Rope (mt `mappend` delta s) (t |> s)--instance Reducer Hunk Rope where-  unit s = Rope (delta s) (singleton (HunkStrand s))-  cons s (Rope mt t) = Rope (delta s `mappend` mt) (HunkStrand s <| t)-  snoc (Rope mt t) s = Rope (mt `mappend` delta s) (t |> HunkStrand s)-  -instance Reducer Path Rope where-  unit s = Rope (delta s) (singleton (PathStrand s))-  cons s (Rope mt t) = Rope (delta s `mappend` mt) (PathStrand s <| t)-  snoc (Rope mt t) s = Rope (mt `mappend` delta s) (t |> PathStrand s)--instance Reducer Strict.ByteString Rope where-  unit = unit . hunk-  cons = cons . hunk -  snoc r = snoc r . hunk
+ Text/Trifecta/Rope/Bytes.hs view
@@ -0,0 +1,15 @@+module Text.Trifecta.Rope.Bytes+  ( HasBytes(..)+  ) where++import Data.ByteString as Strict+import Data.FingerTree++class HasBytes t where+  bytes :: t -> Int++instance HasBytes ByteString where+  bytes = Strict.length++instance (Measured v a, HasBytes v) => HasBytes (FingerTree v a) where+  bytes = bytes . measure
+ Text/Trifecta/Rope/Delta.hs view
@@ -0,0 +1,155 @@+module Text.Trifecta.Rope.Delta +  ( Delta(..) +  , HasDelta(..)+  , nextTab+  , rewind+  , near+  , column+  , columnByte+  ) where++import Control.Applicative+import Data.Monoid+import Data.Semigroup+import Data.Hashable+import Data.Word+import Data.Interned+import Data.Foldable+import Data.FingerTree hiding (empty)+import Data.ByteString hiding (empty)+import Text.Trifecta.Rope.Path+import Text.Trifecta.Rope.Bytes+import Text.PrettyPrint.Free hiding (column)+import System.Console.Terminfo.PrettyPrint++data Delta+  = Columns   {-# UNPACK #-} !Int  -- the number of characters+              {-# UNPACK #-} !Int  -- the number of bytes+  | Tab       {-# UNPACK #-} !Int  -- the number of characters before the tab+              {-# UNPACK #-} !Int  -- the number of characters after the tab+              {-# UNPACK #-} !Int  -- the number of bytes+  | Lines     {-# UNPACK #-} !Int  -- the number of newlines contained+              {-# UNPACK #-} !Int  -- the number of characters since the last newline+              {-# UNPACK #-} !Int  -- number of bytes+              {-# UNPACK #-} !Int  -- the number of bytes since the last newline+  | Directed                 !Path -- the sequence of #line directives since the start of the file+              {-# UNPACK #-} !Int  -- the number of lines since the last line directive+              {-# UNPACK #-} !Int  -- the number of characters since the last newline+              {-# UNPACK #-} !Int  -- number of bytes+              {-# 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++instance Pretty Delta where+  pretty p = prettyTerm p *> empty++instance PrettyTerm Delta where+  prettyTerm d = case d of+    Columns c _ -> k "-" 1 c+    Tab x y _ -> k "-" 1 (nextTab x + y)+    Lines l c _ _ -> k "-" l c+    Directed (Path _ _ _ fn _ _) l c _ _ -> k (maybeFileName "-" unintern fn) l c  -- TODO: add include path+    where +      k fn ln cn = bold (string fn)           +                <> char ':' +                <> bold (int ln)         +                <> char ':' +                <> bold (int (cn + 1))++column :: HasDelta t => t -> Int+column t = case delta t of +  Columns c _ -> c+  Tab b a _ -> nextTab b + a+  Lines _ c _ _ -> c+  Directed _ _ c _ _ -> c++instance HasBytes Delta where+  bytes (Columns _ b) = b+  bytes (Tab _ _ b) = b+  bytes (Lines _ _ b _) = b+  bytes (Directed _ _ _ b _) = b++instance Hashable Delta where+  hash (Columns c a)        = 0 `hashWithSalt` c `hashWithSalt` a+  hash (Tab x y a)          = 1 `hashWithSalt` x `hashWithSalt` y `hashWithSalt` a+  hash (Lines l c b a)      = 2 `hashWithSalt` l `hashWithSalt` c `hashWithSalt` b `hashWithSalt` a+  hash (Directed p l c b a) = 3 `hashWithSalt` p `hashWithSalt` l `hashWithSalt` c `hashWithSalt` b `hashWithSalt` a++instance Monoid Delta where+  mempty = Columns 0 0+  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 p l _ t _ <> Directed p' l' c' t' b = Directed (appendPath p l p') l' c' (t + t') b+  +nextTab :: Int -> Int+nextTab x = x + (8 - mod x 8)++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 ++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++class HasDelta t where+  delta :: t -> Delta++instance HasDelta Delta where+  delta = id++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+    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++instance HasDelta ByteString where+  delta = foldMap delta . unpack++instance HasDelta Path where+  delta p = Directed p 0 0 0 0++instance (Measured v a, HasDelta v) => HasDelta (FingerTree v a) where+  delta = delta . measure
+ Text/Trifecta/Rope/Hunk.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-}+module Text.Trifecta.Rope.Hunk +  ( Hunk(..)+  , hunk+  ) where++import Data.ByteString+import qualified Data.ByteString.UTF8 as UTF8+import Data.FingerTree as FingerTree+import Data.Function (on)+import Data.Hashable+import Data.Interned+import Data.String+import Text.Trifecta.Rope.Delta++data Hunk = Hunk {-# UNPACK #-} !Id !Delta {-# UNPACK #-} !ByteString+  deriving Show++hunk :: ByteString -> Hunk+hunk = intern ++-- instance Show Hunk where showsPrec d (Hunk _ _ b) = showsPrec d b++instance IsString Hunk where+  fromString = hunk . UTF8.fromString++instance Eq Hunk where+  (==) = (==) `on` identity++instance Hashable Hunk where+  hash = hash . identity++instance Ord Hunk where+  compare = compare `on` identity++instance HasDelta Hunk where+  delta (Hunk _ d _) = d++instance Interned Hunk where+  type Uninterned Hunk = ByteString+  data Description Hunk = Describe {-# UNPACK #-} !ByteString deriving (Eq)+  describe = Describe+  identify i bs = Hunk i (delta bs) bs+  identity (Hunk i _ _) = i+  cache = hunkCache++instance Uninternable Hunk where+  unintern (Hunk _ _ bs) = bs++instance Hashable (Description Hunk) where+  hash (Describe bs) = hash bs++hunkCache :: Cache Hunk+hunkCache = mkCache +{-# NOINLINE hunkCache #-}++instance Measured Delta Hunk where+  measure = delta
+ Text/Trifecta/Rope/Path.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TypeFamilies, FlexibleInstances, BangPatterns #-}+module Text.Trifecta.Rope.Path+  ( FileName+  , Path(..), History(..)+  , file+  , snocPath+  , path+  , appendPath+  , comparablePath+  -- * Internals+  , MaybeFileName(..)+  , maybeFileName+  ) where++import Data.Hashable+import Data.Interned+import Data.Interned.String+import Data.Function (on)+import Data.Semigroup+import Data.IntSet as IntSet++type FileName = InternedString++data Path = Path {-# UNPACK #-} !Id !IntSet !History !MaybeFileName {-# UNPACK #-} !Int [Int]+  deriving Show++pathIds :: Path -> IntSet+pathIds (Path _ is _ _ _ _) = is++comparablePath :: Path -> Path -> Bool+comparablePath x y = identity x `IntSet.member` pathIds y+                  || identity y `IntSet.member` pathIds x++instance Eq Path where+  (==) = (==) `on` identity++instance Ord Path where+  compare = compare `on` identity++data History = Continue !Path {-# UNPACK #-} !Int | Complete deriving (Eq, Show)++data MaybeFileName = JustFileName !FileName | NothingFileName deriving (Eq, Show)++maybeFileName :: r -> (FileName -> r) -> MaybeFileName -> r+maybeFileName n _ NothingFileName  = n+maybeFileName _ f (JustFileName a) = f a++file :: String -> Path +file !n = path Complete (JustFileName (intern n)) 0 []++snocPath :: Path -> Int -> MaybeFileName -> Int -> [Int] -> Path+snocPath d l jf l' flags = path (Continue d l) jf l' flags++path :: History -> MaybeFileName -> Int -> [Int] -> Path+path !h !mf l flags = intern (UPath h mf l flags)++appendPath :: Path -> Int -> Path -> Path+appendPath p dl (Path _ _ Complete          mf l flags) = snocPath p dl mf l flags+appendPath p dl (Path _ _ (Continue p' dl') mf l flags) = snocPath (appendPath p dl p') dl' mf l flags++instance Semigroup Path where+  p <> p' = appendPath p 0 p'++data UninternedPath = UPath !History !MaybeFileName {-# UNPACK #-} !Int [Int]+data DHistory = DContinue {-# UNPACK #-} !Id {-# UNPACK #-} !Int | DComplete deriving Eq++instance Hashable DHistory where+  hash (DContinue x y) = y `hashWithSalt` x+  hash DComplete       = 0++instance Hashable Path where+  hash = hash . identity++instance Interned Path where+  type Uninterned Path = UninternedPath+  data Description Path = DPath !(Maybe Id) {-# UNPACK #-} !Int [Int] !DHistory deriving Eq+  describe (UPath h mf l flags) = DPath mi l flags $ case h of+    Continue p dl -> DContinue (identity p) dl+    Complete      -> DComplete +    where +      mi = case mf of +        JustFileName f -> Just (identity f)+        NothingFileName -> Nothing+                     +  identify i (UPath h mf l flags) = Path i m h mf l flags +    where +      m = case h of +        Complete -> IntSet.singleton i+        Continue (Path _ m' _ _ _ _) _ -> IntSet.insert i m'+                 +  identity (Path i _ _ _ _ _) = i+  cache = pathCache++instance Uninternable Path where+  unintern (Path _ _ h mf l flags) = UPath h mf l flags++instance Hashable (Description Path) where+  hash (DPath mi l flags dh) = l `hashWithSalt` mi `hashWithSalt` flags `hashWithSalt` dh++pathCache :: Cache Path+pathCache = mkCache+{-# NOINLINE pathCache #-}+
+ Text/Trifecta/Rope/Prim.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, BangPatterns, PatternGuards #-}+module Text.Trifecta.Rope.Prim+  ( Rope(..)+  , rope+  , strands+  , grabRest+  , grabLine+  ) where++import Data.Monoid+import Data.Semigroup+import Data.Semigroup.Reducer+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Lazy as Lazy+import Data.FingerTree as FingerTree+import Data.Foldable (toList)+import Text.Trifecta.Rope.Hunk+import Text.Trifecta.Rope.Path+import Text.Trifecta.Rope.Delta+import Text.Trifecta.Rope.Bytes+import Text.Trifecta.Rope.Strand+import Text.Trifecta.Util as Util++data Rope = Rope !Delta !(FingerTree Delta Strand) deriving Show++rope :: FingerTree Delta Strand -> Rope+rope r = Rope (measure r) r++strands :: Rope -> FingerTree Delta Strand+strands (Rope _ r) = r++-- | 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 (PathStrand p            : xs) j k = trim xs (j <> delta p) k+  trim (HunkStrand (Hunk _ _ h) : xs) j 0 = go j h xs+  trim (HunkStrand (Hunk _ _ h) : xs) _ k = go i (Strict.drop k h) xs+  trim [] _ _ = kf+  go j h s = ks j $ Lazy.fromChunks $ h : [ a | HunkStrand (Hunk _ _ a) <- s ]+  (l, r) = FingerTree.split (\b -> bytes b > bytes i) $ strands t++-- | grab a the contents of a rope from a given location up to a newline+grabLine :: Delta -> Rope -> r -> (Delta -> Strict.ByteString -> r) -> r+grabLine i t kf ks = grabRest i t kf $ \c -> ks c . Util.fromLazy . Util.takeLine++instance HasBytes Rope where+  bytes = bytes . measure++instance HasDelta Rope where+  delta = measure++instance Measured Delta Rope where+  measure (Rope s _) = s++instance Monoid Rope where+  mempty = Rope mempty mempty+  mappend = (<>)++instance Semigroup Rope where+  Rope mx x <> Rope my y = Rope (mx <> my) (x `mappend` y)++instance Reducer Rope Rope where+  unit = id++instance Reducer Strand Rope where+  unit s = rope (singleton s)+  cons s (Rope mt t) = Rope (delta s `mappend` mt) (s <| t)+  snoc (Rope mt t) !s = Rope (mt `mappend` delta s) (t |> s)++instance Reducer Hunk Rope where+  unit s = Rope (delta s) (singleton (HunkStrand s))+  cons s (Rope mt t) = Rope (delta s `mappend` mt) (HunkStrand s <| t)+  snoc (Rope mt t) s = Rope (mt `mappend` delta s) (t |> HunkStrand s)+  +instance Reducer Path Rope where+  unit s = Rope (delta s) (singleton (PathStrand s))+  cons s (Rope mt t) = Rope (delta s `mappend` mt) (PathStrand s <| t)+  snoc (Rope mt t) s = Rope (mt `mappend` delta s) (t |> PathStrand s)++instance Reducer Strict.ByteString Rope where+  unit = unit . hunk+  cons = cons . hunk +  snoc r = snoc r . hunk
+ Text/Trifecta/Rope/Strand.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}+module Text.Trifecta.Rope.Strand+  ( Strand(..)+  ) where++import Data.Interned+import Data.Hashable+import Data.ByteString as Strict+import Data.FingerTree as FingerTree+import Text.Trifecta.Rope.Hunk+import Text.Trifecta.Rope.Path+import Text.Trifecta.Rope.Bytes+import Text.Trifecta.Rope.Delta++data Strand+  = HunkStrand !Hunk+  | PathStrand !Path+  deriving Show++--instance Show Strand where+--  showsPrec d (HunkStrand h) = showsPrec d h+--  showsPrec d (PathStrand p) = showsPrec d p++instance Measured Delta Strand where+  measure (HunkStrand s) = delta s+  measure (PathStrand p) = delta p++instance Hashable Strand where+  hash (HunkStrand h) = hashWithSalt 0 h+  hash (PathStrand p) = hashWithSalt 0 p++instance HasDelta Strand where+  delta = measure++instance HasBytes Strand where+  bytes (HunkStrand h) = Strict.length (unintern h)+  bytes _ = 0
− Text/Trifecta/Strand.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances #-}-module Text.Trifecta.Strand-  ( Strand(..)-  ) where--import Data.Interned-import Data.Hashable-import Data.ByteString as Strict-import Data.FingerTree as FingerTree-import Text.Trifecta.Hunk-import Text.Trifecta.Path-import Text.Trifecta.Bytes-import Text.Trifecta.Delta--data Strand-  = HunkStrand !Hunk-  | PathStrand !Path-  deriving Show----instance Show Strand where---  showsPrec d (HunkStrand h) = showsPrec d h---  showsPrec d (PathStrand p) = showsPrec d p--instance Measured Delta Strand where-  measure (HunkStrand s) = delta s-  measure (PathStrand p) = delta p--instance Hashable Strand where-  hash (HunkStrand h) = hashWithSalt 0 h-  hash (PathStrand p) = hashWithSalt 0 p--instance HasDelta Strand where-  delta = measure--instance HasBytes Strand where-  bytes (HunkStrand h) = Strict.length (unintern h)-  bytes _ = 0
− Text/Trifecta/Util/MaybePair.hs 
@@ -1,62 +0,0 @@-module Text.Trifecta.Util.MaybePair-  ( MaybePair(..)-  ) where--import Control.Applicative-import Data.Semigroup-import Data.Monoid-import Data.Functor.Apply-import Data.Functor.Plus-import Data.Bifunctor-import Data.Bifoldable-import Data.Bitraversable-import Data.Foldable-import Data.Traversable--data MaybePair a b = JustPair a b | NothingPair-  deriving (Eq,Ord,Show,Read)--instance (Semigroup a, Semigroup b) => Semigroup (MaybePair a b) where-  a <> NothingPair = a-  NothingPair <> b = b-  JustPair a b <> JustPair c d = JustPair (a <> c) (b <> d)--instance (Semigroup a, Semigroup b) => Monoid (MaybePair a b) where-  mappend = (<>) -  mempty = NothingPair--instance Bifunctor MaybePair where-  bimap f g (JustPair a b) = JustPair (f a) (g b)-  bimap _ _ NothingPair = NothingPair- -instance Functor (MaybePair a) where-  fmap f (JustPair a b) = JustPair a (f b)-  fmap _ NothingPair = NothingPair--instance Semigroup a => Apply (MaybePair a) where-  JustPair a b <.> JustPair c d = JustPair (a <> c) (b d)-  _ <.> _ = NothingPair--instance Semigroup a => Alt (MaybePair a) where-  a <!> NothingPair = a-  NothingPair <!> b = b-  JustPair a b <!> JustPair c _ = JustPair (a <> c) b--instance Semigroup a => Plus (MaybePair a) where-  zero = NothingPair--instance Foldable (MaybePair a) where-  foldMap f (JustPair _ b) = f b-  foldMap _ NothingPair = mempty--instance Traversable (MaybePair a) where-  traverse f (JustPair a b) = JustPair a <$> f b-  traverse _ NothingPair = pure NothingPair--instance Bifoldable MaybePair where-  bifoldMap f g (JustPair a b) = f a `mappend` g b-  bifoldMap _ _ NothingPair = mempty--instance Bitraversable MaybePair where-  bitraverse f g (JustPair a b) = JustPair <$> f a <*> g b-  bitraverse _ _ NothingPair = pure NothingPair
trifecta.cabal view
@@ -1,6 +1,6 @@ name:          trifecta category:      Text, Parsing, Diagnostics, Pretty Printer, Logging-version:       0.16.1+version:       0.17 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE@@ -8,9 +8,9 @@ maintainer:    Edward A. Kmett <ekmett@gmail.com> stability:     experimental homepage:      http://github.com/ekmett/trifecta/-copyright:     Copyright (C) 2011 Edward A. Kmett+copyright:     Copyright (C) 2010-2011 Edward A. Kmett synopsis:      A modern parser combinator library with convenient diagnostics-description:   A modern parser combinator library with slicing and Clang-style colored diagnostics+description:   A modern unicode-aware parser combinator library with slicing and Clang-style colored diagnostics build-type:    Simple    source-repository head@@ -20,36 +20,48 @@ library   exposed-modules:     Text.Trifecta-    Text.Trifecta.Bytes-    Text.Trifecta.Delta+    Text.Trifecta.CharSet+    Text.Trifecta.CharSet.Prim+    Text.Trifecta.CharSet.Common+    Text.Trifecta.CharSet.Posix.Ascii+    Text.Trifecta.CharSet.Posix.Unicode+    Text.Trifecta.CharSet.Unicode+    Text.Trifecta.CharSet.Unicode.Block+    Text.Trifecta.CharSet.Unicode.Category+    Text.Trifecta.Rope.Bytes+    Text.Trifecta.Rope.Delta+    Text.Trifecta.Rope.Hunk+    Text.Trifecta.Rope.Path+    Text.Trifecta.Rope.Prim+    Text.Trifecta.Rope.Strand     Text.Trifecta.Diagnostic+    Text.Trifecta.Diagnostic.Prim     Text.Trifecta.Diagnostic.Level-    Text.Trifecta.Hunk+    Text.Trifecta.Diagnostic.Err+    Text.Trifecta.Diagnostic.Err.State+    Text.Trifecta.Diagnostic.Rendering+    Text.Trifecta.Diagnostic.Rendering.Prim+    Text.Trifecta.Diagnostic.Rendering.Caret+    Text.Trifecta.Diagnostic.Rendering.Fixit+    Text.Trifecta.Diagnostic.Rendering.Span     Text.Trifecta.Parser.It     Text.Trifecta.Parser.Char     Text.Trifecta.Parser.Class-    Text.Trifecta.Parser.Err-    Text.Trifecta.Parser.Err.State     Text.Trifecta.Parser.Prim     Text.Trifecta.Parser.Result     Text.Trifecta.Parser.Combinators     Text.Trifecta.Parser.Step+    Text.Trifecta.Parser.Token     Text.Trifecta.Parser.Token.Class     Text.Trifecta.Parser.Token.Combinators-    Text.Trifecta.Parser.Token.Prim     Text.Trifecta.Parser.Token.Style+    Text.Trifecta.Parser.Token.Identifier+    Text.Trifecta.Parser.Token.Identifier.Style     Text.Trifecta.Parser.Expr-    Text.Trifecta.Path-    Text.Trifecta.Render.Prim-    Text.Trifecta.Render.Caret-    Text.Trifecta.Render.Fixit-    Text.Trifecta.Render.Span-    Text.Trifecta.Rope-    Text.Trifecta.Strand-    Text.Trifecta.Util.MaybePair    other-modules:     Text.Trifecta.Util+    Text.Trifecta.CharSet.AsciiSet    ghc-options: -Wall