Use BlockArguments

Author: ollef

benchmarks/parser/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Main where
@@ -40,8 +41,8 @@ main = do
 listDirectoryRecursive :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
 listDirectoryRecursive p dir = do
   files <- listDirectory dir
-  fmap concat $
-    forM files $ \file -> do
+  concat
+    <$> forM files \file -> do
       let path = dir </> file
       isDir <- doesDirectoryExist path
       if isDir
@@ -59,9 +60,10 @@ listDirectoriesWithFilesMatching p dir = do
     then do
       recursiveFiles <- listDirectoryRecursive p dir
       pure [(dir, recursiveFiles)]
-    else fmap concat $
-      forM paths $ \path -> do
-        isDir <- doesDirectoryExist path
-        if isDir
-          then listDirectoriesWithFilesMatching p path
-          else pure []
+    else
+      concat
+        <$> forM paths \path -> do
+          isDir <- doesDirectoryExist path
+          if isDir
+            then listDirectoriesWithFilesMatching p path
+            else pure []

src/AssemblyToLLVM.hs

@@ -146,7 +146,7 @@ freshName (Assembly.NameSuggestion nameSuggestion) = do
   usedNames <- gets (.usedNames)
   let bsName = ShortByteString.toShort $ toUtf8 nameSuggestion
       i = HashMap.lookupDefault 0 bsName usedNames
-  modify $ \s ->
+  modify \s ->
     s
       { usedNames = HashMap.insert bsName (i + 1) usedNames
       }
@@ -155,7 +155,7 @@ freshName (Assembly.NameSuggestion nameSuggestion) = do
 activateLocal :: Assembly.Type -> Assembly.Local -> Assembler Name
 activateLocal type_ local@(Assembly.Local _ nameSuggestion) = do
   name <- freshName nameSuggestion
-  modify $ \s ->
+  modify \s ->
     s
       { locals = HashMap.insert local (type_, TypedOperand {type_ = llvmType type_, operand = Local name}) s.locals
       }
@@ -477,7 +477,7 @@ assembleInstruction instruction =
         _ -> panic "AssemblyToLLVM.assembleInstruction: ExtractValue of non-struct"
     Assembly.Switch destination scrutinee branches (Assembly.BasicBlock defaultBranchInstructions defaultBranchResult) -> do
       scrutinee' <- assembleOperandAndCastTo Assembly.Word scrutinee
-      branchLabels <- forM branches $ \(i, _) -> do
+      branchLabels <- forM branches \(i, _) -> do
         branchLabel <- freshName $ Assembly.NameSuggestion $ "branch_" <> show i
         pure (i, branchLabel)
       defaultBranchLabel <- freshName "default"
@@ -489,7 +489,7 @@ assembleInstruction instruction =
           <> localName defaultBranchLabel
           <> " "
           <> brackets [separate " " [typedOperand TypedOperand {type_ = wordSizedInt, operand = Constant $ Builder.integerDec i} <> ", label " <> localName l | (i, l) <- branchLabels]]
-      branchResultOperands <- forM (zip branchLabels branches) $ \((_, branchLabel), (_, Assembly.BasicBlock instructions result)) -> do
+      branchResultOperands <- forM (zip branchLabels branches) \((_, branchLabel), (_, Assembly.BasicBlock instructions result)) -> do
         startBlock branchLabel
         mapM_ assembleInstruction instructions
         resultOperand <- forM ((,) . fst <$> destination <*> result) $ uncurry assembleOperandAndCastTo

src/ClosureConverted/Readback.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module ClosureConverted.Readback where
@@ -78,7 +79,7 @@ readbackGroupedElimination env eliminee elimination =
                   branchValue <- Evaluation.evaluate env' branch
                   readback env branchValue
               )
-      defaultBranch' <- forM defaultBranch $ \branch -> do
+      defaultBranch' <- forM defaultBranch \branch -> do
         branch' <- Evaluation.evaluate env' branch
         readback env branch'
       pure $ Syntax.Case eliminee branches' defaultBranch'

