feat!: high-level actions for case on primitives

Note that there is no way in our API to say "this action requires an argument, and the argument can be any Int except 3 or 7". Thus when adding a branch to a pattern match of primitive type, we cannot request a frontend to give a branch that does not currently exist. We will give an error if an attempt to add a currently-existing branch is made. It would be possible to augment the API's notion of `FreeInt` and `FreeChar` to include a finite list of illegal entries, but we leave this as a possibility for future work. BREAKING CHANGE: this expands the OpenAPI Signed-off-by: Ben Price <[email protected]>
hackworthltd · Jun 1, 2023 · 5677dbf · 5677dbf
1 parent 464e1ec
commit 5677dbf
Show file tree

Hide file tree

Showing 3 changed files with 60 additions and 15 deletions.
diff --git a/primer/src/Primer/Action.hs b/primer/src/Primer/Action.hs
@@ -1175,14 +1175,11 @@ toProgActionInput def0 sel0 opt0 = \case
     opt <- optGlobal
     toProg [ConstructSaturatedCon opt]
   Available.MakeInt -> do
-    opt <- optNoCxt
-    n <- maybeToEither (NeedInt opt0) $ readMaybe opt
+    n <- optInt
     toProg [ConstructPrim $ PrimInt n]
   Available.MakeChar -> do
-    opt <- optNoCxt
-    case T.uncons opt of
-      Just (c, r) | T.null r -> toProg [ConstructPrim $ PrimChar c]
-      _ -> Left $ NeedChar opt0
+    c <- optChar
+    toProg [ConstructPrim $ PrimChar c]
   Available.MakeVar ->
     toProg [ConstructVar optVar]
   Available.MakeVarSat -> do
@@ -1203,9 +1200,21 @@ toProgActionInput def0 sel0 opt0 = \case
   Available.AddBranch -> do
     opt <- optGlobal
     toProg [AddCaseBranch opt]
+  Available.AddBranchInt -> do
+    n <- optInt
+    toProg [AddCaseBranchPrim $ PrimInt n]
+  Available.AddBranchChar -> do
+    c <- optChar
+    toProg [AddCaseBranchPrim $ PrimChar c]
   Available.DeleteBranch -> do
     opt <- optGlobal
     toProg [DeleteCaseBranch opt]
+  Available.DeleteBranchInt -> do
+    n <- optInt
+    toProg [DeleteCaseBranchPrim $ PrimInt n]
+  Available.DeleteBranchChar -> do
+    c <- optChar
+    toProg [DeleteCaseBranchPrim $ PrimChar c]
   Available.RenamePattern -> do
     opt <- optNoCxt
     toProg [RenameCaseBinding opt]
@@ -1290,6 +1299,14 @@ toProgActionInput def0 sel0 opt0 = \case
     conFieldSel = do
       (ty, s) <- conSel
       maybe (Left NeedTypeDefConsFieldSelection) (pure . (ty,s.con,)) s.field
+    optInt = do
+      opt <- optNoCxt
+      maybeToEither (NeedInt opt0) $ readMaybe opt
+    optChar = do
+      opt <- optNoCxt
+      case T.uncons opt of
+        Just (c, r) | T.null r -> pure c
+        _ -> Left $ NeedChar opt0
     toProg actions = do
       case sel0 of
         SelectionDef sel -> toProg' actions sel.def <$> maybeToEither NoNodeSelection sel.node

