fix!: typedef actions detects all name clashes

Previously we did not consistently check our input names were fresh,
leading to some actions being accepted, only to later throw a
typechecker error. We now always check the new name is fresh, but for
ease of maintainability we collapse all such errors into one
category (previously we had both `ParamAlreadyExists` and
`TyConParamClash`). Instead of collapsing them, we could split out 5
different sorts of clashes (see comment on `TypeDefModifyNameClash` in
this commit), but this does not seem necessary -- as far as I know,
nobody actually wants to distinguish which of these 5 sorts of clashes
happened.

BREAKING CHANGE: this changes `ProgError`, which is serialised in the
richly-typed API (but not the OpenAPI -- they are converted into http
error codes instead).

Signed-off-by: Ben Price <[email protected]>

primer/src/Primer/Action/ProgError.hs

@@ -19,16 +19,22 @@ data ProgError
   | TypeDefNotFound TyConName
   | TypeDefAlreadyExists TyConName
   | TypeDefInUse TyConName
+  | -- | Cannot use a name twice in a type definition.
+    -- This includes
+    -- - clash between the type itself and a constructor
+    -- - clash between the type itself and a parameter
+    -- - clash between two constructors
+    -- - clash between two parameters
+    -- - clash between parameter and constructor
+    TypeDefModifyNameClash Name
   | TypeParamInUse TyConName TyVarName
   | ConNotFound ValConName
   | ConAlreadyExists ValConName
   | -- | We expected to see more arguments to a constructor than actually existed
     -- (this should never happen in a well-typed program)
     ConNotSaturated ValConName
   | ParamNotFound TyVarName
-  | ParamAlreadyExists TyVarName
   | NodeIDNotFound ID
-  | TyConParamClash Name
   | ValConParamClash Name
   | ActionError ActionError
   | EvalError EvalError

primer/src/Primer/App.hs

