looksee 0.5.3 → 0.6.0

raw patch · 3 files changed

+78/−47 lines, 3 filesdep ~tastydep ~tasty-hunitPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: tasty, tasty-hunit

API changes (from Hackage documentation)

Files

• looksee.cabal +4/−4
• src/Looksee.hs +73/−42
• test/Main.hs +1/−1

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           looksee-version:        0.5.3+version:        0.6.0 synopsis:       A simple text parser with decent errors description:    Please see the README on GitHub at <https://github.com/ejconlon/looksee#readme> category:       Parsing@@ -17,7 +17,7 @@ license:        BSD3 build-type:     Simple tested-with:-    GHC == 9.6.3+    GHC == 9.6.4 extra-source-files:     README.md @@ -119,8 +119,8 @@     , mtl >=2.2 && <2.4     , recursion-schemes ==5.2.*     , scientific ==0.3.*-    , tasty-    , tasty-hunit+    , tasty >=1.4.3 && <1.5+    , tasty-hunit ==0.10.*     , text >=1.2 && <2.1     , vector >=0.12 && <0.14   default-language: GHC2021

@@ -27,6 +27,7 @@   , throwP   , altP   , emptyP+  , explainP   , endP   , optP   , lookP@@ -227,6 +228,10 @@ data InfixPhase = InfixPhaseLeft | InfixPhaseRight | InfixPhaseCont   deriving stock (Eq, Ord, Show, Enum, Bounded) +-- | Whether to hide an underlying error or not+data HideError = HideErrorNo | HideErrorYes+  deriving stock (Eq, Ord, Show, Enum, Bounded)+ -- | Reason for parse failure data Reason e r   = ReasonCustom !e@@ -240,6 +245,7 @@   | ReasonLook r   | ReasonTakeNone   | ReasonEmpty+  | ReasonExplained !Text !HideError r   deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)  deriveBifunctor ''Reason@@ -485,6 +491,22 @@ emptyP :: (Monad m) => ParserT e m a emptyP = ParserT (\j -> mkErrT ReasonEmpty >>= j . Left) +-- | If things fail and you can give a good message explaining why, this combinator will+-- annotate the error with your explanation. Returning 'True' with message will hide+-- the original error message in textual rendering.+explainP :: (Monad m) => (Reason e (Err e) -> Maybe (Text, Bool)) -> ParserT e m a -> ParserT e m a+explainP f (ParserT g) = ParserT $ \j -> g $ \ea ->+  case ea of+    Left e@(Err (ErrF _ re)) ->+      case f re of+        Nothing -> j ea+        Just (msg, hide) -> do+          sp <- gets stSpan+          let hide' = if hide then HideErrorYes else HideErrorNo+          let e' = Err (ErrF sp (ReasonExplained msg hide' e))+          j (Left e')+    Right _ -> j ea+ -- | Lookahead - rewinds state if the parser succeeds, otherwise throws error lookP :: (Monad m) => ParserT e m a -> ParserT e m a lookP (ParserT g) = ParserT $ \j -> do@@ -1024,62 +1046,71 @@ stripEnd1P :: (Monad m) => ParserT e m a -> ParserT e m a stripEnd1P p = p <* space1P --- | Implement this to format custom errors. The list will be joined with `unlines`.+-- | Implement this to format custom errors. The list will be indented and joined with `unlines`. class HasErrMessage e where-  getErrMessage :: e -> [Text]+  getErrMessage :: (Int -> Text) -> e -> [Text]  instance HasErrMessage Void where-  getErrMessage = absurd+  getErrMessage = const absurd  -- private indent :: Int -> [Text] -> [Text] indent i = let s = T.replicate (2 * i) " " in fmap (s <>)  instance (HasErrMessage e) => HasErrMessage (Err e) where-  getErrMessage (Err (ErrF (Span start end) re)) =-    let pos = "Error in range: (" <> T.pack (show start) <> ", " <> T.pack (show end) <> ")"-        body = case re of-          ReasonCustom e ->-            let hd = "Custom error:"-                tl = indent 1 (getErrMessage e)-            in  hd : tl-          ReasonExpect expected actual ->-            ["Expected text: '" <> expected <> "' but found: '" <> actual <> "'"]-          ReasonDemand expected actual ->-            ["Expected count: " <> T.pack (show expected) <> " but got: " <> T.pack (show actual)]-          ReasonLeftover count ->-            ["Expected end but had leftover count: " <> T.pack (show count)]-          ReasonAlt errs ->-            let hd = "Alternatives:"-                tl = indent 1 $ do-                  (_, e) <- toList errs-                  "Tried:" : indent 1 (getErrMessage e)-            in  hd : tl-          ReasonInfix errs ->-            let hd = "Infix/split failed:"-                tl = indent 1 $ do-                  (i, _, e) <- toList errs-                  let x = "Tried position: " <> T.pack (show i)-                  x : indent 1 (getErrMessage e)-            in  hd : tl-          ReasonFail msg -> ["User reported failure: " <> msg]-          ReasonLabeled lab e ->-            let hd = "Labeled parser: " <> unLabel lab-                tl = indent 1 (getErrMessage e)-            in  hd : tl-          ReasonLook e ->-            let hd = "Error in lookahead:"-                tl = indent 1 (getErrMessage e)-            in  hd : tl-          ReasonTakeNone -> ["Took/dropped no elements"]-          ReasonEmpty -> ["No parse results"]-    in  pos : body+  getErrMessage repPos = go+   where+    go (Err (ErrF (Span start end) re)) =+      let pos = "Error in range " <> repPos start <> "-" <> repPos end <> ":"+          body = case re of+            ReasonCustom e ->+              let hd = "Custom error:"+                  tl = indent 1 (getErrMessage repPos e)+              in  hd : tl+            ReasonExpect expected actual ->+              ["Expected text: '" <> expected <> "' but found: '" <> actual <> "'"]+            ReasonDemand expected actual ->+              ["Expected count: " <> T.pack (show expected) <> " but got: " <> T.pack (show actual)]+            ReasonLeftover count ->+              ["Expected end but had leftover count: " <> T.pack (show count)]+            ReasonAlt errs ->+              let hd = "Alternatives:"+                  tl = indent 1 $ do+                    (_, e) <- toList errs+                    "Tried:" : indent 1 (go e)+              in  hd : tl+            ReasonInfix errs ->+              let hd = "Infix/split failed:"+                  tl = indent 1 $ do+                    (i, _, e) <- toList errs+                    let x = "Tried position: " <> T.pack (show i)+                    x : indent 1 (go e)+              in  hd : tl+            ReasonFail msg -> ["User reported failure: " <> msg]+            ReasonLabeled lab e ->+              let hd = "Label: " <> unLabel lab+                  tl = indent 1 (go e)+              in  hd : tl+            ReasonLook e ->+              let hd = "Error in lookahead:"+                  tl = indent 1 (go e)+              in  hd : tl+            ReasonTakeNone -> ["Took/dropped no elements"]+            ReasonEmpty -> ["No parse results"]+            ReasonExplained msg hide e ->+              case hide of+                HideErrorNo ->+                  let tl = indent 1 (go e)+                  in  msg : tl+                HideErrorYes -> [msg]+      in  pos : body  -- | Create 'Errata' formatting a parse error errataE :: (HasErrMessage e) => FilePath -> (Int -> (E.Line, E.Column)) -> Err e -> [E.Errata] errataE fp mkP e =   let (line, col) = mkP (spanStart (errSpan e))-      msg = getErrMessage e+      repP i = let (l, c) = mkP i in "(" <> T.pack (show l) <> ", " <> T.pack (show c) <> ")"+      msg = getErrMessage repP e       block = E.blockSimple E.basicStyle E.basicPointer fp Nothing (line, col, col + 1, Nothing) (Just (T.unlines msg))   in  [E.Errata Nothing [block] Nothing] 

@@ -791,7 +791,7 @@ main =   defaultMain $     testGroup-      "Looksee"+      "looksee"       [ testBasic       , testSpan       , testSplitBind