merge-queue: embarking main (5f8b303) and #379 together

primer/src/Primer/Action.hs

@@ -422,6 +422,8 @@ data ProgAction
     --   At the start of the actions, the cursor starts at the root of the definition's type/expression
     CopyPasteSig (GVarName, ID) [Action]
   | CopyPasteBody (GVarName, ID) [Action]
+  | -- | Renames the sole editable module
+    RenameModule Text
   deriving (Eq, Show, Generic)
   deriving (FromJSON, ToJSON) via VJSON ProgAction
 

primer/src/Primer/App.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLabels #-}
@@ -103,7 +104,7 @@ import Primer.Core (
   ID (..),
   LocalName (LocalName, unLocalName),
   Meta (..),
-  ModuleName,
+  ModuleName (ModuleName, unModuleName),
   TmVarRef (GlobalVarRef, LocalVarRef),
   TyConName,
   TyVarName,
@@ -144,6 +145,7 @@ import Primer.Module (
   mkTypeDefMap,
   moduleDefsQualified,
   moduleTypesQualified,
+  renameModule,
  )
 import Primer.Name (Name (unName), NameCounter, freshName, unsafeMkName)
 import Primer.Primitives (primitiveModule)
@@ -343,6 +345,8 @@ data ProgError
     --    https://github.com/hackworthltd/primer/issues/3)
     TypeDefError Text
   | IndexOutOfRange Int
+  | -- | Cannot rename a module to the same name as some other module
+    RenameModuleNameClash
   deriving (Eq, Show, Generic)
   deriving (FromJSON, ToJSON) via VJSON ProgError
 
@@ -534,7 +538,7 @@ applyProgAction prog mdefName = \case
     -- so we just dump out a raw string for debugging/logging purposes
     let m = moduleName $ progModule prog
     unless (m == qualifiedModule (astTypeDefName td)) $
-      throwError $ TypeDefError $ "Cannot create a type definition with incorrect module name: expected " <> unName m
+      throwError $ TypeDefError $ "Cannot create a type definition with incorrect module name: expected " <> unName (unModuleName m)
     (addTypeDef td prog, mdefName)
       <$ liftError
         -- The frontend should never let this error case happen,
@@ -581,7 +585,7 @@ applyProgAction prog mdefName = \case
           #astDefExpr
           $ transform $ over typesInExpr $ transform $ over (#_TCon % _2) updateName
       updateName n = if n == old then new else n
-  RenameCon type_ old (unsafeMkGlobalName . (unName (qualifiedModule type_),) -> new) ->
+  RenameCon type_ old (unsafeMkGlobalName . (unName (unModuleName (qualifiedModule type_)),) -> new) ->
     (,Nothing) <$> do
       when (new `elem` allConNames prog) $ throwError $ ConAlreadyExists new
       traverseOf
@@ -635,7 +639,7 @@ applyProgAction prog mdefName = \case
           )
           $ over _freeVarsTy $ \(_, v) -> TVar () $ updateName v
       updateName n = if n == old then new else n
-  AddCon type_ index (unsafeMkGlobalName . (unName (qualifiedModule type_),) -> con) ->
+  AddCon type_ index (unsafeMkGlobalName . (unName (unModuleName (qualifiedModule type_)),) -> con) ->
     (,Nothing)
       <$> do
         when (con `elem` allConNames prog) $ throwError $ ConAlreadyExists con
@@ -814,6 +818,28 @@ applyProgAction prog mdefName = \case
   CopyPasteBody fromIds setup -> case mdefName of
     Nothing -> throwError NoDefSelected
     Just i -> (,mdefName) <$> copyPasteBody prog fromIds i setup
+  RenameModule newName ->
+    let n = ModuleName $ unsafeMkName newName
+        oldName = moduleName $ progModule prog
+        curMods = RM{imported = progImports prog, editable = progModule prog}
+     in if n == oldName
+          then pure (prog, Nothing)
+          else case renameModule oldName n curMods of
+            Nothing -> throwError RenameModuleNameClash
+            Just renamedMods ->
+              if imported curMods == imported renamedMods
+                then pure . (,Nothing) $ prog & #progModule .~ editable renamedMods
+                else
+                  throwError $
+                    -- It should never happen that the action edits an
+                    -- imported module, since the oldName should be distinct
+                    -- from the name of any import
+                    ActionError $
+                      InternalFailure "RenameModule: imported modules were edited by renaming"
+
+-- Helper for RenameModule action
+data RenameMods a = RM {imported :: [a], editable :: a}
+  deriving (Functor, Foldable, Traversable)
 
 -- Look up the definition by its given Name, then run the given action with it
 -- only looks in the editable module

primer/src/Primer/Builtins.hs

@@ -41,6 +41,7 @@ import Primer.Core (
   ),
   GlobalName,
   Kind (KType),
+  ModuleName,
   TyConName,
   Type' (TApp, TCon, TVar),
   TypeDef (TypeDefAST),
@@ -51,7 +52,7 @@ import Primer.Core (
 import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), mkTypeDefMap)
 import Primer.Name (Name)
 
