trifecta 0.7.2 → 0.8
raw patch · 8 files changed
+329/−142 lines, 8 filesdep +comonad
Dependencies added: comonad
Files
- Text/Trifecta.hs +6/−0
- Text/Trifecta/Caret.hs +38/−63
- Text/Trifecta/Fixit.hs +38/−0
- Text/Trifecta/Parser.hs +6/−0
- Text/Trifecta/Render.hs +90/−78
- Text/Trifecta/Rendered.hs +56/−0
- Text/Trifecta/Span.hs +90/−0
- trifecta.cabal +5/−1
Text/Trifecta.hs view
@@ -5,11 +5,14 @@ , module Text.Trifecta.Rope , module Text.Trifecta.Bytes , module Text.Trifecta.Caret+ , module Text.Trifecta.Span+ , module Text.Trifecta.Fixit , module Text.Trifecta.Delta , module Text.Trifecta.Strand , module Text.Trifecta.Supply , module Text.Trifecta.Parser , module Text.Trifecta.Render+ , module Text.Trifecta.Rendered ) where import Text.Trifecta.It@@ -17,9 +20,12 @@ import Text.Trifecta.Path import Text.Trifecta.Rope import Text.Trifecta.Caret+import Text.Trifecta.Span+import Text.Trifecta.Fixit import Text.Trifecta.Bytes import Text.Trifecta.Delta import Text.Trifecta.Strand import Text.Trifecta.Supply import Text.Trifecta.Parser import Text.Trifecta.Render+import Text.Trifecta.Rendered
Text/Trifecta/Caret.hs view
@@ -1,19 +1,22 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, BangPatterns, PatternGuards #-} module Text.Trifecta.Caret ( Caret(..) , HasCaret(..) , Careted(..)- , Span(..)- , HasSpan(..)- , Spanned(..)- , Fixit(..) ) 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 qualified Data.ByteString.UTF8 as UTF8 import Text.Trifecta.Delta import Text.Trifecta.Render+import Text.Trifecta.Bytes import Prelude hiding (span) -- |@@ -33,75 +36,47 @@ instance HasCaret Caret where caret = id -instance Renderable Caret where- rendering (Caret d bs) = addCaret d $ surface d bs--data Careted a = a :^ Caret deriving (Eq,Ord,Show)--instance Renderable (Careted a) where- rendering = rendering . caret--instance HasCaret (Careted a) where- caret (_ :^ c) = c--instance Hashable a => Hashable (Careted a) where- --- |--- > In file included from bar.c:9--- > foo.c:8:36: note--- > int main(int argc, char ** argv) { int; }--- > ^~~-data Span = Span !Delta !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show)--instance HasCaret Span where- caret (Span s _ b) = Caret s b+instance HasBytes Caret where+ bytes = bytes . delta -instance Renderable Span where- rendering (Span s e bs) = addSpan s e $ surface s bs+instance HasDelta Caret where+ delta (Caret d _) = d -class HasSpan t where- span :: t -> Span+instance Renderable Caret where+ render (Caret d bs) = addCaret d $ surface d bs -instance HasSpan Span where- span = id+instance Semigroup Caret where+ a <> _ = a -data Spanned a = a :~ Span deriving (Eq,Ord,Show)+data Careted a = a :^ Caret deriving (Eq,Ord,Show) +instance Functor Careted where+ fmap f (a :^ s) = f a :^ s -instance HasSpan (Spanned a) where- span (_ :~ c) = c+instance Extend Careted where+ extend f as@(_ :^ s) = f as :^ s -instance Renderable (Spanned a) where- rendering = rendering . span+instance Comonad Careted where+ extract (a :^ _) = a -instance HasCaret (Spanned a) where- caret = caret . span+instance Foldable Careted where+ foldMap f (a :^ _) = f a -instance Hashable Span where- hash (Span s e bs) = hash s `hashWithSalt` e `hashWithSalt` bs+instance Traversable Careted where+ traverse f (a :^ s) = (:^ s) <$> f a -instance Hashable a => Hashable (Spanned a) where- hash (a :~ s) = hash a `hashWithSalt` s+instance Foldable1 Careted where+ foldMap1 f (a :^ _) = f a --- |--- > In file included from bar.c:12--- > foo.c:12:17: note--- > int main(int argc char ** argv) { int; }--- > ^--- > ,-data Fixit = Fixit - { fixitSpan :: {-# UNPACK #-} !Span- , fixitReplacement :: {-# UNPACK #-} !ByteString - } deriving (Eq,Ord,Show)+instance Traversable1 Careted where+ traverse1 f (a :^ s) = (:^ s) <$> f a -instance HasSpan Fixit where- span (Fixit s _) = s+instance Renderable (Careted a) where+ render = render . caret -instance HasCaret Fixit where- caret = caret . span+instance HasCaret (Careted a) where+ caret (_ :^ c) = c -instance Hashable Fixit where- hash (Fixit s b) = hash s `hashWithSalt` b+instance Hashable a => Hashable (Careted a) where+ -instance Renderable Fixit where- rendering (Fixit (Span s e bs) r) = addFixit s e (UTF8.toString r) $ surface s bs
+ Text/Trifecta/Fixit.hs view
@@ -0,0 +1,38 @@+module Text.Trifecta.Fixit+ ( Fixit(..)+ ) where++import Data.Hashable+import Data.ByteString (ByteString)+import qualified Data.ByteString.UTF8 as UTF8+import Text.Trifecta.Delta+import Text.Trifecta.Render+import Text.Trifecta.Caret+import Text.Trifecta.Span+import Prelude hiding (span)++-- |+-- > In file included from bar.c:12+-- > foo.c:12:17: note+-- > int main(int argc char ** argv) { int; }+-- > ^+-- > ,+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
Text/Trifecta/Parser.hs view
@@ -6,6 +6,7 @@ , sliced , careted , spanned+ , fixit ) where import Control.Applicative@@ -22,6 +23,8 @@ import Text.Trifecta.Delta import Text.Trifecta.Strand import Text.Trifecta.Caret+import Text.Trifecta.Span+import Text.Trifecta.Fixit import Text.Trifecta.It import Text.Parsec.Prim hiding ((<|>)) @@ -78,3 +81,6 @@ l <- line m a <- p return $ a :^ Caret m l++fixit :: P u Strict.ByteString -> P u Fixit+fixit p = (\(rep :~ s) -> Fixit s rep) <$> spanned p
Text/Trifecta/Render.hs view
@@ -1,28 +1,30 @@ {-# LANGUAGE TypeSynonymInstances #-} -- | Diagnostics rendering module Text.Trifecta.Render - ( Rendering(..)+ ( Render(..) , Renderable(..) , Source(..) , surface- , draw- , addSym- , addFix , addCaret , addSpan , addFixit+ -- * Lower level drawing primitives+ , draw+ , ifNear+ , (.#)+ , drawCaret+ , drawFixit+ , drawSpan -- * Internals , caretEffects, fixitEffects, spanEffects, outOfRangeEffects- , blankLine ) where -import Control.Applicative hiding (empty) import Data.ByteString hiding (groupBy, empty, any) import qualified Data.ByteString.UTF8 as UTF8 import Data.List (groupBy) import Data.Function (on) import Text.Trifecta.Delta-import Data.Foldable (toList)+import Data.Semigroup import Data.Array import Text.Trifecta.Bytes import Text.PrettyPrint.Leijen.Extras hiding (column)@@ -31,116 +33,126 @@ import Control.Monad.State import Prelude as P -caretEffects, fixitEffects, spanEffects :: [ScopedEffect]+caretEffects, fixitEffects, spanEffects, sourceEffects :: [ScopedEffect] caretEffects = [soft (Foreground Green), soft Bold] fixitEffects = [soft (Foreground Blue)] spanEffects = [soft (Foreground Green)]+sourceEffects = [] outOfRangeEffects :: [ScopedEffect] -> [ScopedEffect] outOfRangeEffects xs = soft Bold : xs -type Line = Array Int ([ScopedEffect], Char)+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 -draw :: [ScopedEffect] -> Int -> String -> Line -> Line-draw e n xs a = gt $ lt $ a /// out- where (lo,hi) = bounds a- out = P.zipWith (\i c -> (i,(e,c))) [n..] xs- lt | any (\el -> fst el < lo) out = (// [(lo,(outOfRangeEffects e,'<'))])- | otherwise = id- gt | any (\el -> fst el > hi) out = (// [(hi,(outOfRangeEffects e,'>'))])- | otherwise = id+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)) -data Rendering = Rendering - { rDelta :: !Delta -- focus, the rendering will keep this visible- , rLineLen :: {-# UNPACK #-} !Int -- actual line length- , rLine :: Line -> Line -- source contents- , rSymbols :: Line -> Line -- annotations about the line- , rFixits :: Maybe (Line -> Line) -- fixits providing alternate text+draw :: [ScopedEffect] -> Int -> Int -> String -> Lines -> Lines+draw e y n xs a0 = 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 | any (\el -> snd (fst el) < lo) out = (// [((y,lo),(outOfRangeEffects e,'<'))])+ | otherwise = id+ gt | 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 } -addSym, addFix :: Rendering -> (Line -> Line) -> Rendering-addSym r f = r { rSymbols = f . rSymbols r }-addFix r f = r { rFixits = fmap (f .) (rFixits r) <|> Just f } +instance Semigroup Render where+ Render del len doc f <> Render _ _ _ g = Render del len doc $ \d l -> f d (g d l) -instance HasDelta Rendering where+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- rendering :: t -> Rendering + render :: t -> Render -instance Renderable Rendering where- rendering = id+instance Renderable Render where+ render = id class Source t where- source :: t -> (Int, Line -> Line)+ source :: t -> (Int, Lines -> Lines) instance Source String where- source s = (P.length s', draw [] 0 s') where s' = expand s+ source s = (P.length s', draw sourceEffects 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 -> Rendering-surface d s = case source s of - (ls, doc) -> Rendering d ls doc id Nothing+surface :: Source s => Delta -> s -> Render+surface del s = case source s of + (len, doc) -> Render del len doc (\_ l -> l) -expand :: String -> String-expand = go 0 where- 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 _ [] = []+drawCaret :: Delta -> Delta -> Lines -> Lines+drawCaret p = ifNear p $ draw caretEffects 1 (column p) "^" -addCaret :: Delta -> Rendering -> Rendering -addCaret p r - | near p r = addSym r $ draw caretEffects (column p) "^"- | otherwise = r+(.#) :: (Delta -> Lines -> Lines) -> Render -> Render+f .# Render d ll s g = Render d ll s $ \e l -> f e $ g e l -addSpan :: Delta -> Delta -> Rendering -> Rendering -addSpan s e r- | nl && nh = addSym r $ draw spanEffects (column l) $ P.replicate (max (column h - column l + 1) 0) '~' - | nl = addSym r $ draw spanEffects (column l) $ P.replicate (max (rLineLen r - column l + 2) 0) '~'- | nh = addSym r $ draw spanEffects (-1) $ P.replicate (max (column h + 1) 0) '~'- | otherwise = r+addCaret :: Delta -> Render -> Render+addCaret p r = drawCaret p .# r++drawSpan :: Delta -> Delta -> Delta -> Lines -> Lines+drawSpan s e d a+ | nl && nh = draw spanEffects 1 (column l) (P.replicate (max (column h - column l + 1) 0) '~') a+ | nl = draw spanEffects 1 (column l) (P.replicate (max (snd (snd (bounds a)) - column l + 2) 0) '~') a+ | nh = draw spanEffects 1 (-1) (P.replicate (max (column h + 1) 0) '~') a+ | otherwise = a where l = argmin bytes s e h = argmax bytes s e- nl = near l r- nh = near h r+ nl = near l d+ nh = near h d -addFixit :: Delta -> Delta -> String -> Rendering -> Rendering-addFixit s e rpl r- | near l r = addFix r' $ draw fixitEffects (column l) rpl- | otherwise = r'- where - l = argmin bytes s e- r' = addSpan s e r+addSpan :: Delta -> Delta -> Render -> Render+addSpan s e r = drawSpan s e .# r -instance Pretty Rendering where+drawFixit :: Delta -> Delta -> String -> Delta -> Lines -> Lines+drawFixit s e rpl d a = ifNear l (draw fixitEffects 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++instance Pretty Render where pretty r = prettyTerm r >>= const empty -instance PrettyTerm Rendering where- prettyTerm r = nesting $ \k -> columns $ \n -> go (n - k) where- go cols = align (vsep img) <> linebreak where - (lo, hi) = window (column r) (rLineLen r) (cols - 2)- line1 = cluster $ rLine r- line2 = cluster $ rSymbols r - img = case cluster <$> rFixits r of - Just line3 -> [line1, line2, line3] - Nothing -> [line1, line2]- cluster :: (Line -> Line) -> TermDoc- cluster m = hcat - . P.map (\g -> P.foldr with (string (P.map snd g)) (fst (P.head g)))- . groupBy ((==) `on` fst)- . toList - $ m (blankLine lo hi)+instance Show Render where+ showsPrec _ = displayS . renderPretty 0.9 100 . prettyTerm -blankLine :: Int -> Int -> Line-blankLine lo hi = listArray (lo,hi) (repeat ([],' '))+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])) <> linebreak where + (lo, hi) = window (column d) ll (cols - 2)+ a = f d $ l $ array ((0,lo),(-1,hi)) [] -- blankLine lo 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
+ Text/Trifecta/Rendered.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, BangPatterns, PatternGuards #-}+module Text.Trifecta.Rendered+ ( Rendered(..)+ ) where++import Control.Applicative+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 Text.Trifecta.Delta+import Text.Trifecta.Bytes+import Text.Trifecta.Render+import Prelude hiding (span)++data Rendered a = a :@ Render++instance Functor Rendered where+ fmap f (a :@ s) = f a :@ s++instance HasDelta (Rendered a) where+ delta = delta . render++instance HasBytes (Rendered a) where+ bytes = bytes . delta++instance Extend Rendered where+ extend f as@(_ :@ s) = f as :@ s++instance Comonad Rendered where+ extract (a :@ _) = a++instance Apply Rendered where+ (f :@ s) <.> (a :@ t) = f a :@ (s <> t)++instance Bind Rendered where+ (a :@ s) >>- f = case f a of+ b :@ t -> b :@ (s <> t)++instance Foldable Rendered where+ foldMap f (a :@ _) = f a ++instance Traversable Rendered where+ traverse f (a :@ s) = (:@ s) <$> f a++instance Foldable1 Rendered where+ foldMap1 f (a :@ _) = f a ++instance Traversable1 Rendered where+ traverse1 f (a :@ s) = (:@ s) <$> f a++instance Renderable (Rendered a) where+ render (_ :@ s) = s
+ Text/Trifecta/Span.hs view
@@ -0,0 +1,90 @@+module Text.Trifecta.Span+ ( Span(..)+ , HasSpan(..)+ , Spanned(..)+ ) 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.Delta+import Text.Trifecta.Caret+import Text.Trifecta.Render+import Prelude hiding (span)++-- |+-- > In file included from bar.c:9+-- > foo.c:8:36: note+-- > int main(int argc, char ** argv) { int; }+-- > ^~~+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++
trifecta.cabal view
@@ -1,6 +1,6 @@ name: trifecta category: Text, Parsing-version: 0.7.2+version: 0.8 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE@@ -34,6 +34,7 @@ semigroupoids >= 1.2.4 && < 1.3, parallel >= 3.1.0.1 && < 3.2, transformers >= 0.2.2 && < 0.3,+ comonad >= 1.1.1 && < 1.2, wl-pprint-extras >= 1.2.2 && < 1.3, wl-pprint-terminfo >= 0.2.1.3 && < 0.3, terminfo >= 0.3.2 && < 0.4@@ -48,8 +49,11 @@ Text.Trifecta.Hunk Text.Trifecta.Bytes Text.Trifecta.Caret+ Text.Trifecta.Span+ Text.Trifecta.Fixit Text.Trifecta.Delta Text.Trifecta.Strand Text.Trifecta.Supply Text.Trifecta.Parser Text.Trifecta.Render+ Text.Trifecta.Rendered