Implement renaming of modules in packages

cardano-foundation · Oct 20, 2023 · 7f0a22b · 7f0a22b
1 parent c92bb4d
commit 7f0a22b
Show file tree

Hide file tree

Showing 7 changed files with 83 additions and 28 deletions.
diff --git a/lib/fine-types/src/Language/FineTypes/Package/Compile.hs b/lib/fine-types/src/Language/FineTypes/Package/Compile.hs
@@ -16,6 +16,7 @@ import Control.Monad.Trans.Except
     , throwE
     , withExceptT
     )
+import Data.Maybe (fromMaybe)
 import Data.TreeDiff (ToExpr)
 import GHC.Generics (Generic)
 import Language.FineTypes.Module (ModuleName, moduleName)
@@ -108,16 +109,17 @@ execStatement dir pkg (Include includeName source) = do
                 description
     exceptT (ErrIncludePackage includeName)
         $ includePackage include pkg
-execStatement dir pkg (Module modName source) = do
+execStatement dir pkg (Module modName mOriginalName source) = do
     file <- loadSource dir source
+    let originalName = fromMaybe modName mOriginalName
     m <-
-        exceptT (ErrParseModuleError modName)
+        exceptT (ErrParseModuleError originalName)
             $ parseModule' file
     guardExceptT
-        (ErrAddModuleNameMismatch modName $ moduleName m)
-        $ modName == moduleName m
+        (ErrAddModuleNameMismatch originalName $ moduleName m)
+        $ originalName == moduleName m
     exceptT (ErrAddModule modName)
-        $ addModule m pkg
+        $ addModule modName m pkg
 execStatement dir pkg (Signature modName source) = do
     file <- loadSource dir source
     m <-

diff --git a/lib/fine-types/src/Language/FineTypes/Package/Content.hs b/lib/fine-types/src/Language/FineTypes/Package/Content.hs
@@ -105,11 +105,11 @@ data ErrAddModule
 
 instance ToExpr ErrAddModule
 
--- | Add a module to the current package if possible.
+-- | Add a module (under a given name) to the current 'Package' if possible.
 addModule
-    :: Module -> Package -> Either ErrAddModule Package
-addModule mo@Module{..} pkg@Package{packageModules}
-    | moduleName `Map.member` packageModules =
+    :: ModuleName -> Module -> Package -> Either ErrAddModule Package
+addModule name mo@Module{..} pkg@Package{packageModules}
+    | name `Map.member` packageModules =
         Left ErrModuleAlreadyInScope
     | not (Set.null invalidImports) =
         Left $ ErrImportNotInScope invalidImports
@@ -120,7 +120,7 @@ addModule mo@Module{..} pkg@Package{packageModules}
             Package
                 { packageModules =
                     Map.insert
-                        moduleName
+                        name
                         (Right moduleInstance)
                         packageModules
                 }

diff --git a/lib/fine-types/src/Language/FineTypes/Package/Description.hs b/lib/fine-types/src/Language/FineTypes/Package/Description.hs
@@ -26,7 +26,7 @@ instance ToExpr PackageDescription
 
 data Statement
     = Include PackageName Source
-    | Module ModuleName Source
+    | Module ModuleName (Maybe ModuleName) Source
     | Signature ModuleName Source
     | Assert Assertion
     deriving (Eq, Show, Generic)

diff --git a/lib/fine-types/src/Language/FineTypes/Package/Parser.hs b/lib/fine-types/src/Language/FineTypes/Package/Parser.hs
@@ -25,6 +25,7 @@ import Text.Megaparsec
     , Parsec
     , between
     , endBy
+    , optional
     , parse
     , takeWhileP
     , (<|>)
@@ -68,9 +69,11 @@ statements = statement `endBy` symbol ";"
 statement :: Parser Statement
 statement =
     (Include <$ symbol "include" <*> packageName <*> source)
-        <|> (Module <$ symbol "module" <*> moduleName <*> source)
+        <|> (Module <$ symbol "module" <*> moduleName <*> renaming <*> source)
         <|> (Signature <$ symbol "signature" <*> moduleName <*> source)
         <|> (Assert () <$ symbol "assert")
