-ddump-ast

src/Compiler/RLPC.hs

@@ -11,7 +11,7 @@ errors and the family of RLPC monads.
 -- only used for mtl instances
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
-{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE BlockArguments, ViewPatterns #-}
 module Compiler.RLPC
     (
     -- * Rlpc Monad transformer
@@ -31,6 +31,7 @@ module Compiler.RLPC
     -- * Misc. Rlpc Monad -related types
     , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
     , MsgEnvelope(..), Severity(..)
+    , addDebugMsg
     , whenDFlag, whenFFlag
     -- * Convenient re-exports
     , addFatal, addWound, def
@@ -60,13 +61,15 @@ import Data.Text                qualified as T
 import Text.ANSI                qualified as Ansi
 import Text.PrettyPrint         hiding ((<>))
 import Lens.Micro.Platform
+import Lens.Micro.Platform.Internal
 import System.Exit
 ----------------------------------------------------------------------------------
 
 newtype RLPCT m a = RLPCT {
         runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
     }
-    deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
+    deriving ( Functor, Applicative, Monad
+             , MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError))
 
 rlpc :: (IsRlpcError e, Monad m)
      => (RLPCOptions -> (Maybe a, [MsgEnvelope e]))
@@ -103,10 +106,18 @@ evalRLPCIO opt r = do
         Nothing -> die "Failed, no code compiled."
 
 putRlpcErrs :: [MsgEnvelope RlpcError] -> IO ()
-putRlpcErrs = traverse_ (putStrLn . ('\n':) . render . prettyRlpcErr)
+putRlpcErrs = traverse_ (putStrLn . ('\n':) . prettyRlpcMsg)
 
-prettyRlpcErr :: MsgEnvelope RlpcError -> Doc
-prettyRlpcErr msg = header
+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
@@ -177,6 +188,9 @@ type CompilerFlag = String
 makeLenses ''RLPCOptions
 pure []
 
+addDebugMsg :: (Monad m, IsText e) => e -> RLPCT m ()
+addDebugMsg e = addWound . debugMsg $ Text [e ^. unpacked . packed]
+
 -- TODO: rewrite this with prisms once microlens-pro drops :3
 whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m ()
 whenDFlag f m = do

src/Compiler/RlpcError.hs

@@ -10,6 +10,7 @@ module Compiler.RlpcError
     , msgSeverity
     , liftRlpcErrors
     , errorMsg
+    , debugMsg
     -- * Located Comonad
     , Located(..)
     , SrcSpan(..)
@@ -46,6 +47,7 @@ instance IsRlpcError RlpcError where
 
 data Severity = SevWarning
               | SevError
+              | SevDebug
               deriving Show
 
 makeLenses ''MsgEnvelope
@@ -65,3 +67,11 @@ errorMsg s e = MsgEnvelope
     , _msgSeverity = SevError
     }
 
+debugMsg :: e -> MsgEnvelope e
+debugMsg e = MsgEnvelope
+    -- TODO: not pretty, but it is a debug message after all
+    { _msgSpan = SrcSpan 0 0 0 0
+    , _msgDiagnostic = e
+    , _msgSeverity = SevDebug
+    }
+

src/Control/Monad/Errorful.hs

@@ -13,6 +13,7 @@ module Control.Monad.Errorful
     where
 ----------------------------------------------------------------------------------
 import Control.Monad.State.Strict
+import Control.Monad.Reader
 import Control.Monad.Trans
 import Data.Functor.Identity
 import Data.Coerce
@@ -76,7 +77,7 @@ mapErrorful f (ErrorfulT m) = ErrorfulT $
 --------------------------------------------------------------------------------
 -- daily dose of n^2 instances
 
-instance (Monad m, MonadErrorful e m) => MonadErrorful e (StateT s m) where
-    addWound = undefined
-    addFatal = undefined
+instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where
+    addWound = lift . addWound
+    addFatal = lift . addFatal
 

src/Core/Parse.y

@@ -21,6 +21,7 @@ import Data.Functor.Identity
 import Core.Syntax
 import Core.Lex
 import Compiler.RLPC
+import Control.Monad
 import Lens.Micro
 import Data.Default.Class   (def)
 import Data.Hashable        (Hashable)
@@ -225,12 +226,17 @@ insScDef sc = programScDefs %~ (sc:)
 singletonScDef :: (Hashable b) => ScDef b -> Program b
 singletonScDef sc = insScDef sc mempty
 
-parseCoreProgR :: forall m. (Applicative m) => [Located CoreToken] -> RLPCT m Program'
-parseCoreProgR = hoistRlpcT generalise . parseCoreProg
+parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m Program'
+parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg)
     where
         generalise :: forall a. Identity a -> m a
         generalise (Identity a) = pure a
 
+        ddumpast :: Program' -> RLPCT m Program'
+        ddumpast p = do
+            whenDFlag "dump-ast" $ (addDebugMsg . show $ p)
+            pure p
+
 happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
 happyBind m k = m >>= k