From 78c633102b66d917e5ac688fa23257d2a3dcb3bc Mon Sep 17 00:00:00 2001 From: Ben Price Date: Wed, 13 Apr 2022 17:26:19 +0100 Subject: [PATCH] feat!: hierarchical module names A `ModuleName` is now a non-empty list, so one can have nested namespaces. BREAKING CHANGE: this change requires a database migration, as it changes the representation of `Prog`. However, since this is just serialised to json and stored as a blob in the DB, it requires no schema changes. Since we have no programs we need to preserve, we decided not to bother with a migration. This means that DBs created before this commit will not load with a primer containing this commit. --- primer-rel8/test/TestUtils.hs | 7 +- primer-service/src/Primer/Server.hs | 8 +- primer/primer.cabal | 1 + primer/src/Primer/Action.hs | 4 +- primer/src/Primer/App.hs | 20 ++- primer/src/Primer/Builtins.hs | 4 +- primer/src/Primer/Core.hs | 19 +- primer/src/Primer/Core/DSL.hs | 18 +- primer/src/Primer/Primitives.hs | 4 +- primer/src/Primer/Typecheck.hs | 8 +- primer/test/Gen/Core/Raw.hs | 7 +- primer/test/TestUtils.hs | 18 +- primer/test/Tests/API.hs | 12 +- primer/test/Tests/Action.hs | 4 +- primer/test/Tests/Action/Available.hs | 8 +- primer/test/Tests/Action/Prog.hs | 27 +-- primer/test/Tests/Eval.hs | 168 +++++++++--------- primer/test/Tests/EvalFull.hs | 36 ++-- primer/test/Tests/FreeVars.hs | 2 +- primer/test/Tests/Question.hs | 3 +- primer/test/Tests/Serialization.hs | 11 +- primer/test/Tests/Transform.hs | 32 ++-- primer/test/Tests/Typecheck.hs | 39 ++-- primer/test/Tests/Unification.hs | 4 +- primer/test/outputs/serialization/def.json | 4 +- .../serialization/edit_response_2.json | 24 ++- primer/test/outputs/serialization/prog.json | 24 ++- .../outputs/serialization/progaction.json | 4 +- .../test/outputs/serialization/selection.json | 4 +- .../test/outputs/serialization/typeDef.json | 12 +- 30 files changed, 295 insertions(+), 241 deletions(-) diff --git a/primer-rel8/test/TestUtils.hs b/primer-rel8/test/TestUtils.hs index 2d6cbce10..9eae1e6ce 100644 --- a/primer-rel8/test/TestUtils.hs +++ b/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) } diff --git a/primer-service/src/Primer/Server.hs b/primer-service/src/Primer/Server.hs index 6b6c3c28b..c7b14b605 100644 --- a/primer-service/src/Primer/Server.hs +++ b/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} diff --git a/primer/primer.cabal b/primer/primer.cabal index 26280b008..9428b9c82 100644 --- a/primer/primer.cabal +++ b/primer/primer.cabal @@ -131,6 +131,7 @@ test-suite primer-test GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses + OverloadedLists OverloadedStrings ScopedTypeVariables diff --git a/primer/src/Primer/Action.hs b/primer/src/Primer/Action.hs index 2a0af9c6a..1b75720f6 100644 --- a/primer/src/Primer/Action.hs +++ b/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 diff --git a/primer/src/Primer/App.hs b/primer/src/Primer/App.hs index fc7239c03..0141ed329 100644 --- a/primer/src/Primer/App.hs +++ b/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" :| [] } } diff --git a/primer/src/Primer/Builtins.hs b/primer/src/Primer/Builtins.hs index 088d3169c..2fd2839cb 100644 --- a/primer/src/Primer/Builtins.hs +++ b/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 diff --git a/primer/src/Primer/Core.hs b/primer/src/Primer/Core.hs index 03b057e2b..4775fe0d5 100644 --- a/primer/src/Primer/Core.hs +++ b/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) diff --git a/primer/src/Primer/Core/DSL.hs b/primer/src/Primer/Core/DSL.hs index 99f7684a1..7ee597170 100644 --- a/primer/src/Primer/Core/DSL.hs +++ b/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 diff --git a/primer/src/Primer/Primitives.hs b/primer/src/Primer/Primitives.hs index 9c6231b13..05077bb9c 100644 --- a/primer/src/Primer/Primitives.hs +++ b/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 diff --git a/primer/src/Primer/Typecheck.hs b/primer/src/Primer/Typecheck.hs index 3556aabd7..2ada03399 100644 --- a/primer/src/Primer/Typecheck.hs +++ b/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 = diff --git a/primer/test/Gen/Core/Raw.hs b/primer/test/Gen/Core/Raw.hs index 88d57a9e4..fd0d3fd0c 100644 --- a/primer/test/Gen/Core/Raw.hs +++ b/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 diff --git a/primer/test/TestUtils.hs b/primer/test/TestUtils.hs index 50af59cc6..53ce4188a 100644 --- a/primer/test/TestUtils.hs +++ b/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 diff --git a/primer/test/Tests/API.hs b/primer/test/Tests/API.hs index 68fe2641f..4283e4fbf 100644 --- a/primer/test/Tests/API.hs +++ b/primer/test/Tests/API.hs @@ -28,7 +28,7 @@ hprop_viewTreeType_injective = property $ do unit_viewTreeExpr_injective_con :: Assertion unit_viewTreeExpr_injective_con = - distinctTreeExpr (con' "M" "C") (con' "M" "D") + distinctTreeExpr (con' ["M"] "C") (con' ["M"] "D") unit_viewTreeExpr_injective_lam :: Assertion unit_viewTreeExpr_injective_lam = @@ -44,7 +44,7 @@ unit_viewTreeExpr_injective_var = unit_viewTreeExpr_injective_globalvar :: Assertion unit_viewTreeExpr_injective_globalvar = - distinctTreeExpr (gvar' "M" "0") (gvar' "M" "1") + distinctTreeExpr (gvar' ["M"] "0") (gvar' ["M"] "1") -- When we changed how references were handled so 'Expr' had one constructor -- that handled both local and global variable references, there was a @@ -53,7 +53,7 @@ unit_viewTreeExpr_injective_globalvar = -- global variables had a qualified name). unit_viewTreeExpr_injective_locglobvar :: Assertion unit_viewTreeExpr_injective_locglobvar = - distinctTreeExpr (lvar "x") (gvar' "M" "x") + distinctTreeExpr (lvar "x") (gvar' ["M"] "x") unit_viewTreeExpr_injective_let :: Assertion unit_viewTreeExpr_injective_let = @@ -69,15 +69,15 @@ unit_viewTreeExpr_injective_letrec = unit_viewTreeExpr_injective_case_conName :: Assertion unit_viewTreeExpr_injective_case_conName = - distinctTreeExpr (case_ emptyHole [branch' ("M", "C") [("x", Nothing)] emptyHole]) (case_ emptyHole [branch' ("M", "D") [("x", Nothing)] emptyHole]) + distinctTreeExpr (case_ emptyHole [branch' (["M"], "C") [("x", Nothing)] emptyHole]) (case_ emptyHole [branch' (["M"], "D") [("x", Nothing)] emptyHole]) unit_viewTreeExpr_injective_case_paramName :: Assertion unit_viewTreeExpr_injective_case_paramName = - distinctTreeExpr (case_ emptyHole [branch' ("M", "C") [("x", Nothing)] emptyHole]) (case_ emptyHole [branch' ("M", "C") [("y", Nothing)] emptyHole]) + distinctTreeExpr (case_ emptyHole [branch' (["M"], "C") [("x", Nothing)] emptyHole]) (case_ emptyHole [branch' (["M"], "C") [("y", Nothing)] emptyHole]) unit_viewTreeType_injective_con :: Assertion unit_viewTreeType_injective_con = - distinctTreeType (tcon' "M" "T") (tcon' "M" "S") + distinctTreeType (tcon' ["M"] "T") (tcon' ["M"] "S") unit_viewTreeType_injective_var :: Assertion unit_viewTreeType_injective_var = diff --git a/primer/test/Tests/Action.hs b/primer/test/Tests/Action.hs index 45359e3c5..0dfa5f1ce 100644 --- a/primer/test/Tests/Action.hs +++ b/primer/test/Tests/Action.hs @@ -362,7 +362,7 @@ unit_bad_constructor = (const True) NoSmartHoles emptyHole - [ConstructCon ("M", "NotARealConstructor")] + [ConstructCon (["M"], "NotARealConstructor")] unit_bad_type_constructor :: Assertion unit_bad_type_constructor = @@ -370,7 +370,7 @@ unit_bad_type_constructor = (const True) NoSmartHoles (ann emptyHole tEmptyHole) - [EnterType, ConstructTCon ("M", "NotARealTypeConstructor")] + [EnterType, ConstructTCon (["M"], "NotARealTypeConstructor")] unit_bad_app :: Assertion unit_bad_app = diff --git a/primer/test/Tests/Action/Available.hs b/primer/test/Tests/Action/Available.hs index b25825416..05b1968a5 100644 --- a/primer/test/Tests/Action/Available.hs +++ b/primer/test/Tests/Action/Available.hs @@ -18,7 +18,7 @@ import Primer.Core ( HasID (_id), ID, Kind (KType), - ModuleName (unModuleName), + moduleNamePretty, _exprMeta, _exprTypeMeta, _typeMeta, @@ -61,7 +61,7 @@ test_1 :: TestTree test_1 = mkTests ASTDef - { astDefName = gvn "M" "1" + { astDefName = gvn ["M"] "1" , astDefExpr , astDefType } @@ -94,7 +94,7 @@ test_1 = (con cJust) ) ( hole - (gvar' "M" "0") + (gvar' ["M"] "0") ) ) ( thole @@ -170,7 +170,7 @@ data Output = Output mkTests :: ASTDef -> TestTree mkTests def = let defName = astDefName def - testName = T.unpack $ unName (unModuleName $ qualifiedModule defName) <> "." <> unName (baseName defName) + testName = T.unpack $ moduleNamePretty (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 9f12f5fa6..44a348792 100644 --- a/primer/test/Tests/Action/Prog.hs +++ b/primer/test/Tests/Action/Prog.hs @@ -57,7 +57,7 @@ import Primer.Core ( ID (ID), Kind (KType), Meta (..), - ModuleName (unModuleName), + ModuleName (ModuleName, unModuleName), TmVarRef (..), TyConName, Type, @@ -726,16 +726,16 @@ unit_copy_paste_import = importModules [builtinModule] ty <- tcon tBool `tfun` tcon tBool e <- lam "x" $ lvar "x" - let def = ASTDef (TestUtils.gvn "M" "foo") e ty + let def = ASTDef (TestUtils.gvn ["M"] "foo") e ty let m = Module - { moduleName = "M" + { moduleName = ModuleName ["M"] , moduleTypes = mempty , moduleDefs = Map.singleton "foo" $ DefAST def } importModules [m] prog <- gets appProg - case (findGlobalByName prog $ TestUtils.gvn "M" "foo", Map.assocs $ moduleDefsQualified $ progModule prog) of + case (findGlobalByName prog $ TestUtils.gvn ["M"] "foo", Map.assocs $ moduleDefsQualified $ progModule prog) of (Just (DefAST fooDef), [(i, _)]) -> do let fromDef = astDefName fooDef fromType = getID $ astDefType fooDef @@ -1111,6 +1111,7 @@ 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 :: [Module] renamed = transformBi (const m) [builtinModule, primitiveModule] renamedTypes = renamed ^.. folded % #moduleTypes % folded renamedDefs = foldOf (folded % #moduleDefs) renamed @@ -1172,20 +1173,20 @@ unit_rename_module :: Assertion unit_rename_module = let test = do importModules [builtinModule] - handleEditRequest [RenameModule "Module2"] + 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" + Right p -> unModuleName (moduleName $ progModule p) @?= ["Module2"] unit_rename_module_clash :: Assertion unit_rename_module_clash = let test = do importModules [builtinModule] - handleEditRequest [RenameModule "Builtins"] + handleEditRequest [RenameModule ["Builtins"]] a = newEmptyApp in do - moduleName builtinModule @?= "Builtins" + unModuleName (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" @@ -1242,8 +1243,8 @@ astDefBaseName = baseName . astDefName mainModuleName :: ModuleName mainModuleName = moduleName $ progModule newEmptyProg -mainModuleNameText :: Text -mainModuleNameText = unName $ unModuleName mainModuleName +mainModuleNameText :: NonEmpty Text +mainModuleNameText = unName <$> unModuleName mainModuleName moveToDef :: Name -> ProgAction moveToDef = MoveToDef . qualifyName mainModuleName @@ -1255,13 +1256,13 @@ deleteDef :: Name -> ProgAction deleteDef = DeleteDef . gvn tcn :: Name -> TyConName -tcn = TestUtils.tcn mainModuleName +tcn = TestUtils.tcn $ unModuleName mainModuleName vcn :: Name -> ValConName -vcn = TestUtils.vcn mainModuleName +vcn = TestUtils.vcn $ unModuleName mainModuleName gvn :: Name -> GVarName -gvn = TestUtils.gvn mainModuleName +gvn = TestUtils.gvn $ unModuleName mainModuleName astDef :: Name -> Expr -> Type -> ASTDef astDef = ASTDef . gvn diff --git a/primer/test/Tests/Eval.hs b/primer/test/Tests/Eval.hs index 25d38003a..9e831e42b 100644 --- a/primer/test/Tests/Eval.hs +++ b/primer/test/Tests/Eval.hs @@ -103,11 +103,11 @@ unit_tryReduce_beta_annotation :: Assertion unit_tryReduce_beta_annotation = do let ((lambda, body, arg, input, expectedResult, argType, resultType), maxid) = create $ do - t1 <- tcon' "M" "A" - t2 <- tcon' "M" "B" + t1 <- tcon' ["M"] "A" + t2 <- tcon' ["M"] "B" x <- lvar "x" l <- lam "x" (pure x) - a <- con' "M" "C" + a <- con' ["M"] "C" i <- app (ann (pure l) (tfun (pure t1) (pure t2))) (pure a) r <- ann (let_ "x" (ann (pure a) (pure t1)) (pure x)) (pure t2) pure (l, x, a, i, r, t1, t2) @@ -133,7 +133,7 @@ unit_tryReduce_beta_annotation_hole = do t2 <- tEmptyHole x <- lvar "x" l <- lam "x" (pure x) - a <- con' "M" "C" + a <- con' ["M"] "C" i <- app (ann (pure l) tEmptyHole) (pure a) r <- hole (let_ "x" (hole (pure a)) (pure x)) pure (l, x, a, i, r, t1, t2) @@ -158,16 +158,16 @@ unit_tryReduce_beta_nested = do create $ do e <- lam "y" (lvar "x") l <- lam "x" (pure e) - a <- con' "M" "C" - i <- app (app (pure l) (pure a)) (con' "M" "D") - r <- app (let_ "x" (pure a) (pure e)) (con' "M" "D") + a <- con' ["M"] "C" + i <- app (app (pure l) (pure a)) (con' ["M"] "D") + r <- app (let_ "x" (pure a) (pure e)) (con' ["M"] "D") pure (l, e, a, i, r) result = runTryReduce mempty mempty (input, maxid) case result of Right (expr, BetaReduction detail) -> do expr ~= expectedResult - betaBefore detail ~= fst (create (app (lam "x" (lam "y" (lvar "x"))) (con' "M" "C"))) - betaAfter detail ~= fst (create (let_ "x" (con' "M" "C") (lam "y" (lvar "x")))) + betaBefore detail ~= fst (create (app (lam "x" (lam "y" (lvar "x"))) (con' ["M"] "C"))) + betaAfter detail ~= fst (create (let_ "x" (con' ["M"] "C") (lam "y" (lvar "x")))) betaBindingName detail @?= "x" betaLambdaID detail @?= lambda ^. _id betaArgID detail @?= arg ^. _id @@ -179,20 +179,20 @@ unit_tryReduce_beta_annotation_nested :: Assertion unit_tryReduce_beta_annotation_nested = do let ((lambda, body, arg, input, expectedResult, argType, resultType), maxid) = create $ do - t1 <- tcon' "M" "A" - t2 <- tcon' "M" "B" + t1 <- tcon' ["M"] "A" + t2 <- tcon' ["M"] "B" x <- lvar "x" l <- lam "x" (pure x) - a <- con' "M" "C" - i <- app (app (ann (pure l) (tfun (pure t1) (pure t2))) (pure a)) (con' "M" "D") - r <- app (ann (let_ "x" (ann (pure a) (pure t1)) (pure x)) (pure t2)) (con' "M" "D") + a <- con' ["M"] "C" + i <- app (app (ann (pure l) (tfun (pure t1) (pure t2))) (pure a)) (con' ["M"] "D") + r <- app (ann (let_ "x" (ann (pure a) (pure t1)) (pure x)) (pure t2)) (con' ["M"] "D") pure (l, x, a, i, r, t1, t2) result = runTryReduce mempty mempty (input, maxid) case result of Right (expr, BetaReduction detail@BetaReductionDetail{betaTypes = Just (l, r)}) -> do expr ~= expectedResult - betaBefore detail ~= fst (create (app (ann (lam "x" (lvar "x")) (tfun (tcon' "M" "A") (tcon' "M" "B"))) (con' "M" "C"))) - betaAfter detail ~= fst (create (ann (let_ "x" (ann (con' "M" "C") (tcon' "M" "A")) (lvar "x")) (tcon' "M" "B"))) + betaBefore detail ~= fst (create (app (ann (lam "x" (lvar "x")) (tfun (tcon' ["M"] "A") (tcon' ["M"] "B"))) (con' ["M"] "C"))) + betaAfter detail ~= fst (create (ann (let_ "x" (ann (con' ["M"] "C") (tcon' ["M"] "A")) (lvar "x")) (tcon' ["M"] "B"))) betaBindingName detail @?= "x" betaLambdaID detail @?= lambda ^. _id betaArgID detail @?= arg ^. _id @@ -214,7 +214,7 @@ unit_tryReduce_beta_name_clash :: Assertion unit_tryReduce_beta_name_clash = do let ((c, lambda, body, arg, input, expectedResult), maxid) = create $ do - c_ <- con' "M" "C" + c_ <- con' ["M"] "C" e <- lam "x0" (lvar "x") l <- lam "x" (pure e) a <- lvar "x" @@ -262,7 +262,7 @@ unit_tryReduce_BETA = do unit_tryReduce_local_term_var :: Assertion unit_tryReduce_local_term_var = do -- We assume we're inside a larger expression (e.g. a let) where the node that binds x has ID 5. - let ((expr, val), i) = create $ (,) <$> lvar "x" <*> con' "M" "C" + let ((expr, val), i) = create $ (,) <$> lvar "x" <*> con' ["M"] "C" locals = Map.singleton "x" (5, Left val) result = runTryReduce mempty locals (expr, i) case result of @@ -280,7 +280,7 @@ unit_tryReduce_local_term_var = do unit_tryReduce_local_type_var :: Assertion unit_tryReduce_local_type_var = do -- We assume we're inside a larger expression (e.g. a let type) where the node that binds x has ID 5. - let ((tyvar, val), i) = create $ (,) <$> tvar "x" <*> tcon' "M" "C" + let ((tyvar, val), i) = create $ (,) <$> tvar "x" <*> tcon' ["M"] "C" locals = Map.singleton "x" (5, Right val) result = runTryReduceType mempty locals (tyvar, i) case result of @@ -297,15 +297,15 @@ unit_tryReduce_local_type_var = do unit_tryReduce_global_var :: Assertion unit_tryReduce_global_var = do - let f = gvn "M" "f" + let f = gvn ["M"] "f" ((expr, def), i) = create $ do g <- gvar f e <- lam "x" (lvar "x") - t <- tfun (tcon' "M" "A") (tcon' "M" "B") + t <- tfun (tcon' ["M"] "A") (tcon' ["M"] "B") pure (g, ASTDef{astDefName = f, astDefExpr = e, astDefType = t}) globals = Map.singleton f (DefAST def) result = runTryReduce globals mempty (expr, i) - expectedResult = fst $ create $ ann (lam "x" (lvar "x")) (tfun (tcon' "M" "A") (tcon' "M" "B")) + expectedResult = fst $ create $ ann (lam "x" (lvar "x")) (tfun (tcon' ["M"] "A") (tcon' ["M"] "B")) case result of Right (expr', GlobalVarInline detail) -> do expr' ~= expectedResult @@ -317,9 +317,9 @@ unit_tryReduce_global_var = do unit_tryReduce_let :: Assertion unit_tryReduce_let = do - let (expr, i) = create $ let_ "x" (con' "M" "C") (con' "M" "D") + let (expr, i) = create $ let_ "x" (con' ["M"] "C") (con' ["M"] "D") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con' "M" "D" + expectedResult = fst $ create $ con' ["M"] "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -333,9 +333,9 @@ unit_tryReduce_let = do unit_tryReduce_lettype :: Assertion unit_tryReduce_lettype = do - let (expr, i) = create $ letType "x" (tcon' "M" "C") (con' "M" "D") + let (expr, i) = create $ letType "x" (tcon' ["M"] "C") (con' ["M"] "D") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con' "M" "D" + expectedResult = fst $ create $ con' ["M"] "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -349,9 +349,9 @@ unit_tryReduce_lettype = do unit_tryReduce_letrec :: Assertion unit_tryReduce_letrec = do - let (expr, i) = create $ letrec "x" (con' "M" "C") (tcon' "M" "T") (con' "M" "D") + let (expr, i) = create $ letrec "x" (con' ["M"] "C") (tcon' ["M"] "T") (con' ["M"] "D") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con' "M" "D" + expectedResult = fst $ create $ con' ["M"] "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -368,13 +368,13 @@ unit_tryReduce_letrec = do unit_tryReduce_letrec_app :: Assertion unit_tryReduce_letrec_app = do let ((arg, lambda, letrec_, expr), i) = create $ do - arg_ <- con' "M" "D" + arg_ <- con' ["M"] "D" lam_ <- lam "x" $ app (lvar "f") (lvar "x") - lr <- letrec "f" (lam "x" (lvar "x")) (tcon' "M" "T") (pure lam_) + lr <- letrec "f" (lam "x" (lvar "x")) (tcon' ["M"] "T") (pure lam_) expr_ <- app (pure lr) (pure arg_) pure (arg_, lam_, lr, expr_) result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ letrec "f" (lam "x" (lvar "x")) (tcon' "M" "T") (app (lam "x" (app (lvar "f") (lvar "x"))) (con' "M" "D")) + expectedResult = fst $ create $ letrec "f" (lam "x" (lvar "x")) (tcon' ["M"] "T") (app (lam "x" (app (lvar "f") (lvar "x"))) (con' ["M"] "D")) case result of Right (expr', PushAppIntoLetrec detail) -> do expr' ~= expectedResult @@ -393,13 +393,13 @@ unit_tryReduce_letrec_app = do unit_tryReduce_letrec_APP :: Assertion unit_tryReduce_letrec_APP = do let ((arg, lambda, letrec_, expr), i) = create $ do - arg_ <- tcon' "M" "B" + arg_ <- tcon' ["M"] "B" lam_ <- lAM "x" $ aPP (lvar "f") (tvar "x") - lr <- letrec "f" (lAM "x" (con' "M" "A")) (tcon' "M" "T") (pure lam_) + lr <- letrec "f" (lAM "x" (con' ["M"] "A")) (tcon' ["M"] "T") (pure lam_) expr_ <- aPP (pure lr) (pure arg_) pure (arg_, lam_, lr, expr_) result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ letrec "f" (lAM "x" (con' "M" "A")) (tcon' "M" "T") (aPP (lAM "x" (aPP (lvar "f") (tvar "x"))) (tcon' "M" "B")) + expectedResult = fst $ create $ letrec "f" (lAM "x" (con' ["M"] "A")) (tcon' ["M"] "T") (aPP (lAM "x" (aPP (lvar "f") (tvar "x"))) (tcon' ["M"] "B")) case result of Right (expr', PushAppIntoLetrec detail) -> do expr' ~= expectedResult @@ -422,9 +422,9 @@ unit_tryReduce_letrec_name_clash = do -- locals map. This simulates focusing on the letrec inside the let expression. let ((expr, d, letd), i) = create $ do -- the value bound by the outer let - d_ <- con' "M" "D" + d_ <- con' ["M"] "D" -- the application - e <- app (letrec "f" (lam "x" (lvar "x")) (tcon' "M" "T") (lam "x" (app (lvar "f") (lvar "x")))) (lvar "f") + e <- app (letrec "f" (lam "x" (lvar "x")) (tcon' ["M"] "T") (lam "x" (app (lvar "f") (lvar "x")))) (lvar "f") -- the outer let letd_ <- let_ "f" (pure d_) (pure e) pure (e, d_, letd_) @@ -433,9 +433,9 @@ unit_tryReduce_letrec_name_clash = do unit_tryReduce_case_1 :: Assertion unit_tryReduce_case_1 = do - let (expr, i) = create $ case_ (con' "M" "C") [branch' ("M", "B") [("b", Nothing)] (con' "M" "D"), branch' ("M", "C") [] (con' "M" "E")] + let (expr, i) = create $ case_ (con' ["M"] "C") [branch' (["M"], "B") [("b", Nothing)] (con' ["M"] "D"), branch' (["M"], "C") [] (con' ["M"] "E")] result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con' "M" "E" + expectedResult = fst $ create $ con' ["M"] "E" case result of Right (expr', CaseReduction detail) -> do expr' ~= expectedResult @@ -444,7 +444,7 @@ unit_tryReduce_case_1 = do caseAfter detail ~= expectedResult caseTargetID detail @?= 1 caseTargetCtorID detail @?= 1 - caseCtorName detail @?= vcn "M" "C" + caseCtorName detail @?= vcn ["M"] "C" caseTargetArgIDs detail @?= [] caseBranchBindingIDs detail @?= [] caseBranchRhsID detail @?= 4 @@ -456,12 +456,12 @@ unit_tryReduce_case_2 = do let (expr, i) = create $ case_ - (app (app (app (con' "M" "C") (lam "x" (lvar "x"))) (lvar "y")) (lvar "z")) - [ branch' ("M", "B") [("b", Nothing)] (con' "M" "D") - , branch' ("M", "C") [("c", Nothing), ("d", Nothing), ("e", Nothing)] (con' "M" "E") + (app (app (app (con' ["M"] "C") (lam "x" (lvar "x"))) (lvar "y")) (lvar "z")) + [ branch' (["M"], "B") [("b", Nothing)] (con' ["M"] "D") + , branch' (["M"], "C") [("c", Nothing), ("d", Nothing), ("e", Nothing)] (con' ["M"] "E") ] result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ let_ "c" (lam "x" (lvar "x")) (let_ "d" (lvar "y") (let_ "e" (lvar "z") (con' "M" "E"))) + expectedResult = fst $ create $ let_ "c" (lam "x" (lvar "x")) (let_ "d" (lvar "y") (let_ "e" (lvar "z") (con' ["M"] "E"))) case result of Right (expr', CaseReduction detail) -> do expr' ~= expectedResult @@ -470,7 +470,7 @@ unit_tryReduce_case_2 = do caseAfter detail ~= expectedResult caseTargetID detail @?= 1 caseTargetCtorID detail @?= 4 - caseCtorName detail @?= vcn "M" "C" + caseCtorName detail @?= vcn ["M"] "C" caseTargetArgIDs detail @?= [5, 7, 8] caseBranchBindingIDs detail @?= [11, 12, 13] caseBranchRhsID detail @?= 14 @@ -482,12 +482,12 @@ unit_tryReduce_case_3 = do let (expr, i) = create $ case_ - (app (aPP (con' "M" "C") (tcon' "M" "D")) (con' "M" "E")) - [ branch' ("M", "B") [("b", Nothing)] (con' "M" "D") - , branch' ("M", "C") [("c", Nothing)] (con' "M" "F") + (app (aPP (con' ["M"] "C") (tcon' ["M"] "D")) (con' ["M"] "E")) + [ branch' (["M"], "B") [("b", Nothing)] (con' ["M"] "D") + , branch' (["M"], "C") [("c", Nothing)] (con' ["M"] "F") ] result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ let_ "c" (con' "M" "E") (con' "M" "F") + expectedResult = fst $ create $ let_ "c" (con' ["M"] "E") (con' ["M"] "F") case result of Right (expr', CaseReduction detail) -> do expr' ~= expectedResult @@ -496,7 +496,7 @@ unit_tryReduce_case_3 = do caseAfter detail ~= expectedResult caseTargetID detail @?= 1 caseTargetCtorID detail @?= 3 - caseCtorName detail @?= vcn "M" "C" + caseCtorName detail @?= vcn ["M"] "C" caseTargetArgIDs detail @?= [5] caseBranchBindingIDs detail @?= [8] caseBranchRhsID detail @?= 9 @@ -505,25 +505,25 @@ unit_tryReduce_case_3 = do unit_tryReduce_case_too_many_bindings :: Assertion unit_tryReduce_case_too_many_bindings = do - let (expr, i) = create $ case_ (con' "M" "C") [branch' ("M", "C") [("b", Nothing)] (con' "M" "D")] + let (expr, i) = create $ case_ (con' ["M"] "C") [branch' (["M"], "C") [("b", Nothing)] (con' ["M"] "D")] result = runTryReduce mempty mempty (expr, i) result @?= Left CaseBranchBindingLengthMismatch unit_tryReduce_case_too_few_bindings :: Assertion unit_tryReduce_case_too_few_bindings = do - let (expr, i) = create $ case_ (app (con' "M" "B") (lvar "y")) [branch' ("M", "B") [] (con' "M" "D")] + let (expr, i) = create $ case_ (app (con' ["M"] "B") (lvar "y")) [branch' (["M"], "B") [] (con' ["M"] "D")] result = runTryReduce mempty mempty (expr, i) result @?= Left CaseBranchBindingLengthMismatch unit_tryReduce_case_scrutinee_not_redex :: Assertion unit_tryReduce_case_scrutinee_not_redex = do - let (expr, i) = create $ case_ (lvar "x") [branch' ("M", "B") [] (con' "M" "D")] + let (expr, i) = create $ case_ (lvar "x") [branch' (["M"], "B") [] (con' ["M"] "D")] result = runTryReduce mempty mempty (expr, i) result @?= Left NotRedex unit_tryReduce_case_no_matching_branch :: Assertion unit_tryReduce_case_no_matching_branch = do - let (expr, i) = create $ case_ (con' "M" "C") [branch' ("M", "B") [] (con' "M" "D")] + let (expr, i) = create $ case_ (con' ["M"] "C") [branch' (["M"], "B") [] (con' ["M"] "D")] result = runTryReduce mempty mempty (expr, i) result @?= Left NoMatchingCaseBranch @@ -570,9 +570,9 @@ unit_tryReduce_prim_fail_unreduced_args = do unit_findNodeByID_letrec :: Assertion unit_findNodeByID_letrec = do - let expr = fst $ create $ letrec "x" (lvar "x") (tcon' "M" "T") (lvar "x") + let expr = fst $ create $ letrec "x" (lvar "x") (tcon' ["M"] "T") (lvar "x") x = fst $ create $ lvar "x" - t = fst $ create $ tcon' "M" "T" + t = fst $ create $ tcon' ["M"] "T" case findNodeByID 0 expr of Just (locals, Left z) -> do assertBool "no locals in scope at node 0" $ Map.null locals @@ -605,7 +605,7 @@ unit_findNodeByID_1 = do -- id 0 x_ <- lvar "x" -- id 1 - c_ <- con' "M" "C" + c_ <- con' ["M"] "C" -- id 2 e <- let_ "x" (pure c_) (pure x_) pure (x_, c_, e) @@ -638,7 +638,7 @@ unit_findNodeByID_2 = do -- id 0 x_ <- tvar "x" -- id 1 - t_ <- tcon' "M" "T" + t_ <- tcon' ["M"] "T" -- id 2 e <- letType "x" (pure t_) (ann (lvar "y") (pure x_)) pure (x_, t_, e) @@ -661,7 +661,7 @@ unit_findNodeByID_2 = do -- e.g. -- -- 0 1 2 3 4 5 6 7 --- lam "y" (app (lam "x" (var "x")) (app (lam "z" (var "z")) (con' "M" "C"))) +-- lam "y" (app (lam "x" (var "x")) (app (lam "z" (var "z")) (con' ["M"] "C"))) -- | A helper for these tests redexesOf :: S Expr -> Set ID @@ -672,130 +672,130 @@ redexesOfWithPrims :: S Expr -> Set ID redexesOfWithPrims x = uncurry redexes $ fst $ create $ withPrimDefs $ \globals -> (globals,) <$> x unit_redexes_con :: Assertion -unit_redexes_con = redexesOf (con' "M" "C") @?= mempty +unit_redexes_con = redexesOf (con' ["M"] "C") @?= mempty unit_redexes_lam_1 :: Assertion unit_redexes_lam_1 = - redexesOf (app (lam "x" (lvar "x")) (con' "M" "C")) @?= Set.singleton 0 + redexesOf (app (lam "x" (lvar "x")) (con' ["M"] "C")) @?= Set.singleton 0 unit_redexes_lam_2 :: Assertion unit_redexes_lam_2 = - redexesOf (lam "y" (app (lam "x" (lvar "x")) (con' "M" "C"))) @?= Set.singleton 1 + redexesOf (lam "y" (app (lam "x" (lvar "x")) (con' ["M"] "C"))) @?= Set.singleton 1 unit_redexes_lam_3 :: Assertion unit_redexes_lam_3 = - redexesOf (lam "y" (app (lam "x" (lvar "x")) (app (lam "z" (lvar "z")) (con' "M" "C")))) + redexesOf (lam "y" (app (lam "x" (lvar "x")) (app (lam "z" (lvar "z")) (con' ["M"] "C")))) @?= Set.fromList [1, 4] unit_redexes_lam_4 :: Assertion unit_redexes_lam_4 = - redexesOf (lam "y" (app (lam "x" (lvar "x")) (app (lam "z" (lvar "z")) (con' "M" "C")))) + redexesOf (lam "y" (app (lam "x" (lvar "x")) (app (lam "z" (lvar "z")) (con' ["M"] "C")))) @?= Set.fromList [1, 4] unit_redexes_LAM_1 :: Assertion unit_redexes_LAM_1 = - redexesOf (lAM "a" (con' "M" "C")) @?= mempty + redexesOf (lAM "a" (con' ["M"] "C")) @?= mempty unit_redexes_LAM_2 :: Assertion unit_redexes_LAM_2 = - redexesOf (aPP (lAM "a" (con' "M" "C")) (tcon' "M" "A")) @?= Set.fromList [0] + redexesOf (aPP (lAM "a" (con' ["M"] "C")) (tcon' ["M"] "A")) @?= Set.fromList [0] unit_redexes_LAM_3 :: Assertion unit_redexes_LAM_3 = - redexesOf (lAM "a" (aPP (lAM "b" (con' "M" "X")) (tcon' "M" "T"))) @?= Set.fromList [1] + redexesOf (lAM "a" (aPP (lAM "b" (con' ["M"] "X")) (tcon' ["M"] "T"))) @?= Set.fromList [1] unit_redexes_LAM_4 :: Assertion unit_redexes_LAM_4 = - redexesOf (let_ "x" (con' "M" "C") (lAM "a" (aPP (lAM "b" (lvar "x")) (tcon' "M" "T")))) + redexesOf (let_ "x" (con' ["M"] "C") (lAM "a" (aPP (lAM "b" (lvar "x")) (tcon' ["M"] "T")))) @?= Set.fromList [3, 5] unit_redexes_let_1 :: Assertion unit_redexes_let_1 = - redexesOf (let_ "x" (con' "M" "C") (app (lvar "x") (lvar "y"))) + redexesOf (let_ "x" (con' ["M"] "C") (app (lvar "x") (lvar "y"))) @?= Set.singleton 3 unit_redexes_let_2 :: Assertion unit_redexes_let_2 = - redexesOf (let_ "x" (con' "M" "C") (lam "x" (app (lvar "x") (lvar "y")))) + redexesOf (let_ "x" (con' ["M"] "C") (lam "x" (app (lvar "x") (lvar "y")))) @?= Set.singleton 0 unit_redexes_letrec_1 :: Assertion unit_redexes_letrec_1 = - redexesOf (letrec "x" (app (con' "M" "C") (lvar "x")) (tcon' "M" "T") (app (lvar "x") (lvar "y"))) + redexesOf (letrec "x" (app (con' ["M"] "C") (lvar "x")) (tcon' ["M"] "T") (app (lvar "x") (lvar "y"))) @?= Set.fromList [3, 6] unit_redexes_letrec_2 :: Assertion unit_redexes_letrec_2 = - redexesOf (letrec "x" (app (con' "M" "C") (lvar "x")) (tcon' "M" "T") (lvar "y")) + redexesOf (letrec "x" (app (con' ["M"] "C") (lvar "x")) (tcon' ["M"] "T") (lvar "y")) @?= Set.fromList [0, 3] -- The application can be reduced by pushing the argument inside the letrec unit_redexes_letrec_app_1 :: Assertion unit_redexes_letrec_app_1 = - redexesOf (app (letrec "e" (con' "M" "C") (tcon' "M" "T") (lam "x" (lvar "e"))) (con' "M" "D")) + redexesOf (app (letrec "e" (con' ["M"] "C") (tcon' ["M"] "T") (lam "x" (lvar "e"))) (con' ["M"] "D")) @?= Set.fromList [0, 5] -- The application can't be reduced because variables in the argument clash with the letrec unit_redexes_letrec_app_2 :: Assertion unit_redexes_letrec_app_2 = - redexesOf (let_ "e" (con' "M" "D") (app (letrec "e" (con' "M" "C") (tcon' "M" "T") (lam "x" (lvar "e"))) (lvar "e"))) + redexesOf (let_ "e" (con' ["M"] "D") (app (letrec "e" (con' ["M"] "C") (tcon' ["M"] "T") (lam "x" (lvar "e"))) (lvar "e"))) @?= Set.fromList [7, 8] unit_redexes_letrec_APP_1 :: Assertion unit_redexes_letrec_APP_1 = - redexesOf (aPP (letrec "e" (con' "M" "C") (tcon' "M" "T") (lAM "x" (lvar "e"))) (tcon' "M" "D")) + redexesOf (aPP (letrec "e" (con' ["M"] "C") (tcon' ["M"] "T") (lAM "x" (lvar "e"))) (tcon' ["M"] "D")) @?= Set.fromList [0, 5] unit_redexes_letrec_APP_2 :: Assertion unit_redexes_letrec_APP_2 = - redexesOf (letType "e" (tcon' "M" "D") (aPP (letrec "e" (con' "M" "C") (tcon' "M" "T") (lAM "x" (lvar "e"))) (tvar "e"))) + redexesOf (letType "e" (tcon' ["M"] "D") (aPP (letrec "e" (con' ["M"] "C") (tcon' ["M"] "T") (lAM "x" (lvar "e"))) (tvar "e"))) @?= Set.fromList [7, 8] unit_redexes_lettype_1 :: Assertion unit_redexes_lettype_1 = - redexesOf (letType "x" (tcon' "M" "T") (con' "M" "C")) @?= Set.fromList [0] + redexesOf (letType "x" (tcon' ["M"] "T") (con' ["M"] "C")) @?= Set.fromList [0] unit_redexes_lettype_2 :: Assertion unit_redexes_lettype_2 = - redexesOf (letType "x" (tcon' "M" "T") (aPP (con' "M" "C") (tvar "x"))) @?= Set.fromList [4] + redexesOf (letType "x" (tcon' ["M"] "T") (aPP (con' ["M"] "C") (tvar "x"))) @?= Set.fromList [4] unit_redexes_lettype_3 :: Assertion unit_redexes_lettype_3 = - redexesOf (letType "x" (tcon' "M" "T") (letrec "y" (con' "M" "C") (tvar "x") (lvar "y"))) @?= Set.fromList [4, 5] + redexesOf (letType "x" (tcon' ["M"] "T") (letrec "y" (con' ["M"] "C") (tvar "x") (lvar "y"))) @?= Set.fromList [4, 5] unit_redexes_case_1 :: Assertion unit_redexes_case_1 = - redexesOf (case_ (con' "M" "C") [branch' ("M", "C") [] (con' "M" "D")]) + redexesOf (case_ (con' ["M"] "C") [branch' (["M"], "C") [] (con' ["M"] "D")]) @?= Set.singleton 0 -- Same as above, but the scrutinee has an annotation unit_redexes_case_1_annotated :: Assertion unit_redexes_case_1_annotated = - redexesOf (case_ (ann (con' "M" "C") (tcon' "M" "C")) [branch' ("M", "C") [] (con' "M" "D")]) + redexesOf (case_ (ann (con' ["M"] "C") (tcon' ["M"] "C")) [branch' (["M"], "C") [] (con' ["M"] "D")]) @?= Set.singleton 0 unit_redexes_case_2 :: Assertion unit_redexes_case_2 = - redexesOf (case_ (lam "x" (lvar "x")) [branch' ("M", "C") [] (con' "M" "D")]) + redexesOf (case_ (lam "x" (lvar "x")) [branch' (["M"], "C") [] (con' ["M"] "D")]) @?= mempty -- The case expression can be reduced, as can the variable x in the branch rhs. unit_redexes_case_3 :: Assertion unit_redexes_case_3 = - redexesOf (let_ "x" (con' "M" "C") (case_ (con' "M" "C") [branch' ("M", "C") [] (lvar "x")])) + redexesOf (let_ "x" (con' ["M"] "C") (case_ (con' ["M"] "C") [branch' (["M"], "C") [] (lvar "x")])) @?= Set.fromList [2, 4] -- The variable x in the rhs is bound to the branch pattern, so is no longer reducible. -- However this means the let is redundant, and can be reduced. unit_redexes_case_4 :: Assertion unit_redexes_case_4 = - redexesOf (let_ "x" (con' "M" "C") (case_ (con' "M" "C") [branch' ("M", "C") [("x", Nothing)] (lvar "x")])) + redexesOf (let_ "x" (con' ["M"] "C") (case_ (con' ["M"] "C") [branch' (["M"], "C") [("x", Nothing)] (lvar "x")])) @?= Set.fromList [0, 2] -- If scrutinee of a case is a redex itself, we recognise that unit_redexes_case_5 :: Assertion unit_redexes_case_5 = - redexesOf (let_ "x" (con' "M" "C") (case_ (lvar "x") [])) @?= Set.fromList [3] + redexesOf (let_ "x" (con' ["M"] "C") (case_ (lvar "x") [])) @?= Set.fromList [3] unit_redexes_prim_1 :: Assertion unit_redexes_prim_1 = diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs index d0650adbc..0717a6481 100644 --- a/primer/test/Tests/EvalFull.hs +++ b/primer/test/Tests/EvalFull.hs @@ -76,9 +76,9 @@ unit_2 = unit_3 :: Assertion unit_3 = let ((expr, expected), maxID) = create $ do - e <- letType "a" (tvar "b") $ emptyHole `ann` (tcon' "M" "T" `tapp` tvar "a" `tapp` tforall "a" KType (tvar "a") `tapp` tforall "b" KType (tcon' "M" "S" `tapp` tvar "a" `tapp` tvar "b")) + e <- letType "a" (tvar "b") $ emptyHole `ann` (tcon' ["M"] "T" `tapp` tvar "a" `tapp` tforall "a" KType (tvar "a") `tapp` tforall "b" KType (tcon' ["M"] "S" `tapp` tvar "a" `tapp` tvar "b")) let b' = "a33" -- NB: fragile name a33 - expect <- emptyHole `ann` (tcon' "M" "T" `tapp` tvar "b" `tapp` tforall "a" KType (tvar "a") `tapp` tforall b' KType (tcon' "M" "S" `tapp` tvar "b" `tapp` tvar b')) + expect <- emptyHole `ann` (tcon' ["M"] "T" `tapp` tvar "b" `tapp` tforall "a" KType (tvar "a") `tapp` tforall b' KType (tcon' ["M"] "S" `tapp` tvar "b" `tapp` tvar b')) pure (e, expect) s = evalFullTest maxID mempty mempty 5 Syn expr in do @@ -89,9 +89,9 @@ unit_3 = unit_4 :: Assertion unit_4 = let ((expr, expected), maxID) = create $ do - e <- let_ "a" (lvar "b") $ con' "M" "C" `app` lvar "a" `app` lam "a" (lvar "a") `app` lam "b" (con' "M" "D" `app` lvar "a" `app` lvar "b") + e <- let_ "a" (lvar "b") $ con' ["M"] "C" `app` lvar "a" `app` lam "a" (lvar "a") `app` lam "b" (con' ["M"] "D" `app` lvar "a" `app` lvar "b") let b' = "a29" -- NB: fragile name a29 - expect <- con' "M" "C" `app` lvar "b" `app` lam "a" (lvar "a") `app` lam b' (con' "M" "D" `app` lvar "b" `app` lvar b') + expect <- con' ["M"] "C" `app` lvar "b" `app` lam "a" (lvar "a") `app` lam b' (con' ["M"] "D" `app` lvar "b" `app` lvar b') pure (e, expect) s = evalFullTest maxID mempty mempty 7 Syn expr in do @@ -148,7 +148,7 @@ unit_8 :: Assertion unit_8 = let n = 10 ((globals, e, expected), maxID) = create $ do - let mapName = gvn "M" "map" + let mapName = gvn ["M"] "map" mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) map_ <- lAM "a" $ @@ -160,8 +160,8 @@ unit_8 = [ branch cNil [] $ con cNil `aPP` tvar "b" , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cCons `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (gvar mapName `aPP` tvar "a" `aPP` tvar "b" `app` lvar "f" `app` lvar "ys") ] - let evenName = gvn "M" "even" - let oddName = gvn "M" "odd" + let evenName = gvn ["M"] "even" + let oddName = gvn ["M"] "odd" -- even and odd have almost the same type, but their types contain different IDs let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy @@ -190,7 +190,7 @@ unit_9 :: Assertion unit_9 = let n = 10 ((globals, e, expected), maxID) = create $ do - let mapName = gvn "M" "map" + let mapName = gvn ["M"] "map" mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) let worker = lam "xs" $ @@ -200,8 +200,8 @@ unit_9 = , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cCons `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (lvar "go" `app` lvar "ys") ] map_ <- lAM "a" $ lAM "b" $ lam "f" $ letrec "go" worker ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) $ lvar "go" - let evenName = gvn "M" "even" - let oddName = gvn "M" "odd" + let evenName = gvn ["M"] "even" + let oddName = gvn ["M"] "odd" -- even and odd have almost the same type, but their types contain different IDs let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy @@ -259,8 +259,8 @@ unit_10 = unit_11 :: Assertion unit_11 = let ((globals, e, expected), maxID) = create $ do - let evenName = gvn "M" "even" - let oddName = gvn "M" "odd" + let evenName = gvn ["M"] "even" + let oddName = gvn ["M"] "odd" -- even and odd have almost the same type, but their types contain different IDs let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy @@ -314,8 +314,8 @@ unit_12 = unit_13 :: Assertion unit_13 = let ((e, expected), maxID) = create $ do - expr <- (lam "x" (con' "M" "C" `app` lvar "x" `app` let_ "x" (con cTrue) (lvar "x") `app` lvar "x") `ann` (tcon tNat `tfun` tcon tBool)) `app` con cZero - expect <- (con' "M" "C" `app` con cZero `app` con cTrue `app` con cZero) `ann` tcon tBool + expr <- (lam "x" (con' ["M"] "C" `app` lvar "x" `app` let_ "x" (con cTrue) (lvar "x") `app` lvar "x") `ann` (tcon tNat `tfun` tcon tBool)) `app` con cZero + expect <- (con' ["M"] "C" `app` con cZero `app` con cTrue `app` con cZero) `ann` tcon tBool pure (expr, expect) in do let s = evalFullTest maxID builtinTypes mempty 15 Syn e @@ -346,7 +346,7 @@ unit_15 :: Assertion unit_15 = let ((expr, steps, expected), maxID) = create $ do let l = let_ "x" (lvar "y") - let c a b = con' "M" "C" `app` lvar a `app` lvar b + let c a b = con' ["M"] "C" `app` lvar a `app` lvar b e0 <- l $ lam "y" $ c "x" "y" let y' = "a50" -- NB: fragile name "a50" e1 <- l $ lam y' $ let_ "y" (lvar y') $ c "x" "y" @@ -918,7 +918,7 @@ unit_prim_partial_map = , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cCons `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (lvar "go" `app` lvar "ys") ] map_ <- lAM "a" $ lAM "b" $ lam "f" $ letrec "go" worker ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) $ lvar "go" - pure $ DefAST $ ASTDef (gvn "M" "map") map_ mapTy + pure $ DefAST $ ASTDef (gvn ["M"] "map") map_ mapTy -- Test that handleEvalFullRequest will reduce imported terms unit_eval_full_modules :: Assertion @@ -1031,13 +1031,13 @@ testModule :: Module testModule = let (ty, expr) = fst . create $ (,) <$> tcon tChar `tfun` tcon tChar <*> lam "x" (lvar "x") in Module - { moduleName = "M" + { moduleName = ModuleName ["M"] , moduleTypes = mempty , moduleDefs = Map.singleton "idChar" $ DefAST ASTDef - { astDefName = gvn "M" "idChar" + { astDefName = gvn ["M"] "idChar" , astDefType = ty , astDefExpr = expr } diff --git a/primer/test/Tests/FreeVars.hs b/primer/test/Tests/FreeVars.hs index 98e1a6de7..280877435 100644 --- a/primer/test/Tests/FreeVars.hs +++ b/primer/test/Tests/FreeVars.hs @@ -29,4 +29,4 @@ unit_2 = ) (lvar "y") ) - (tforall "a" KType $ tcon' "M" "T" `tapp` tvar "a" `tapp` tvar "b") + (tforall "a" KType $ tcon' ["M"] "T" `tapp` tvar "a" `tapp` tvar "b") diff --git a/primer/test/Tests/Question.hs b/primer/test/Tests/Question.hs index 124b93ad4..42b019dc9 100644 --- a/primer/test/Tests/Question.hs +++ b/primer/test/Tests/Question.hs @@ -17,6 +17,7 @@ import Primer.Core ( Kind (KFun, KType), LVarName, LocalName (LocalName, unLocalName), + ModuleName (ModuleName), TyVarName, Type, Type' (TCon), @@ -145,7 +146,7 @@ genSTE' = Right (ty, True) -> Global (qualifyName m n, ty) in evalExprGen 0 $ Gen.list (Range.linear 0 20) $ toSTE' <$> genModuleName <*> genName <*> g where - genModuleName = Gen.element ["M", "M1"] + genModuleName = ModuleName <$> Gen.element [["M"], ["M1"]] genSTE :: Gen ShadowedVarsExpr genSTE = deal . nubBy ((==) `on` nameSTE') <$> genSTE' diff --git a/primer/test/Tests/Serialization.hs b/primer/test/Tests/Serialization.hs index 7ea85d7ca..06992de7f 100644 --- a/primer/test/Tests/Serialization.hs +++ b/primer/test/Tests/Serialization.hs @@ -36,6 +36,7 @@ import Primer.Core ( ID (..), Kind (KFun, KType), Meta (..), + ModuleName (ModuleName), PrimCon (..), Type' (TApp, TCon, TEmptyHole, TVar), TypeCache (TCSynthed), @@ -96,26 +97,26 @@ fixtures = log :: Log log = Log [[BodyAction [Move Child1]]] def :: ASTDef - def = ASTDef{astDefName = gvn "M" "main", astDefExpr = expr, astDefType = TEmptyHole typeMeta} + def = ASTDef{astDefName = gvn ["M"] "main", astDefExpr = expr, astDefType = TEmptyHole typeMeta} typeDef :: TypeDef typeDef = TypeDefAST ASTTypeDef - { astTypeDefName = tcn "M" "T" + { astTypeDefName = tcn ["M"] "T" , astTypeDefParameters = [("a", KType), ("b", KFun KType KType)] - , astTypeDefConstructors = [ValCon (vcn "M" "C") [TApp () (TVar () "b") (TVar () "a"), TCon () tNat]] + , astTypeDefConstructors = [ValCon (vcn ["M"] "C") [TApp () (TVar () "b") (TVar () "a"), TCon () tNat]] , astTypeDefNameHints = [] } progerror :: ProgError progerror = NoDefSelected progaction :: ProgAction - progaction = MoveToDef $ gvn "M" "main" + progaction = MoveToDef $ gvn ["M"] "main" prog = Prog { progImports = mempty , progModule = Module - { moduleName = "M" + { moduleName = ModuleName ["M"] , moduleTypes = mkTypeDefMap [typeDef] , moduleDefs = Map.singleton (baseName $ astDefName def) (DefAST def) } diff --git a/primer/test/Tests/Transform.hs b/primer/test/Tests/Transform.hs index 506a51e2a..9d8e66c4f 100644 --- a/primer/test/Tests/Transform.hs +++ b/primer/test/Tests/Transform.hs @@ -79,15 +79,15 @@ unit_case_1 = "y" ( case_ (lvar "x") - [ branch' ("M", "A") [("t", Nothing), ("u", Nothing)] (lvar "x") - , branch' ("M", "B") [("v", Nothing), ("w", Nothing)] (lvar "x") + [ branch' (["M"], "A") [("t", Nothing), ("u", Nothing)] (lvar "x") + , branch' (["M"], "B") [("v", Nothing), ("w", Nothing)] (lvar "x") ] ) ( Just ( case_ (lvar "y") - [ branch' ("M", "A") [("t", Nothing), ("u", Nothing)] (lvar "y") - , branch' ("M", "B") [("v", Nothing), ("w", Nothing)] (lvar "y") + [ branch' (["M"], "A") [("t", Nothing), ("u", Nothing)] (lvar "y") + , branch' (["M"], "B") [("v", Nothing), ("w", Nothing)] (lvar "y") ] ) ) @@ -100,8 +100,8 @@ unit_case_2 = "y" ( case_ (lvar "x") - [ branch' ("M", "A") [("t", Nothing), ("u", Nothing)] (lvar "x") - , branch' ("M", "B") [("v", Nothing), ("y", Nothing)] (lvar "x") + [ branch' (["M"], "A") [("t", Nothing), ("u", Nothing)] (lvar "x") + , branch' (["M"], "B") [("v", Nothing), ("y", Nothing)] (lvar "x") ] ) Nothing @@ -115,15 +115,15 @@ unit_case_3 = "y" ( case_ (lvar "x") - [ branch' ("M", "A") [("t", Nothing), ("u", Nothing)] (lvar "x") - , branch' ("M", "B") [("x", Nothing), ("w", Nothing)] (lvar "x") + [ branch' (["M"], "A") [("t", Nothing), ("u", Nothing)] (lvar "x") + , branch' (["M"], "B") [("x", Nothing), ("w", Nothing)] (lvar "x") ] ) ( Just ( case_ (lvar "y") - [ branch' ("M", "A") [("t", Nothing), ("u", Nothing)] (lvar "y") - , branch' ("M", "B") [("x", Nothing), ("w", Nothing)] (lvar "x") + [ branch' (["M"], "A") [("t", Nothing), ("u", Nothing)] (lvar "y") + , branch' (["M"], "B") [("x", Nothing), ("w", Nothing)] (lvar "x") ] ) ) @@ -156,8 +156,8 @@ unit_case = "y" ( case_ (lvar "x") - [ branch' ("M", "A") [("y", Nothing), ("z", Nothing)] (lvar "y") - , branch' ("M", "B") [("u", Nothing), ("v", Nothing)] (lvar "u") + [ branch' (["M"], "A") [("y", Nothing), ("z", Nothing)] (lvar "y") + , branch' (["M"], "B") [("u", Nothing), ("v", Nothing)] (lvar "u") ] ) Nothing @@ -254,12 +254,12 @@ afterRename' rename clearMeta fromVar toVar input output = do unit_unfoldApp_1 :: Assertion unit_unfoldApp_1 = let expr :: Expr' () () - expr = App () (App () (App () (Con () $ vcn "M" "C") (Lam () "x" (v "x"))) (App () (v "w") (v "y"))) (v "z") + expr = App () (App () (App () (Con () $ vcn ["M"] "C") (Lam () "x" (v "x"))) (App () (v "w") (v "y"))) (v "z") v = Var () . LocalVarRef - in unfoldApp expr @?= (Con () $ vcn "M" "C", [Lam () "x" (v "x"), App () (v "w") (v "y"), v "z"]) + in unfoldApp expr @?= (Con () $ vcn ["M"] "C", [Lam () "x" (v "x"), App () (v "w") (v "y"), v "z"]) unit_unfoldApp_2 :: Assertion unit_unfoldApp_2 = let expr :: Expr' () () - expr = Con () $ vcn "M" "C" - in unfoldApp expr @?= (Con () $ vcn "M" "C", []) + expr = Con () $ vcn ["M"] "C" + in unfoldApp expr @?= (Con () $ vcn ["M"] "C", []) diff --git a/primer/test/Tests/Typecheck.hs b/primer/test/Tests/Typecheck.hs index 7fd5b1dfb..6741c07e2 100644 --- a/primer/test/Tests/Typecheck.hs +++ b/primer/test/Tests/Typecheck.hs @@ -54,6 +54,7 @@ import Primer.Core ( ID, Kind (KFun, KHole, KType), Meta (..), + ModuleName (ModuleName), PrimDef (PrimDef, primDefName, primDefType), TmVarRef (LocalVarRef), TyConName, @@ -116,7 +117,7 @@ unit_constructor_doesn't_exist :: Assertion unit_constructor_doesn't_exist = con nope `expectFailsWith` const (UnknownConstructor nope) where - nope = vcn "M" "Nope" + nope = vcn ["M"] "Nope" unit_inc :: Assertion unit_inc = @@ -218,9 +219,9 @@ unit_mkTAppCon = do mkTAppCon c [TCon () x] @?= TApp () (TCon () c) (TCon () x) mkTAppCon c [TCon () x, TCon () y] @?= TApp () (TApp () (TCon () c) (TCon () x)) (TCon () y) where - c = tcn "M1" "C" - x = tcn "M2" "X" - y = tcn "M2" "Y" + c = tcn ["M1"] "C" + x = tcn ["M2"] "X" + y = tcn ["M2"] "Y" -- Note [cover] -- We disable coverage checking as it causes spurious hydra failures which are @@ -298,7 +299,7 @@ unit_ann_bad :: Assertion unit_ann_bad = ann emptyHole (tcon nonexistant) `expectFailsWith` const (UnknownTypeConstructor nonexistant) where - nonexistant = tcn "M" "IDoNotExist" + nonexistant = tcn ["M"] "IDoNotExist" unit_ann_insert :: Assertion unit_ann_insert = @@ -327,12 +328,12 @@ unit_check_emb = unit_case_scrutinee :: Assertion unit_case_scrutinee = - ann (case_ (con cSucc) [branch' ("M", "C") [] $ lvar "x"]) (tcon tBool) + ann (case_ (con cSucc) [branch' (["M"], "C") [] $ lvar "x"]) (tcon tBool) `smartSynthGives` ann (case_ (hole $ con cSucc) []) (tcon tBool) unit_case_branches :: Assertion unit_case_branches = - ann (case_ (con cZero) [branch' ("M", "C") [] $ lvar "x"]) (tcon tBool) + ann (case_ (con cZero) [branch' (["M"], "C") [] $ lvar "x"]) (tcon tBool) `smartSynthGives` ann (case_ (con cZero) [branch cZero [] emptyHole, branch cSucc [("a7", Nothing)] emptyHole]) (tcon tBool) -- Fragile name here "a7" unit_remove_hole :: Assertion @@ -536,7 +537,7 @@ unit_good_maybeT = case runTypecheckTestM NoSmartHoles $ NoSmartHoles CheckEverything { trusted = [builtinModule] - , toCheck = [Module "TestModule" (mkTypeDefMap [TypeDefAST maybeTDef]) mempty] + , toCheck = [Module (ModuleName ["TestModule"]) (mkTypeDefMap [TypeDefAST maybeTDef]) mempty] } of Left err -> assertFailure $ show err Right _ -> pure () @@ -544,12 +545,12 @@ unit_good_maybeT = case runTypecheckTestM NoSmartHoles $ unit_bad_prim_map_base :: Assertion unit_bad_prim_map_base = case runTypecheckTestM NoSmartHoles $ do fooType <- tcon tNat - let foo = PrimDef{primDefName = gvn "M" "bar", primDefType = fooType} + let foo = PrimDef{primDefName = gvn ["M"] "bar", primDefType = fooType} checkEverything NoSmartHoles CheckEverything { trusted = [progModule newProg] - , toCheck = [Module "M" mempty $ Map.singleton "foo" $ DefPrim foo] + , toCheck = [Module (ModuleName ["M"]) mempty $ Map.singleton "foo" $ DefPrim foo] } of Left err -> err @?= InternalError "Inconsistant names in moduleDefs map for module M" Right _ -> assertFailure "Expected failure but succeeded" @@ -557,27 +558,27 @@ unit_bad_prim_map_base = case runTypecheckTestM NoSmartHoles $ do unit_bad_prim_map_module :: Assertion unit_bad_prim_map_module = case runTypecheckTestM NoSmartHoles $ do fooType <- tcon tNat - let foo = PrimDef{primDefName = gvn "OtherMod" "foo", primDefType = fooType} + let foo = PrimDef{primDefName = gvn ["OtherMod"] "foo", primDefType = fooType} checkEverything NoSmartHoles CheckEverything { trusted = [progModule newProg] - , toCheck = [Module "M" mempty $ Map.singleton "foo" $ DefPrim foo] + , toCheck = [Module (ModuleName ["M"]) mempty $ Map.singleton "foo" $ DefPrim foo] } of Left err -> err @?= InternalError "Inconsistant names in moduleDefs map for module M" Right _ -> assertFailure "Expected failure but succeeded" unit_bad_prim_type :: Assertion unit_bad_prim_type = case runTypecheckTestM NoSmartHoles $ do - fooType <- tcon' "M" "NonExistant" - let foo = PrimDef{primDefName = gvn "M" "foo", primDefType = fooType} + fooType <- tcon' ["M"] "NonExistant" + let foo = PrimDef{primDefName = gvn ["M"] "foo", primDefType = fooType} checkEverything NoSmartHoles CheckEverything { trusted = [progModule newProg] - , toCheck = [Module "M" mempty $ Map.singleton "foo" $ DefPrim foo] + , toCheck = [Module (ModuleName ["M"]) mempty $ Map.singleton "foo" $ DefPrim foo] } of - Left err -> err @?= UnknownTypeConstructor (tcn "M" "NonExistant") + Left err -> err @?= UnknownTypeConstructor (tcn ["M"] "NonExistant") Right _ -> assertFailure "Expected failure but succeeded" -- * Helpers @@ -672,19 +673,19 @@ runTypecheckTestMWithPrims sh = testModule :: Module testModule = Module - { moduleName = "TestModule" + { moduleName = ModuleName ["TestModule"] , moduleTypes = mkTypeDefMap [TypeDefAST maybeTDef] , moduleDefs = mempty } tMaybeT :: TyConName -tMaybeT = tcn "TestModule" "MaybeT" +tMaybeT = tcn ["TestModule"] "MaybeT" maybeTDef :: ASTTypeDef maybeTDef = ASTTypeDef { astTypeDefName = tMaybeT , astTypeDefParameters = [("m", KFun KType KType), ("a", KType)] - , astTypeDefConstructors = [ValCon (vcn "TestModule" "MakeMaybeT") [TApp () (TVar () "m") (TApp () (TCon () tMaybe) (TVar () "a"))]] + , astTypeDefConstructors = [ValCon (vcn ["TestModule"] "MakeMaybeT") [TApp () (TVar () "m") (TApp () (TCon () tMaybe) (TVar () "a"))]] , astTypeDefNameHints = [] } diff --git a/primer/test/Tests/Unification.hs b/primer/test/Tests/Unification.hs index 87cfe7c07..e0dd0cb0c 100644 --- a/primer/test/Tests/Unification.hs +++ b/primer/test/Tests/Unification.hs @@ -103,14 +103,14 @@ unit_diff_module_not_refl = (extendTypeDefCxt [mint] defaultCxt) mempty (TCon () tInt) - (TCon () $ tcn "M" "Int") + (TCon () $ tcn ["M"] "Int") ) @?= Nothing where mint = TypeDefAST $ ASTTypeDef - { astTypeDefName = tcn "M" "Int" + { astTypeDefName = tcn ["M"] "Int" , astTypeDefParameters = mempty , astTypeDefConstructors = mempty , astTypeDefNameHints = mempty diff --git a/primer/test/outputs/serialization/def.json b/primer/test/outputs/serialization/def.json index b1aa0d01f..baab4f527 100644 --- a/primer/test/outputs/serialization/def.json +++ b/primer/test/outputs/serialization/def.json @@ -15,7 +15,9 @@ }, "astDefName": { "baseName": "main", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] }, "astDefType": { "contents": [ diff --git a/primer/test/outputs/serialization/edit_response_2.json b/primer/test/outputs/serialization/edit_response_2.json index e3f51e522..bf346e651 100644 --- a/primer/test/outputs/serialization/edit_response_2.json +++ b/primer/test/outputs/serialization/edit_response_2.json @@ -38,7 +38,9 @@ }, "astDefName": { "baseName": "main", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] }, "astDefType": { "contents": [ @@ -54,7 +56,9 @@ "tag": "DefAST" } }, - "moduleName": "M", + "moduleName": [ + "M" + ], "moduleTypes": { "T": { "contents": { @@ -86,7 +90,9 @@ [], { "baseName": "Nat", - "qualifiedModule": "Builtins" + "qualifiedModule": [ + "Builtins" + ] } ], "tag": "TCon" @@ -94,13 +100,17 @@ ], "valConName": { "baseName": "C", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] } } ], "astTypeDefName": { "baseName": "T", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] }, "astTypeDefNameHints": [], "astTypeDefParameters": [ @@ -133,7 +143,9 @@ "progSelection": { "selectedDef": { "baseName": "main", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] }, "selectedNode": { "meta": { diff --git a/primer/test/outputs/serialization/prog.json b/primer/test/outputs/serialization/prog.json index 244cca776..c8d0188c9 100644 --- a/primer/test/outputs/serialization/prog.json +++ b/primer/test/outputs/serialization/prog.json @@ -37,7 +37,9 @@ }, "astDefName": { "baseName": "main", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] }, "astDefType": { "contents": [ @@ -53,7 +55,9 @@ "tag": "DefAST" } }, - "moduleName": "M", + "moduleName": [ + "M" + ], "moduleTypes": { "T": { "contents": { @@ -85,7 +89,9 @@ [], { "baseName": "Nat", - "qualifiedModule": "Builtins" + "qualifiedModule": [ + "Builtins" + ] } ], "tag": "TCon" @@ -93,13 +99,17 @@ ], "valConName": { "baseName": "C", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] } } ], "astTypeDefName": { "baseName": "T", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] }, "astTypeDefNameHints": [], "astTypeDefParameters": [ @@ -132,7 +142,9 @@ "progSelection": { "selectedDef": { "baseName": "main", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] }, "selectedNode": { "meta": { diff --git a/primer/test/outputs/serialization/progaction.json b/primer/test/outputs/serialization/progaction.json index 5eb0e1139..3fffca38b 100644 --- a/primer/test/outputs/serialization/progaction.json +++ b/primer/test/outputs/serialization/progaction.json @@ -1,7 +1,9 @@ { "contents": { "baseName": "main", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] }, "tag": "MoveToDef" } \ No newline at end of file diff --git a/primer/test/outputs/serialization/selection.json b/primer/test/outputs/serialization/selection.json index 107a95980..d26c6fcb7 100644 --- a/primer/test/outputs/serialization/selection.json +++ b/primer/test/outputs/serialization/selection.json @@ -1,7 +1,9 @@ { "selectedDef": { "baseName": "main", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] }, "selectedNode": { "meta": { diff --git a/primer/test/outputs/serialization/typeDef.json b/primer/test/outputs/serialization/typeDef.json index 4d7f83851..e6600f90f 100644 --- a/primer/test/outputs/serialization/typeDef.json +++ b/primer/test/outputs/serialization/typeDef.json @@ -28,7 +28,9 @@ [], { "baseName": "Nat", - "qualifiedModule": "Builtins" + "qualifiedModule": [ + "Builtins" + ] } ], "tag": "TCon" @@ -36,13 +38,17 @@ ], "valConName": { "baseName": "C", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] } } ], "astTypeDefName": { "baseName": "T", - "qualifiedModule": "M" + "qualifiedModule": [ + "M" + ] }, "astTypeDefNameHints": [], "astTypeDefParameters": [