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 4d7145bce..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, + 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 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/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/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..9f12f5fa6 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, @@ -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