src/ClosureConverted/Representation.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -38,7 +39,7 @@ signature :: Syntax.Definition -> M Representation.Signature
 signature def =
   case def of
     Syntax.TypeDeclaration (Syntax.Function tele) -> do
-      telescopeSignature context tele mempty $ \context' body parameterRepresentations -> do
+      telescopeSignature context tele mempty \context' body parameterRepresentations -> do
         let env' =
               Context.toEnvironment context'
         body' <- Evaluation.evaluate env' body
@@ -52,7 +53,7 @@ signature def =
       type_ <- TypeOf.typeOf context value
       Representation.ConstantSignature <$> typeRepresentation env type_
     Syntax.FunctionDefinition tele ->
-      telescopeSignature context tele mempty $ \context' body parameterRepresentations -> do
+      telescopeSignature context tele mempty \context' body parameterRepresentations -> do
         let env' =
               Context.toEnvironment context'
         body' <- Evaluation.evaluate env' body
@@ -62,7 +63,7 @@ signature def =
     Syntax.DataDefinition {} ->
       pure $ Representation.ConstantSignature $ Representation.Direct Representation.Doesn'tContainHeapPointers
     Syntax.ParameterisedDataDefinition _boxity tele ->
-      telescopeSignature context tele mempty $ \_ _ parameterRepresentations -> do
+      telescopeSignature context tele mempty \_ _ parameterRepresentations -> do
         pure $ Representation.FunctionSignature parameterRepresentations $ Representation.Direct Representation.Doesn'tContainHeapPointers
   where
     context =
@@ -201,7 +202,7 @@ compileData env dataTypeName (Syntax.ConstructorDefinitions constructors) = do
     Boxed ->
       pure $ Syntax.Global (Name.Lifted Builtin.WordRepresentationName 0)
     Unboxed -> do
-      compiledConstructorFields <- forM (OrderedHashMap.toList constructors) $ \(_, type_) -> do
+      compiledConstructorFields <- forM (OrderedHashMap.toList constructors) \(_, type_) -> do
         type' <- Evaluation.evaluate env type_
         compileUnboxedConstructorFields env type'
       let maxFieldSize =
