From 7a6518583f251a3e94276b6128515535a67e66ac Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Thu, 1 Feb 2024 11:57:37 -0700 Subject: [PATCH] debug tags --- src/Compiler/RLPC.hs | 111 +++++++++++++++++++++----------------- src/Compiler/RlpcError.hs | 8 +-- src/Core/Parse.y | 2 +- 3 files changed, 67 insertions(+), 54 deletions(-) diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index 90ee262..f7ed654 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -97,51 +97,6 @@ evalRLPCT opt r = runRLPCT r & flip runReaderT opt & runErrorfulT -evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a -evalRLPCIO opt r = do - (ma,es) <- evalRLPCT opt r - putRlpcErrs es - case ma of - Just x -> pure x - Nothing -> die "Failed, no code compiled." - -putRlpcErrs :: [MsgEnvelope RlpcError] -> IO () -putRlpcErrs = traverse_ (putStrLn . ('\n':) . prettyRlpcMsg) - -prettyRlpcMsg :: MsgEnvelope RlpcError -> String -prettyRlpcMsg m@(view msgSeverity -> SevDebug) = prettyRlpcDebugMsg m -prettyRlpcMsg m = render $ docRlpcErr m - -prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String -prettyRlpcDebugMsg (view msgDiagnostic -> Text ts) = - T.unpack . foldMap (`T.snoc` '\n') $ ts - -docRlpcErr :: MsgEnvelope RlpcError -> Doc -docRlpcErr msg = header - $$ nest 2 bullets - $$ source - where - source = vcat $ zipWith (<+>) rule srclines - where - rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|") - srclines = ["", "", ""] - filename = msgColour "" - pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine) - <> ":" - <> tshow (msg ^. msgSpan . srcspanColumn) - - header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": " - <> errorColour "error" <> msgColour ":" - - bullets = let Text ts = msg ^. msgDiagnostic - in vcat $ hang "•" 2 . ttext . msgColour <$> ts - - msgColour = Ansi.white . Ansi.bold - errorColour = Ansi.red . Ansi.bold - ttext = text . T.unpack - tshow :: (Show a) => a -> Text - tshow = T.pack . show - liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e) @@ -181,15 +136,15 @@ instance Default RLPCOptions where } -- debug flags are passed with -dFLAG -type DebugFlag = String +type DebugFlag = Text -type CompilerFlag = String +type CompilerFlag = Text makeLenses ''RLPCOptions pure [] -addDebugMsg :: (Monad m, IsText e) => e -> RLPCT m () -addDebugMsg e = addWound . debugMsg $ Text [e ^. unpacked . packed] +addDebugMsg :: (Monad m, IsText e) => Text -> e -> RLPCT m () +addDebugMsg tag e = addWound . debugMsg tag $ Text [e ^. unpacked . packed] -- TODO: rewrite this with prisms once microlens-pro drops :3 whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m () @@ -206,3 +161,61 @@ whenFFlag f m = do let a = S.member f fs when a m +-------------------------------------------------------------------------------- + +evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a +evalRLPCIO opt r = do + (ma,es) <- evalRLPCT opt r + putRlpcErrs opt es + case ma of + Just x -> pure x + Nothing -> die "Failed, no code compiled." + +putRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> IO () +putRlpcErrs opts = filter byTag + >>> traverse_ (putStrLn . ('\n':) . prettyRlpcMsg) + where + dflags = opts ^. rlpcDFlags + + byTag :: MsgEnvelope RlpcError -> Bool + byTag (view msgSeverity -> SevDebug t) = + t `S.member` dflags + +prettyRlpcMsg :: MsgEnvelope RlpcError -> String +prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m +prettyRlpcMsg m = render $ docRlpcErr m + +prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String +prettyRlpcDebugMsg msg = + T.unpack . foldMap mkLine $ ts + where + mkLine s = tag <> ": " <> s <> "\n" + Text ts = msg ^. msgDiagnostic + SevDebug tag = msg ^. msgSeverity + +docRlpcErr :: MsgEnvelope RlpcError -> Doc +docRlpcErr msg = header + $$ nest 2 bullets + $$ source + where + source = vcat $ zipWith (<+>) rule srclines + where + rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|") + srclines = ["", "", ""] + filename = msgColour "" + pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine) + <> ":" + <> tshow (msg ^. msgSpan . srcspanColumn) + + header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": " + <> errorColour "error" <> msgColour ":" + + bullets = let Text ts = msg ^. msgDiagnostic + in vcat $ hang "•" 2 . ttext . msgColour <$> ts + + msgColour = Ansi.white . Ansi.bold + errorColour = Ansi.red . Ansi.bold + ttext = text . T.unpack + tshow :: (Show a) => a -> Text + tshow = T.pack . show + diff --git a/src/Compiler/RlpcError.hs b/src/Compiler/RlpcError.hs index f44b1ca..a590a85 100644 --- a/src/Compiler/RlpcError.hs +++ b/src/Compiler/RlpcError.hs @@ -47,7 +47,7 @@ instance IsRlpcError RlpcError where data Severity = SevWarning | SevError - | SevDebug + | SevDebug Text deriving Show makeLenses ''MsgEnvelope @@ -67,11 +67,11 @@ errorMsg s e = MsgEnvelope , _msgSeverity = SevError } -debugMsg :: e -> MsgEnvelope e -debugMsg e = MsgEnvelope +debugMsg :: Text -> e -> MsgEnvelope e +debugMsg tag e = MsgEnvelope -- TODO: not pretty, but it is a debug message after all { _msgSpan = SrcSpan 0 0 0 0 , _msgDiagnostic = e - , _msgSeverity = SevDebug + , _msgSeverity = SevDebug tag } diff --git a/src/Core/Parse.y b/src/Core/Parse.y index d89f60f..20ee3eb 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -234,7 +234,7 @@ parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg) ddumpast :: Program' -> RLPCT m Program' ddumpast p = do - whenDFlag "dump-ast" $ (addDebugMsg . show $ p) + addDebugMsg "dump-ast" . show $ p pure p happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b