Simplify the IfaceDecls type

As IfaceDecls is no longer used when interpreting imports, there's no way for
conflicts to appear. As a result, the values of each map no longer need to be
lists, and the mappend operation is greatly simplified.

src/Cryptol/ModuleSystem/Base.hs

@@ -45,7 +45,7 @@ import qualified Control.Exception as X
 import Control.Monad (unless)
 import Data.Function (on)
 import Data.List (nubBy)
-import Data.Maybe (mapMaybe,fromMaybe)
+import Data.Maybe (fromMaybe)
 import Data.Monoid ((<>))
 import           Data.Text.Lazy (Text)
 import qualified Data.Text.Lazy.IO as T
@@ -447,9 +447,9 @@ genInferInput r prims env = do
   -- TODO: include the environment needed by the module
   return T.InferInput
     { T.inpRange     = r
-    , T.inpVars      = Map.map ifDeclSig (filterEnv ifDecls)
-    , T.inpTSyns     =                    filterEnv ifTySyns
-    , T.inpNewtypes  =                    filterEnv ifNewtypes
+    , T.inpVars      = Map.map ifDeclSig (ifDecls env)
+    , T.inpTSyns     = ifTySyns env
+    , T.inpNewtypes  = ifNewtypes env
     , T.inpNameSeeds = seeds
     , T.inpMonoBinds = monoBinds
     , T.inpSolverConfig = cfg
@@ -457,18 +457,6 @@ genInferInput r prims env = do
     , T.inpPrimNames = prims
     }
 
-  where
-  -- at this point, the names used in the aggregate interface should be
-  -- unique
-  keepOne :: (Name,[a]) -> Maybe (Name,a)
-  keepOne (qn,syns) = case syns of
-    [syn] -> Just (qn,syn)
-    _     -> Nothing
-
-  -- keep symbols without duplicates.  the renamer would have caught
-  -- duplication already, so this is safe.
-  filterEnv p = Map.fromList (mapMaybe keepOne (Map.toList (p env)))
-
 
 -- Evaluation ------------------------------------------------------------------
 

src/Cryptol/ModuleSystem/Env.hs

@@ -266,7 +266,7 @@ deIfaceDecls DEnv { deDecls = dgs } =
   mconcat [ IfaceDecls
             { ifTySyns   = Map.empty
             , ifNewtypes = Map.empty
-            , ifDecls    = Map.singleton (ifDeclName ifd) [ifd]
+            , ifDecls    = Map.singleton (ifDeclName ifd) ifd
             }
           | decl <- concatMap T.groupDecls dgs
           , let ifd = mkIfaceDecl decl

src/Cryptol/ModuleSystem/Interface.hs

@@ -45,9 +45,9 @@ data Iface = Iface
 instance NFData Iface
 
 data IfaceDecls = IfaceDecls
-  { ifTySyns   :: Map.Map Name [IfaceTySyn]
-  , ifNewtypes :: Map.Map Name [IfaceNewtype]
-  , ifDecls    :: Map.Map Name [IfaceDecl]
+  { ifTySyns   :: Map.Map Name IfaceTySyn
+  , ifNewtypes :: Map.Map Name IfaceNewtype
+  , ifDecls    :: Map.Map Name IfaceDecl
   } deriving (Show, Generic)
 
 instance NFData IfaceDecls
@@ -55,22 +55,16 @@ instance NFData IfaceDecls
 instance Monoid IfaceDecls where
   mempty      = IfaceDecls Map.empty Map.empty Map.empty
   mappend l r = IfaceDecls
-    { ifTySyns   = Map.unionWith (mergeByName ifTySynName) (ifTySyns l)   (ifTySyns r)
-    , ifNewtypes = Map.unionWith (mergeByName ntName)      (ifNewtypes l) (ifNewtypes r)
-    , ifDecls    = Map.unionWith (mergeByName ifDeclName)  (ifDecls l)    (ifDecls r)
+    { ifTySyns   = Map.union (ifTySyns l)   (ifTySyns r)
+    , ifNewtypes = Map.union (ifNewtypes l) (ifNewtypes r)
+    , ifDecls    = Map.union (ifDecls l)    (ifDecls r)
     }
   mconcat ds  = IfaceDecls
-    { ifTySyns   = Map.unionsWith (mergeByName ifTySynName) (map ifTySyns ds)
-    , ifNewtypes = Map.unionsWith (mergeByName ntName)      (map ifNewtypes ds)
-    , ifDecls    = Map.unionsWith (mergeByName ifDeclName)  (map ifDecls  ds)
+    { ifTySyns   = Map.unions (map ifTySyns   ds)
+    , ifNewtypes = Map.unions (map ifNewtypes ds)
+    , ifDecls    = Map.unions (map ifDecls    ds)
     }
 
--- | Merge the entries in the simple case.
-mergeByName :: (a -> Name) -> [a] -> [a] -> [a]
-mergeByName f ls rs
-  | [l] <- ls, [r] <- rs, f l == f r = ls
-  | otherwise                        = ls ++ rs
-
 type IfaceTySyn = TySyn
 
 ifTySynName :: TySyn -> Name
@@ -117,19 +111,16 @@ genIface m = Iface
   where
 
   (tsPub,tsPriv) =
-      Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m )
-      $ fmap return (mTySyns m)
-
+      Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m ) (mTySyns m)
   (ntPub,ntPriv) =
-      Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m )
-      $ fmap return (mNewtypes m)
+      Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m ) (mNewtypes m)
 
   (dPub,dPriv) =
       Map.partitionWithKey (\ qn _ -> qn `isExportedBind` mExports m)
