From cf1baee5236d49058bc1165f471e99b7ce02e1c9 Mon Sep 17 00:00:00 2001
From: Mitchell Rosen <mitchellwrosen@gmail.com>
Date: Wed, 26 Jun 2024 15:31:30 -0400
Subject: [PATCH] add debug.alias.type.force

---
 .../src/Unison/Codebase/Editor/HandleInput.hs | 10 ++---
 .../src/Unison/Codebase/Editor/Input.hs       |  2 +-
 .../src/Unison/CommandLine/InputPatterns.hs   | 24 ++++++++--
 unison-src/transcripts/alias-type.md          | 28 ++++++++++++
 unison-src/transcripts/alias-type.output.md   | 44 +++++++++++++++++++
 5 files changed, 98 insertions(+), 10 deletions(-)
 create mode 100644 unison-src/transcripts/alias-type.md
 create mode 100644 unison-src/transcripts/alias-type.output.md

diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
index 45efd7b33..639eaa27e 100644
--- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
+++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
@@ -494,7 +494,7 @@ loop e = do
               description <- inputDescription input
               Cli.stepAt description (BranchUtil.makeAddTermName (first Path.unabsolute dest) srcTerm)
               Cli.respond Success
-            AliasTypeI src' dest' -> do
+            AliasTypeI force src' dest' -> do
               src <- traverseOf _Right Cli.resolveSplit' src'
               srcTypes <-
                 either
@@ -512,7 +512,7 @@ loop e = do
                       pure (DeleteNameAmbiguous hqLength name Set.empty srcTypes)
               dest <- Cli.resolveSplit' dest'
               destTypes <- Cli.getTypesAt (HQ'.NameOnly <$> dest)
-              when (not (Set.null destTypes)) do
+              when (not force && not (Set.null destTypes)) do
                 Cli.returnEarly (TypeAlreadyExists dest' destTypes)
               description <- inputDescription input
               Cli.stepAt description (BranchUtil.makeAddTypeName (first Path.unabsolute dest) srcType)
@@ -980,11 +980,11 @@ inputDescription input =
     AliasTermI force src0 dest0 -> do
       src <- hhqs' src0
       dest <- ps' dest0
-      pure ((if force then "alias.term.force " else "alias.term ") <> src <> " " <> dest)
-    AliasTypeI src0 dest0 -> do
+      pure ((if force then "debug.alias.term.force " else "alias.term ") <> src <> " " <> dest)
+    AliasTypeI force src0 dest0 -> do
       src <- hhqs' src0
       dest <- ps' dest0
-      pure ("alias.type " <> src <> " " <> dest)
+      pure ((if force then "debug.alias.type.force " else "alias.term ") <> src <> " " <> dest)
     AliasManyI srcs0 dest0 -> do
       srcs <- traverse hqs srcs0
       dest <- p' dest0
diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs
index 8dc38bb14..86ecb3849 100644
--- a/unison-cli/src/Unison/Codebase/Editor/Input.hs
+++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs
@@ -133,7 +133,7 @@ data Input
     -- > names #sdflkjsdfhsdf
     NamesI IsGlobal (HQ.HashQualified Name)
   | AliasTermI !Bool HashOrHQSplit' Path.Split' -- bool = force?
-  | AliasTypeI HashOrHQSplit' Path.Split'
+  | AliasTypeI !Bool HashOrHQSplit' Path.Split' -- bool = force?
   | AliasManyI [Path.HQSplit] Path'
   | MoveAllI Path.Path' Path.Path'
   | -- Move = Rename; It's an HQSplit' not an HQSplit', meaning the arg has to have a name.
diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs
index 7b395659a..31fcd41ae 100644
--- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs
+++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs
@@ -1392,8 +1392,8 @@ aliasTerm =
         _ -> Left . warn $ P.wrap "`alias.term` takes two arguments, like `alias.term oldname newname`."
     }
 
-aliasTermForce :: InputPattern
-aliasTermForce =
+debugAliasTermForce :: InputPattern
+debugAliasTermForce =
   InputPattern
     { patternName = "debug.alias.term.force",
       aliases = [],
@@ -1416,9 +1416,24 @@ aliasType =
     [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)]
     "`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`."
     \case
-      [oldName, newName] -> Input.AliasTypeI <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName
+      [oldName, newName] -> Input.AliasTypeI False <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName
       _ -> Left . warn $ P.wrap "`alias.type` takes two arguments, like `alias.type oldname newname`."
 
+debugAliasTypeForce :: InputPattern
+debugAliasTypeForce =
+  InputPattern
+    { patternName = "debug.alias.type.force",
+      aliases = [],
+      visibility = I.Hidden,
+      args = [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)],
+      help = "`debug.alias.type.force Foo Bar` introduces `Bar` with the same definition as `Foo`.",
+      parse = \case
+        [oldName, newName] -> Input.AliasTypeI True <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName
+        _ ->
+          Left . warn $
+            P.wrap "`debug.alias.type.force` takes two arguments, like `debug.alias.type.force oldname newname`."
+    }
+
 aliasMany :: InputPattern
 aliasMany =
   InputPattern
@@ -3299,7 +3314,6 @@ validInputs =
     [ add,
       aliasMany,
       aliasTerm,
-      aliasTermForce,
       aliasType,
       api,
       authLogin,
@@ -3313,6 +3327,8 @@ validInputs =
       clone,
       compileScheme,
       createAuthor,
+      debugAliasTermForce,
+      debugAliasTypeForce,
       debugClearWatchCache,
       debugDoctor,
       debugDumpNamespace,
diff --git a/unison-src/transcripts/alias-type.md b/unison-src/transcripts/alias-type.md
new file mode 100644
index 000000000..b167daa2c
--- /dev/null
+++ b/unison-src/transcripts/alias-type.md
@@ -0,0 +1,28 @@
+`alias.type` makes a new name for a type.
+
+```ucm:hide
+project/main> builtins.mergeio lib.builtins
+```
+
+```ucm
+project/main> alias.type lib.builtins.Nat Foo
+project/main> ls
+```
+
+It won't create a conflicted name, though.
+
+```ucm:error
+project/main> alias.type lib.builtins.Int Foo
+```
+
+```ucm
+project/main> ls
+```
+
+You can use `debug.alias.type.force` for that.
+
+```ucm
+project/main> debug.alias.type.force lib.builtins.Int Foo
+project/main> ls
+```
+
diff --git a/unison-src/transcripts/alias-type.output.md b/unison-src/transcripts/alias-type.output.md
new file mode 100644
index 000000000..820c81761
--- /dev/null
+++ b/unison-src/transcripts/alias-type.output.md
@@ -0,0 +1,44 @@
+`alias.type` makes a new name for a type.
+
+```ucm
+project/main> alias.type lib.builtins.Nat Foo
+
+  Done.
+
+project/main> ls
+
+  1. Foo  (builtin type)
+  2. lib/ (643 terms, 92 types)
+
+```
+It won't create a conflicted name, though.
+
+```ucm
+project/main> alias.type lib.builtins.Int Foo
+
+  ⚠️
+  
+  A type by that name already exists.
+
+```
+```ucm
+project/main> ls
+
+  1. Foo  (builtin type)
+  2. lib/ (643 terms, 92 types)
+
+```
+You can use `debug.alias.type.force` for that.
+
+```ucm
+project/main> debug.alias.type.force lib.builtins.Int Foo
+
+  Done.
+
+project/main> ls
+
+  1. Foo  (builtin type)
+  2. Foo  (builtin type)
+  3. lib/ (643 terms, 92 types)
+
+```