@@ -314,7 +315,7 @@ constructorRepresentations name = do
   pure $ case definition of
     Core.Syntax.DataDefinition boxity tele ->
       ( boxity
-      , Telescope.under tele $ \(Core.Syntax.ConstructorDefinitions constructors) ->
+      , Telescope.under tele \(Core.Syntax.ConstructorDefinitions constructors) ->
           case OrderedHashMap.toList constructors of
             [] -> Nothing
             [_] -> Nothing

src/ClosureConvertedToAssembly.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -80,7 +81,7 @@ subBuilder (Builder s) = do
 
 emit :: Assembly.Instruction -> Builder ()
 emit instruction =
-  modify $ \s -> s {instructions = s.instructions Tsil.:> instruction}
+  modify \s -> s {instructions = s.instructions Tsil.:> instruction}
 
 tagBytes :: Num a => a
 tagBytes = wordBytes
@@ -157,14 +158,14 @@ getFreeShadowStackSlot :: Builder (Int, Builder ())
 getFreeShadowStackSlot = do
   slot <- gets (.nextShadowStackSlot)
   let newNextSlot = slot + 1
-  modify $ \s ->
+  modify \s ->
     s
       { nextShadowStackSlot = newNextSlot
       , shadowStackSlotCount = max newNextSlot s.shadowStackSlotCount
       }
   pure
     ( slot
-    , modify $ \s ->
+    , modify \s ->
         s
           { nextShadowStackSlot =
               if s.nextShadowStackSlot == newNextSlot
@@ -244,7 +245,7 @@ heapAllocate nameSuggestion constructorTag size = do
   result <- extractValue nameSuggestion destinationOperand 0
   heapPointer' <- extractValue "heap_pointer" destinationOperand 1
   heapLimit' <- extractValue "heap_limit" destinationOperand 2
-  modify $ \s -> s {heapPointer = heapPointer', heapLimit = heapLimit'}
+  modify \s -> s {heapPointer = heapPointer', heapLimit = heapLimit'}
   pure result
 
 extractHeapPointer :: Assembly.NameSuggestion -> Assembly.Operand -> Builder Assembly.Operand
@@ -286,7 +287,7 @@ switch returnType scrutinee branches defaultBranch = do
   initialHeapPointer <- gets (.heapPointer)
   initialHeapLimit <- gets (.heapLimit)
   let wrapBranch branch = subBuilder $ do
-        modify $ \s ->
+        modify \s ->
           s
             { nextShadowStackSlot = initialNextShadowStackSlot
             , heapPointer = initialHeapPointer
@@ -304,13 +305,13 @@ switch returnType scrutinee branches defaultBranch = do
           )
 
   ((defaultReturn, defaultNextShadowStackSlot), defaultInstructions) <- wrapBranch defaultBranch
-  branches' <- forM branches $ \(i, branch) -> do
+  branches' <- forM branches \(i, branch) -> do
     ((branchReturn, branchNextShadowStackSlot), branchInstructions) <- wrapBranch branch
     pure ((i, Assembly.BasicBlock branchInstructions branchReturn), branchNextShadowStackSlot)
   let branchNextShadowStackSlots = snd <$> branches'
   when (any (/= defaultNextShadowStackSlot) branchNextShadowStackSlots) $
     panic "ClosureConvertedToAssembly.switch: Shadow stack mismatch"
-  modify $ \s -> s {nextShadowStackSlot = defaultNextShadowStackSlot}
+  modify \s -> s {nextShadowStackSlot = defaultNextShadowStackSlot}
   case returnType of
     Assembly.Void -> do
       resultLocal <- freshLocal "heap_pointer_and_limit"
@@ -319,7 +320,7 @@ switch returnType scrutinee branches defaultBranch = do
       emit $ Assembly.Switch (Assembly.Return (resultType, resultLocal)) scrutinee (fst <$> branches') $ Assembly.BasicBlock defaultInstructions defaultReturn
       heapPointer <- extractValue "heap_pointer" resultOperand 0
       heapLimit <- extractValue "heap_limit" resultOperand 1
-      modify $ \s -> s {heapPointer, heapLimit}
+      modify \s -> s {heapPointer, heapLimit}
       pure Assembly.Void
     Assembly.Return (type_, nameSuggestion) -> do
       resultLocal <- freshLocal $ nameSuggestion <> "_with_heap_pointer_and_limit"
@@ -329,15 +330,15 @@ switch returnType scrutinee branches defaultBranch = do
       result <- extractValue nameSuggestion resultOperand 0
       heapPointer <- extractValue "heap_pointer" resultOperand 1
       heapLimit <- extractValue "heap_limit" resultOperand 2
-      modify $ \s -> s {heapPointer, heapLimit}
+      modify \s -> s {heapPointer, heapLimit}
       pure $ Assembly.Return result
 
 -------------------------------------------------------------------------------
 
 freshLocal :: Assembly.NameSuggestion -> Builder Assembly.Local
 freshLocal nameSuggestion = do
   fresh <- gets (.fresh)
-  modify $ \s -> s {fresh = fresh + 1}
+  modify \s -> s {fresh = fresh + 1}
   pure $ Assembly.Local fresh nameSuggestion
 
 copy :: Assembly.Operand -> Operand -> Assembly.Operand -> Builder ()
@@ -366,7 +367,7 @@ callVoid global args = do
   let resultStructOperand = Assembly.LocalOperand resultStruct
   heapPointer' <- extractValue "heap_pointer" resultStructOperand 0
   heapLimit' <- extractValue "heap_limit" resultStructOperand 1
-  modify $ \s ->
+  modify \s ->
     s
       { heapPointer = heapPointer'
       , heapLimit = heapLimit'
@@ -394,7 +395,7 @@ callDirect nameSuggestion global args = do
   result <- extractValue nameSuggestion resultStructOperand 0
   heapPointer' <- extractValue "heap_pointer" resultStructOperand 1
   heapLimit' <- extractValue "heap_limit" resultStructOperand 2
-  modify $ \s ->
+  modify \s ->
     s
       { heapPointer = heapPointer'
       , heapLimit = heapLimit'
@@ -424,7 +425,7 @@ callInitFunction nameSuggestion global args = do
   result <- extractValue nameSuggestion resultStructOperand 0
   heapPointer' <- extractValue "heap_pointer" resultStructOperand 1
   heapLimit' <- extractValue "heap_limit" resultStructOperand 2
-  modify $ \s ->
+  modify \s ->
     s
       { heapPointer = heapPointer'
       , heapLimit = heapLimit'
@@ -630,7 +631,7 @@ withFunctionDefinitionParameters m = do
   heapPointer <- gets (.heapPointer)
   heapLimit <- gets (.heapLimit)
   pure $
-    mkDefinition $ \returnType parameters (Assembly.BasicBlock instructions returnOperand) ->
+    mkDefinition \returnType parameters (Assembly.BasicBlock instructions returnOperand) ->
       Assembly.FunctionDefinition
         ( case returnType of
             Assembly.Void -> Assembly.Return $ Assembly.Struct [Assembly.WordPointer, Assembly.WordPointer]
@@ -677,11 +678,11 @@ generateGlobal env name representation term = do
       pure $ Assembly.KnownConstantDefinition Assembly.Word knownConstant True
     Nothing ->
       case representation of
-        Representation.Empty -> makeConstantDefinition Assembly.WordPointer $ \globalPointer -> do
+        Representation.Empty -> makeConstantDefinition Assembly.WordPointer \globalPointer -> do
           (_, deallocateTerm) <- generateTypedTerm env term (Direct emptyTypeOperand) representation
           sequence_ deallocateTerm
           pure globalPointer
-        Representation.Direct Representation.Doesn'tContainHeapPointers -> makeConstantDefinition Assembly.Word $ \globalPointer -> do
+        Representation.Direct Representation.Doesn'tContainHeapPointers -> makeConstantDefinition Assembly.Word \globalPointer -> do
           (result, deallocateTerm) <- generateTypedTerm env term (Direct directTypeOperand) representation
           directResult <- forceDirect result
           sequence_ deallocateTerm
@@ -693,7 +694,7 @@ generateGlobal env name representation term = do
           indirectCase containsHeapPointers
   where
     indirectCase containsHeapPointers = do
-      makeConstantDefinition Assembly.WordPointer $ \globalPointer -> do
+      makeConstantDefinition Assembly.WordPointer \globalPointer -> do
         (type_, _representation) <- typeOf env term
         typeSize <- sizeOfType type_
         globalPointer' <- globalAllocate "globals" globalPointer typeSize
@@ -1227,7 +1228,7 @@ boxedConstructorSize env con params args = do
   tele <- fetch $ Query.ClosureConvertedConstructorType con
   params' <- mapM (Evaluation.evaluate env) params
   args' <- mapM (Evaluation.evaluate env) args
-  maybeResult <- Evaluation.applyTelescope env (Telescope.fromVoid tele) params' $ \env' type_ -> do
+  maybeResult <- Evaluation.applyTelescope env (Telescope.fromVoid tele) params' \env' type_ -> do
     type' <- Evaluation.evaluate env' type_
     size <- ClosureConverted.Representation.compileBoxedConstructorFields env' type' args'
     Evaluation.evaluate env' size

src/Command/BenchmarkProjectGenerator.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -21,7 +22,7 @@ data Options = Options
 generate :: Options -> IO ()
 generate Options {..} = do
   createDirectoryIfMissing True $ outputDirectory </> "src"
-  forM_ [1 .. moduleCount] $ \moduleNumber -> do
+  forM_ [1 .. moduleCount] \moduleNumber -> do
     let moduleName num =
           "Module" <> show num
 
@@ -32,7 +33,7 @@ generate Options {..} = do
       replicateM (min (moduleNumber - 1) importCount) $
         randomRIO (1, moduleNumber - 1)
 
-    functions <- forM [1 .. functionCount] $ \functionNumber -> do
+    functions <- forM [1 .. functionCount] \functionNumber -> do
       def <-
         if not (null importedModules)
           then do

src/Command/Check.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -26,16 +27,16 @@ check argumentFiles printElaborated = do
   ((), errs) <-
     Driver.runTask sourceDirectories filePaths Error.Hydrated.pretty $
       if printElaborated
-        then withAsync (void Driver.checkAll) $ \checkedAll -> do
+        then withAsync (void Driver.checkAll) \checkedAll -> do
           inputFiles <- fetch Query.InputFiles
-          forM_ inputFiles $ \filePath -> do
+          forM_ inputFiles \filePath -> do
             (module_, _, defs) <- fetch $ Query.ParsedFile filePath
             let names =
                   HashSet.fromList $
                     Name.Qualified module_ . fst . snd <$> defs
             emptyPrettyEnv <- Pretty.emptyM module_
             liftIO $ putDoc $ "module" <+> pretty module_ <> line <> line
-            forM_ names $ \name -> do
+            forM_ names \name -> do
               type_ <- fetch $ Query.ElaboratedType name
               liftIO $ putDoc $ Pretty.prettyDefinition emptyPrettyEnv name (Syntax.TypeDeclaration type_) <> line
               (definition, _) <- fetch $ Query.ElaboratedDefinition name
@@ -47,7 +48,7 @@ check argumentFiles printElaborated = do
           wait checkedAll
         else void Driver.checkAll
   endTime <- getCurrentTime
-  forM_ errs $ \err ->
+  forM_ errs \err ->
     putDoc $ err <> line
   let errorCount =
         length errs

src/Command/Compile.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -32,8 +33,8 @@ withCompiledExecutable :: (FilePath -> IO ()) -> Options -> IO ()
 withCompiledExecutable k Options {..} = do
   startTime <- getCurrentTime
   (sourceDirectories, filePaths) <- Project.filesFromArguments argumentFiles
-  withAssemblyDirectory maybeAssemblyDir $ \assemblyDir ->
-    withOutputFile maybeOutputFile $ \outputFile -> do
+  withAssemblyDirectory maybeAssemblyDir \assemblyDir ->
+    withOutputFile maybeOutputFile \outputFile -> do
       ((), errs) <-
         Driver.runTask sourceDirectories filePaths Error.Hydrated.pretty $
           Compiler.compile assemblyDir (isJust maybeAssemblyDir) outputFile maybeOptimisationLevel
@@ -59,7 +60,7 @@ withOutputFile :: Maybe FilePath -> (FilePath -> IO a) -> IO a
 withOutputFile maybeOutputFile_ k' =
   case maybeOutputFile_ of
     Nothing ->
-      withTempFile "." "temp.exe" $ \outputFile outputFileHandle -> do
+      withTempFile "." "temp.exe" \outputFile outputFileHandle -> do
         hClose outputFileHandle
         k' outputFile
     Just o -> do

src/Command/Run.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE BlockArguments #-}
+
 module Command.Run where
 
 import qualified Command.Compile
@@ -6,4 +8,4 @@ import System.Process
 
 run :: Command.Compile.Options -> IO ()
 run =
-  Command.Compile.withCompiledExecutable $ \exe -> callProcess exe []
+  Command.Compile.withCompiledExecutable \exe -> callProcess exe []