-      $ Map.fromList [ (qn,[mkIfaceDecl d]) | dg <- mDecls m
-                                            , d  <- groupDecls dg
-                                            , let qn = dName d
-                                            ]
+      $ Map.fromList [ (qn,mkIfaceDecl d) | dg <- mDecls m
+                                          , d  <- groupDecls dg
+                                          , let qn = dName d
+                                          ]
 
 
 -- | Produce a PrimMap from an interface.

src/Cryptol/ModuleSystem/NamingEnv.hs

@@ -228,7 +228,7 @@ unqualifiedEnv IfaceDecls { .. } =
 
   fixity =
     catMaybes [ do f <- ifDeclFixity d; return (ifDeclName d,f)
-              | d:_ <- Map.elems ifDecls ]
+              | d    <- Map.elems ifDecls ]
 
 
 data ImportIface = ImportIface Import Iface

src/Cryptol/REPL/Command.hs

@@ -611,7 +611,7 @@ browseCmd pfx = do
 
 browseTSyns :: (M.IfaceDecls,NameDisp) -> String -> REPL ()
 browseTSyns (decls,names) pfx = do
-  let tsyns = keepOne "browseTSyns" `fmap` M.ifTySyns decls
+  let tsyns = M.ifTySyns decls
       tsyns' = Map.filterWithKey (\k _ -> pfx `isNamePrefix` k) tsyns
   unless (Map.null tsyns') $ do
     rPutStrLn "Type Synonyms"
@@ -622,7 +622,7 @@ browseTSyns (decls,names) pfx = do
 
 browseNewtypes :: (M.IfaceDecls,NameDisp) -> String -> REPL ()
 browseNewtypes (decls,names) pfx = do
-  let nts  = keepOne "browseNewtypes" `fmap` M.ifNewtypes decls
+  let nts  = M.ifNewtypes decls
       nts' = Map.filterWithKey (\k _ -> pfx `isNamePrefix` k) nts
   unless (Map.null nts') $ do
     rPutStrLn "Newtypes"
@@ -633,7 +633,7 @@ browseNewtypes (decls,names) pfx = do
 
 browseVars :: (M.IfaceDecls,NameDisp) -> String -> REPL ()
 browseVars (decls,names) pfx = do
-  let vars = keepOne "browseVars" `fmap` M.ifDecls decls
+  let vars = M.ifDecls decls
       allNames = vars
       vars' = Map.filterWithKey (\k _ -> pfx `isNamePrefix` k) allNames
 
@@ -691,7 +691,7 @@ helpCmd cmd
         do (env,rnEnv,nameEnv) <- getFocusedEnv
            name <- liftModuleCmd (M.renameVar rnEnv qname)
            case Map.lookup name (M.ifDecls env) of
-             Just [M.IfaceDecl { .. }] ->
+             Just M.IfaceDecl { .. } ->
                do rPutStrLn ""
 
                   let property
@@ -708,7 +708,7 @@ helpCmd cmd
                     Just str -> rPutStrLn ('\n' : str)
                     Nothing  -> return ()
 
-             _ -> rPutStrLn "// No documentation is available."
+             Nothing -> rPutStrLn "// No documentation is available."
 
       Nothing ->
            rPutStrLn ("Unable to parse name: " ++ cmd)

src/Cryptol/REPL/Monad.hs

@@ -28,7 +28,7 @@ module Cryptol.REPL.Monad (
   , rethrowEvalError
 
     -- ** Environment
-  , getFocusedEnv, keepOne
+  , getFocusedEnv
   , getModuleEnv, setModuleEnv
   , getDynEnv, setDynEnv
   , uniqify, freshName
@@ -343,12 +343,6 @@ rPutStrLn str = rPutStr $ str ++ "\n"
 rPrint :: Show a => a -> REPL ()
 rPrint x = rPutStrLn (show x)
 
--- | Only meant for use with one of getVars or getTSyns.
-keepOne :: String -> [a] -> a
-keepOne src as = case as of
-  [a] -> a
-  _   -> panic ("REPL: " ++ src) ["name clash in interface file"]
-
 getFocusedEnv :: REPL (M.IfaceDecls,M.NamingEnv,NameDisp)
 getFocusedEnv  = do
   me <- getModuleEnv
@@ -384,17 +378,17 @@ getFocusedEnv  = do
 getVars :: REPL (Map.Map M.Name M.IfaceDecl)
 getVars  = do
   (decls,_,_) <- getFocusedEnv
-  return (keepOne "getVars" `fmap` M.ifDecls decls)
+  return (M.ifDecls decls)
 
 getTSyns :: REPL (Map.Map M.Name T.TySyn)
 getTSyns  = do
   (decls,_,_) <- getFocusedEnv
-  return (keepOne "getTSyns" `fmap` M.ifTySyns decls)
+  return (M.ifTySyns decls)
 
 getNewtypes :: REPL (Map.Map M.Name T.Newtype)
 getNewtypes = do
   (decls,_,_) <- getFocusedEnv
-  return (keepOne "getNewtypes" `fmap` M.ifNewtypes decls)
+  return (M.ifNewtypes decls)
 
 -- | Get visible variable names.
 getExprNames :: REPL [String]
@@ -410,7 +404,7 @@ getTypeNames  =
 getPropertyNames :: REPL ([M.Name],NameDisp)
 getPropertyNames =
   do (decls,_,names) <- getFocusedEnv
-     let xs = keepOne "getPropertyNames" `fmap` M.ifDecls decls
+     let xs = M.ifDecls decls
      return ([ x | (x,d) <- Map.toList xs,
                 T.PragmaProperty `elem` M.ifDeclPragmas d ], names)