From 6d15e60aa0eb6e663aa4d93a2d232db4dd181c2a Mon Sep 17 00:00:00 2001 From: Ben Price Date: Wed, 13 Apr 2022 13:41:49 +0100 Subject: [PATCH 1/2] refactor: newtype ModuleName This makes renaming modules a lot slicker, as we can do more generically. --- primer/src/Primer/App.hs | 8 ++++---- primer/src/Primer/Builtins.hs | 3 ++- primer/src/Primer/Core.hs | 11 +++++++---- primer/src/Primer/Primitives.hs | 3 ++- primer/src/Primer/Typecheck.hs | 5 +++-- primer/test/Gen/Core/Raw.hs | 5 +++-- primer/test/TestUtils.hs | 4 ++-- primer/test/Tests/Action/Available.hs | 3 ++- primer/test/Tests/Action/Prog.hs | 27 ++++----------------------- 9 files changed, 29 insertions(+), 40 deletions(-) diff --git a/primer/src/Primer/App.hs b/primer/src/Primer/App.hs index 4d7145bce..986930d35 100644 --- a/primer/src/Primer/App.hs +++ b/primer/src/Primer/App.hs @@ -103,7 +103,7 @@ import Primer.Core ( ID (..), LocalName (LocalName, unLocalName), Meta (..), - ModuleName, + ModuleName (unModuleName), TmVarRef (GlobalVarRef, LocalVarRef), TyConName, TyVarName, @@ -534,7 +534,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 +581,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 +635,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 diff --git a/primer/src/Primer/Builtins.hs b/primer/src/Primer/Builtins.hs index 7d142e000..088d3169c 100644 --- a/primer/src/Primer/Builtins.hs +++ b/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 diff --git a/primer/src/Primer/Core.hs b/primer/src/Primer/Core.hs index fecb31d5c..03b057e2b 100644 --- a/primer/src/Primer/Core.hs +++ b/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 diff --git a/primer/src/Primer/Primitives.hs b/primer/src/Primer/Primitives.hs index f652ae9dc..9c6231b13 100644 --- a/primer/src/Primer/Primitives.hs +++ b/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 diff --git a/primer/src/Primer/Typecheck.hs b/primer/src/Primer/Typecheck.hs index 3e6a0de16..3556aabd7 100644 --- a/primer/src/Primer/Typecheck.hs +++ b/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 = diff --git a/primer/test/Gen/Core/Raw.hs b/primer/test/Gen/Core/Raw.hs index bb7c815cd..88d57a9e4 100644 --- a/primer/test/Gen/Core/Raw.hs +++ b/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 diff --git a/primer/test/TestUtils.hs b/primer/test/TestUtils.hs index 8fa26342c..50af59cc6 100644 --- a/primer/test/TestUtils.hs +++ b/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 diff --git a/primer/test/Tests/Action/Available.hs b/primer/test/Tests/Action/Available.hs index b10cbde6d..b25825416 100644 --- a/primer/test/Tests/Action/Available.hs +++ b/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 -> diff --git a/primer/test/Tests/Action/Prog.hs b/primer/test/Tests/Action/Prog.hs index 2a75d438a..1e0a9737f 100644 --- a/primer/test/Tests/Action/Prog.hs +++ b/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, @@ -1125,26 +1125,7 @@ defaultFullProg = do -- 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 + renameMod fromName toName = transformBi $ \n -> if n == fromName then toName else n findTypeDef :: TyConName -> Prog -> IO ASTTypeDef findTypeDef d p = maybe (assertFailure "couldn't find typedef") pure $ (typeDefAST <=< Map.lookup d) $ p ^. (#progModule % to moduleTypesQualified) @@ -1249,7 +1230,7 @@ mainModuleName :: ModuleName mainModuleName = moduleName $ progModule newEmptyProg mainModuleNameText :: Text -mainModuleNameText = unName mainModuleName +mainModuleNameText = unName $ unModuleName mainModuleName moveToDef :: Name -> ProgAction moveToDef = MoveToDef . qualifyName mainModuleName From b361c38a4cdaafcf1b21f5a5eaa4db310fec5731 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Wed, 13 Apr 2022 14:41:33 +0100 Subject: [PATCH 2/2] feat: action to rename the editable module The reason for the slightly convoluted implementation is that I am looking forward to when we have multiple editable modules, where we need to edit multiple modules (as they all may contain references to the renamed module). A potential optimisation is only checking for name clashes with imports and not rewriting theose modules, since we do not support renaming imports, and imports cannot depend on the editable module. I also take the chance to simplify the test code which does module renaming, now that the idea has been properly implemented in the library, with name clash detection. It is not worth making the library more complex or exposing an "unsafe" version for one use in testsuite (which intentionally clashes names, in order to merge modules). --- primer/src/Primer/Action.hs | 2 ++ primer/src/Primer/App.hs | 28 ++++++++++++++++++++++++++- primer/src/Primer/Module.hs | 13 +++++++++++++ primer/test/Tests/Action/Prog.hs | 33 ++++++++++++++++++++++---------- 4 files changed, 65 insertions(+), 11 deletions(-) diff --git a/primer/src/Primer/Action.hs b/primer/src/Primer/Action.hs index 9e4e350c4..2a0af9c6a 100644 --- a/primer/src/Primer/Action.hs +++ b/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 diff --git a/primer/src/Primer/App.hs b/primer/src/Primer/App.hs index 986930d35..fc7239c03 100644 --- a/primer/src/Primer/App.hs +++ b/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 (unModuleName), + 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 @@ -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 diff --git a/primer/src/Primer/Module.hs b/primer/src/Primer/Module.hs index 6ee87d80d..183e6dbc9 100644 --- a/primer/src/Primer/Module.hs +++ b/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 diff --git a/primer/test/Tests/Action/Prog.hs b/primer/test/Tests/Action/Prog.hs index 1e0a9737f..9f12f5fa6 100644 --- a/primer/test/Tests/Action/Prog.hs +++ b/primer/test/Tests/Action/Prog.hs @@ -1111,21 +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 = transformBi $ \n -> if n == fromName then toName else n findTypeDef :: TyConName -> Prog -> IO ASTTypeDef findTypeDef d p = maybe (assertFailure "couldn't find typedef") pure $ (typeDefAST <=< Map.lookup d) $ p ^. (#progModule % to moduleTypesQualified) @@ -1177,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