Permalink
Browse files

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

  • Loading branch information...
1 parent 8fffb98 commit 90a8ffbc74d72f6e5e86422d5316a4469319d918 @ekmett committed Jan 17, 2013
View
@@ -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
@@ -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
@@ -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
@@ -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
+ (<>) = (<>)
@@ -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,40 +230,36 @@ 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
empty = Failure mempty
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)
Oops, something went wrong.

0 comments on commit 90a8ffb

Please sign in to comment.