-builtinModuleName :: Name
+builtinModuleName :: ModuleName
 builtinModuleName = "Builtins"
 
 builtin :: Name -> GlobalName k

primer/src/Primer/Core.hs

@@ -26,7 +26,7 @@ module Primer.Core (
   setID,
   HasMetadata (_metadata),
   ID (ID),
-  ModuleName,
+  ModuleName (ModuleName, unModuleName),
   GlobalNameKind (..),
   GlobalName (qualifiedModule, baseName),
   qualifyName,
@@ -165,7 +165,10 @@ _synthed = #_TCSynthed `afailing` (#_TCEmb % #tcSynthed)
 -- nodes we're inserting.
 type ExprMeta = Meta (Maybe TypeCache)
 
-type ModuleName = Name
+newtype ModuleName = ModuleName {unModuleName :: Name}
+  deriving (Eq, Ord, Show, Data, Generic)
+  deriving (IsString) via Name
+  deriving (FromJSON, ToJSON) via Name
 
 -- | Tags for 'GlobalName'
 data GlobalNameKind
@@ -187,9 +190,9 @@ instance ToJSON (GlobalName k)
 -- | Construct a name from a Text. This is called unsafe because there are no
 -- guarantees about whether the name refers to anything that is in scope.
 unsafeMkGlobalName :: (Text, Text) -> GlobalName k
-unsafeMkGlobalName (m, n) = GlobalName (unsafeMkName m) (unsafeMkName n)
+unsafeMkGlobalName (m, n) = GlobalName (ModuleName $ unsafeMkName m) (unsafeMkName n)
 
-qualifyName :: Name -> Name -> GlobalName k
+qualifyName :: ModuleName -> Name -> GlobalName k
 qualifyName = GlobalName
 
 type TyConName = GlobalName 'ATyCon

primer/src/Primer/Module.hs

@@ -7,9 +7,11 @@ module Primer.Module (
   moduleDefsQualified,
   insertDef,
   deleteDef,
+  renameModule,
 ) where
 
 import Data.Data (Data)
+import Data.Generics.Uniplate.Data (transformBi)
 import Data.Map (delete, insert, mapKeys, member)
 import qualified Data.Map as M
 import Foreword
@@ -67,3 +69,14 @@ deleteDef m d =
   if d `member` moduleDefsQualified m
     then Just $ m{moduleDefs = delete (baseName d) (moduleDefs m)}
     else Nothing
+
+-- | Renames a module and any references to it (in the given 'Traversable' of
+-- modules). Returns 'Nothing' if the requested new name is in use
+-- (as the name of one of the modules, references are not detected)
+renameModule :: Traversable t => ModuleName -> ModuleName -> t Module -> Maybe (t Module)
+renameModule fromName toName = traverse rn1
+  where
+    rn1 m =
+      if moduleName m == toName
+        then Nothing
+        else pure $ transformBi (\n -> if n == fromName then toName else n) m

primer/src/Primer/Primitives.hs

@@ -29,6 +29,7 @@ import Primer.Core (
   ExprAnyFresh (..),
   GVarName,
   GlobalName (baseName),
+  ModuleName,
   PrimCon (..),
   PrimDef (PrimDef, primDefName, primDefType),
   PrimFun (..),
@@ -55,7 +56,7 @@ import Primer.Core.DSL (
 import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes))
 import Primer.Name (Name)
 
-primitiveModuleName :: Name
+primitiveModuleName :: ModuleName
 primitiveModuleName = "Primitives"
 
 primitive :: Name -> GlobalName k

primer/src/Primer/Typecheck.hs

@@ -113,6 +113,7 @@ import Primer.Core (
   typeDefName,
   typeDefParameters,
   unLocalName,
+  unModuleName,
   valConType,
   _exprMeta,
   _exprTypeMeta,
@@ -440,11 +441,11 @@ checkEverything sh CheckEverything{trusted, toCheck} =
         -- Check the type definitions have the right modules
         for_ toCheck $ \m -> flip Map.traverseWithKey (moduleTypes m) $ \n td ->
           unless (qualifyTyConName m n == typeDefName td) $
-            throwError' $ InternalError $ "Inconsistant names in moduleTypes for module " <> unName (moduleName m)
+            throwError' $ InternalError $ "Inconsistant names in moduleTypes for module " <> unName (unModuleName $ moduleName m)
         -- Check that the definition map has the right keys
         for_ toCheck $ \m -> flip Map.traverseWithKey (moduleDefs m) $ \n d ->
           unless (qualifyDefName m n == defName d) $
-            throwError' $ InternalError $ "Inconsistant names in moduleDefs map for module " <> unName (moduleName m)
+            throwError' $ InternalError $ "Inconsistant names in moduleDefs map for module " <> unName (unModuleName $ moduleName m)
         checkTypeDefs $ foldMap moduleTypesQualified toCheck
         let newTypes = foldMap moduleTypesQualified toCheck
             newDefs =

primer/test/Gen/Core/Raw.hs

@@ -33,6 +33,7 @@ import Primer.Core (
   LVarName,
   LocalName (LocalName),
   Meta (..),
+  ModuleName (ModuleName),
   PrimCon (..),
   TmVarRef (..),
   TyConName,
@@ -85,8 +86,8 @@ genApp = App <$> genMeta <*> genExpr <*> genExpr
 genAPP :: ExprGen Expr
 genAPP = APP <$> genMeta <*> genExpr <*> genType
 
-genModuleName :: MonadGen m => m Name
-genModuleName = Gen.frequency [(9, pure "M"), (1, genName)]
+genModuleName :: MonadGen m => m ModuleName
+genModuleName = ModuleName <$> Gen.frequency [(9, pure "M"), (1, genName)]
 
 genValConName :: ExprGen ValConName
 genValConName = qualifyName <$> genModuleName <*> genName

primer/test/TestUtils.hs

@@ -18,7 +18,7 @@ import Primer.Core (
   GVarName,
   GlobalName (baseName, qualifiedModule),
   ID,
-  ModuleName,
+  ModuleName (unModuleName),
   PrimDef (..),
   TyConName,
   ValConName,
@@ -48,7 +48,7 @@ constructRefinedCon :: ValConName -> Action
 constructRefinedCon = ConstructRefinedCon . toQualText
 
 toQualText :: GlobalName k -> (Text, Text)
-toQualText n = (unName $ qualifiedModule n, unName $ baseName n)
+toQualText n = (unName $ unModuleName $ qualifiedModule n, unName $ baseName n)
 
 vcn :: ModuleName -> Name -> ValConName
 vcn = qualifyName

primer/test/Tests/Action/Available.hs

@@ -18,6 +18,7 @@ import Primer.Core (
   HasID (_id),
   ID,
   Kind (KType),
+  ModuleName (unModuleName),
   _exprMeta,
   _exprTypeMeta,
   _typeMeta,
@@ -169,7 +170,7 @@ data Output = Output
 mkTests :: ASTDef -> TestTree
 mkTests def =
   let defName = astDefName def
-      testName = T.unpack $ unName (qualifiedModule defName) <> "." <> unName (baseName defName)
+      testName = T.unpack $ unName (unModuleName $ qualifiedModule defName) <> "." <> unName (baseName defName)
    in testGroup testName $
         enumerate
           <&> \level ->

primer/test/Tests/Action/Prog.hs

@@ -53,11 +53,11 @@ import Primer.Core (
   Expr,
   Expr' (..),
   GVarName,
-  GlobalName (baseName, qualifiedModule),
+  GlobalName (baseName),
   ID (ID),
   Kind (KType),
   Meta (..),
-  ModuleName,
+  ModuleName (unModuleName),
   TmVarRef (..),
   TyConName,
   Type,
@@ -1111,40 +1111,12 @@ defaultFullProg = do
   let m = moduleName $ progModule p
       -- We need to move the primitives, which requires renaming
       -- unit_defaultFullModule_no_clash ensures that there will be no clashes
-      renamed =
-        renameMod (moduleName primitiveModule) m $
-          renameMod (moduleName builtinModule) m [builtinModule, primitiveModule]
+      renamed = transformBi (const m) [builtinModule, primitiveModule]
       renamedTypes = renamed ^.. folded % #moduleTypes % folded
       renamedDefs = foldOf (folded % #moduleDefs) renamed
   pure $
     p & #progModule % #moduleTypes %~ (mkTypeDefMap renamedTypes <>)
       & #progModule % #moduleDefs %~ (renamedDefs <>)
-  where
-    renameMod :: ModuleName -> ModuleName -> [Module] -> [Module]
-    -- Caution: if we expose something similar as an action, we would need a
-    -- test for duplicate module names similar to this for safety, but that
-    -- would get in the way for our testing purposes here.
-    --  | any ((== to).moduleName) mods = error "clashing name"
-    renameMod fromName toName = map rnMod
-      where
-        rnMod (m :: Module) =
-          transformBi rnRef1 $
-            transformBi rnRef2 $
-              transformBi rnRef3 $
-                over #moduleName rnName m
-        rnName n = if n == fromName then toName else n
-        -- We have to be careful here, as ModuleName = Name, and we don't want
-        -- to transform Names inside LocalName etc!
-        -- TODO: perhaps ModuleName should be its own type?
-        -- Annoyingly we cannot do this in one pass of transformBi, as it cannot
-        -- take a function of type GlobalName k -> GlobalName k and act on all
-        -- instances of k at once.
-        rnRef1 :: GVarName -> GVarName
-        rnRef1 qn = qn & #qualifiedModule %~ rnName
-        rnRef2 :: TyConName -> TyConName
-        rnRef2 qn = qn & #qualifiedModule %~ rnName
-        rnRef3 :: ValConName -> ValConName
-        rnRef3 qn = qn & #qualifiedModule %~ rnName
 
 findTypeDef :: TyConName -> Prog -> IO ASTTypeDef
 findTypeDef d p = maybe (assertFailure "couldn't find typedef") pure $ (typeDefAST <=< Map.lookup d) $ p ^. (#progModule % to moduleTypesQualified)
@@ -1196,6 +1168,28 @@ unit_defaultFullProg_no_clash =
         assertBool "Expected every type making up defaultFullProg to have distinct names" $ not $ anySame typeNames
         assertBool "Expected every term making up defaultFullProg to have distinct names" $ not $ anySame termNames
 
+unit_rename_module :: Assertion
+unit_rename_module =
+  let test = do
+        importModules [builtinModule]
+        handleEditRequest [RenameModule "Module2"]
+      a = newEmptyApp
+   in case fst $ runAppTestM (ID $ appIdCounter a) a test of
+        Left err -> assertFailure $ show err
+        Right p -> moduleName (progModule p) @?= "Module2"
+
+unit_rename_module_clash :: Assertion
+unit_rename_module_clash =
+  let test = do
+        importModules [builtinModule]
+        handleEditRequest [RenameModule "Builtins"]
+      a = newEmptyApp
+   in do
+        moduleName builtinModule @?= "Builtins"
+        case fst $ runAppTestM (ID $ appIdCounter a) a test of
+          Left err -> err @?= RenameModuleNameClash
+          Right _ -> assertFailure "Expected RenameModule to error, since module names clash with prior import"
+
 _defIDs :: Traversal' ASTDef ID
 _defIDs = #astDefExpr % (_exprMeta % _id `adjoin` _exprTypeMeta % _id) `adjoin` #astDefType % _typeMeta % _id
 
@@ -1249,7 +1243,7 @@ mainModuleName :: ModuleName
 mainModuleName = moduleName $ progModule newEmptyProg
 
 mainModuleNameText :: Text
-mainModuleNameText = unName mainModuleName
+mainModuleNameText = unName $ unModuleName mainModuleName
 
 moveToDef :: Name -> ProgAction
 moveToDef = MoveToDef . qualifyName mainModuleName