hackworthltd · dhess · Jul 31, 2023
diff --git a/flake.nix b/flake.nix
@@ -48,7 +48,7 @@
 
       # Fourmolu updates often alter formatting arbitrarily, and we want to
       # have more control over this.
-      fourmoluVersion = "0.12.0.0";
+      fourmoluVersion = "0.13.1.0";
 
       allOverlays = [
         inputs.haskell-nix.overlay

diff --git a/primer-api/src/Primer/API.hs b/primer-api/src/Primer/API.hs
@@ -540,8 +540,9 @@ deleteSession = logAPI (noError DeleteSession) $ \sid -> do
 listSessions :: (MonadIO m, MonadAPILog l m) => OffsetLimit -> PrimerM m (Page Session)
 listSessions = logAPI (noError ListSessions) $ \ol -> do
   q <- asks dbOpQueue
-  callback <- liftIO $
-    atomically $ do
+  callback <- liftIO
+    $ atomically
+    $ do
       cb <- newEmptyTMVar
       writeTBQueue q $ Database.ListSessions ol cb
       pure cb
@@ -554,8 +555,9 @@ findSessions :: (MonadIO m, MonadAPILog l m) => Text -> OffsetLimit -> PrimerM m
 findSessions = curry $ logAPI (noError FindSessions) $ \case
   (substr, ol) -> do
     q <- asks dbOpQueue
-    callback <- liftIO $
-      atomically $ do
+    callback <- liftIO
+      $ atomically
+      $ do
         cb <- newEmptyTMVar
         writeTBQueue q $ Database.FindSessions substr ol cb
         pure cb
@@ -728,8 +730,9 @@ viewProg p =
                   , constructors = case d of
                       TypeDef.TypeDefPrim _ -> Nothing
                       TypeDef.TypeDefAST t ->
-                        Just $
-                          astTypeDefConstructors t <&> \(TypeDef.ValCon nameCon argsCon) ->
+                        Just
+                          $ astTypeDefConstructors t
+                          <&> \(TypeDef.ValCon nameCon argsCon) ->
                             ValCon
                               { name = nameCon
                               , fields = viewTreeType' . over _typeMeta (show . view _id) <$> argsCon
@@ -875,24 +878,25 @@ viewTreeExpr e0 = case e0 of
           Tree
             { nodeId = boxId
             , body =
-                BoxBody . RecordPair Flavor.Pattern $
-                  ( Tree
-                      { nodeId = patternRootId
-                      , body = pat p
-                      , childTrees =
-                          map
-                            ( \(Bind m v) ->
-                                Tree
-                                  { nodeId = show $ getID m
-                                  , body = TextBody $ RecordPair Flavor.PatternBind $ localName v
-                                  , childTrees = []
-                                  , rightChild = Nothing
-                                  }
-                            )
-                            binds
-                      , rightChild = Nothing
-                      }
-                  )
+                BoxBody
+                  . RecordPair Flavor.Pattern
+                  $ ( Tree
+                        { nodeId = patternRootId
+                        , body = pat p
+                        , childTrees =
+                            map
+                              ( \(Bind m v) ->
+                                  Tree
+                                    { nodeId = show $ getID m
+                                    , body = TextBody $ RecordPair Flavor.PatternBind $ localName v
+                                    , childTrees = []
+                                    , rightChild = Nothing
+                                    }
+                              )
+                              binds
+                        , rightChild = Nothing
+                        }
+                    )
             , childTrees = [viewTreeExpr rhs]
             , rightChild = Nothing
             }
@@ -906,18 +910,19 @@ viewTreeExpr e0 = case e0 of
             boxId = nodeId <> "Pwild"
             patternRootId = boxId <> "B"
            in
-            Just $
-              Tree
+            Just
+              $ Tree
                 { nodeId = boxId
                 , body =
-                    BoxBody . RecordPair Flavor.Pattern $
-                      ( Tree
-                          { nodeId = patternRootId
-                          , body = NoBody Flavor.PatternWildcard
-                          , childTrees = []
-                          , rightChild = Nothing
-                          }
-                      )
+                    BoxBody
+                      . RecordPair Flavor.Pattern
+                      $ ( Tree
+                            { nodeId = patternRootId
+                            , body = NoBody Flavor.PatternWildcard
+                            , childTrees = []
+                            , rightChild = Nothing
+                            }
+                        )
                 , childTrees = [viewTreeExpr rhs]
                 , rightChild = Nothing
                 }
@@ -1018,16 +1023,16 @@ viewTreeKind = flip evalState (0 :: Integer) . go
       modify succ
       case k of
         KType ->
-          pure $
-            Tree
+          pure
+            $ Tree
               { nodeId
               , body = NoBody Flavor.KType
               , childTrees = []
               , rightChild = Nothing
               }
         KHole ->
-          pure $
-            Tree
+          pure
+            $ Tree
               { nodeId
               , body = NoBody Flavor.KHole
               , childTrees = []
@@ -1036,8 +1041,8 @@ viewTreeKind = flip evalState (0 :: Integer) . go
         KFun k1 k2 -> do
           k1tree <- go k1
           k2tree <- go k2
-          pure $
-            Tree
+          pure
+            $ Tree
               { nodeId
               , body = NoBody Flavor.KFun
               , childTrees = [k1tree, k2tree]
@@ -1123,8 +1128,8 @@ evalFull' = curry3 $ logAPI (noError EvalFull') $ \(sid, lim, d) ->
       -- evaluation step will be to inline this definition, removing the node.
       let e = create' $ DSL.gvar d
       x <-
-        handleEvalFullRequest $
-          EvalFullReq
+        handleEvalFullRequest
+          $ EvalFullReq
             { evalFullReqExpr = e
             , evalFullCxtDir = Chk
             , evalFullMaxSteps = fromMaybe 10 lim
@@ -1150,8 +1155,8 @@ createDefinition ::
   Maybe Text ->
   PrimerM m Prog
 createDefinition =
-  curry3 $
-    logAPI (noError CreateDef) \(sid, moduleName, mDefName) ->
+  curry3
+    $ logAPI (noError CreateDef) \(sid, moduleName, mDefName) ->
       edit sid (App.Edit [App.CreateDef moduleName mDefName])
         >>= either (throwM . AddDefError moduleName mDefName) (pure . viewProg)
 
@@ -1163,8 +1168,8 @@ createTypeDef ::
   [ValConName] ->
   PrimerM m Prog
 createTypeDef =
-  curry3 $
-    logAPI (noError CreateTypeDef) \(sid, tyconName, valcons) ->
+  curry3
+    $ logAPI (noError CreateTypeDef) \(sid, tyconName, valcons) ->
       edit sid (App.Edit [App.AddTypeDef tyconName $ ASTTypeDef [] (map (`TypeDef.ValCon` []) valcons) []])
         >>= either (throwM . AddTypeDefError tyconName valcons) (pure . viewProg)
 
@@ -1211,8 +1216,8 @@ actionOptions = curry4 $ logAPI (noError ActionOptions) $ \(sid, level, selectio
       allDefs = progAllDefs prog
       allTypeDefs = progAllTypeDefs prog
   def <- snd <$> findASTTypeOrTermDef prog selection
-  maybe (throwM $ ActionOptionsNoID selection) pure $
-    Available.options (snd <$> allTypeDefs) (snd <$> allDefs) (progCxt prog) level def selection action
+  maybe (throwM $ ActionOptionsNoID selection) pure
+    $ Available.options (snd <$> allTypeDefs) (snd <$> allDefs) (progCxt prog) level def selection action
 
 findASTDef :: MonadThrow m => Map GVarName (Editable, Def.Def) -> GVarName -> m (Editable, ASTDef)
 findASTDef allDefs def = case allDefs Map.!? def of
@@ -1243,8 +1248,8 @@ applyActionNoInput = curry3 $ logAPI (noError ApplyActionNoInput) $ \(sid, selec
   prog <- getProgram sid
   def <- snd <$> findASTTypeOrTermDef prog selection
   actions <-
-    either (throwM . ToProgActionError (Available.NoInput action)) pure $
-      toProgActionNoInput (snd <$> progAllDefs prog) def selection action
+    either (throwM . ToProgActionError (Available.NoInput action)) pure
+      $ toProgActionNoInput (snd <$> progAllDefs prog) def selection action
   applyActions sid actions
 
 applyActionInput ::
@@ -1257,8 +1262,8 @@ applyActionInput = curry3 $ logAPI (noError ApplyActionInput) $ \(sid, body, act
   prog <- getProgram sid
   def <- snd <$> findASTTypeOrTermDef prog body.selection
   actions <-
-    either (throwM . ToProgActionError (Available.Input action)) pure $
-      toProgActionInput def body.selection body.option action
+    either (throwM . ToProgActionError (Available.Input action)) pure
+      $ toProgActionInput def body.selection body.option action
   applyActions sid actions
 
 data ApplyActionBody = ApplyActionBody
@@ -1337,12 +1342,15 @@ getSelectionTypeOrKind = curry $ logAPI (noError GetTypeOrKind) $ \(sid, sel0) -
         Nothing -> pure $ Kind $ viewTreeKind $ typeDefKind $ TypeDef.TypeDefAST def
         -- param node selected - return its kind
         Just (TypeDefParamNodeSelection p) ->
-          maybe (throw' $ ParamNotFound p) (pure . Kind . viewTreeKind . snd) $
-            find ((== p) . fst) (astTypeDefParameters def)
+          maybe (throw' $ ParamNotFound p) (pure . Kind . viewTreeKind . snd)
+            $ find ((== p) . fst) (astTypeDefParameters def)
         -- constructor node selected - return the type to which it belongs
         Just (TypeDefConsNodeSelection (TypeDefConsSelection _ Nothing)) ->
-          pure . Type . viewTreeType' . mkIds $
-            foldl' (\t -> TApp () t . TVar ()) (TCon () sel.def) (map fst $ astTypeDefParameters def)
+          pure
+            . Type
+            . viewTreeType'
+            . mkIds
+            $ foldl' (\t -> TApp () t . TVar ()) (TCon () sel.def) (map fst $ astTypeDefParameters def)
         -- field node selected - return its kind
         Just (TypeDefConsNodeSelection (TypeDefConsSelection c (Just s))) -> do
           t0 <- maybe (throw' $ TypeDefConFieldNotFound sel.def c s.index) pure $ getTypeDefConFieldType def c s.index

diff --git a/primer-api/test/Tests/API.hs b/primer-api/test/Tests/API.hs
@@ -472,30 +472,30 @@ test_eval_undo =
           Just e@EmptyHole{} -> pure $ getID e
           _ -> liftIO $ assertFailure "unexpected form of main"
       _ <-
-        expectSuccess $
-          edit sid $
-            Edit
-              [ MoveToDef $ qualifyName scope "main"
-              , BodyAction
-                  [ SetCursor i1
-                  , InsertSaturatedVar $ GlobalVarRef Integer.even
-                  ]
-              ]
+        expectSuccess
+          $ edit sid
+          $ Edit
+            [ MoveToDef $ qualifyName scope "main"
+            , BodyAction
+                [ SetCursor i1
+                , InsertSaturatedVar $ GlobalVarRef Integer.even
+                ]
+            ]
       step "insert 4"
       i2 <-
         getMain >>= \case
           Just (App _ _ e) -> pure $ getID e
           _ -> liftIO $ assertFailure "unexpected form of main"
       _ <-
-        expectSuccess $
-          edit sid $
-            Edit
-              [ MoveToDef $ qualifyName scope "main"
-              , BodyAction
-                  [ SetCursor i2
-                  , ConstructPrim $ PrimInt 4
-                  ]
-              ]
+        expectSuccess
+          $ edit sid
+          $ Edit
+            [ MoveToDef $ qualifyName scope "main"
+            , BodyAction
+                [ SetCursor i2
+                , ConstructPrim $ PrimInt 4
+                ]
+            ]
       step "get edited App"
       app0 <- getApp sid
       step "undo"

diff --git a/primer-api/test/Tests/Database.hs b/primer-api/test/Tests/Database.hs
@@ -156,8 +156,9 @@ testSessionName testName t expected =
     [ testCase "unsafe" $ case mkSessionName t of
         Nothing -> assertFailure "name is invalid"
         Just sn -> fromSessionName sn @?= expected
-    , testCase "safe" $
-        fromSessionName (safeMkSessionName t) @?= expected
+    , testCase "safe"
+        $ fromSessionName (safeMkSessionName t)
+        @?= expected
     ]
 emptyQHarness :: Text -> PrimerM (PureLogT (WithSeverity LogMsg) IO) () -> TestTree
 emptyQHarness desc test = testCaseSteps (toS desc) $ \step' -> do

diff --git a/primer-api/testlib/Primer/API/Test/Util.hs b/primer-api/testlib/Primer/API/Test/Util.hs
@@ -45,9 +45,10 @@ runAPI action = do
   dbOpQueue <- newTBQueueIO 1
   initialSessions <- StmMap.newIO
   (r, logs) <-
-    withAsync (runNullDb' $ serve (ServiceCfg dbOpQueue version)) $
-      const $
-        runPureLogT . runPrimerM action $
-          Env initialSessions dbOpQueue version
+    withAsync (runNullDb' $ serve (ServiceCfg dbOpQueue version))
+      $ const
+      $ runPureLogT
+      . runPrimerM action
+      $ Env initialSessions dbOpQueue version
   assertNoSevereLogs logs
   pure r
diff --git a/primer-benchmark/src/Benchmarks.hs b/primer-benchmark/src/Benchmarks.hs
@@ -99,13 +99,13 @@ benchmarks =
   ]
   where
     evalTestMPureLogs e maxEvals =
-      evalTestM (maxID e) $
-        runPureLogT $
-          evalFull @EvalLog builtinTypes (defMap e) maxEvals Syn (expr e)
+      evalTestM (maxID e)
+        $ runPureLogT
+        $ evalFull @EvalLog builtinTypes (defMap e) maxEvals Syn (expr e)
     evalTestMDiscardLogs e maxEvals =
-      evalTestM (maxID e) $
-        runDiscardLogT $
-          evalFull @EvalLog builtinTypes (defMap e) maxEvals Syn (expr e)
+      evalTestM (maxID e)
+        $ runDiscardLogT
+        $ evalFull @EvalLog builtinTypes (defMap e) maxEvals Syn (expr e)
 
     benchExpected f g e n b = EnvBench e n $ \e' ->
       NF
@@ -118,8 +118,9 @@ benchmarks =
 
     tcTest id = evalTestM id . runExceptT @TypeError . tcWholeProgWithImports
 
-    benchTC e n = EnvBench e n $ \(prog, maxId, _) -> NF (tcTest maxId) prog $
-      pure $ \case
+    benchTC e n = EnvBench e n $ \(prog, maxId, _) -> NF (tcTest maxId) prog
+      $ pure
+      $ \case
         Left err -> assertFailure $ "Failed to typecheck: " <> show err
         Right p -> assertBool "Unexpected smarthole changes" $ forgetProgTypecache p == forgetProgTypecache prog
 
@@ -139,8 +140,10 @@ runTests :: [Benchmark] -> TestTree
 runTests = testGroup "Benchmark result tests" . map go
   where
     go (EnvBench act n b) = withResource act (const $ pure ()) $ \e ->
-      testCase (toS n) $
-        e >>= testBenchmarkable . b
+      testCase (toS n)
+        $ e
+        >>= testBenchmarkable
+        . b
     go (Group n bs) = testGroup (toS n) $ map go bs
 
     testBenchmarkable (NF f x test) = test >>= ($ f x)