Commit 351dbd78 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Removed bug in handling of {-# LANGUAGE Records #-} pragma

parent ff313cf9
......@@ -17,6 +17,7 @@ import qualified Data.Map as Map (Map, keys, toList)
import Curry.Base.Ident (ModuleIdent)
import Curry.Base.Pretty
import Curry.Syntax
import Base.TopEnv (allLocalBindings)
......@@ -30,18 +31,20 @@ import Env.Value
-- compiled. The information is updated during the different stages of
-- compilation.
data CompilerEnv = CompilerEnv
{ moduleIdent :: ModuleIdent -- ^ identifier of the module
, interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces
, aliasEnv :: AliasEnv -- ^ aliases for imported modules
, tyConsEnv :: TCEnv -- ^ type constructors
, valueEnv :: ValueEnv -- ^ functions and data constructors
, opPrecEnv :: OpPrecEnv -- ^ operator precedences
{ moduleIdent :: ModuleIdent -- ^ identifier of the module
, extensions :: [KnownExtension] -- ^ enabled language extensions
, interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces
, aliasEnv :: AliasEnv -- ^ aliases for imported modules
, tyConsEnv :: TCEnv -- ^ type constructors
, valueEnv :: ValueEnv -- ^ functions and data constructors
, opPrecEnv :: OpPrecEnv -- ^ operator precedences
}
-- |Initial 'CompilerEnv'
initCompilerEnv :: ModuleIdent -> CompilerEnv
initCompilerEnv mid = CompilerEnv
{ moduleIdent = mid
, extensions = []
, interfaceEnv = initInterfaceEnv
, aliasEnv = initAliasEnv
, tyConsEnv = initTCEnv
......@@ -52,13 +55,14 @@ initCompilerEnv mid = CompilerEnv
-- |Show the 'CompilerEnv'
showCompilerEnv :: CompilerEnv -> String
showCompilerEnv env = show $ vcat
[ header "ModuleIdent " $ textS $ moduleIdent env
, header "Interfaces " $ hcat $ punctuate comma $ map textS
$ Map.keys $ interfaceEnv env
, header "ModuleAliases " $ ppMap $ aliasEnv env
, header "TypeConstructors" $ ppAL $ allLocalBindings $ tyConsEnv env
, header "Values " $ ppAL $ allLocalBindings $ valueEnv env
, header "Precedences " $ ppAL $ allLocalBindings $ opPrecEnv env
[ header "ModuleIdent " $ textS $ moduleIdent env
, header "Language Etensions" $ text $ show $ extensions env
, header "Interfaces " $ hcat $ punctuate comma $ map textS
$ Map.keys $ interfaceEnv env
, header "ModuleAliases " $ ppMap $ aliasEnv env
, header "TypeConstructors " $ ppAL $ allLocalBindings $ tyConsEnv env
, header "Values " $ ppAL $ allLocalBindings $ valueEnv env
, header "Precedences " $ ppAL $ allLocalBindings $ opPrecEnv env
]
where
header hdr content = hang (text hdr <+> colon) 4 content
......
......@@ -45,14 +45,15 @@ import CompilerOpts
-- |The function 'importModules' brings the declarations of all
-- imported interfaces into scope for the current module.
importModules :: Monad m => Options -> Module -> InterfaceEnv -> CYT m CompilerEnv
importModules opts (Module _ mid _ imps _) iEnv
importModules opts mdl@(Module _ mid _ imps _) iEnv
= case foldl importModule (initEnv, []) imps of
(e, [] ) -> right $ expandTCValueEnv opts $ importUnifyData e
(_, errs) -> left errs
where
initEnv = (initCompilerEnv mid)
{ aliasEnv = importAliases imps -- import module aliases
, interfaceEnv = iEnv -- imported interfaces
{ aliasEnv = importAliases imps -- import module aliases
, interfaceEnv = iEnv -- imported interfaces
, extensions = knownExtensions mdl
}
importModule (env, msgs) (ImportDecl _ m q asM is) =
case Map.lookup m iEnv of
......@@ -74,7 +75,6 @@ importInterfaces opts (Interface m is _) iEnv
Nothing -> internalError $ "Imports.importInterfaces: no interface for "
++ show m
-- ---------------------------------------------------------------------------
-- Importing an interface into the module
-- ---------------------------------------------------------------------------
......@@ -497,7 +497,7 @@ expandTCValueEnv opts env
| enabled = env' { tyConsEnv = tcEnv' }
| otherwise = env
where
enabled = Records `elem` optExtensions opts
enabled = Records `elem` (optExtensions opts ++ extensions env)
tcEnv' = fmap (expandRecordTC tcEnv) tcEnv
tcEnv = tyConsEnv env'
env' = expandValueEnv opts env
......@@ -520,11 +520,11 @@ expandValueEnv opts env
| enabled = env { valueEnv = tyEnv' }
| otherwise = env
where
tcEnv = tyConsEnv env
tyEnv = valueEnv env
enabled = Records `elem` optExtensions opts
tyEnv' = fmap (expandRecordTypes tcEnv) $ addImportedLabels m tyEnv
m = moduleIdent env
tcEnv = tyConsEnv env
tyEnv = valueEnv env
enabled = Records `elem` (optExtensions opts ++ extensions env)
tyEnv' = fmap (expandRecordTypes tcEnv) $ addImportedLabels m tyEnv
m = moduleIdent env
-- TODO: This is necessary as currently labels are unqualified.
-- Without this additional import the labels would no longer be known.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment