style improvements

anoma · Feb 12, 2024 · ef438c3 · ef438c3
1 parent e3044c4
commit ef438c3
Show file tree

Hide file tree

Showing 7 changed files with 41 additions and 42 deletions.
diff --git a/app/Commands/Dev/Asm/Compile.hs b/app/Commands/Dev/Asm/Compile.hs
@@ -33,15 +33,15 @@ runCommand opts = do
               $ tab
           tab' <- getRight r
           let code = Reg.ppPrint tab' tab'
-          embed @IO $ writeFileEnsureLn regFile code
+          writeFileEnsureLn regFile code
         _ ->
           case run $ runReader entryPoint $ runError $ asmToMiniC tab of
             Left err -> exitJuvixError err
             Right C.MiniCResult {..} -> do
               buildDir <- askBuildDir
               ensureDir buildDir
               cFile <- inputCFile file
-              embed @IO $ writeFileEnsureLn cFile _resultCCode
+              writeFileEnsureLn cFile _resultCCode
               outfile <- Compile.outputFile opts file
               Compile.runCommand
                 opts

diff --git a/app/Commands/Dev/Core/Compile/Base.hs b/app/Commands/Dev/Core/Compile/Base.hs
@@ -89,7 +89,7 @@ runGebPipeline pa@PipelineArg {..} = do
                   _lispPackageEntry = "*entry*"
                 }
   Geb.Result {..} <- getRight (run (runReader entryPoint (runError (coreToGeb spec _pipelineArgModule :: Sem '[Error JuvixError, Reader EntryPoint] Geb.Result))))
-  embed @IO $ writeFileEnsureLn gebFile _resultCode
+  writeFileEnsureLn gebFile _resultCode
 
 runVampIRPipeline ::
   forall r.

diff --git a/app/Commands/Dev/Tree/Compile/Base.hs b/app/Commands/Dev/Tree/Compile/Base.hs
@@ -59,7 +59,7 @@ runCPipeline pa@PipelineArg {..} = do
       . runError @JuvixError
       $ treeToMiniC _pipelineArgTable
   cFile <- inputCFile _pipelineArgFile
-  embed @IO $ writeFileEnsureLn cFile _resultCCode
+  writeFileEnsureLn cFile _resultCCode
   outfile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile
   Compile.runCommand
     _pipelineArgOptions

diff --git a/src/Juvix/Compiler/Reg/Extra.hs b/src/Juvix/Compiler/Reg/Extra.hs
@@ -50,14 +50,13 @@ computeMaxStackHeight lims = maximum . map go
           (computeMaxStackHeight lims _instrBranchTrue)
           (computeMaxStackHeight lims _instrBranchFalse)
       Case InstrCase {..} ->
-        max
-          ( maximum
-              ( map
-                  (computeMaxStackHeight lims . (^. caseBranchCode))
-                  _instrCaseBranches
-              )
+        maximum1
+          ( maybe 0 (computeMaxStackHeight lims) _instrCaseDefault
+              :| ( map
+                     (computeMaxStackHeight lims . (^. caseBranchCode))
+                     _instrCaseBranches
+                 )
           )
-          (maybe 0 (computeMaxStackHeight lims) _instrCaseDefault)
       Block InstrBlock {..} ->
         computeMaxStackHeight lims _instrBlockCode
 
@@ -91,14 +90,13 @@ computeMaxCallClosuresArgsNum = maximum . map go
           (computeMaxCallClosuresArgsNum _instrBranchTrue)
           (computeMaxCallClosuresArgsNum _instrBranchFalse)
       Case InstrCase {..} ->
-        max
-          ( maximum
-              ( map
-                  (computeMaxCallClosuresArgsNum . (^. caseBranchCode))
-                  _instrCaseBranches
-              )
+        maximum1
+          ( maybe 0 computeMaxCallClosuresArgsNum _instrCaseDefault
+              :| ( map
+                     (computeMaxCallClosuresArgsNum . (^. caseBranchCode))
+                     _instrCaseBranches
+                 )
           )
-          (maybe 0 computeMaxCallClosuresArgsNum _instrCaseDefault)
       Block InstrBlock {..} ->
         computeMaxCallClosuresArgsNum _instrBlockCode
 
@@ -191,14 +189,13 @@ computeLocalVarsNum = maximum . map go
           (computeLocalVarsNum _instrBranchTrue)
           (computeLocalVarsNum _instrBranchFalse)
       Case InstrCase {..} ->
-        max
-          ( maximum
-              ( map
-                  (computeLocalVarsNum . (^. caseBranchCode))
-                  _instrCaseBranches
-              )
+        maximum1
+          ( maybe 0 computeLocalVarsNum _instrCaseDefault
+              :| ( map
+                     (computeLocalVarsNum . (^. caseBranchCode))
+                     _instrCaseBranches
+                 )
           )
-          (maybe 0 computeLocalVarsNum _instrCaseDefault)
       Block InstrBlock {..} ->
         computeLocalVarsNum _instrBlockCode
 
@@ -261,9 +258,9 @@ computeExtraInfo lims tab =
       _extraInfoMaxArgsNum =
         maximum (map (^. functionArgsNum) (HashMap.elems (tab ^. infoFunctions))),
       _extraInfoMaxCallClosuresArgsNum =
-        maximum
+        maximum1
           ( lims ^. limitsSpecialisedApply
-              : map (computeMaxCallClosuresArgsNum . (^. functionCode)) (HashMap.elems (tab ^. infoFunctions))
+              :| map (computeMaxCallClosuresArgsNum . (^. functionCode)) (HashMap.elems (tab ^. infoFunctions))
           ),
       _extraInfoConstrsNum =
         length (userConstrs tab) + lims ^. limitsBuiltinUIDsNum,

diff --git a/src/Juvix/Compiler/Reg/Pretty.hs b/src/Juvix/Compiler/Reg/Pretty.hs
@@ -25,4 +25,4 @@ ppTrace :: (PrettyCode c) => InfoTable -> c -> Text
 ppTrace tab = ppTrace' (defaultOptions tab)
 
 ppPrint :: (PrettyCode c) => InfoTable -> c -> Text
-ppPrint tab = show . ppOutDefault tab
+ppPrint tab = toPlainText . ppOutDefault tab
diff --git a/src/Juvix/Compiler/Reg/Pretty/Base.hs b/src/Juvix/Compiler/Reg/Pretty/Base.hs
@@ -25,9 +25,9 @@ class PrettyCode c where
 instance PrettyCode VarRef where
   ppCode VarRef {..} = case _varRefName of
     Just n -> return $ variable (quoteName n)
-    Nothing -> case _varRefGroup of
-      VarGroupArgs -> return $ ppRef Str.arg _varRefIndex
-      VarGroupLocal -> return $ ppRef Str.tmp _varRefIndex
+    Nothing -> return $ case _varRefGroup of
+      VarGroupArgs -> ppRef Str.arg _varRefIndex
+      VarGroupLocal -> ppRef Str.tmp _varRefIndex
     where
       ppRef :: Text -> Index -> Doc Ann
       ppRef str off = variable str <> brackets (integer off)
@@ -45,16 +45,16 @@ instance PrettyCode Value where
     VRef x -> ppCode x
 
 instance PrettyCode Opcode where
-  ppCode = \case
-    OpIntAdd -> return $ primitive Str.add_
-    OpIntSub -> return $ primitive Str.sub_
-    OpIntMul -> return $ primitive Str.mul_
-    OpIntDiv -> return $ primitive Str.div_
-    OpIntMod -> return $ primitive Str.mod_
-    OpIntLt -> return $ primitive Str.lt_
-    OpIntLe -> return $ primitive Str.le_
-    OpEq -> return $ primitive Str.eq
-    OpStrConcat -> return $ primitive Str.instrStrConcat
+  ppCode op = return $ case op of
+    OpIntAdd -> primitive Str.add_
+    OpIntSub -> primitive Str.sub_
+    OpIntMul -> primitive Str.mul_
+    OpIntDiv -> primitive Str.div_
+    OpIntMod -> primitive Str.mod_
+    OpIntLt -> primitive Str.lt_
+    OpIntLe -> primitive Str.le_
+    OpEq -> primitive Str.eq
+    OpStrConcat -> primitive Str.instrStrConcat
 
 instance PrettyCode BinaryOp where
   ppCode BinaryOp {..} = do

diff --git a/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs
@@ -350,9 +350,11 @@ functionBody parseCode' argnames = do
   let updateNames :: LocalNameMap d -> LocalNameMap d
       updateNames names =
         foldr
-          (\(mn, idx) h -> maybe h (\n -> HashMap.insert n ((sig ^. parserSigArgRef) idx (Just n)) h) mn)
+          (\(mname, idx) names' -> maybe names' (updateWithArgRef names' idx) mname)
           names
           (zip argnames [0 ..])
+      updateWithArgRef :: LocalNameMap d -> Int -> Text -> LocalNameMap d
+      updateWithArgRef names idx name = HashMap.insert name ((sig ^. parserSigArgRef) idx (Just name)) names
   localS (over localParamsNameMap updateNames) parseCode'
 
 memRef ::