diff --git a/primer/src/Primer/Action/Available.hs b/primer/src/Primer/Action/Available.hs
@@ -59,7 +59,8 @@ import Primer.Core (
   GlobalName (baseName, qualifiedModule),
   ID,
   ModuleName (unModuleName),
-  Pattern (PatCon),
+  Pattern (PatCon, PatPrim),
+  PrimCon (PrimChar, PrimInt),
   Type,
   Type' (..),
   TypeMeta,
@@ -156,7 +157,11 @@ data InputAction
   | MakeLam
   | MakeLAM
   | AddBranch
+  | AddBranchInt
+  | AddBranchChar
   | DeleteBranch
+  | DeleteBranchInt
+  | DeleteBranchChar
   | RenamePattern
   | RenameLet
   | RenameLam
@@ -267,13 +272,14 @@ forExpr tydefs l expr =
         <> annotate
         <> [Input RenameLet]
     Case _ scrut brs fb ->
-      delete
-        <> annotate
-        <> case scrut ^? _exprMetaLens % _type % _Just % _synthed of
-          Just (TCon () t) | t == tInt -> []
-          Just (TCon () t) | t == tChar -> []
-          -- AddBranch and DeleteBranch only work for ADTs
-          _ -> munless (fb == CaseExhaustive) [Input AddBranch] <> munless (null brs) [Input DeleteBranch]
+      let (addBranch, deleteBranch) = case scrut ^? _exprMetaLens % _type % _Just % _synthed of
+            Just (TCon () t) | t == tInt -> (AddBranchInt, DeleteBranchInt)
+            Just (TCon () t) | t == tChar -> (AddBranchChar, DeleteBranchChar)
+            _ -> (AddBranch, DeleteBranch)
+       in delete
+            <> annotate
+            <> munless (fb == CaseExhaustive) [Input addBranch]
+            <> munless (null brs) [Input deleteBranch]
     _ ->
       delete
         <> annotate
@@ -448,12 +454,26 @@ options typeDefs defs cxt level def0 sel0 = \case
                 others = allBr \\ exist
              in pure $ noFree $ globalOpt <$> others
       _ -> Nothing
+  AddBranchInt -> pure Options{opts = [], free = FreeInt}
+  AddBranchChar -> pure Options{opts = [], free = FreeChar}
   DeleteBranch ->
     findNode >>= \case
       ExprNode (Case _ _ brs _) ->
         let exist = mapMaybe ((\case (PatCon c) -> Just c; _ -> Nothing) . caseBranchName) brs
          in pure $ noFree $ globalOpt <$> exist
       _ -> Nothing
+  DeleteBranchInt ->
+    findNode >>= \case
+      ExprNode (Case _ _ brs _) ->
+        let exist = mapMaybe ((\case (PatPrim (PrimInt i)) -> Just i; _ -> Nothing) . caseBranchName) brs
+         in pure $ noFree $ (\i -> Option (show i) Nothing) <$> exist
+      _ -> Nothing
+  DeleteBranchChar ->
+    findNode >>= \case
+      ExprNode (Case _ _ brs _) ->
+        let exist = mapMaybe ((\case (PatPrim (PrimChar c)) -> Just c; _ -> Nothing) . caseBranchName) brs
+         in pure $ noFree $ (\c -> Option (show c) Nothing) <$> exist
+      _ -> Nothing
   RenamePattern -> do
     CaseBindNode b <- findNode
     freeVar <$> genNames (Left $ b ^? _bindMeta % _type % _Just % _chkedAt)
@@ -600,7 +620,11 @@ sortByPriority l =
         MakeLam -> P.makeLambda
         MakeLAM -> P.makeTypeAbstraction
         AddBranch -> P.addBranch
+        AddBranchInt -> P.addBranch
+        AddBranchChar -> P.addBranch
         DeleteBranch -> P.deleteBranch
+        DeleteBranchInt -> P.deleteBranch
+        DeleteBranchChar -> P.deleteBranch
         RenamePattern -> P.rename
         RenameLet -> P.rename
         RenameLam -> P.rename

diff --git a/primer/test/Tests/Action/Available.hs b/primer/test/Tests/Action/Available.hs
@@ -29,7 +29,7 @@ import Hedgehog.Internal.Property (forAllWithT)
 import Hedgehog.Range qualified as Range
 import Optics (ix, toListOf, (%), (.~), (^..), _head)
 import Primer.Action (
-  ActionError (CaseBindsClash, NameCapture),
+  ActionError (CaseBindsClash, CaseBranchAlreadyExists, NameCapture),
   Movement (Child1, Child2),
   enterType,
   move,
@@ -76,6 +76,7 @@ import Primer.Core (
   ID,
   Kind (KFun, KType),
   ModuleName (ModuleName, unModuleName),
+  Pattern (PatPrim),
   Type,
   getID,
   mkSimpleModuleName,
@@ -362,6 +363,9 @@ tasty_available_actions_accepted = withTests 500 $
         (StudentProvided, (Left DefAlreadyExists{}, _)) -> do
           label "rename def name clash with entered name"
           annotate "ignoring def already exists error as was generated name, not offered one"
+        (StudentProvided, (Left (ActionError (CaseBranchAlreadyExists (PatPrim _))), _)) -> do
+          label "add duplicate primitive case branch"
+          annotate "ignoring CaseBranchAlreadyExistsPrim error as was generated constructor"
         (_, (Left err, _)) -> annotateShow err >> failure
         (_, (Right _, a'')) -> ensureSHNormal a''
     ensureSHNormal a = case checkAppWellFormed a of