Build pipeline tidy

wasm-calc11/src/Calc/Build.hs

@@ -11,27 +11,22 @@ module Calc.Build
   )
 where
 
-import Calc.Ability.Check
-import Calc.Dependencies
-import qualified Calc.Linearity as Linearity
-import Calc.Module (resolveModule)
-import Calc.Parser
-import Calc.Parser.Types
-import Calc.PrettyPrint (formatAndSave)
+import Calc.Build.Format (formatAndSave)
+import Calc.Build.Steps
 import Calc.Test
-import Calc.Typecheck
-import Calc.Wasm.FromExpr.Module
+import Calc.Types.Annotation
+import Calc.Types.Module
 import Calc.Wasm.ToWasm.Module
 import Calc.Wasm.WriteModule
+import Control.Monad (unless)
+import Control.Monad.Except
 import Control.Monad.IO.Class
-import Data.Foldable (traverse_)
-import Data.Monoid
-import Data.Text (Text)
+import Data.Functor (($>))
 import qualified Data.Text as T
+import qualified Data.Text.IO as T
 import qualified Error.Diagnose as Diag
-import Error.Diagnose.Compat.Megaparsec
+import qualified Language.Wasm.Structure as Wasm
 import System.Exit
-import System.IO (hPutStrLn)
 
 build :: FilePath -> IO ()
 build filePath =
@@ -40,73 +35,50 @@ build filePath =
 doBuild :: (MonadIO m) => FilePath -> m ExitCode
 doBuild filePath = do
   input <- liftIO (readFile filePath)
-  case parseModule (T.pack input) of
-    Left bundle ->
-      do
-        printDiagnostic (fromErrorBundle bundle input)
-        >> pure (ExitFailure 1)
-    Right parsedModuleItems ->
-      case resolveModule parsedModuleItems of
-        Left err ->
-          liftIO (print err)
-            >> pure (ExitFailure 1)
-        Right parsedModule -> case elaborateModule parsedModule of
-          Left typeErr -> do
-            printDiagnostic (typeErrorDiagnostic (T.pack input) typeErr)
-              >> pure (ExitFailure 1)
-          Right typedMod ->
-            case Linearity.validateModule typedMod of
-              Left linearityError -> do
-                printDiagnostic (Linearity.linearityErrorDiagnostic (T.pack input) linearityError)
-                  >> pure (ExitFailure 1)
-              Right _ -> do
-                case abilityCheckModule parsedModule of
-                  Left abilityError ->
-                    printDiagnostic (abilityErrorDiagnostic (T.pack input) abilityError)
-                      >> pure (ExitFailure 1)
-                  Right _ -> do
-                    testResults <- liftIO $ testModule typedMod
-                    if not (testsAllPass testResults)
-                      then do
-                        printTestResults testResults
-                        pure (ExitFailure 1)
-                      else case fromModule (treeShakeModule typedMod) of
-                        Left fromWasmError -> do
-                          liftIO (print fromWasmError)
-                            >> pure (ExitFailure 1)
-                        Right wasmMod -> do
-                          formatAndSave filePath (T.pack input) parsedModuleItems
-                          -- print module to stdout
-                          liftIO $ printModule (moduleToWasm wasmMod)
-                          pure ExitSuccess
-
-testsAllPass :: [(a, Bool)] -> Bool
-testsAllPass = getAll . foldMap (All . snd)
-
-printTestResults :: (MonadIO m) => [(T.Text, Bool)] -> m ()
-printTestResults =
-  traverse_ printResult
-  where
-    printResult (name, True) =
-      liftIO $ hPutStrLn Diag.stderr $ "✅ " <> show name
-    printResult (name, False) =
-      liftIO $ hPutStrLn Diag.stderr $ "❌ " <> show name
-
-printDiagnostic :: (MonadIO m) => Diag.Diagnostic Text -> m ()
-printDiagnostic =
+
+  result <- runExceptT (buildSteps (T.pack input))
+
+  case result of
+    Left buildError ->
+      printBuildError buildError $> ExitFailure 1
+    Right (parsedModuleItems, wasmModule) -> do
+      formatAndSave filePath (T.pack input) parsedModuleItems
+      -- print module to stdout
+      liftIO $ printModule wasmModule
+      -- hooray
+      pure ExitSuccess
+
+buildSteps ::
+  (MonadIO m, MonadError BuildError m) =>
+  T.Text ->
+  m ([ModuleItem Annotation], Wasm.Module)
+buildSteps input = do
+  parsedModuleItems <- liftEither (parseModuleStep input)
+
+  parsedModule <- liftEither (resolveModuleStep parsedModuleItems)
+
+  typedModule <- liftEither (typecheckModuleStep input parsedModule)
+
+  liftEither (linearityCheckStep input typedModule)
+
+  _ <- liftEither (abilityCheckStep input parsedModule)
+
+  testResults <- liftIO (testModule typedModule)
+
+  unless (testsAllPass testResults) $
+    throwError (BuildMessage (T.intercalate "\n" (displayResults testResults)))
+
+  wasmMod <- liftEither (fromExprStep typedModule)
+
+  pure (parsedModuleItems, moduleToWasm wasmMod)
+
+printBuildError :: (MonadIO m) => BuildError -> m ()
+printBuildError (BuildDiagnostic diag) =
   Diag.printDiagnostic
     Diag.stderr
     Diag.WithUnicode
     (Diag.TabSize 4)
     Diag.defaultStyle
