trifecta 0.5.1 → 0.6
raw patch · 4 files changed
+186/−140 lines, 4 filesdep +arraydep +terminfodep +wl-pprint-terminfodep ~base
Dependencies added: array, terminfo, wl-pprint-terminfo
Dependency ranges changed: base
Files
- Text/Trifecta/Caret.hs +41/−36
- Text/Trifecta/Parser.hs +4/−4
- Text/Trifecta/Render.hs +122/−84
- trifecta.cabal +19/−16
Text/Trifecta/Caret.hs view
@@ -3,16 +3,18 @@ ( Caret(..) , HasCaret(..) , Careted(..)- , Cover(..)- , HasCover(..)- , Covered(..)+ , Span(..)+ , HasSpan(..)+ , Spanned(..) , Fixit(..)- , Diagnostic(..) ) where import Data.Hashable-import Data.ByteString as Strict+import Data.ByteString (ByteString)+import qualified Data.ByteString.UTF8 as UTF8 import Text.Trifecta.Delta+import Text.Trifecta.Render+import Prelude hiding (span) -- | -- > In file included from baz.c:9@@ -31,8 +33,14 @@ 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 @@ -43,29 +51,36 @@ -- > foo.c:8:36: note -- > int main(int argc, char ** argv) { int; } -- > ^~~-data Cover = Cover {-# UNPACK #-} !Caret !Delta deriving (Eq,Ord,Show)+data Span = Span !Delta !Delta {-# UNPACK #-} !ByteString deriving (Eq,Ord,Show) -instance HasCaret Cover where- caret (Cover c _) = c+instance HasCaret Span where+ caret (Span s _ b) = Caret s b -class HasCover t where- cover :: t -> Cover+instance Renderable Span where+ rendering (Span s e bs) = addSpan s e $ surface s bs -instance HasCover Cover where- cover = id+class HasSpan t where+ span :: t -> Span -data Covered a = a :~ Cover deriving (Eq,Ord,Show)+instance HasSpan Span where+ span = id -instance HasCover (Covered a) where- cover (_ :~ c) = c+data Spanned a = a :~ Span deriving (Eq,Ord,Show) -instance HasCaret (Covered a) where- caret = caret . cover -instance Hashable Cover where- hash (Cover c bs) = hash c `hashWithSalt` bs+instance HasSpan (Spanned a) where+ span (_ :~ c) = c -instance Hashable a => Hashable (Covered a) where+instance Renderable (Spanned a) where+ rendering = rendering . 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 -- |@@ -75,28 +90,18 @@ -- > ^ -- > , data Fixit = Fixit - { fixitCover :: {-# UNPACK #-} !Cover+ { fixitSpan :: {-# UNPACK #-} !Span , fixitReplacement :: {-# UNPACK #-} !ByteString } deriving (Eq,Ord,Show) -instance HasCover Fixit where- cover (Fixit s _) = s+instance HasSpan Fixit where+ span (Fixit s _) = s instance HasCaret Fixit where- caret = caret . cover+ caret = caret . span instance Hashable Fixit where hash (Fixit s b) = hash s `hashWithSalt` b --- |--- > In file included from bar.h:12--- > baz.h:12:17: note--- > foo + bar--- > ~~~ ^ ~~~-data Diagnostic = Diagnostic !Caret [Cover] [Fixit]--instance HasCaret Diagnostic where- caret (Diagnostic c _ _) = c--instance Hashable Diagnostic where- hash (Diagnostic c ss fs) = hash c `hashWithSalt` ss `hashWithSalt` fs+instance Renderable Fixit where+ rendering (Fixit (Span s e bs) r) = addFixit s e (UTF8.toString r) $ surface s bs
Text/Trifecta/Parser.hs view
@@ -5,7 +5,7 @@ , slice , sliced , careted- , covered+ , spanned ) where import Control.Applicative@@ -64,13 +64,13 @@ release <- getInput slice mark release -covered :: P u a -> P u (Covered a)-covered p = do+spanned :: P u a -> P u (Spanned a)+spanned p = do m <- getInput l <- line m a <- p r <- getInput- return $ a :~ Cover (Caret m l) r+ return $ a :~ Span m r l careted :: P u a -> P u (Careted a) careted p = do
Text/Trifecta/Render.hs view
@@ -1,120 +1,158 @@-module Text.Trifecta.Render+{-# LANGUAGE TypeSynonymInstances #-}+-- | Diagnostics rendering+module Text.Trifecta.Render ( Rendering(..)- , rendering- , render- , addSymbol+ , Renderable(..)+ , Source(..)+ , surface+ , draw+ , addSym+ , addFix+ , addCaret+ , addSpan , addFixit- , effect- , drawCover- , drawCaret+ -- * Internals+ , withEffects+ , caretEffects, fixitEffects, spanEffects, outOfRangeEffects+ , blankLine ) where -import Data.Ix (inRange)-import Data.ByteString hiding (groupBy)+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 Data.IntMap as IM import Text.Trifecta.Delta+import Data.Foldable (toList)+import Data.Array import Text.Trifecta.Bytes-import Text.Trifecta.Caret import Text.PrettyPrint.Leijen.Extras hiding (column)+import System.Console.Terminfo.Color+import System.Console.Terminfo.PrettyPrint import Control.Monad.State import Prelude as P -type Effect e = Doc e -> Doc e-type EffectId = Int+withEffects :: TermDoc -> [ScopedEffect] -> TermDoc+withEffects = P.foldr with -data Rendering e = Rendering - { rDelta :: !Delta- , rLine :: String- , rFresh :: !EffectId- , rEffects :: !(IntMap (Effect e))- , rSymbols :: !(IntMap (EffectId, Char))- , rFixits :: !(IntMap (EffectId, Char))+caretEffects, fixitEffects, spanEffects :: [ScopedEffect]+caretEffects = [soft (Foreground Green), soft Bold]+fixitEffects = [soft (Foreground Blue)]+spanEffects = [soft (Foreground Green)]++outOfRangeEffects :: [ScopedEffect] -> [ScopedEffect]+outOfRangeEffects xs = soft Bold : xs++type Line = Array Int ([ScopedEffect], Char)++blankLine :: Int -> Int -> Line+blankLine lo hi = listArray (lo,hi) (repeat ([],' '))++draw :: [ScopedEffect] -> Int -> String -> Line -> Line+draw e n xs a = lt $ gt $ a // P.filter (inRange bds . fst) out+ where bds@(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++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 } -instance HasDelta (Rendering e) where+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 HasDelta Rendering where delta = rDelta -rendering :: (Doc e -> Doc e) -> Delta -> ByteString -> Rendering e-rendering bold d bs = Rendering d (expand bs) 2 (IM.fromList [(0,id),(1,bold)]) IM.empty IM.empty where- expand :: ByteString -> String- expand = go 0 . UTF8.toString 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 _ [] = []+class Renderable t where+ rendering :: t -> Rendering -effect :: Effect e -> State (Rendering e) EffectId-effect f = do- s <- get- let eff = rFresh s- put s { rFresh = eff + 1, rEffects = IM.insert eff f (rEffects s) }- return eff+class Source t where+ source :: t -> (Int, Line -> Line) -drawCaret :: EffectId -> Caret -> Rendering e -> Rendering e-drawCaret eff (Caret p _) r - | near p r = addSymbol (column p) eff "^" r+instance Source String where+ source s = let s' = expand s in (P.length s', (// P.zipWith (\i c -> (i,([],c))) [0..] s'))++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++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 _ [] = []++addCaret :: Delta -> Rendering -> Rendering +addCaret p r + | near p r = addSym r $ draw caretEffects (column p) "^" | otherwise = r -drawCover :: EffectId -> Cover -> Rendering e -> Rendering e-drawCover eff (Cover (Caret s _) e) r- | nl && nh = addSymbol (column l) eff (P.replicate (column h - column l + 1) '~') r- | nl = addSymbol (column l) eff (P.replicate (cols - column l) '~' ++ ">") r- | nh = addSymbol 0 eff ('<' : P.replicate (column l) '~') r+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) 0) '~' ++ ">"+ | nh = addSym r $ draw spanEffects (-1) $ '<' : P.replicate (column l) '~' | otherwise = r where l = argmin bytes s e h = argmax bytes s e nl = near l r nh = near h r- cols = P.length (rLine r) -addSymbol, addFixit :: Int -> EffectId -> String -> Rendering e -> Rendering e-addSymbol n eff xs0 r = r { rSymbols = interval n eff xs0 (rSymbols r) }-addFixit n eff xs0 r = r { rSymbols = interval n eff xs0 (rSymbols r) }+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 -render :: Rendering e -> Doc e-render r = nesting $ \k -> columns $ \n -> go (n - k) where- go cols = (dots $ align $ vsep img) <> linebreak- where (dots, rdots, lo, hi) = window (cols - 7) r- -- line1, line2, line3 :: Doc e- line1 = rdots $ string $ P.take (hi - lo + 1) $ P.drop lo $ rLine r- line2 = cluster rSymbols- line3 = cluster rFixits- hasFixits = P.any (inRange (lo, hi)) $ IM.keys (rFixits r)- img | hasFixits = [line1, line2, line3] - | otherwise = [line1, line2]- cluster m = hcat - . P.map (\g -> findWithDefault id (fst (P.head g)) (rEffects r) $ string (P.map snd g))- . groupBy ((==) `on` fst)- $ P.map (\i -> findWithDefault (0,' ') i (m r)) [lo .. hi]+instance Pretty Rendering where+ pretty r = prettyTerm r >>= const empty -window :: Int -> Rendering e -> (Doc e -> Doc e, Doc e -> Doc e, Int, Int)-window w r - | clamp_lo && clamp_hi = (id, id, 0, w )- | clamp_lo = (id, (<> dots), 0, w )- | clamp_hi = ((dots <>), id , l-w, l )- | otherwise = ((dots <>), (<> dots), c-w2, c + w2)- where - bold = rEffects r IM.! 1- dots = bold $ text "..."- l = P.length $ rLine r- w2 = div w 2- c = column r- clamp_lo = c <= w2- clamp_hi = c + w2 > l+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+ 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 -> withEffects (string (P.map snd g)) (fst (P.head g)))+ . groupBy ((==) `on` fst)+ . toList + $ m (blankLine lo hi) -interval :: Int -> EffectId -> String -> IntMap (EffectId, Char) -> IntMap (EffectId, Char)-interval _ _ [] = id-interval k eff (x:xs) = interval (k + 1) eff xs . insert k (eff,x)+window :: Int -> Int -> Int -> (Int, Int)+window c l w + | c <= w2 = (0, w)+ | c + w2 > l = (l-w, l)+ | otherwise = (c-w2,c + w2)+ where w2 = div w 2 argmin :: Ord b => (a -> b) -> a -> a -> a-argmin f a b | f a <= f b = a- | otherwise = b+argmin f a b + | f a <= f b = a+ | otherwise = b argmax :: Ord b => (a -> b) -> a -> a -> a-argmax f a b | f a > f b = a- | otherwise = b-+argmax f a b + | f a > f b = a+ | otherwise = b
trifecta.cabal view
@@ -1,6 +1,6 @@ name: trifecta category: Text, Parsing-version: 0.5.1+version: 0.6 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE@@ -19,21 +19,24 @@ library build-depends: - base >= 4 && < 5, - containers >= 0.3 && < 0.5,- intern >= 0.5.1.1 && < 0.6,- hashable >= 1.1.2.1 && < 1.2,- bytestring >= 0.9.1 && < 0.10,- mtl >= 2.0.1 && < 2.1,- semigroups >= 0.7.1 && < 0.8, - fingertree >= 0.0.1 && < 0.1,- reducers >= 0.1.2 && < 0.2,- parsec >= 3.1.1 && < 3.2,- utf8-string >= 0.3.6 && < 0.4,- semigroupoids >= 1.2.4 && < 1.3,- parallel >= 3.1.0.1 && < 3.2,- transformers >= 0.2.2 && < 0.3,- wl-pprint-extras >= 1.2.2 && < 1.3+ base >= 4 && < 5, + array >= 0.3.0.2 && < 0.4, + containers >= 0.3 && < 0.5,+ intern >= 0.5.1.1 && < 0.6,+ hashable >= 1.1.2.1 && < 1.2,+ bytestring >= 0.9.1 && < 0.10,+ mtl >= 2.0.1 && < 2.1,+ semigroups >= 0.7.1 && < 0.8, + fingertree >= 0.0.1 && < 0.1,+ reducers >= 0.1.2 && < 0.2,+ parsec >= 3.1.1 && < 3.2,+ utf8-string >= 0.3.6 && < 0.4,+ semigroupoids >= 1.2.4 && < 1.3,+ parallel >= 3.1.0.1 && < 3.2,+ transformers >= 0.2.2 && < 0.3,+ wl-pprint-extras >= 1.2.2 && < 1.3,+ wl-pprint-terminfo >= 0.2.1.3 && < 0.3,+ terminfo >= 0.3.2 && < 0.4 ghc-options: -Wall