packages feed

trifecta 0.21 → 0.22

raw patch · 3 files changed

+67/−59 lines, 3 files

Files

Text/Trifecta/Diagnostic/Err/State.hs view
@@ -4,27 +4,24 @@  import Data.Functor.Plus import Data.Set as Set-import Data.Sequence as Seq import Data.Semigroup import Data.Monoid import Text.Trifecta.Diagnostic.Err-import Text.Trifecta.Diagnostic  data ErrState e = ErrState  { errExpected :: !(Set String)  , errMessage  :: !(Err e)- , errLog      :: !(Seq (Diagnostic e))  }  instance Functor ErrState where-  fmap f (ErrState a b c) = ErrState a (fmap f b) (fmap (fmap f) c)+  fmap f (ErrState a b) = ErrState a (fmap f b)  instance Alt ErrState where-  ErrState a b c <!> ErrState a' b' c' = ErrState (a <> a') (b <!> b') (c <!> c')+  ErrState a b <!> ErrState a' b' = ErrState (a <> a') (b <!> b')   {-# INLINE (<!>) #-}  instance Plus ErrState where-  zero = ErrState mempty zero zero+  zero = ErrState mempty zero   instance Semigroup (ErrState e) where   (<>) = (<!>)
Text/Trifecta/Parser/Prim.hs view
@@ -30,7 +30,6 @@ import Data.ByteString as Strict hiding (empty) import Data.Sequence as Seq hiding (empty) import Data.ByteString.UTF8 as UTF8-import Data.Bifunctor import Text.PrettyPrint.Free hiding (line) import Text.Trifecta.Rope.Delta import Text.Trifecta.Rope.Prim@@ -47,13 +46,15 @@ import Text.Trifecta.Parser.Result import System.Console.Terminfo.PrettyPrint +type ErrLog e = Seq (Diagnostic e) -- use a fingertree to sort them?+ data Parser e a = Parser    { unparser :: forall r.-    (a -> ErrState e -> Delta -> ByteString -> It Rope r) ->  -- uncommitted ok-    (ErrState e -> Delta -> ByteString -> It Rope r) ->       -- uncommitted err-    (a ->  ErrState e -> Delta -> ByteString -> It Rope r) -> -- committed ok-    (ErrState e -> Delta -> ByteString -> It Rope r) ->       -- committed err-    Delta -> ByteString -> It Rope r+    (a -> ErrState e -> ErrLog e -> Delta -> ByteString -> It Rope r) -> -- uncommitted ok+    (     ErrState e -> ErrLog e -> Delta -> ByteString -> It Rope r) -> -- uncommitted err+    (a -> ErrState e -> ErrLog e -> Delta -> ByteString -> It Rope r) -> -- committed ok+    (     ErrState e -> ErrLog e -> Delta -> ByteString -> It Rope r) -> -- committed err+                        ErrLog e -> Delta -> ByteString -> It Rope r   }   instance Functor (Parser e) where@@ -113,15 +114,24 @@   mzero = empty   mplus = (<|>)  + instance MonadWriter (Seq (Diagnostic e)) (Parser e) where-  tell w = Parser $ \eo _ _ _ -> eo () mempty { errLog = w }+  tell w = Parser $ \eo _ _ _ l -> eo () mempty (l <> w)   {-# INLINE tell #-}-  listen (Parser m) = Parser $ \eo ee co ce -> -    m (\ a e -> eo (a,errLog e) e) ee -      (\ a e -> co (a,errLog e) e) ce -  pass (Parser m) = Parser $ \eo ee co ce -> -    m (\(a,p) e -> eo a e { errLog = p $ errLog e }) ee-      (\(a,p) e -> co a e { errLog = p $ errLog e }) ce+  listen (Parser m) = Parser $ \eo ee co ce l -> +    m (\ a e' l' -> eo (a,l') e' (l <> l')) +      (\   e' l' -> ee        e' (l <> l'))+      (\ a e' l' -> co (a,l') e' (l <> l')) +      (\   e' l' -> ce        e' (l <> l'))+      mempty+  {-# INLINE listen #-}+  pass (Parser m) = Parser $ \eo ee co ce l -> +    m (\(a,p) e' l' -> eo a e' (l <> p l'))+      (\      e' l' -> ee   e' (l <> l'))+      (\(a,p) e' l' -> co a e' (l <> p l'))+      (\      e' l' -> ce   e' (l <> l'))+      mempty+  {-# INLINE pass #-}  logging :: DiagnosticLevel -> e -> Parser e () logging level e = do@@ -131,7 +141,7 @@  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+  fatal e = Parser $ \_ _ _ ce l d bs -> ce mempty { errMessage = FatalErr (Diagnostic (addCaret d $ rendering d bs) Fatal e []) } l d bs   err e = do     m <- mark     throwError $ RichErr $ \r -> Diagnostic (addCaret m r) Error e [] -- showing the actual location@@ -160,73 +170,74 @@                      else e)      (\e -> ee e { errExpected = msgs })   {-# INLINE labels #-}-  liftIt m = Parser $ \ eo _ _ _ d bs -> do +  liftIt m = Parser $ \ eo _ _ _ l d bs -> do       a <- m-     eo a mempty d bs+     eo a mempty l d bs   {-# INLINE liftIt #-}-  mark = Parser $ \eo _ _ _ d -> eo d mempty d+  mark = Parser $ \eo _ _ _ l d -> eo d mempty l d   {-# INLINE mark #-}-  release d' = Parser $ \_ ee co _ d bs -> do+  release d' = Parser $ \_ ee co _ l d bs -> do     mbs <- rewindIt d'     case mbs of-      Just bs' -> co () mempty d' bs'-      Nothing -> ee mempty d bs+      Just bs' -> co () mempty l d' bs'+      Nothing -> ee mempty l d bs   {-# INLINE release #-}-  line = Parser $ \eo _ _ _ d bs -> eo bs mempty d bs+  line = Parser $ \eo _ _ _ l d bs -> eo bs mempty l d bs   {-# INLINE line #-}-  satisfy f = Parser $ \ _ ee co _ d bs ->+  satisfy f = Parser $ \ _ ee co _ l d bs ->     case UTF8.uncons $ Strict.drop (columnByte d) bs of-      Nothing             -> ee mempty { errMessage = EndOfFileErr } d bs+      Nothing             -> ee mempty { errMessage = EndOfFileErr } l d bs       Just (c, xs) -        | not (f c)       -> ee mempty d bs+        | not (f c)       -> ee mempty l d bs         | Strict.null xs  -> let ddc = d <> delta c in-                             join $ fillIt (co c mempty ddc bs) (co c mempty) ddc-        | otherwise       -> co c mempty (d <> delta c) bs +                             join $ fillIt (co c mempty l ddc bs) (co c mempty l) ddc+        | otherwise       -> co c mempty l (d <> delta c) bs    {-# INLINE satisfy #-}-  satisfyAscii f = Parser $ \ _ ee co _ d bs ->+  satisfyAscii f = Parser $ \ _ ee co _ l d bs ->     let b = columnByte d in     if b >= 0 && b < Strict.length bs      then case toEnum $ fromEnum $ Strict.index bs b of-      c | not (f c)                 -> ee mempty d bs+      c | not (f c)                 -> ee mempty l d bs         | b == Strict.length bs - 1 -> let ddc = d <> delta c in -                                       join $ fillIt (co c mempty ddc bs) (co c mempty) ddc-        | otherwise                 -> co c mempty (d <> delta c) bs-    else ee mempty { errMessage = EndOfFileErr } d bs+                                       join $ fillIt (co c mempty l ddc bs) (co c mempty l) ddc+        | otherwise                 -> co c mempty l (d <> delta c) bs+    else ee mempty { errMessage = EndOfFileErr } l d bs   {-# INLINE satisfyAscii #-} -data St e a = JuSt a !(ErrState e) !Delta !ByteString-            | NoSt !(ErrState e) !Delta !ByteString--instance Bifunctor St where-  bimap f g (JuSt a e d bs) = JuSt (g a) (fmap f e) d bs-  bimap f _ (NoSt e d bs) = NoSt (fmap f e) d bs+data St e a = JuSt a !(ErrState e) !(ErrLog e) !Delta !ByteString+            | NoSt !(ErrState e) !(ErrLog e) !Delta !ByteString  stepParser :: (Diagnostic e -> Diagnostic t) ->                (ErrState e -> Delta -> ByteString -> Diagnostic t) ->-              Parser e a -> Delta -> ByteString -> Step t a-stepParser yl y (Parser p) d0 bs0 = -  go mempty $ p ju no ju no d0 bs0+              Parser e a -> ErrLog e -> Delta -> ByteString -> Step t a+stepParser yl y (Parser p) l0 d0 bs0 = +  go mempty $ p ju no ju no l0 d0 bs0   where-    ju a e d bs = Pure (JuSt a e d bs)-    no e d bs = Pure (NoSt e d bs)-    go r (Pure (JuSt a e _ _)) = StepDone r (yl <$> errLog e) a-    go r (Pure (NoSt e d bs))  = StepFail r (yl <$> errLog e) $ y e d bs+    ju a e l d bs = Pure (JuSt a e l d bs)+    no e l d bs = Pure (NoSt e l d bs)+    extendLog e l d bs +      | knownErr (errMessage e) = l |> y e d bs+      | otherwise = l+    go r (Pure (JuSt a e l d bs)) = StepDone r (extendLog e (yl <$> l) d bs) a+    go r (Pure (NoSt e l d bs))   = StepFail r (yl <$> l) $ y e d bs     go r (It ma k) = StepCont r (case ma of-                                   JuSt a e _ _ -> Success (yl <$> errLog e) a-                                   NoSt e d bs  -> Failure (yl <$> errLog e) (y e d bs)) +                                   JuSt a e l d bs -> Success (extendLog e (yl <$> l) d bs) a+                                   NoSt e l d bs   -> Failure (yl <$> l) $ y e d bs)                                  (go <*> k) ++-- explain an error in terms of the expected set, when we are running the step parser for pretty printing 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     expected doc = doc <> text ", expected" <+> fillSep (punctuate (char ',') $ text <$> toList ss) -parseTest :: Show a => Parser TermDoc a -> String -> IO ()-parseTest p s = case starve (feed st (UTF8.fromString s)) of+parseTest :: Show a => Parser String a -> String -> IO ()+parseTest p s = case starve $ feed st $ UTF8.fromString s of   Failure xs e -> displayLn $ prettyTerm $ toList (xs |> e)-  Success xs a -> do -    displayLn $ prettyTerm $ toList xs+  Success xs a -> do+    unless (Seq.null xs) $ displayLn $ prettyTerm $ toList xs     print a-  where st = stepParser id (why id) (release mempty *> p) mempty mempty+  where st = stepParser (fmap prettyTerm) (why prettyTerm) (release mempty *> p) mempty mempty mempty
trifecta.cabal view
@@ -1,6 +1,6 @@ name:          trifecta category:      Text, Parsing, Diagnostics, Pretty Printer, Logging-version:       0.21+version:       0.22 license:       BSD3 cabal-version: >= 1.6 license-file:  LICENSE