-
--- | turn Megaparsec error + input into a Diagnostic
-fromErrorBundle :: ParseErrorType -> String -> Diag.Diagnostic Text
-fromErrorBundle bundle input =
-  let diag =
-        errorDiagnosticFromBundle
-          Nothing
-          "Parse error on input"
-          Nothing
-          bundle
-   in Diag.addFile diag replFilename input
+    diag
+printBuildError (BuildMessage msg) =
+  liftIO (T.hPutStrLn Diag.stderr msg)

wasm-calc11/src/Calc/Build/Format.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+{-# OPTIONS -Wno-orphans #-}
+
+module Calc.Build.Format
+  ( formatAndSave,
+    format,
+  )
+where
+
+import Calc.Types.Module
+import Control.Monad (when)
+import Control.Monad.IO.Class
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Data.Void
+import Error.Diagnose.Compat.Megaparsec
+import qualified Prettyprinter as PP
+import qualified Prettyprinter.Render.Text as PP
+
+instance HasHints Void msg where
+  hints _ = mempty
+
+-- format the file, and if it's changed, save it
+format :: [ModuleItem ann] -> T.Text
+format parsedModuleItems = do
+  let prettyMod = PP.cat (PP.punctuate PP.line (PP.pretty <$> parsedModuleItems))
+   in renderWithWidth 60 prettyMod
+
+-- format the file, and if it's changed, save it
+formatAndSave :: (MonadIO m) => FilePath -> T.Text -> [ModuleItem ann] -> m ()
+formatAndSave filePath originalInput parsedModuleItems = do
+  let printed = format parsedModuleItems
+  when (printed /= originalInput) $
+    liftIO $
+      T.writeFile filePath printed
+
+renderWithWidth :: Int -> PP.Doc ann -> T.Text
+renderWithWidth w doc = PP.renderStrict (PP.layoutPretty layoutOptions (PP.unAnnotate doc))
+  where
+    layoutOptions = PP.LayoutOptions {PP.layoutPageWidth = PP.AvailablePerLine w 1}

wasm-calc11/src/Calc/Build/Print.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module Calc.Build.Print (printBuildError) where
+
+import Calc.Build.Steps
+import Control.Monad.IO.Class
+import qualified Data.Text.IO as T
+import qualified Error.Diagnose as Diag
+
+printBuildError :: (MonadIO m) => BuildError -> m ()
+printBuildError (BuildDiagnostic diag) =
+  Diag.printDiagnostic
+    Diag.stderr
+    Diag.WithUnicode
+    (Diag.TabSize 4)
+    Diag.defaultStyle
+    diag
+printBuildError (BuildMessage msg) =
+  liftIO (T.hPutStrLn Diag.stderr msg)

wasm-calc11/src/Calc/Build/Steps.hs

@@ -0,0 +1,112 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{-# OPTIONS -Wno-orphans #-}
+
+module Calc.Build.Steps
+  ( BuildError (..),
+    parseModuleStep,
+    resolveModuleStep,
+    typecheckModuleStep,
+    linearityCheckStep,
+    abilityCheckStep,
+    fromExprStep,
+    testsAllPass,
+    displayResults,
+  )
+where
+
+import Calc.Ability.Check
+import Calc.Dependencies
+import qualified Calc.Linearity as Linearity
+import Calc.Module (resolveModule)
+import Calc.Parser
+import Calc.Parser.Types
+import Calc.Typecheck
+import Calc.Types.Ability
+import Calc.Types.Annotation
+import Calc.Types.Module
+import Calc.Types.Type
+import Calc.Wasm.FromExpr.Module
+import Calc.Wasm.ToWasm.Types (WasmModule)
+import Control.Monad.Except
+import Data.Monoid
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Void
+import qualified Error.Diagnose as Diag
+import Error.Diagnose.Compat.Megaparsec
+
+data BuildError
+  = BuildDiagnostic (Diag.Diagnostic T.Text)
+  | BuildMessage Text
+
+instance HasHints Void msg where
+  hints _ = mempty
+
+parseModuleStep :: T.Text -> Either BuildError [ModuleItem Annotation]
+parseModuleStep input =
+  case parseModule input of
+    Right a -> pure a
+    Left bundle -> throwError $ BuildDiagnostic (fromErrorBundle bundle (T.unpack input))
+
+resolveModuleStep :: [ModuleItem Annotation] -> Either BuildError (Module Annotation)
+resolveModuleStep parsedModuleItems =
+  case resolveModule parsedModuleItems of
+    Right a -> pure a
+    Left err -> throwError $ BuildMessage (T.pack $ show err)
+
+typecheckModuleStep :: T.Text -> Module Annotation -> Either BuildError (Module (Type Annotation))
+typecheckModuleStep input parsedModule =
+  case elaborateModule parsedModule of
+    Right a -> pure a
+    Left typeErr ->
+      throwError $ BuildDiagnostic (typeErrorDiagnostic input typeErr)
+
+linearityCheckStep :: T.Text -> Module (Type Annotation) -> Either BuildError ()
+linearityCheckStep input typedModule =
+  case Linearity.validateModule typedModule of
+    Right a -> pure a
+    Left linearityError ->
+      throwError $ BuildDiagnostic (Linearity.linearityErrorDiagnostic input linearityError)
+
+abilityCheckStep :: T.Text -> Module Annotation -> Either BuildError (ModuleAnnotations (S.Set (Ability Annotation)))
+abilityCheckStep input parsedModule =
+  case abilityCheckModule parsedModule of
+    Right a -> pure a
+    Left abilityError ->
+      throwError $ BuildDiagnostic (abilityErrorDiagnostic input abilityError)
+
+fromExprStep :: Module (Type Annotation) -> Either BuildError WasmModule
+fromExprStep typedModule =
+  case fromModule (treeShakeModule typedModule) of
+    Right wasmMod -> pure wasmMod
+    Left fromWasmError -> do
+      throwError (BuildMessage $ T.pack $ show fromWasmError)
+
+testsAllPass :: [(a, Bool)] -> Bool
+testsAllPass = getAll . foldMap (All . snd)
+
+displayResults :: [(T.Text, Bool)] -> [T.Text]
+displayResults =
+  fmap (T.pack . printResult)
+  where
+    printResult (name, True) =
+      "✅ " <> show name
+    printResult (name, False) =
+      "❌ " <> show name
+
+-- | turn Megaparsec error + input into a Diagnostic
+fromErrorBundle :: ParseErrorType -> String -> Diag.Diagnostic Text
+fromErrorBundle bundle input =
+  let diag =
+        errorDiagnosticFromBundle
+          Nothing
+          "Parse error on input"
+          Nothing
+          bundle
+   in Diag.addFile diag replFilename input