@@ -78,11 +78,16 @@ import Optics (
   Field1 (_1),
   Field2 (_2),
   Field3 (_3),
+  Fold,
   ReversibleOptic (re),
+  elemOf,
+  folded,
   ifoldMap,
   mapped,
   over,
   set,
+  summing,
+  to,
   traverseOf,
   traversed,
   view,
@@ -672,7 +677,7 @@ applyProgAction prog = \case
           -- To relax this, we'd have to be careful about how it interacts with type-checking of primitive literals.
           maybe (throwError $ TypeDefIsPrim old) pure . typeDefAST
             =<< maybe (throwError $ TypeDefNotFound old) pure (Map.lookup (baseName old) m)
-        when (nameRaw `elem` map (unLocalName . fst) (astTypeDefParameters d0)) $ throwError $ TyConParamClash nameRaw
+        assertFreshNameForTypeDef nameRaw (old, d0)
         pure $ Map.insert nameRaw (TypeDefAST d0) $ Map.delete (baseName old) m
       updateRefsInTypes =
         over
@@ -703,11 +708,14 @@ applyProgAction prog = \case
     where
       updateTypeDef =
         alterTypeDef
-          ( traverseOf
-              #astTypeDefConstructors
-              ( maybe (throwError $ ConNotFound old) pure
-                  . findAndAdjust ((== old) . valConName) (#valConName .~ new)
-              )
+          ( \td -> do
+              when (old /= new) $ assertFreshNameForTypeDef (baseName new) (type_, td)
+              traverseOf
+                #astTypeDefConstructors
+                ( maybe (throwError $ ConNotFound old) pure
+                    . findAndAdjust ((== old) . valConName) (#valConName .~ new)
+                )
+                td
           )
           type_
       updateDefs =
@@ -726,12 +734,10 @@ applyProgAction prog = \case
     where
       updateTypeDef =
         alterTypeDef
-          (updateConstructors <=< updateParam)
+          (updateConstructors <=< updateParam <=< \td -> td <$ when (old /= new) (assertFreshNameForTypeDef (unLocalName new) (type_, td)))
           type_
       updateParam def = do
-        when (new `elem` map fst (astTypeDefParameters def)) $ throwError $ ParamAlreadyExists new
         let nameRaw = unLocalName new
-        when (nameRaw == baseName type_) $ throwError $ TyConParamClash nameRaw
         when (nameRaw `elem` map (baseName . valConName) (astTypeDefConstructors def)) $ throwError $ ValConParamClash nameRaw
         def
           & traverseOf
@@ -768,9 +774,12 @@ applyProgAction prog = \case
         pure $ insertSubseqBy caseBranchName (CaseBranch (PatCon con) [] (EmptyHole m')) (PatCon . valConName <$> allCons) bs
       updateTypeDef =
         alterTypeDef
-          ( traverseOf
-              #astTypeDefConstructors
-              (maybe (throwError $ IndexOutOfRange index) pure . insertAt index (ValCon con []))
+          ( \td -> do
+              assertFreshNameForTypeDef (baseName con) (type_, td)
+              traverseOf
+                #astTypeDefConstructors
+                (maybe (throwError $ IndexOutOfRange index) pure . insertAt index (ValCon con []))
+                td
           )
           type_
   DeleteCon tdName vcName -> editModuleCross (qualifiedModule tdName) prog $ \(m, ms) -> do
@@ -872,12 +881,10 @@ applyProgAction prog = \case
       alterTypeDef
         ( \td -> do
             checkTypeNotInUse tdName td $ m : ms
+            assertFreshNameForTypeDef (unLocalName paramName) (tdName, td)
             traverseOf
               #astTypeDefParameters
               ( \ps -> do
-                  when
-                    (paramName `elem` map fst ps)
-                    (throwError $ ParamAlreadyExists paramName)
                   maybe (throwError $ IndexOutOfRange index) pure $ insertAt index (paramName, k) ps
               )
               td
@@ -1007,6 +1014,13 @@ applyProgAction prog = \case
     mdefName = case progSelection prog of
       Just (SelectionDef s) -> Just s.def
       _ -> Nothing
+    typeDefNames :: Fold (TyConName, ASTTypeDef a) Name
+    typeDefNames =
+      (_1 % to baseName)
+        `summing` (_2 % #astTypeDefParameters % folded % _1 % to unLocalName)
+        `summing` (_2 % #astTypeDefConstructors % folded % #valConName % to baseName)
+    assertFreshNameForTypeDef n tydef =
+      when (elemOf typeDefNames n tydef) $ throwError $ TypeDefModifyNameClash n
 
 -- Helper for RenameModule action
 data RenameMods a = RM {imported :: [a], editable :: [a]}

primer/test/Tests/Action/Available.hs

@@ -56,7 +56,13 @@ import Primer.App (
   NodeSelection (..),
   NodeType (..),
   Prog (..),
-  ProgError (ActionError, ConAlreadyExists, DefAlreadyExists, ParamAlreadyExists, TypeDefAlreadyExists),
+  ProgError (
+    ActionError,
+    ConAlreadyExists,
+    DefAlreadyExists,
+    TypeDefAlreadyExists,
+    TypeDefModifyNameClash
+  ),
   Selection' (..),
   TypeDefConsSelection (TypeDefConsSelection),
   TypeDefNodeSelection (TypeDefConsNodeSelection, TypeDefParamNodeSelection),
@@ -455,7 +461,7 @@ tasty_available_actions_accepted = withTests 500 $
           pure ()
         (StudentProvided, (Left (ConAlreadyExists _), _)) -> do
           pure ()
-        (StudentProvided, (Left (ParamAlreadyExists _), _)) -> do
+        (StudentProvided, (Left (TypeDefModifyNameClash _), _)) -> do
           pure ()
         (_, (Left err, _)) -> annotateShow err >> failure
         (_, (Right _, a'')) -> ensureSHNormal a''

primer/test/Tests/Action/Prog.hs

@@ -985,7 +985,7 @@ unit_RenameTypeParam_clash =
   progActionTest
     (defaultProgEditableTypeDefs $ pure [])
     [RenameTypeParam tT "a" "b"]
-    $ expectError (@?= ParamAlreadyExists "b")
+    $ expectError (@?= TypeDefModifyNameClash "b")
 
 unit_AddCon :: Assertion
 unit_AddCon =