Merge pull request #42 from kadena-io/gr/curr_module_type

Keep the current module type and account for it in `resolve{Module,Interface}Name`

pact-core/Pact/Core/IR/Desugar.hs

@@ -81,15 +81,28 @@ 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
+
 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 +397,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 +410,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 +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 (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, [])
@@ -771,7 +784,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 MTModule) | currMod == mn -> pure (currMod, imps)
     _ -> resolveModuleData mn i >>= \case
       ModuleData md _ -> do
         let implementeds = view mImplements md
@@ -785,7 +798,7 @@ resolveModuleName i mn =
 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
+    Just (CurrModule currMod _ MTInterface) | currMod == mn -> pure currMod
     _ -> resolveModuleData mn i >>= \case
       ModuleData _ _ ->
         throwDesugarError (InvalidModuleReference mn) i
@@ -1175,7 +1188,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 _type) | currMod == mn ->
           pure (Name bn (NModRef mn imps), Nothing)
         _ -> do
           (mn', imps) <- resolveModuleName i mn
@@ -1252,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 (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)
@@ -1359,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 (ifn, []))) $ renameIfDef d
+          local (set reCurrModule (Just $ CurrModule ifn [] MTInterface)) $ renameIfDef d
     let m' = case ifDefToDef d' of
               Just defn ->
                 let dk = defKind defn
@@ -1411,7 +1424,7 @@ runDesugarReplDefun
   -> m (DesugarOutput (Defun Name Type b i))
 runDesugarReplDefun =
   runDesugar
-  . local (set reCurrModule (Just (replModuleName, [])))
+  . local (set reCurrModule (Just $ CurrModule replModuleName [] MTModule))
   . (desugarDefun >=> renameReplDefun)
 
 runDesugarReplDefConst
@@ -1420,7 +1433,7 @@ runDesugarReplDefConst
   -> m (DesugarOutput (DefConst Name Type b i))
 runDesugarReplDefConst  =
   runDesugar
-  . local (set reCurrModule (Just (replModuleName,[])))
+  . local (set reCurrModule (Just $ CurrModule replModuleName [] MTModule))
   . (desugarDefConst >=> renameReplDefConst)
 
 runDesugarTopLevel
@@ -1451,3 +1464,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, Unused $ set cmType]