From 3fcf6007b8fa0b9bd52d475f1c2f1971103a10e8 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 13 Dec 2023 13:27:04 -0600 Subject: [PATCH 1/2] Introduce a separate type for the current module info Much lens golfing to get `currModuleName` right! --- pact-core/Pact/Core/IR/Desugar.hs | 46 +++++++++++++++++++++---------- 1 file changed, 32 insertions(+), 14 deletions(-) diff --git a/pact-core/Pact/Core/IR/Desugar.hs b/pact-core/Pact/Core/IR/Desugar.hs index 5eae9171e..d303570eb 100644 --- a/pact-core/Pact/Core/IR/Desugar.hs +++ b/pact-core/Pact/Core/IR/Desugar.hs @@ -81,15 +81,25 @@ import qualified Pact.Core.Syntax.ParseTree as Lisp type DesugarType = Lisp.Type +data CurrModule + = CurrModule + { _cmName :: ModuleName + , _cmImplements :: [ModuleName] + } +makeLenses ''CurrModule + data RenamerEnv b i = RenamerEnv { _reBinds :: Map Text (NameKind, Maybe DefKind) , _reVarDepth :: DeBruijn - , _reCurrModule :: Maybe (ModuleName, [ModuleName]) + , _reCurrModule :: Maybe CurrModule , _reCurrDef :: Maybe DefKind } makeLenses ''RenamerEnv +currModuleName :: MonadReader (RenamerEnv b i) m => m (Maybe ModuleName) +currModuleName = preview $ reCurrModule . folded . cmName + -- Our type to keep track of newtype RenamerState = RenamerState { _rsDependencies :: Set ModuleName } @@ -384,8 +394,8 @@ desugarDefun (Lisp.Defun defname [] mrt body _ _ i) = do desugarDefun (Lisp.Defun defname (arg:args) mrt body _ _ i) = do let args' = toArg <$> (arg :| args) body' <- desugarLispTerm body - view reCurrModule >>= \case - Just (mn,_) -> do + currModuleName >>= \case + Just mn -> do let bodyLam = Lam (TLDefun mn defname) args' body' i pure $ Defun defname (NE.toList args') mrt bodyLam i Nothing -> throwDesugarError (NotAllowedOutsideModule "defun") i @@ -397,8 +407,8 @@ desugarDefPact desugarDefPact (Lisp.DefPact dpname _ _ [] _ _ i) = throwDesugarError (EmptyDefPact dpname) i desugarDefPact (Lisp.DefPact dpname margs rt (step:steps) _ _ i) = - view reCurrModule >>= \case - Just (mn,_) -> do + currModuleName >>= \case + Just mn -> do let args' = toArg <$> margs steps' <- forM (step :| steps) \case Lisp.Step s _ -> @@ -503,7 +513,7 @@ desugarModule -> RenamerT b i m (Module ParsedName DesugarType b i) desugarModule (Lisp.Module mname mgov extdecls defs _ _ i) = do (imports, blessed, implemented) <- splitExts extdecls - defs' <- locally reCurrModule (const (Just (mname,[]))) $ traverse desugarDef (NE.toList defs) + defs' <- locally reCurrModule (const (Just $ CurrModule mname [])) $ traverse desugarDef (NE.toList defs) pure $ Module mname mgov defs' blessed imports implemented placeholderHash i where splitExts = split ([], S.empty, []) @@ -771,7 +781,7 @@ resolveModuleName -> RenamerT b i m (ModuleName, [ModuleName]) resolveModuleName i mn = view reCurrModule >>= \case - Just (currMod, imps) | currMod == mn -> pure (currMod, imps) + Just (CurrModule currMod imps) | currMod == mn -> pure (currMod, imps) _ -> resolveModuleData mn i >>= \case ModuleData md _ -> do let implementeds = view mImplements md @@ -784,8 +794,8 @@ resolveModuleName i mn = -- including all current resolveInterfaceName :: (MonadEval b i m) => i -> ModuleName -> RenamerT b i m (ModuleName) resolveInterfaceName i mn = - view reCurrModule >>= \case - Just (currMod, _imps) | currMod == mn -> pure currMod + currModuleName >>= \case + Just currMod | currMod == mn -> pure currMod _ -> resolveModuleData mn i >>= \case ModuleData _ _ -> throwDesugarError (InvalidModuleReference mn) i @@ -1175,7 +1185,7 @@ resolveBare (BareName bn) i = views reBinds (M.lookup bn) >>= \case Nothing -> do let mn = ModuleName bn Nothing view reCurrModule >>= \case - Just (currMod, imps) | currMod == mn -> + Just (CurrModule currMod imps) | currMod == mn -> pure (Name bn (NModRef mn imps), Nothing) _ -> do (mn', imps) <- resolveModuleName i mn @@ -1252,7 +1262,7 @@ renameModule (Module unmangled mgov defs blessed imports implements mhash i) = d go mname (defns, s, m) defn = do when (S.member (defName defn) s) $ throwDesugarError (DuplicateDefinition (defName defn)) i let dn = defName defn - defn' <- local (set reCurrModule (Just (mname, implements))) + defn' <- local (set reCurrModule (Just $ CurrModule mname implements)) $ local (set reBinds m) $ renameDef defn let dk = defKind defn' let depPair = (NTopLevel mname mhash, dk) @@ -1359,7 +1369,7 @@ renameInterface (Interface unmangled defs imports ih info) = do when (S.member dn s) $ throwDesugarError (DuplicateDefinition dn) info d' <- local (set reBinds m) $ - local (set reCurrModule (Just (ifn, []))) $ renameIfDef d + local (set reCurrModule (Just $ CurrModule ifn [])) $ renameIfDef d let m' = case ifDefToDef d' of Just defn -> let dk = defKind defn @@ -1411,7 +1421,7 @@ runDesugarReplDefun -> m (DesugarOutput (Defun Name Type b i)) runDesugarReplDefun = runDesugar - . local (set reCurrModule (Just (replModuleName, []))) + . local (set reCurrModule (Just $ CurrModule replModuleName [])) . (desugarDefun >=> renameReplDefun) runDesugarReplDefConst @@ -1420,7 +1430,7 @@ runDesugarReplDefConst -> m (DesugarOutput (DefConst Name Type b i)) runDesugarReplDefConst = runDesugar - . local (set reCurrModule (Just (replModuleName,[]))) + . local (set reCurrModule (Just $ CurrModule replModuleName [])) . (desugarDefConst >=> renameReplDefConst) runDesugarTopLevel @@ -1451,3 +1461,11 @@ runDesugarReplTopLevel = \case over dsOut RTLDefun <$> runDesugarReplDefun de Lisp.RTLDefConst dc -> over dsOut RTLDefConst <$> runDesugarReplDefConst dc + + +-- Some types don't get all their lenses used, hence GHC warns about unused bindings. +-- This is one way to controllably silence these warnings. +data Unused where Unused :: a -> Unused + +_unused :: [Unused] +_unused = [Unused $ set cmImplements] From dfb278cbdbc42ab65cf894f003f6546cc81bac84 Mon Sep 17 00:00:00 2001 From: 0xd34df00d <0xd34df00d@gmail.com> Date: Wed, 13 Dec 2023 13:33:51 -0600 Subject: [PATCH 2/2] Annotate curr module info with module type and check it in resolvers --- pact-core/Pact/Core/IR/Desugar.hs | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/pact-core/Pact/Core/IR/Desugar.hs b/pact-core/Pact/Core/IR/Desugar.hs index d303570eb..ffa516452 100644 --- a/pact-core/Pact/Core/IR/Desugar.hs +++ b/pact-core/Pact/Core/IR/Desugar.hs @@ -81,10 +81,13 @@ import qualified Pact.Core.Syntax.ParseTree as Lisp type DesugarType = Lisp.Type +data ModuleType = MTModule | MTInterface + data CurrModule = CurrModule { _cmName :: ModuleName , _cmImplements :: [ModuleName] + , _cmType :: ModuleType } makeLenses ''CurrModule @@ -513,7 +516,7 @@ desugarModule -> RenamerT b i m (Module ParsedName DesugarType b i) desugarModule (Lisp.Module mname mgov extdecls defs _ _ i) = do (imports, blessed, implemented) <- splitExts extdecls - defs' <- locally reCurrModule (const (Just $ CurrModule mname [])) $ traverse desugarDef (NE.toList defs) + defs' <- locally reCurrModule (const (Just $ CurrModule mname [] MTModule)) $ traverse desugarDef (NE.toList defs) pure $ Module mname mgov defs' blessed imports implemented placeholderHash i where splitExts = split ([], S.empty, []) @@ -781,7 +784,7 @@ resolveModuleName -> RenamerT b i m (ModuleName, [ModuleName]) resolveModuleName i mn = view reCurrModule >>= \case - Just (CurrModule currMod imps) | currMod == mn -> pure (currMod, imps) + Just (CurrModule currMod imps MTModule) | currMod == mn -> pure (currMod, imps) _ -> resolveModuleData mn i >>= \case ModuleData md _ -> do let implementeds = view mImplements md @@ -794,8 +797,8 @@ resolveModuleName i mn = -- including all current resolveInterfaceName :: (MonadEval b i m) => i -> ModuleName -> RenamerT b i m (ModuleName) resolveInterfaceName i mn = - currModuleName >>= \case - Just currMod | currMod == mn -> pure currMod + view reCurrModule >>= \case + Just (CurrModule currMod _ MTInterface) | currMod == mn -> pure currMod _ -> resolveModuleData mn i >>= \case ModuleData _ _ -> throwDesugarError (InvalidModuleReference mn) i @@ -1185,7 +1188,7 @@ resolveBare (BareName bn) i = views reBinds (M.lookup bn) >>= \case Nothing -> do let mn = ModuleName bn Nothing view reCurrModule >>= \case - Just (CurrModule currMod imps) | currMod == mn -> + Just (CurrModule currMod imps _type) | currMod == mn -> pure (Name bn (NModRef mn imps), Nothing) _ -> do (mn', imps) <- resolveModuleName i mn @@ -1262,7 +1265,7 @@ renameModule (Module unmangled mgov defs blessed imports implements mhash i) = d go mname (defns, s, m) defn = do when (S.member (defName defn) s) $ throwDesugarError (DuplicateDefinition (defName defn)) i let dn = defName defn - defn' <- local (set reCurrModule (Just $ CurrModule mname implements)) + defn' <- local (set reCurrModule (Just $ CurrModule mname implements MTModule)) $ local (set reBinds m) $ renameDef defn let dk = defKind defn' let depPair = (NTopLevel mname mhash, dk) @@ -1369,7 +1372,7 @@ renameInterface (Interface unmangled defs imports ih info) = do when (S.member dn s) $ throwDesugarError (DuplicateDefinition dn) info d' <- local (set reBinds m) $ - local (set reCurrModule (Just $ CurrModule ifn [])) $ renameIfDef d + local (set reCurrModule (Just $ CurrModule ifn [] MTInterface)) $ renameIfDef d let m' = case ifDefToDef d' of Just defn -> let dk = defKind defn @@ -1421,7 +1424,7 @@ runDesugarReplDefun -> m (DesugarOutput (Defun Name Type b i)) runDesugarReplDefun = runDesugar - . local (set reCurrModule (Just $ CurrModule replModuleName [])) + . local (set reCurrModule (Just $ CurrModule replModuleName [] MTModule)) . (desugarDefun >=> renameReplDefun) runDesugarReplDefConst @@ -1430,7 +1433,7 @@ runDesugarReplDefConst -> m (DesugarOutput (DefConst Name Type b i)) runDesugarReplDefConst = runDesugar - . local (set reCurrModule (Just $ CurrModule replModuleName [])) + . local (set reCurrModule (Just $ CurrModule replModuleName [] MTModule)) . (desugarDefConst >=> renameReplDefConst) runDesugarTopLevel @@ -1468,4 +1471,4 @@ runDesugarReplTopLevel = \case data Unused where Unused :: a -> Unused _unused :: [Unused] -_unused = [Unused $ set cmImplements] +_unused = [Unused $ set cmImplements, Unused $ set cmType]