feat!: hierarchical module names

primer-rel8/test/TestUtils.hs

@@ -67,6 +67,7 @@ import Primer.Core (
   GlobalName (baseName),
   ID,
   Kind (KType),
+  ModuleName (ModuleName),
   qualifyName,
  )
 import Primer.Core.DSL (
@@ -246,7 +247,7 @@ testASTDef :: ASTDef
 testASTDefNextID :: ID
 (testASTDef, testASTDefNextID) =
   ( ASTDef
-    { astDefName = qualifyName "TestModule" "1"
+    { astDefName = qualifyName (ModuleName $ "TestModule" :| []) "1"
     , astDefExpr
     , astDefType
     }
@@ -281,7 +282,7 @@ testASTDefNextID :: ID
                     (con cJust)
                 )
                 ( hole
-                    (gvar' "TestModule" "0")
+                    (gvar' ("TestModule" :| []) "0")
                 )
             )
             ( thole
@@ -364,7 +365,7 @@ testApp =
         { progImports = [builtinModule, primitiveModule]
         , progModule =
             Module
-              { moduleName = "TestModule"
+              { moduleName = ModuleName $ "TestModule" :| []
               , moduleTypes = mempty
               , moduleDefs = Map.singleton (baseName $ astDefName testASTDef) (DefAST testASTDef)
               }

primer-service/src/Primer/Server.hs

@@ -16,6 +16,7 @@ import Control.Monad.Catch (catch)
 import Control.Monad.Except (ExceptT (..))
 import Control.Monad.Reader (runReaderT)
 import Data.Function ((&))
+import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.OpenApi (OpenApi)
 import Data.Streaming.Network.Internal (HostPreference (HostIPv4Only))
 import Data.Text (Text)
@@ -76,6 +77,7 @@ import Primer.Core (
   ID,
   Kind (KFun, KType),
   LVarName,
+  ModuleName (ModuleName),
   TyVarName,
   Type,
   Type' (TEmptyHole),
@@ -330,14 +332,14 @@ testEndpoints =
     :<|> mkTest (TCBoth (TEmptyHole ()) (TEmptyHole ()))
     :<|> mkTest (create' (app emptyHole emptyHole))
     :<|> mkTest (create' $ case_ emptyHole [])
-    :<|> mkTest (create' $ case_ emptyHole [branch' ("M", "C") [("x", Nothing)] emptyHole])
+    :<|> mkTest (create' $ case_ emptyHole [branch' ("M" :| [], "C") [("x", Nothing)] emptyHole])
     :<|> mkTest (KFun KType KType)
     :<|> mkTest 0
     :<|> mkTest (Log [[BodyAction [Move Child1]]])
     :<|> mkTest newProg
-    :<|> mkTest (MoveToDef $ qualifyName "M" "main")
+    :<|> mkTest (MoveToDef $ qualifyName (ModuleName $ "M" :| []) "main")
     :<|> mkTest NoDefSelected
-    :<|> mkTest (DefAST $ ASTDef (qualifyName "M" "main") expr ty)
+    :<|> mkTest (DefAST $ ASTDef (qualifyName (ModuleName $ "M" :| []) "main") expr ty)
     :<|> mkTest boolDef
     :<|> mkTest EvalReq{evalReqExpr = expr, evalReqRedex = 0}
     :<|> mkTest EvalResp{evalRespExpr = expr, evalRespRedexes = [0, 1], evalRespDetail = reductionDetail}

primer/primer.cabal

@@ -131,6 +131,7 @@ test-suite primer-test
     GeneralizedNewtypeDeriving
     LambdaCase
     MultiParamTypeClasses
+    OverloadedLists
     OverloadedStrings
     ScopedTypeVariables
 

primer/src/Primer/Action.hs

@@ -248,7 +248,7 @@ uniquifyDefName m name' defs =
     avoid :: [Text]
     avoid = mapMaybe (f . defName) $ Map.elems defs
 
-type QualifiedText = (Text, Text)
+type QualifiedText = (NonEmpty Text, Text)
 
 -- | Core actions.
 --  These describe edits to the core AST.
@@ -423,7 +423,7 @@ data ProgAction
     CopyPasteSig (GVarName, ID) [Action]
   | CopyPasteBody (GVarName, ID) [Action]
   | -- | Renames the sole editable module
-    RenameModule Text
+    RenameModule (NonEmpty Text)
   deriving (Eq, Show, Generic)
   deriving (FromJSON, ToJSON) via VJSON ProgAction
 

primer/src/Primer/App.hs

@@ -104,7 +104,7 @@ import Primer.Core (
   ID (..),
   LocalName (LocalName, unLocalName),
   Meta (..),
-  ModuleName (ModuleName, unModuleName),
+  ModuleName (ModuleName),
   TmVarRef (GlobalVarRef, LocalVarRef),
   TyConName,
   TyVarName,
@@ -118,9 +118,11 @@ import Primer.Core (
   defName,
   defPrim,
   getID,
+  moduleNamePretty,
   qualifyName,
   typeDefAST,
   typesInExpr,
+  unModuleName,
   unsafeMkGlobalName,
   unsafeMkLocalName,
   _exprMeta,
@@ -538,7 +540,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 (unModuleName m)
+      throwError $ TypeDefError $ "Cannot create a type definition with incorrect module name: expected " <> moduleNamePretty m
     (addTypeDef td prog, mdefName)
       <$ liftError
         -- The frontend should never let this error case happen,
@@ -585,7 +587,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 (unModuleName (qualifiedModule type_)),) -> new) ->
+  RenameCon type_ old (unsafeMkGlobalName . (fmap unName (unModuleName (qualifiedModule type_)),) -> new) ->
     (,Nothing) <$> do
       when (new `elem` allConNames prog) $ throwError $ ConAlreadyExists new
       traverseOf
@@ -639,7 +641,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 (unModuleName (qualifiedModule type_)),) -> con) ->
+  AddCon type_ index (unsafeMkGlobalName . (fmap unName (unModuleName (qualifiedModule type_)),) -> con) ->
     (,Nothing)
       <$> do
         when (con `elem` allConNames prog) $ throwError $ ConAlreadyExists con
@@ -819,7 +821,7 @@ applyProgAction prog mdefName = \case
     Nothing -> throwError NoDefSelected
     Just i -> (,mdefName) <$> copyPasteBody prog fromIds i setup
   RenameModule newName ->
-    let n = ModuleName $ unsafeMkName newName
+    let n = ModuleName $ unsafeMkName <$> newName
         oldName = moduleName $ progModule prog
         curMods = RM{imported = progImports prog, editable = progModule prog}
      in if n == oldName
@@ -963,12 +965,12 @@ newEmptyProg :: Prog
 newEmptyProg =
   let expr = EmptyHole (Meta 1 Nothing Nothing)
       ty = TEmptyHole (Meta 2 Nothing Nothing)
-      def = DefAST $ ASTDef (qualifyName "Main" "main") expr ty
+      def = DefAST $ ASTDef (qualifyName (ModuleName $ "Main" :| []) "main") expr ty
    in Prog
         { progImports = mempty
         , progModule =
             Module
-              { moduleName = "Main"
+              { moduleName = ModuleName $ "Main" :| []
               , moduleTypes = mempty
               , moduleDefs = Map.singleton (baseName $ defName def) def
               }
@@ -994,9 +996,9 @@ newProg =
     { progImports = [builtinModule, primitiveModule]
     , progModule =
         Module
-          { moduleName = "Main"
+          { moduleName = ModuleName $ "Main" :| []
           , moduleTypes = mempty
-          , moduleDefs = defaultDefs "Main"
+          , moduleDefs = defaultDefs $ ModuleName $ "Main" :| []
           }
     }
 

primer/src/Primer/Builtins.hs

@@ -41,7 +41,7 @@ import Primer.Core (
   ),
   GlobalName,
   Kind (KType),
-  ModuleName,
+  ModuleName (ModuleName),
   TyConName,
   Type' (TApp, TCon, TVar),
   TypeDef (TypeDefAST),
@@ -53,7 +53,7 @@ import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), mkTy
 import Primer.Name (Name)
 
 builtinModuleName :: ModuleName
-builtinModuleName = "Builtins"
+builtinModuleName = ModuleName $ "Builtins" :| []
 
 builtin :: Name -> GlobalName k
 builtin = qualifyName builtinModuleName

primer/src/Primer/Core.hs

@@ -27,6 +27,7 @@ module Primer.Core (
   HasMetadata (_metadata),
   ID (ID),
   ModuleName (ModuleName, unModuleName),
+  moduleNamePretty,
   GlobalNameKind (..),
   GlobalName (qualifiedModule, baseName),
   qualifyName,
@@ -101,7 +102,7 @@ import Optics (
   _4,
  )
 import Primer.JSON
-import Primer.Name (Name, unsafeMkName)
+import Primer.Name (Name, unName, unsafeMkName)
 
 -- | An identifier for an expression. Every node of the AST has an ID.
 newtype ID = ID {unID :: Int}
@@ -165,10 +166,12 @@ _synthed = #_TCSynthed `afailing` (#_TCEmb % #tcSynthed)
 -- nodes we're inserting.
 type ExprMeta = Meta (Maybe TypeCache)
 
-newtype ModuleName = ModuleName {unModuleName :: Name}
+newtype ModuleName = ModuleName {unModuleName :: NonEmpty Name}
   deriving (Eq, Ord, Show, Data, Generic)
-  deriving (IsString) via Name
-  deriving (FromJSON, ToJSON) via Name
+  deriving (FromJSON, ToJSON) via NonEmpty Name
+
+moduleNamePretty :: ModuleName -> Text
+moduleNamePretty = mconcat . intersperse "." . toList . fmap unName . unModuleName
 
 -- | Tags for 'GlobalName'
 data GlobalNameKind
@@ -189,8 +192,8 @@ 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 (ModuleName $ unsafeMkName m) (unsafeMkName n)
+unsafeMkGlobalName :: (NonEmpty Text, Text) -> GlobalName k
+unsafeMkGlobalName (m, n) = GlobalName (ModuleName $ fmap unsafeMkName m) (unsafeMkName n)
 
 qualifyName :: ModuleName -> Name -> GlobalName k
 qualifyName = GlobalName
@@ -500,8 +503,8 @@ data PrimCon
 -- This should be a key in `allPrimTypeDefs`.
 primConName :: PrimCon -> TyConName
 primConName = \case
-  PrimChar _ -> qualifyName "Primitives" "Char"
-  PrimInt _ -> qualifyName "Primitives" "Int"
+  PrimChar _ -> qualifyName (ModuleName $ "Primitives" :| []) "Char"
+  PrimInt _ -> qualifyName (ModuleName $ "Primitives" :| []) "Int"
 
 data PrimFun = PrimFun
   { primFunTypes :: forall m. MonadFresh ID m => m ([Type], Type)

primer/src/Primer/Core/DSL.hs

@@ -58,7 +58,7 @@ import Primer.Core (
   Kind,
   LVarName,
   Meta (..),
-  ModuleName,
+  ModuleName (ModuleName),
   PrimCon (..),
   TmVarRef (..),
   TyConName,
@@ -197,14 +197,14 @@ list_ t =
 
 -- | A helper for use in testsuite. With OverloadedStrings one can use literals
 -- for both arguments
-tcon' :: MonadFresh ID m => ModuleName -> Name -> m Type
-tcon' m n = tcon $ qualifyName m n
+tcon' :: MonadFresh ID m => NonEmpty Name -> Name -> m Type
+tcon' m n = tcon $ qualifyName (ModuleName m) n
 
-con' :: MonadFresh ID m => ModuleName -> Name -> m Expr
-con' m n = con $ qualifyName m n
+con' :: MonadFresh ID m => NonEmpty Name -> Name -> m Expr
+con' m n = con $ qualifyName (ModuleName m) n
 
-gvar' :: MonadFresh ID m => ModuleName -> Name -> m Expr
-gvar' m n = gvar $ qualifyName m n
+gvar' :: MonadFresh ID m => NonEmpty Name -> Name -> m Expr
+gvar' m n = gvar $ qualifyName (ModuleName m) n
 
-branch' :: MonadFresh ID m => (ModuleName, Name) -> [(LVarName, Maybe TypeCache)] -> m Expr -> m CaseBranch
-branch' (m, n) = branch $ qualifyName m n
+branch' :: MonadFresh ID m => (NonEmpty Name, Name) -> [(LVarName, Maybe TypeCache)] -> m Expr -> m CaseBranch
+branch' (m, n) = branch $ qualifyName (ModuleName m) n

primer/src/Primer/Primitives.hs

@@ -29,7 +29,7 @@ import Primer.Core (
   ExprAnyFresh (..),
   GVarName,
   GlobalName (baseName),
-  ModuleName,
+  ModuleName (ModuleName),
   PrimCon (..),
   PrimDef (PrimDef, primDefName, primDefType),
   PrimFun (..),
@@ -57,7 +57,7 @@ import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes))
 import Primer.Name (Name)
 
 primitiveModuleName :: ModuleName
-primitiveModuleName = "Primitives"
+primitiveModuleName = ModuleName $ "Primitives" :| []
 
 primitive :: Name -> GlobalName k
 primitive = qualifyName primitiveModuleName

primer/src/Primer/Typecheck.hs

@@ -107,13 +107,13 @@ import Primer.Core (
   bindName,
   defName,
   defType,
+  moduleNamePretty,
   primConName,
   typeDefAST,
   typeDefKind,
   typeDefName,
   typeDefParameters,
   unLocalName,
-  unModuleName,
   valConType,
   _exprMeta,
   _exprTypeMeta,
@@ -133,7 +133,7 @@ import Primer.Module (
   qualifyDefName,
   qualifyTyConName,
  )
-import Primer.Name (Name (unName), NameCounter, freshName)
+import Primer.Name (Name, NameCounter, freshName)
 import Primer.Subst (substTy)
 
 -- | Typechecking takes as input an Expr with 'Maybe Type' annotations and
@@ -441,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 (unModuleName $ moduleName m)
+            throwError' $ InternalError $ "Inconsistant names in moduleTypes for module " <> moduleNamePretty (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 (unModuleName $ moduleName m)
+            throwError' $ InternalError $ "Inconsistant names in moduleDefs map for module " <> moduleNamePretty (moduleName m)
         checkTypeDefs $ foldMap moduleTypesQualified toCheck
         let newTypes = foldMap moduleTypesQualified toCheck
             newDefs =

primer/test/Gen/Core/Raw.hs

@@ -87,7 +87,12 @@ genAPP :: ExprGen Expr
 genAPP = APP <$> genMeta <*> genExpr <*> genType
 
 genModuleName :: MonadGen m => m ModuleName
-genModuleName = ModuleName <$> Gen.frequency [(9, pure "M"), (1, genName)]
+genModuleName =
+  ModuleName
+    <$> Gen.frequency
+      [ (9, pure $ "M" :| [])
+      , (1, Gen.nonEmpty (Range.linear 1 3) 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 (unModuleName),
+  ModuleName (ModuleName, unModuleName),
   PrimDef (..),
   TyConName,
   ValConName,
@@ -47,14 +47,14 @@ constructCon = ConstructCon . toQualText
 constructRefinedCon :: ValConName -> Action
 constructRefinedCon = ConstructRefinedCon . toQualText
 
-toQualText :: GlobalName k -> (Text, Text)
-toQualText n = (unName $ unModuleName $ qualifiedModule n, unName $ baseName n)
+toQualText :: GlobalName k -> (NonEmpty Text, Text)
+toQualText n = (map unName $ unModuleName $ qualifiedModule n, unName $ baseName n)
 
-vcn :: ModuleName -> Name -> ValConName
-vcn = qualifyName
+vcn :: NonEmpty Name -> Name -> ValConName
+vcn = qualifyName . ModuleName
 
-tcn :: ModuleName -> Name -> TyConName
-tcn = qualifyName
+tcn :: NonEmpty Name -> Name -> TyConName
+tcn = qualifyName . ModuleName
 
-gvn :: ModuleName -> Name -> GVarName
-gvn = qualifyName
+gvn :: NonEmpty Name -> Name -> GVarName
+gvn = qualifyName . ModuleName