diff --git a/primer-rel8/test/TestUtils.hs b/primer-rel8/test/TestUtils.hs index b4c72acd2..2d6cbce10 100644 --- a/primer-rel8/test/TestUtils.hs +++ b/primer-rel8/test/TestUtils.hs @@ -44,21 +44,30 @@ import Primer.App ( App (..), InitialApp (NewApp), Prog (..), - defaultTypeDefs, newEmptyApp, newEmptyProg, ) +import Primer.Builtins ( + builtinModule, + cFalse, + cJust, + cLeft, + cSucc, + cTrue, + cZero, + tBool, + tEither, + tList, + tMaybe, + tNat, + ) import Primer.Core ( ASTDef (..), - Def (DefAST, DefPrim), - GVarName, + Def (DefAST), + GlobalName (baseName), ID, Kind (KType), - PrimDef (..), - PrimFun, - defName, - primDefType, - primFunType, + qualifyName, ) import Primer.Core.DSL ( aPP, @@ -69,7 +78,7 @@ import Primer.Core.DSL ( con, create, emptyHole, - gvar, + gvar', hole, lAM, lam, @@ -94,12 +103,11 @@ import Primer.Module ( Module ( Module, moduleDefs, + moduleName, moduleTypes ), ) -import Primer.Primitives ( - allPrimDefs, - ) +import Primer.Primitives (primitiveModule) import Rel8 ( Expr, Insert (Insert, into, onConflict, returning, rows), @@ -235,24 +243,27 @@ insertSessionRow row conn = -- so it should be refactored into a common test library. See: -- https://github.com/hackworthltd/primer/issues/273 testASTDef :: ASTDef -testASTDef = - ASTDef - { astDefName = "1" +testASTDefNextID :: ID +(testASTDef, testASTDefNextID) = + ( ASTDef + { astDefName = qualifyName "TestModule" "1" , astDefExpr , astDefType } + , nextID + ) where - ((astDefExpr, astDefType), _) = create $ (,) <$> e <*> t + ((astDefExpr, astDefType), nextID) = create $ (,) <$> e <*> t t = tfun - (tcon "Nat") + (tcon tNat) ( tforall "a" KType ( tapp ( thole ( tapp - (tcon "List") + (tcon tList) tEmptyHole ) ) @@ -262,19 +273,19 @@ testASTDef = e = let_ "x" - (con "True") + (con cTrue) ( letrec "y" ( app ( hole - (con "Just") + (con cJust) ) ( hole - (gvar "0") + (gvar' "TestModule" "0") ) ) ( thole - (tcon "Maybe") + (tcon tMaybe) ) ( ann ( lam @@ -285,9 +296,9 @@ testASTDef = ( aPP ( letType "b" - (tcon "Bool") + (tcon tBool) ( aPP - (con "Left") + (con cLeft) (tvar "b") ) ) @@ -296,11 +307,11 @@ testASTDef = ( case_ (lvar "i") [ branch - "Zero" + cZero [] - (con "False") + (con cFalse) , branch - "Succ" + cSucc [ ( "n" , Nothing @@ -319,14 +330,14 @@ testASTDef = ) ) ( tfun - (tcon "Nat") + (tcon tNat) ( tforall "α" KType ( tapp ( tapp - (tcon "Either") - (tcon "Bool") + (tcon tEither) + (tcon tBool) ) (tvar "α") ) @@ -335,24 +346,6 @@ testASTDef = ) ) --- | Helper function for creating test apps from a predefined list of --- 'ASTDef's and 'PrimFun's. --- --- TODO: move this function into 'Primer.App'. See: --- https://github.com/hackworthltd/primer/issues/273#issuecomment-1058713380 -mkTestDefs :: [ASTDef] -> Map GVarName PrimFun -> (Map GVarName Def, ID) -mkTestDefs astDefs primMap = - let (defs, nextID) = create $ do - primDefs <- for (Map.toList primMap) $ \(primDefName, def) -> do - primDefType <- primFunType def - pure $ - PrimDef - { primDefName - , primDefType - } - pure $ map DefAST astDefs <> map DefPrim primDefs - in (Map.fromList $ (\d -> (defName d, d)) <$> defs, nextID) - -- | An initial test 'App' instance that contains all default type -- definitions (including primitive types), all primitive functions, -- and a top-level definition that contains every construct in the @@ -362,16 +355,17 @@ testApp = newEmptyApp { appProg = testProg , appInit = NewApp - , appIdCounter = fromEnum nextId + , appIdCounter = fromEnum testASTDefNextID } where - (defs, nextId) = mkTestDefs [testASTDef] allPrimDefs testProg :: Prog testProg = newEmptyProg - { progModule = + { progImports = [builtinModule, primitiveModule] + , progModule = Module - { moduleTypes = defaultTypeDefs - , moduleDefs = defs + { 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 166139041..6b6c3c28b 100644 --- a/primer-service/src/Primer/Server.hs +++ b/primer-service/src/Primer/Server.hs @@ -64,9 +64,9 @@ import Primer.App ( Prog, ProgAction (BodyAction, MoveToDef), ProgError (NoDefSelected), - boolDef, newProg, ) +import Primer.Builtins (boolDef) import Primer.Core ( ASTDef (..), ASTTypeDef, @@ -81,8 +81,9 @@ import Primer.Core ( Type' (TEmptyHole), TypeCache (..), TypeCacheBoth (..), + qualifyName, ) -import Primer.Core.DSL (app, branch, case_, create, emptyHole, tEmptyHole, tfun) +import Primer.Core.DSL (app, branch', case_, create, emptyHole, tEmptyHole, tfun) import Primer.Database ( Session, SessionId, @@ -329,14 +330,14 @@ testEndpoints = :<|> mkTest (TCBoth (TEmptyHole ()) (TEmptyHole ())) :<|> mkTest (create' (app emptyHole emptyHole)) :<|> mkTest (create' $ case_ emptyHole []) - :<|> mkTest (create' $ case_ emptyHole [branch "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 "main") + :<|> mkTest (MoveToDef $ qualifyName "M" "main") :<|> mkTest NoDefSelected - :<|> mkTest (DefAST $ ASTDef "main" expr ty) + :<|> mkTest (DefAST $ ASTDef (qualifyName "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 fbe57708e..26280b008 100644 --- a/primer/primer.cabal +++ b/primer/primer.cabal @@ -19,6 +19,7 @@ library Primer.Action.Priorities Primer.API Primer.App + Primer.Builtins Primer.Core Primer.Core.DSL Primer.Core.Transform diff --git a/primer/src/Foreword.hs b/primer/src/Foreword.hs index a35a7b2dd..4ecbf9751 100644 --- a/primer/src/Foreword.hs +++ b/primer/src/Foreword.hs @@ -33,6 +33,7 @@ import Protolude hiding ( gcast, ignore, lenientDecode, + moduleName, orElse, replace, retry, diff --git a/primer/src/Primer/Action.hs b/primer/src/Primer/Action.hs index 2f53081fb..9e4e350c4 100644 --- a/primer/src/Primer/Action.hs +++ b/primer/src/Primer/Action.hs @@ -45,6 +45,7 @@ import Primer.Core ( ID, LVarName, LocalName (LocalName, unLocalName), + ModuleName, TmVarRef (..), TyConName, TyVarName, @@ -58,6 +59,7 @@ import Primer.Core ( bindName, defName, getID, + qualifiedModule, unsafeMkGlobalName, unsafeMkLocalName, valConArgs, @@ -89,7 +91,7 @@ import Primer.Core.DSL ( import Primer.Core.Transform (renameLocalVar, renameTyVar, renameTyVarExpr) import Primer.Core.Utils (forgetTypeIDs, generateTypeIDs) import Primer.JSON -import Primer.Module (Module (moduleDefs, moduleTypes)) +import Primer.Module (Module, insertDef) import Primer.Name (Name, NameCounter, unName) import Primer.Name.Fresh ( isFresh, @@ -103,7 +105,7 @@ import Primer.Typecheck ( CheckEverythingRequest (CheckEverything, toCheck, trusted), SmartHoles, TypeError, - buildTypingContext, + buildTypingContextFromModules, check, checkEverything, exprTtoExpr, @@ -175,8 +177,8 @@ data FunctionFiltering -- This type is parameterised because we may need it for other things in -- future, and because it lets us derive a useful functor instance. data UserInput a - = ChooseConstructor FunctionFiltering (Text -> a) - | ChooseTypeConstructor (Text -> a) + = ChooseConstructor FunctionFiltering (QualifiedText -> a) + | ChooseTypeConstructor (QualifiedText -> a) | -- | Renders a choice between some options (as buttons), -- plus a textbox to manually enter a name ChooseOrEnterName @@ -229,19 +231,24 @@ nameString :: Text nameString = "n" <> T.singleton '\x200C' <> "ame" -- | Given a definition name and a program, return a unique variant of --- that name. Note that if no definition of the given name already --- exists in the program, this function will return the same name --- it's been given. -uniquifyDefName :: Text -> Map ID Def -> Text -uniquifyDefName name' defs = +-- that name (within the specified module). Note that if no definition +-- of the given name already exists in the program, this function will +-- return the same name it's been given. +uniquifyDefName :: C.ModuleName -> Text -> Map ID Def -> Text +uniquifyDefName m name' defs = if name' `notElem` avoid then name' else let go i = if (name' <> "_" <> show i) `notElem` avoid then name' <> "_" <> show i else go (i + 1) in go (1 :: Int) where + f qn + | qualifiedModule qn == m = Just (unName $ baseName qn) + | otherwise = Nothing avoid :: [Text] - avoid = Map.elems $ map (unName . baseName . defName) defs + avoid = mapMaybe (f . defName) $ Map.elems defs + +type QualifiedText = (Text, Text) -- | Core actions. -- These describe edits to the core AST. @@ -283,11 +290,11 @@ data Action | -- | Construct a type abstraction "big-lambda" ConstructLAM (Maybe Text) | -- | Put a constructor in an empty hole - ConstructCon Text + ConstructCon QualifiedText | -- | Put a constructor applied to a saturated spine in an empty hole - ConstructSaturatedCon Text + ConstructSaturatedCon QualifiedText | -- | Put a constructor in an empty hole, and infer what it should be applied to - ConstructRefinedCon Text + ConstructRefinedCon QualifiedText | -- | Put a let expression in an empty hole ConstructLet (Maybe Text) | -- | Put a letrec expression in an empty hole @@ -313,7 +320,7 @@ data Action -- The type under the cursor is placed in the range (right) position. ConstructArrowR | -- | Put a type constructor in a type hole - ConstructTCon Text + ConstructTCon QualifiedText | -- | Construct a type variable in an empty type hole ConstructTVar Text | -- | Construct a forall type (only at kind KType for now) @@ -360,6 +367,9 @@ data ActionError -- a bug. It does not get thrown for "no valid refinement found" -- - see Note [No valid refinement] RefineError (Either Text TypeError) + | -- | Cannot import modules whose names clash with previously-imported things + -- (or with each other) + ImportNameClash [ModuleName] | -- | Importing some modules failed. -- This should be impossible as long as the requested modules are well-typed -- and all of their dependencies are already imported @@ -374,7 +384,7 @@ data ActionError data ProgAction = -- | Move the cursor to the definition with the given Name MoveToDef GVarName - | -- | Rename the definition with the given Name + | -- | Rename the definition with the given (base) Name RenameDef GVarName Text | -- | Create a new definition CreateDef (Maybe Text) @@ -441,11 +451,7 @@ applyActionsToTypeSig :: applyActionsToTypeSig smartHoles imports mod def actions = runReaderT go - ( buildTypingContext - (foldMap moduleTypes $ mod : imports) - (foldMap moduleDefs $ mod : imports) - smartHoles - ) + (buildTypingContextFromModules (mod : imports) smartHoles) & runExceptT where go :: ActionM m => m (ASTDef, Module, TypeZ) @@ -454,8 +460,7 @@ applyActionsToTypeSig smartHoles imports mod def actions = let t = target (top zt) e <- check (forgetTypeIDs t) (astDefExpr def) let def' = def{astDefExpr = exprTtoExpr e, astDefType = t} - defs' = Map.insert (astDefName def) (DefAST def') $ moduleDefs mod - mod' = mod{moduleDefs = defs'} + mod' = insertDef mod (DefAST def') -- The actions were applied to the type successfully, and the definition body has been -- typechecked against the new type. -- Now we need to typecheck the whole program again, to check any uses of the definition @@ -492,14 +497,13 @@ applyActionsToTypeSig smartHoles imports mod def actions = applyActionsToBody :: (MonadFresh ID m, MonadFresh NameCounter m) => SmartHoles -> - Map TyConName TypeDef -> - Map GVarName Def -> + [Module] -> ASTDef -> [Action] -> m (Either ActionError (ASTDef, Loc)) -applyActionsToBody sh typeDefs defs def actions = +applyActionsToBody sh modules def actions = go - & flip runReaderT (buildTypingContext typeDefs defs sh) + & flip runReaderT (buildTypingContextFromModules modules sh) & runExceptT where go :: ActionM m => m (ASTDef, Loc) @@ -526,12 +530,12 @@ applyActionAndCheck ty action z = do -- This is currently only used for tests. -- We may need it in the future for a REPL, where we want to build standalone expressions. --- We take a list of the types that should be in scope for the test. -applyActionsToExpr :: (MonadFresh ID m, MonadFresh NameCounter m) => SmartHoles -> Map TyConName TypeDef -> Expr -> [Action] -> m (Either ActionError (Either ExprZ TypeZ)) -applyActionsToExpr sh typeDefs expr actions = +-- We take a list of the modules that should be in scope for the test. +applyActionsToExpr :: (MonadFresh ID m, MonadFresh NameCounter m) => SmartHoles -> [Module] -> Expr -> [Action] -> m (Either ActionError (Either ExprZ TypeZ)) +applyActionsToExpr sh modules expr actions = foldM (flip applyActionAndSynth) (focusLoc expr) actions -- apply all actions <&> locToEither - & flip runReaderT (buildTypingContext typeDefs mempty sh) + & flip runReaderT (buildTypingContextFromModules modules sh) & runExceptT -- catch any errors applyActionAndSynth :: ActionM m => Action -> Loc -> m Loc @@ -824,12 +828,12 @@ constructLAM mx ze = do result <- flip replace ze <$> lAM x (pure (target ze)) moveExpr Child1 result -constructCon :: ActionM m => Text -> ExprZ -> m ExprZ +constructCon :: ActionM m => QualifiedText -> ExprZ -> m ExprZ constructCon c ze = case target ze of EmptyHole{} -> flip replace ze <$> con (unsafeMkGlobalName c) e -> throwError $ NeedEmptyHole (ConstructCon c) e -constructSatCon :: ActionM m => Text -> ExprZ -> m ExprZ +constructSatCon :: ActionM m => QualifiedText -> ExprZ -> m ExprZ constructSatCon c ze = case target ze of -- Similar comments re smartholes apply as to insertSatVar EmptyHole{} -> do @@ -851,7 +855,7 @@ getConstructorType c = Just (vc, td) -> Right $ valConType td vc Nothing -> Left $ "Could not find constructor " <> show c -constructRefinedCon :: ActionM m => Text -> ExprZ -> m ExprZ +constructRefinedCon :: ActionM m => QualifiedText -> ExprZ -> m ExprZ constructRefinedCon c ze = do let n = unsafeMkGlobalName c cTy <- @@ -1035,7 +1039,7 @@ constructArrowL zt = flip replace zt <$> tfun (pure (target zt)) tEmptyHole constructArrowR :: ActionM m => TypeZ -> m TypeZ constructArrowR zt = flip replace zt <$> tfun tEmptyHole (pure (target zt)) -constructTCon :: ActionM m => Text -> TypeZ -> m TypeZ +constructTCon :: ActionM m => QualifiedText -> TypeZ -> m TypeZ constructTCon c zt = case target zt of TEmptyHole{} -> flip replace zt <$> tcon (unsafeMkGlobalName c) _ -> throwError $ CustomFailure (ConstructTCon c) "can only construct tcon in hole" diff --git a/primer/src/Primer/Action/Available.hs b/primer/src/Primer/Action/Available.hs index 0e5e15b11..5d065ae93 100644 --- a/primer/src/Primer/Action/Available.hs +++ b/primer/src/Primer/Action/Available.hs @@ -42,7 +42,7 @@ import Primer.Core ( Expr' (..), ExprMeta, GVarName, - GlobalName (baseName), + GlobalName (baseName, qualifiedModule), ID, Kind, Meta (..), @@ -97,7 +97,8 @@ actionsForDef l defs def = bodyID = astDefExpr def ^. _exprMetaLens % _id - copyName = uniquifyDefName (unName (baseName $ astDefName def) <> "Copy") defs + qn = astDefName def + copyName = uniquifyDefName (qualifiedModule qn) (unName (baseName qn) <> "Copy") defs in NoInputRequired [ CreateDef (Just copyName) , CopyPasteSig (astDefName def, sigID) [] diff --git a/primer/src/Primer/App.hs b/primer/src/Primer/App.hs index 7f63fcfee..4d7145bce 100644 --- a/primer/src/Primer/App.hs +++ b/primer/src/Primer/App.hs @@ -22,6 +22,7 @@ module Primer.App ( runEditAppM, runQueryAppM, Prog (..), + progAllModules, tcWholeProg, ProgAction (..), ProgError (..), @@ -42,11 +43,6 @@ module Primer.App ( EvalFullReq (..), EvalFullResp (..), lookupASTDef, - boolDef, - natDef, - listDef, - eitherDef, - defaultTypeDefs, ) where import Foreword hiding (mod) @@ -63,7 +59,8 @@ import Data.Generics.Uniplate.Operations (descendM, transform, transformM) import Data.Generics.Uniplate.Zipper ( fromZipper, ) -import Data.List.Extra ((!?)) +import Data.List (intersect, (\\)) +import Data.List.Extra (anySame, disjoint, (!?)) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Optics ( @@ -90,6 +87,7 @@ import Primer.Action ( applyActionsToBody, applyActionsToTypeSig, ) +import Primer.Builtins (builtinModule) import Primer.Core ( ASTDef (..), ASTTypeDef (..), @@ -101,12 +99,11 @@ import Primer.Core ( Expr' (Case, Con, EmptyHole, Hole, Var), ExprMeta, GVarName, - GlobalName (baseName), + GlobalName (baseName, qualifiedModule), ID (..), - Kind (..), LocalName (LocalName, unLocalName), Meta (..), - PrimDef (..), + ModuleName, TmVarRef (GlobalVarRef, LocalVarRef), TyConName, TyVarName, @@ -120,7 +117,6 @@ import Primer.Core ( defName, defPrim, getID, - primFunType, qualifyName, typeDefAST, typesInExpr, @@ -141,9 +137,16 @@ import Primer.Eval (EvalDetail, EvalError) import qualified Primer.Eval as Eval import Primer.EvalFull (Dir, EvalFullError (TimedOut), TerminationBound, evalFull) import Primer.JSON -import Primer.Module (Module (Module, moduleDefs, moduleTypes)) -import Primer.Name (Name, NameCounter, freshName) -import Primer.Primitives (allPrimDefs, allPrimTypeDefs) +import Primer.Module ( + Module (Module, moduleDefs, moduleName, moduleTypes), + deleteDef, + insertDef, + mkTypeDefMap, + moduleDefsQualified, + moduleTypesQualified, + ) +import Primer.Name (Name (unName), NameCounter, freshName, unsafeMkName) +import Primer.Primitives (primitiveModule) import Primer.Questions ( Question (..), generateNameExpr, @@ -157,10 +160,11 @@ import Primer.Typecheck ( SmartHoles (NoSmartHoles, SmartHoles), TypeError, buildTypingContext, + buildTypingContextFromModules, checkDef, checkEverything, checkTypeDefs, - mkTypeDefMap, + mkTypeDefMapQualified, synth, ) import Primer.Zipper ( @@ -204,19 +208,15 @@ data Prog = Prog deriving (Eq, Show, Generic) deriving (FromJSON, ToJSON) via VJSON Prog +progAllModules :: Prog -> [Module] +progAllModules p = progModule p : progImports p + -- Note [Modules] -- The invariant is that the @progImports@ modules are never edited, but -- one can insert new ones (and perhaps delete unneeded ones). -- --- Currently we assume that all Names and IDs are globally unique (across --- all the imported and editable modules). We intend to lift this restriction --- shortly by introducing unique module identifiers. Since the user has no --- control over IDs, this means that importing modules is unsafe: either it may --- break this invariant, or it could fail with no way for a end-user to fix it. --- (Or it would have to do a lot of work to uniquify names and ids, and then --- bear this in mind when importing further modules that may reference these.) --- Since we do not yet expose any way for an end-user to import modules, this --- restriction is not particularly severe in practice. +-- We assume that all Names and IDs are unique within one module, and that +-- module names are unique. -- -- All modules in a @Prog@ shall be well-typed, in the appropriate scope: -- all the imports are in one mutual dependency group @@ -226,13 +226,17 @@ data Prog = Prog -- (and all their dependencies are already imported) importModules :: MonadEditApp m => [Module] -> m () importModules ms = do - -- NB: we do not enforce the invariant that IDs and Names are globally unique - -- (see Note [Modules]), because we plan to only use this function internally - -- until we add unique names to modules. - -- This means that any call to this function should ensure that the IDs/Names - -- in the imported module are distinct from those already existing in the - -- App. p <- gets appProg + -- Module names must be unique + let currentModules = progAllModules p + let currentNames = moduleName <$> currentModules + let newNames = moduleName <$> ms + unless (disjoint currentNames newNames && not (anySame newNames)) $ + throwError $ + ActionError $ + ImportNameClash $ + (currentNames `intersect` newNames) <> (newNames \\ ordNub newNames) + -- Imports must be well-typed (and cannot depend on the editable module) checkedImports <- liftError (ActionError . ImportFailed ()) $ checkEverything NoSmartHoles $ @@ -242,22 +246,22 @@ importModules ms = do -- | Get all type definitions from all modules (including imports) allTypes :: Prog -> Map TyConName TypeDef -allTypes p = foldMap moduleTypes $ progModule p : progImports p +allTypes p = foldMap moduleTypesQualified $ progAllModules p -- | Get all definitions from all modules (including imports) allDefs :: Prog -> Map GVarName Def -allDefs p = foldMap moduleDefs $ progModule p : progImports p +allDefs p = foldMap moduleDefsQualified $ progAllModules p -- | Add a definition to the editable module +-- assumes the def has the correct name to go in the editable module addDef :: ASTDef -> Prog -> Prog addDef d p = let mod = progModule p - defs = moduleDefs mod - defs' = Map.insert (astDefName d) (DefAST d) defs - mod' = mod{moduleDefs = defs'} + mod' = insertDef mod $ DefAST d in p{progModule = mod'} -- | Add a type definition to the editable module +-- assumes the def has the correct name to go in the editable module addTypeDef :: ASTTypeDef -> Prog -> Prog addTypeDef t p = let mod = progModule p @@ -388,8 +392,8 @@ handleQuestion = \case Right zT -> (variablesInScopeTy zT, [], []) pure ((tyvars, termvars), globals) GenerateName defid nodeid typeKind -> do - progTypeDefs <- asks $ moduleTypes . progModule . appProg - progDefs <- asks $ moduleDefs . progModule . appProg + progTypeDefs <- asks $ moduleTypesQualified . progModule . appProg + progDefs <- asks $ moduleDefsQualified . progModule . appProg names <- focusNode' defid nodeid <&> \case Left zE -> generateNameExpr typeKind zE @@ -403,7 +407,7 @@ handleQuestion = \case -- This only looks in the editable module, not in any imports focusNode :: MonadError ProgError m => Prog -> GVarName -> ID -> m (Either (Either ExprZ TypeZ) TypeZip) -focusNode prog = focusNodeDefs $ moduleDefs $ progModule prog +focusNode prog = focusNodeDefs $ moduleDefsQualified $ progModule prog -- This looks in the editable module and also in any imports focusNodeImports :: MonadError ProgError m => Prog -> GVarName -> ID -> m (Either (Either ExprZ TypeZ) TypeZip) @@ -470,15 +474,14 @@ handleEvalFullRequest (EvalFullReq{evalFullReqExpr, evalFullCxtDir, evalFullMaxS -- Prog actions only affect the editable module applyProgAction :: MonadEditApp m => Prog -> Maybe GVarName -> ProgAction -> m (Prog, Maybe GVarName) applyProgAction prog mdefName = \case - MoveToDef d -> case Map.lookup d (moduleDefs $ progModule prog) of + MoveToDef d -> case Map.lookup d (moduleDefsQualified $ progModule prog) of Nothing -> throwError $ DefNotFound d Just _ -> pure (prog, Just d) - DeleteDef d - | mod <- progModule prog - , Map.member d (moduleDefs mod) -> do - let modDefs' = Map.delete d $ moduleDefs mod - mod' = mod{moduleDefs = modDefs'} - prog' = prog{progModule = mod', progSelection = Nothing} + DeleteDef d -> + case deleteDef (progModule prog) d of + Nothing -> throwError $ DefNotFound d + Just mod' -> do + let prog' = prog{progModule = mod', progSelection = Nothing} -- Run a full TC solely to ensure that no references to the removed id -- remain. This is rather inefficient and could be improved in the -- future. @@ -487,42 +490,51 @@ applyProgAction prog mdefName = \case NoSmartHoles CheckEverything{trusted = progImports prog, toCheck = [mod']} pure (prog', Nothing) - DeleteDef d -> throwError $ DefNotFound d - RenameDef d nameStr -> case lookupASTDef d (moduleDefs $ progModule prog) of + RenameDef d nameStr -> case lookupASTDef d (moduleDefsQualified $ progModule prog) of Nothing -> throwError $ DefNotFound d Just def -> do let defs = moduleDefs $ progModule prog - name = unsafeMkGlobalName nameStr - if Map.member name defs - then throwError $ DefAlreadyExists name + oldNameBase = baseName d + newNameBase = unsafeMkName nameStr + newName = qualifyName (moduleName $ progModule prog) newNameBase + if Map.member newNameBase defs + then throwError $ DefAlreadyExists newName else do - let def' = DefAST def{astDefName = name} + let def' = DefAST def{astDefName = newName} defs' <- maybe (throwError $ ActionError NameCapture) pure $ traverse ( traverseOf (#_DefAST % #astDefExpr) $ - renameVar (GlobalVarRef d) (GlobalVarRef name) + renameVar (GlobalVarRef d) (GlobalVarRef newName) ) - (Map.insert name def' $ Map.delete d defs) + (Map.insert newNameBase def' $ Map.delete oldNameBase defs) let prog' = prog & #progSelection ?~ Selection (defName def') Nothing & #progModule % #moduleDefs .~ defs' pure (prog', mdefName) CreateDef n -> do - let defs = moduleDefs $ progModule prog + let mod = progModule prog + let modName = moduleName mod + let defs = moduleDefs mod name <- case n of Just nameStr -> - let name = unsafeMkGlobalName nameStr - in if Map.member name defs + let baseName = unsafeMkName nameStr + name = qualifyName modName baseName + in if Map.member baseName defs then throwError $ DefAlreadyExists name else pure name - Nothing -> fmap qualifyName . freshName $ Set.fromList $ map (baseName . defName) $ Map.elems defs + Nothing -> fmap (qualifyName modName) $ freshName $ Map.keysSet defs expr <- newExpr ty <- newType let def = ASTDef name expr ty pure (addDef def prog{progSelection = Just $ Selection name Nothing}, Just name) AddTypeDef td -> do + -- The frontend should never let this error happen, + -- so we just dump out a raw string for debugging/logging purposes + let m = moduleName $ progModule prog + unless (m == qualifiedModule (astTypeDefName td)) $ + throwError $ TypeDefError $ "Cannot create a type definition with incorrect module name: expected " <> unName m (addTypeDef td prog, mdefName) <$ liftError -- The frontend should never let this error case happen, @@ -534,10 +546,10 @@ applyProgAction prog mdefName = \case -- see https://github.com/hackworthltd/primer/issues/3) (TypeDefError . show @TypeError) ( runReaderT - (checkTypeDefs $ mkTypeDefMap [TypeDefAST td]) - (buildTypingContext (allTypes prog) mempty NoSmartHoles) + (checkTypeDefs $ mkTypeDefMapQualified [TypeDefAST td]) + (buildTypingContextFromModules (progAllModules prog) NoSmartHoles) ) - RenameType old (unsafeMkGlobalName -> new) -> + RenameType old (unsafeMkName -> nameRaw) -> (,Nothing) <$> do traverseOf #progModule @@ -546,17 +558,16 @@ applyProgAction prog mdefName = \case ) prog where + new = qualifyName (qualifiedModule old) nameRaw updateType m = do d0 <- -- NB We do not allow primitive types to be renamed. -- To relax this, we'd have to be careful about how it interacts with type-checking of primitive literals. maybe (throwError $ TypeDefIsPrim old) pure . typeDefAST - =<< maybe (throwError $ TypeDefNotFound old) pure (Map.lookup old m) - -- TODO we should really check this against _all_ modules, but we will very shortly be adding namespacing - when (Map.member new m) $ throwError $ TypeDefAlreadyExists new - let nameRaw = baseName new + =<< maybe (throwError $ TypeDefNotFound old) pure (Map.lookup (baseName old) m) + when (Map.member nameRaw m) $ throwError $ TypeDefAlreadyExists new when (nameRaw `elem` map (unLocalName . fst) (astTypeDefParameters d0)) $ throwError $ TyConParamClash nameRaw - pure $ Map.insert new (TypeDefAST $ d0 & #astTypeDefName .~ new) $ Map.delete old m + pure $ Map.insert nameRaw (TypeDefAST $ d0 & #astTypeDefName .~ new) $ Map.delete (baseName old) m updateRefsInTypes = over (traversed % #_TypeDefAST % #astTypeDefConstructors % traversed % #valConArgs % traversed) @@ -570,12 +581,12 @@ 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 -> new) -> + RenameCon type_ old (unsafeMkGlobalName . (unName (qualifiedModule type_),) -> new) -> (,Nothing) <$> do when (new `elem` allConNames prog) $ throwError $ ConAlreadyExists new traverseOf #progModule - ( traverseOf #moduleTypes updateType + ( updateType <=< traverseOf #moduleDefs (pure . updateDefs) ) prog @@ -593,11 +604,11 @@ applyProgAction prog mdefName = \case over (traversed % #_DefAST % #astDefExpr) $ transform $ over (#_Con % _2) updateName updateName n = if n == old then new else n - RenameTypeParam type_ old (unsafeMkLocalName -> new) -> + RenameTypeParam type_ old (unsafeMkLocalName -> new) -> do (,Nothing) <$> traverseOf #progModule - (traverseOf #moduleTypes updateType) + updateType prog where updateType = @@ -624,7 +635,7 @@ applyProgAction prog mdefName = \case ) $ over _freeVarsTy $ \(_, v) -> TVar () $ updateName v updateName n = if n == old then new else n - AddCon type_ index (unsafeMkGlobalName -> con) -> + AddCon type_ index (unsafeMkGlobalName . (unName (qualifiedModule type_),) -> con) -> (,Nothing) <$> do when (con `elem` allConNames prog) $ throwError $ ConAlreadyExists con @@ -633,9 +644,7 @@ applyProgAction prog mdefName = \case ( traverseOf (#moduleDefs % traversed % #_DefAST % #astDefExpr) updateDefs - <=< traverseOf - #moduleTypes - updateType + <=< updateType ) prog where @@ -649,12 +658,12 @@ applyProgAction prog mdefName = \case (maybe (throwError $ IndexOutOfRange index) pure . insertAt index (ValCon con [])) ) type_ - SetConFieldType type_ con index new -> + SetConFieldType type_ con index new -> do (,Nothing) <$> traverseOf #progModule ( traverseOf #moduleDefs updateDefs - <=< traverseOf #moduleTypes updateType + <=< updateType ) prog where @@ -702,12 +711,12 @@ applyProgAction prog mdefName = \case ) e else pure cb - AddConField type_ con index new -> + AddConField type_ con index new -> do (,Nothing) <$> traverseOf #progModule ( traverseOf #moduleDefs updateDefs - <=< traverseOf #moduleTypes updateType + <=< updateType ) prog where @@ -749,7 +758,7 @@ applyProgAction prog mdefName = \case BodyAction actions -> do withDef mdefName prog $ \def -> do smartHoles <- gets $ progSmartHoles . appProg - res <- applyActionsToBody smartHoles (allTypes prog) (allDefs prog) def actions + res <- applyActionsToBody smartHoles (progAllModules prog) def actions case res of Left err -> throwError $ ActionError err Right (def', z) -> do @@ -813,7 +822,7 @@ withDef mdefName prog f = case mdefName of Nothing -> throwError NoDefSelected Just defname -> do - case lookupASTDef defname (moduleDefs $ progModule prog) of + case lookupASTDef defname (moduleDefsQualified $ progModule prog) of Nothing -> throwError $ DefNotFound defname Just def -> f def @@ -928,13 +937,14 @@ newEmptyProg :: Prog newEmptyProg = let expr = EmptyHole (Meta 1 Nothing Nothing) ty = TEmptyHole (Meta 2 Nothing Nothing) - def = DefAST $ ASTDef "main" expr ty + def = DefAST $ ASTDef (qualifyName "Main" "main") expr ty in Prog { progImports = mempty , progModule = Module - { moduleTypes = mempty - , moduleDefs = Map.singleton (defName def) def + { moduleName = "Main" + , moduleTypes = mempty + , moduleDefs = Map.singleton (baseName $ defName def) def } , progSelection = Nothing , progSmartHoles = SmartHoles @@ -951,39 +961,36 @@ newEmptyApp = , appInit = NewEmptyApp } --- | An initial program with some useful typedefs. +-- | An initial program with some useful typedefs imported. newProg :: Prog newProg = newEmptyProg - { progModule = + { progImports = [builtinModule, primitiveModule] + , progModule = Module - { moduleTypes = defaultTypeDefs - , moduleDefs = defaultDefs + { moduleName = "Main" + , moduleTypes = mempty + , moduleDefs = defaultDefs "Main" } } +-- Since IDs should be unique in a module, we record 'defaultDefsNextID' +-- to initialise the 'appIdCounter' defaultDefsNextId :: ID -defaultDefs :: Map GVarName Def +defaultDefs :: ModuleName -> Map Name Def (defaultDefs, defaultDefsNextId) = let (defs, nextID) = create $ do mainExpr <- emptyHole mainType <- tEmptyHole - let astDefs = + let astDefs m = [ ASTDef - { astDefName = "main" + { astDefName = qualifyName m "main" , astDefExpr = mainExpr , astDefType = mainType } ] - primDefs <- for (Map.toList allPrimDefs) $ \(primDefName, def) -> do - primDefType <- primFunType def - pure $ - PrimDef - { primDefName - , primDefType - } - pure $ map DefAST astDefs <> map DefPrim primDefs - in (Map.fromList $ (\d -> (defName d, d)) <$> defs, nextID) + pure $ \m -> map DefAST $ astDefs m + in (\m -> Map.fromList $ (\d -> (baseName $ defName d, d)) <$> defs m, nextID) -- | An initial app whose program includes some useful definitions. newApp :: App @@ -1154,7 +1161,7 @@ copyPasteBody p (fromDefName, fromId) toDefName setup = do smartHoles <- gets $ progSmartHoles . appProg -- The Loc zipper captures all the changes, they are only reflected in the -- returned Def, which we thus ignore - (oldDef, doneSetup) <- withDef (Just toDefName) p $ \def -> (def,) <$> applyActionsToBody smartHoles (allTypes p) (allDefs p) def setup + (oldDef, doneSetup) <- withDef (Just toDefName) p $ \def -> (def,) <$> applyActionsToBody smartHoles (progAllModules p) def setup tgt <- case doneSetup of Left err -> throwError $ ActionError err Right (_, tgt) -> pure tgt @@ -1239,19 +1246,24 @@ alterTypeDef :: MonadEditApp m => (ASTTypeDef -> m ASTTypeDef) -> TyConName -> - Map TyConName TypeDef -> - m (Map TyConName TypeDef) -alterTypeDef f type_ = - Map.alterF - ( maybe - (throwError $ TypeDefNotFound type_) + Module -> + m Module +alterTypeDef f type_ m = do + unless (qualifiedModule type_ == moduleName m) $ throwError $ TypeDefNotFound type_ + traverseOf + #moduleTypes + ( Map.alterF ( maybe - (throwError $ TypeDefIsPrim type_) - (map (Just . TypeDefAST) . f) - . typeDefAST + (throwError $ TypeDefNotFound type_) + ( maybe + (throwError $ TypeDefIsPrim type_) + (map (Just . TypeDefAST) . f) + . typeDefAST + ) ) + (baseName type_) ) - type_ + m -- | Apply a bottom-up transformation to all branches of case expressions on the given type. transformCaseBranches :: @@ -1275,7 +1287,7 @@ transformCaseBranches prog type_ f = transformM $ \case e -> pure e progCxt :: Prog -> Cxt -progCxt p = buildTypingContext (allTypes p) (allDefs p) (progSmartHoles p) +progCxt p = buildTypingContextFromModules (progAllModules p) (progSmartHoles p) -- | Run a computation in some context whose errors can be promoted to `ProgError`. liftError :: MonadEditApp m => (e -> ProgError) -> ExceptT e m b -> m b @@ -1291,85 +1303,3 @@ allConNames = % #astTypeDefConstructors % traversed % #valConName - -defaultTypeDefs :: Map TyConName TypeDef -defaultTypeDefs = - mkTypeDefMap $ - map - TypeDefAST - [boolDef, natDef, listDef, maybeDef, pairDef, eitherDef] - <> map - TypeDefPrim - (Map.elems allPrimTypeDefs) - --- | A definition of the Bool type -boolDef :: ASTTypeDef -boolDef = - ASTTypeDef - { astTypeDefName = "Bool" - , astTypeDefParameters = [] - , astTypeDefConstructors = - [ ValCon "True" [] - , ValCon "False" [] - ] - , astTypeDefNameHints = ["p", "q"] - } - --- | A definition of the Nat type -natDef :: ASTTypeDef -natDef = - ASTTypeDef - { astTypeDefName = "Nat" - , astTypeDefParameters = [] - , astTypeDefConstructors = - [ ValCon "Zero" [] - , ValCon "Succ" [TCon () "Nat"] - ] - , astTypeDefNameHints = ["i", "j", "n", "m"] - } - --- | A definition of the List type -listDef :: ASTTypeDef -listDef = - ASTTypeDef - { astTypeDefName = "List" - , astTypeDefParameters = [("a", KType)] - , astTypeDefConstructors = - [ ValCon "Nil" [] - , ValCon "Cons" [TVar () "a", TApp () (TCon () "List") (TVar () "a")] - ] - , astTypeDefNameHints = ["xs", "ys", "zs"] - } - --- | A definition of the Maybe type -maybeDef :: ASTTypeDef -maybeDef = - ASTTypeDef - { astTypeDefName = "Maybe" - , astTypeDefParameters = [("a", KType)] - , astTypeDefConstructors = - [ ValCon "Nothing" [] - , ValCon "Just" [TVar () "a"] - ] - , astTypeDefNameHints = ["mx", "my", "mz"] - } - --- | A definition of the Pair type -pairDef :: ASTTypeDef -pairDef = - ASTTypeDef - { astTypeDefName = "Pair" - , astTypeDefParameters = [("a", KType), ("b", KType)] - , astTypeDefConstructors = [ValCon "MakePair" [TVar () "a", TVar () "b"]] - , astTypeDefNameHints = [] - } - --- | A definition of the Either type -eitherDef :: ASTTypeDef -eitherDef = - ASTTypeDef - { astTypeDefName = "Either" - , astTypeDefParameters = [("a", KType), ("b", KType)] - , astTypeDefConstructors = [ValCon "Left" [TVar () "a"], ValCon "Right" [TVar () "b"]] - , astTypeDefNameHints = [] - } diff --git a/primer/src/Primer/Builtins.hs b/primer/src/Primer/Builtins.hs new file mode 100644 index 000000000..7d142e000 --- /dev/null +++ b/primer/src/Primer/Builtins.hs @@ -0,0 +1,176 @@ +-- | This module defines some builtin types that are used to seed initial programs. +-- The definitions here are no different than ones than a user can create, except +-- for the fact that some of the primitive functions (see "Primer.Primitives") +-- refer to these types. +module Primer.Builtins ( + builtinModule, + tBool, + cTrue, + cFalse, + boolDef, + tNat, + cZero, + cSucc, + natDef, + tList, + cNil, + cCons, + listDef, + tMaybe, + cNothing, + cJust, + maybeDef, + tPair, + cMakePair, + pairDef, + tEither, + cLeft, + cRight, + eitherDef, +) where + +import Foreword + +import Primer.Core ( + ASTTypeDef ( + ASTTypeDef, + astTypeDefConstructors, + astTypeDefName, + astTypeDefNameHints, + astTypeDefParameters + ), + GlobalName, + Kind (KType), + TyConName, + Type' (TApp, TCon, TVar), + TypeDef (TypeDefAST), + ValCon (ValCon), + ValConName, + qualifyName, + ) +import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), mkTypeDefMap) +import Primer.Name (Name) + +builtinModuleName :: Name +builtinModuleName = "Builtins" + +builtin :: Name -> GlobalName k +builtin = qualifyName builtinModuleName + +builtinModule :: Module +builtinModule = + Module + { moduleName = builtinModuleName + , moduleTypes = + mkTypeDefMap $ + map TypeDefAST [boolDef, natDef, listDef, maybeDef, pairDef, eitherDef] + , moduleDefs = mempty + } + +tBool :: TyConName +tBool = builtin "Bool" +cTrue, cFalse :: ValConName +cTrue = builtin "True" +cFalse = builtin "False" + +tNat :: TyConName +tNat = builtin "Nat" +cZero, cSucc :: ValConName +cZero = builtin "Zero" +cSucc = builtin "Succ" + +tList :: TyConName +tList = builtin "List" +cNil, cCons :: ValConName +cNil = builtin "Nil" +cCons = builtin "Cons" + +tMaybe :: TyConName +tMaybe = builtin "Maybe" +cNothing :: ValConName +cNothing = builtin "Nothing" +cJust :: ValConName +cJust = builtin "Just" + +tPair :: TyConName +tPair = builtin "Pair" +cMakePair :: ValConName +cMakePair = builtin "MakePair" + +tEither :: TyConName +tEither = builtin "Either" +cLeft, cRight :: ValConName +cLeft = builtin "Left" +cRight = builtin "Right" + +-- | A definition of the Bool type +boolDef :: ASTTypeDef +boolDef = + ASTTypeDef + { astTypeDefName = tBool + , astTypeDefParameters = [] + , astTypeDefConstructors = + [ ValCon cTrue [] + , ValCon cFalse [] + ] + , astTypeDefNameHints = ["p", "q"] + } + +-- | A definition of the Nat type +natDef :: ASTTypeDef +natDef = + ASTTypeDef + { astTypeDefName = tNat + , astTypeDefParameters = [] + , astTypeDefConstructors = + [ ValCon cZero [] + , ValCon cSucc [TCon () tNat] + ] + , astTypeDefNameHints = ["i", "j", "n", "m"] + } + +-- | A definition of the List type +listDef :: ASTTypeDef +listDef = + ASTTypeDef + { astTypeDefName = tList + , astTypeDefParameters = [("a", KType)] + , astTypeDefConstructors = + [ ValCon cNil [] + , ValCon cCons [TVar () "a", TApp () (TCon () tList) (TVar () "a")] + ] + , astTypeDefNameHints = ["xs", "ys", "zs"] + } + +-- | A definition of the Maybe type +maybeDef :: ASTTypeDef +maybeDef = + ASTTypeDef + { astTypeDefName = tMaybe + , astTypeDefParameters = [("a", KType)] + , astTypeDefConstructors = + [ ValCon cNothing [] + , ValCon cJust [TVar () "a"] + ] + , astTypeDefNameHints = ["mx", "my", "mz"] + } + +-- | A definition of the Pair type +pairDef :: ASTTypeDef +pairDef = + ASTTypeDef + { astTypeDefName = tPair + , astTypeDefParameters = [("a", KType), ("b", KType)] + , astTypeDefConstructors = [ValCon cMakePair [TVar () "a", TVar () "b"]] + , astTypeDefNameHints = [] + } + +-- | A definition of the Either type +eitherDef :: ASTTypeDef +eitherDef = + ASTTypeDef + { astTypeDefName = tEither + , astTypeDefParameters = [("a", KType), ("b", KType)] + , astTypeDefConstructors = [ValCon cLeft [TVar () "a"], ValCon cRight [TVar () "b"]] + , astTypeDefNameHints = [] + } diff --git a/primer/src/Primer/Core.hs b/primer/src/Primer/Core.hs index b82399bd3..fecb31d5c 100644 --- a/primer/src/Primer/Core.hs +++ b/primer/src/Primer/Core.hs @@ -12,7 +12,6 @@ module Primer.Core ( Expr' (..), Bind' (..), TmVarRef (..), - varRefName, CaseBranch, CaseBranch' (..), Def (..), @@ -27,8 +26,9 @@ module Primer.Core ( setID, HasMetadata (_metadata), ID (ID), + ModuleName, GlobalNameKind (..), - GlobalName (baseName), + GlobalName (qualifiedModule, baseName), qualifyName, unsafeMkGlobalName, TyConName, @@ -165,25 +165,31 @@ _synthed = #_TCSynthed `afailing` (#_TCEmb % #tcSynthed) -- nodes we're inserting. type ExprMeta = Meta (Maybe TypeCache) +type ModuleName = Name + -- | Tags for 'GlobalName' data GlobalNameKind = ATyCon | AValCon | ADefName --- | Global names are currently the same as 'Name's, but will shortly contain --- a module prefix also. They are tagged with what sort of name they are. -newtype GlobalName (k :: GlobalNameKind) = GlobalName {baseName :: Name} - deriving (Eq, Ord, Generic, Data) - deriving newtype (Show, IsString) - deriving newtype (FromJSON, ToJSON, FromJSONKey, ToJSONKey) +-- | Global names are fully qualified with a module name. +-- They are tagged with what sort of name they are. +data GlobalName (k :: GlobalNameKind) = GlobalName + { qualifiedModule :: ModuleName + , baseName :: Name + } + deriving (Eq, Ord, Generic, Data, Show) + +instance FromJSON (GlobalName k) +instance ToJSON (GlobalName k) -unsafeMkGlobalName :: Text -> GlobalName k -unsafeMkGlobalName = GlobalName . unsafeMkName +-- | Construct a name from a Text. This is called unsafe because there are no +-- guarantees about whether the name refers to anything that is in scope. +unsafeMkGlobalName :: (Text, Text) -> GlobalName k +unsafeMkGlobalName (m, n) = GlobalName (unsafeMkName m) (unsafeMkName n) --- | Currently just wraps the name, but shortly will take another --- argument for a module prefix -qualifyName :: Name -> GlobalName k +qualifyName :: Name -> Name -> GlobalName k qualifyName = GlobalName type TyConName = GlobalName 'ATyCon @@ -201,7 +207,7 @@ data LocalNameKind newtype LocalName (k :: LocalNameKind) = LocalName {unLocalName :: Name} deriving (Eq, Ord, Show, Data, Generic) deriving (IsString) via Name - deriving (FromJSON, ToJSON, FromJSONKey, ToJSONKey) via Name + deriving (FromJSON, ToJSON) via Name unsafeMkLocalName :: Text -> LocalName k unsafeMkLocalName = LocalName . unsafeMkName @@ -250,11 +256,6 @@ data TmVarRef deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON TmVarRef -varRefName :: TmVarRef -> Name -varRefName = \case - GlobalVarRef (GlobalName n) -> n - LocalVarRef (LocalName n) -> n - -- Note [Synthesisable constructors] -- Whilst our calculus is heavily inspired by bidirectional type systems -- (especially McBride's principled rendition), we do not treat constructors @@ -448,7 +449,7 @@ instance HasMetadata (Bind' ExprMeta) where data Def = DefPrim PrimDef | DefAST ASTDef - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON Def -- | A primitive, built-in definition @@ -457,7 +458,7 @@ data PrimDef = PrimDef -- ^ Used for display, and to link to an entry in `allPrimDefs` , primDefType :: Type } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON PrimDef -- | A top-level definition, built from an 'Expr' @@ -466,7 +467,7 @@ data ASTDef = ASTDef , astDefExpr :: Expr , astDefType :: Type } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON ASTDef defName :: Def -> GVarName @@ -496,8 +497,8 @@ data PrimCon -- This should be a key in `allPrimTypeDefs`. primConName :: PrimCon -> TyConName primConName = \case - PrimChar _ -> "Char" - PrimInt _ -> "Int" + PrimChar _ -> qualifyName "Primitives" "Char" + PrimInt _ -> qualifyName "Primitives" "Int" data PrimFun = PrimFun { primFunTypes :: forall m. MonadFresh ID m => m ([Type], Type) @@ -531,7 +532,7 @@ data PrimFunError data TypeDef = TypeDefPrim PrimTypeDef | TypeDefAST ASTTypeDef - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON TypeDef -- | Definition of a primitive data type @@ -540,7 +541,7 @@ data PrimTypeDef = PrimTypeDef , primTypeDefParameters :: [Kind] , primTypeDefNameHints :: [Name] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON PrimTypeDef -- | Definition of an algebraic data type @@ -554,14 +555,14 @@ data ASTTypeDef = ASTTypeDef , astTypeDefConstructors :: [ValCon] , astTypeDefNameHints :: [Name] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON ASTTypeDef data ValCon = ValCon { valConName :: ValConName , valConArgs :: [Type' ()] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON ValCon valConType :: ASTTypeDef -> ValCon -> Type' () diff --git a/primer/src/Primer/Core/DSL.hs b/primer/src/Primer/Core/DSL.hs index cac8d8a60..99f7684a1 100644 --- a/primer/src/Primer/Core/DSL.hs +++ b/primer/src/Primer/Core/DSL.hs @@ -35,6 +35,10 @@ module Primer.Core.DSL ( create, setMeta, S, + tcon', + con', + gvar', + branch', ) where import Foreword @@ -42,6 +46,7 @@ import Foreword import Control.Monad.Fresh (MonadFresh, fresh) import Numeric.Natural (Natural) import Optics (set) +import Primer.Builtins (cCons, cFalse, cJust, cNil, cNothing, cSucc, cTrue, cZero) import Primer.Core ( Bind' (..), CaseBranch, @@ -53,6 +58,7 @@ import Primer.Core ( Kind, LVarName, Meta (..), + ModuleName, PrimCon (..), TmVarRef (..), TyConName, @@ -62,8 +68,10 @@ import Primer.Core ( TypeCache, ValConName, Value, + qualifyName, _metadata, ) +import Primer.Name (Name) newtype S a = S {unS :: State ID a} deriving newtype (Functor, Applicative, Monad) @@ -167,22 +175,36 @@ meta' a = Meta <$> fresh <*> pure a <*> pure Nothing -- These functions rely on particular types being in scope. bool_ :: MonadFresh ID m => Bool -> m Expr -bool_ b = con $ if b then "True" else "False" +bool_ b = con $ if b then cTrue else cFalse nat :: MonadFresh ID m => Natural -> m Expr nat = \case - 0 -> con "Zero" - n -> app (con "Succ") $ nat (n - 1) + 0 -> con cZero + n -> app (con cSucc) $ nat (n - 1) maybe_ :: MonadFresh ID m => m Type -> (a -> m Expr) -> Maybe a -> m Expr maybe_ t f = \case - Nothing -> con "Nothing" `aPP` t - Just x -> con "Just" `aPP` t `app` f x + Nothing -> con cNothing `aPP` t + Just x -> con cJust `aPP` t `app` f x list_ :: MonadFresh ID m => TyConName -> [m Expr] -> m Expr list_ t = foldr ( \a b -> - con "Cons" + con cCons `aPP` tcon t `app` a `app` b ) - (con "Nil" `aPP` tcon t) + (con cNil `aPP` tcon 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 + +con' :: MonadFresh ID m => ModuleName -> Name -> m Expr +con' m n = con $ qualifyName m n + +gvar' :: MonadFresh ID m => ModuleName -> Name -> m Expr +gvar' m n = gvar $ qualifyName m n + +branch' :: MonadFresh ID m => (ModuleName, Name) -> [(LVarName, Maybe TypeCache)] -> m Expr -> m CaseBranch +branch' (m, n) = branch $ qualifyName m n diff --git a/primer/src/Primer/Core/Transform.hs b/primer/src/Primer/Core/Transform.hs index d2a994fcb..e1ed17a3f 100644 --- a/primer/src/Primer/Core/Transform.hs +++ b/primer/src/Primer/Core/Transform.hs @@ -17,7 +17,17 @@ import Control.Monad.Fresh (MonadFresh) import Data.Data (Data) import Data.Generics.Uniplate.Data (descendM) import qualified Data.List.NonEmpty as NE -import Primer.Core (CaseBranch' (..), Expr, Expr' (..), ID, LVarName, LocalName (unLocalName), TmVarRef (..), TyVarName, Type' (..), bindName, varRefName) +import Primer.Core ( + CaseBranch' (..), + Expr, + Expr' (..), + ID, + LVarName, + TmVarRef (..), + TyVarName, + Type' (..), + bindName, + ) import Primer.Core.DSL (meta) -- AST transformations. @@ -28,44 +38,27 @@ import Primer.Core.DSL (meta) -- Returns 'Nothing' if replacement could result in variable capture. -- See the tests for explanation and examples. renameVar :: (Data a, Data b) => TmVarRef -> TmVarRef -> Expr' a b -> Maybe (Expr' a b) -renameVar x y = - let xn = varRefName x - yn = varRefName y - in \case - Lam m v e - | LocalVarRef v == x -> pure $ Lam m v e - | LocalVarRef v == y -> Nothing - -- If we have the same Name, but different local/global scopes - -- also bail out as something has gone wrong. - | unLocalName v == xn || unLocalName v == yn -> Nothing - | otherwise -> Lam m v <$> renameVar x y e - Let m v e1 e2 - | LocalVarRef v == x -> pure $ Let m v e1 e2 - | LocalVarRef v == y -> Nothing - -- If we have the same Name, but different local/global scopes - -- also bail out as something has gone wrong. - | unLocalName v == xn || unLocalName v == yn -> Nothing - | otherwise -> Let m v <$> renameVar x y e1 <*> renameVar x y e2 - Case m scrut branches -> Case m <$> renameVar x y scrut <*> mapM renameBranch branches - where - renameBranch b@(CaseBranch con termargs rhs) - | LocalVarRef lx <- x, lx `elem` bindingNames b = pure b - | LocalVarRef ly <- y, ly `elem` bindingNames b = Nothing - -- If we have the same Name, but different local/global scopes - -- also bail out as something has gone wrong. - | bns <- map unLocalName $ bindingNames b - , xn `elem` bns || yn `elem` bns = - Nothing - | otherwise = CaseBranch con termargs <$> renameVar x y rhs - bindingNames (CaseBranch _ bs _) = map bindName bs - Var m v - | v == x -> pure $ Var m y - | v == y -> Nothing - -- If we have the same Name, but different local/global scopes - -- also bail out as something has gone wrong. - | varRefName v == xn || varRefName v == yn -> Nothing - | otherwise -> pure $ Var m v - e -> descendM (renameVar x y) e +renameVar x y = \case + Lam m v e + | LocalVarRef v == x -> pure $ Lam m v e + | LocalVarRef v == y -> Nothing + | otherwise -> Lam m v <$> renameVar x y e + Let m v e1 e2 + | LocalVarRef v == x -> pure $ Let m v e1 e2 + | LocalVarRef v == y -> Nothing + | otherwise -> Let m v <$> renameVar x y e1 <*> renameVar x y e2 + Case m scrut branches -> Case m <$> renameVar x y scrut <*> mapM renameBranch branches + where + renameBranch b@(CaseBranch con termargs rhs) + | LocalVarRef lx <- x, lx `elem` bindingNames b = pure b + | LocalVarRef ly <- y, ly `elem` bindingNames b = Nothing + | otherwise = CaseBranch con termargs <$> renameVar x y rhs + bindingNames (CaseBranch _ bs _) = map bindName bs + Var m v + | v == x -> pure $ Var m y + | v == y -> Nothing + | otherwise -> pure $ Var m v + e -> descendM (renameVar x y) e -- | As 'renameVar', but specialised to local variables renameLocalVar :: (Data a, Data b) => LVarName -> LVarName -> Expr' a b -> Maybe (Expr' a b) diff --git a/primer/src/Primer/Module.hs b/primer/src/Primer/Module.hs index 7e67ab45e..6ee87d80d 100644 --- a/primer/src/Primer/Module.hs +++ b/primer/src/Primer/Module.hs @@ -1,12 +1,69 @@ -module Primer.Module (Module (..)) where +module Primer.Module ( + Module (..), + mkTypeDefMap, + qualifyTyConName, + moduleTypesQualified, + qualifyDefName, + moduleDefsQualified, + insertDef, + deleteDef, +) where +import Data.Data (Data) +import Data.Map (delete, insert, mapKeys, member) +import qualified Data.Map as M import Foreword -import Primer.Core (Def, GlobalName, GlobalNameKind (ADefName, ATyCon), TypeDef) +import Primer.Core ( + Def, + GVarName, + GlobalName (baseName), + ModuleName, + TyConName, + TypeDef, + defName, + qualifyName, + typeDefName, + ) import Primer.JSON +import Primer.Name (Name) data Module = Module - { moduleTypes :: Map (GlobalName 'ATyCon) TypeDef - , moduleDefs :: Map (GlobalName 'ADefName) Def -- The current program: a set of definitions indexed by Name + { moduleName :: ModuleName + , -- Invariant: the names are consistent: keys cache the names in the Defs. + -- In particular, if (n,d) is in the moduleDefs map, + -- then "qualifyDefName m n == defName d" + moduleTypes :: Map Name TypeDef + , moduleDefs :: Map Name Def -- The current program: a set of definitions indexed by Name } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON Module + +-- | Create a mapping of name to typedef for use in modules. +-- Ensures that @baseName $ typeDefName (mkTypeDefMap ! n) == n@ +-- Assumes that all the typedefs have the same @qualifiedModule@ part to their name. +mkTypeDefMap :: [TypeDef] -> Map Name TypeDef +mkTypeDefMap defs = M.fromList $ map (\d -> (baseName $ typeDefName d, d)) defs + +qualifyTyConName :: Module -> Name -> TyConName +qualifyTyConName m = qualifyName (moduleName m) + +moduleTypesQualified :: Module -> Map TyConName TypeDef +moduleTypesQualified m = mapKeys (qualifyTyConName m) $ moduleTypes m + +qualifyDefName :: Module -> Name -> GVarName +qualifyDefName m = qualifyName (moduleName m) + +moduleDefsQualified :: Module -> Map GVarName Def +moduleDefsQualified m = mapKeys (qualifyDefName m) $ moduleDefs m + +-- | This assumes that the definition has the correct name to be inserted +-- into the module. I.e. @qualifiedModule (defName d) == moduleName m@. +insertDef :: Module -> Def -> Module +insertDef m d = m{moduleDefs = insert (baseName $ defName d) d $ moduleDefs m} + +-- | Returns 'Nothing' if (and only if) the definition was not found in the module +deleteDef :: Module -> GVarName -> Maybe Module +deleteDef m d = + if d `member` moduleDefsQualified m + then Just $ m{moduleDefs = delete (baseName d) (moduleDefs m)} + else Nothing diff --git a/primer/src/Primer/Name/Fresh.hs b/primer/src/Primer/Name/Fresh.hs index 1297fbfb0..f6ad7d23c 100644 --- a/primer/src/Primer/Name/Fresh.hs +++ b/primer/src/Primer/Name/Fresh.hs @@ -63,7 +63,7 @@ mkAvoidForFreshNameTy :: MonadReader TC.Cxt m => TypeZ -> m (S.Set Name) mkAvoidForFreshNameTy t = do let moreGlobal = bindersAboveTypeZ t moreLocal = S.map unLocalName $ bindersBelowTy $ focusOnlyType t - globals <- TC.getGlobalNames + globals <- TC.getGlobalBaseNames pure $ S.unions [moreGlobal, moreLocal, globals] mkFreshNameTy :: (MonadFresh NameCounter m, MonadReader TC.Cxt m) => TypeZ -> m Name @@ -73,5 +73,5 @@ mkAvoidForFreshName :: MonadReader TC.Cxt m => ExprZ -> m (S.Set Name) mkAvoidForFreshName e = do let moreGlobal = bindersAbove e moreLocal = bindersBelow e - globals <- TC.getGlobalNames + globals <- TC.getGlobalBaseNames pure $ S.unions [moreGlobal, moreLocal, globals] diff --git a/primer/src/Primer/Primitives.hs b/primer/src/Primer/Primitives.hs index 73f84fdad..f652ae9dc 100644 --- a/primer/src/Primer/Primitives.hs +++ b/primer/src/Primer/Primitives.hs @@ -1,8 +1,12 @@ {-# LANGUAGE ViewPatterns #-} module Primer.Primitives ( + primitiveModule, allPrimDefs, allPrimTypeDefs, + tInt, + tChar, + primitiveGVar, ) where import Foreword @@ -10,15 +14,30 @@ import Foreword import Data.Bitraversable (bisequence) import qualified Data.Map as M import Numeric.Natural (Natural) +import Primer.Builtins ( + cJust, + cNothing, + cSucc, + cZero, + tBool, + tMaybe, + tNat, + ) import Primer.Core ( + Def (DefPrim), Expr' (App, Con, PrimCon), ExprAnyFresh (..), GVarName, + GlobalName (baseName), PrimCon (..), + PrimDef (PrimDef, primDefName, primDefType), PrimFun (..), PrimFunError (..), PrimTypeDef (..), TyConName, + TypeDef (TypeDefPrim), + primFunType, + qualifyName, ) import Primer.Core.DSL ( aPP, @@ -26,19 +45,58 @@ import Primer.Core.DSL ( bool_, char, con, + create, int, maybe_, nat, tapp, tcon, ) +import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes)) +import Primer.Name (Name) + +primitiveModuleName :: Name +primitiveModuleName = "Primitives" + +primitive :: Name -> GlobalName k +primitive = qualifyName primitiveModuleName + +-- | This module depends on the builtin module, due to some terms referencing builtin types. +-- It contains all primitive types and terms. +primitiveModule :: Module +primitiveModule = + Module + { moduleName = primitiveModuleName + , moduleTypes = TypeDefPrim <$> M.mapKeys baseName allPrimTypeDefs + , moduleDefs = fst . create $ + getAp $ + flip M.foldMapWithKey allPrimDefs $ \n def -> Ap $ do + ty <- primFunType def + pure $ + M.singleton (baseName n) $ + DefPrim + PrimDef + { primDefName = n + , primDefType = ty + } + } + +tChar :: TyConName +tChar = primitive "Char" + +tInt :: TyConName +tInt = primitive "Int" + +-- | Construct a reference to a primitive definition. For use in tests. +primitiveGVar :: Name -> GVarName +primitiveGVar = primitive -- | Primitive type definitions. -- There should be one entry here for each constructor of `PrimCon`. allPrimTypeDefs :: Map TyConName PrimTypeDef allPrimTypeDefs = M.fromList - [ let name = "Char" + [ let name = tChar in ( name , PrimTypeDef { primTypeDefName = name @@ -46,7 +104,7 @@ allPrimTypeDefs = , primTypeDefNameHints = ["c"] } ) - , let name = "Int" + , let name = tInt in ( name , PrimTypeDef { primTypeDefName = name @@ -67,128 +125,128 @@ allPrimTypeDefs = allPrimDefs :: Map GVarName PrimFun allPrimDefs = M.fromList - [ let name = "toUpper" + [ let name = primitiveGVar "toUpper" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Char"] $ tcon "Char" + { primFunTypes = sequenceTypes [tcon tChar] (tcon tChar) , primFunDef = \case [PrimCon _ (PrimChar c)] -> Right $ ExprAnyFresh $ char $ toUpper c xs -> Left $ PrimFunError name xs } ) - , let name = "isSpace" + , let name = primitiveGVar "isSpace" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Char"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tChar] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimChar c)] -> Right $ ExprAnyFresh $ bool_ $ isSpace c xs -> Left $ PrimFunError name xs } ) - , let name = "hexToNat" + , let name = primitiveGVar "hexToNat" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Char"] $ tcon "Maybe" `tapp` tcon "Nat" + { primFunTypes = sequenceTypes [tcon tChar] $ tcon tMaybe `tapp` tcon tNat , primFunDef = \case [PrimCon _ (PrimChar c)] -> do - Right $ ExprAnyFresh $ maybe_ (tcon "Nat") nat $ digitToIntSafe c + Right $ ExprAnyFresh $ maybe_ (tcon tNat) nat $ digitToIntSafe c where digitToIntSafe :: Char -> Maybe Natural digitToIntSafe c' = fromIntegral <$> (guard (isHexDigit c') $> digitToInt c') xs -> Left $ PrimFunError name xs } ) - , let name = "natToHex" + , let name = primitiveGVar "natToHex" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Nat"] $ tcon "Maybe" `tapp` tcon "Char" + { primFunTypes = sequenceTypes [tcon tNat] $ tcon tMaybe `tapp` tcon tChar , primFunDef = \case [exprToNat -> Just n] -> - Right $ ExprAnyFresh $ maybe_ (tcon "Char") char $ intToDigitSafe n + Right $ ExprAnyFresh $ maybe_ (tcon tChar) char $ intToDigitSafe n where intToDigitSafe :: Natural -> Maybe Char intToDigitSafe n' = guard (0 <= n && n <= 15) $> intToDigit (fromIntegral n') xs -> Left $ PrimFunError name xs } ) - , let name = "eqChar" + , let name = primitiveGVar "eqChar" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Char", tcon "Char"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tChar, tcon tChar] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimChar c1), PrimCon _ (PrimChar c2)] -> Right $ ExprAnyFresh $ bool_ $ c1 == c2 xs -> Left $ PrimFunError name xs } ) - , let name = "Int.+" + , let name = primitiveGVar "Int.+" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tInt) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ int $ x + y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.-" + , let name = primitiveGVar "Int.-" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tInt) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ int $ x - y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.×" + , let name = primitiveGVar "Int.×" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tInt) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ int $ x * y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.quotient" + , let name = primitiveGVar "Int.quotient" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Maybe" `tapp` tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] $ tcon tMaybe `tapp` tcon tInt , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ if y == 0 - then con "Nothing" `aPP` tcon "Int" + then con cNothing `aPP` tcon tInt else - con "Just" `aPP` tcon "Int" + con cJust `aPP` tcon tInt `app` int (x `div` y) xs -> Left $ PrimFunError name xs } ) - , let name = "Int.remainder" + , let name = primitiveGVar "Int.remainder" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Maybe" `tapp` tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] $ tcon tMaybe `tapp` tcon tInt , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ if y == 0 - then con "Nothing" `aPP` tcon "Int" + then con cNothing `aPP` tcon tInt else - con "Just" `aPP` tcon "Int" + con cJust `aPP` tcon tInt `app` int (x `mod` y) xs -> Left $ PrimFunError name xs } ) - , let name = "Int.quot" + , let name = primitiveGVar "Int.quot" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tInt) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ @@ -199,10 +257,10 @@ allPrimDefs = xs -> Left $ PrimFunError name xs } ) - , let name = "Int.rem" + , let name = primitiveGVar "Int.rem" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tInt) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ @@ -213,86 +271,86 @@ allPrimDefs = xs -> Left $ PrimFunError name xs } ) - , let name = "Int.<" + , let name = primitiveGVar "Int.<" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x < y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.≤" + , let name = primitiveGVar "Int.≤" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x <= y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.>" + , let name = primitiveGVar "Int.>" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x > y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.≥" + , let name = primitiveGVar "Int.≥" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x >= y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.=" + , let name = primitiveGVar "Int.=" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x == y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.≠" + , let name = primitiveGVar "Int.≠" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x /= y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.toNat" + , let name = primitiveGVar "Int.toNat" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int"] $ tcon "Maybe" `tapp` tcon "Nat" + { primFunTypes = sequenceTypes [tcon tInt] $ tcon tMaybe `tapp` tcon tNat , primFunDef = \case [PrimCon _ (PrimInt x)] -> Right $ ExprAnyFresh $ if x < 0 - then con "Nothing" `aPP` tcon "Nat" + then con cNothing `aPP` tcon tNat else - con "Just" - `aPP` tcon "Nat" `app` nat (fromInteger x) + con cJust + `aPP` tcon tNat `app` nat (fromInteger x) xs -> Left $ PrimFunError name xs } ) - , let name = "Int.fromNat" + , let name = primitiveGVar "Int.fromNat" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Nat"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tNat] (tcon tInt) , primFunDef = \case [exprToNat -> Just n] -> Right $ ExprAnyFresh $ int $ fromIntegral n @@ -303,6 +361,6 @@ allPrimDefs = where sequenceTypes args res = bisequence (sequence args, res) exprToNat = \case - Con _ "Zero" -> Just 0 - App _ (Con _ "Succ") x -> succ <$> exprToNat x + Con _ c | c == cZero -> Just 0 + App _ (Con _ c) x | c == cSucc -> succ <$> exprToNat x _ -> Nothing diff --git a/primer/src/Primer/Questions.hs b/primer/src/Primer/Questions.hs index 2435edc44..a6a04e8d1 100644 --- a/primer/src/Primer/Questions.hs +++ b/primer/src/Primer/Questions.hs @@ -31,7 +31,7 @@ import Primer.Core ( ) import Primer.Name (Name, unName, unsafeMkName) import Primer.Name.Fresh (mkAvoidForFreshName, mkAvoidForFreshNameTy) -import Primer.Typecheck (Cxt, decomposeTAppCon, getGlobalNames, typeDefs) +import Primer.Typecheck (Cxt, decomposeTAppCon, getGlobalBaseNames, typeDefs) import Primer.Zipper ( ExprZ, TypeZ, @@ -131,7 +131,7 @@ getAvoidSet = \case getAvoidSetTy :: MonadReader Cxt m => TypeZip -> m (Set.Set Name) getAvoidSetTy z = do - globals <- getGlobalNames + globals <- getGlobalBaseNames pure $ Set.map unLocalName (bindersAboveTy z <> bindersBelowTy z) <> globals -- We do not use Name.freshName as we don't want a global fresh counter diff --git a/primer/src/Primer/Typecheck.hs b/primer/src/Primer/Typecheck.hs index 3d3b47ae9..3e6a0de16 100644 --- a/primer/src/Primer/Typecheck.hs +++ b/primer/src/Primer/Typecheck.hs @@ -26,6 +26,7 @@ module Primer.Typecheck ( KindOrType (..), initialCxt, buildTypingContext, + buildTypingContextFromModules, TypeError (..), typeOf, maybeTypeOf, @@ -44,11 +45,12 @@ module Primer.Typecheck ( checkDef, substituteTypeVars, getGlobalNames, + getGlobalBaseNames, lookupGlobal, lookupLocalTy, lookupVar, primConInScope, - mkTypeDefMap, + mkTypeDefMapQualified, consistentKinds, consistentTypes, extendLocalCxtTy, @@ -56,12 +58,14 @@ module Primer.Typecheck ( extendLocalCxt, extendLocalCxts, extendGlobalCxt, + extendTypeDefCxt, localTmVars, localTyVars, ) where import Foreword +import Control.Arrow ((&&&)) import Control.Monad.Fresh (MonadFresh (..)) import Control.Monad.NestedError (MonadNestedError (..)) import Data.Functor.Compose (Compose (Compose), getCompose) @@ -81,12 +85,13 @@ import Primer.Core ( Expr' (..), ExprMeta, GVarName, - GlobalName (baseName), + GlobalName (baseName, qualifiedModule), ID, Kind (..), LVarName, LocalName (LocalName), Meta (..), + ModuleName, PrimCon, PrimDef (primDefType), TmVarRef (..), @@ -116,8 +121,18 @@ import Primer.Core ( import Primer.Core.DSL (branch, emptyHole, meta, meta') import Primer.Core.Utils (alphaEqTy, forgetTypeIDs, freshLocalName, generateTypeIDs) import Primer.JSON (CustomJSON (CustomJSON), FromJSON, ToJSON, VJSON) -import Primer.Module (Module (moduleDefs, moduleTypes)) -import Primer.Name (Name, NameCounter, freshName) +import Primer.Module ( + Module ( + moduleDefs, + moduleName, + moduleTypes + ), + moduleDefsQualified, + moduleTypesQualified, + qualifyDefName, + qualifyTyConName, + ) +import Primer.Name (Name (unName), NameCounter, freshName) import Primer.Subst (substTy) -- | Typechecking takes as input an Expr with 'Maybe Type' annotations and @@ -253,6 +268,17 @@ buildTypingContext tydefs defs sh = let globals = Map.elems $ fmap (\def -> (defName def, forgetTypeIDs (defType def))) defs in extendTypeDefCxt (Map.elems tydefs) $ extendGlobalCxt globals $ initialCxt sh +buildTypingContextFromModules :: [Module] -> SmartHoles -> Cxt +buildTypingContextFromModules modules = + buildTypingContext + (foldMap moduleTypesQualified modules) + (foldMap moduleDefsQualified modules) + +-- | Create a mapping of name to typedef for fast lookup. +-- Ensures that @typeDefName (mkTypeDefMap ! n) == n@ +mkTypeDefMapQualified :: [TypeDef] -> Map TyConName TypeDef +mkTypeDefMapQualified defs = M.fromList $ map (\d -> (typeDefName d, d)) defs + -- | Create a mapping of name to typedef for fast lookup. -- Ensures that @typeDefName (mkTypeDefMap ! n) == n@ mkTypeDefMap :: [TypeDef] -> Map TyConName TypeDef @@ -366,6 +392,12 @@ checkTypeDefs tds = do checkTypeDef td = do let params = astTypeDefParameters td let cons = astTypeDefConstructors td + assert + ( (1 ==) . S.size $ + S.fromList $ + qualifiedModule (astTypeDefName td) : fmap (qualifiedModule . valConName) cons + ) + "Module name of type and all constructors must be the same" assert (distinct $ map (unLocalName . fst) params <> map (baseName . valConName) cons) "Duplicate names in one tydef: between parameter-names and constructor-names" @@ -403,17 +435,18 @@ checkEverything :: CheckEverythingRequest -> m [Module] checkEverything sh CheckEverything{trusted, toCheck} = - let cxt = - buildTypingContext - (foldMap moduleTypes trusted) - (foldMap moduleDefs trusted) - sh + let cxt = buildTypingContextFromModules trusted sh in flip runReaderT cxt $ do + -- Check the type definitions have the right modules + for_ toCheck $ \m -> flip Map.traverseWithKey (moduleTypes m) $ \n td -> + unless (qualifyTyConName m n == typeDefName td) $ + throwError' $ InternalError $ "Inconsistant names in moduleTypes for module " <> unName (moduleName m) -- Check that the definition map has the right keys for_ toCheck $ \m -> flip Map.traverseWithKey (moduleDefs m) $ \n d -> - unless (n == defName d) $ throwError' $ InternalError "Inconsistant names in moduleDefs map" - checkTypeDefs $ foldMap moduleTypes toCheck - let newTypes = foldMap moduleTypes toCheck + unless (qualifyDefName m n == defName d) $ + throwError' $ InternalError $ "Inconsistant names in moduleDefs map for module " <> unName (moduleName m) + checkTypeDefs $ foldMap moduleTypesQualified toCheck + let newTypes = foldMap moduleTypesQualified toCheck newDefs = foldMap (\d -> [(defName d, forgetTypeIDs $ defType d)]) $ foldMap moduleDefs toCheck @@ -861,7 +894,7 @@ checkBranch t (vc, args) (CaseBranch nb patterns rhs) = -- if the branch is nonsense, replace it with a sensible pattern and an empty hole (False, SmartHoles) -> do -- Avoid automatically generated names shadowing anything - globals <- getGlobalNames + globals <- getGlobalBaseNames locals <- asks $ M.keysSet . localCxt liftA2 (,) (mapM (createBinding (locals <> globals)) args) emptyHole -- otherwise, convert all @Maybe TypeCache@ metadata to @TypeCache@ @@ -975,16 +1008,21 @@ typeTtoType :: TypeT -> Type' TypeMeta typeTtoType = over _typeMeta (fmap Just) -- Helper to create fresh names -getGlobalNames :: MonadReader Cxt m => m (S.Set Name) +getGlobalNames :: MonadReader Cxt m => m (S.Set (ModuleName, Name)) getGlobalNames = do tyDefs <- asks typeDefs - topLevel <- asks $ S.fromList . map baseName . M.keys . globalCxt + topLevel <- asks $ S.fromList . map f . M.keys . globalCxt let ctors = Map.foldMapWithKey ( \t def -> S.fromList $ - (baseName t :) $ - map (baseName . valConName) $ maybe [] astTypeDefConstructors $ typeDefAST def + (f t :) $ + map (f . valConName) $ maybe [] astTypeDefConstructors $ typeDefAST def ) tyDefs pure $ S.union topLevel ctors + where + f = qualifiedModule &&& baseName + +getGlobalBaseNames :: MonadReader Cxt m => m (S.Set Name) +getGlobalBaseNames = S.map snd <$> getGlobalNames diff --git a/primer/test/Gen/Core/Raw.hs b/primer/test/Gen/Core/Raw.hs index 302ccf410..bb7c815cd 100644 --- a/primer/test/Gen/Core/Raw.hs +++ b/primer/test/Gen/Core/Raw.hs @@ -9,6 +9,7 @@ module Gen.Core.Raw ( evalExprGen, genID, genName, + genModuleName, genLVarName, genTyVarName, genTyConName, @@ -84,8 +85,11 @@ genApp = App <$> genMeta <*> genExpr <*> genExpr genAPP :: ExprGen Expr genAPP = APP <$> genMeta <*> genExpr <*> genType +genModuleName :: MonadGen m => m Name +genModuleName = Gen.frequency [(9, pure "M"), (1, genName)] + genValConName :: ExprGen ValConName -genValConName = qualifyName <$> genName +genValConName = qualifyName <$> genModuleName <*> genName genCon :: ExprGen Expr genCon = Con <$> genMeta <*> genValConName @@ -100,7 +104,7 @@ genLocalVar :: ExprGen Expr genLocalVar = Var <$> genMeta <*> (LocalVarRef <$> genLVarName) genGlobalVar :: ExprGen Expr -genGlobalVar = Var <$> genMeta <*> (GlobalVarRef . qualifyName <$> genName) +genGlobalVar = Var <$> genMeta <*> ((\m n -> GlobalVarRef $ qualifyName m n) <$> genModuleName <*> genName) genLet :: ExprGen Expr genLet = Let <$> genMeta <*> genLVarName <*> genExpr <*> genExpr @@ -148,7 +152,7 @@ genType = ] genTyConName :: ExprGen TyConName -genTyConName = qualifyName <$> genName +genTyConName = qualifyName <$> genModuleName <*> genName genKind :: ExprGen Kind genKind = Gen.recursive Gen.choice [pure KType, pure KHole] [KFun <$> genKind <*> genKind] diff --git a/primer/test/Gen/Core/Typed.hs b/primer/test/Gen/Core/Typed.hs index 99faed814..66bc8967e 100644 --- a/primer/test/Gen/Core/Typed.hs +++ b/primer/test/Gen/Core/Typed.hs @@ -33,7 +33,7 @@ import Control.Monad.Fresh (MonadFresh, fresh) import Control.Monad.Morph (hoist) import Control.Monad.Reader (mapReaderT) import qualified Data.Map as M -import Gen.Core.Raw (genLVarName, genName, genTyVarName) +import Gen.Core.Raw (genLVarName, genModuleName, genName, genTyVarName) import Hedgehog ( GenT, MonadGen, @@ -50,6 +50,7 @@ import Primer.Core ( CaseBranch' (CaseBranch), Expr' (..), GVarName, + GlobalName (qualifiedModule), ID, Kind (..), LVarName, @@ -70,18 +71,21 @@ import Primer.Core ( valConType, ) import Primer.Core.Utils (freeVarsTy) +import Primer.Module (Module) import Primer.Name (Name, NameCounter, freshName, unName, unsafeMkName) import Primer.Refine (Inst (InstAPP, InstApp, InstUnconstrainedAPP), refine) import Primer.Subst (substTy, substTys) import Primer.Typecheck ( Cxt (), + SmartHoles (NoSmartHoles), TypeDefError (TDIHoleType), + buildTypingContextFromModules, consistentKinds, extendLocalCxt, extendLocalCxtTy, extendLocalCxtTys, extendLocalCxts, - getGlobalNames, + getGlobalBaseNames, globalCxt, instantiateValCons, localCxt, @@ -89,7 +93,7 @@ import Primer.Typecheck ( localTyVars, matchArrowType, matchForallType, - mkTypeDefMap, + mkTypeDefMapQualified, primConInScope, typeDefs, ) @@ -141,7 +145,7 @@ instance MonadFresh ID (PropertyT WT) where freshNameForCxt :: GenT WT Name freshNameForCxt = do - globs <- getGlobalNames + globs <- getGlobalBaseNames locals <- asks $ M.keysSet . localCxt freshName $ globs <> locals @@ -151,6 +155,9 @@ freshLVarNameForCxt = LocalName <$> freshNameForCxt freshTyVarNameForCxt :: GenT WT TyVarName freshTyVarNameForCxt = LocalName <$> freshNameForCxt +freshTyConNameForCxt :: GenT WT TyConName +freshTyConNameForCxt = qualifyName <$> genModuleName <*> freshNameForCxt + -- We try to have a decent distribution of names, where there is a -- significant chance that the same name is reused (both in disjoint -- contexts, and with shadowing). However, we need to ensure that our @@ -420,7 +427,7 @@ genGlobalCxtExtension :: GenT WT [(GVarName, TypeG)] genGlobalCxtExtension = local forgetLocals $ Gen.list (Range.linear 1 5) $ - (,) <$> fmap qualifyName genName <*> genWTType KType + (,) <$> (qualifyName <$> genModuleName <*> genName) <*> genWTType KType where -- we are careful to not let the globals depend on whatever locals may be in -- the cxt @@ -430,14 +437,14 @@ genGlobalCxtExtension = genTypeDefGroup :: GenT WT [TypeDef] genTypeDefGroup = do let genParams = Gen.list (Range.linear 0 5) $ (,) <$> freshTyVarNameForCxt <*> genWTKind - nps <- Gen.list (Range.linear 1 5) $ (,) <$> freshNameForCxt <*> genParams + nps <- Gen.list (Range.linear 1 5) $ (,) <$> freshTyConNameForCxt <*> genParams -- create empty typedefs to temporarilly extend the context, so can do recursive types let types = map ( \(n, ps) -> TypeDefAST ASTTypeDef - { astTypeDefName = qualifyName n + { astTypeDefName = n , astTypeDefParameters = ps , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -445,22 +452,23 @@ genTypeDefGroup = do ) nps let genConArgs params = Gen.list (Range.linear 0 5) $ local (extendLocalCxtTys params . addTypeDefs types) $ genWTType KType -- params+types scope... - let genCons params = Gen.list (Range.linear 0 5) $ ValCon <$> fmap qualifyName freshNameForCxt <*> genConArgs params + let freshValConNameForCxt tyConName = qualifyName (qualifiedModule tyConName) <$> freshNameForCxt + let genCons ty params = Gen.list (Range.linear 0 5) $ ValCon <$> freshValConNameForCxt ty <*> genConArgs params let genTD (n, ps) = ( \cons -> TypeDefAST ASTTypeDef - { astTypeDefName = qualifyName n + { astTypeDefName = n , astTypeDefParameters = ps , astTypeDefConstructors = cons , astTypeDefNameHints = [] } ) - <$> genCons ps + <$> genCons n ps mapM genTD nps addTypeDefs :: [TypeDef] -> Cxt -> Cxt -addTypeDefs tds cxt = cxt{typeDefs = typeDefs cxt <> mkTypeDefMap tds} +addTypeDefs tds cxt = cxt{typeDefs = typeDefs cxt <> mkTypeDefMapQualified tds} extendGlobals :: [(GVarName, TypeG)] -> Cxt -> Cxt extendGlobals nts cxt = cxt{globalCxt = globalCxt cxt <> M.fromList nts} @@ -527,5 +535,7 @@ hoist' cxt = pure . evalTestM 0 . flip runReaderT cxt . unWT -- It is recommended to do more than default number of tests when using this module. -- That is to say, generating well-typed syntax is hard, and you probably want -- to increase the number of tests run to get decent coverage. -propertyWT :: Cxt -> PropertyT WT () -> Property -propertyWT cxt = property . hoist (hoist' cxt) +-- The modules form the 'Cxt' in the environment of the 'WT' monad +-- (thus the definitions of terms is ignored) +propertyWT :: [Module] -> PropertyT WT () -> Property +propertyWT mods = property . hoist (hoist' $ buildTypingContextFromModules mods NoSmartHoles) diff --git a/primer/test/TestUtils.hs b/primer/test/TestUtils.hs index 41f25fefb..8fa26342c 100644 --- a/primer/test/TestUtils.hs +++ b/primer/test/TestUtils.hs @@ -1,18 +1,31 @@ -- | Utilities useful across several types of tests. module TestUtils ( withPrimDefs, + constructTCon, + constructCon, + constructRefinedCon, + tcn, + vcn, + gvn, ) where import Foreword import Control.Monad.Fresh (MonadFresh) import qualified Data.Map as Map +import Primer.Action (Action (ConstructCon, ConstructRefinedCon, ConstructTCon)) import Primer.Core ( GVarName, + GlobalName (baseName, qualifiedModule), ID, + ModuleName, PrimDef (..), + TyConName, + ValConName, primFunType, + qualifyName, ) +import Primer.Name (Name (unName)) import Primer.Primitives (allPrimDefs) withPrimDefs :: MonadFresh ID m => (Map GVarName PrimDef -> m a) -> m a @@ -23,3 +36,25 @@ withPrimDefs f = do (\(name, p) -> PrimDef name <$> primFunType p) f (Map.fromList $ (\d -> (primDefName d, d)) <$> defs) + +-- impedence mismatch: ConstructTCon takes text, but tChar etc are TyConNames +constructTCon :: TyConName -> Action +constructTCon = ConstructTCon . toQualText + +constructCon :: ValConName -> Action +constructCon = ConstructCon . toQualText + +constructRefinedCon :: ValConName -> Action +constructRefinedCon = ConstructRefinedCon . toQualText + +toQualText :: GlobalName k -> (Text, Text) +toQualText n = (unName $ qualifiedModule n, unName $ baseName n) + +vcn :: ModuleName -> Name -> ValConName +vcn = qualifyName + +tcn :: ModuleName -> Name -> TyConName +tcn = qualifyName + +gvn :: ModuleName -> Name -> GVarName +gvn = qualifyName diff --git a/primer/test/Tests/API.hs b/primer/test/Tests/API.hs index e522a0e57..68fe2641f 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 "C") (con "D") + distinctTreeExpr (con' "M" "C") (con' "M" "D") unit_viewTreeExpr_injective_lam :: Assertion unit_viewTreeExpr_injective_lam = @@ -44,15 +44,16 @@ unit_viewTreeExpr_injective_var = unit_viewTreeExpr_injective_globalvar :: Assertion unit_viewTreeExpr_injective_globalvar = - distinctTreeExpr (gvar "0") (gvar "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 -- regression where they both rendered identically. --- This is a regression test for said issue. +-- This is a regression test for said issue (which occurred before +-- global variables had a qualified name). unit_viewTreeExpr_injective_locglobvar :: Assertion unit_viewTreeExpr_injective_locglobvar = - distinctTreeExpr (lvar "x") (gvar "x") + distinctTreeExpr (lvar "x") (gvar' "M" "x") unit_viewTreeExpr_injective_let :: Assertion unit_viewTreeExpr_injective_let = @@ -68,15 +69,15 @@ unit_viewTreeExpr_injective_letrec = unit_viewTreeExpr_injective_case_conName :: Assertion unit_viewTreeExpr_injective_case_conName = - distinctTreeExpr (case_ emptyHole [branch "C" [("x", Nothing)] emptyHole]) (case_ emptyHole [branch "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 "C" [("x", Nothing)] emptyHole]) (case_ emptyHole [branch "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 "T") (tcon "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 23684178d..45359e3c5 100644 --- a/primer/test/Tests/Action.hs +++ b/primer/test/Tests/Action.hs @@ -19,7 +19,7 @@ import Primer.Action ( Movement (..), applyActionsToExpr, ) -import Primer.App (defaultTypeDefs) +import Primer.Builtins import Primer.Core ( Expr, Expr' (..), @@ -46,6 +46,7 @@ import Primer.Zipper ( ) import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) import TestM (evalTestM) +import TestUtils (constructCon, constructRefinedCon, constructTCon) -- | The largest used ID in an expression maxID :: Expr -> ID @@ -191,10 +192,10 @@ unit_7 = ( ann (lam "f" (lam "g" (app (lvar "f") (hole (lvar "g"))))) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) - (tcon "Nat") + (tfun (tcon tNat) (tcon tNat)) + (tcon tNat) ) ) ) @@ -202,10 +203,10 @@ unit_7 = ( ann (lam "f" (lam "g" (app (lvar "f") (hole (app (lvar "g") emptyHole))))) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) - (tcon "Nat") + (tfun (tcon tNat) (tcon tNat)) + (tcon tNat) ) ) ) @@ -219,10 +220,10 @@ unit_8 = , EnterType , ConstructArrowL , Move Child1 - , ConstructTCon "Bool" + , constructTCon tBool , Move Parent , Move Child2 - , ConstructTCon "Bool" + , constructTCon tBool , ExitType , Move Child1 , ConstructLam (Just "x") @@ -231,9 +232,9 @@ unit_8 = , Move Parent , ConstructApp , Move Child2 - , ConstructCon "True" + , constructCon cTrue ] - (app (ann (lam "x" (lvar "x")) (tfun (tcon "Bool") (tcon "Bool"))) (con "True")) + (app (ann (lam "x" (lvar "x")) (tfun (tcon tBool) (tcon tBool))) (con cTrue)) unit_9 :: Assertion unit_9 = @@ -242,28 +243,28 @@ unit_9 = emptyHole [ ConstructLet (Just "x") , Move Child1 - , ConstructCon "True" + , constructCon cTrue , Move Parent , Move Child2 , ConstructVar $ LocalVarRef "x" ] - (let_ "x" (con "True") (lvar "x")) + (let_ "x" (con cTrue) (lvar "x")) unit_construct_arrow_left :: Assertion unit_construct_arrow_left = actionTest NoSmartHoles - (ann emptyHole (tcon "Bool")) - [EnterType, ConstructArrowL, Move Child2, ConstructTCon "Nat"] - (ann emptyHole (tfun (tcon "Bool") (tcon "Nat"))) + (ann emptyHole (tcon tBool)) + [EnterType, ConstructArrowL, Move Child2, constructTCon tNat] + (ann emptyHole (tfun (tcon tBool) (tcon tNat))) unit_construct_arrow_right :: Assertion unit_construct_arrow_right = actionTest NoSmartHoles - (ann emptyHole (tcon "Bool")) - [EnterType, ConstructArrowR, Move Child1, ConstructTCon "Nat"] - (ann emptyHole (tfun (tcon "Nat") (tcon "Bool"))) + (ann emptyHole (tcon tBool)) + [EnterType, ConstructArrowR, Move Child1, constructTCon tNat] + (ann emptyHole (tfun (tcon tNat) (tcon tBool))) unit_construct_letrec :: Assertion unit_construct_letrec = @@ -272,7 +273,7 @@ unit_construct_letrec = emptyHole [ ConstructLetrec (Just "x") , EnterType - , ConstructTCon "Bool" + , constructTCon tBool , ExitType , Move Child1 , ConstructVar $ LocalVarRef "x" @@ -280,31 +281,31 @@ unit_construct_letrec = , Move Child2 , ConstructVar $ LocalVarRef "x" ] - (letrec "x" (lvar "x") (tcon "Bool") (lvar "x")) + (letrec "x" (lvar "x") (tcon tBool) (lvar "x")) unit_rename_let :: Assertion unit_rename_let = actionTest NoSmartHoles - (let_ "x" (con "True") (lvar "x")) + (let_ "x" (con cTrue) (lvar "x")) [RenameLet "y"] - (let_ "y" (con "True") (lvar "y")) + (let_ "y" (con cTrue) (lvar "y")) unit_rename_letrec :: Assertion unit_rename_letrec = actionTest NoSmartHoles - (letrec "x" (lvar "x") (tcon "Bool") (lvar "x")) + (letrec "x" (lvar "x") (tcon tBool) (lvar "x")) [RenameLet "y"] - (letrec "y" (lvar "y") (tcon "Bool") (lvar "y")) + (letrec "y" (lvar "y") (tcon tBool) (lvar "y")) unit_rename_lam :: Assertion unit_rename_lam = actionTest NoSmartHoles - (ann (lam "x" (app (lvar "x") (con "False"))) tEmptyHole) + (ann (lam "x" (app (lvar "x") (con cFalse))) tEmptyHole) [Move Child1, RenameLam "y"] - (ann (lam "y" (app (lvar "y") (con "False"))) tEmptyHole) + (ann (lam "y" (app (lvar "y") (con cFalse))) tEmptyHole) unit_rename_lam_2 :: Assertion unit_rename_lam_2 = @@ -318,31 +319,31 @@ unit_rename_LAM :: Assertion unit_rename_LAM = actionTest NoSmartHoles - (ann (lAM "a" (aPP (con "Nil") (tvar "a"))) (tforall "b" KType $ tapp (tcon "List") (tvar "b"))) + (ann (lAM "a" (aPP (con cNil) (tvar "a"))) (tforall "b" KType $ tapp (tcon tList) (tvar "b"))) [Move Child1, RenameLAM "b"] - (ann (lAM "b" (aPP (con "Nil") (tvar "b"))) (tforall "b" KType $ tapp (tcon "List") (tvar "b"))) + (ann (lAM "b" (aPP (con cNil) (tvar "b"))) (tforall "b" KType $ tapp (tcon tList) (tvar "b"))) unit_rename_LAM_2 :: Assertion unit_rename_LAM_2 = actionTestExpectFail (const True) NoSmartHoles - (ann (lAM "b" (lAM "a" (aPP (con "Nil") (tvar "b")))) tEmptyHole) + (ann (lAM "b" (lAM "a" (aPP (con cNil) (tvar "b")))) tEmptyHole) [Move Child1, Move Child1, RenameLAM "b"] unit_convert_let_to_letrec :: Assertion unit_convert_let_to_letrec = actionTest NoSmartHoles - (let_ "x" (con "True") (lvar "x")) + (let_ "x" (con cTrue) (lvar "x")) [ConvertLetToLetrec] - (letrec "x" (con "True") tEmptyHole (lvar "x")) + (letrec "x" (con cTrue) tEmptyHole (lvar "x")) unit_delete_type :: Assertion unit_delete_type = actionTest NoSmartHoles - (ann emptyHole (tcon "Nat")) + (ann emptyHole (tcon tNat)) [EnterType, Delete] (ann emptyHole tEmptyHole) @@ -351,7 +352,7 @@ unit_setcursor_type = -- Note: we guess that the ID of the tcon will be 2 actionTest NoSmartHoles - (ann emptyHole (tcon "Nat")) + (ann emptyHole (tcon tNat)) [SetCursor 2, Delete] (ann emptyHole tEmptyHole) @@ -361,7 +362,7 @@ unit_bad_constructor = (const True) NoSmartHoles emptyHole - [ConstructCon "NotARealConstructor"] + [ConstructCon ("M", "NotARealConstructor")] unit_bad_type_constructor :: Assertion unit_bad_type_constructor = @@ -369,14 +370,14 @@ unit_bad_type_constructor = (const True) NoSmartHoles (ann emptyHole tEmptyHole) - [EnterType, ConstructTCon "NotARealTypeConstructor"] + [EnterType, ConstructTCon ("M", "NotARealTypeConstructor")] unit_bad_app :: Assertion unit_bad_app = actionTestExpectFail (const True) NoSmartHoles - (con "True") + (con cTrue) [ConstructApp] unit_insert_expr_in_type :: Assertion @@ -385,7 +386,7 @@ unit_insert_expr_in_type = (const True) NoSmartHoles (ann emptyHole tEmptyHole) - [EnterType, ConstructCon "True"] + [EnterType, constructCon cTrue] unit_bad_lambda :: Assertion unit_bad_lambda = @@ -400,16 +401,16 @@ unit_enter_emptyHole = actionTest NoSmartHoles emptyHole - [EnterHole, ConstructCon "True"] - (hole $ con "True") + [EnterHole, constructCon cTrue] + (hole $ con cTrue) unit_enter_nonEmptyHole :: Assertion unit_enter_nonEmptyHole = actionTest NoSmartHoles (hole emptyHole) - [Move Child1, ConstructCon "True"] - (hole $ con "True") + [Move Child1, constructCon cTrue] + (hole $ con cTrue) unit_bad_enter_hole :: Assertion unit_bad_enter_hole = @@ -426,7 +427,7 @@ unit_case_create = NoSmartHoles ( ann (lam "x" emptyHole) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [ Move Child1 , Move Child1 @@ -435,8 +436,8 @@ unit_case_create = , ConstructAnn , Move Child1 , ConstructCase - , Move (Branch "True") - , ConstructCon "Zero" + , Move (Branch cTrue) + , constructCon cZero ] ( ann ( lam "x" $ @@ -444,11 +445,11 @@ unit_case_create = ann ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) tEmptyHole ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) -- Test tidying up after the creation of cases @@ -462,20 +463,20 @@ unit_case_tidy = ann ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) tEmptyHole ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [Move Child1, Move Child1, FinishHole, RemoveAnn] ( ann ( lam "x" $ case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) -- Test movement into RHS of branches @@ -489,20 +490,20 @@ unit_case_move_branch_1 = ann ( case_ (lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) tEmptyHole ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [ Move Child1 , Move Child1 , Move Child1 , Move Child1 - , Move (Branch "Zero") - , ConstructCon "Zero" + , Move (Branch cZero) + , constructCon cZero , Move Parent - , Move (Branch "Succ") + , Move (Branch cSucc) , ConstructVar $ LocalVarRef "n" ] ( ann @@ -511,11 +512,11 @@ unit_case_move_branch_1 = ann ( case_ (lvar "x") - [branch "Zero" [] (con "Zero"), branch "Succ" [("n", Nothing)] (lvar "n")] + [branch cZero [] (con cZero), branch cSucc [("n", Nothing)] (lvar "n")] ) tEmptyHole ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) -- Test movement into RHS of branches (case not wrapped in a hole) @@ -527,25 +528,25 @@ unit_case_move_branch_2 = ( lam "x" $ case_ (lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [ Move Child1 , Move Child1 - , Move (Branch "Zero") - , ConstructCon "Zero" + , Move (Branch cZero) + , constructCon cZero , Move Parent - , Move (Branch "Succ") + , Move (Branch cSucc) , ConstructVar $ LocalVarRef "n" ] ( ann ( lam "x" $ case_ (lvar "x") - [branch "Zero" [] (con "Zero"), branch "Succ" [("n", Nothing)] (lvar "n")] + [branch cZero [] (con cZero), branch cSucc [("n", Nothing)] (lvar "n")] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) -- Test movement into scrutinee @@ -559,11 +560,11 @@ unit_case_move_scrutinee_1 = ann ( case_ (lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) tEmptyHole ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [ Move Child1 , Move Child1 @@ -578,11 +579,11 @@ unit_case_move_scrutinee_1 = ann ( case_ (setMeta "meta" $ lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) tEmptyHole ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) -- Test movement into scrutinee (case not wrapped in a hole) @@ -594,18 +595,18 @@ unit_case_move_scrutinee_2 = ( lam "x" $ case_ (lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [Move Child1, Move Child1, Move Child1, SetMetadata "meta"] ( ann ( lam "x" $ case_ (setMeta "meta" $ lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) unit_bad_case_1 :: Assertion @@ -615,7 +616,7 @@ unit_bad_case_1 = NoSmartHoles ( ann (lam "x" $ hole $ lvar "x") - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [ConstructCase] @@ -638,11 +639,11 @@ unit_bad_case_3 = ann ( case_ (lvar "x") - [branch "True" [] emptyHole, branch "False" [] emptyHole] + [branch cTrue [] emptyHole, branch cFalse [] emptyHole] ) tEmptyHole ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [Move Child1, Move Child1, Move Child1, Move Child1, Move Child2] @@ -656,23 +657,23 @@ unit_case_on_hole = NoSmartHoles ( ann (lam "x" emptyHole) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [ Move Child1 , Move Child1 , ConstructAnn , EnterType - , ConstructTCon "Nat" + , constructTCon tNat , ExitType , ConstructCase ] ( ann ( lam "x" $ case_ - (ann emptyHole $ tcon "Nat") - [branch "Zero" [] emptyHole, branch "Succ" [("a13", Nothing)] emptyHole] -- NB: fragile names here + (ann emptyHole $ tcon tNat) + [branch cZero [] emptyHole, branch cSucc [("a13", Nothing)] emptyHole] -- NB: fragile names here ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) -- Changing the scrutinee is ok, as long as the type does not change @@ -683,10 +684,10 @@ unit_case_fill_hole_scrut = ( ann ( lam "x" $ case_ - (ann emptyHole $ tcon "Nat") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + (ann emptyHole $ tcon tNat) + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [ Move Child1 , Move Child1 @@ -700,9 +701,9 @@ unit_case_fill_hole_scrut = ( lam "x" $ case_ (lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) -- Test creation of cases, with smart actions @@ -712,24 +713,24 @@ unit_case_create_smart_on_term = SmartHoles ( ann (lam "x" emptyHole) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [ Move Child1 , Move Child1 , ConstructVar $ LocalVarRef "x" , ConstructCase - , Move (Branch "True") - , ConstructCon "Zero" + , Move (Branch cTrue) + , constructCon cZero ] ( ann ( lam "x" ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) unit_case_create_smart_on_hole :: Assertion @@ -738,7 +739,7 @@ unit_case_create_smart_on_hole = SmartHoles ( ann (lam "x" emptyHole) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [ Move Child1 , Move Child1 @@ -746,18 +747,18 @@ unit_case_create_smart_on_hole = , Move Child1 , ConstructVar $ LocalVarRef "x" , Move Parent - , Move (Branch "True") - , ConstructCon "Zero" + , Move (Branch cTrue) + , constructCon cZero ] ( ann ( lam "x" ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) unit_case_change_smart_scrutinee_type :: Assertion @@ -766,39 +767,39 @@ unit_case_change_smart_scrutinee_type = SmartHoles ( ann ( case_ - (con "True") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + (con cTrue) + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) - (tcon "Nat") + (tcon tNat) ) [ Move Child1 , Move Child1 , Delete - , ConstructCon "Zero" + , constructCon cZero ] ( ann ( case_ - (con "Zero") - [branch "Zero" [] emptyHole, branch "Succ" [("a11", Nothing)] emptyHole] -- fragile names here + (con cZero) + [branch cZero [] emptyHole, branch cSucc [("a11", Nothing)] emptyHole] -- fragile names here ) - (tcon "Nat") + (tcon tNat) ) unit_constructAPP :: Assertion unit_constructAPP = actionTest NoSmartHoles - (con "Nil") - [ConstructAPP, EnterType, ConstructTCon "Bool"] - (con "Nil" `aPP` tcon "Bool") + (con cNil) + [ConstructAPP, EnterType, constructTCon tBool] + (con cNil `aPP` tcon tBool) unit_constructLAM :: Assertion unit_constructLAM = actionTest NoSmartHoles (emptyHole `ann` tEmptyHole) - [Move Child1, ConstructLAM (Just "a"), ConstructCon "True"] - (lAM "a" (con "True") `ann` tEmptyHole) + [Move Child1, ConstructLAM (Just "a"), constructCon cTrue] + (lAM "a" (con cTrue) `ann` tEmptyHole) unit_construct_TForall :: Assertion unit_construct_TForall = @@ -812,16 +813,16 @@ unit_rename_TForall :: Assertion unit_rename_TForall = actionTest NoSmartHoles - (emptyHole `ann` tforall "a" KType (tapp (tcon "List") (tvar "a"))) + (emptyHole `ann` tforall "a" KType (tapp (tcon tList) (tvar "a"))) [EnterType, RenameForall "b"] - (emptyHole `ann` tforall "b" KType (tapp (tcon "List") (tvar "b"))) + (emptyHole `ann` tforall "b" KType (tapp (tcon tList) (tvar "b"))) unit_rename_TForall_2 :: Assertion unit_rename_TForall_2 = actionTestExpectFail (const True) NoSmartHoles - (emptyHole `ann` tforall "b" KType (tforall "a" KType $ tapp (tcon "List") (tvar "b"))) + (emptyHole `ann` tforall "b" KType (tforall "a" KType $ tapp (tcon tList) (tvar "b"))) [EnterType, Move Child1, RenameLAM "b"] unit_construct_TForall_TVar :: Assertion @@ -888,40 +889,40 @@ unit_constructTApp = actionTest NoSmartHoles (emptyHole `ann` tEmptyHole) - [EnterType, ConstructTApp, Move Child1, ConstructTCon "List", Move Parent, Move Child2, ConstructTCon "Bool"] - (emptyHole `ann` (tcon "List" `tapp` tcon "Bool")) + [EnterType, ConstructTApp, Move Child1, constructTCon tList, Move Parent, Move Child2, constructTCon tBool] + (emptyHole `ann` (tcon tList `tapp` tcon tBool)) unit_construct_lam :: Assertion unit_construct_lam = actionTest SmartHoles - (con "True") + (con cTrue) [ConstructLam (Just "x")] - (ann (lam "x" (con "True")) tEmptyHole) + (ann (lam "x" (con cTrue)) tEmptyHole) unit_construct_LAM :: Assertion unit_construct_LAM = actionTest SmartHoles - (con "True") + (con cTrue) [ConstructLAM (Just "a")] - (ann (lAM "a" (con "True")) tEmptyHole) + (ann (lAM "a" (con cTrue)) tEmptyHole) unit_smart_type_1 :: Assertion unit_smart_type_1 = actionTest SmartHoles - (emptyHole `ann` tcon "Nat") + (emptyHole `ann` tcon tNat) [EnterType, ConstructTApp, Move Child1] - (emptyHole `ann` (thole (tcon "Nat") `tapp` tEmptyHole)) + (emptyHole `ann` (thole (tcon tNat) `tapp` tEmptyHole)) unit_smart_type_2 :: Assertion unit_smart_type_2 = actionTest SmartHoles - (emptyHole `ann` thole (tcon "List")) + (emptyHole `ann` thole (tcon tList)) [EnterType, ConstructTApp] - (emptyHole `ann` (tcon "List" `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tList `tapp` tEmptyHole)) unit_refine_1 :: Assertion unit_refine_1 = @@ -929,39 +930,39 @@ unit_refine_1 = (\case RefineError _ -> True; _ -> False) NoSmartHoles emptyHole - [ConstructRefinedCon "Nil"] + [constructRefinedCon cNil] unit_refine_2 :: Assertion unit_refine_2 = actionTest NoSmartHoles - (emptyHole `ann` (tcon "List" `tapp` tcon "Nat")) - [Move Child1, ConstructRefinedCon "Nil"] - ((con "Nil" `aPP` tcon "Nat") `ann` (tcon "List" `tapp` tcon "Nat")) + (emptyHole `ann` (tcon tList `tapp` tcon tNat)) + [Move Child1, constructRefinedCon cNil] + ((con cNil `aPP` tcon tNat) `ann` (tcon tList `tapp` tcon tNat)) unit_refine_3 :: Assertion unit_refine_3 = actionTest NoSmartHoles - (emptyHole `ann` (tcon "List" `tapp` tEmptyHole)) - [Move Child1, ConstructRefinedCon "Nil"] - ((con "Nil" `aPP` tEmptyHole) `ann` (tcon "List" `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tList `tapp` tEmptyHole)) + [Move Child1, constructRefinedCon cNil] + ((con cNil `aPP` tEmptyHole) `ann` (tcon tList `tapp` tEmptyHole)) unit_refine_4 :: Assertion unit_refine_4 = actionTest NoSmartHoles - (let_ "nil" (con "Nil") $ emptyHole `ann` (tcon "List" `tapp` tcon "Nat")) + (let_ "nil" (con cNil) $ emptyHole `ann` (tcon tList `tapp` tcon tNat)) [Move Child2, Move Child1, InsertRefinedVar $ LocalVarRef "nil"] - (let_ "nil" (con "Nil") $ (lvar "nil" `aPP` tcon "Nat") `ann` (tcon "List" `tapp` tcon "Nat")) + (let_ "nil" (con cNil) $ (lvar "nil" `aPP` tcon tNat) `ann` (tcon tList `tapp` tcon tNat)) unit_refine_5 :: Assertion unit_refine_5 = actionTest NoSmartHoles - (let_ "nil" (con "Nil") $ emptyHole `ann` (tcon "List" `tapp` tEmptyHole)) + (let_ "nil" (con cNil) $ emptyHole `ann` (tcon tList `tapp` tEmptyHole)) [Move Child2, Move Child1, InsertRefinedVar $ LocalVarRef "nil"] - (let_ "nil" (con "Nil") $ (lvar "nil" `aPP` tEmptyHole) `ann` (tcon "List" `tapp` tEmptyHole)) + (let_ "nil" (con cNil) $ (lvar "nil" `aPP` tEmptyHole) `ann` (tcon tList `tapp` tEmptyHole)) -- * Helpers @@ -997,4 +998,4 @@ actionTestExpectFail f sh expr actions = runTestActions :: SmartHoles -> ID -> Expr -> [Action] -> Either ActionError Expr runTestActions sh i expr actions = either unfocusExpr (unfocusExpr . unfocusType) - <$> evalTestM (i + 1) (applyActionsToExpr sh defaultTypeDefs expr actions) + <$> evalTestM (i + 1) (applyActionsToExpr sh [builtinModule] expr actions) diff --git a/primer/test/Tests/Action/Available.hs b/primer/test/Tests/Action/Available.hs index 57bed0476..b10cbde6d 100644 --- a/primer/test/Tests/Action/Available.hs +++ b/primer/test/Tests/Action/Available.hs @@ -11,9 +11,10 @@ import qualified Data.Text.Lazy as TL import Optics (adjoin, toListOf, (%)) import Primer.Action (ActionName (..), OfferedAction (name)) import Primer.Action.Available (actionsForDef, actionsForDefBody, actionsForDefSig) +import Primer.Builtins import Primer.Core ( ASTDef (..), - GlobalName (baseName), + GlobalName (baseName, qualifiedModule), HasID (_id), ID, Kind (KType), @@ -30,7 +31,7 @@ import Primer.Core.DSL ( con, create, emptyHole, - gvar, + gvar', hole, lAM, lam, @@ -51,6 +52,7 @@ import System.FilePath (()) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (goldenVsString) import Test.Tasty.HUnit () +import TestUtils (gvn) import Text.Pretty.Simple (pShowNoColor) -- | This definition contains every construct in the Primer language. @@ -58,7 +60,7 @@ test_1 :: TestTree test_1 = mkTests ASTDef - { astDefName = "1" + { astDefName = gvn "M" "1" , astDefExpr , astDefType } @@ -66,14 +68,14 @@ test_1 = ((astDefExpr, astDefType), _) = create $ (,) <$> e <*> t t = tfun - (tcon "Nat") + (tcon tNat) ( tforall "a" KType ( tapp ( thole ( tapp - (tcon "List") + (tcon tList) tEmptyHole ) ) @@ -83,19 +85,19 @@ test_1 = e = let_ "x" - (con "True") + (con cTrue) ( letrec "y" ( app ( hole - (con "Just") + (con cJust) ) ( hole - (gvar "0") + (gvar' "M" "0") ) ) ( thole - (tcon "Maybe") + (tcon tMaybe) ) ( ann ( lam @@ -106,9 +108,9 @@ test_1 = ( aPP ( letType "b" - (tcon "Bool") + (tcon tBool) ( aPP - (con "Left") + (con cLeft) (tvar "b") ) ) @@ -117,11 +119,11 @@ test_1 = ( case_ (lvar "i") [ branch - "Zero" + cZero [] - (con "False") + (con cFalse) , branch - "Succ" + cSucc [ ( "n" , Nothing @@ -140,14 +142,14 @@ test_1 = ) ) ( tfun - (tcon "Nat") + (tcon tNat) ( tforall "α" KType ( tapp ( tapp - (tcon "Either") - (tcon "Bool") + (tcon tEither) + (tcon tBool) ) (tvar "α") ) @@ -166,7 +168,8 @@ data Output = Output -- | Golden tests for the available actions at each node of the definition, for each level. mkTests :: ASTDef -> TestTree mkTests def = - let testName = T.unpack $ unName $ baseName $ astDefName def + let defName = astDefName def + testName = T.unpack $ unName (qualifiedModule defName) <> "." <> unName (baseName defName) in testGroup testName $ enumerate <&> \level -> diff --git a/primer/test/Tests/Action/Capture.hs b/primer/test/Tests/Action/Capture.hs index a16eac380..544419872 100644 --- a/primer/test/Tests/Action/Capture.hs +++ b/primer/test/Tests/Action/Capture.hs @@ -8,6 +8,7 @@ import Primer.Action ( ActionError (NameCapture, NeedEmptyHole), Movement (..), ) +import Primer.Builtins import Primer.Core ( Kind (KType), ) @@ -161,7 +162,7 @@ unit_ty_tm_same_namespace = actionTestExpectFail isNameCapture NoSmartHoles - (ann (lAM "a" $ con "Nil" `aPP` tvar "a") tEmptyHole) + (ann (lAM "a" $ con cNil `aPP` tvar "a") tEmptyHole) [Move Child1, Move Child1, ConstructLam (Just "a")] -- * Helpers diff --git a/primer/test/Tests/Action/Prog.hs b/primer/test/Tests/Action/Prog.hs index 87975204a..2a75d438a 100644 --- a/primer/test/Tests/Action/Prog.hs +++ b/primer/test/Tests/Action/Prog.hs @@ -6,13 +6,14 @@ module Tests.Action.Prog where import Foreword import Control.Monad.Fresh +import Data.Generics.Uniplate.Data (transformBi) +import Data.List.Extra (anySame) import qualified Data.Map.Strict as Map import Optics import Primer.Action ( Action ( ConstructAnn, ConstructArrowL, - ConstructLam, ConstructLet, ConstructTCon, ConstructVar, @@ -20,7 +21,7 @@ import Primer.Action ( EnterType, Move ), - ActionError (NameCapture), + ActionError (ImportNameClash), Movement (Branch, Child1, Child2), ) import Primer.App ( @@ -33,7 +34,6 @@ import Primer.App ( ProgError (..), Question (VariablesInScope), Selection (..), - defaultTypeDefs, handleEditRequest, handleQuestion, importModules, @@ -42,26 +42,35 @@ import Primer.App ( newEmptyApp, newEmptyProg, newProg, + progAllModules, tcWholeProg, ) +import Primer.Builtins (builtinModule, cCons, cJust, cMakePair, cNil, tBool, tList, tMaybe, tPair) import Primer.Core ( ASTDef (..), ASTTypeDef (..), Def (..), + Expr, Expr' (..), GVarName, + GlobalName (baseName, qualifiedModule), ID (ID), Kind (KType), Meta (..), + ModuleName, TmVarRef (..), TyConName, + Type, Type' (..), TypeDef (..), ValCon (..), + ValConName, defAST, defName, getID, + qualifyName, typeDefAST, + typeDefName, _exprMeta, _exprTypeMeta, _id, @@ -90,12 +99,14 @@ import Primer.Core.DSL ( tvar, ) import Primer.Core.Utils (forgetIDs) -import Primer.Module (Module (moduleDefs, moduleTypes)) +import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), mkTypeDefMap, moduleDefsQualified, moduleTypesQualified) import Primer.Name -import Primer.Typecheck (mkTypeDefMap) +import Primer.Primitives (primitiveGVar, primitiveModule, tChar) +import Primer.Typecheck (TypeError (UnknownTypeConstructor)) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import TestM (TestM, evalTestM) -import TestUtils (withPrimDefs) +import TestUtils (constructTCon) +import qualified TestUtils import Tests.Typecheck (checkProgWellFormed) unit_empty_actions_only_change_the_log :: Assertion @@ -106,17 +117,17 @@ unit_empty_actions_only_change_the_log = progActionTest defaultEmptyProg [] $ -- We can move to the default def in a program -- (this may only exist at the start of a session) unit_move_to_def_main :: Assertion -unit_move_to_def_main = progActionTest defaultEmptyProg [MoveToDef "main"] $ +unit_move_to_def_main = progActionTest defaultEmptyProg [moveToDef "main"] $ expectSuccess $ \prog prog' -> - prog' @?= prog{progLog = Log [[MoveToDef "main"]]} + prog' @?= prog{progLog = Log [[moveToDef "main"]]} -- Expression actions are tested in ActionTest - here we just check that we can modify the correct -- def. unit_move_to_def_and_construct_let :: Assertion unit_move_to_def_and_construct_let = - progActionTest defaultEmptyProg [MoveToDef "other", BodyAction [ConstructLet (Just "x")]] $ + progActionTest defaultEmptyProg [moveToDef "other", BodyAction [ConstructLet (Just "x")]] $ expectSuccess $ \prog prog' -> - case astDefExpr <$> lookupASTDef "other" (moduleDefs $ progModule prog') of + case astDefExpr <$> lookupASTDef' "other" (moduleDefs $ progModule prog') of Just Let{} -> -- Check that main is unchanged Map.lookup "main" (moduleDefs $ progModule prog') @?= Map.lookup "main" (moduleDefs $ progModule prog) @@ -124,79 +135,79 @@ unit_move_to_def_and_construct_let = unit_rename_def :: Assertion unit_rename_def = - progActionTest defaultEmptyProg [RenameDef "other" "foo"] $ + progActionTest defaultEmptyProg [renameDef "other" "foo"] $ expectSuccess $ \_ prog' -> do fmap defName (Map.lookup "other" (moduleDefs $ progModule prog')) @?= Nothing - fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just "foo" - fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just "main" + fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just (gvn "foo") + fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just (gvn "main") unit_rename_def_to_same_name_as_existing_def :: Assertion unit_rename_def_to_same_name_as_existing_def = - progActionTest defaultEmptyProg [RenameDef "main" "main"] $ - expectError (@?= DefAlreadyExists "main") + progActionTest defaultEmptyProg [renameDef "main" "main"] $ + expectError (@?= DefAlreadyExists (gvn "main")) unit_rename_def_to_same_name_as_existing_def_prim :: Assertion unit_rename_def_to_same_name_as_existing_def_prim = - progActionTest defaultFullProg [RenameDef "other" "toUpper"] $ - expectError (@?= DefAlreadyExists "toUpper") + progActionTest defaultFullProg [renameDef "other" "toUpper"] $ + expectError (@?= DefAlreadyExists (gvn "toUpper")) unit_rename_def_referenced :: Assertion unit_rename_def_referenced = progActionTest defaultEmptyProg - [ MoveToDef "main" - , BodyAction [ConstructVar $ GlobalVarRef "other"] - , RenameDef "other" "foo" + [ moveToDef "main" + , BodyAction [ConstructVar $ globalVarRef "other"] + , renameDef "other" "foo" ] $ expectSuccess $ \_ prog' -> do fmap defName (Map.lookup "other" (moduleDefs $ progModule prog')) @?= Nothing - fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just "foo" - fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just "main" - fmap (set _exprMeta () . astDefExpr) (defAST =<< Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just (Var () $ GlobalVarRef "foo") + fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just (gvn "foo") + fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just (gvn "main") + fmap (set _exprMeta () . astDefExpr) (defAST =<< Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just (Var () $ globalVarRef "foo") unit_rename_def_recursive :: Assertion unit_rename_def_recursive = progActionTest defaultEmptyProg - [ MoveToDef "main" - , BodyAction [ConstructVar $ GlobalVarRef "main"] - , RenameDef "main" "foo" + [ moveToDef "main" + , BodyAction [ConstructVar $ globalVarRef "main"] + , renameDef "main" "foo" ] $ expectSuccess $ \_ prog' -> do fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Nothing - fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just "foo" - fmap (set _exprMeta () . astDefExpr) (defAST =<< Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just (Var () $ GlobalVarRef "foo") + fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just (gvn "foo") + fmap (set _exprMeta () . astDefExpr) (defAST =<< Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just (Var () $ globalVarRef "foo") unit_delete_def :: Assertion unit_delete_def = - progActionTest defaultEmptyProg [DeleteDef "other"] $ + progActionTest defaultEmptyProg [deleteDef "other"] $ expectSuccess $ \_ prog' -> do fmap defName (Map.lookup "other" (moduleDefs $ progModule prog')) @?= Nothing - fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just "main" + fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just (gvn "main") unit_delete_def_unknown_id :: Assertion unit_delete_def_unknown_id = - progActionTest defaultEmptyProg [DeleteDef "unknown"] $ - expectError (@?= DefNotFound "unknown") + progActionTest defaultEmptyProg [deleteDef "unknown"] $ + expectError (@?= DefNotFound (gvn "unknown")) unit_delete_def_used_id :: Assertion unit_delete_def_used_id = - progActionTest defaultEmptyProg [MoveToDef "main", BodyAction [ConstructVar $ GlobalVarRef "other"], DeleteDef "other"] $ - expectError (@?= DefInUse "other") + progActionTest defaultEmptyProg [moveToDef "main", BodyAction [ConstructVar $ globalVarRef "other"], deleteDef "other"] $ + expectError (@?= DefInUse (gvn "other")) -- 'foo = foo' shouldn't count as "in use" and block deleting itself unit_delete_def_recursive :: Assertion unit_delete_def_recursive = - progActionTest defaultEmptyProg [MoveToDef "main", BodyAction [ConstructVar $ GlobalVarRef "main"], DeleteDef "main"] $ + progActionTest defaultEmptyProg [moveToDef "main", BodyAction [ConstructVar $ globalVarRef "main"], deleteDef "main"] $ expectSuccess $ \prog prog' -> Map.delete "main" (moduleDefs $ progModule prog) @?= moduleDefs (progModule prog') unit_move_to_unknown_def :: Assertion unit_move_to_unknown_def = - progActionTest defaultEmptyProg [MoveToDef "unknown"] $ expectError (@?= DefNotFound "unknown") + progActionTest defaultEmptyProg [moveToDef "unknown"] $ expectError (@?= DefNotFound (gvn "unknown")) unit_rename_unknown_def :: Assertion unit_rename_unknown_def = - progActionTest defaultEmptyProg [RenameDef "unknown" "foo"] $ expectError (@?= DefNotFound "unknown") + progActionTest defaultEmptyProg [renameDef "unknown" "foo"] $ expectError (@?= DefNotFound (gvn "unknown")) unit_construct_let_without_moving_to_def_first :: Assertion unit_construct_let_without_moving_to_def_first = @@ -205,34 +216,34 @@ unit_construct_let_without_moving_to_def_first = unit_create_def :: Assertion unit_create_def = progActionTest defaultEmptyProg [CreateDef $ Just "newDef"] $ expectSuccess $ \_ prog' -> do - case lookupASTDef "newDef" (moduleDefs $ progModule prog') of + case lookupASTDef' "newDef" (moduleDefs $ progModule prog') of Nothing -> assertFailure $ show $ moduleDefs $ progModule prog' Just def -> do - astDefName def @?= "newDef" + astDefName def @?= gvn "newDef" astDefExpr def @?= EmptyHole (Meta 4 Nothing Nothing) unit_create_def_clash_prim :: Assertion unit_create_def_clash_prim = progActionTest defaultFullProg [CreateDef $ Just "toUpper"] $ - expectError (@?= DefAlreadyExists "toUpper") + expectError (@?= DefAlreadyExists (gvn "toUpper")) unit_create_typedef :: Assertion unit_create_typedef = let lst = ASTTypeDef - { astTypeDefName = "List" + { astTypeDefName = tcn "List" , astTypeDefParameters = [("a", KType)] , astTypeDefConstructors = - [ ValCon "Nil" [] - , ValCon "Cons" [TVar () "a", TApp () (TCon () "List") (TVar () "a")] + [ ValCon (vcn "Nil") [] + , ValCon (vcn "Cons") [TVar () "a", TApp () (TCon () (tcn "List")) (TVar () "a")] ] , astTypeDefNameHints = ["xs", "ys", "zs"] } tree = ASTTypeDef - { astTypeDefName = "Tree" + { astTypeDefName = tcn "Tree" , astTypeDefParameters = [("a", KType)] - , astTypeDefConstructors = [ValCon "Node" [TVar () "a", TApp () (TCon () "List") (TApp () (TCon () "Tree") (TVar () "a"))]] + , astTypeDefConstructors = [ValCon (vcn "Node") [TVar () "a", TApp () (TCon () (tcn "List")) (TApp () (TCon () (tcn "Tree")) (TVar () "a"))]] , astTypeDefNameHints = ["xs", "ys", "zs"] } in progActionTest defaultEmptyProg [AddTypeDef lst, AddTypeDef tree] $ @@ -249,27 +260,27 @@ unit_create_typedef_bad_1 :: Assertion unit_create_typedef_bad_1 = let td = ASTTypeDef - { astTypeDefName = "Tree" + { astTypeDefName = tcn "Tree" , astTypeDefParameters = [("a", KType)] - , astTypeDefConstructors = [ValCon "Node" [TVar () "a", TApp () (TCon () "List") (TApp () (TCon () "Tree") (TVar () "a"))]] + , astTypeDefConstructors = [ValCon (vcn "Node") [TVar () "a", TApp () (TCon () $ tcn "List") (TApp () (TCon () $ tcn "Tree") (TVar () "a"))]] , astTypeDefNameHints = ["xs", "ys", "zs"] } in progActionTest defaultEmptyProg [AddTypeDef td] $ - expectError (@?= TypeDefError "UnknownTypeConstructor \"List\"") + expectError (@?= (TypeDefError $ show $ UnknownTypeConstructor (tcn "List"))) -- duplicate type(names) added unit_create_typedef_bad_2 :: Assertion unit_create_typedef_bad_2 = let td1 = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [] , astTypeDefConstructors = [] , astTypeDefNameHints = [] } td2 = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [] , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -282,11 +293,11 @@ unit_create_typedef_bad_3 :: Assertion unit_create_typedef_bad_3 = let td = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [] , astTypeDefConstructors = - [ ValCon "C" [] - , ValCon "C" [] + [ ValCon (vcn "C") [] + , ValCon (vcn "C") [] ] , astTypeDefNameHints = [] } @@ -298,16 +309,16 @@ unit_create_typedef_bad_4 :: Assertion unit_create_typedef_bad_4 = let td1 = ASTTypeDef - { astTypeDefName = "T1" + { astTypeDefName = tcn "T1" , astTypeDefParameters = [] - , astTypeDefConstructors = [ValCon "C" []] + , astTypeDefConstructors = [ValCon (vcn "C") []] , astTypeDefNameHints = [] } td2 = ASTTypeDef - { astTypeDefName = "T2" + { astTypeDefName = tcn "T2" , astTypeDefParameters = [] - , astTypeDefConstructors = [ValCon "C" []] + , astTypeDefConstructors = [ValCon (vcn "C") []] , astTypeDefNameHints = [] } in progActionTest defaultEmptyProg [AddTypeDef td1, AddTypeDef td2] $ @@ -318,7 +329,7 @@ unit_create_typedef_bad_5 :: Assertion unit_create_typedef_bad_5 = let td = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [("a", KType), ("a", KType)] , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -331,7 +342,7 @@ unit_create_typedef_bad_6 :: Assertion unit_create_typedef_bad_6 = let td = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [("T", KType)] , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -344,9 +355,9 @@ unit_create_typedef_bad_7 :: Assertion unit_create_typedef_bad_7 = let td = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [("a", KType)] - , astTypeDefConstructors = [ValCon "a" []] + , astTypeDefConstructors = [ValCon (vcn "a") []] , astTypeDefNameHints = [] } in progActionTest defaultEmptyProg [AddTypeDef td] $ @@ -357,7 +368,7 @@ unit_create_typedef_bad_prim :: Assertion unit_create_typedef_bad_prim = let td = ASTTypeDef - { astTypeDefName = "Char" + { astTypeDefName = tcn "Char" , astTypeDefParameters = [] , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -370,9 +381,9 @@ unit_create_typedef_8 :: Assertion unit_create_typedef_8 = let td = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [] - , astTypeDefConstructors = [ValCon "T" []] + , astTypeDefConstructors = [ValCon (vcn "T") []] , astTypeDefNameHints = [] } in progActionTest defaultEmptyProg [AddTypeDef td] $ @@ -383,14 +394,14 @@ unit_create_typedef_9 :: Assertion unit_create_typedef_9 = let td1 = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [] - , astTypeDefConstructors = [ValCon "C" []] + , astTypeDefConstructors = [ValCon (vcn "C") []] , astTypeDefNameHints = [] } td2 = ASTTypeDef - { astTypeDefName = "C" + { astTypeDefName = tcn "C" , astTypeDefParameters = [] , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -400,9 +411,9 @@ unit_create_typedef_9 = unit_construct_arrow_in_sig :: Assertion unit_construct_arrow_in_sig = - progActionTest defaultEmptyProg [MoveToDef "other", SigAction [ConstructArrowL, Move Child1]] $ + progActionTest defaultEmptyProg [moveToDef "other", SigAction [ConstructArrowL, Move Child1]] $ expectSuccess $ \_ prog' -> - case lookupASTDef "other" (moduleDefs $ progModule prog') of + case lookupASTDef' "other" (moduleDefs $ progModule prog') of Just def -> -- Check that the signature is an arrow type case astDefType def of @@ -420,34 +431,36 @@ unit_sigaction_creates_holes :: Assertion unit_sigaction_creates_holes = let acts = [ -- main :: Char - MoveToDef "main" - , SigAction [ConstructTCon "Char"] + moveToDef "main" + , SigAction [ConstructTCon (mainModuleNameText, "Char")] , -- other :: Char; other = main - MoveToDef "other" - , SigAction [ConstructTCon "Char"] - , BodyAction [ConstructVar $ GlobalVarRef "main"] + moveToDef "other" + , SigAction [ConstructTCon (mainModuleNameText, "Char")] + , BodyAction [ConstructVar $ GlobalVarRef $ gvn "main"] , -- main :: Int -- We expect this to change 'other' to contain a hole - MoveToDef "main" - , SigAction [Delete, ConstructTCon "Int"] + moveToDef "main" + , SigAction [Delete, ConstructTCon (mainModuleNameText, "Int")] ] in progActionTest defaultFullProg acts $ expectSuccess $ \_ prog' -> - case lookupASTDef "other" (moduleDefs $ progModule prog') of + case lookupASTDef' "other" (moduleDefs $ progModule prog') of Just def -> -- Check that the definition is a non-empty hole case astDefExpr def of - Hole _ (Var _ (GlobalVarRef "main")) -> pure () + Hole _ (Var _ (GlobalVarRef n)) | n == gvn "main" -> pure () _ -> assertFailure "expected {? main ?}" _ -> assertFailure "definition not found" unit_copy_paste_duplicate :: Assertion unit_copy_paste_duplicate = do - let ((p, fromType, fromExpr, _toType, _toExpr), maxID) = create $ do - mainType <- tforall "a" KType (tvar "a" `tfun` (tcon "Maybe" `tapp` tEmptyHole)) - mainExpr <- lAM "b" $ lam "x" $ con "Just" `aPP` tvar "b" `app` lvar "x" - let mainDef = ASTDef "main" mainExpr mainType - blankDef <- ASTDef "blank" <$> emptyHole <*> tEmptyHole + let fromDef = gvn "main" + toDef = gvn "blank" + ((p, fromType, fromExpr, _toType, _toExpr), maxID) = create $ do + mainType <- tforall "a" KType (tvar "a" `tfun` (tcon tMaybe `tapp` tEmptyHole)) + mainExpr <- lAM "b" $ lam "x" $ con cJust `aPP` tvar "b" `app` lvar "x" + let mainDef = ASTDef fromDef mainExpr mainType + blankDef <- ASTDef toDef <$> emptyHole <*> tEmptyHole pure ( newProg{progSelection = Nothing} & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST mainDef), ("blank", DefAST blankDef)] @@ -456,8 +469,6 @@ unit_copy_paste_duplicate = do , getID (astDefType blankDef) , getID (astDefExpr blankDef) ) - fromDef = "main" - toDef = "blank" let a = newApp{appProg = p} actions = [MoveToDef toDef, CopyPasteSig (fromDef, fromType) [], CopyPasteBody (fromDef, fromExpr) []] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg p <*> handleEditRequest actions @@ -466,12 +477,12 @@ unit_copy_paste_duplicate = do Right (tcp, r) -> -- use the typechecked input p, as the result will have had a typecheck run, so -- we need the cached kinds to match up - let src = lookupASTDef fromDef (moduleDefs $ progModule tcp) + let src = lookupASTDef fromDef (moduleDefsQualified $ progModule tcp) clearIDs = set (_Just % _defIDs) 0 in do - src @?= lookupASTDef fromDef (moduleDefs $ progModule r) - assertBool "equal to toDef" $ src /= lookupASTDef "blank" (moduleDefs $ progModule r) - clearIDs (set (_Just % #astDefName) "blank" src) @?= clearIDs (lookupASTDef "blank" (moduleDefs $ progModule r)) + src @?= lookupASTDef fromDef (moduleDefsQualified $ progModule r) + assertBool "equal to toDef" $ src /= lookupASTDef' "blank" (moduleDefs $ progModule r) + clearIDs (set (_Just % #astDefName) toDef src) @?= clearIDs (lookupASTDef' "blank" (moduleDefs $ progModule r)) -- ∀a . (∀b,c . a -> b -> ∀d. c -> d) -> ∀c. ? -- copy ^------------------^ @@ -487,18 +498,19 @@ unit_copy_paste_duplicate = do -- - The d is bound within the copied subtree, so it is in-scope unit_copy_paste_type_scoping :: Assertion unit_copy_paste_type_scoping = do - let ((pInitial, srcID, pExpected), maxID) = create $ do + let mainName = gvn "main" + ((pInitial, srcID, pExpected), maxID) = create $ do toCopy <- tvar "a" `tfun` tvar "b" `tfun` tforall "d" KType (tvar "c" `tfun` tvar "d") let skel r = tforall "a" KType $ tfun (tforall "b" KType $ tforall "c" KType $ pure toCopy) $ tforall "c" KType r - defInitial <- ASTDef "main" <$> emptyHole <*> skel tEmptyHole - expected <- ASTDef "main" <$> emptyHole <*> skel (tvar "a" `tfun` tEmptyHole `tfun` tforall "d" KType (tEmptyHole `tfun` tvar "d")) + defInitial <- ASTDef mainName <$> emptyHole <*> skel tEmptyHole + expected <- ASTDef mainName <$> emptyHole <*> skel (tvar "a" `tfun` tEmptyHole `tfun` tforall "d" KType (tEmptyHole `tfun` tvar "d")) pure ( newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] , getID toCopy , newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST expected)] ) let a = newEmptyApp{appProg = pInitial} - actions = [MoveToDef "main", CopyPasteSig ("main", srcID) [Move Child1, Move Child2, Move Child1]] + actions = [MoveToDef mainName, CopyPasteSig (mainName, srcID) [Move Child1, Move Child2, Move Child1]] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg pExpected <*> handleEditRequest actions case result of Left e -> assertFailure $ show e @@ -506,23 +518,24 @@ unit_copy_paste_type_scoping = do -- use the typechecked input p, as the result will have had a typecheck run, so -- we need the cached kinds to match up let clearIDs = set (traversed % #_DefAST % _defIDs) 0 - in -- clearIDs (set (_Just % #defName) "blank" src ) @?= clearIDs (Map.lookup toDef (progDefs r)) - clearIDs (moduleDefs $ progModule r) @?= clearIDs (moduleDefs $ progModule tcpExpected) + in clearIDs (moduleDefs $ progModule r) @?= clearIDs (moduleDefs $ progModule tcpExpected) -- ∀a b.a ~> ∀a.a unit_raise :: Assertion unit_raise = do - let ((pInitial, srcID, pExpected), maxID) = create $ do + let mainName' = "main" + mainName = gvn mainName' + ((pInitial, srcID, pExpected), maxID) = create $ do toCopy <- tvar "a" - defInitial <- ASTDef "main" <$> emptyHole <*> tforall "a" KType (tforall "b" KType $ pure toCopy) - expected <- ASTDef "main" <$> emptyHole <*> tforall "a" KType (tvar "a") + defInitial <- ASTDef mainName <$> emptyHole <*> tforall "a" KType (tforall "b" KType $ pure toCopy) + expected <- ASTDef mainName <$> emptyHole <*> tforall "a" KType (tvar "a") pure - ( newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] + ( newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [(mainName', DefAST defInitial)] , getID toCopy - , newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST expected)] + , newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [(mainName', DefAST expected)] ) let a = newEmptyApp{appProg = pInitial} - actions = [MoveToDef "main", CopyPasteSig ("main", srcID) [Move Child1, Delete]] + actions = [MoveToDef mainName, CopyPasteSig (mainName, srcID) [Move Child1, Delete]] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg pExpected <*> handleEditRequest actions case result of Left e -> assertFailure $ show e @@ -538,31 +551,33 @@ unit_raise = do -- /\a . λ x . case x of Nil -> lettype b = ? in let y = ? : a in Pair @a @b y z ; Cons y ys -> /\@b z -> Pair @a @b y z unit_copy_paste_expr_1 :: Assertion unit_copy_paste_expr_1 = do - let ((pInitial, srcID, pExpected), maxID) = create $ do - ty <- tforall "a" KType $ (tcon "List" `tapp` tvar "a") `tfun` tforall "b" KType (tvar "b" `tfun` (tcon "Pair" `tapp` tvar "a" `tapp` tvar "b")) - let toCopy' = con "MakePair" `aPP` tvar "a" `aPP` tvar "b" `app` lvar "y" `app` lvar "z" -- want different IDs for the two occurences in expected + let mainName' = "main" + mainName = gvn mainName' + ((pInitial, srcID, pExpected), maxID) = create $ do + ty <- tforall "a" KType $ (tcon tList `tapp` tvar "a") `tfun` tforall "b" KType (tvar "b" `tfun` (tcon tPair `tapp` tvar "a" `tapp` tvar "b")) + let toCopy' = con cMakePair `aPP` tvar "a" `aPP` tvar "b" `app` lvar "y" `app` lvar "z" -- want different IDs for the two occurences in expected toCopy <- toCopy' let skel r = lAM "a" $ lam "x" $ case_ (lvar "x") - [ branch "Nil" [] r - , branch "Cons" [("y", Nothing), ("ys", Nothing)] $ lAM "b" $ lam "z" $ pure toCopy + [ branch cNil [] r + , branch cCons [("y", Nothing), ("ys", Nothing)] $ lAM "b" $ lam "z" $ pure toCopy ] - expectPasted <- con "MakePair" `aPP` tvar "a" `aPP` tEmptyHole `app` emptyHole `app` emptyHole + expectPasted <- con cMakePair `aPP` tvar "a" `aPP` tEmptyHole `app` emptyHole `app` emptyHole -- TODO: in the future we may want to insert let bindings for variables -- which are out of scope in the target, and produce something like -- expectPasted <- letType "b" tEmptyHole $ let_ "y" (emptyHole `ann` tvar "a") $ let_ "z" (emptyHole `ann` tvar "b") toCopy' - defInitial <- ASTDef "main" <$> skel emptyHole <*> pure ty - expected <- ASTDef "main" <$> skel (pure expectPasted) <*> pure ty + defInitial <- ASTDef mainName <$> skel emptyHole <*> pure ty + expected <- ASTDef mainName <$> skel (pure expectPasted) <*> pure ty pure - ( newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] + ( newProg & #progModule % #moduleDefs .~ Map.fromList [(mainName', DefAST defInitial)] , getID toCopy - , newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST expected)] + , newProg & #progModule % #moduleDefs .~ Map.fromList [(mainName', DefAST expected)] ) let a = newApp{appProg = pInitial} - actions = [MoveToDef "main", CopyPasteBody ("main", srcID) [Move Child1, Move Child1, Move (Branch "Nil")]] + actions = [MoveToDef mainName, CopyPasteBody (mainName, srcID) [Move Child1, Move Child1, Move (Branch cNil)]] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg pExpected <*> handleEditRequest actions case result of Left e -> assertFailure $ show e @@ -574,42 +589,46 @@ unit_copy_paste_expr_1 = do unit_copy_paste_ann :: Assertion unit_copy_paste_ann = do - let ((p, fromAnn), maxID) = create $ do - toCopy <- tcon "Bool" - mainDef <- ASTDef "main" <$> emptyHole `ann` pure toCopy <*> tEmptyHole - blankDef <- ASTDef "blank" <$> emptyHole `ann` tEmptyHole <*> tEmptyHole + let fromDef' = "main" + fromDef = gvn fromDef' + toDef' = "blank" + toDef = gvn toDef' + ((p, fromAnn), maxID) = create $ do + toCopy <- tcon tBool + mainDef <- ASTDef fromDef <$> emptyHole `ann` pure toCopy <*> tEmptyHole + blankDef <- ASTDef toDef <$> emptyHole `ann` tEmptyHole <*> tEmptyHole pure - ( newProg{progSelection = Nothing} & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST mainDef), ("blank", DefAST blankDef)] + ( newProg{progSelection = Nothing} & #progModule % #moduleDefs .~ Map.fromList [(fromDef', DefAST mainDef), ("blank", DefAST blankDef)] , getID toCopy ) let a = newApp{appProg = p} - actions = [MoveToDef "blank", CopyPasteBody ("main", fromAnn) [EnterType]] + actions = [MoveToDef toDef, CopyPasteBody (fromDef, fromAnn) [EnterType]] let (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg p <*> handleEditRequest actions case result of Left e -> assertFailure $ show e Right (tcp, r) -> -- use the typechecked input p, as the result will have had a typecheck run, so -- we need the cached kinds to match up - let src = lookupASTDef "main" (moduleDefs $ progModule tcp) + let src = lookupASTDef' fromDef' (moduleDefs $ progModule tcp) clearIDs = set (_Just % _defIDs) 0 in do - src @?= lookupASTDef "main" (moduleDefs $ progModule r) - assertBool "equal to blank" $ src /= lookupASTDef "blank" (moduleDefs $ progModule r) - clearIDs (set (_Just % #astDefName) "blank" src) @?= clearIDs (lookupASTDef "blank" (moduleDefs $ progModule r)) + src @?= lookupASTDef' fromDef' (moduleDefs $ progModule r) + assertBool "equal to blank" $ src /= lookupASTDef' toDef' (moduleDefs $ progModule r) + clearIDs (set (_Just % #astDefName) toDef src) @?= clearIDs (lookupASTDef' toDef' (moduleDefs $ progModule r)) unit_copy_paste_ann2sig :: Assertion unit_copy_paste_ann2sig = do let ((pInitial, srcID, pExpected), maxID) = create $ do - toCopy <- tcon "Bool" - defInitial <- ASTDef "main" <$> emptyHole `ann` pure toCopy <*> tEmptyHole - expected <- ASTDef "main" <$> emptyHole `ann` pure toCopy <*> tcon "Bool" + toCopy <- tcon tBool + defInitial <- astDef "main" <$> emptyHole `ann` pure toCopy <*> tEmptyHole + expected <- astDef "main" <$> emptyHole `ann` pure toCopy <*> tcon tBool pure ( newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] , getID toCopy , newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST expected)] ) let a = newApp{appProg = pInitial} - actions = [MoveToDef "main", CopyPasteSig ("main", srcID) []] + actions = [moveToDef "main", copyPasteSig ("main", srcID) []] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg pExpected <*> handleEditRequest actions case result of Left e -> assertFailure $ show e @@ -622,16 +641,16 @@ unit_copy_paste_ann2sig = do unit_copy_paste_sig2ann :: Assertion unit_copy_paste_sig2ann = do let ((pInitial, srcID, pExpected), maxID) = create $ do - toCopy <- tcon "Bool" - defInitial <- ASTDef "main" <$> emptyHole <*> pure toCopy - expected <- ASTDef "main" <$> emptyHole `ann` tcon "Bool" <*> pure toCopy + toCopy <- tcon tBool + defInitial <- astDef "main" <$> emptyHole <*> pure toCopy + expected <- astDef "main" <$> emptyHole `ann` tcon tBool <*> pure toCopy pure ( newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] , getID toCopy , newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST expected)] ) let a = newApp{appProg = pInitial} - actions = [MoveToDef "main", CopyPasteBody ("main", srcID) [ConstructAnn, EnterType]] + actions = [moveToDef "main", copyPasteBody ("main", srcID) [ConstructAnn, EnterType]] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg pExpected <*> handleEditRequest actions case result of Left e -> assertFailure $ show e @@ -645,15 +664,14 @@ unit_copy_paste_sig2ann = do unit_import_vars :: Assertion unit_import_vars = let test = do - p <- defaultFullProg - importModules [progModule p] - gets (Map.assocs . moduleDefs . progModule . appProg) >>= \case + importModules [builtinModule, primitiveModule] + gets (Map.assocs . moduleDefsQualified . progModule . appProg) >>= \case [(i, DefAST d)] -> do a' <- get (_, vs) <- runReaderT (handleQuestion (VariablesInScope i $ getID $ astDefExpr d)) a' pure $ assertBool "VariablesInScope did not report the imported Int.+" $ - any ((== "Int.+") . fst) vs + any ((== primitiveGVar "Int.+") . fst) vs _ -> pure $ assertFailure "Expected one def 'main' from newEmptyApp" a = newEmptyApp in case fst $ runAppTestM (ID $ appIdCounter a) a test of @@ -664,15 +682,14 @@ unit_import_vars = unit_import_reference :: Assertion unit_import_reference = let test = do - p <- defaultFullProg - importModules [progModule p] + importModules [builtinModule, primitiveModule] prog <- gets appProg - case (findGlobalByName prog "toUpper", Map.assocs $ moduleDefs $ progModule prog) of + case (findGlobalByName prog $ primitiveGVar "toUpper", Map.assocs $ moduleDefsQualified $ progModule prog) of (Just toUpperDef, [(i, _)]) -> do _ <- handleEditRequest [ MoveToDef i - , SigAction [ConstructTCon "Char"] + , SigAction [constructTCon tChar] , BodyAction [ConstructVar $ GlobalVarRef $ defName toUpperDef] ] pure $ pure () @@ -683,18 +700,46 @@ unit_import_reference = Left err -> assertFailure $ show err Right assertion -> assertion +unit_import_twice_1 :: Assertion +unit_import_twice_1 = + let test = do + importModules [builtinModule] + importModules [builtinModule] + a = newEmptyApp + in case fst $ runAppTestM (ID $ appIdCounter a) a test of + Left err -> err @?= ActionError (ImportNameClash [moduleName builtinModule]) + Right _ -> assertFailure "Expected importModules to error, since module names clash with prior import" + +unit_import_twice_2 :: Assertion +unit_import_twice_2 = + let test = do + importModules [builtinModule, builtinModule] + a = newEmptyApp + in case fst $ runAppTestM (ID $ appIdCounter a) a test of + Left err -> err @?= ActionError (ImportNameClash [moduleName builtinModule]) + Right _ -> assertFailure "Expected importModules to error, since module names clash within one import" + -- Can copy and paste from an imported module unit_copy_paste_import :: Assertion unit_copy_paste_import = let test = do - p <- defaultFullProg - importModules [progModule p] + importModules [builtinModule] + ty <- tcon tBool `tfun` tcon tBool + e <- lam "x" $ lvar "x" + let def = ASTDef (TestUtils.gvn "M" "foo") e ty + let m = + Module + { moduleName = "M" + , moduleTypes = mempty + , moduleDefs = Map.singleton "foo" $ DefAST def + } + importModules [m] prog <- gets appProg - case (findGlobalByName prog "other", Map.assocs $ moduleDefs $ progModule prog) of - (Just (DefAST other), [(i, _)]) -> do - let fromDef = astDefName other - fromType = getID $ astDefType other - fromExpr = getID $ astDefExpr other + 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 + fromExpr = getID $ astDefExpr fooDef _ <- handleEditRequest [ MoveToDef i @@ -702,45 +747,40 @@ unit_copy_paste_import = , CopyPasteBody (fromDef, fromExpr) [] ] pure $ pure () - (Nothing, _) -> pure $ assertFailure "Could not find the imported 'other'" + (Nothing, _) -> pure $ assertFailure "Could not find the imported 'foo'" (Just _, _) -> pure $ assertFailure "Expected one def 'main' from newEmptyApp" a = newEmptyApp in case fst $ runAppTestM (ID $ appIdCounter a) a test of Left err -> assertFailure $ show err Right assertion -> assertion -unit_rename_def_capture :: Assertion -unit_rename_def_capture = - progActionTest defaultEmptyProg [MoveToDef "other", BodyAction [ConstructLam $ Just "foo"], RenameDef "main" "foo"] $ - expectError (@?= ActionError NameCapture) - unit_RenameType :: Assertion unit_RenameType = progActionTest ( defaultProgEditableTypeDefs $ sequence [ do - x <- emptyHole `ann` (tcon "T" `tapp` tcon "Bool") - ASTDef "def" x <$> tEmptyHole + x <- emptyHole `ann` (tcon tT `tapp` tcon (tcn "Bool")) + astDef "def" x <$> tEmptyHole ] ) - [RenameType "T" "T'"] + [RenameType tT "T'"] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T'" prog' - astTypeDefName td @?= "T'" - def <- findDef "def" prog' + td <- findTypeDef (tcn "T'") prog' + astTypeDefName td @?= tcn "T'" + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ - emptyHole `ann` (tcon "T'" `tapp` tcon "Bool") + emptyHole `ann` (tcon (tcn "T'") `tapp` tcon (tcn "Bool")) ) unit_RenameType_clash :: Assertion unit_RenameType_clash = progActionTest (defaultProgEditableTypeDefs $ pure []) - [RenameType "T" "Int"] - $ expectError (@?= TypeDefAlreadyExists "Int") + [RenameType tT "Int"] + $ expectError (@?= TypeDefAlreadyExists (tcn "Int")) unit_RenameCon :: Assertion unit_RenameCon = @@ -751,25 +791,25 @@ unit_RenameCon = x <- hole ( hole - (con "A") + (con cA) ) - ASTDef "def" x <$> tEmptyHole + astDef "def" x <$> tEmptyHole ] ) - [RenameCon "T" "A" "A'"] + [RenameCon tT cA "A'"] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T" prog' + td <- findTypeDef tT prog' astTypeDefConstructors td - @?= [ ValCon "A'" [TCon () "Bool", TCon () "Bool", TCon () "Bool"] - , ValCon "B" [TVar () "b"] + @?= [ ValCon (vcn "A'") [TCon () (tcn "Bool"), TCon () (tcn "Bool"), TCon () (tcn "Bool")] + , ValCon cB [TVar () "b"] ] - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ hole ( hole - (con "A'") + (con $ vcn "A'") ) ) @@ -782,32 +822,32 @@ unit_RenameCon_clash = x <- hole ( hole - (con "A") + (con cA) ) - ASTDef "def" x <$> tEmptyHole + astDef "def" x <$> tEmptyHole ] ) - [RenameCon "T" "A" "True"] - $ expectError (@?= ConAlreadyExists "True") + [RenameCon tT cA "True"] + $ expectError (@?= ConAlreadyExists (vcn "True")) unit_RenameTypeParam :: Assertion unit_RenameTypeParam = progActionTest (defaultProgEditableTypeDefs $ pure []) - [RenameTypeParam "T" "b" "b'"] + [RenameTypeParam tT "b" "b'"] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T" prog' + td <- findTypeDef tT prog' astTypeDefParameters td @?= [("a", KType), ("b'", KType)] astTypeDefConstructors td - @?= [ ValCon "A" [TCon () "Bool", TCon () "Bool", TCon () "Bool"] - , ValCon "B" [TVar () "b'"] + @?= [ ValCon cA [TCon () (tcn "Bool"), TCon () (tcn "Bool"), TCon () (tcn "Bool")] + , ValCon cB [TVar () "b'"] ] unit_RenameTypeParam_clash :: Assertion unit_RenameTypeParam_clash = progActionTest (defaultProgEditableTypeDefs $ pure []) - [RenameTypeParam "T" "a" "b"] + [RenameTypeParam tT "a" "b"] $ expectError (@?= ParamAlreadyExists "b") unit_AddCon :: Assertion @@ -818,30 +858,30 @@ unit_AddCon = [ do x <- case_ - (emptyHole `ann` (tcon "T" `tapp` tcon "Bool" `tapp` tcon "Int")) - [ branch "A" [] emptyHole - , branch "B" [] emptyHole + (emptyHole `ann` (tcon tT `tapp` tcon (tcn "Bool") `tapp` tcon (tcn "Int"))) + [ branch cA [] emptyHole + , branch cB [] emptyHole ] - ASTDef "def" x <$> tEmptyHole + astDef "def" x <$> tEmptyHole ] ) - [AddCon "T" 1 "C"] + [AddCon tT 1 "C"] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T" prog' + td <- findTypeDef tT prog' astTypeDefConstructors td - @?= [ ValCon "A" [TCon () "Bool", TCon () "Bool", TCon () "Bool"] - , ValCon "C" [] - , ValCon "B" [TVar () "b"] + @?= [ ValCon cA [TCon () (tcn "Bool"), TCon () (tcn "Bool"), TCon () (tcn "Bool")] + , ValCon (vcn "C") [] + , ValCon cB [TVar () "b"] ] - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ case_ - (emptyHole `ann` (tcon "T" `tapp` tcon "Bool" `tapp` tcon "Int")) - [ branch "A" [] emptyHole - , branch "C" [] emptyHole - , branch "B" [] emptyHole + (emptyHole `ann` (tcon tT `tapp` tcon (tcn "Bool") `tapp` tcon (tcn "Int"))) + [ branch cA [] emptyHole + , branch (vcn "C") [] emptyHole + , branch cB [] emptyHole ] ) @@ -849,40 +889,40 @@ unit_SetConFieldType :: Assertion unit_SetConFieldType = progActionTest ( defaultProgEditableTypeDefs . sequence . pure $ do - x <- con "A" `app` lvar "x" `app` (gvar "y" `ann` tcon "Bool") - ASTDef "def" x <$> tEmptyHole + x <- con cA `app` lvar "x" `app` (gvar (gvn "y") `ann` tcon (tcn "Bool")) + astDef "def" x <$> tEmptyHole ) - [SetConFieldType "T" "A" 1 $ TCon () "Int"] + [SetConFieldType tT cA 1 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T" prog' + td <- findTypeDef tT prog' astTypeDefConstructors td - @?= [ ValCon "A" [TCon () "Bool", TCon () "Int", TCon () "Bool"] - , ValCon "B" [TVar () "b"] + @?= [ ValCon cA [TCon () (tcn "Bool"), TCon () (tcn "Int"), TCon () (tcn "Bool")] + , ValCon cB [TVar () "b"] ] - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ - con "A" `app` lvar "x" `app` hole (gvar "y" `ann` tcon "Bool") + con cA `app` lvar "x" `app` hole (gvar (gvn "y") `ann` tcon (tcn "Bool")) ) unit_SetConFieldType_partial_app :: Assertion unit_SetConFieldType_partial_app = progActionTest ( defaultProgEditableTypeDefs $ do - x <- con "A" `app` lvar "x" + x <- con cA `app` lvar "x" sequence - [ ASTDef "def" x <$> tcon "T" + [ astDef "def" x <$> tcon tT ] ) - [SetConFieldType "T" "A" 1 $ TCon () "Int"] + [SetConFieldType tT cA 1 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ hole $ - con "A" `app` lvar "x" + con cA `app` lvar "x" ) unit_SetConFieldType_case :: Assertion @@ -891,30 +931,30 @@ unit_SetConFieldType_case = ( defaultProgEditableTypeDefs $ do x <- case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("z", Nothing)] (lvar "y") - , branch "B" [] emptyHole + , branch cB [] emptyHole ] sequence - [ ASTDef "def" x <$> tcon "Bool" + [ astDef "def" x <$> tcon (tcn "Bool") ] ) - [SetConFieldType "T" "A" 1 $ TCon () "Int"] + [SetConFieldType tT cA 1 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("z", Nothing)] (hole $ lvar "y") - , branch "B" [] emptyHole + , branch cB [] emptyHole ] ) @@ -924,31 +964,31 @@ unit_SetConFieldType_shadow = ( defaultProgEditableTypeDefs $ do x <- case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("z", Nothing)] (lam "y" (lvar "y") `app` lvar "y") - , branch "B" [] emptyHole + , branch cB [] emptyHole ] sequence - [ ASTDef "def" x <$> tcon "Bool" + [ astDef "def" x <$> tcon (tcn "Bool") ] ) - [SetConFieldType "T" "A" 1 $ TCon () "Int"] + [SetConFieldType tT cA 1 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("z", Nothing)] -- only the free `y` should be put in to a hole (lam "y" (lvar "y") `app` hole (lvar "y")) - , branch "B" [] emptyHole + , branch cB [] emptyHole ] ) @@ -956,41 +996,41 @@ unit_AddConField :: Assertion unit_AddConField = progActionTest ( defaultProgEditableTypeDefs $ do - x <- con "A" `app` con "True" + x <- con cA `app` con (vcn "True") sequence - [ ASTDef "def" x <$> tEmptyHole + [ astDef "def" x <$> tEmptyHole ] ) - [AddConField "T" "A" 1 $ TCon () "Int"] + [AddConField tT cA 1 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T" prog' + td <- findTypeDef tT prog' astTypeDefConstructors td - @?= [ ValCon "A" [TCon () "Bool", TCon () "Int", TCon () "Bool", TCon () "Bool"] - , ValCon "B" [TVar () "b"] + @?= [ ValCon cA [TCon () (tcn "Bool"), TCon () (tcn "Int"), TCon () (tcn "Bool"), TCon () (tcn "Bool")] + , ValCon cB [TVar () "b"] ] - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ - con "A" `app` con "True" `app` emptyHole + con cA `app` con (vcn "True") `app` emptyHole ) unit_AddConField_partial_app :: Assertion unit_AddConField_partial_app = progActionTest ( defaultProgEditableTypeDefs $ do - x <- con "A" `app` con "True" + x <- con cA `app` con (vcn "True") sequence - [ ASTDef "def" x <$> tEmptyHole + [ astDef "def" x <$> tEmptyHole ] ) - [AddConField "T" "A" 2 $ TCon () "Int"] + [AddConField tT cA 2 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ - hole $ con "A" `app` con "True" + hole $ con cA `app` con (vcn "True") ) unit_AddConField_case :: Assertion @@ -999,37 +1039,37 @@ unit_AddConField_case = ( defaultProgEditableTypeDefs $ do x <- case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("z", Nothing)] (lvar "y") - , branch "B" [] emptyHole + , branch cB [] emptyHole ] sequence - [ ASTDef "def" x <$> tEmptyHole + [ astDef "def" x <$> tEmptyHole ] ) - [AddConField "T" "A" 2 $ TCon () "Int"] + [AddConField tT cA 2 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("a19", Nothing), ("z", Nothing)] (lvar "y") - , branch "B" [] emptyHole + , branch cB [] emptyHole ] ) -- * Utilities findGlobalByName :: Prog -> GVarName -> Maybe Def -findGlobalByName p n = Map.lookup n . foldMap moduleDefs $ progModule p : progImports p +findGlobalByName p n = Map.lookup n . foldMap moduleDefsQualified $ progAllModules p -- We use a program with two defs: "main" and "other" defaultEmptyProg :: MonadFresh ID m => m Prog @@ -1038,8 +1078,8 @@ defaultEmptyProg = do mainType <- tEmptyHole otherExpr <- emptyHole otherType <- tEmptyHole - let mainDef = ASTDef "main" mainExpr mainType - otherDef = ASTDef "other" otherExpr otherType + let mainDef = astDef "main" mainExpr mainType + otherDef = astDef "other" otherExpr otherType in pure $ newEmptyProg { progSelection = @@ -1054,50 +1094,108 @@ defaultEmptyProg = do } & #progModule % #moduleDefs - .~ Map.fromList [(astDefName mainDef, DefAST mainDef), (astDefName otherDef, DefAST otherDef)] + .~ Map.fromList [(astDefBaseName mainDef, DefAST mainDef), (astDefBaseName otherDef, DefAST otherDef)] unit_good_defaultEmptyProg :: Assertion unit_good_defaultEmptyProg = checkProgWellFormed defaultEmptyProg --- `defaultEmptyProg`, plus all primitive definitions (types and terms), --- and all builtin types. +-- `defaultEmptyProg`, plus all primitive definitions (types and terms) +-- and all builtin types, all moved into the editable module +-- NB: this means that primitive constructors are unusable, since they +-- will not typecheck (we now have only a "Main.Char" type, not a +-- "Primitive.Char" type), but we can now test our error handling for +-- adding types whose name clashes with that of a primitive etc. defaultFullProg :: MonadFresh ID m => m Prog defaultFullProg = do p <- defaultEmptyProg - withPrimDefs $ \m -> - pure $ - over (#progModule % #moduleTypes) (defaultTypeDefs <>) - . over (#progModule % #moduleDefs) ((DefPrim <$> m) <>) - $ p + let m = moduleName $ progModule p + -- We need to move the primitives, which requires renaming + -- unit_defaultFullModule_no_clash ensures that there will be no clashes + renamed = + renameMod (moduleName primitiveModule) m $ + renameMod (moduleName builtinModule) m [builtinModule, primitiveModule] + renamedTypes = renamed ^.. folded % #moduleTypes % folded + renamedDefs = foldOf (folded % #moduleDefs) renamed + pure $ + p & #progModule % #moduleTypes %~ (mkTypeDefMap renamedTypes <>) + & #progModule % #moduleDefs %~ (renamedDefs <>) + where + renameMod :: ModuleName -> ModuleName -> [Module] -> [Module] + -- Caution: if we expose something similar as an action, we would need a + -- test for duplicate module names similar to this for safety, but that + -- would get in the way for our testing purposes here. + -- | any ((== to).moduleName) mods = error "clashing name" + renameMod fromName toName = map rnMod + where + rnMod (m :: Module) = + transformBi rnRef1 $ + transformBi rnRef2 $ + transformBi rnRef3 $ + over #moduleName rnName m + rnName n = if n == fromName then toName else n + -- We have to be careful here, as ModuleName = Name, and we don't want + -- to transform Names inside LocalName etc! + -- TODO: perhaps ModuleName should be its own type? + -- Annoyingly we cannot do this in one pass of transformBi, as it cannot + -- take a function of type GlobalName k -> GlobalName k and act on all + -- instances of k at once. + rnRef1 :: GVarName -> GVarName + rnRef1 qn = qn & #qualifiedModule %~ rnName + rnRef2 :: TyConName -> TyConName + rnRef2 qn = qn & #qualifiedModule %~ rnName + rnRef3 :: ValConName -> ValConName + rnRef3 qn = qn & #qualifiedModule %~ rnName findTypeDef :: TyConName -> Prog -> IO ASTTypeDef -findTypeDef d p = maybe (assertFailure "couldn't find typedef") pure $ (typeDefAST <=< Map.lookup d) $ p ^. (#progModule % #moduleTypes) +findTypeDef d p = maybe (assertFailure "couldn't find typedef") pure $ (typeDefAST <=< Map.lookup d) $ p ^. (#progModule % to moduleTypesQualified) findDef :: GVarName -> Prog -> IO ASTDef -findDef d p = maybe (assertFailure "couldn't find def") pure $ (defAST <=< Map.lookup d) $ p ^. (#progModule % #moduleDefs) +findDef d p = maybe (assertFailure "couldn't find def") pure $ (defAST <=< Map.lookup d) $ p ^. (#progModule % to moduleDefsQualified) -- We use the same type definition for all tests related to editing type definitions +-- (This is added to `defaultFullProg`) +-- The qualified name for this is recorded in 'tT', and its constructors are 'cA' and 'cB' defaultProgEditableTypeDefs :: MonadFresh ID f => f [ASTDef] -> f Prog defaultProgEditableTypeDefs ds = do - p <- defaultEmptyProg + p <- defaultFullProg ds' <- ds let tds = [ TypeDefAST ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tT , astTypeDefParameters = [("a", KType), ("b", KType)] - , astTypeDefConstructors = [ValCon "A" (replicate 3 $ TCon () "Bool"), ValCon "B" [TVar () "b"]] + , astTypeDefConstructors = [ValCon cA (replicate 3 $ TCon () (tcn "Bool")), ValCon cB [TVar () "b"]] , astTypeDefNameHints = [] } ] pure $ p - & (#progModule % #moduleTypes) %~ ((mkTypeDefMap tds <> defaultTypeDefs) <>) - & (#progModule % #moduleDefs) %~ (Map.fromList ((\d -> (astDefName d, DefAST d)) <$> ds') <>) + & (#progModule % #moduleTypes) %~ (mkTypeDefMap tds <>) + & (#progModule % #moduleDefs) %~ (Map.fromList ((\d -> (baseName $ astDefName d, DefAST d)) <$> ds') <>) + +tT :: TyConName +tT = tcn "T" + +cA :: ValConName +cA = vcn "A" + +cB :: ValConName +cB = vcn "B" unit_good_defaultFullProg :: Assertion unit_good_defaultFullProg = checkProgWellFormed defaultFullProg +-- All primitives,builtins and defaultEmptyProg things have distinct base names (defaultFullProg expects this) +unit_defaultFullProg_no_clash :: Assertion +unit_defaultFullProg_no_clash = + let (p, _) = create defaultEmptyProg + ms = progModule p : [builtinModule, primitiveModule] + typeNames = ms ^.. folded % #moduleTypes % folded % to typeDefName % #baseName + termNames = ms ^.. folded % #moduleDefs % to Map.keys % folded + in do + assertBool "Expected every type making up defaultFullProg to have distinct names" $ not $ anySame typeNames + assertBool "Expected every term making up defaultFullProg to have distinct names" $ not $ anySame termNames + _defIDs :: Traversal' ASTDef ID _defIDs = #astDefExpr % (_exprMeta % _id `adjoin` _exprTypeMeta % _id) `adjoin` #astDefType % _typeMeta % _id @@ -1136,3 +1234,49 @@ runAppTestM startID a m = case evalTestM startID $ runExceptT $ flip runStateT a $ unAppTestM m of Left err -> (Left err, a) Right (res, app') -> (Right res, app') + +-- Looks up a definition, ignoring any module prefix +-- Useful in these tests so we don't have to specify +-- the name of the module all the time +lookupASTDef' :: Name -> Map Name Def -> Maybe ASTDef +lookupASTDef' name = defAST <=< Map.lookup name + +astDefBaseName :: ASTDef -> Name +astDefBaseName = baseName . astDefName + +-- Some helpers to run actions on the current module +mainModuleName :: ModuleName +mainModuleName = moduleName $ progModule newEmptyProg + +mainModuleNameText :: Text +mainModuleNameText = unName mainModuleName + +moveToDef :: Name -> ProgAction +moveToDef = MoveToDef . qualifyName mainModuleName + +renameDef :: Name -> Text -> ProgAction +renameDef = RenameDef . qualifyName mainModuleName + +deleteDef :: Name -> ProgAction +deleteDef = DeleteDef . gvn + +tcn :: Name -> TyConName +tcn = TestUtils.tcn mainModuleName + +vcn :: Name -> ValConName +vcn = TestUtils.vcn mainModuleName + +gvn :: Name -> GVarName +gvn = TestUtils.gvn mainModuleName + +astDef :: Name -> Expr -> Type -> ASTDef +astDef = ASTDef . gvn + +copyPasteSig :: (Name, ID) -> [Action] -> ProgAction +copyPasteSig (d, i) = CopyPasteSig (gvn d, i) + +copyPasteBody :: (Name, ID) -> [Action] -> ProgAction +copyPasteBody (d, i) = CopyPasteBody (gvn d, i) + +globalVarRef :: Name -> TmVarRef +globalVarRef = GlobalVarRef . gvn diff --git a/primer/test/Tests/AlphaEquality.hs b/primer/test/Tests/AlphaEquality.hs index 88e1d097b..69419bacb 100644 --- a/primer/test/Tests/AlphaEquality.hs +++ b/primer/test/Tests/AlphaEquality.hs @@ -9,6 +9,7 @@ import Gen.Core.Raw ( ) import Hedgehog hiding (check) import Optics (set) +import Primer.Builtins import Primer.Core ( Kind (KFun, KType), Type', @@ -21,68 +22,68 @@ import Test.Tasty.HUnit hiding (assert) unit_1 :: Assertion unit_1 = assertNotEqual - (create' (tcon "Nat")) - (create' (tcon "Bool")) + (create' (tcon tNat)) + (create' (tcon tBool)) unit_2 :: Assertion unit_2 = (@?=) - (create' (tcon "List" `tapp` tcon "Nat")) - (create' (tcon "List" `tapp` tcon "Nat")) + (create' (tcon tList `tapp` tcon tNat)) + (create' (tcon tList `tapp` tcon tNat)) unit_3 :: Assertion unit_3 = assertNotEqual - (create' (tcon "List" `tapp` tcon "Bool")) - (create' (tcon "List" `tapp` tcon "Nat")) + (create' (tcon tList `tapp` tcon tBool)) + (create' (tcon tList `tapp` tcon tNat)) unit_4 :: Assertion unit_4 = assertNotEqual - (create' (tcon "List" `tapp` tcon "Bool")) - (create' (tcon "Nat")) + (create' (tcon tList `tapp` tcon tBool)) + (create' (tcon tNat)) unit_5 :: Assertion unit_5 = assertNotEqual - (create' (tforall "a" KType $ tcon "List" `tapp` tvar "a")) - (create' (tcon "Nat")) + (create' (tforall "a" KType $ tcon tList `tapp` tvar "a")) + (create' (tcon tNat)) unit_6 :: Assertion unit_6 = (@?=) - (create' (tforall "a" KType $ tcon "List" `tapp` tvar "a")) - (create' (tforall "b" KType $ tcon "List" `tapp` tvar "b")) + (create' (tforall "a" KType $ tcon tList `tapp` tvar "a")) + (create' (tforall "b" KType $ tcon tList `tapp` tvar "b")) unit_7 :: Assertion unit_7 = assertNotEqual - (create' (tforall "a" KType $ tcon "List" `tapp` tvar "a")) - (create' (tforall "b" KType $ tcon "List" `tapp` tcon "Bool")) + (create' (tforall "a" KType $ tcon tList `tapp` tvar "a")) + (create' (tforall "b" KType $ tcon tList `tapp` tcon tBool)) unit_8 :: Assertion unit_8 = assertNotEqual - (create' (tforall "a" KType $ tcon "Bool")) - (create' (tforall "b" (KFun KType KType) $ tcon "Bool")) + (create' (tforall "a" KType $ tcon tBool)) + (create' (tforall "b" (KFun KType KType) $ tcon tBool)) unit_9 :: Assertion unit_9 = assertNotEqual - (create' (tforall "a" KType $ tforall "b" KType $ tcon "List" `tapp` tvar "a")) - (create' (tforall "a" KType $ tforall "b" KType $ tcon "List" `tapp` tvar "b")) + (create' (tforall "a" KType $ tforall "b" KType $ tcon tList `tapp` tvar "a")) + (create' (tforall "a" KType $ tforall "b" KType $ tcon tList `tapp` tvar "b")) unit_10 :: Assertion unit_10 = assertNotEqual - (create' (tforall "a" KType $ tcon "List" `tapp` tvar "a")) - (create' (tcon "List" `tapp` tforall "a" KType (tvar "b"))) + (create' (tforall "a" KType $ tcon tList `tapp` tvar "a")) + (create' (tcon tList `tapp` tforall "a" KType (tvar "b"))) unit_11 :: Assertion unit_11 = assertNotEqual - (create' (tforall "a" KType $ tcon "Bool" `tfun` (tcon "List" `tapp` tvar "a"))) - (create' (tcon "Bool" `tfun` tforall "a" KType (tcon "List" `tapp` tvar "a"))) + (create' (tforall "a" KType $ tcon tBool `tfun` (tcon tList `tapp` tvar "a"))) + (create' (tcon tBool `tfun` tforall "a" KType (tcon tList `tapp` tvar "a"))) hprop_refl :: Property hprop_refl = property $ do diff --git a/primer/test/Tests/Eval.hs b/primer/test/Tests/Eval.hs index 1fd672d32..25d38003a 100644 --- a/primer/test/Tests/Eval.hs +++ b/primer/test/Tests/Eval.hs @@ -11,16 +11,24 @@ import Primer.App ( App (appIdCounter), EvalReq (EvalReq, evalReqExpr, evalReqRedex), EvalResp (EvalResp, evalRespExpr), - Prog (progModule), - boolDef, handleEvalRequest, importModules, newEmptyApp, ) +import Primer.Builtins ( + boolDef, + builtinModule, + cFalse, + cNil, + cTrue, + cZero, + tBool, + ) import Primer.Core ( ASTDef (..), Def (..), Expr, + GlobalName (qualifiedModule), ID (ID), Type, TypeDef (TypeDefAST), @@ -46,13 +54,13 @@ import Primer.Eval ( tryReduceExpr, tryReduceType, ) -import Primer.Module (Module (Module, moduleDefs, moduleTypes)) -import Primer.Typecheck (mkTypeDefMap) +import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), mkTypeDefMap) +import Primer.Primitives (primitiveGVar, primitiveModule, tChar) import Primer.Zipper (target) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=)) import TestM (evalTestM) -import TestUtils (withPrimDefs) -import Tests.Action.Prog (defaultFullProg, runAppTestM) +import TestUtils (gvn, vcn, withPrimDefs) +import Tests.Action.Prog (runAppTestM) -- * 'tryReduce' tests @@ -65,7 +73,7 @@ runTryReduceType globals locals (ty, i) = evalTestM i $ runExceptT $ tryReduceTy unit_tryReduce_no_redex :: Assertion unit_tryReduce_no_redex = do - runTryReduce mempty mempty (create (con "Zero")) @?= Left NotRedex + runTryReduce mempty mempty (create (con cZero)) @?= Left NotRedex unit_tryReduce_beta :: Assertion unit_tryReduce_beta = do @@ -73,7 +81,7 @@ unit_tryReduce_beta = do create $ do x <- lvar "x" l <- lam "x" (pure x) - a <- con "Zero" + a <- con cZero i <- app (pure l) (pure a) r <- let_ "x" (pure a) (pure x) pure (l, x, a, i, r) @@ -95,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 "A" - t2 <- tcon "B" + t1 <- tcon' "M" "A" + t2 <- tcon' "M" "B" x <- lvar "x" l <- lam "x" (pure x) - a <- con "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) @@ -125,7 +133,7 @@ unit_tryReduce_beta_annotation_hole = do t2 <- tEmptyHole x <- lvar "x" l <- lam "x" (pure x) - a <- con "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) @@ -150,16 +158,16 @@ unit_tryReduce_beta_nested = do create $ do e <- lam "y" (lvar "x") l <- lam "x" (pure e) - a <- con "C" - i <- app (app (pure l) (pure a)) (con "D") - r <- app (let_ "x" (pure a) (pure e)) (con "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 "C"))) - betaAfter detail ~= fst (create (let_ "x" (con "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 @@ -171,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 "A" - t2 <- tcon "B" + t1 <- tcon' "M" "A" + t2 <- tcon' "M" "B" x <- lvar "x" l <- lam "x" (pure x) - a <- con "C" - i <- app (app (ann (pure l) (tfun (pure t1) (pure t2))) (pure a)) (con "D") - r <- app (ann (let_ "x" (ann (pure a) (pure t1)) (pure x)) (pure t2)) (con "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 "A") (tcon "B"))) (con "C"))) - betaAfter detail ~= fst (create (ann (let_ "x" (ann (con "C") (tcon "A")) (lvar "x")) (tcon "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 @@ -206,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 "C" + c_ <- con' "M" "C" e <- lam "x0" (lvar "x") l <- lam "x" (pure e) a <- lvar "x" @@ -231,9 +239,9 @@ unit_tryReduce_BETA :: Assertion unit_tryReduce_BETA = do let ((body, lambda, arg, input, expectedResult), maxid) = create $ do - b <- aPP (con "Nil") (tvar "x") + b <- aPP (con cNil) (tvar "x") l <- lAM "x" (pure b) - a <- tcon "Bool" + a <- tcon tBool i <- aPP (pure l) (pure a) r <- letType "x" (pure a) (pure b) pure (b, l, a, i, r) @@ -254,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 "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 @@ -272,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 "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 @@ -289,14 +297,15 @@ unit_tryReduce_local_type_var = do unit_tryReduce_global_var :: Assertion unit_tryReduce_global_var = do - let ((expr, def), i) = create $ do - g <- gvar "f" + let f = gvn "M" "f" + ((expr, def), i) = create $ do + g <- gvar f e <- lam "x" (lvar "x") - t <- tfun (tcon "A") (tcon "B") - pure (g, ASTDef{astDefName = "f", astDefExpr = e, astDefType = t}) - globals = Map.singleton "f" (DefAST def) + 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 "A") (tcon "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 @@ -308,9 +317,9 @@ unit_tryReduce_global_var = do unit_tryReduce_let :: Assertion unit_tryReduce_let = do - let (expr, i) = create $ let_ "x" (con "C") (con "D") + let (expr, i) = create $ let_ "x" (con' "M" "C") (con' "M" "D") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con "D" + expectedResult = fst $ create $ con' "M" "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -324,9 +333,9 @@ unit_tryReduce_let = do unit_tryReduce_lettype :: Assertion unit_tryReduce_lettype = do - let (expr, i) = create $ letType "x" (tcon "C") (con "D") + let (expr, i) = create $ letType "x" (tcon' "M" "C") (con' "M" "D") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con "D" + expectedResult = fst $ create $ con' "M" "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -340,9 +349,9 @@ unit_tryReduce_lettype = do unit_tryReduce_letrec :: Assertion unit_tryReduce_letrec = do - let (expr, i) = create $ letrec "x" (con "C") (tcon "T") (con "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 "D" + expectedResult = fst $ create $ con' "M" "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -359,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 "D" + arg_ <- con' "M" "D" lam_ <- lam "x" $ app (lvar "f") (lvar "x") - lr <- letrec "f" (lam "x" (lvar "x")) (tcon "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 "T") (app (lam "x" (app (lvar "f") (lvar "x"))) (con "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 @@ -384,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 "B" + arg_ <- tcon' "M" "B" lam_ <- lAM "x" $ aPP (lvar "f") (tvar "x") - lr <- letrec "f" (lAM "x" (con "A")) (tcon "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 "A")) (tcon "T") (aPP (lAM "x" (aPP (lvar "f") (tvar "x"))) (tcon "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 @@ -413,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 "D" + d_ <- con' "M" "D" -- the application - e <- app (letrec "f" (lam "x" (lvar "x")) (tcon "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_) @@ -424,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 "C") [branch "B" [("b", Nothing)] (con "D"), branch "C" [] (con "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 "E" + expectedResult = fst $ create $ con' "M" "E" case result of Right (expr', CaseReduction detail) -> do expr' ~= expectedResult @@ -435,7 +444,7 @@ unit_tryReduce_case_1 = do caseAfter detail ~= expectedResult caseTargetID detail @?= 1 caseTargetCtorID detail @?= 1 - caseCtorName detail @?= "C" + caseCtorName detail @?= vcn "M" "C" caseTargetArgIDs detail @?= [] caseBranchBindingIDs detail @?= [] caseBranchRhsID detail @?= 4 @@ -447,12 +456,12 @@ unit_tryReduce_case_2 = do let (expr, i) = create $ case_ - (app (app (app (con "C") (lam "x" (lvar "x"))) (lvar "y")) (lvar "z")) - [ branch "B" [("b", Nothing)] (con "D") - , branch "C" [("c", Nothing), ("d", Nothing), ("e", Nothing)] (con "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 "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 @@ -461,7 +470,7 @@ unit_tryReduce_case_2 = do caseAfter detail ~= expectedResult caseTargetID detail @?= 1 caseTargetCtorID detail @?= 4 - caseCtorName detail @?= "C" + caseCtorName detail @?= vcn "M" "C" caseTargetArgIDs detail @?= [5, 7, 8] caseBranchBindingIDs detail @?= [11, 12, 13] caseBranchRhsID detail @?= 14 @@ -473,12 +482,12 @@ unit_tryReduce_case_3 = do let (expr, i) = create $ case_ - (app (aPP (con "C") (tcon "D")) (con "E")) - [ branch "B" [("b", Nothing)] (con "D") - , branch "C" [("c", Nothing)] (con "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 "E") (con "F") + expectedResult = fst $ create $ let_ "c" (con' "M" "E") (con' "M" "F") case result of Right (expr', CaseReduction detail) -> do expr' ~= expectedResult @@ -487,7 +496,7 @@ unit_tryReduce_case_3 = do caseAfter detail ~= expectedResult caseTargetID detail @?= 1 caseTargetCtorID detail @?= 3 - caseCtorName detail @?= "C" + caseCtorName detail @?= vcn "M" "C" caseTargetArgIDs detail @?= [5] caseBranchBindingIDs detail @?= [8] caseBranchRhsID detail @?= 9 @@ -496,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 "C") [branch "C" [("b", Nothing)] (con "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 "B") (lvar "y")) [branch "B" [] (con "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 "B" [] (con "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 "C") [branch "B" [] (con "D")] + let (expr, i) = create $ case_ (con' "M" "C") [branch' ("M", "B") [] (con' "M" "D")] result = runTryReduce mempty mempty (expr, i) result @?= Left NoMatchingCaseBranch @@ -523,8 +532,8 @@ unit_tryReduce_prim = do let ((expr, expectedResult, globals), i) = create . withPrimDefs $ \m -> (,,) - <$> gvar "eqChar" `app` char 'a' `app` char 'a' - <*> con "True" + <$> gvar (primitiveGVar "eqChar") `app` char 'a' `app` char 'a' + <*> con cTrue <*> pure m result = runTryReduce (DefPrim <$> globals) mempty (expr, i) case result of @@ -533,7 +542,7 @@ unit_tryReduce_prim = do applyPrimFunBefore detail ~= expr applyPrimFunAfter detail ~= expr' - applyPrimFunName detail @?= "eqChar" + applyPrimFunName detail @?= primitiveGVar "eqChar" applyPrimFunArgIDs detail @?= [101, 102] _ -> assertFailure $ show result @@ -542,7 +551,7 @@ unit_tryReduce_prim_fail_unsaturated = do let ((expr, globals), i) = create . withPrimDefs $ \m -> (,) - <$> gvar "eqChar" `app` char 'a' + <$> gvar (primitiveGVar "eqChar") `app` char 'a' <*> pure m result = runTryReduce (DefPrim <$> globals) mempty (expr, i) result @?= Left NotRedex @@ -552,7 +561,7 @@ unit_tryReduce_prim_fail_unreduced_args = do let ((expr, globals), i) = create . withPrimDefs $ \m -> (,) - <$> gvar "eqChar" `app` char 'a' `app` (gvar "toUpper" `app` char 'a') + <$> gvar (primitiveGVar "eqChar") `app` char 'a' `app` (gvar (primitiveGVar "toUpper") `app` char 'a') <*> pure m result = runTryReduce (DefPrim <$> globals) mempty (expr, i) result @?= Left NotRedex @@ -561,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 "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 "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 @@ -596,7 +605,7 @@ unit_findNodeByID_1 = do -- id 0 x_ <- lvar "x" -- id 1 - c_ <- con "C" + c_ <- con' "M" "C" -- id 2 e <- let_ "x" (pure c_) (pure x_) pure (x_, c_, e) @@ -629,7 +638,7 @@ unit_findNodeByID_2 = do -- id 0 x_ <- tvar "x" -- id 1 - t_ <- tcon "T" + t_ <- tcon' "M" "T" -- id 2 e <- letType "x" (pure t_) (ann (lvar "y") (pure x_)) pure (x_, t_, e) @@ -652,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 "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 @@ -663,159 +672,158 @@ redexesOfWithPrims :: S Expr -> Set ID redexesOfWithPrims x = uncurry redexes $ fst $ create $ withPrimDefs $ \globals -> (globals,) <$> x unit_redexes_con :: Assertion -unit_redexes_con = redexesOf (con "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 "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 "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 "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 "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 "C")) @?= mempty + redexesOf (lAM "a" (con' "M" "C")) @?= mempty unit_redexes_LAM_2 :: Assertion unit_redexes_LAM_2 = - redexesOf (aPP (lAM "a" (con "C")) (tcon "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 "X")) (tcon "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 "C") (lAM "a" (aPP (lAM "b" (lvar "x")) (tcon "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 "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 "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 "C") (lvar "x")) (tcon "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 "C") (lvar "x")) (tcon "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 "C") (tcon "T") (lam "x" (lvar "e"))) (con "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 "D") (app (letrec "e" (con "C") (tcon "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 "C") (tcon "T") (lAM "x" (lvar "e"))) (tcon "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 "D") (aPP (letrec "e" (con "C") (tcon "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 "T") (con "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 "T") (aPP (con "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 "T") (letrec "y" (con "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 "C") [branch "C" [] (con "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 "C") (tcon "C")) [branch "C" [] (con "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 "C" [] (con "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 "C") (case_ (con "C") [branch "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 "C") (case_ (con "C") [branch "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 "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 = - redexesOfWithPrims (gvar "eqChar" `app` char 'a' `app` char 'b') @?= Set.fromList [98] + redexesOfWithPrims (gvar (primitiveGVar "eqChar") `app` char 'a' `app` char 'b') @?= Set.fromList [98] unit_redexes_prim_2 :: Assertion unit_redexes_prim_2 = - redexesOfWithPrims (gvar "eqChar" `app` lvar "a" `app` char 'b') @?= Set.empty + redexesOfWithPrims (gvar (primitiveGVar "eqChar") `app` lvar "a" `app` char 'b') @?= Set.empty unit_redexes_prim_3 :: Assertion unit_redexes_prim_3 = - redexesOfWithPrims (gvar "eqChar" `app` char 'a') @?= Set.empty + redexesOfWithPrims (gvar (primitiveGVar "eqChar") `app` char 'a') @?= Set.empty unit_redexes_prim_ann :: Assertion unit_redexes_prim_ann = redexesOfWithPrims expr @?= Set.singleton 98 where expr = - gvar "toUpper" - `ann` (tcon "Char" `tfun` tcon "Char") - `app` (char 'a' `ann` tcon "Char") + gvar (primitiveGVar "toUpper") + `ann` (tcon tChar `tfun` tcon tChar) + `app` (char 'a' `ann` tcon tChar) -- Test that handleEvalRequest will reduce imported terms unit_eval_modules :: Assertion unit_eval_modules = let test = do - p <- defaultFullProg - importModules [progModule p] - foo <- gvar "toUpper" `app` char 'a' + importModules [primitiveModule, builtinModule] + foo <- gvar (primitiveGVar "toUpper") `app` char 'a' EvalResp{evalRespExpr = e} <- handleEvalRequest EvalReq{evalReqExpr = foo, evalReqRedex = getID foo} @@ -831,11 +839,11 @@ unit_eval_modules_scrutinize_imported_type :: Assertion unit_eval_modules_scrutinize_imported_type = let test = do importModules [m] - foo <- case_ (con "True") [branch "True" [] $ con "False", branch "False" [] $ con "True"] + foo <- case_ (con cTrue) [branch cTrue [] $ con cFalse, branch cFalse [] $ con cTrue] EvalResp{evalRespExpr = e} <- handleEvalRequest EvalReq{evalReqExpr = foo, evalReqRedex = getID foo} - expect <- con "False" + expect <- con cFalse pure $ e ~= expect a = newEmptyApp in case fst $ runAppTestM (ID $ appIdCounter a) a test of @@ -844,7 +852,8 @@ unit_eval_modules_scrutinize_imported_type = where m = Module - { moduleTypes = mkTypeDefMap [TypeDefAST boolDef] + { moduleName = qualifiedModule tBool + , moduleTypes = mkTypeDefMap [TypeDefAST boolDef] , moduleDefs = mempty } diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs index c5c9aa8d1..d0650adbc 100644 --- a/primer/test/Tests/EvalFull.hs +++ b/primer/test/Tests/EvalFull.hs @@ -5,8 +5,8 @@ import Foreword hiding (unlines) import Control.Monad.Fresh (MonadFresh) import Data.Generics.Uniplate.Data (universe) import Data.List ((\\)) -import Data.Map ((!)) import qualified Data.Map as M +import qualified Data.Map as Map import qualified Data.Set as S import Data.String (unlines) import Gen.Core.Typed (WT, forAllT, genChk, genSyn, genWTType, isolateWT, propertyWT) @@ -18,34 +18,43 @@ import Primer.App ( App (appIdCounter), EvalFullReq (EvalFullReq, evalFullCxtDir, evalFullMaxSteps, evalFullReqExpr), EvalFullResp (EvalFullRespNormal, EvalFullRespTimedOut), - Prog (progModule), - boolDef, - defaultTypeDefs, handleEvalFullRequest, importModules, newEmptyApp, ) +import Primer.Builtins ( + boolDef, + builtinModule, + cCons, + cFalse, + cJust, + cMakePair, + cNil, + cNothing, + cSucc, + cTrue, + cZero, + tBool, + tList, + tNat, + tPair, + ) import Primer.Core import Primer.Core.DSL -import Primer.Core.Utils (forgetIDs, forgetTypeIDs, generateIDs, generateTypeIDs) +import Primer.Core.Utils (forgetIDs, generateIDs) import Primer.EvalFull -import Primer.Module (Module (Module, moduleDefs, moduleTypes)) -import Primer.Primitives (allPrimDefs) +import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), mkTypeDefMap, moduleDefsQualified, moduleTypesQualified) +import Primer.Name (Name) +import Primer.Primitives (primitiveGVar, primitiveModule, tChar, tInt) import Primer.Typecheck ( - SmartHoles (NoSmartHoles), - buildTypingContext, - extendGlobalCxt, - globalCxt, - mkTypeDefMap, typeDefs, ) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=)) import TestM -import TestUtils (withPrimDefs) -import Tests.Action.Prog (defaultFullProg, runAppTestM) +import TestUtils (gvn, withPrimDefs) +import Tests.Action.Prog (runAppTestM) import Tests.Eval ((~=)) import Tests.Gen.Core.Typed (checkTest) -import Prelude (error) unit_1 :: Assertion unit_1 = @@ -67,9 +76,9 @@ unit_2 = unit_3 :: Assertion unit_3 = let ((expr, expected), maxID) = create $ do - e <- letType "a" (tvar "b") $ emptyHole `ann` (tcon "T" `tapp` tvar "a" `tapp` tforall "a" KType (tvar "a") `tapp` tforall "b" KType (tcon "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 "T" `tapp` tvar "b" `tapp` tforall "a" KType (tvar "a") `tapp` tforall b' KType (tcon "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 @@ -80,9 +89,9 @@ unit_3 = unit_4 :: Assertion unit_4 = let ((expr, expected), maxID) = create $ do - e <- let_ "a" (lvar "b") $ con "C" `app` lvar "a" `app` lam "a" (lvar "a") `app` lam "b" (con "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 "C" `app` lvar "b" `app` lam "a" (lvar "a") `app` lam b' (con "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 @@ -98,8 +107,8 @@ unit_4 = unit_5 :: Assertion unit_5 = let ((e, expt), maxID) = create $ do - a <- letrec "x" (lvar "x") (tcon "Bool") (lvar "x") - b <- letrec "x" (lvar "x") (tcon "Bool") (lvar "x" `ann` tcon "Bool") `ann` tcon "Bool" + a <- letrec "x" (lvar "x") (tcon tBool) (lvar "x") + b <- letrec "x" (lvar "x") (tcon tBool) (lvar "x" `ann` tcon tBool) `ann` tcon tBool pure (a, b) s = evalFullTest maxID mempty mempty 100 Syn e in do @@ -109,8 +118,8 @@ unit_5 = unit_6 :: Assertion unit_6 = let ((e, expt), maxID) = create $ do - tr <- con "True" - an <- ann (pure tr) (tcon "Bool") + tr <- con cTrue + an <- ann (pure tr) (tcon tBool) pure (an, tr) s = evalFullTest maxID mempty mempty 1 Syn e t = evalFullTest maxID mempty mempty 2 Chk e @@ -139,7 +148,8 @@ unit_8 :: Assertion unit_8 = let n = 10 ((globals, e, expected), maxID) = create $ do - mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon "List" `tapp` tvar "a") `tfun` (tcon "List" `tapp` tvar "b")) + 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" $ lAM "b" $ @@ -147,29 +157,31 @@ unit_8 = lam "xs" $ case_ (lvar "xs") - [ branch "Nil" [] $ con "Nil" `aPP` tvar "b" - , branch "Cons" [("y", Nothing), ("ys", Nothing)] $ con "Cons" `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (gvar "map" `aPP` tvar "a" `aPP` tvar "b" `app` lvar "f" `app` lvar "ys") + [ 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" -- even and odd have almost the same type, but their types contain different IDs - let evenOddTy = tcon "Nat" `tfun` tcon "Bool" + let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy oddTy <- evenOddTy - isEven <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "True", branch "Succ" [("n", Nothing)] $ gvar "odd" `app` lvar "n"] - isOdd <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "False", branch "Succ" [("n", Nothing)] $ gvar "even" `app` lvar "n"] - let mkList t = foldr (\x xs -> con "Cons" `aPP` t `app` x `app` xs) (con "Nil" `aPP` t) - let lst = mkList (tcon "Nat") $ take n $ iterate (con "Succ" `app`) (con "Zero") - expr <- gvar "map" `aPP` tcon "Nat" `aPP` tcon "Bool" `app` gvar "even" `app` lst - let mapDef = DefAST $ ASTDef "map" map_ mapTy - let evenDef = DefAST $ ASTDef "even" isEven evenTy - let oddDef = DefAST $ ASTDef "odd" isOdd oddTy - let globs = [("map", mapDef), ("even", evenDef), ("odd", oddDef)] - expect <- mkList (tcon "Bool") (take n $ cycle [con "True", con "False"]) `ann` (tcon "List" `tapp` tcon "Bool") + isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar oddName `app` lvar "n"] + isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar evenName `app` lvar "n"] + let mkList t = foldr (\x xs -> con cCons `aPP` t `app` x `app` xs) (con cNil `aPP` t) + let lst = mkList (tcon tNat) $ take n $ iterate (con cSucc `app`) (con cZero) + expr <- gvar mapName `aPP` tcon tNat `aPP` tcon tBool `app` gvar evenName `app` lst + let mapDef = DefAST $ ASTDef mapName map_ mapTy + let evenDef = DefAST $ ASTDef evenName isEven evenTy + let oddDef = DefAST $ ASTDef oddName isOdd oddTy + let globs = [(mapName, mapDef), (evenName, evenDef), (oddName, oddDef)] + expect <- mkList (tcon tBool) (take n $ cycle [con cTrue, con cFalse]) `ann` (tcon tList `tapp` tcon tBool) pure (globs, expr, expect) in do - case evalFullTest maxID defaultTypeDefs (M.fromList globals) 500 Syn e of + case evalFullTest maxID builtinTypes (M.fromList globals) 500 Syn e of Left (TimedOut _) -> pure () x -> assertFailure $ show x - let s = evalFullTest maxID defaultTypeDefs (M.fromList globals) 1000 Syn e + let s = evalFullTest maxID builtinTypes (M.fromList globals) 1000 Syn e distinctIDs s s <~==> Right expected @@ -178,35 +190,38 @@ unit_9 :: Assertion unit_9 = let n = 10 ((globals, e, expected), maxID) = create $ do - mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon "List" `tapp` tvar "a") `tfun` (tcon "List" `tapp` tvar "b")) + 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" $ case_ (lvar "xs") - [ branch "Nil" [] $ con "Nil" `aPP` tvar "b" - , branch "Cons" [("y", Nothing), ("ys", Nothing)] $ con "Cons" `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (lvar "go" `app` lvar "ys") + [ 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` (lvar "go" `app` lvar "ys") ] - map_ <- lAM "a" $ lAM "b" $ lam "f" $ letrec "go" worker ((tcon "List" `tapp` tvar "a") `tfun` (tcon "List" `tapp` tvar "b")) $ lvar "go" + 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" -- even and odd have almost the same type, but their types contain different IDs - let evenOddTy = tcon "Nat" `tfun` tcon "Bool" + let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy oddTy <- evenOddTy - isEven <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "True", branch "Succ" [("n", Nothing)] $ gvar "odd" `app` lvar "n"] - isOdd <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "False", branch "Succ" [("n", Nothing)] $ gvar "even" `app` lvar "n"] - let mkList t = foldr (\x xs -> con "Cons" `aPP` t `app` x `app` xs) (con "Nil" `aPP` t) - let lst = mkList (tcon "Nat") $ take n $ iterate (con "Succ" `app`) (con "Zero") - expr <- gvar "map" `aPP` tcon "Nat" `aPP` tcon "Bool" `app` gvar "even" `app` lst - let mapDef = DefAST $ ASTDef "map" map_ mapTy - let evenDef = DefAST $ ASTDef "even" isEven evenTy - let oddDef = DefAST $ ASTDef "odd" isOdd oddTy - let globs = [("map", mapDef), ("even", evenDef), ("odd", oddDef)] - expect <- mkList (tcon "Bool") (take n $ cycle [con "True", con "False"]) `ann` (tcon "List" `tapp` tcon "Bool") + isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar oddName `app` lvar "n"] + isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar evenName `app` lvar "n"] + let mkList t = foldr (\x xs -> con cCons `aPP` t `app` x `app` xs) (con cNil `aPP` t) + let lst = mkList (tcon tNat) $ take n $ iterate (con cSucc `app`) (con cZero) + expr <- gvar mapName `aPP` tcon tNat `aPP` tcon tBool `app` gvar evenName `app` lst + let mapDef = DefAST $ ASTDef mapName map_ mapTy + let evenDef = DefAST $ ASTDef evenName isEven evenTy + let oddDef = DefAST $ ASTDef oddName isOdd oddTy + let globs = [(mapName, mapDef), (evenName, evenDef), (oddName, oddDef)] + expect <- mkList (tcon tBool) (take n $ cycle [con cTrue, con cFalse]) `ann` (tcon tList `tapp` tcon tBool) pure (globs, expr, expect) in do - case evalFullTest maxID defaultTypeDefs (M.fromList globals) 500 Syn e of + case evalFullTest maxID builtinTypes (M.fromList globals) 500 Syn e of Left (TimedOut _) -> pure () x -> assertFailure $ show x - let s = evalFullTest maxID defaultTypeDefs (M.fromList globals) 1000 Syn e + let s = evalFullTest maxID builtinTypes (M.fromList globals) 1000 Syn e distinctIDs s s <~==> Right expected @@ -219,21 +234,21 @@ unit_10 = let ((s, t, expected), maxID) = create $ do annCase <- case_ - (con "Zero" `ann` tcon "Nat") - [ branch "Zero" [] $ con "True" - , branch "Succ" [("n", Nothing)] $ con "False" + (con cZero `ann` tcon tNat) + [ branch cZero [] $ con cTrue + , branch cSucc [("n", Nothing)] $ con cFalse ] noannCase <- case_ - (con "Zero") - [ branch "Zero" [] $ con "True" - , branch "Succ" [("n", Nothing)] $ con "False" + (con cZero) + [ branch cZero [] $ con cTrue + , branch cSucc [("n", Nothing)] $ con cFalse ] - expect <- con "True" + expect <- con cTrue pure (annCase, noannCase, expect) in do - let s' = evalFullTest maxID defaultTypeDefs mempty 2 Syn s - t' = evalFullTest maxID defaultTypeDefs mempty 2 Syn t + let s' = evalFullTest maxID builtinTypes mempty 2 Syn s + t' = evalFullTest maxID builtinTypes mempty 2 Syn t distinctIDs s' s' <~==> Right expected distinctIDs t' @@ -244,30 +259,33 @@ unit_10 = unit_11 :: Assertion unit_11 = let ((globals, e, expected), maxID) = create $ do + 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 "Nat" `tfun` tcon "Bool" + let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy oddTy <- evenOddTy - isEven <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "True", branch "Succ" [("n", Nothing)] $ gvar "odd" `app` lvar "n"] - isOdd <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "False", branch "Succ" [("n", Nothing)] $ gvar "even" `app` lvar "n"] - let ty = tcon "Nat" `tfun` (tcon "Pair" `tapp` tcon "Bool" `tapp` tcon "Nat") + isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar oddName `app` lvar "n"] + isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar evenName `app` lvar "n"] + + let ty = tcon tNat `tfun` (tcon tPair `tapp` tcon tBool `tapp` tcon tNat) let expr1 = - let_ "x" (con "Zero") $ - lam "n" (con "MakePair" `aPP` tcon "Bool" `aPP` tcon "Nat" `app` (gvar "even" `app` lvar "n") `app` lvar "x") + let_ "x" (con cZero) $ + lam "n" (con cMakePair `aPP` tcon tBool `aPP` tcon tNat `app` (gvar evenName `app` lvar "n") `app` lvar "x") `ann` ty - expr <- expr1 `app` con "Zero" - let evenDef = DefAST $ ASTDef "even" isEven evenTy - let oddDef = DefAST $ ASTDef "odd" isOdd oddTy - let globs = [("even", evenDef), ("odd", oddDef)] + expr <- expr1 `app` con cZero + let evenDef = DefAST $ ASTDef evenName isEven evenTy + let oddDef = DefAST $ ASTDef oddName isOdd oddTy + let globs = [(evenName, evenDef), (oddName, oddDef)] expect <- - (con "MakePair" `aPP` tcon "Bool" `aPP` tcon "Nat" `app` con "True" `app` con "Zero") - `ann` (tcon "Pair" `tapp` tcon "Bool" `tapp` tcon "Nat") + (con cMakePair `aPP` tcon tBool `aPP` tcon tNat `app` con cTrue `app` con cZero) + `ann` (tcon tPair `tapp` tcon tBool `tapp` tcon tNat) pure (globs, expr, expect) in do - case evalFullTest maxID defaultTypeDefs (M.fromList globals) 10 Syn e of + case evalFullTest maxID builtinTypes (M.fromList globals) 10 Syn e of Left (TimedOut _) -> pure () x -> assertFailure $ show x - let s = evalFullTest maxID defaultTypeDefs (M.fromList globals) 20 Syn e + let s = evalFullTest maxID builtinTypes (M.fromList globals) 20 Syn e distinctIDs s s <~==> Right expected @@ -282,36 +300,36 @@ unit_12 = lam "x" $ case_ (lvar "x") - [ branch "Zero" [] $ con "True" - , branch "Succ" [("i", Nothing)] $ lvar "f" `app` lvar "i" + [ branch cZero [] $ con cTrue + , branch cSucc [("i", Nothing)] $ lvar "f" `app` lvar "i" ] - expr <- let_ "n" (con "Zero") $ letrec "f" f (tcon "Nat" `tfun` tcon "Bool") $ lvar "f" `app` lvar "n" - expect <- con "True" `ann` tcon "Bool" + expr <- let_ "n" (con cZero) $ letrec "f" f (tcon tNat `tfun` tcon tBool) $ lvar "f" `app` lvar "n" + expect <- con cTrue `ann` tcon tBool pure (expr, expect) in do - let s = evalFullTest maxID defaultTypeDefs mempty 15 Syn e + let s = evalFullTest maxID builtinTypes mempty 15 Syn e distinctIDs s s <~==> Right expected unit_13 :: Assertion unit_13 = let ((e, expected), maxID) = create $ do - expr <- (lam "x" (con "C" `app` lvar "x" `app` let_ "x" (con "True") (lvar "x") `app` lvar "x") `ann` (tcon "Nat" `tfun` tcon "Bool")) `app` con "Zero" - expect <- (con "C" `app` con "Zero" `app` con "True" `app` con "Zero") `ann` tcon "Bool" + 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 defaultTypeDefs mempty 15 Syn e + let s = evalFullTest maxID builtinTypes mempty 15 Syn e distinctIDs s s <~==> Right expected unit_14 :: Assertion unit_14 = let ((e, expected), maxID) = create $ do - expr <- (lam "x" (lam "x" $ lvar "x") `ann` (tcon "Bool" `tfun` (tcon "Nat" `tfun` tcon "Nat"))) `app` con "True" `app` con "Zero" - expect <- con "Zero" `ann` tcon "Nat" + expr <- (lam "x" (lam "x" $ lvar "x") `ann` (tcon tBool `tfun` (tcon tNat `tfun` tcon tNat))) `app` con cTrue `app` con cZero + expect <- con cZero `ann` tcon tNat pure (expr, expect) in do - let s = evalFullTest maxID defaultTypeDefs mempty 15 Syn e + let s = evalFullTest maxID builtinTypes mempty 15 Syn e distinctIDs s s <~==> Right expected @@ -328,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 "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" @@ -338,19 +356,19 @@ unit_15 = e5 <- lam y' $ c "y" y' pure (e0, [e0, e1, e2, e3, e4, e5], e5) in do - let si = map (\i -> evalFullTest maxID defaultTypeDefs mempty i Syn expr) [0 .. fromIntegral $ length steps - 1] + let si = map (\i -> evalFullTest maxID builtinTypes mempty i Syn expr) [0 .. fromIntegral $ length steps - 1] f s e = do distinctIDs s s <~==> Left (TimedOut e) zipWithM_ f si steps - let s = evalFullTest maxID defaultTypeDefs mempty (fromIntegral $ length steps) Syn expr + let s = evalFullTest maxID builtinTypes mempty (fromIntegral $ length steps) Syn expr distinctIDs s s <~==> Right expected unit_hole_ann_case :: Assertion unit_hole_ann_case = - let (tm, maxID) = create $ hole $ ann (case_ emptyHole []) (tcon "Bool") - in evalFullTest maxID defaultTypeDefs mempty 1 Chk tm @?= Right tm + let (tm, maxID) = create $ hole $ ann (case_ emptyHole []) (tcon tBool) + in evalFullTest maxID builtinTypes mempty 1 Chk tm @?= Right tm -- TODO: examples with holes @@ -361,14 +379,14 @@ unit_hole_ann_case = -- | Resuming evaluation is the same as running it for longer in the first place hprop_resume :: Property hprop_resume = withDiscards 2000 $ - propertyWT (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ - withGlobals testGlobals $ \fixedGlobs -> do - (dir, t, _, globs) <- genDirTmGlobs fixedGlobs - resumeTest globs dir t + propertyWT testModules $ do + (dir, t, _) <- genDirTm + resumeTest testModules dir t -- A helper for hprop_resume, and hprop_resume_regression -resumeTest :: Map GVarName Def -> Dir -> Expr -> PropertyT WT () -resumeTest globs dir t = do +resumeTest :: [Module] -> Dir -> Expr -> PropertyT WT () +resumeTest mods dir t = do + let globs = foldMap moduleDefsQualified mods tds <- asks typeDefs n <- forAllT $ Gen.integral $ Range.linear 2 1000 -- Arbitrary limit here -- NB: We need to run this first reduction in an isolated context @@ -397,7 +415,7 @@ resumeTest globs dir t = do -- the two reduction attempts in resumeTest should not interfere with each -- other's names, else we will get occasional failures in that property test. hprop_resume_regression :: Property -hprop_resume_regression = propertyWT (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do +hprop_resume_regression = propertyWT [] $ do -- This indeed requires fresh names when reducing (see unit_type_preservation_rename_LAM_regression) t <- lAM "a" (letrec "b" emptyHole (tvar "a") (lAM "a" emptyHole)) resumeTest mempty Chk t @@ -429,31 +447,31 @@ unit_type_preservation_rename_LAM_regression = hprop_type_preservation :: Property hprop_type_preservation = withTests 1000 $ withDiscards 2000 $ - propertyWT (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ - withGlobals testGlobals $ \fixedGlobs -> do - tds <- asks typeDefs - (dir, t, ty, globs) <- genDirTmGlobs fixedGlobs - let test msg e = do - s <- case e of - Left (TimedOut s') -> label (msg <> "TimedOut") >> pure s' - Right s' -> label (msg <> "NF") >> pure s' - if null [() | LetType{} <- universe s] - then do - annotateShow s - s' <- checkTest ty s - forgetIDs s === forgetIDs s' -- check no smart holes happened - else label (msg <> "skipped due to LetType") >> success - maxSteps <- forAllT $ Gen.integral $ Range.linear 1 1000 -- Arbitrary limit here - (steps, s) <- evalFullStepCount tds globs maxSteps dir t - -- s is often reduced to normal form - test "long " s - -- also test an intermediate point - if steps <= 1 - then label "generated a normal form" - else do - midSteps <- forAllT $ Gen.integral $ Range.linear 1 (steps - 1) - (_, s') <- evalFullStepCount tds globs midSteps dir t - test "mid " s' + propertyWT testModules $ do + let globs = foldMap moduleDefsQualified testModules + tds <- asks typeDefs + (dir, t, ty) <- genDirTm + let test msg e = do + s <- case e of + Left (TimedOut s') -> label (msg <> "TimedOut") >> pure s' + Right s' -> label (msg <> "NF") >> pure s' + if null [() | LetType{} <- universe s] + then do + annotateShow s + s' <- checkTest ty s + forgetIDs s === forgetIDs s' -- check no smart holes happened + else label (msg <> "skipped due to LetType") >> success + maxSteps <- forAllT $ Gen.integral $ Range.linear 1 1000 -- Arbitrary limit here + (steps, s) <- evalFullStepCount tds globs maxSteps dir t + -- s is often reduced to normal form + test "long " s + -- also test an intermediate point + if steps <= 1 + then label "generated a normal form" + else do + midSteps <- forAllT $ Gen.integral $ Range.linear 1 (steps - 1) + (_, s') <- evalFullStepCount tds globs midSteps dir t + test "mid " s' unit_prim_toUpper :: Assertion unit_prim_toUpper = @@ -485,31 +503,31 @@ hprop_prim_hex_nat = withTests 20 . property $ do then create . withPrimDefs $ \globals -> (,,) <$> case_ - ( gvar "natToHex" + ( gvar (primitiveGVar "natToHex") `app` ne ) [ branch - "Nothing" + cNothing [] - (con "Nothing") + (con cNothing) , branch - "Just" + cJust [("x", Nothing)] - ( gvar "hexToNat" + ( gvar (primitiveGVar "hexToNat") `app` lvar "x" ) ] - <*> (con "Just" `aPP` tcon "Nat") + <*> (con cJust `aPP` tcon tNat) `app` ne <*> pure (DefPrim <$> globals) else create . withPrimDefs $ \globals -> (,,) - <$> gvar "natToHex" + <$> gvar (primitiveGVar "natToHex") `app` ne - <*> con "Nothing" - `aPP` tcon "Char" + <*> con cNothing + `aPP` tcon tChar <*> pure (DefPrim <$> globals) - s = evalFullTest maxID defaultTypeDefs gs 7 Syn e + s = evalFullTest maxID builtinTypes gs 7 Syn e set _ids' 0 s === set _ids' 0 (Right r) unit_prim_char_eq_1 :: Assertion @@ -518,7 +536,7 @@ unit_prim_char_eq_1 = "eqChar" (char 'a') (char 'a') - (con "True") + (con cTrue) unit_prim_char_eq_2 :: Assertion unit_prim_char_eq_2 = @@ -526,14 +544,14 @@ unit_prim_char_eq_2 = "eqChar" (char 'a') (char 'A') - (con "False") + (con cFalse) unit_prim_char_partial :: Assertion unit_prim_char_partial = let ((e, gs), maxID) = create . withPrimDefs $ \globals -> (,) - <$> gvar "eqChar" + <$> gvar (primitiveGVar "eqChar") `app` char 'a' <*> pure (DefPrim <$> globals) s = evalFullTest maxID mempty gs 1 Syn e @@ -589,7 +607,7 @@ unit_prim_int_quotient = "Int.quotient" (int 7) (int 3) - (con "Just" `aPP` tcon "Int" `app` int 2) + (con cJust `aPP` tcon tInt `app` int 2) unit_prim_int_quotient_negative :: Assertion unit_prim_int_quotient_negative = @@ -597,7 +615,7 @@ unit_prim_int_quotient_negative = "Int.quotient" (int (-7)) (int 3) - (con "Just" `aPP` tcon "Int" `app` int (-3)) + (con cJust `aPP` tcon tInt `app` int (-3)) unit_prim_int_quotient_zero :: Assertion unit_prim_int_quotient_zero = @@ -605,7 +623,7 @@ unit_prim_int_quotient_zero = "Int.quotient" (int (-7)) (int 0) - (con "Nothing" `aPP` tcon "Int") + (con cNothing `aPP` tcon tInt) unit_prim_int_remainder :: Assertion unit_prim_int_remainder = @@ -613,7 +631,7 @@ unit_prim_int_remainder = "Int.remainder" (int 7) (int 3) - (con "Just" `aPP` tcon "Int" `app` int 1) + (con cJust `aPP` tcon tInt `app` int 1) unit_prim_int_remainder_negative_1 :: Assertion unit_prim_int_remainder_negative_1 = @@ -621,7 +639,7 @@ unit_prim_int_remainder_negative_1 = "Int.remainder" (int (-7)) (int (-3)) - (con "Just" `aPP` tcon "Int" `app` int (-1)) + (con cJust `aPP` tcon tInt `app` int (-1)) unit_prim_int_remainder_negative_2 :: Assertion unit_prim_int_remainder_negative_2 = @@ -629,7 +647,7 @@ unit_prim_int_remainder_negative_2 = "Int.remainder" (int (-7)) (int 3) - (con "Just" `aPP` tcon "Int" `app` int 2) + (con cJust `aPP` tcon tInt `app` int 2) unit_prim_int_remainder_negative_3 :: Assertion unit_prim_int_remainder_negative_3 = @@ -637,7 +655,7 @@ unit_prim_int_remainder_negative_3 = "Int.remainder" (int 7) (int (-3)) - (con "Just" `aPP` tcon "Int" `app` int (-2)) + (con cJust `aPP` tcon tInt `app` int (-2)) unit_prim_int_remainder_zero :: Assertion unit_prim_int_remainder_zero = @@ -645,7 +663,7 @@ unit_prim_int_remainder_zero = "Int.remainder" (int 7) (int 0) - (con "Nothing" `aPP` tcon "Int") + (con cNothing `aPP` tcon tInt) unit_prim_int_quot :: Assertion unit_prim_int_quot = @@ -828,14 +846,14 @@ unit_prim_int_toNat = unaryPrimTest "Int.toNat" (int 0) - (con "Just" `aPP` tcon "Nat" `app` nat 0) + (con cJust `aPP` tcon tNat `app` nat 0) unit_prim_int_toNat_negative :: Assertion unit_prim_int_toNat_negative = unaryPrimTest "Int.toNat" (int (-1)) - (con "Nothing" `aPP` tcon "Nat") + (con cNothing `aPP` tcon tNat) unit_prim_int_fromNat :: Assertion unit_prim_int_fromNat = @@ -849,13 +867,13 @@ unit_prim_ann = let ((e, r, gs), maxID) = create . withPrimDefs $ \globals -> (,,) - <$> ( gvar "toUpper" - `ann` (tcon "Char" `tfun` tcon "Char") + <$> ( gvar (primitiveGVar "toUpper") + `ann` (tcon tChar `tfun` tcon tChar) ) - `app` (char 'a' `ann` tcon "Char") + `app` (char 'a' `ann` tcon tChar) <*> char 'A' <*> pure (DefPrim <$> globals) - s = evalFullTest maxID defaultTypeDefs gs 2 Syn e + s = evalFullTest maxID builtinTypes gs 2 Syn e in do distinctIDs s s <~==> Right r @@ -867,48 +885,47 @@ unit_prim_partial_map = map_ <- mapDef (,,) <$> gvar (defName map_) - `aPP` tcon "Char" - `aPP` tcon "Char" - `app` gvar "toUpper" + `aPP` tcon tChar + `aPP` tcon tChar + `app` gvar (primitiveGVar "toUpper") `app` list_ - "Char" + tChar [ char 'a' , char 'b' , char 'c' ] <*> list_ - "Char" + tChar [ char 'A' , char 'B' , char 'C' ] - `ann` (tcon "List" `tapp` tcon "Char") + `ann` (tcon tList `tapp` tcon tChar) <*> pure (M.singleton (defName map_) map_ <> (DefPrim <$> globals)) - s = evalFullTest maxID defaultTypeDefs gs 65 Syn e + s = evalFullTest maxID builtinTypes gs 65 Syn e in do distinctIDs s s <~==> Right r where mapDef :: MonadFresh ID m => m Def mapDef = do - mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon "List" `tapp` tvar "a") `tfun` (tcon "List" `tapp` tvar "b")) + 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" $ case_ (lvar "xs") - [ branch "Nil" [] $ con "Nil" `aPP` tvar "b" - , branch "Cons" [("y", Nothing), ("ys", Nothing)] $ con "Cons" `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (lvar "go" `app` lvar "ys") + [ 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` (lvar "go" `app` lvar "ys") ] - map_ <- lAM "a" $ lAM "b" $ lam "f" $ letrec "go" worker ((tcon "List" `tapp` tvar "a") `tfun` (tcon "List" `tapp` tvar "b")) $ lvar "go" - pure $ DefAST $ ASTDef "map" map_ mapTy + 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 -- Test that handleEvalFullRequest will reduce imported terms unit_eval_full_modules :: Assertion unit_eval_full_modules = let test = do - p <- defaultFullProg - importModules [progModule p] - foo <- gvar "toUpper" `app` char 'a' + importModules [primitiveModule, builtinModule] + foo <- gvar (primitiveGVar "toUpper") `app` char 'a' resp <- handleEvalFullRequest EvalFullReq @@ -930,11 +947,11 @@ unit_eval_full_modules_scrutinize_imported_type :: Assertion unit_eval_full_modules_scrutinize_imported_type = let test = do importModules [m] - foo <- case_ (con "True") [branch "True" [] $ con "False", branch "False" [] $ con "True"] + foo <- case_ (con cTrue) [branch cTrue [] $ con cFalse, branch cFalse [] $ con cTrue] resp <- handleEvalFullRequest EvalFullReq{evalFullReqExpr = foo, evalFullCxtDir = Chk, evalFullMaxSteps = 2} - expect <- con "False" + expect <- con cFalse pure $ case resp of EvalFullRespTimedOut _ -> assertFailure "EvalFull timed out" EvalFullRespNormal e -> e ~= expect @@ -945,7 +962,8 @@ unit_eval_full_modules_scrutinize_imported_type = where m = Module - { moduleTypes = mkTypeDefMap [TypeDefAST boolDef] + { moduleName = qualifiedModule tBool + , moduleTypes = mkTypeDefMap [TypeDefAST boolDef] , moduleDefs = mempty } @@ -954,12 +972,12 @@ unit_eval_full_modules_scrutinize_imported_type = evalFullTest :: ID -> M.Map TyConName TypeDef -> M.Map GVarName Def -> TerminationBound -> Dir -> Expr -> Either EvalFullError Expr evalFullTest id_ tydefs globals n d e = evalTestM id_ $ evalFull tydefs globals n d e -unaryPrimTest :: GVarName -> S Expr -> S Expr -> Assertion +unaryPrimTest :: Name -> S Expr -> S Expr -> Assertion unaryPrimTest f x y = let ((e, r, gs), maxID) = create . withPrimDefs $ \globals -> (,,) - <$> gvar f + <$> gvar (primitiveGVar f) `app` x <*> y <*> pure (DefPrim <$> globals) @@ -967,12 +985,12 @@ unaryPrimTest f x y = in do distinctIDs s s <~==> Right r -binaryPrimTest :: GVarName -> S Expr -> S Expr -> S Expr -> Assertion +binaryPrimTest :: Name -> S Expr -> S Expr -> S Expr -> Assertion binaryPrimTest f x y z = let ((e, r, gs), maxID) = create . withPrimDefs $ \globals -> (,,) - <$> gvar f + <$> gvar (primitiveGVar f) `app` x `app` y <*> z @@ -986,20 +1004,13 @@ binaryPrimTest f x y z = -- -- * a term (to be the subject of some evaluation steps) -- --- * definitions for each global variable (to be the environment of the evaluation steps) --- -- Also returns -- -- * whether the term is synthesisable or checkable -- -- * the type of the term --- --- The first arg is "given" globals: in the "globals" return, we will --- return the corresponding ones in this list, if one exists. --- Thus you can specify a few particular terms you want in scope --- (e.g. primitives), and generate the rest. -genDirTmGlobs :: [Def] -> PropertyT WT (Dir, Expr, Type' (), M.Map GVarName Def) -genDirTmGlobs defs = do +genDirTm :: PropertyT WT (Dir, Expr, Type' ()) +genDirTm = do dir <- forAllT $ Gen.element [Chk, Syn] (t', ty) <- case dir of Chk -> do @@ -1008,35 +1019,29 @@ genDirTmGlobs defs = do pure (t', ty') Syn -> forAllT genSyn t <- generateIDs t' - globTypes <- asks globalCxt - let genDef n defTy = case find ((== n) . defName) defs of - Just d -> do - unless (forgetTypeIDs (defType d) == defTy) $ - -- This is a bug in the calling property. Bail out loudly! - error "genDirTmGlobs: given def had different type to expected from context" - pure d - Nothing -> - (\ty' e -> DefAST ASTDef{astDefName = n, astDefType = ty', astDefExpr = e}) - <$> generateTypeIDs defTy <*> (generateIDs =<< genChk defTy) - globs <- forAllT $ M.traverseWithKey genDef globTypes - pure (dir, t, ty, globs) - --- | Adds the global's types to the global context, and gives you access to the definitions, --- to e.g. pass to 'genDirTmGlobs' -withGlobals :: WT [Def] -> ([Def] -> PropertyT WT a) -> PropertyT WT a -withGlobals mdefs prop = do - defs <- lift mdefs - let cxtext = flip map defs $ \d -> (defName d, forgetTypeIDs $ defType d) - local (extendGlobalCxt cxtext) (prop defs) + pure (dir, t, ty) -- | Some generally-useful globals to have around when testing. --- Currently: an AST identity function on Char and a primitive @toUpper@. -testGlobals :: WT [Def] -testGlobals = do - idCharDef <- ASTDef <$> pure "idChar" <*> lam "x" (lvar "x") <*> (tcon "Char" `tfun` tcon "Char") - let toUpperFun = allPrimDefs ! "toUpper" - toUpperDef <- PrimDef <$> pure "toUpper" <*> primFunType toUpperFun - pure [DefAST idCharDef, DefPrim toUpperDef] +-- Currently: an AST identity function on Char and all builtins and +-- primitives +testModules :: [Module] +testModules = [builtinModule, primitiveModule, testModule] + +testModule :: Module +testModule = + let (ty, expr) = fst . create $ (,) <$> tcon tChar `tfun` tcon tChar <*> lam "x" (lvar "x") + in Module + { moduleName = "M" + , moduleTypes = mempty + , moduleDefs = + Map.singleton "idChar" $ + DefAST + ASTDef + { astDefName = gvn "M" "idChar" + , astDefType = ty + , astDefExpr = expr + } + } _ids :: Traversal' Expr ID _ids = (_exprMeta % _id) `adjoin` (_exprTypeMeta % _id) @@ -1063,3 +1068,6 @@ distinctIDs e = ] ) (nIds == nDistinct) + +builtinTypes :: Map TyConName TypeDef +builtinTypes = moduleTypesQualified builtinModule diff --git a/primer/test/Tests/FreeVars.hs b/primer/test/Tests/FreeVars.hs index 6f7782969..98e1a6de7 100644 --- a/primer/test/Tests/FreeVars.hs +++ b/primer/test/Tests/FreeVars.hs @@ -3,6 +3,7 @@ module Tests.FreeVars where import Foreword import qualified Data.Set as Set +import Primer.Builtins import Primer.Core (Kind (KType)) import Primer.Core.DSL import Primer.Core.Utils @@ -22,10 +23,10 @@ unit_2 = ( lam "x" $ case_ (lvar "x") - [ branch "Zero" [] $ con "True" - , branch "Succ" [("n", Nothing)] (app (lvar "f") (lvar "n")) + [ branch cZero [] $ con cTrue + , branch cSucc [("n", Nothing)] (app (lvar "f") (lvar "n")) ] ) (lvar "y") ) - (tforall "a" KType $ tcon "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/Gen/Core/Typed.hs b/primer/test/Tests/Gen/Core/Typed.hs index aae5eb88d..2ccdbf5b3 100644 --- a/primer/test/Tests/Gen/Core/Typed.hs +++ b/primer/test/Tests/Gen/Core/Typed.hs @@ -29,7 +29,7 @@ import Hedgehog ( (===), ) import Hedgehog.Internal.Property (forAllT) -import Primer.App (defaultTypeDefs) +import Primer.Builtins (builtinModule) import Primer.Core ( Expr, Kind (KType), @@ -43,12 +43,13 @@ import Primer.Core.Utils ( generateIDs, generateTypeIDs, ) +import Primer.Module (Module) +import Primer.Primitives (primitiveModule) import Primer.Typecheck ( Cxt (..), ExprT, SmartHoles (NoSmartHoles), TypeError, - buildTypingContext, check, checkKind, checkValidContext, @@ -75,15 +76,15 @@ inExtendedLocalCxt p = do annotateShow $ M.differenceWith (\l r -> if l == r then Nothing else Just l) (localCxt cxtE) (localCxt cxt) local (const cxtE) p -propertyWTInExtendedGlobalCxt :: Cxt -> PropertyT WT () -> Property -propertyWTInExtendedGlobalCxt cxt = propertyWT cxt . inExtendedGlobalCxt +propertyWTInExtendedGlobalCxt :: [Module] -> PropertyT WT () -> Property +propertyWTInExtendedGlobalCxt mods = propertyWT mods . inExtendedGlobalCxt -propertyWTInExtendedLocalGlobalCxt :: Cxt -> PropertyT WT () -> Property -propertyWTInExtendedLocalGlobalCxt cxt = propertyWT cxt . inExtendedLocalCxt . inExtendedGlobalCxt +propertyWTInExtendedLocalGlobalCxt :: [Module] -> PropertyT WT () -> Property +propertyWTInExtendedLocalGlobalCxt mods = propertyWT mods . inExtendedLocalCxt . inExtendedGlobalCxt hprop_genTy :: Property hprop_genTy = withTests 1000 $ - propertyWTInExtendedGlobalCxt (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do + propertyWTInExtendedGlobalCxt [builtinModule, primitiveModule] $ do k <- forAllT genWTKind ty <- forAllT $ genWTType k ty' <- checkKindTest k =<< generateTypeIDs ty @@ -116,7 +117,7 @@ checkValidContextTest t = do -- This indirectly also tests genCxtExtendingLocal, genCxtExtendingGlobal and genTypeDefGroup hprop_genCxtExtending_typechecks :: Property hprop_genCxtExtending_typechecks = withTests 1000 $ - propertyWT (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do + propertyWT [builtinModule, primitiveModule] $ do cxt <- forAllT genCxtExtendingGlobal checkValidContextTest cxt cxt' <- forAllT $ local (const cxt) genCxtExtendingLocal @@ -126,7 +127,7 @@ hprop_genCxtExtending_is_extension :: Property hprop_genCxtExtending_is_extension = withTests 1000 $ let cxt0 = initialCxt NoSmartHoles - in propertyWT cxt0 $ do + in propertyWT [] $ do cxt1 <- forAllT genCxtExtendingGlobal diff cxt0 extendsGlobal cxt1 cxt2 <- forAllT $ local (const cxt1) genCxtExtendingGlobal @@ -155,7 +156,7 @@ hprop_genCxtExtending_is_extension = hprop_genSyns :: Property hprop_genSyns = withTests 1000 $ withDiscards 2000 $ - propertyWTInExtendedLocalGlobalCxt (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do + propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tgtTy <- forAllT $ genWTType KType _ :: Type' (Meta Kind) <- checkKindTest KType =<< generateTypeIDs tgtTy (e, ty) <- forAllT $ genSyns tgtTy @@ -169,7 +170,7 @@ hprop_genSyns = withTests 1000 $ hprop_genChk :: Property hprop_genChk = withTests 1000 $ withDiscards 2000 $ - propertyWTInExtendedLocalGlobalCxt (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do + propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do ty <- forAllT $ genWTType KType _ :: Type' (Meta Kind) <- checkKindTest KType =<< generateTypeIDs ty t <- forAllT $ genChk ty diff --git a/primer/test/Tests/Primitives.hs b/primer/test/Tests/Primitives.hs index 4d72378fc..b26c99d80 100644 --- a/primer/test/Tests/Primitives.hs +++ b/primer/test/Tests/Primitives.hs @@ -8,7 +8,6 @@ import qualified Data.Map as M import Gen.Core.Typed (forAllT, genPrimCon, propertyWT) import Hedgehog (Property, assert) import Hedgehog.Gen (choice) -import Primer.App (defaultTypeDefs) import Primer.Core ( ASTTypeDef ( ASTTypeDef, @@ -22,22 +21,24 @@ import Primer.Core ( primConName, ) import Primer.Core.DSL (char, tcon) -import Primer.Primitives (allPrimTypeDefs) +import Primer.Primitives (allPrimTypeDefs, primitiveModule, tChar) import Primer.Typecheck ( SmartHoles (NoSmartHoles), TypeError (PrimitiveTypeNotInScope, UnknownTypeConstructor), buildTypingContext, + buildTypingContextFromModules, checkKind, checkValidContext, - mkTypeDefMap, + mkTypeDefMapQualified, synth, ) +import Primer.Builtins (builtinModule) import Test.Tasty.HUnit (Assertion, assertBool, (@?=)) -import Tests.Typecheck (runTypecheckTestMFromIn) +import Tests.Typecheck (runTypecheckTestMIn) hprop_all_prim_cons_have_typedef :: Property -hprop_all_prim_cons_have_typedef = propertyWT (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do +hprop_all_prim_cons_have_typedef = propertyWT [builtinModule, primitiveModule] $ do c <- forAllT $ (fmap fst . choice) =<< genPrimCon assert $ primConName c `elem` M.keys allPrimTypeDefs @@ -46,11 +47,11 @@ hprop_all_prim_cons_have_typedef = propertyWT (buildTypingContext defaultTypeDef unit_prim_con_scope :: Assertion unit_prim_con_scope = do -- Char is indeed not in scope - test (checkKind KType =<< tcon "Char") @?= Left (UnknownTypeConstructor "Char") - test (synth =<< char 'a') @?= Left (PrimitiveTypeNotInScope "Char") + test (checkKind KType =<< tcon tChar) @?= Left (UnknownTypeConstructor tChar) + test (synth =<< char 'a') @?= Left (PrimitiveTypeNotInScope tChar) where - cxt = buildTypingContext mempty mempty NoSmartHoles - test = runTypecheckTestMFromIn 0 cxt + cxt = buildTypingContextFromModules mempty NoSmartHoles + test = runTypecheckTestMIn cxt -- If we use a prim con, then we need the corresponding prim type -- in scope, and not some other type of that name @@ -61,17 +62,17 @@ unit_prim_con_scope_ast = do -- Char is in scope (though the wrong kind to accept 'PrimChar's!) assertBool "Char is not in scope?" $ isRight $ - test $ checkKind (KType `KFun` KType) =<< tcon "Char" - test (synth =<< char 'a') @?= Left (PrimitiveTypeNotInScope "Char") + test $ checkKind (KType `KFun` KType) =<< tcon tChar + test (synth =<< char 'a') @?= Left (PrimitiveTypeNotInScope tChar) where charASTDef = TypeDefAST $ ASTTypeDef - { astTypeDefName = "Char" + { astTypeDefName = tChar , astTypeDefParameters = [("a", KType)] , astTypeDefConstructors = mempty , astTypeDefNameHints = mempty } - cxt = buildTypingContext (mkTypeDefMap [charASTDef]) mempty NoSmartHoles - test = runTypecheckTestMFromIn 0 cxt + cxt = buildTypingContext (mkTypeDefMapQualified [charASTDef]) mempty NoSmartHoles + test = runTypecheckTestMIn cxt diff --git a/primer/test/Tests/Question.hs b/primer/test/Tests/Question.hs index 3ae4dda8d..124b93ad4 100644 --- a/primer/test/Tests/Question.hs +++ b/primer/test/Tests/Question.hs @@ -9,7 +9,7 @@ import Hedgehog hiding (check) import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Primer.App (defaultTypeDefs) +import Primer.Builtins import Primer.Core ( Expr, GVarName, @@ -36,7 +36,7 @@ import Primer.Questions ( import Primer.Typecheck ( Cxt, SmartHoles (NoSmartHoles), - buildTypingContext, + buildTypingContextFromModules, exprTtoExpr, synth, ) @@ -139,11 +139,13 @@ nameSTE' = \case genSTE' :: Gen [STE'] genSTE' = let g = Gen.either_ genKind $ (,) <$> fmap forgetTypeIDs genType <*> Gen.bool - toSTE' n = \case + toSTE' m n = \case Left k -> TyVar (LocalName n, k) Right (ty, False) -> TmVar (LocalName n, ty) - Right (ty, True) -> Global (qualifyName n, ty) - in evalExprGen 0 $ Gen.list (Range.linear 0 20) $ toSTE' <$> genName <*> g + 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"] genSTE :: Gen ShadowedVarsExpr genSTE = deal . nubBy ((==) `on` nameSTE') <$> genSTE' @@ -164,46 +166,46 @@ unit_variablesInScope_empty = -- Given a single lambda, we return just the variable it binds unit_variablesInScope_lambda :: Assertion unit_variablesInScope_lambda = do - let expr = ann (lam "x" emptyHole) (tfun (tcon "Bool") (tcon "Bool")) + let expr = ann (lam "x" emptyHole) (tfun (tcon tBool) (tcon tBool)) hasVariables expr pure [] hasVariables expr down [] - hasVariables expr (down >=> down) [("x", TCon () "Bool")] + hasVariables expr (down >=> down) [("x", TCon () tBool)] -- Given a let, its bound variable is in scope in the body but not the bound expression unit_variablesInScope_let :: Assertion unit_variablesInScope_let = do - let oneLet = let_ "x" (con "True") emptyHole - twoLet = let_ "x" (con "True") (let_ "y" (con "Zero") emptyHole) + let oneLet = let_ "x" (con cTrue) emptyHole + twoLet = let_ "x" (con cTrue) (let_ "y" (con cZero) emptyHole) hasVariables oneLet pure mempty hasVariables oneLet down mempty - hasVariables oneLet (down >=> right) [("x", TCon () "Bool")] + hasVariables oneLet (down >=> right) [("x", TCon () tBool)] hasVariables twoLet (down >=> right >=> down) - [("x", TCon () "Bool")] + [("x", TCon () tBool)] hasVariables twoLet (down >=> right >=> down >=> right) - [("x", TCon () "Bool"), ("y", TCon () "Nat")] + [("x", TCon () tBool), ("y", TCon () tNat)] -- Given a letrec, its bound variable is in scope in both the body and the bound expression unit_variablesInScope_letrec :: Assertion unit_variablesInScope_letrec = do - let expr = letrec "x" (con "True") (tcon "Bool") emptyHole + let expr = letrec "x" (con cTrue) (tcon tBool) emptyHole hasVariables expr pure [] - hasVariables expr down [("x", TCon () "Bool")] - hasVariables expr (down >=> right) [("x", TCon () "Bool")] + hasVariables expr down [("x", TCon () tBool)] + hasVariables expr (down >=> right) [("x", TCon () tBool)] -- Given a case expression, any variables bound by its branches are in scope in their corresponding -- LHS. unit_variablesInScope_case :: Assertion unit_variablesInScope_case = do - let expr = ann (case_ (con "Zero") [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole]) (tcon "Nat") + let expr = ann (case_ (con cZero) [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole]) (tcon tNat) hasVariables expr pure [] hasVariables expr down [] hasVariables expr (down >=> down) [] hasVariables expr (down >=> down >=> right) [] - hasVariables expr (down >=> down >=> right >=> right) [("n", TCon () "Nat")] + hasVariables expr (down >=> down >=> right >=> right) [("n", TCon () tNat)] unit_variablesInScope_type :: Assertion unit_variablesInScope_type = do @@ -216,8 +218,8 @@ unit_variablesInScope_type = do unit_variablesInScope_shadowed :: Assertion unit_variablesInScope_shadowed = do - let ty = tforall "a" (KFun KType KType) $ tforall "b" KType $ tcon "Nat" `tfun` tforall "a" KType (tcon "Bool" `tfun` (tcon "List" `tapp` tvar "b")) - expr' = lAM "c" $ lAM "d" $ lam "c" $ lAM "c" $ lam "c" $ con "Nil" `aPP` tvar "d" + let ty = tforall "a" (KFun KType KType) $ tforall "b" KType $ tcon tNat `tfun` tforall "a" KType (tcon tBool `tfun` (tcon tList `tapp` tvar "b")) + expr' = lAM "c" $ lAM "d" $ lam "c" $ lAM "c" $ lam "c" $ con cNil `aPP` tvar "d" expr = ann expr' ty hasVariablesType ty pure [] hasVariablesType ty down [("a", KFun KType KType)] @@ -227,9 +229,9 @@ unit_variablesInScope_shadowed = do hasVariablesTyTm expr pure [] [] hasVariablesTyTm expr (down >=> down) [("c", KFun KType KType)] [] hasVariablesTyTm expr (down >=> down >=> down) [("c", KFun KType KType), ("d", KType)] [] - hasVariablesTyTm expr (down >=> down >=> down >=> down) [("d", KType)] [("c", TCon () "Nat")] + hasVariablesTyTm expr (down >=> down >=> down >=> down) [("d", KType)] [("c", TCon () tNat)] hasVariablesTyTm expr (down >=> down >=> down >=> down >=> down) [("d", KType), ("c", KType)] [] - hasVariablesTyTm expr (down >=> down >=> down >=> down >=> down >=> down) [("d", KType)] [("c", TCon () "Bool")] + hasVariablesTyTm expr (down >=> down >=> down >=> down >=> down >=> down) [("d", KType)] [("c", TCon () tBool)] -- | Test that if we walk 'path' to some node in 'expr', that node will have -- 'expected' in-scope variables. @@ -269,12 +271,12 @@ unit_hasGeneratedNames_1 :: Assertion unit_hasGeneratedNames_1 = do hasGeneratedNamesExpr emptyHole Nothing pure ["x", "y", "z"] hasGeneratedNamesExpr emptyHole (Just $ tfun tEmptyHole tEmptyHole) pure ["f", "g", "h"] - hasGeneratedNamesExpr emptyHole (Just $ tcon "Nat") pure ["i", "j", "m", "n"] - hasGeneratedNamesExpr emptyHole (Just $ tcon "List" `tapp` tcon "Nat") pure ["xs", "ys", "zs"] + hasGeneratedNamesExpr emptyHole (Just $ tcon tNat) pure ["i", "j", "m", "n"] + hasGeneratedNamesExpr emptyHole (Just $ tcon tList `tapp` tcon tNat) pure ["xs", "ys", "zs"] let expr = lam "x" $ lam "i" emptyHole hasGeneratedNamesExpr expr Nothing pure ["y", "z", "x1"] - hasGeneratedNamesExpr expr (Just $ tcon "Nat") pure ["j", "m", "n", "i1"] - hasGeneratedNamesExpr expr (Just $ tcon "List" `tapp` tcon "Nat") pure ["xs", "ys", "zs"] + hasGeneratedNamesExpr expr (Just $ tcon tNat) pure ["j", "m", "n", "i1"] + hasGeneratedNamesExpr expr (Just $ tcon tList `tapp` tcon tNat) pure ["xs", "ys", "zs"] -- test type-level names unit_hasGeneratedNames_2 :: Assertion @@ -297,7 +299,7 @@ unit_hasGeneratedNames_3 = do hasGeneratedNamesExpr expr Nothing (down >=> down >=> right) ["z", "x1", "y1"] defCxt :: Cxt -defCxt = buildTypingContext defaultTypeDefs mempty NoSmartHoles +defCxt = buildTypingContextFromModules [builtinModule] NoSmartHoles hasGeneratedNamesExpr :: S Expr -> Maybe (S Type) -> (ExprZ -> Maybe ExprZ) -> [Name] -> Assertion hasGeneratedNamesExpr expr ty path expected = do diff --git a/primer/test/Tests/Refine.hs b/primer/test/Tests/Refine.hs index 5240c1abd..4702be4ff 100644 --- a/primer/test/Tests/Refine.hs +++ b/primer/test/Tests/Refine.hs @@ -26,7 +26,7 @@ import Hedgehog ( ) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Primer.App (defaultTypeDefs) +import Primer.Builtins (builtinModule, tBool, tList, tNat) import Primer.Core ( Expr' (APP, Ann, App, EmptyHole), ID, @@ -40,13 +40,14 @@ import Primer.Core ( ) import Primer.Core.Utils (forgetIDs, freeVarsTy, generateIDs, noHoles) import Primer.Name (NameCounter) +import Primer.Primitives (primitiveModule) import Primer.Refine (Inst (InstAPP, InstApp, InstUnconstrainedAPP), refine) import Primer.Subst (substTy, substTys) import Primer.Typecheck ( Cxt, SmartHoles (NoSmartHoles), Type, - buildTypingContext, + buildTypingContextFromModules, consistentTypes, extendLocalCxtTy, typeDefs, @@ -56,7 +57,7 @@ import TestM (evalTestM) import Tests.Gen.Core.Typed (propertyWTInExtendedLocalGlobalCxt, synthTest) defaultCxt :: Cxt -defaultCxt = buildTypingContext defaultTypeDefs mempty NoSmartHoles +defaultCxt = buildTypingContextFromModules [builtinModule, primitiveModule] NoSmartHoles refine' :: (MonadFresh NameCounter m, MonadFresh ID m) => Cxt -> Type -> Type -> m (Maybe ([Inst], Type)) refine' cxt s t = fmap (either crash identity) $ runExceptT $ refine cxt s t @@ -83,10 +84,10 @@ unit_con_refl = 0 ( refine' defaultCxt - (TCon () "Nat") - (TCon () "Nat") + (TCon () tNat) + (TCon () tNat) ) - @?= Just ([], TCon () "Nat") + @?= Just ([], TCon () tNat) -- refine [...] Nat Bool fails unit_distinct_con :: Assertion @@ -95,8 +96,8 @@ unit_distinct_con = 0 ( refine' defaultCxt - (TCon () "Nat") - (TCon () "Bool") + (TCon () tNat) + (TCon () tBool) ) @?= Nothing @@ -107,10 +108,10 @@ unit_instApp = 0 ( refine' defaultCxt - (TCon () "Nat") - (TFun () (TCon () "Bool") (TCon () "Nat")) + (TCon () tNat) + (TFun () (TCon () tBool) (TCon () tNat)) ) - @?= Just ([InstApp $ TCon () "Bool"], TCon () "Nat") + @?= Just ([InstApp $ TCon () tBool], TCon () tNat) -- refine [...] Nat (∀a.Nat) succeeds: have an unconstraind APP to do unit_instUnconstrainedAPP :: Assertion @@ -120,10 +121,10 @@ unit_instUnconstrainedAPP = 0 ( refine' defaultCxt - (TCon () "Nat") - (TForall () "a" KType (TCon () "Nat")) + (TCon () tNat) + (TForall () "a" KType (TCon () tNat)) ) - @?= Just ([InstUnconstrainedAPP "a1" KType], TCon () "Nat") + @?= Just ([InstUnconstrainedAPP "a1" KType], TCon () tNat) -- refine [...] Nat (∀a.a) succeeds: have an APP Nat to do unit_instAPP :: Assertion @@ -132,10 +133,10 @@ unit_instAPP = 0 ( refine' defaultCxt - (TCon () "Nat") + (TCon () tNat) (TForall () "a" KType (TVar () "a")) ) - @?= Just ([InstAPP $ TCon () "Nat"], TCon () "Nat") + @?= Just ([InstAPP $ TCon () tNat], TCon () tNat) -- refine [...] Nat (∀a.List a) fails unit_forall_fail :: Assertion @@ -144,8 +145,8 @@ unit_forall_fail = 0 ( refine' defaultCxt - (TCon () "Nat") - (TForall () "a" KType $ TApp () (TCon () "List") (TVar () "a")) + (TCon () tNat) + (TForall () "a" KType $ TApp () (TCon () tList) (TVar () "a")) ) @?= Nothing @@ -156,7 +157,7 @@ unit_ill_kinded_fail = 0 ( refine' defaultCxt - (TCon () "Nat") + (TCon () tNat) (TForall () "a" (KFun KType KType) $ TVar () "a") ) @?= Nothing @@ -168,20 +169,20 @@ unit_ill_kinded_fail_2 = 0 ( refine' defaultCxt - (TApp () (TEmptyHole ()) (TCon () "List")) - (TForall () "a" KType $ TApp () (TCon () "List") (TVar () "a")) + (TApp () (TEmptyHole ()) (TCon () tList)) + (TForall () "a" KType $ TApp () (TCon () tList) (TVar () "a")) ) @?= Nothing -- refine [...] (∀a. List a) (∀b. List b) succeeds, trivially unit_alpha :: Assertion unit_alpha = - let t n = (TForall () n KType $ TApp () (TCon () "List") (TVar () n)) + let t n = (TForall () n KType $ TApp () (TCon () tList) (TVar () n)) in evalTestM 0 (refine' defaultCxt (t "a") (t "b")) @?= Just ([], t "b") -- refine cxt T T succeeds hprop_refl :: Property -hprop_refl = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_refl = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do k <- forAllT genWTKind ty <- forAllT $ genWTType k cxt <- ask @@ -190,7 +191,7 @@ hprop_refl = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- refine _ ? S succeeds hprop_tgt_hole :: Property -hprop_tgt_hole = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_tgt_hole = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do k <- forAllT genWTKind tgt <- forAllT $ Gen.choice [pure $ TEmptyHole (), THole () <$> genWTType k] src <- forAllT $ genWTType k @@ -200,7 +201,7 @@ hprop_tgt_hole = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- refine _ T ? succeeds hprop_src_hole :: Property -hprop_src_hole = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_src_hole = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do k <- forAllT genWTKind tgt <- forAllT $ genWTType k src <- forAllT $ Gen.choice [pure $ TEmptyHole (), THole () <$> genWTType k] @@ -210,9 +211,10 @@ hprop_src_hole = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- constructor types refine to their fully-applied typedef hprop_con :: Property -hprop_con = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_con = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tcs <- asks $ mapMaybe typeDefAST . M.elems . typeDefs - -- NB: this only works because defaultCxt has at least one tydef with a constructor + -- NB: this only works because our context has at least one tydef with a constructor + -- (because, among others, it includes builtinModule that contains Bool) td <- forAllT $ Gen.element tcs let cons = astTypeDefConstructors td when (null cons) discard @@ -231,7 +233,7 @@ hprop_con = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- refine cxt T S succeds when S is built from T, S1 -> _, ∀a._ -- The success may not instantiate as much as one would expect, if T has holes in hprop_arr_app :: Property -hprop_arr_app = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_arr_app = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tgt <- forAllT $ genWTType KType when (isHole tgt) discard src' <- forAllT $ Gen.list (Range.linear 0 10) $ Gen.choice [Left <$> genWTType KType, curry Right <$> freshTyVarNameForCxt <*> genWTKind] @@ -256,7 +258,7 @@ hprop_arr_app = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- if refine _ T S = Just (I:IS,_) , then refine _ T (S $ I) = Just (IS,_); here "S $ I" means "inspect S, I assert they match and strip off a layer" hprop_matches :: Property hprop_matches = withDiscards 2000 $ - propertyWTInExtendedLocalGlobalCxt defaultCxt $ do + propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tgt <- forAllT $ genWTType KType src <- forAllT $ genWTType KType cxt <- ask @@ -280,7 +282,7 @@ hprop_matches = withDiscards 2000 $ -- if refine cxt tgt s = Just (is,ty) => (? : s) $ ∈ ty[instantiation vars substituted appropriately] ~ tgt hprop_refinement_synths :: Property -hprop_refinement_synths = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_refinement_synths = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tgt <- forAllT $ genWTType KType src <- forAllT $ genWTType KType cxt <- ask @@ -304,7 +306,7 @@ hprop_refinement_synths = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- | (Because unif vars are only in one side) the names from -- 'InstUnconstrainedAPP' do not appear in 'InstAPP's (but can in 'InstApp's) hprop_scoping :: Property -hprop_scoping = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_scoping = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tgt <- forAllT $ genWTType KType src <- forAllT $ genWTType KType cxt <- ask diff --git a/primer/test/Tests/Serialization.hs b/primer/test/Tests/Serialization.hs index 2a71f8145..7ea85d7ca 100644 --- a/primer/test/Tests/Serialization.hs +++ b/primer/test/Tests/Serialization.hs @@ -24,6 +24,7 @@ import Primer.App ( ProgError (NoDefSelected), Selection (..), ) +import Primer.Builtins (tNat) import Primer.Core ( ASTDef (..), ASTTypeDef (..), @@ -31,6 +32,7 @@ import Primer.Core ( Expr, Expr' (EmptyHole, PrimCon), ExprMeta, + GlobalName (baseName), ID (..), Kind (KFun, KType), Meta (..), @@ -42,13 +44,14 @@ import Primer.Core ( TypeMeta, ValCon (..), ) -import Primer.Module (Module (Module, moduleDefs, moduleTypes)) +import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap, moduleName) import Primer.Name (unsafeMkName) -import Primer.Typecheck (SmartHoles (SmartHoles), mkTypeDefMap) +import Primer.Typecheck (SmartHoles (SmartHoles)) import System.FilePath (takeBaseName) import Test.Tasty import Test.Tasty.Golden import Test.Tasty.HUnit +import TestUtils (gvn, tcn, vcn) -- | Check that encoding the value produces the file. test_encode :: TestTree @@ -93,27 +96,28 @@ fixtures = log :: Log log = Log [[BodyAction [Move Child1]]] def :: ASTDef - def = ASTDef{astDefName = "main", astDefExpr = expr, astDefType = TEmptyHole typeMeta} + def = ASTDef{astDefName = gvn "M" "main", astDefExpr = expr, astDefType = TEmptyHole typeMeta} typeDef :: TypeDef typeDef = TypeDefAST ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "M" "T" , astTypeDefParameters = [("a", KType), ("b", KFun KType KType)] - , astTypeDefConstructors = [ValCon "C" [TApp () (TVar () "b") (TVar () "a"), TCon () "Nat"]] + , astTypeDefConstructors = [ValCon (vcn "M" "C") [TApp () (TVar () "b") (TVar () "a"), TCon () tNat]] , astTypeDefNameHints = [] } progerror :: ProgError progerror = NoDefSelected progaction :: ProgAction - progaction = MoveToDef "main" + progaction = MoveToDef $ gvn "M" "main" prog = Prog { progImports = mempty , progModule = Module - { moduleTypes = mkTypeDefMap [typeDef] - , moduleDefs = Map.singleton (astDefName def) (DefAST def) + { moduleName = "M" + , moduleTypes = mkTypeDefMap [typeDef] + , moduleDefs = Map.singleton (baseName $ astDefName def) (DefAST def) } , progSelection = Just selection , progSmartHoles = SmartHoles diff --git a/primer/test/Tests/Subst.hs b/primer/test/Tests/Subst.hs index 166c8ee8e..3695fca39 100644 --- a/primer/test/Tests/Subst.hs +++ b/primer/test/Tests/Subst.hs @@ -3,6 +3,7 @@ module Tests.Subst where import Foreword import Optics (set) +import Primer.Builtins (tBool, tList) import Primer.Core ( Kind (KType), TyVarName, @@ -16,10 +17,10 @@ import TestM (evalTestM) unit_1 :: Assertion unit_1 = - create' (tcon "Bool") + create' (tcon tBool) @=? substTy' "a" - (create' $ tcon "Bool") + (create' $ tcon tBool) (create' $ tvar "a") unit_2 :: Assertion @@ -27,16 +28,16 @@ unit_2 = create' (tforall "a" KType $ tvar "a") @=? substTy' "a" - (create' $ tcon "Bool") + (create' $ tcon tBool) (create' $ tforall "a" KType $ tvar "a") unit_3 :: Assertion unit_3 = - create' (tforall "b" KType $ tcon "List" `tapp` tcon "Bool") + create' (tforall "b" KType $ tcon tList `tapp` tcon tBool) @=? substTy' "a" - (create' $ tcon "Bool") - (create' $ tforall "b" KType $ tcon "List" `tapp` tvar "a") + (create' $ tcon tBool) + (create' $ tforall "b" KType $ tcon tList `tapp` tvar "a") create' :: S (Type' a) -> Type' () create' = set _typeMeta () . fst . create diff --git a/primer/test/Tests/Transform.hs b/primer/test/Tests/Transform.hs index ebab82dc8..506a51e2a 100644 --- a/primer/test/Tests/Transform.hs +++ b/primer/test/Tests/Transform.hs @@ -3,10 +3,12 @@ module Tests.Transform where import Foreword import Optics (over, view) +import Primer.Builtins import Primer.Core import Primer.Core.DSL import Primer.Core.Transform import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) +import TestUtils (vcn) -- When renaming we have to be careful of binding sites. If we're renaming x to -- y and we encounter a binding site for a new variable v, then there are three @@ -77,15 +79,15 @@ unit_case_1 = "y" ( case_ (lvar "x") - [ branch "A" [("t", Nothing), ("u", Nothing)] (lvar "x") - , branch "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 "A" [("t", Nothing), ("u", Nothing)] (lvar "y") - , branch "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") ] ) ) @@ -98,8 +100,8 @@ unit_case_2 = "y" ( case_ (lvar "x") - [ branch "A" [("t", Nothing), ("u", Nothing)] (lvar "x") - , branch "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 @@ -113,15 +115,15 @@ unit_case_3 = "y" ( case_ (lvar "x") - [ branch "A" [("t", Nothing), ("u", Nothing)] (lvar "x") - , branch "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 "A" [("t", Nothing), ("u", Nothing)] (lvar "y") - , branch "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") ] ) ) @@ -145,7 +147,7 @@ unit_app :: Assertion unit_app = afterRename "x" "y" (app (lvar "x") (lvar "x")) (Just (app (lvar "y") (lvar "y"))) unit_con :: Assertion -unit_con = afterRename "x" "y" (con "True") (Just (con "True")) +unit_con = afterRename "x" "y" (con cTrue) (Just (con cTrue)) unit_case :: Assertion unit_case = @@ -154,8 +156,8 @@ unit_case = "y" ( case_ (lvar "x") - [ branch "A" [("y", Nothing), ("z", Nothing)] (lvar "y") - , branch "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 @@ -187,7 +189,7 @@ unit_tEmptyHole :: Assertion unit_tEmptyHole = afterRenameTy "x" "y" tEmptyHole (Just tEmptyHole) unit_tcon :: Assertion -unit_tcon = afterRenameTy "x" "y" (tcon "Bool") (Just $ tcon "Bool") +unit_tcon = afterRenameTy "x" "y" (tcon tBool) (Just $ tcon tBool) unit_tfun :: Assertion unit_tfun = afterRenameTy "x" "y" (tfun (tvar "x") (tvar "x")) (Just $ tfun (tvar "y") (tvar "y")) @@ -252,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 () "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 () "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 () "C" - in unfoldApp expr @?= (Con () "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 c5c1a6807..7fd5b1dfb 100644 --- a/primer/test/Tests/Typecheck.hs +++ b/primer/test/Tests/Typecheck.hs @@ -22,15 +22,29 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Optics (over, set) import Primer.App ( - Prog (progImports), + Prog, + newEmptyProg, + newProg, + progAllModules, + progModule, + ) +import Primer.Builtins ( boolDef, - defaultTypeDefs, + builtinModule, + cCons, + cFalse, + cNil, + cSucc, + cTrue, + cZero, eitherDef, listDef, natDef, - newEmptyProg, - newProg, - progModule, + tBool, + tEither, + tList, + tMaybe, + tNat, ) import Primer.Core ( ASTTypeDef (..), @@ -61,28 +75,28 @@ import Primer.Core.DSL import Primer.Core.Utils (generateIDs, generateTypeIDs) import Primer.Module import Primer.Name (NameCounter) +import Primer.Primitives (primitiveGVar, primitiveModule, tChar) import Primer.Typecheck ( CheckEverythingRequest (CheckEverything, toCheck, trusted), Cxt, ExprT, SmartHoles (NoSmartHoles, SmartHoles), TypeError (..), - buildTypingContext, + buildTypingContextFromModules, checkEverything, decomposeTAppCon, mkTAppCon, - mkTypeDefMap, synth, synthKind, ) import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) import TestM (TestM, evalTestM) -import TestUtils (withPrimDefs) +import TestUtils (gvn, tcn, vcn) import Tests.Gen.Core.Typed unit_identity :: Assertion unit_identity = - expectTyped $ ann (lam "x" (lvar "x")) (tfun (tcon "Bool") (tcon "Bool")) + expectTyped $ ann (lam "x" (lvar "x")) (tfun (tcon tBool) (tcon tBool)) unit_undefined_variable :: Assertion unit_undefined_variable = @@ -93,21 +107,23 @@ unit_const = expectTyped $ ann (lam "x" (lam "y" (lvar "x"))) - (tfun (tcon "Bool") (tfun (tcon "Bool") (tcon "Bool"))) + (tfun (tcon tBool) (tfun (tcon tBool) (tcon tBool))) unit_true :: Assertion -unit_true = expectTyped $ con "True" +unit_true = expectTyped $ con cTrue unit_constructor_doesn't_exist :: Assertion unit_constructor_doesn't_exist = - con "Nope" `expectFailsWith` const (UnknownConstructor "Nope") + con nope `expectFailsWith` const (UnknownConstructor nope) + where + nope = vcn "M" "Nope" unit_inc :: Assertion unit_inc = expectTyped $ ann - (lam "n" (app (con "Succ") (lvar "n"))) - (tfun (tcon "Nat") (tcon "Nat")) + (lam "n" (app (con cSucc) (lvar "n"))) + (tfun (tcon tNat) (tcon tNat)) unit_compose_nat :: Assertion unit_compose_nat = @@ -115,17 +131,17 @@ unit_compose_nat = ann (lam "f" (lam "g" (app (lvar "f") (hole (lvar "g"))))) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) - (tcon "Nat") + (tfun (tcon tNat) (tcon tNat)) + (tcon tNat) ) ) -- let x = True in x unit_let :: Assertion unit_let = - expectTyped $ let_ "x" (con "True") (lvar "x") + expectTyped $ let_ "x" (con cTrue) (lvar "x") -- Normal lets do not permit recursion unit_recursive_let :: Assertion @@ -137,7 +153,7 @@ unit_recursive_let = unit_letrec_1 :: Assertion unit_letrec_1 = expectTyped $ - letrec "x" (lvar "x") (tcon "Bool") (lvar "x") + letrec "x" (lvar "x") (tcon tBool) (lvar "x") -- let double : Nat -> Nat -- double = \x -> case x of @@ -153,26 +169,26 @@ unit_letrec_2 = "x" ( case_ (lvar "x") - [ branch "Zero" [] (con "Zero") + [ branch cZero [] (con cZero) , branch - "Succ" + cSucc [("n", Nothing)] ( app - (con "Succ") - (app (con "Succ") (app (lvar "double") (lvar "n"))) + (con cSucc) + (app (con cSucc) (app (lvar "double") (lvar "n"))) ) ] ) ) - (tfun (tcon "Nat") (tcon "Nat")) - (app (lvar "double") (app (con "Succ") (con "Zero"))) + (tfun (tcon tNat) (tcon tNat)) + (app (lvar "double") (app (con cSucc) (con cZero))) -- let x = True -- in let y = False -- in x unit_nested_let :: Assertion unit_nested_let = - expectTyped $ let_ "x" (con "True") (let_ "y" (con "False") (lvar "x")) + expectTyped $ let_ "x" (con cTrue) (let_ "y" (con cFalse) (lvar "x")) -- let yes = \x -> True : Bool -> Bool -- in let y = False @@ -182,8 +198,8 @@ unit_let_function = expectTyped $ let_ "yes" - (ann (lam "x" (con "True")) (tfun (tcon "Bool") (tcon "Bool"))) - (let_ "y" (con "False") (app (lvar "yes") (lvar "y"))) + (ann (lam "x" (con cTrue)) (tfun (tcon tBool) (tcon tBool))) + (let_ "y" (con cFalse) (app (lvar "yes") (lvar "y"))) -- (\f -> f : (Bool -> Bool) -> (Bool -> Bool)) (let y = True in \x -> y) unit_let_in_arg :: Assertion @@ -192,15 +208,19 @@ unit_let_in_arg = app ( ann (lam "f" (lvar "f")) - (tfun (tfun (tcon "Bool") (tcon "Bool")) (tfun (tcon "Bool") (tcon "Bool"))) + (tfun (tfun (tcon tBool) (tcon tBool)) (tfun (tcon tBool) (tcon tBool))) ) - (let_ "y" (con "True") (lam "x" (lvar "y"))) + (let_ "y" (con cTrue) (lam "x" (lvar "y"))) unit_mkTAppCon :: Assertion unit_mkTAppCon = do - mkTAppCon "C" [] @?= TCon () "C" - mkTAppCon "C" [TCon () "X"] @?= TApp () (TCon () "C") (TCon () "X") - mkTAppCon "C" [TCon () "X", TCon () "Y"] @?= TApp () (TApp () (TCon () "C") (TCon () "X")) (TCon () "Y") + mkTAppCon c [] @?= TCon () c + 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" -- Note [cover] -- We disable coverage checking as it causes spurious hydra failures which are @@ -236,21 +256,21 @@ unit_typeDefKind = do unit_valConType :: Assertion unit_valConType = do - f boolDef @?= [TCon () "Bool", TCon () "Bool"] - f natDef @?= [TCon () "Nat", TFun () (TCon () "Nat") (TCon () "Nat")] + f boolDef @?= [TCon () tBool, TCon () tBool] + f natDef @?= [TCon () tNat, TFun () (TCon () tNat) (TCon () tNat)] f listDef - @?= [ TForall () "a" KType (TApp () (TCon () "List") (TVar () "a")) - , TForall () "a" KType $ TFun () (TVar () "a") $ TFun () (TApp () (TCon () "List") (TVar () "a")) $ TApp () (TCon () "List") (TVar () "a") + @?= [ TForall () "a" KType (TApp () (TCon () tList) (TVar () "a")) + , TForall () "a" KType $ TFun () (TVar () "a") $ TFun () (TApp () (TCon () tList) (TVar () "a")) $ TApp () (TCon () tList) (TVar () "a") ] f eitherDef @?= [ TForall () "a" KType $ TForall () "b" KType $ TFun () (TVar () "a") $ - TApp () (TApp () (TCon () "Either") (TVar () "a")) (TVar () "b") + TApp () (TApp () (TCon () tEither) (TVar () "a")) (TVar () "b") , TForall () "a" KType $ TForall () "b" KType $ TFun () (TVar () "b") $ - TApp () (TApp () (TCon () "Either") (TVar () "a")) (TVar () "b") + TApp () (TApp () (TCon () tEither) (TVar () "a")) (TVar () "b") ] where f t = map (valConType t) (astTypeDefConstructors t) @@ -259,34 +279,36 @@ unit_valConType = do unit_case_isZero :: Assertion unit_case_isZero = expectTyped $ - ann (lam "x" $ case_ (lvar "x") [branch "Zero" [] (con "True"), branch "Succ" [("n", Nothing)] (con "False")]) (tfun (tcon "Nat") (tcon "Bool")) + ann (lam "x" $ case_ (lvar "x") [branch cZero [] (con cTrue), branch cSucc [("n", Nothing)] (con cFalse)]) (tfun (tcon tNat) (tcon tBool)) -- Nat -> Bool rejects \x . case x of {} unit_case_badEmpty :: Assertion unit_case_badEmpty = - ann (lam "x" $ case_ (lvar "x") []) (tfun (tcon "Nat") (tcon "Bool")) - `expectFailsWith` const (WrongCaseBranches "Nat" []) + ann (lam "x" $ case_ (lvar "x") []) (tfun (tcon tNat) (tcon tBool)) + `expectFailsWith` const (WrongCaseBranches tNat []) -- Cannot case on a Nat -> Nat unit_case_badType :: Assertion unit_case_badType = - ann (lam "x" $ case_ (lvar "x") []) (tfun (tfun (tcon "Nat") (tcon "Nat")) (tcon "Bool")) - `expectFailsWith` const (CannotCaseNonADT $ TFun () (TCon () "Nat") (TCon () "Nat")) + ann (lam "x" $ case_ (lvar "x") []) (tfun (tfun (tcon tNat) (tcon tNat)) (tcon tBool)) + `expectFailsWith` const (CannotCaseNonADT $ TFun () (TCon () tNat) (TCon () tNat)) -- Cannot annotate something with a non-existent type constructor unit_ann_bad :: Assertion unit_ann_bad = - ann emptyHole (tcon "IDoNotExist") `expectFailsWith` const (UnknownTypeConstructor "IDoNotExist") + ann emptyHole (tcon nonexistant) `expectFailsWith` const (UnknownTypeConstructor nonexistant) + where + nonexistant = tcn "M" "IDoNotExist" unit_ann_insert :: Assertion unit_ann_insert = - app (lam "x" $ lvar "x") (con "Zero") - `smartSynthGives` app (ann (lam "x" $ lvar "x") tEmptyHole) (con "Zero") + app (lam "x" $ lvar "x") (con cZero) + `smartSynthGives` app (ann (lam "x" $ lvar "x") tEmptyHole) (con cZero) unit_app_not_arrow :: Assertion unit_app_not_arrow = - app (con "Zero") (con "Zero") - `smartSynthGives` app (hole (con "Zero")) (con "Zero") + app (con cZero) (con cZero) + `smartSynthGives` app (hole (con cZero)) (con cZero) -- Note: there is something odd with this test, related to -- annotations-changing-types/chk-annotations I think the correct thing to give @@ -295,28 +317,28 @@ unit_app_not_arrow = -- The smartTC currently gives an annotation inside a hole. unit_chk_lam_not_arrow :: Assertion unit_chk_lam_not_arrow = - app (con "Succ") (lam "x" $ lvar "x") - `smartSynthGives` app (con "Succ") (hole $ ann (lam "x" $ lvar "x") tEmptyHole) + app (con cSucc) (lam "x" $ lvar "x") + `smartSynthGives` app (con cSucc) (hole $ ann (lam "x" $ lvar "x") tEmptyHole) unit_check_emb :: Assertion unit_check_emb = - app (con "Succ") (con "True") - `smartSynthGives` app (con "Succ") (hole $ con "True") + app (con cSucc) (con cTrue) + `smartSynthGives` app (con cSucc) (hole $ con cTrue) unit_case_scrutinee :: Assertion unit_case_scrutinee = - ann (case_ (con "Succ") [branch "C" [] $ lvar "x"]) (tcon "Bool") - `smartSynthGives` ann (case_ (hole $ con "Succ") []) (tcon "Bool") + 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 "Zero") [branch "C" [] $ lvar "x"]) (tcon "Bool") - `smartSynthGives` ann (case_ (con "Zero") [branch "Zero" [] emptyHole, branch "Succ" [("a7", Nothing)] emptyHole]) (tcon "Bool") -- Fragile name here "a7" + 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 unit_remove_hole = - ann (lam "x" $ hole (lvar "x")) (tfun (tcon "Nat") (tcon "Nat")) - `smartSynthGives` ann (lam "x" $ lvar "x") (tfun (tcon "Nat") (tcon "Nat")) + ann (lam "x" $ hole (lvar "x")) (tfun (tcon tNat) (tcon tNat)) + `smartSynthGives` ann (lam "x" $ lvar "x") (tfun (tcon tNat) (tcon tNat)) -- It is not clear how to (efficiently) remove the hole in -- {? Succ ?} Zero @@ -326,9 +348,9 @@ unit_remove_hole = -- This is tracked as https://github.com/hackworthltd/primer/issues/7 unit_remove_hole_not_perfect :: Assertion unit_remove_hole_not_perfect = - app (hole (con "Succ")) (con "Zero") - `smartSynthGives` app (hole (con "Succ")) (con "Zero") -- We currently give this as output - -- app (con "Succ") (con "Zero") -- We would prefer to see the hole removed + app (hole (con cSucc)) (con cZero) + `smartSynthGives` app (hole (con cSucc)) (con cZero) -- We currently give this as output + -- app (con cSucc) (con cZero) -- We would prefer to see the hole removed -- When not using "smart" TC which automatically inserts holes etc, -- one would have to do a bit of dance to build a case expression, and @@ -342,21 +364,21 @@ unit_smart_remove_clean_case = ann ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) tEmptyHole ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) `smartSynthGives` ann ( lam "x" $ ann ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) tEmptyHole ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) unit_poly :: Assertion unit_poly = @@ -372,107 +394,107 @@ unit_poly_head_Nat = ( lam "x" $ case_ (lvar "x") - [ branch "Nil" [] (con "Zero") - , branch "Cons" [("y", Nothing), ("ys", Nothing)] $ con "Succ" `app` lvar "y" + [ branch cNil [] (con cZero) + , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cSucc `app` lvar "y" ] ) - ((tcon "List" `tapp` tcon "Nat") `tfun` tcon "Nat") + ((tcon tList `tapp` tcon tNat) `tfun` tcon tNat) unit_type_hole_1 :: Assertion unit_type_hole_1 = tEmptyHole `expectKinded` KHole unit_type_hole_2 :: Assertion -unit_type_hole_2 = tapp tEmptyHole (tcon "Bool") `expectKinded` KHole +unit_type_hole_2 = tapp tEmptyHole (tcon tBool) `expectKinded` KHole unit_type_hole_3 :: Assertion -unit_type_hole_3 = tapp tEmptyHole (tcon "List") `expectKinded` KHole +unit_type_hole_3 = tapp tEmptyHole (tcon tList) `expectKinded` KHole unit_type_hole_4 :: Assertion -unit_type_hole_4 = tapp (tcon "MaybeT") tEmptyHole `expectKinded` KFun KType KType +unit_type_hole_4 = tapp (tcon tMaybeT) tEmptyHole `expectKinded` KFun KType KType unit_type_hole_5 :: Assertion unit_type_hole_5 = tforall "a" KType tEmptyHole `expectKinded` KType unit_type_hole_6 :: Assertion -unit_type_hole_6 = thole (tcon "Bool") `expectKinded` KHole +unit_type_hole_6 = thole (tcon tBool) `expectKinded` KHole unit_smart_type_not_arrow :: Assertion unit_smart_type_not_arrow = - tapp (tcon "Bool") (tcon "Bool") - `smartSynthKindGives` tapp (thole $ tcon "Bool") (tcon "Bool") + tapp (tcon tBool) (tcon tBool) + `smartSynthKindGives` tapp (thole $ tcon tBool) (tcon tBool) unit_smart_type_forall :: Assertion unit_smart_type_forall = - tforall "a" KType (tcon "List") - `smartSynthKindGives` tforall "a" KType (thole $ tcon "List") + tforall "a" KType (tcon tList) + `smartSynthKindGives` tforall "a" KType (thole $ tcon tList) unit_smart_type_not_type :: Assertion unit_smart_type_not_type = - tapp (tcon "List") (tcon "List") - `smartSynthKindGives` tapp (tcon "List") (thole $ tcon "List") + tapp (tcon tList) (tcon tList) + `smartSynthKindGives` tapp (tcon tList) (thole $ tcon tList) unit_smart_type_fun :: Assertion unit_smart_type_fun = - tfun (tcon "List") (tcon "MaybeT") - `smartSynthKindGives` tfun (thole $ tcon "List") (thole $ tcon "MaybeT") + tfun (tcon tList) (tcon tMaybeT) + `smartSynthKindGives` tfun (thole $ tcon tList) (thole $ tcon tMaybeT) unit_smart_type_inside_hole_1 :: Assertion unit_smart_type_inside_hole_1 = - thole (tcon "Bool" `tapp` tcon "MaybeT") - `smartSynthKindGives` (thole (tcon "Bool") `tapp` tcon "MaybeT") + thole (tcon tBool `tapp` tcon tMaybeT) + `smartSynthKindGives` (thole (tcon tBool) `tapp` tcon tMaybeT) unit_smart_type_inside_hole_2 :: Assertion unit_smart_type_inside_hole_2 = - thole (tcon "List" `tapp` tcon "MaybeT") - `smartSynthKindGives` (tcon "List" `tapp` thole (tcon "MaybeT")) + thole (tcon tList `tapp` tcon tMaybeT) + `smartSynthKindGives` (tcon tList `tapp` thole (tcon tMaybeT)) unit_smart_type_inside_hole_3 :: Assertion unit_smart_type_inside_hole_3 = - (tcon "List" `tapp` thole (tcon "MaybeT" `tapp` tcon "Bool")) - `smartSynthKindGives` (tcon "List" `tapp` thole (tcon "MaybeT" `tapp` thole (tcon "Bool"))) + (tcon tList `tapp` thole (tcon tMaybeT `tapp` tcon tBool)) + `smartSynthKindGives` (tcon tList `tapp` thole (tcon tMaybeT `tapp` thole (tcon tBool))) unit_smart_type_remove_1 :: Assertion unit_smart_type_remove_1 = - tapp (thole $ tcon "List") (tcon "Bool") - `smartSynthKindGives` tapp (tcon "List") (tcon "Bool") + tapp (thole $ tcon tList) (tcon tBool) + `smartSynthKindGives` tapp (tcon tList) (tcon tBool) unit_smart_type_remove_2 :: Assertion unit_smart_type_remove_2 = - tforall "a" KType (thole $ tcon "Bool") - `smartSynthKindGives` tforall "a" KType (tcon "Bool") + tforall "a" KType (thole $ tcon tBool) + `smartSynthKindGives` tforall "a" KType (tcon tBool) unit_smart_type_remove_3 :: Assertion unit_smart_type_remove_3 = - tapp (tcon "List") (thole $ tcon "Bool") - `smartSynthKindGives` tapp (tcon "List") (tcon "Bool") + tapp (tcon tList) (thole $ tcon tBool) + `smartSynthKindGives` tapp (tcon tList) (tcon tBool) unit_smart_type_remove_4 :: Assertion unit_smart_type_remove_4 = - tfun (thole $ tcon "Bool") (thole $ tcon "Nat") - `smartSynthKindGives` tfun (tcon "Bool") (tcon "Nat") + tfun (thole $ tcon tBool) (thole $ tcon tNat) + `smartSynthKindGives` tfun (tcon tBool) (tcon tNat) unit_smart_type_remove_5 :: Assertion unit_smart_type_remove_5 = - thole (tapp (tcon "List") tEmptyHole) - `smartSynthKindGives` tapp (tcon "List") tEmptyHole + thole (tapp (tcon tList) tEmptyHole) + `smartSynthKindGives` tapp (tcon tList) tEmptyHole unit_prim_char :: Assertion unit_prim_char = - expectTyped $ ann (char 'a') (tcon "Char") + expectTypedWithPrims $ ann (char 'a') (tcon tChar) unit_prim_fun :: Assertion unit_prim_fun = - expectTypedWithPrims $ ann (gvar "hexToNat") (tfun (tcon "Char") (tapp (tcon "Maybe") (tcon "Nat"))) + expectTypedWithPrims $ ann (gvar $ primitiveGVar "hexToNat") (tfun (tcon tChar) (tapp (tcon tMaybe) (tcon tNat))) unit_prim_fun_applied :: Assertion unit_prim_fun_applied = - expectTypedWithPrims $ ann (app (gvar "hexToNat") (char 'a')) (tapp (tcon "Maybe") (tcon "Nat")) + expectTypedWithPrims $ ann (app (gvar $ primitiveGVar "hexToNat") (char 'a')) (tapp (tcon tMaybe) (tcon tNat)) -- Whenever we synthesise a type, then it kind-checks against KType hprop_synth_well_typed_extcxt :: Property hprop_synth_well_typed_extcxt = withTests 1000 $ withDiscards 2000 $ - propertyWTInExtendedLocalGlobalCxt (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do + propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do (e, _ty) <- forAllT genSyn ty' <- generateTypeIDs . fst =<< synthTest =<< generateIDs e void $ checkKindTest KType ty' @@ -483,7 +505,7 @@ hprop_synth_well_typed_extcxt = withTests 1000 $ hprop_synth_well_typed_defcxt :: Property hprop_synth_well_typed_defcxt = withTests 1000 $ withDiscards 2000 $ - propertyWT (buildTypingContext mempty mempty NoSmartHoles) $ do + propertyWT [] $ do (e, _ty) <- forAllT genSyn ty' <- generateTypeIDs . fst =<< synthTest =<< generateIDs e void $ checkKindTest KType ty' @@ -497,7 +519,7 @@ checkProgWellFormed p' = case runTypecheckTestM NoSmartHoles $ do NoSmartHoles CheckEverything { trusted = mempty - , toCheck = progModule p : progImports p + , toCheck = progAllModules p } of Left err -> assertFailure $ show err Right _ -> pure () @@ -513,36 +535,49 @@ unit_good_maybeT = case runTypecheckTestM NoSmartHoles $ checkEverything NoSmartHoles CheckEverything - { trusted = [progModule newProg] - , toCheck = [Module (mkTypeDefMap [TypeDefAST maybeTDef]) mempty] + { trusted = [builtinModule] + , toCheck = [Module "TestModule" (mkTypeDefMap [TypeDefAST maybeTDef]) mempty] } of Left err -> assertFailure $ show err Right _ -> pure () -unit_bad_prim_map :: Assertion -unit_bad_prim_map = case runTypecheckTestM NoSmartHoles $ do - fooType <- tcon "Nat" - let foo = PrimDef{primDefName = "bar", primDefType = fooType} +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} + checkEverything + NoSmartHoles + CheckEverything + { trusted = [progModule newProg] + , toCheck = [Module "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_map_module :: Assertion +unit_bad_prim_map_module = case runTypecheckTestM NoSmartHoles $ do + fooType <- tcon tNat + let foo = PrimDef{primDefName = gvn "OtherMod" "foo", primDefType = fooType} checkEverything NoSmartHoles CheckEverything { trusted = [progModule newProg] - , toCheck = [Module mempty $ Map.singleton "foo" $ DefPrim foo] + , toCheck = [Module "M" mempty $ Map.singleton "foo" $ DefPrim foo] } of - Left err -> err @?= InternalError "Inconsistant names in moduleDefs map" + 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 "NonExistant" - let foo = PrimDef{primDefName = "foo", primDefType = fooType} + fooType <- tcon' "M" "NonExistant" + let foo = PrimDef{primDefName = gvn "M" "foo", primDefType = fooType} checkEverything NoSmartHoles CheckEverything { trusted = [progModule newProg] - , toCheck = [Module mempty $ Map.singleton "foo" $ DefPrim foo] + , toCheck = [Module "M" mempty $ Map.singleton "foo" $ DefPrim foo] } of - Left err -> err @?= UnknownTypeConstructor "NonExistant" + Left err -> err @?= UnknownTypeConstructor (tcn "M" "NonExistant") Right _ -> assertFailure "Expected failure but succeeded" -- * Helpers @@ -622,28 +657,34 @@ newtype TypecheckTestM a = TypecheckTestM {unTypecheckTestM :: ExceptT TypeError , MonadError TypeError ) -runTypecheckTestMFromIn :: ID -> Cxt -> TypecheckTestM a -> Either TypeError a -runTypecheckTestMFromIn nextFresh cxt = - evalTestM nextFresh +runTypecheckTestMIn :: Cxt -> TypecheckTestM a -> Either TypeError a +runTypecheckTestMIn cxt = + evalTestM 0 . flip runReaderT cxt . runExceptT . unTypecheckTestM runTypecheckTestM :: SmartHoles -> TypecheckTestM a -> Either TypeError a -runTypecheckTestM sh = runTypecheckTestMFromIn 0 (buildTypingContext testingTypeDefs mempty sh) +runTypecheckTestM sh = runTypecheckTestMIn (buildTypingContextFromModules [testModule, builtinModule] sh) runTypecheckTestMWithPrims :: SmartHoles -> TypecheckTestM a -> Either TypeError a runTypecheckTestMWithPrims sh = - runTypecheckTestMFromIn n (buildTypingContext testingTypeDefs defs sh) - where - (defs, n) = create $ withPrimDefs $ \m -> pure $ DefPrim <$> m + runTypecheckTestMIn (buildTypingContextFromModules [testModule, builtinModule, primitiveModule] sh) + +testModule :: Module +testModule = + Module + { moduleName = "TestModule" + , moduleTypes = mkTypeDefMap [TypeDefAST maybeTDef] + , moduleDefs = mempty + } -testingTypeDefs :: Map TyConName TypeDef -testingTypeDefs = mkTypeDefMap [TypeDefAST maybeTDef] <> defaultTypeDefs +tMaybeT :: TyConName +tMaybeT = tcn "TestModule" "MaybeT" maybeTDef :: ASTTypeDef maybeTDef = ASTTypeDef - { astTypeDefName = "MaybeT" + { astTypeDefName = tMaybeT , astTypeDefParameters = [("m", KFun KType KType), ("a", KType)] - , astTypeDefConstructors = [ValCon "MakeMaybeT" [TApp () (TVar () "m") (TApp () (TCon () "Maybe") (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 5e10a75cf..87cfe7c07 100644 --- a/primer/test/Tests/Unification.hs +++ b/primer/test/Tests/Unification.hs @@ -32,23 +32,34 @@ import Hedgehog ( ) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Primer.App (defaultTypeDefs) -import Primer.Core (ID, Kind (KFun, KHole, KType), TyVarName, Type' (TApp, TCon, TEmptyHole, TForall, TFun, THole, TVar)) +import Primer.Builtins (builtinModule, tList, tNat) +import Primer.Core ( + ASTTypeDef (ASTTypeDef, astTypeDefConstructors, astTypeDefName, astTypeDefNameHints, astTypeDefParameters), + ID, + Kind (KFun, KHole, KType), + TyVarName, + Type' (TApp, TCon, TEmptyHole, TForall, TFun, THole, TVar), + TypeDef (TypeDefAST), + ) import Primer.Core.Utils (forgetTypeIDs, freeVarsTy, generateTypeIDs) +import Primer.Module (Module) import Primer.Name (NameCounter) +import Primer.Primitives (primitiveModule, tInt) import Primer.Subst (substTys) import Primer.Typecheck ( Cxt, SmartHoles (NoSmartHoles), Type, - buildTypingContext, + buildTypingContextFromModules, consistentTypes, extendLocalCxt, extendLocalCxtTy, + extendTypeDefCxt, ) import Primer.Unification (unify) import Test.Tasty.HUnit (Assertion, assertBool, (@?=)) import TestM (evalTestM) +import TestUtils (tcn) import Tests.Gen.Core.Typed ( checkKindTest, checkValidContextTest, @@ -57,7 +68,7 @@ import Tests.Gen.Core.Typed ( ) defaultCxt :: Cxt -defaultCxt = buildTypingContext defaultTypeDefs mempty NoSmartHoles +defaultCxt = buildTypingContextFromModules [builtinModule, primitiveModule] NoSmartHoles unify' :: (MonadFresh NameCounter m, MonadFresh ID m) => @@ -79,11 +90,32 @@ unit_Int_refl = ( unify' defaultCxt mempty - (TCon () "Int") - (TCon () "Int") + (TCon () tInt) + (TCon () tInt) ) @?= Just mempty +unit_diff_module_not_refl :: Assertion +unit_diff_module_not_refl = + evalTestM + 0 + ( unify' + (extendTypeDefCxt [mint] defaultCxt) + mempty + (TCon () tInt) + (TCon () $ tcn "M" "Int") + ) + @?= Nothing + where + mint = + TypeDefAST $ + ASTTypeDef + { astTypeDefName = tcn "M" "Int" + , astTypeDefParameters = mempty + , astTypeDefConstructors = mempty + , astTypeDefNameHints = mempty + } + -- unify [...,a:*] [] a a = Just [] unit_a_refl :: Assertion unit_a_refl = @@ -106,7 +138,7 @@ unit_var_con = (extendLocalCxtTy ("a", KType) defaultCxt) mempty (TVar () "a") - (TCon () "Nat") + (TCon () tNat) ) @?= Nothing @@ -119,9 +151,9 @@ unit_unif_var_con = (extendLocalCxtTy ("a", KType) defaultCxt) (S.singleton "a") (TVar () "a") - (TCon () "Nat") + (TCon () tNat) ) - @?= Just (M.singleton "a" $ TCon () "Nat") + @?= Just (M.singleton "a" $ TCon () tNat) -- unify [...,a:*] [a] a a = Just [] unit_unif_var_refl :: Assertion @@ -145,7 +177,7 @@ unit_ill_kinded = (extendLocalCxtTy ("a", KFun KType KType) defaultCxt) (S.singleton "a") (TVar () "a") - (TCon () "Nat") + (TCon () tNat) ) @?= Nothing @@ -158,9 +190,9 @@ unit_List_Nat = (extendLocalCxtTy ("a", KType) defaultCxt) (S.singleton "a") (TVar () "a") - (TApp () (TCon () "List") (TCon () "Nat")) + (TApp () (TCon () tList) (TCon () tNat)) ) - @?= Just (M.singleton "a" $ TApp () (TCon () "List") (TCon () "Nat")) + @?= Just (M.singleton "a" $ TApp () (TCon () tList) (TCon () tNat)) -- unify [...,a:*] [a] (List a) (List Nat) = Just [Nat/a] unit_List :: Assertion @@ -170,10 +202,10 @@ unit_List = ( unify' (extendLocalCxtTy ("a", KType) defaultCxt) (S.singleton "a") - (TApp () (TCon () "List") (TVar () "a")) - (TApp () (TCon () "List") (TCon () "Nat")) + (TApp () (TCon () tList) (TVar () "a")) + (TApp () (TCon () tList) (TCon () tNat)) ) - @?= Just (M.singleton "a" $ TCon () "Nat") + @?= Just (M.singleton "a" $ TCon () tNat) -- unify [...,a:*] [a] (List Nat) (List Nat) = Just [] unit_List_Nat_refl :: Assertion @@ -183,8 +215,8 @@ unit_List_Nat_refl = ( unify' (extendLocalCxtTy ("a", KType) defaultCxt) (S.singleton "a") - (TApp () (TCon () "List") (TCon () "Nat")) - (TApp () (TCon () "List") (TCon () "Nat")) + (TApp () (TCon () tList) (TCon () tNat)) + (TApp () (TCon () tList) (TCon () tNat)) ) @?= Just mempty @@ -196,10 +228,10 @@ unit_higher_kinded = ( unify' (extendLocalCxtTy ("a", KFun KType KType) defaultCxt) (S.singleton "a") - (TApp () (TVar () "a") (TCon () "Nat")) - (TApp () (TCon () "List") (TCon () "Nat")) + (TApp () (TVar () "a") (TCon () tNat)) + (TApp () (TCon () tList) (TCon () tNat)) ) - @?= Just (M.singleton "a" $ TCon () "List") + @?= Just (M.singleton "a" $ TCon () tList) -- unify [...] [a] (? List) (List a) fails, as 'a' is not in the context -- In particular, it does not succeed with the nonsense [List/a], as we throw @@ -213,8 +245,8 @@ unit_ill_kinded_0 = unify defaultCxt (S.singleton "a") - (TApp () (TEmptyHole ()) (TCon () "List")) - (TApp () (TCon () "List") (TVar () "a")) + (TApp () (TEmptyHole ()) (TCon () tList)) + (TApp () (TCon () tList) (TVar () "a")) ) in assertBool "Should have detected a unification variable was not in the context" $ isLeft res @@ -227,10 +259,10 @@ unit_uv_not_in_context = ( unify' (extendLocalCxtTy ("b", KType) defaultCxt) (S.fromList ["a", "b"]) - (TCon () "Nat") + (TCon () tNat) (TVar () "b") ) - @?= Just (M.singleton "b" $ TCon () "Nat") + @?= Just (M.singleton "b" $ TCon () tNat) -- unify [...,a:*] [a] (? List) (List a) = Nothing unit_ill_kinded_1 :: Assertion @@ -240,8 +272,8 @@ unit_ill_kinded_1 = ( unify' (extendLocalCxtTy ("a", KType) defaultCxt) (S.singleton "a") - (TApp () (TEmptyHole ()) (TCon () "List")) - (TApp () (TCon () "List") (TVar () "a")) + (TApp () (TEmptyHole ()) (TCon () tList)) + (TApp () (TCon () tList) (TVar () "a")) ) @?= Nothing @@ -255,10 +287,10 @@ unit_ill_kinded_2 = ( unify' (extendLocalCxtTy ("a", KFun KType KType) defaultCxt) (S.singleton "a") - (TApp () (TEmptyHole ()) (TCon () "List")) - (TApp () (TCon () "List") (TVar () "a")) + (TApp () (TEmptyHole ()) (TCon () tList)) + (TApp () (TCon () tList) (TVar () "a")) ) - @?= Just (M.singleton "a" $ TCon () "List") + @?= Just (M.singleton "a" $ TCon () tList) -- unify [...,a:*,b:*->*] [a] a b = Nothing unit_ill_kinded_3 :: Assertion @@ -347,7 +379,7 @@ unit_unify_hole_trivial_1 = defaultCxt mempty (TEmptyHole ()) - (THole () $ TCon () "Nat") + (THole () $ TCon () tNat) ) @?= Just mempty @@ -383,24 +415,24 @@ genCxtExtendingLocalUVs = do -- Run a property in a context extended with typedefs, globals and locals. Some -- of the locals (mentioned in the Set) are considered unification variables. -propertyWTInExtendedUVCxt' :: Cxt -> (M.Map TyVarName Kind -> PropertyT WT ()) -> Property -propertyWTInExtendedUVCxt' cxt p = propertyWT cxt $ do +propertyWTInExtendedUVCxt' :: [Module] -> (M.Map TyVarName Kind -> PropertyT WT ()) -> Property +propertyWTInExtendedUVCxt' mods p = propertyWT mods $ do cxtG <- forAllT genCxtExtendingGlobal local (const cxtG) $ do (cxtL, uvs) <- forAllT genCxtExtendingLocalUVs annotateShow uvs local (const cxtL) $ p uvs -propertyWTInExtendedUVCxt :: Cxt -> (S.Set TyVarName -> PropertyT WT ()) -> Property -propertyWTInExtendedUVCxt cxt p = propertyWTInExtendedUVCxt' cxt $ p . M.keysSet +propertyWTInExtendedUVCxt :: [Module] -> (S.Set TyVarName -> PropertyT WT ()) -> Property +propertyWTInExtendedUVCxt mods p = propertyWTInExtendedUVCxt' mods $ p . M.keysSet hprop_extendedUVCxt_typechecks :: Property -hprop_extendedUVCxt_typechecks = propertyWTInExtendedUVCxt defaultCxt $ \_ -> +hprop_extendedUVCxt_typechecks = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \_ -> checkValidContextTest =<< ask -- unify _ _ T T is Just [] hprop_refl :: Property -hprop_refl = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_refl = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind t <- forAllT $ genWTType k @@ -409,7 +441,7 @@ hprop_refl = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- unify _ [] S T is Nothing or Just [], exactly when S = T up to holes hprop_eq :: Property -hprop_eq = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_eq = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -426,7 +458,7 @@ hprop_eq = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- unify ga uvs S T = Maybe sub => sub <= uvs hprop_only_sub_uvs :: Property -hprop_only_sub_uvs = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_only_sub_uvs = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -438,7 +470,7 @@ hprop_only_sub_uvs = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- unify ga uvs S T = Maybe sub => S[sub] = T[sub] hprop_sub_unifies :: Property -hprop_sub_unifies = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_sub_unifies = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -453,7 +485,7 @@ hprop_sub_unifies = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- unify ga uvs S T = Maybe sub => for t/a in sub, have checkKind uvs(a) t hprop_sub_checks :: Property -hprop_sub_checks = propertyWTInExtendedUVCxt' defaultCxt $ \uvs -> do +hprop_sub_checks = propertyWTInExtendedUVCxt' [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -468,7 +500,7 @@ hprop_sub_checks = propertyWTInExtendedUVCxt' defaultCxt $ \uvs -> do -- (S,T kind check and) unify ga uvs S T = Maybe sub => S[sub] , T[sub] kind check hprop_unified_checks :: Property -hprop_unified_checks = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_unified_checks = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -488,7 +520,7 @@ hprop_unified_checks = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- This requires each to not be holey - i.e. don't synthesise KHole hprop_diff_kinds_never_unify :: Property hprop_diff_kinds_never_unify = withDiscards 5000 $ - propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do + propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k1 <- forAllT genWTKind k2 <- forAllT genWTKind @@ -504,7 +536,7 @@ hprop_diff_kinds_never_unify = withDiscards 5000 $ -- unification is symmetric hprop_sym :: Property -hprop_sym = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_sym = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -515,7 +547,7 @@ hprop_sym = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- the sub should be "non-cyclic", i.e. any sub should stabalise if done repeatedly hprop_non_cyclic :: Property -hprop_non_cyclic = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_non_cyclic = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -531,7 +563,7 @@ hprop_non_cyclic = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- unifying a unif var gives simple success hprop_uv_succeeds :: Property -hprop_uv_succeeds = propertyWT defaultCxt $ do +hprop_uv_succeeds = propertyWT [builtinModule, primitiveModule] $ do k <- forAllT genWTKind t <- forAllT $ genWTType k uv <- forAllT freshTyVarNameForCxt diff --git a/primer/test/Tests/Zipper/BindersAbove.hs b/primer/test/Tests/Zipper/BindersAbove.hs index 09c2f672a..4cf548254 100644 --- a/primer/test/Tests/Zipper/BindersAbove.hs +++ b/primer/test/Tests/Zipper/BindersAbove.hs @@ -8,6 +8,7 @@ import Primer.Action ( Movement (..), moveExpr, ) +import Primer.Builtins (cSucc, cZero, tNat) import Primer.Core ( Expr, ) @@ -42,43 +43,43 @@ unit_4 = unit_5 :: Assertion unit_5 = bindersAboveTest - (letrec "x" (lam "y" emptyHole) (tcon "Nat") (lam "z" emptyHole)) + (letrec "x" (lam "y" emptyHole) (tcon tNat) (lam "z" emptyHole)) [Child1, Child1] (S.fromList ["x", "y"]) unit_6 :: Assertion unit_6 = bindersAboveTest - (letrec "x" (lam "y" emptyHole) (tcon "Nat") (lam "z" emptyHole)) + (letrec "x" (lam "y" emptyHole) (tcon tNat) (lam "z" emptyHole)) [Child2, Child1] (S.fromList ["x", "z"]) unit_7 :: Assertion unit_7 = bindersAboveTest - (case_ (lvar "x") [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole]) + (case_ (lvar "x") [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole]) [] (S.fromList []) unit_8 :: Assertion unit_8 = bindersAboveTest - (case_ (lvar "x") [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole]) + (case_ (lvar "x") [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole]) [Child1] (S.fromList []) unit_9 :: Assertion unit_9 = bindersAboveTest - (case_ (lvar "x") [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole]) - [Branch "Zero"] + (case_ (lvar "x") [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole]) + [Branch cZero] (S.fromList []) unit_10 :: Assertion unit_10 = bindersAboveTest - (case_ (lvar "x") [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole]) - [Branch "Succ"] + (case_ (lvar "x") [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole]) + [Branch cSucc] (S.fromList ["n"]) -- * Helpers diff --git a/primer/test/outputs/serialization/def.json b/primer/test/outputs/serialization/def.json index 677035463..b1aa0d01f 100644 --- a/primer/test/outputs/serialization/def.json +++ b/primer/test/outputs/serialization/def.json @@ -13,7 +13,10 @@ ], "tag": "EmptyHole" }, - "astDefName": "main", + "astDefName": { + "baseName": "main", + "qualifiedModule": "M" + }, "astDefType": { "contents": [ 0, diff --git a/primer/test/outputs/serialization/edit_response_2.json b/primer/test/outputs/serialization/edit_response_2.json index 9936c2986..e3f51e522 100644 --- a/primer/test/outputs/serialization/edit_response_2.json +++ b/primer/test/outputs/serialization/edit_response_2.json @@ -36,7 +36,10 @@ ], "tag": "EmptyHole" }, - "astDefName": "main", + "astDefName": { + "baseName": "main", + "qualifiedModule": "M" + }, "astDefType": { "contents": [ 0, @@ -51,6 +54,7 @@ "tag": "DefAST" } }, + "moduleName": "M", "moduleTypes": { "T": { "contents": { @@ -80,15 +84,24 @@ { "contents": [ [], - "Nat" + { + "baseName": "Nat", + "qualifiedModule": "Builtins" + } ], "tag": "TCon" } ], - "valConName": "C" + "valConName": { + "baseName": "C", + "qualifiedModule": "M" + } } ], - "astTypeDefName": "T", + "astTypeDefName": { + "baseName": "T", + "qualifiedModule": "M" + }, "astTypeDefNameHints": [], "astTypeDefParameters": [ [ @@ -118,7 +131,10 @@ } }, "progSelection": { - "selectedDef": "main", + "selectedDef": { + "baseName": "main", + "qualifiedModule": "M" + }, "selectedNode": { "meta": { "Left": [ diff --git a/primer/test/outputs/serialization/prog.json b/primer/test/outputs/serialization/prog.json index 6ee4f26c5..244cca776 100644 --- a/primer/test/outputs/serialization/prog.json +++ b/primer/test/outputs/serialization/prog.json @@ -35,7 +35,10 @@ ], "tag": "EmptyHole" }, - "astDefName": "main", + "astDefName": { + "baseName": "main", + "qualifiedModule": "M" + }, "astDefType": { "contents": [ 0, @@ -50,6 +53,7 @@ "tag": "DefAST" } }, + "moduleName": "M", "moduleTypes": { "T": { "contents": { @@ -79,15 +83,24 @@ { "contents": [ [], - "Nat" + { + "baseName": "Nat", + "qualifiedModule": "Builtins" + } ], "tag": "TCon" } ], - "valConName": "C" + "valConName": { + "baseName": "C", + "qualifiedModule": "M" + } } ], - "astTypeDefName": "T", + "astTypeDefName": { + "baseName": "T", + "qualifiedModule": "M" + }, "astTypeDefNameHints": [], "astTypeDefParameters": [ [ @@ -117,7 +130,10 @@ } }, "progSelection": { - "selectedDef": "main", + "selectedDef": { + "baseName": "main", + "qualifiedModule": "M" + }, "selectedNode": { "meta": { "Left": [ diff --git a/primer/test/outputs/serialization/progaction.json b/primer/test/outputs/serialization/progaction.json index c84b5a70e..5eb0e1139 100644 --- a/primer/test/outputs/serialization/progaction.json +++ b/primer/test/outputs/serialization/progaction.json @@ -1,4 +1,7 @@ { - "contents": "main", + "contents": { + "baseName": "main", + "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 597a7cade..107a95980 100644 --- a/primer/test/outputs/serialization/selection.json +++ b/primer/test/outputs/serialization/selection.json @@ -1,5 +1,8 @@ { - "selectedDef": "main", + "selectedDef": { + "baseName": "main", + "qualifiedModule": "M" + }, "selectedNode": { "meta": { "Left": [ diff --git a/primer/test/outputs/serialization/typeDef.json b/primer/test/outputs/serialization/typeDef.json index 3399e62f1..4d7f83851 100644 --- a/primer/test/outputs/serialization/typeDef.json +++ b/primer/test/outputs/serialization/typeDef.json @@ -26,15 +26,24 @@ { "contents": [ [], - "Nat" + { + "baseName": "Nat", + "qualifiedModule": "Builtins" + } ], "tag": "TCon" } ], - "valConName": "C" + "valConName": { + "baseName": "C", + "qualifiedModule": "M" + } } ], - "astTypeDefName": "T", + "astTypeDefName": { + "baseName": "T", + "qualifiedModule": "M" + }, "astTypeDefNameHints": [], "astTypeDefParameters": [ [