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