[ohua-dev/ohuac#12] Added more stages (no all of which useful)

Also added the missing `Pretty` instance for DFExpr

src/Ohua/Compile.hs

@@ -23,6 +23,7 @@ import Ohua.ALang.Passes.SSA
 import Ohua.DFGraph
 import Ohua.DFLang.Lang
 import Ohua.DFLang.Optimizations
+import Ohua.DFLang.PPrint ()
 import Ohua.DFLang.Passes
 import qualified Ohua.DFLang.Verify
 import Ohua.Stage
@@ -46,38 +47,40 @@ forceLog msg a = a `deepseq` logDebugN msg
 
 -- | The canonical order of transformations and lowerings performed in a full compilation.
 pipeline :: CustomPasses env -> Expression -> OhuaM env OutGraph
-pipeline CustomPasses{..} e = do
+pipeline CustomPasses {..} e = do
     stage resolvedAlang e
+
     ssaE <- performSSA e
     stage ssaAlang ssaE
+
     normalizedE <- normalize ssaE
     stage normalizedAlang normalizedE
 
     whenDebug $ do
-      checkProgramValidity normalizedE
-      checkHigherOrderFunctionSupport normalizedE
-      Ohua.ALang.Passes.SSA.checkSSA normalizedE
+        checkProgramValidity normalizedE
+        checkHigherOrderFunctionSupport normalizedE
+        Ohua.ALang.Passes.SSA.checkSSA normalizedE
 
-    customAfterNorm <- normalize =<< passAfterNormalize normalizedE
+    customAfterNorm <- passAfterNormalize normalizedE
+    stage customAlangPasses customAfterNorm
 
-    optimizedE <- Ohua.ALang.Optimizations.runOptimizations customAfterNorm
+    optimizedE <-
+        Ohua.ALang.Optimizations.runOptimizations =<< normalize customAfterNorm
+    stage optimizedAlang optimizedE
 
     whenDebug $ Ohua.ALang.Passes.SSA.checkSSA optimizedE
-
-    dfE <- lowerALang optimizedE
+    dfE <- lowerALang =<< normalize optimizedE
+    stage initialDflang dfE
 
     Ohua.DFLang.Verify.verify dfE
-
-    whenDebug $
-      Ohua.DFLang.Passes.checkSSAExpr dfE
-
+    whenDebug $ Ohua.DFLang.Passes.checkSSAExpr dfE
     dfAfterCustom <- passAfterDFLowering dfE
+    stage customDflang dfAfterCustom
 
     optimizedDfE <- Ohua.DFLang.Optimizations.runOptimizations dfAfterCustom
+    stage optimizedDflang optimizedE
 
-    whenDebug $
-      Ohua.DFLang.Passes.checkSSAExpr optimizedDfE
-
+    whenDebug $ Ohua.DFLang.Passes.checkSSAExpr optimizedDfE
     pure $ toGraph optimizedDfE
 
 

src/Ohua/DFLang/PPrint.hs

@@ -12,6 +12,9 @@ prettyDFExpr :: DFExpr -> Doc a
 prettyDFExpr DFExpr {..} =
     vsep $ map prettyLetExpr (toList letExprs) <> [pretty returnVar]
 
+instance Pretty DFExpr where
+    pretty = prettyDFExpr
+
 prettyLetExpr :: LetExpr -> Doc a
 prettyLetExpr LetExpr {..} =
     hsep

src/Ohua/Monad.hs

@@ -32,6 +32,7 @@ import Data.ByteString (hPutStr)
 
 import Ohua.Internal.Monad
 import Ohua.Types
+import Ohua.Util
 
 runSilentLoggingT :: LoggingT m a -> m a
 runSilentLoggingT = flip runLoggingT $ \_ _ _ _ -> pure ()

src/Ohua/Stage.hs

@@ -29,5 +29,29 @@ ssaAlang = "alang-ssa"
 normalizedAlang :: StageName
 normalizedAlang = "alang-normalized"
 
+customAlangPasses :: StageName
+customAlangPasses = "alang-custom"
+
+optimizedAlang :: StageName
+optimizedAlang = "alang-optimized"
+
+initialDflang :: StageName
+initialDflang = "dflang-initial"
+
+customDflang :: StageName
+customDflang = "dflang-custom"
+
+optimizedDflang :: StageName
+optimizedDflang = "dflang-optimized"
+
 knownStages :: [StageName]
-knownStages = [resolvedAlang, ssaAlang, normalizedAlang]
+knownStages =
+    [ resolvedAlang
+    , ssaAlang
+    , normalizedAlang
+    , customAlangPasses
+    , optimizedAlang
+    , initialDflang
+    , customDflang
+    , optimizedDflang
+    ]

src/Ohua/Types.hs

@@ -77,7 +77,7 @@ module Ohua.Types
 import Universum
 
 import Control.Comonad
-import Control.Monad.Error.Class (MonadError, throwError)
+import Control.Monad.Error.Class (MonadError)
 import Data.Bifoldable
 import Data.Bitraversable
 import Data.Default.Class

src/Ohua/Util.hs

@@ -199,4 +199,4 @@ throwErrorS msg = throwError $ msg <> "\n" <> fromString cs
     cs = callStackToStr callStack
 
 throwErrorDebugS :: (HasCallStack, MonadError s m, IsString s, SemigroupConstraint s) => s -> m a
-throwErrorDebugS = whenDebug throwErrorS throwError
+throwErrorDebugS = throwErrorS `debugOr` throwError