+  where
+    renaming = optional (symbol "renaming" *> moduleName)
 
 source :: Parser Source
 source =

diff --git a/lib/fine-types/test/Language/FineTypes/PackageSpec.hs b/lib/fine-types/test/Language/FineTypes/PackageSpec.hs
@@ -290,39 +290,54 @@ positiveOnPackageTest = do
                     )
                 ,
                     ( "X"
+                    , Right moduleInstanceX
+                    )
+                ,
+                    ( "Xoops"
+                    , Right moduleInstanceX
+                    )
+                ,
+                    ( "Y"
                     , Right
                         ( ModuleInstance
                             { content =
                                 Module
-                                    { moduleName = "X"
-                                    , moduleImports = []
+                                    { moduleName = "Y"
+                                    , moduleImports =
+                                        [
+                                            ( "X"
+                                            , ImportNames
+                                                { getImportNames =
+                                                    ["A", "B"]
+                                                }
+                                            )
+                                        ]
                                     , moduleDeclarations =
-                                        [ ("A", Zero Integer)
-                                        ,
-                                            ( "B"
+                                        [
+                                            ( "C"
                                             , Two
-                                                Sum2
-                                                (var moduleIdentityX "A")
-                                                (Zero Bytes)
+                                                Product2
+                                                (Zero Rational)
+                                                (var moduleIdentityX "B")
                                             )
                                         ]
                                     , moduleDocumentation =
                                         Documentation{getDocumentation = []}
                                     }
-                            , identity = moduleIdentityX
+                            , identity = moduleIdentityY
                             }
                         )
                     )
                 ,
-                    ( "Y"
+                    ( "Z"
                     , Right
                         ( ModuleInstance
                             { content =
                                 Module
-                                    { moduleName = "Y"
+                                    { moduleName = "Z"
                                     , moduleImports =
                                         [
-                                            ( "X"
+                                            ( "Xoops"
                                             , ImportNames
                                                 { getImportNames =
                                                     ["A", "B"]
@@ -333,24 +348,51 @@ positiveOnPackageTest = do
                                         [
                                             ( "C"
                                             , Two
-                                                Product2
-                                                (Zero Rational)
-                                                (var moduleIdentityX "B")
+                                                Sum2
+                                                (var moduleIdentityXoops "A")
+                                                (var moduleIdentityXoops "B")
                                             )
                                         ]
                                     , moduleDocumentation =
                                         Documentation{getDocumentation = []}
                                     }
-                            , identity = moduleIdentityY
+                            , identity = moduleIdentityZ
                             }
                         )
                     )
                 ]
             }
 
+    moduleInstanceX =
+        ( ModuleInstance
+            { content =
+                Module
+                    { moduleName = "X"
+                    , moduleImports = []
+                    , moduleDeclarations =
+                        [ ("A", Zero Integer)
+                        ,
+                            ( "B"
+                            , Two
+                                Sum2
+                                (var moduleIdentityX "A")
+                                (Zero Bytes)
+                            )
+                        ]
+                    , moduleDocumentation =
+                        Documentation{getDocumentation = []}
+                    }
+            , identity = moduleIdentityX
+            }
+        )
+
     var mid typname = Var (Just mid, typname)
 
     moduleIdentityX =
         Const "X"
+    moduleIdentityXoops =
+        moduleIdentityX
     moduleIdentityY =
         Apply (Const "Y") [Const "X"]
+    moduleIdentityZ =
+        Apply (Const "Z") [moduleIdentityXoops]
diff --git a/lib/fine-types/test/data/package/P2.fine b/lib/fine-types/test/data/package/P2.fine
@@ -2,3 +2,6 @@ package P2 where
 
 include P1 from "P1.fine";
 module Y from "Y.fine";
+
+module Xoops renaming X from "X.fine";
+module Z from "Z.fine";
diff --git a/lib/fine-types/test/data/package/Z.fine b/lib/fine-types/test/data/package/Z.fine
@@ -0,0 +1,5 @@
+module Z where
+
+import Xoops(A,B);
+
+C = A + B;