mirror of
https://github.com/GaloisInc/cryptol.git
synced 2024-09-11 14:06:13 +03:00
Remove OldStyleParameters, which were unused
This commit is contained in:
parent
07ca544268
commit
6a1f12e42c
@ -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
|
||||
}
|
||||
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 =
|
||||
|
@ -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 ()
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user