Remove OldStyleParameters, which were unused

src/Cryptol/ModuleSystem/Base.hs

@@ -425,27 +425,8 @@ checkModule ::
   ImportSource -> ModulePath -> P.Module PName ->
   ModuleM (R.NamingEnv, T.Module)
 checkModule isrc path m = checkSingleModule T.tcModule isrc path m
-{-
-  case mDef m of
-    NormalModule _ -> 
-    FunctorInstanceAnon fmName _ ->
-      do mbtf <- getLoadedMaybe (thing fmName)
-         case mbtf of
-           Just tf ->
-             do renThis <- io $ newIORef (lmNamingEnv tf)
-                let how = T.tcModuleInst renThis (lmModule tf)
-                (_,m') <- checkSingleModule how isrc path m
-                newEnv <- io $ readIORef renThis
-                pure (newEnv,m')
-           Nothing -> panic "checkModule"
-                        [ "Functor of module instantiation not loaded" ]
 
-    -- XXX: functor instance; this is for top-level functor instances
--}
-
--- | Typecheck a single module.  If the module is an instantiation
--- of a functor, then this just type-checks the instantiating parameters.
--- See 'checkModule'
+-- | Typecheck a single module.
 checkSingleModule ::
   Act (P.Module Name) T.Module {- ^ how to check -} ->
   ImportSource                 {- ^ why are we loading this -} ->
@@ -499,7 +480,7 @@ checkSingleModule how isrc path m = do
                      , tcPrims  = prims }
 
 
-  tcm0 <- typecheck act (R.rmModule renMod) Nothing (R.rmImported renMod)
+  tcm0 <- typecheck act (R.rmModule renMod) mempty (R.rmImported renMod)
 
   let tcm = tcm0 -- fromMaybe tcm0 (addModParams tcm0)
 
@@ -553,7 +534,7 @@ data TCAction i o = TCAction
 
 typecheck ::
   (Show i, Show o, HasLoc i) =>
-  TCAction i o -> i -> Maybe IfaceFunctorParams -> IfaceDecls -> ModuleM o
+  TCAction i o -> i -> IfaceFunctorParams -> IfaceDecls -> ModuleM o
 typecheck act i params env = do
 
   let range = fromMaybe emptyRange (getLoc i)
@@ -582,9 +563,9 @@ typecheck act i params env = do
 
 -- | Generate input for the typechecker.
 genInferInput ::
-  Range -> PrimMap -> Maybe IfaceFunctorParams -> IfaceDecls ->
+  Range -> PrimMap -> IfaceFunctorParams -> IfaceDecls ->
   ModuleM T.InferInput
-genInferInput r prims mbParams env' = do
+genInferInput r prims params env = do
   seeds <- getNameSeeds
   monoBinds <- getMonoBinds
   solver <- getTCSolver
@@ -592,42 +573,33 @@ genInferInput r prims mbParams env' = do
   searchPath <- getSearchPath
   callStacks <- getCallStacks
 
-  -- TODO: include the environment needed by the module
-  let env = env'
-            -- XXX: we should really just pass this directly
-
-      (paramTys,paramCtrs,paramVs) =
-        case mbParams of
-          Nothing -> (mempty,mempty,mempty)
-          Just (OldStyle p) ->
-            (ifParamTypes p, ifParamConstraints p, ifParamFuns p)
-          Just (NewStyle p) ->
-            let ps = map ifmpParameters (Map.elems p)
-            in ( mconcat (map ifParamTypes ps)
-               , mconcat (map ifParamConstraints ps)
-               , mconcat (map ifParamFuns ps)
-               )
+  let (paramTys,paramCtrs,paramVs) =
+        let ps = map ifmpParameters (Map.elems params)
+        in ( mconcat (map ifParamTypes ps)
+           , mconcat (map ifParamConstraints ps)
+           , mconcat (map ifParamFuns ps)
+           )
 
   topMods <- getAllLoaded
 
   return T.InferInput
-    { T.inpRange     = r
-    , T.inpVars      = Map.map ifDeclSig (ifDecls env)
-    , T.inpTSyns     = ifTySyns env
-    , T.inpNewtypes  = ifNewtypes env
-    , T.inpAbstractTypes = ifAbstractTypes env
-    , T.inpSignatures = ifSignatures env
-    , T.inpNameSeeds = seeds
-    , T.inpMonoBinds = monoBinds
-    , T.inpCallStacks = callStacks
-    , T.inpSearchPath = searchPath
-    , T.inpSupply    = supply
-    , T.inpPrimNames = prims
+    { T.inpRange            = r
+    , T.inpVars             = Map.map ifDeclSig (ifDecls env)
+    , T.inpTSyns            = ifTySyns env
+    , T.inpNewtypes         = ifNewtypes env
+    , T.inpAbstractTypes    = ifAbstractTypes env
+    , T.inpSignatures       = ifSignatures env
+    , T.inpNameSeeds        = seeds
+    , T.inpMonoBinds        = monoBinds
+    , T.inpCallStacks       = callStacks
+    , T.inpSearchPath       = searchPath
+    , T.inpSupply           = supply
+    , T.inpPrimNames        = prims
     , T.inpParamTypes       = paramTys
     , T.inpParamConstraints = paramCtrs
     , T.inpParamFuns        = paramVs
     , T.inpSolver           = solver
-    , T.inpTopModules = topMods
+    , T.inpTopModules       = topMods
     }
 
 

src/Cryptol/ModuleSystem/Env.hs

@@ -187,7 +187,7 @@ allDeclGroups = concatMap T.mDecls . loadedNonParamModules
 -- | Contains enough information to browse what's in scope,
 -- or type check new expressions.
 data ModContext = ModContext
-  { mctxParams          :: Maybe IfaceFunctorParams
+  { mctxParams          :: IfaceFunctorParams
   , mctxExported        :: Set Name
   , mctxDecls           :: IfaceDecls
     -- ^ Should contain at least names in NamingEnv, but may have more
@@ -199,7 +199,7 @@ data ModContext = ModContext
 -- This instance is a bit bogus.  It is mostly used to add the dynamic
 -- environemnt to an existing module, and it makes sense for that use case.
 instance Semigroup ModContext where
-  x <> y = ModContext { mctxParams   = jnParams (mctxParams x) (mctxParams y)
+  x <> y = ModContext { mctxParams   = mctxParams x <> mctxParams y
                       , mctxExported = mctxExported x <> mctxExported y
                       , mctxDecls    = mctxDecls x  <> mctxDecls  y
                       , mctxNames    = names
@@ -208,14 +208,9 @@ instance Semigroup ModContext where
 
       where
       names = mctxNames x `R.shadowing` mctxNames y
-      jnParams a b =
-        case (a,b) of
-          (Nothing,_) -> b
-          (_,Nothing) -> a
-          _ -> panic "ModContext" [ "Cannot combined 2 parameterized contexts" ]
 
 instance Monoid ModContext where
-  mempty = ModContext { mctxParams   = Nothing
+  mempty = ModContext { mctxParams   = mempty
                       , mctxDecls    = mempty
                       , mctxExported = mempty
                       , mctxNames    = mempty

src/Cryptol/ModuleSystem/Interface.hs

@@ -18,7 +18,7 @@ module Cryptol.ModuleSystem.Interface (
   , IfaceTySyn, ifTySynName
   , IfaceNewtype
   , IfaceDecl(..)
-  , IfaceFunctorParams(..)
+  , IfaceFunctorParams
   , IfaceParams(..)
   , IfaceModParam(..)
   , IfaceNames(..)
@@ -40,7 +40,6 @@ import           Data.Map(Map)
 import qualified Data.Map as Map
 import           Data.Semigroup
 import           Data.Text (Text)
-import           Data.Maybe(isJust)
 
 import GHC.Generics (Generic)
 import Control.DeepSeq
@@ -63,7 +62,7 @@ data IfaceG name = Iface
   { ifNames     :: IfaceNames name
   , ifPublic    :: IfaceDecls   -- ^ Exported definitions
   , ifPrivate   :: IfaceDecls
-  , ifParams    :: Maybe IfaceFunctorParams
+  , ifParams    :: IfaceFunctorParams
   } deriving (Show, Generic, NFData)
 
 -- XXX: signature
@@ -84,7 +83,7 @@ data IfaceNames name = IfaceNames
 
 
 ifaceIsFunctor :: IfaceG name -> Bool
-ifaceIsFunctor = isJust . ifParams
+ifaceIsFunctor = not . Map.null . ifParams
 
 emptyIface :: ModName -> Iface
 emptyIface nm = Iface
@@ -95,13 +94,10 @@ emptyIface nm = Iface
                            }
   , ifPublic  = mempty
   , ifPrivate = mempty
-  , ifParams  = Nothing
+  , ifParams  = mempty
   }
 
-data IfaceFunctorParams =
-    OldStyle IfaceParams
-  | NewStyle (Map Ident IfaceModParam)
-    deriving (Show, Generic, NFData)
+type IfaceFunctorParams = Map Ident IfaceModParam
 
 data IfaceModParam = IfaceModParam
   { ifmpName        :: Ident

src/Cryptol/REPL/Browse.hs

@@ -47,16 +47,10 @@ data DispInfo = DispInfo { dispHow :: BrowseHow, env :: NameDisp }
 --------------------------------------------------------------------------------
 
 
-browseMParams :: NameDisp -> Maybe IfaceFunctorParams -> [Doc]
-browseMParams disp mbParams =
-  case mbParams of
-    Nothing -> []
-    Just (OldStyle params) ->
-      ppSectionHeading "Module Parameters"
-      $ addEmpty
-      $ map ppParamTy (sortByName disp (Map.toList (ifParamTypes params))) ++
-        map ppParamFu (sortByName disp (Map.toList (ifParamFuns  params)))
-    Just (NewStyle params) ->
+browseMParams :: NameDisp -> IfaceFunctorParams -> [Doc]
+browseMParams disp params
+  | Map.null params = []
+  | otherwise =
       ppSectionHeading "Module Parameters"
       $ [ "parameter" <+> pp (ifmpName p) <+> ":" <+>
           "signature" <+> pp (ifmpSignature p) $$
@@ -73,10 +67,6 @@ browseMParams disp mbParams =
   ppParamFu p = nest 2 (sep [pp (T.mvpName p) <+> ":", pp (T.mvpType p)])
   -- XXX: should we print the constraints somewhere too?
 
-  addEmpty xs = case xs of
-                  [] -> []
-                  _  -> xs ++ ["    "]
-
 
 browseMods :: DispInfo -> IfaceDecls -> [Doc]
 browseMods disp decls =

src/Cryptol/REPL/Help.hs

@@ -74,7 +74,7 @@ showSigHelp env nameEnv name =
 
 
 showTypeHelp ::
-  Maybe M.IfaceFunctorParams -> M.IfaceDecls -> NameDisp -> T.Name -> REPL ()
+  M.IfaceFunctorParams -> M.IfaceDecls -> NameDisp -> T.Name -> REPL ()
 showTypeHelp mbParams env nameEnv name =
   fromMaybe (noInfo nameEnv name) $
   msum [ fromTySyn, fromPrimType, fromNewtype, fromTyParam ]
@@ -110,7 +110,8 @@ showTypeHelp mbParams env nameEnv name =
                  doShowFix (T.atFixitiy a)
                  doShowDocString (T.atDoc a)
 
-  fromTyParam =
+  fromTyParam = Nothing -- XXX
+{-
     do hasPs <- mbParams
        case hasPs of
          M.NewStyle {} -> undefined -- XXX
@@ -127,6 +128,7 @@ showTypeHelp mbParams env nameEnv name =
                              <+> pp (T.mtpKind p) ]
                            ++ ctrDoc
               return $ doShowTyHelp nameEnv decl (T.mtpDoc p)
+-}
 
 
 doShowTyHelp :: NameDisp -> Doc -> Maybe Text -> REPL ()
@@ -152,7 +154,7 @@ doShowFix fx =
 
 
 showValHelp ::
-  Maybe M.IfaceFunctorParams ->
+  M.IfaceFunctorParams ->
     M.IfaceDecls -> NameDisp -> P.PName -> T.Name -> REPL ()
 
 showValHelp mbParams env nameEnv qname name =
@@ -182,7 +184,8 @@ showValHelp mbParams env nameEnv qname name =
     do _ <- Map.lookup name (M.ifNewtypes env)
        return $ return ()
 
-  fromParameter =
+  fromParameter = Nothing -- XXX
+{-
     do hasPs <- mbParams
        case hasPs of
          M.NewStyle {} -> undefined -- XXX
@@ -198,6 +201,7 @@ showValHelp mbParams env nameEnv qname name =
 
                    doShowFix (T.mvpFixity p)
                    doShowDocString (T.mvpDoc p)
+-}
 
 
 doShowDocString :: Maybe Text -> REPL ()

src/Cryptol/TypeCheck/Interface.hs

@@ -76,22 +76,7 @@ genIfaceWithNames names m =
     , ifFunctors  = fPriv
     }
 
-  , ifParams =
-    if Map.null (mParams m)
-      then -- old style
-        let d = IfaceParams
-                  { ifParamTypes = mParamTypes m
-                  , ifParamConstraints = mParamConstraints m
-                  , ifParamFuns  = mParamFuns m
-                  , ifParamDoc = Nothing
-                  }
-        in if isEmptyIfaceParams d
-             then Nothing
-             else Just (OldStyle d)
-
-      else Just (NewStyle (mParams m))
-
-
+  , ifParams = mParams m
   }
   where
   pub = ifsPublic names