trifecta 0.20 → 0.21
raw patch · 7 files changed
+55/−24 lines, 7 files
Files
- Text/Trifecta/Diagnostic/Class.hs +1/−1
- Text/Trifecta/Diagnostic/Err.hs +16/−5
- Text/Trifecta/Diagnostic/Prim.hs +2/−2
- Text/Trifecta/Parser/Prim.hs +23/−8
- Text/Trifecta/Parser/Result.hs +7/−3
- Text/Trifecta/Rope/Delta.hs +5/−4
- trifecta.cabal +1/−1
Text/Trifecta/Diagnostic/Class.hs view
@@ -9,7 +9,7 @@ import Text.Trifecta.Diagnostic.Prim class Monad m => MonadDiagnostic e m | m -> e where- record :: Diagnostic e -> m a+ record :: Diagnostic e -> m () fatal :: e -> m a -- consuming error err :: e -> m a -- non-consuming error warn :: e -> m ()
Text/Trifecta/Diagnostic/Err.hs view
@@ -2,6 +2,7 @@ ( Err(..) , diagnose , knownErr+ , fatalErr ) where import Control.Applicative@@ -18,17 +19,19 @@ -- | unlocated error messages data Err e = EmptyErr- | FailErr String | UnexpectedErr String | EndOfFileErr- | RichErr (Rendering -> Diagnostic e)+ | FailErr String + | RichErr (Rendering -> Diagnostic e) -- relocates with us as we try+ | FatalErr (Diagnostic e) -instance Show (Err e) where+instance Show e => 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 d (FatalErr e) = showParen (d > 10) $ showString "FatalErr " . showsPrec 11 e showsPrec _ EndOfFileErr = showString "EndOfFileErr" showsPrec d (RichErr _) = showParen (d > 10) $ showString "RichErr ..."@@ -37,11 +40,16 @@ knownErr EmptyErr = False knownErr _ = True +fatalErr :: Err e -> Bool+fatalErr FatalErr{} = True+fatalErr _ = False+ 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 _ (FatalErr e) = fmap k e diagnose k r (RichErr f) = fmap k (f r) diagnose0 :: Pretty t => Err t -> Diagnostic (Doc e)@@ -62,12 +70,15 @@ fmap _ EmptyErr = EmptyErr fmap _ (FailErr s) = FailErr s fmap _ EndOfFileErr = EndOfFileErr+ fmap f (FatalErr e) = FatalErr (fmap f e) fmap _ (UnexpectedErr s) = UnexpectedErr s fmap f (RichErr k) = RichErr (fmap f . k) instance Alt Err where- EmptyErr <!> a = a- a <!> _ = a+ EmptyErr <!> a = a+ e@FatalErr{} <!> _ = e+ _ <!> e@FatalErr{} = e+ a <!> _ = a {-# INLINE (<!>) #-} instance Plus Err where
Text/Trifecta/Diagnostic/Prim.hs view
@@ -51,14 +51,14 @@ [ 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+ prettyList = vsep . Prelude.map pretty 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+ prettyTermList = vsep . Prelude.map prettyTerm instance Functor Diagnostic where fmap f (Diagnostic r l m xs) = Diagnostic r l (f m) $ map (fmap f) xs
Text/Trifecta/Parser/Prim.hs view
@@ -31,10 +31,12 @@ import Data.Sequence as Seq hiding (empty) import Data.ByteString.UTF8 as UTF8 import Data.Bifunctor-import Text.PrettyPrint.Free+import Text.PrettyPrint.Free hiding (line) import Text.Trifecta.Rope.Delta import Text.Trifecta.Rope.Prim+import Text.Trifecta.Diagnostic.Class import Text.Trifecta.Diagnostic.Prim+import Text.Trifecta.Diagnostic.Level import Text.Trifecta.Diagnostic.Err import Text.Trifecta.Diagnostic.Err.State import Text.Trifecta.Diagnostic.Rendering.Prim@@ -84,10 +86,7 @@ {-# INLINE empty #-} -- Parser m <|> Parser n = Parser $ \ eo ee co ce -> m eo (n eo ee co ce) co ce Parser m <|> Parser n = Parser $ \ eo ee co ce -> - m eo (\e -> n (\a e'-> eo a (e <> e')) - (\e' -> ee (e <> e')) - co - ce) + m eo (\e -> n (\a e'-> eo a (e <> e')) (\e' -> ee (e <> e')) co ce) co ce {-# INLINE (<|>) #-} instance Semigroup (Parser e a) where@@ -124,6 +123,22 @@ m (\(a,p) e -> eo a e { errLog = p $ errLog e }) ee (\(a,p) e -> co a e { errLog = p $ errLog e }) ce +logging :: DiagnosticLevel -> e -> Parser e ()+logging level e = do+ m <- mark+ l <- line+ tell $ return $ Diagnostic (addCaret m $ rendering m l) level e []++instance MonadDiagnostic e (Parser e) where+ record = tell . return+ fatal e = Parser $ \_ _ _ ce d bs -> ce mempty { errMessage = FatalErr (Diagnostic (addCaret d $ rendering d bs) Fatal e []) } d bs+ err e = do+ m <- mark+ throwError $ RichErr $ \r -> Diagnostic (addCaret m r) Error e [] -- showing the actual location+ warn = logging Warning+ note = logging Note+ verbose = logging . Verbose+ instance MonadError (Err e) (Parser e) where throwError m = Parser $ \_ ee _ _ -> ee mempty { errMessage = m } {-# INLINE throwError #-}@@ -134,7 +149,8 @@ instance MonadParser (Parser e) where -- commit (Parser m) = Parser $ \ _ _ co ce -> m co ce co ce- try (Parser m) = Parser $ \ eo ee co _ -> m eo ee co ee+ try (Parser m) = Parser $ \ eo ee co ce -> m eo ee co $ + \e -> if fatalErr (errMessage e) then ce e else ee e {-# INLINE try #-} unexpected s = Parser $ \ _ ee _ _ -> ee mempty { errMessage = UnexpectedErr s } @@ -201,11 +217,10 @@ (go <*> k) why :: Pretty e => (e -> Doc t) -> ErrState e -> Delta -> ByteString -> Diagnostic (Doc t)-why pp (ErrState ss _m _) d bs +why pp (ErrState ss m _) d bs | 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) parseTest :: Show a => Parser TermDoc a -> String -> IO ()
Text/Trifecta/Parser/Result.hs view
@@ -10,7 +10,7 @@ import Data.Functor.Plus import Data.Traversable import Data.Bifunctor-import Data.Sequence+import Data.Sequence as Seq import Text.Trifecta.Diagnostic.Prim import Text.PrettyPrint.Free import System.Console.Terminfo.PrettyPrint@@ -21,11 +21,15 @@ deriving Show instance (Pretty e, Show a) => Pretty (Result e a) where- pretty (Success xs a) = prettyList (toList xs) `above` string (show a)+ pretty (Success xs a) + | Seq.null xs = string (show a)+ | otherwise = prettyList (toList xs) `above` string (show a) pretty (Failure xs e) = prettyList $ toList $ xs |> e instance (PrettyTerm e, Show a) => PrettyTerm (Result e a) where- prettyTerm (Success xs a) = prettyTermList (toList xs) `above` string (show a)+ prettyTerm (Success xs a)+ | Seq.null xs = string (show a)+ | otherwise = prettyTermList (toList xs) `above` string (show a) prettyTerm (Failure xs e) = prettyTermList $ toList $ xs |> e instance Functor (Result e) where
Text/Trifecta/Rope/Delta.hs view
@@ -53,16 +53,17 @@ 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+ Columns c _ -> k f 1 c+ Tab x y _ -> k f 1 (nextTab x + y)+ Lines l c _ _ -> k f l c+ Directed (Path _ _ _ fn _ _) l c _ _ -> k (maybeFileName f 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))+ f = "(interactive)" column :: HasDelta t => t -> Int column t = case delta t of
trifecta.cabal view
@@ -1,6 +1,6 @@ name: trifecta category: Text, Parsing, Diagnostics, Pretty Printer, Logging-version: 0.20+version: 0.21 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE