Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Everything but Text/Trifecta/Highlight.hs is switched to ansi-wl-pprint

  • Loading branch information...
commit 90a8ffbc74d72f6e5e86422d5316a4469319d918 1 parent 8fffb98
@ekmett authored
View
2  src/Text/Trifecta.hs
@@ -18,7 +18,6 @@ module Text.Trifecta
, module Text.Parser.Combinators
, module Text.Parser.Char
, module Text.Parser.Token
- , module System.Console.Terminfo.PrettyPrint
) where
import Text.Trifecta.Rendering
@@ -29,4 +28,3 @@ import Text.Trifecta.Rope
import Text.Parser.Combinators
import Text.Parser.Char
import Text.Parser.Token
-import System.Console.Terminfo.PrettyPrint
View
12 src/Text/Trifecta/Delta.hs
@@ -21,7 +21,6 @@ module Text.Trifecta.Delta
, columnByte
) where
-import Control.Applicative
import Data.Semigroup
import Data.Hashable
import Data.Int
@@ -33,8 +32,8 @@ import Data.FingerTree hiding (empty)
import Data.ByteString as Strict hiding (empty)
import qualified Data.ByteString.UTF8 as UTF8
import GHC.Generics
-import Text.PrettyPrint.Free hiding (column)
-import System.Console.Terminfo.PrettyPrint
+import Text.Trifecta.Instances ()
+import Text.PrettyPrint.ANSI.Leijen hiding (column, (<>))
class HasBytes t where
bytes :: t -> Int64
@@ -72,10 +71,7 @@ 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
+ pretty d = case d of
Columns c _ -> k f 0 c
Tab x y _ -> k f 0 (nextTab x + y)
Lines l c _ _ -> k f l c
@@ -84,7 +80,7 @@ instance PrettyTerm Delta where
k fn ln cn = bold (pretty fn) <> char ':' <> bold (int64 (ln+1)) <> char ':' <> bold (int64 (cn+1))
f = "(interactive)"
-int64 :: Int64 -> Doc e
+int64 :: Int64 -> Doc
int64 = pretty . show
column :: HasDelta t => t -> Int64
View
61 src/Text/Trifecta/Highlight.hs
@@ -15,16 +15,12 @@ module Text.Trifecta.Highlight
( Highlight
, HighlightedRope(HighlightedRope)
, HasHighlightedRope(..)
- , highlightEffects
- , pushToken
- , popToken
, withHighlight
, HighlightDoc(HighlightDoc)
, HasHighlightDoc(..)
, doc
) where
-import Control.Applicative
import Control.Lens
import Data.Foldable as F
import Data.Int (Int64)
@@ -33,41 +29,38 @@ import Data.List (sort)
import Data.Semigroup
import Data.Semigroup.Union
import Prelude hiding (head)
-import System.Console.Terminfo.Color
-import System.Console.Terminfo.PrettyPrint
import Text.Blaze
import Text.Blaze.Html5 hiding (a,b,i)
import qualified Text.Blaze.Html5 as Html5
-import Text.Blaze.Html5.Attributes hiding (title)
+import Text.Blaze.Html5.Attributes hiding (title,id)
import Text.Blaze.Internal
import Text.Parser.Token.Highlight
-import Text.PrettyPrint.Free
+import Text.PrettyPrint.ANSI.Leijen hiding ((<>))
import Text.Trifecta.Util.IntervalMap as IM
import Text.Trifecta.Delta
import Text.Trifecta.Rope
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8 as LazyUTF8
-highlightEffects :: Highlight -> [ScopedEffect]
-highlightEffects Comment = [soft $ Foreground Blue]
-highlightEffects ReservedIdentifier = [soft $ Foreground Magenta, soft Bold]
-highlightEffects ReservedConstructor = [soft $ Foreground Magenta, soft Bold]
-highlightEffects EscapeCode = [soft $ Foreground Magenta, soft Bold]
-highlightEffects Operator = [soft $ Foreground Yellow]
-highlightEffects CharLiteral = [soft $ Foreground Cyan]
-highlightEffects StringLiteral = [soft $ Foreground Cyan]
-highlightEffects Constructor = [soft Bold]
-highlightEffects ReservedOperator = [soft $ Foreground Yellow]
-highlightEffects ConstructorOperator = [soft $ Foreground Yellow, soft Bold]
-highlightEffects ReservedConstructorOperator = [soft $ Foreground Yellow, soft Bold]
-highlightEffects _ = []
-
-pushToken, popToken :: Highlight -> TermDoc
-pushToken h = Prelude.foldr (\x b -> pure (Push x) <> b) mempty (highlightEffects h)
-popToken h = Prelude.foldr (\_ b -> pure Pop <> b) mempty (highlightEffects h)
-
-withHighlight :: Highlight -> TermDoc -> TermDoc
-withHighlight h d = pushToken h <> d <> popToken h
+withHighlight :: Highlight -> Doc -> Doc
+withHighlight Comment = blue
+withHighlight ReservedIdentifier = magenta
+withHighlight ReservedConstructor = magenta
+withHighlight EscapeCode = magenta
+withHighlight Operator = yellow
+withHighlight CharLiteral = cyan
+withHighlight StringLiteral = cyan
+withHighlight Constructor = bold
+withHighlight ReservedOperator = yellow
+withHighlight ConstructorOperator = yellow
+withHighlight ReservedConstructorOperator = yellow
+withHighlight _ = id
+
+{-
+pushToken, popToken :: Highlight -> Doc
+pushToken h = Prelude.foldr (\x b -> pure (Push x) <> b) mempty (withHighlight h)
+popToken h = Prelude.foldr (\_ b -> pure Pop <> b) mempty (withHighlight h)
+-}
data HighlightedRope = HighlightedRope
{ _ropeHighlights :: !(IM.IntervalMap Delta Highlight)
@@ -112,20 +105,20 @@ instance ToMarkup HighlightedRope where
where (om,nom) = L.splitAt (fromIntegral (eb - b)) cs
instance Pretty HighlightedRope where
- pretty (HighlightedRope _ r) = hsep $ [ pretty bs | Strand bs _ <- F.toList (strands r)]
-
-instance PrettyTerm HighlightedRope where
- prettyTerm (HighlightedRope intervals r) = go 0 lbs effects where
+ pretty (HighlightedRope _intervals r) = go 0 lbs effects where
lbs = L.fromChunks [bs | Strand bs _ <- F.toList (strands r)]
+ effects = error "pretty HighlightRope effects"
+{-
effects = sort $ [ i | (Interval lo hi, tok) <- intersections mempty (delta r) intervals
, i <- [ pushToken tok :@ bytes lo
, popToken tok :@ bytes hi
]
]
- go _ cs [] = prettyTerm (LazyUTF8.toString cs)
+-}
+ go _ cs [] = pretty (LazyUTF8.toString cs)
go b cs ((eff :@ eb) : es)
| eb <= b = eff <> go b cs es
- | otherwise = prettyTerm (LazyUTF8.toString om) <> go eb nom es
+ | otherwise = pretty (LazyUTF8.toString om) <> go eb nom es
where (om,nom) = L.splitAt (fromIntegral (eb - b)) cs
-- | Represents a source file like an HsColour rendered document
View
20 src/Text/Trifecta/Instances.hs
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Trifecta.Instances
+-- Copyright : (c) Edward Kmett 2013
+-- License : BSD3
+--
+-- Maintainer : ekmett@gmail.com
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Orphan instances we need to remain sane.
+-----------------------------------------------------------------------------
+module Text.Trifecta.Instances () where
+
+import Text.PrettyPrint.ANSI.Leijen
+import qualified Data.Semigroup as Data
+
+instance Data.Semigroup Doc where
+ (<>) = (<>)
View
37 src/Text/Trifecta/Parser.hs
@@ -55,21 +55,22 @@ import Data.Semigroup
import Data.Semigroup.Reducer
-- import Data.Sequence as Seq hiding (empty)
import Data.Set as Set hiding (empty, toList)
-import System.Console.Terminfo.PrettyPrint
+import System.IO
import Text.Parser.Combinators
import Text.Parser.Char
import Text.Parser.LookAhead
import Text.Parser.Token
-import Text.PrettyPrint.Free as Pretty hiding (line)
+import Text.PrettyPrint.ANSI.Leijen as Pretty hiding (line, (<>), (<$>), empty)
import Text.Trifecta.Combinators
+import Text.Trifecta.Instances ()
import Text.Trifecta.Rendering
import Text.Trifecta.Rope
import Text.Trifecta.Delta as Delta
import Text.Trifecta.Util.It
data Err = Err
- { _reason :: Maybe TermDoc
- , _footnotes :: [TermDoc]
+ { _reason :: Maybe Doc
+ , _footnotes :: [Doc]
, _expected :: Set String
}
@@ -92,7 +93,7 @@ newtype Parser a = Parser
(a -> Err -> It Rope r) ->
(Err -> It Rope r) ->
(a -> Set String -> Delta -> ByteString -> It Rope r) -> -- committed success
- (TermDoc -> It Rope r) -> -- committed err
+ (Doc -> It Rope r) -> -- committed err
Delta -> ByteString -> It Rope r
}
@@ -218,9 +219,9 @@ instance MarkParsing Delta Parser where
else co () mempty d' mempty
| otherwise -> ee mempty
-explain :: Rendering -> Err -> TermDoc
+explain :: Rendering -> Err -> Doc
explain r (Err mm as es)
- | Set.null es = report (withEx empty)
+ | Set.null es = report (withEx mempty)
| isJust mm = report $ withEx $ Pretty.char ',' <+> expecting
| otherwise = report expecting
where
@@ -229,32 +230,28 @@ explain r (Err mm as es)
spaceHack xs = List.filter (/= "") xs
withEx x = fromMaybe (fillSep $ text <$> words "unspecified error") mm <> x
expecting = text "expected:" <+> fillSep (punctuate (Pretty.char ',') (text <$> now))
- report txt = vsep $ [prettyTerm (delta r) <> Pretty.char ':' <+> red (text "error") <> Pretty.char ':' <+> nest 4 txt]
- <|> prettyTerm r <$ guard (not (nullRendering r))
+ report txt = vsep $ [pretty (delta r) <> Pretty.char ':' <+> red (text "error") <> Pretty.char ':' <+> nest 4 txt]
+ <|> pretty r <$ guard (not (nullRendering r))
<|> as
data Result a
= Success a
- | Failure TermDoc
+ | Failure Doc
deriving (Show,Functor,Foldable,Traversable)
instance Show a => Pretty (Result a) where
pretty (Success a) = pretty (show a)
pretty (Failure xs) = pretty xs
-instance Show a => PrettyTerm (Result a) where
- prettyTerm (Success a) = pretty (show a)
- prettyTerm (Failure xs) = prettyTerm xs
-
instance Applicative Result where
pure = Success
Success f <*> Success a = Success (f a)
Success _ <*> Failure ys = Failure ys
Failure xs <*> Success _ = Failure xs
- Failure xs <*> Failure ys = Failure $ above xs ys
+ Failure xs <*> Failure ys = Failure $ vsep [xs, ys]
instance Alternative Result where
- Failure xs <|> Failure ys = Failure $ above xs ys
+ Failure xs <|> Failure ys = Failure $ vsep [xs, ys]
Success a <|> Success _ = Success a
Success a <|> Failure _ = Success a
Failure _ <|> Success a = Success a
@@ -262,7 +259,7 @@ instance Alternative Result where
data Step a
= StepDone !Rope a
- | StepFail !Rope TermDoc
+ | StepFail !Rope Doc
| StepCont !Rope (Result a) (Rope -> Step a)
instance Show a => Show (Step a) where
@@ -301,7 +298,7 @@ data Stepping a
= EO a Err
| EE Err
| CO a (Set String) Delta ByteString
- | CE TermDoc
+ | CE Doc
stepParser :: Parser a -> Delta -> ByteString -> Step a
stepParser (Parser p) d0 bs0 = go mempty $ p eo ee co ce d0 bs0 where
@@ -335,7 +332,7 @@ parseFromFile p fn = do
case result of
Success a -> return (Just a)
Failure xs -> do
- displayLn xs
+ liftIO $ displayIO stdout $ renderPretty 0.8 80 $ xs <> linebreak
return Nothing
-- | @parseFromFileEx p filePath@ runs a parser @p@ on the
@@ -364,5 +361,5 @@ parseString p d inp = starve $ feed inp $ stepParser (release d *> p) mempty mem
parseTest :: (MonadIO m, Show a) => Parser a -> String -> m ()
parseTest p s = case parseByteString p mempty (UTF8.fromString s) of
- Failure xs -> displayLn xs
+ Failure xs -> liftIO $ displayIO stdout $ renderPretty 0.8 80 $ xs <> linebreak -- TODO: retrieve columns
Success a -> liftIO (print a)
View
111 src/Text/Trifecta/Rendering.hs
@@ -59,7 +59,6 @@ module Text.Trifecta.Rendering
import Control.Applicative
import Control.Comonad
import Control.Lens
-import Control.Monad.State
import Data.Array
import Data.ByteString as B hiding (groupBy, empty, any)
import qualified Data.ByteString.UTF8 as UTF8
@@ -68,23 +67,70 @@ import Data.Foldable
import Data.Function (on)
import Data.Hashable
import Data.Int (Int64)
+import Data.Maybe
import Data.List (groupBy)
import Data.Semigroup
import Data.Semigroup.Reducer
import GHC.Generics
import Prelude as P hiding (span)
-import System.Console.Terminfo.Color
-import System.Console.Terminfo.PrettyPrint
-import Text.PrettyPrint.Free hiding (column)
--- import Text.Trifecta.Highlight
+import System.Console.ANSI
+import Text.PrettyPrint.ANSI.Leijen hiding (column, (<>), (<$>))
import Text.Trifecta.Delta
+import Text.Trifecta.Instances ()
import Text.Trifecta.Util.Combinators
--- import Text.Trifecta.Util.IntervalMap
-outOfRangeEffects :: [ScopedEffect] -> [ScopedEffect]
-outOfRangeEffects xs = soft Bold : xs
-
-type Lines = Array (Int,Int64) ([ScopedEffect], Char)
+outOfRangeEffects :: [SGR] -> [SGR]
+outOfRangeEffects xs = SetConsoleIntensity BoldIntensity : xs
+
+sgr :: [SGR] -> Doc -> Doc
+sgr xs0 = go (P.reverse xs0) where
+ go [] = id
+ go (SetConsoleIntensity NormalIntensity : xs) = debold . go xs
+ go (SetConsoleIntensity BoldIntensity : xs) = bold . go xs
+ go (SetUnderlining NoUnderline : xs) = deunderline . go xs
+ go (SetUnderlining SingleUnderline : xs) = underline . go xs
+ go (SetColor f i c : xs) = case f of
+ Foreground -> case i of
+ Dull -> case c of
+ Black -> dullblack . go xs
+ Red -> dullred . go xs
+ Green -> dullgreen . go xs
+ Yellow -> dullyellow . go xs
+ Blue -> dullblue . go xs
+ Magenta -> dullmagenta . go xs
+ Cyan -> dullcyan . go xs
+ White -> dullwhite . go xs
+ Vivid -> case c of
+ Black -> black . go xs
+ Red -> red . go xs
+ Green -> green . go xs
+ Yellow -> yellow . go xs
+ Blue -> blue . go xs
+ Magenta -> magenta . go xs
+ Cyan -> cyan . go xs
+ White -> white . go xs
+ Background -> case i of
+ Dull -> case c of
+ Black -> ondullblack . go xs
+ Red -> ondullred . go xs
+ Green -> ondullgreen . go xs
+ Yellow -> ondullyellow . go xs
+ Blue -> ondullblue . go xs
+ Magenta -> ondullmagenta . go xs
+ Cyan -> ondullcyan . go xs
+ White -> ondullwhite . go xs
+ Vivid -> case c of
+ Black -> onblack . go xs
+ Red -> onred . go xs
+ Green -> ongreen . go xs
+ Yellow -> onyellow . go xs
+ Blue -> onblue . go xs
+ Magenta -> onmagenta . go xs
+ Cyan -> oncyan . go xs
+ White -> onwhite . go xs
+ go (_ : xs) = go xs
+
+type Lines = Array (Int,Int64) ([SGR], Char)
(///) :: Ix i => Array i e -> [(i, e)] -> Array i e
a /// xs = a // P.filter (inRange (bounds a) . fst) xs
@@ -96,7 +142,7 @@ grow y a
where old@((t,lo),(b,hi)) = bounds a
new = ((min t y,lo),(max b y,hi))
-draw :: [ScopedEffect] -> Int -> Int64 -> String -> Lines -> Lines
+draw :: [SGR] -> Int -> Int64 -> String -> Lines -> Lines
draw e y n xs a0
| P.null xs = a0
| otherwise = gt $ lt (a /// out)
@@ -119,30 +165,6 @@ data Rendering = Rendering
makeClassy ''Rendering
-{-
-instance Highlightable Rendering where
- addHighlights intervals (Rendering d ll lb l o) = Rendering d ll lb l' o where
- d' = rewind d
- l' = P.foldr (.) l [ recolor (eff tok) (column lo <$ guard (near d lo)) (column hi <$ guard (near d hi))
- | (Interval lo hi, tok) <- intersections d' (d' <> Columns ll lb) intervals ]
- eff t _ = highlightEffects t
-
--- | fill the interval from [n .. m) with a given effect
-recolor :: ([ScopedEffect] -> [ScopedEffect]) -> Maybe Int64 -> Maybe Int64 -> Lines -> Lines
-recolor f n0 m0 a0
- | m <= n = a0
- | otherwise = a /// P.map rc [n .. m - 1]
- where
- ((_,lo),(_,hi)) = bounds a
- n = maybe lo id n0
- m = maybe (hi + 1) id m0
- a = grow 0 a0
- rc i = (yi, (f e, c)) -- only if not isSpace?
- where
- yi = (0, i)
- (e,c) = a ! yi
--}
-
instance Show Rendering where
showsPrec d (Rendering p ll lb _ _) = showParen (d > 10) $
showString "Rendering " . showsPrec 11 p . showChar ' ' . showsPrec 11 ll . showChar ' ' . showsPrec 11 lb . showString " ... ..."
@@ -182,7 +204,7 @@ class Source t where
instance Source String where
source s
| P.elem '\n' s = ( ls, bs, draw [] 0 0 s')
- | otherwise = ( ls + fromIntegral (P.length end), bs, draw [soft (Foreground Blue), soft Bold] 0 ls end . draw [] 0 0 s')
+ | otherwise = ( ls + fromIntegral (P.length end), bs, draw [SetColor Foreground Vivid Blue, SetConsoleIntensity BoldIntensity] 0 ls end . draw [] 0 0 s')
where
end = "<EOF>"
s' = go 0 s
@@ -206,16 +228,13 @@ rendered del s = case source s of
f .# Rendering d ll lb s g = Rendering d ll lb 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 (fromIntegral (n - k)) where
+ pretty (Rendering d ll _ l f) = nesting $ \k -> columns $ \mn -> go (fromIntegral (fromMaybe 80 mn - k)) where
go cols = align (vsep (P.map ln [t..b])) where
(lo, hi) = window (column d) ll (min (max (cols - 2) 30) 200)
a = f d $ l $ array ((0,lo),(-1,hi)) []
((t,_),(b,_)) = bounds a
ln y = hcat
- $ P.map (\g -> P.foldr with (pretty (P.map snd g)) (fst (P.head g)))
+ $ P.map (\g -> sgr (fst (P.head g)) (pretty (P.map snd g)))
$ groupBy ((==) `on` fst)
[ a ! (y,i) | i <- [lo..hi] ]
@@ -270,8 +289,8 @@ instance HasCaret Caret where
instance Hashable Caret
-caretEffects :: [ScopedEffect]
-caretEffects = [soft (Foreground Green), soft Bold]
+caretEffects :: [SGR]
+caretEffects = [SetColor Foreground Vivid Green]
drawCaret :: Delta -> Delta -> Lines -> Lines
drawCaret p = ifNear p $ draw caretEffects 1 (fromIntegral (column p)) "^"
@@ -332,8 +351,8 @@ instance Reducer (Careted a) Rendering where
instance Hashable a => Hashable (Careted a)
-spanEffects :: [ScopedEffect]
-spanEffects = [soft (Foreground Green)]
+spanEffects :: [SGR]
+spanEffects = [SetColor Foreground Dull Green]
drawSpan :: Delta -> Delta -> Delta -> Lines -> Lines
drawSpan s e d a
@@ -407,7 +426,7 @@ instance Hashable a => Hashable (Spanned a)
-- > ^
-- > ,
drawFixit :: Delta -> Delta -> String -> Delta -> Lines -> Lines
-drawFixit s e rpl d a = ifNear l (draw [soft (Foreground Blue)] 2 (fromIntegral (column l)) rpl) d
+drawFixit s e rpl d a = ifNear l (draw [SetColor Foreground Dull Blue] 2 (fromIntegral (column l)) rpl) d
$ drawSpan s e d a
where l = argmin bytes s e
View
8 trifecta.cabal
@@ -38,11 +38,14 @@ library
Text.Trifecta.Util.Array
other-modules:
+ Text.Trifecta.Instances
Text.Trifecta.Util.Combinators
ghc-options: -Wall
build-depends:
+ ansi-wl-pprint >= 0.6.5 && < 0.7,
+ ansi-terminal >= 0.6 && < 0.7,
array >= 0.3.0.2 && < 0.5,
base >= 4.4 && < 5,
blaze-builder >= 0.3.0.1 && < 0.4,
@@ -62,12 +65,9 @@ library
parsers >= 0.5,
reducers >= 3,
semigroups >= 0.8.3.1,
- terminfo >= 0.3.2 && < 0.4,
transformers >= 0.2 && < 0.4,
unordered-containers >= 0.2.1 && < 0.3,
- utf8-string >= 0.3.6 && < 0.4,
- wl-pprint-extras >= 3.3,
- wl-pprint-terminfo >= 3.4
+ utf8-string >= 0.3.6 && < 0.4
test-suite doctests
type: exitcode-stdio-1.0
Please sign in to comment.
Something went wrong with that request. Please try again.