diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/Text/Trifecta.hs b/Text/Trifecta.hs --- a/Text/Trifecta.hs +++ b/Text/Trifecta.hs @@ -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 diff --git a/Text/Trifecta/Bytes.hs b/Text/Trifecta/Bytes.hs deleted file mode 100644 --- a/Text/Trifecta/Bytes.hs +++ /dev/null @@ -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 diff --git a/Text/Trifecta/CharSet.hs b/Text/Trifecta/CharSet.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/CharSet.hs @@ -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 () + diff --git a/Text/Trifecta/CharSet/AsciiSet.hs b/Text/Trifecta/CharSet/AsciiSet.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/CharSet/AsciiSet.hs @@ -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 diff --git a/Text/Trifecta/CharSet/Common.hs b/Text/Trifecta/CharSet/Common.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/CharSet/Common.hs @@ -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 diff --git a/Text/Trifecta/CharSet/Posix/Ascii.hs b/Text/Trifecta/CharSet/Posix/Ascii.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/CharSet/Posix/Ascii.hs @@ -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 diff --git a/Text/Trifecta/CharSet/Posix/Unicode.hs b/Text/Trifecta/CharSet/Posix/Unicode.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/CharSet/Posix/Unicode.hs @@ -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 + diff --git a/Text/Trifecta/CharSet/Prim.hs b/Text/Trifecta/CharSet/Prim.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/CharSet/Prim.hs @@ -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 diff --git a/Text/Trifecta/CharSet/Unicode.hs b/Text/Trifecta/CharSet/Unicode.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/CharSet/Unicode.hs @@ -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 diff --git a/Text/Trifecta/CharSet/Unicode/Block.hs b/Text/Trifecta/CharSet/Unicode/Block.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/CharSet/Unicode/Block.hs @@ -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' diff --git a/Text/Trifecta/CharSet/Unicode/Category.hs b/Text/Trifecta/CharSet/Unicode/Category.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/CharSet/Unicode/Category.hs @@ -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 diff --git a/Text/Trifecta/Delta.hs b/Text/Trifecta/Delta.hs deleted file mode 100644 --- a/Text/Trifecta/Delta.hs +++ /dev/null @@ -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 diff --git a/Text/Trifecta/Diagnostic.hs b/Text/Trifecta/Diagnostic.hs --- a/Text/Trifecta/Diagnostic.hs +++ b/Text/Trifecta/Diagnostic.hs @@ -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 diff --git a/Text/Trifecta/Diagnostic/Err.hs b/Text/Trifecta/Diagnostic/Err.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Diagnostic/Err.hs @@ -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 = () diff --git a/Text/Trifecta/Diagnostic/Err/State.hs b/Text/Trifecta/Diagnostic/Err/State.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Diagnostic/Err/State.hs @@ -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 = () diff --git a/Text/Trifecta/Diagnostic/Prim.hs b/Text/Trifecta/Diagnostic/Prim.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Diagnostic/Prim.hs @@ -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) + + diff --git a/Text/Trifecta/Diagnostic/Rendering.hs b/Text/Trifecta/Diagnostic/Rendering.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Diagnostic/Rendering.hs @@ -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 diff --git a/Text/Trifecta/Diagnostic/Rendering/Caret.hs b/Text/Trifecta/Diagnostic/Rendering/Caret.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Diagnostic/Rendering/Caret.hs @@ -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 + diff --git a/Text/Trifecta/Diagnostic/Rendering/Fixit.hs b/Text/Trifecta/Diagnostic/Rendering/Fixit.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Diagnostic/Rendering/Fixit.hs @@ -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 diff --git a/Text/Trifecta/Diagnostic/Rendering/Prim.hs b/Text/Trifecta/Diagnostic/Rendering/Prim.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Diagnostic/Rendering/Prim.hs @@ -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 diff --git a/Text/Trifecta/Diagnostic/Rendering/Span.hs b/Text/Trifecta/Diagnostic/Rendering/Span.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Diagnostic/Rendering/Span.hs @@ -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 diff --git a/Text/Trifecta/Hunk.hs b/Text/Trifecta/Hunk.hs deleted file mode 100644 --- a/Text/Trifecta/Hunk.hs +++ /dev/null @@ -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 diff --git a/Text/Trifecta/Parser/Class.hs b/Text/Trifecta/Parser/Class.hs --- a/Text/Trifecta/Parser/Class.hs +++ b/Text/Trifecta/Parser/Class.hs @@ -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 diff --git a/Text/Trifecta/Parser/Combinators.hs b/Text/Trifecta/Parser/Combinators.hs --- a/Text/Trifecta/Parser/Combinators.hs +++ b/Text/Trifecta/Parser/Combinators.hs @@ -216,4 +216,3 @@ m <- mark p <* release m - diff --git a/Text/Trifecta/Parser/Err.hs b/Text/Trifecta/Parser/Err.hs deleted file mode 100644 --- a/Text/Trifecta/Parser/Err.hs +++ /dev/null @@ -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 = () diff --git a/Text/Trifecta/Parser/Err/State.hs b/Text/Trifecta/Parser/Err/State.hs deleted file mode 100644 --- a/Text/Trifecta/Parser/Err/State.hs +++ /dev/null @@ -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 = () diff --git a/Text/Trifecta/Parser/It.hs b/Text/Trifecta/Parser/It.hs --- a/Text/Trifecta/Parser/It.hs +++ b/Text/Trifecta/Parser/It.hs @@ -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 - diff --git a/Text/Trifecta/Parser/Prim.hs b/Text/Trifecta/Parser/Prim.hs --- a/Text/Trifecta/Parser/Prim.hs +++ b/Text/Trifecta/Parser/Prim.hs @@ -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) diff --git a/Text/Trifecta/Parser/Result.hs b/Text/Trifecta/Parser/Result.hs --- a/Text/Trifecta/Parser/Result.hs +++ b/Text/Trifecta/Parser/Result.hs @@ -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 diff --git a/Text/Trifecta/Parser/Step.hs b/Text/Trifecta/Parser/Step.hs --- a/Text/Trifecta/Parser/Step.hs +++ b/Text/Trifecta/Parser/Step.hs @@ -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 diff --git a/Text/Trifecta/Parser/Token.hs b/Text/Trifecta/Parser/Token.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Parser/Token.hs @@ -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 diff --git a/Text/Trifecta/Parser/Token/Identifier.hs b/Text/Trifecta/Parser/Token/Identifier.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Parser/Token/Identifier.hs @@ -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 + diff --git a/Text/Trifecta/Parser/Token/Identifier/Style.hs b/Text/Trifecta/Parser/Token/Identifier/Style.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Parser/Token/Identifier/Style.hs @@ -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" + ] diff --git a/Text/Trifecta/Parser/Token/Prim.hs b/Text/Trifecta/Parser/Token/Prim.hs deleted file mode 100644 --- a/Text/Trifecta/Parser/Token/Prim.hs +++ /dev/null @@ -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" diff --git a/Text/Trifecta/Parser/Token/Style.hs b/Text/Trifecta/Parser/Token/Style.hs --- a/Text/Trifecta/Parser/Token/Style.hs +++ b/Text/Trifecta/Parser/Token/Style.hs @@ -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" diff --git a/Text/Trifecta/Path.hs b/Text/Trifecta/Path.hs deleted file mode 100644 --- a/Text/Trifecta/Path.hs +++ /dev/null @@ -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 #-} - diff --git a/Text/Trifecta/Render/Caret.hs b/Text/Trifecta/Render/Caret.hs deleted file mode 100644 --- a/Text/Trifecta/Render/Caret.hs +++ /dev/null @@ -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 diff --git a/Text/Trifecta/Render/Fixit.hs b/Text/Trifecta/Render/Fixit.hs deleted file mode 100644 --- a/Text/Trifecta/Render/Fixit.hs +++ /dev/null @@ -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 diff --git a/Text/Trifecta/Render/Prim.hs b/Text/Trifecta/Render/Prim.hs deleted file mode 100644 --- a/Text/Trifecta/Render/Prim.hs +++ /dev/null @@ -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 diff --git a/Text/Trifecta/Render/Span.hs b/Text/Trifecta/Render/Span.hs deleted file mode 100644 --- a/Text/Trifecta/Render/Span.hs +++ /dev/null @@ -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 diff --git a/Text/Trifecta/Rope.hs b/Text/Trifecta/Rope.hs deleted file mode 100644 --- a/Text/Trifecta/Rope.hs +++ /dev/null @@ -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 diff --git a/Text/Trifecta/Rope/Bytes.hs b/Text/Trifecta/Rope/Bytes.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Rope/Bytes.hs @@ -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 diff --git a/Text/Trifecta/Rope/Delta.hs b/Text/Trifecta/Rope/Delta.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Rope/Delta.hs @@ -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 diff --git a/Text/Trifecta/Rope/Hunk.hs b/Text/Trifecta/Rope/Hunk.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Rope/Hunk.hs @@ -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 diff --git a/Text/Trifecta/Rope/Path.hs b/Text/Trifecta/Rope/Path.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Rope/Path.hs @@ -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 #-} + diff --git a/Text/Trifecta/Rope/Prim.hs b/Text/Trifecta/Rope/Prim.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Rope/Prim.hs @@ -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 diff --git a/Text/Trifecta/Rope/Strand.hs b/Text/Trifecta/Rope/Strand.hs new file mode 100644 --- /dev/null +++ b/Text/Trifecta/Rope/Strand.hs @@ -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 diff --git a/Text/Trifecta/Strand.hs b/Text/Trifecta/Strand.hs deleted file mode 100644 --- a/Text/Trifecta/Strand.hs +++ /dev/null @@ -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 diff --git a/Text/Trifecta/Util/MaybePair.hs b/Text/Trifecta/Util/MaybePair.hs deleted file mode 100644 --- a/Text/Trifecta/Util/MaybePair.hs +++ /dev/null @@ -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 diff --git a/trifecta.cabal b/trifecta.cabal --- a/trifecta.cabal +++ b/trifecta.cabal @@ -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 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