Commit 6bef7507 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Env refactorings adapted

parent e19d83c9
...@@ -33,11 +33,11 @@ is computed. ...@@ -33,11 +33,11 @@ is computed.
> import Base.CurryTypes (fromQualType) > import Base.CurryTypes (fromQualType)
> import Base.Messages (errorAt', internalError) > import Base.Messages (errorAt', internalError)
> import Base.TopEnv
> import Base.Types > import Base.Types
> import Base.Utils (findDouble) > import Base.Utils (findDouble)
> import Env.OpPrec (PEnv, PrecInfo (..), OpPrec (..), qualLookupP) > import Env.OpPrec (PEnv, PrecInfo (..), OpPrec (..), qualLookupP)
> import Env.TopEnv
> import Env.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC) > import Env.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
> import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue) > import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
......
...@@ -50,7 +50,7 @@ parse fn src = parseModule True fn src >>= genCurrySyntax fn ...@@ -50,7 +50,7 @@ parse fn src = parseModule True fn src >>= genCurrySyntax fn
-} -}
fullParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad Module) fullParse :: [FilePath] -> FilePath -> String -> IO (MsgMonad Module)
fullParse paths fn src = fullParse paths fn src =
genFullCurrySyntax simpleCheckModule paths fn $ parse fn src genFullCurrySyntax checkModule paths fn $ parse fn src
{- |Behaves like 'fullParse', but returns the syntax tree of the source {- |Behaves like 'fullParse', but returns the syntax tree of the source
program 'src' (type 'Module'; see Module "CurrySyntax") after inferring program 'src' (type 'Module'; see Module "CurrySyntax") after inferring
...@@ -76,8 +76,8 @@ genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do ...@@ -76,8 +76,8 @@ genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do
then do then do
iEnv <- loadInterfaces paths mod1 iEnv <- loadInterfaces paths mod1
let env = importModules opts mod1 iEnv let env = importModules opts mod1 iEnv
(_, mod', _, msgs') = check opts env mod1 (_, mod', _, msgs) = check opts env mod1
return (tell msgs' >> return mod') return (tell msgs >> return mod')
else return $ failWith $ head errs else return $ failWith $ head errs
where opts = mkOpts paths where opts = mkOpts paths
......
...@@ -18,10 +18,10 @@ import Curry.Syntax ...@@ -18,10 +18,10 @@ import Curry.Syntax
import Base.CurryTypes (fromType) import Base.CurryTypes (fromType)
import Base.Messages (internalError, errorAt) import Base.Messages (internalError, errorAt)
import Base.TopEnv
import Base.Types import Base.Types
import Env.TypeConstructors (TCEnv, lookupTC) import Env.TypeConstructors (TCEnv, lookupTC)
import Env.TopEnv
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue) import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
......
...@@ -25,14 +25,14 @@ import qualified Curry.Syntax as CS ...@@ -25,14 +25,14 @@ import qualified Curry.Syntax as CS
-- Base -- Base
import Base.Messages (internalError) import Base.Messages (internalError)
import Base.ScopeEnv (ScopeEnv)
import qualified Base.ScopeEnv as ScopeEnv
import Base.TopEnv (topEnvMap)
import Base.Types import Base.Types
-- environments -- environments
import Env.Arity (ArityEnv, ArityInfo (..), lookupArity, qualLookupArity) import Env.Arity (ArityEnv, ArityInfo (..), lookupArity, qualLookupArity)
import Env.Interface import Env.Interface
import Env.ScopeEnv (ScopeEnv)
import qualified Env.ScopeEnv as ScopeEnv
import Env.TopEnv (topEnvMap)
import Env.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC) import Env.TypeConstructors (TCEnv, TypeInfo (..), qualLookupTC)
import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue) import Env.Value (ValueEnv, ValueInfo (..), lookupValue, qualLookupValue)
......
...@@ -25,13 +25,13 @@ import Curry.Syntax ...@@ -25,13 +25,13 @@ import Curry.Syntax
import Base.CurryTypes (toQualType, toQualTypes) import Base.CurryTypes (toQualType, toQualTypes)
import Base.Messages (internalError, errorAt') import Base.Messages (internalError, errorAt')
import Base.TopEnv
import Base.Types import Base.Types
import Env.Arity import Env.Arity
import Env.Interface import Env.Interface
import Env.ModuleAlias import Env.ModuleAlias
import Env.OpPrec import Env.OpPrec
import Env.TopEnv
import Env.TypeConstructors import Env.TypeConstructors
import Env.Value import Env.Value
......
...@@ -24,12 +24,12 @@ import Curry.Syntax ...@@ -24,12 +24,12 @@ import Curry.Syntax
import Base.CurryTypes (toType) import Base.CurryTypes (toType)
import Base.Messages import Base.Messages
import Base.TopEnv
import Base.Types import Base.Types
import Base.TypeSubst import Base.TypeSubst
import Env.Interface import Env.Interface
import Env.Label import Env.Label
import Env.TopEnv
import Env.TypeConstructors import Env.TypeConstructors
import Env.Value import Env.Value
...@@ -94,10 +94,10 @@ addImportedLabels m lEnv tyEnv = ...@@ -94,10 +94,10 @@ addImportedLabels m lEnv tyEnv =
recordExpansion1 :: Options -> CompilerEnv -> CompilerEnv recordExpansion1 :: Options -> CompilerEnv -> CompilerEnv
recordExpansion1 opts env recordExpansion1 opts env
| withExt = env { tyConsEnv = tcEnv', valueEnv = tyEnv' } | enabled = env { tyConsEnv = tcEnv', valueEnv = tyEnv' }
| otherwise = env | otherwise = env
where where
withExt = BerndExtension `elem` optExtensions opts enabled = Records `elem` optExtensions opts
tcEnv' = fmap (expandRecordTC tcEnv) tcEnv tcEnv' = fmap (expandRecordTC tcEnv) tcEnv
tyEnv' = fmap (expandRecordTypes tcEnv) tyEnvLbl tyEnv' = fmap (expandRecordTypes tcEnv) tyEnvLbl
tyEnvLbl = addImportedLabels m lEnv tyEnv tyEnvLbl = addImportedLabels m lEnv tyEnv
...@@ -108,10 +108,10 @@ recordExpansion1 opts env ...@@ -108,10 +108,10 @@ recordExpansion1 opts env
recordExpansion2 :: Options -> CompilerEnv -> CompilerEnv recordExpansion2 :: Options -> CompilerEnv -> CompilerEnv
recordExpansion2 opts env recordExpansion2 opts env
| withExt = env { valueEnv = tyEnv' } | enabled = env { valueEnv = tyEnv' }
| otherwise = env | otherwise = env
where where
withExt = BerndExtension `elem` optExtensions opts enabled = Records `elem` optExtensions opts
tyEnv' = fmap (expandRecordTypes tcEnv) tyEnvLbl tyEnv' = fmap (expandRecordTypes tcEnv) tyEnvLbl
tyEnvLbl = addImportedLabels m lEnv tyEnv tyEnvLbl = addImportedLabels m lEnv tyEnv
m = moduleIdent env m = moduleIdent env
...@@ -128,6 +128,8 @@ expandRecordTC tcEnv (DataType qid n args) = ...@@ -128,6 +128,8 @@ expandRecordTC tcEnv (DataType qid n args) =
DataType qid n (map (maybe Nothing (Just . (expandData tcEnv))) args) DataType qid n (map (maybe Nothing (Just . (expandData tcEnv))) args)
expandRecordTC tcEnv (RenamingType qid n (DataConstr ident m [ty])) = expandRecordTC tcEnv (RenamingType qid n (DataConstr ident m [ty])) =
RenamingType qid n (DataConstr ident m [expandRecords tcEnv ty]) RenamingType qid n (DataConstr ident m [expandRecords tcEnv ty])
expandRecordTC _ (RenamingType _ _ (DataConstr _ _ _)) =
internalError "Records.expandRecordTC"
expandRecordTC tcEnv (AliasType qid n ty) = expandRecordTC tcEnv (AliasType qid n ty) =
AliasType qid n (expandRecords tcEnv ty) AliasType qid n (expandRecords tcEnv ty)
......
...@@ -51,8 +51,8 @@ lift mdl env = (mdl', env { valueEnv = tyEnv', evalAnnotEnv = eEnv', arityEnv = ...@@ -51,8 +51,8 @@ lift mdl env = (mdl', env { valueEnv = tyEnv', evalAnnotEnv = eEnv', arityEnv =
= L.lift (valueEnv env) (evalAnnotEnv env) (arityEnv env) mdl = L.lift (valueEnv env) (evalAnnotEnv env) (arityEnv env) mdl
-- |Fully qualify used constructors and functions -- |Fully qualify used constructors and functions
qual :: Module -> CompilerEnv -> (Module, CompilerEnv) qual :: CompilerEnv -> Module -> (CompilerEnv, Module)
qual (Module m es is ds) env = (Module m es is ds', env) qual env (Module m es is ds) = (env, Module m es is ds')
where ds' = Q.qual (moduleIdent env) (valueEnv env) ds where ds' = Q.qual (moduleIdent env) (valueEnv env) ds
-- |Simplify the source code -- |Simplify the source code
......
...@@ -10,15 +10,17 @@ ...@@ -10,15 +10,17 @@
module Transformations.CaseCompletion (completeCase) where module Transformations.CaseCompletion (completeCase) where
import Prelude hiding (mod) import Prelude hiding (mod)
import Data.Maybe (fromJust, fromMaybe, isJust) import Data.Maybe (catMaybes, fromMaybe)
import Curry.Base.Position (SrcRef) import Curry.Base.Position (SrcRef)
import Curry.Base.Ident import Curry.Base.Ident
import qualified Curry.Syntax import qualified Curry.Syntax
import Base.OldScopeEnv as ScopeEnv
(ScopeEnv, newScopeEnv, beginScope, insertIdent, genIdentList)
import Env.Interface (InterfaceEnv, lookupInterface) import Env.Interface (InterfaceEnv, lookupInterface)
import Env.OldScopeEnv as ScopeEnv
(ScopeEnv, beginScope, genIdentList, insertIdent, newScopeEnv)
import IL import IL
type Message = String type Message = String
...@@ -583,8 +585,7 @@ getCCFromIDecls mident constrs (Curry.Syntax.Interface _ _ idecls) ...@@ -583,8 +585,7 @@ getCCFromIDecls mident constrs (Curry.Syntax.Interface _ _ idecls)
p_declaresIConstr qident idecl p_declaresIConstr qident idecl
= case idecl of = case idecl of
Curry.Syntax.IDataDecl _ _ _ cdecls Curry.Syntax.IDataDecl _ _ _ cdecls
-> any (p_isIConstrDecl qident) -> any (p_isIConstrDecl qident) $ catMaybes cdecls
(map fromJust (filter isJust cdecls))
Curry.Syntax.INewtypeDecl _ _ _ ncdecl Curry.Syntax.INewtypeDecl _ _ _ ncdecl
-> p_isINewConstrDecl qident ncdecl -> p_isINewConstrDecl qident ncdecl
_ -> False _ -> False
...@@ -600,7 +601,7 @@ getCCFromIDecls mident constrs (Curry.Syntax.Interface _ _ idecls) ...@@ -600,7 +601,7 @@ getCCFromIDecls mident constrs (Curry.Syntax.Interface _ _ idecls)
p_extractIConstrDecls idecl p_extractIConstrDecls idecl
= case idecl of = case idecl of
Curry.Syntax.IDataDecl _ _ _ cdecls Curry.Syntax.IDataDecl _ _ _ cdecls
-> map fromJust (filter isJust cdecls) -> catMaybes cdecls
_ -> [] _ -> []
p_getIConstrDeclInfo mid (Curry.Syntax.ConstrDecl _ _ ident types) p_getIConstrDeclInfo mid (Curry.Syntax.ConstrDecl _ _ ident types)
......
...@@ -30,11 +30,11 @@ lifted to the top-level. ...@@ -30,11 +30,11 @@ lifted to the top-level.
> import Base.Expr > import Base.Expr
> import Base.Messages (internalError) > import Base.Messages (internalError)
> import Base.SCC > import Base.SCC
> import Base.TopEnv
> import Base.Types > import Base.Types
> import Env.Arity > import Env.Arity
> import Env.Eval > import Env.Eval
> import Env.TopEnv
> import Env.Value > import Env.Value
> lift :: ValueEnv -> EvalEnv -> ArityEnv -> Module > lift :: ValueEnv -> EvalEnv -> ArityEnv -> Module
......
...@@ -4,18 +4,17 @@ ...@@ -4,18 +4,17 @@
% See LICENSE for the full license. % See LICENSE for the full license.
% %
% Modified by Martin Engelke (men@informatik.uni-kiel.de) % Modified by Martin Engelke (men@informatik.uni-kiel.de)
% Modified by Björn Peemöller (bjp@informatik.uni-kiel.de)
% %
\nwfilename{Qual.lhs} \nwfilename{Qual.lhs}
\section{Proper Qualification} \section{Proper Qualification}
After checking the module and before starting the translation into the After checking the module and before starting the translation into the
intermediate language, the compiler properly qualifies all intermediate language, the compiler properly qualifies all type constructors,
constructors and (global) functions occurring in a pattern or data constructors and (global) functions occurring in a pattern or
expression such that their module prefix matches the module of their expression such that their module prefix matches the module of their
definition. This is done also for functions and constructors declared definition. This is done also for functions and constructors declared
in the current module. Only functions and variables declared in local in the current module. Only functions and variables declared in local
declarations groups as well as function arguments remain unchanged. declarations groups as well as function arguments remain unchanged.
\em{Note:} The modified version also qualifies type constructors
\begin{verbatim} \begin{verbatim}
> module Transformations.Qual (qual) where > module Transformations.Qual (qual) where
...@@ -23,7 +22,8 @@ declarations groups as well as function arguments remain unchanged. ...@@ -23,7 +22,8 @@ declarations groups as well as function arguments remain unchanged.
> import Curry.Base.Ident > import Curry.Base.Ident
> import Curry.Syntax > import Curry.Syntax
> import Env.TopEnv > import Base.TopEnv
> import Env.Value (ValueEnv, qualLookupValue) > import Env.Value (ValueEnv, qualLookupValue)
> qual :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl] > qual :: ModuleIdent -> ValueEnv -> [Decl] -> [Decl]
...@@ -31,46 +31,41 @@ declarations groups as well as function arguments remain unchanged. ...@@ -31,46 +31,41 @@ declarations groups as well as function arguments remain unchanged.
> qualDecl :: ModuleIdent -> ValueEnv -> Decl -> Decl > qualDecl :: ModuleIdent -> ValueEnv -> Decl -> Decl
> qualDecl m tyEnv (FunctionDecl p f eqs) = > qualDecl m tyEnv (FunctionDecl p f eqs) =
> FunctionDecl p f (map (qualEqn m tyEnv) eqs) > FunctionDecl p f $ map (qualEqn m tyEnv) eqs
> qualDecl m tyEnv (PatternDecl p t rhs) = > qualDecl m tyEnv (PatternDecl p t rhs) =
> PatternDecl p (qualTerm m tyEnv t) (qualRhs m tyEnv rhs) > PatternDecl p (qualTerm m tyEnv t) (qualRhs m tyEnv rhs)
> qualDecl _ _ d = d > qualDecl _ _ d = d
> qualEqn :: ModuleIdent -> ValueEnv -> Equation -> Equation > qualEqn :: ModuleIdent -> ValueEnv -> Equation -> Equation
> qualEqn m tyEnv (Equation p lhs rhs) = > qualEqn m tyEnv (Equation p lhs rhs) =
> Equation p (qualLhs m tyEnv lhs) (qualRhs m tyEnv rhs) > Equation p (qualLhs m tyEnv lhs) (qualRhs m tyEnv rhs)
> qualLhs :: ModuleIdent -> ValueEnv -> Lhs -> Lhs > qualLhs :: ModuleIdent -> ValueEnv -> Lhs -> Lhs
> qualLhs m tyEnv (FunLhs f ts) = FunLhs f (map (qualTerm m tyEnv) ts) > qualLhs m tyEnv (FunLhs f ts) = FunLhs f $ map (qualTerm m tyEnv) ts
> qualLhs m tyEnv (OpLhs t1 op t2) = > qualLhs m tyEnv (OpLhs t1 op t2) =
> OpLhs (qualTerm m tyEnv t1) op (qualTerm m tyEnv t2) > OpLhs (qualTerm m tyEnv t1) op (qualTerm m tyEnv t2)
> qualLhs m tyEnv (ApLhs lhs ts) = > qualLhs m tyEnv (ApLhs lhs ts) =
> ApLhs (qualLhs m tyEnv lhs) (map (qualTerm m tyEnv) ts) > ApLhs (qualLhs m tyEnv lhs) (map (qualTerm m tyEnv) ts)
> qualTerm :: ModuleIdent -> ValueEnv -> ConstrTerm -> ConstrTerm > qualTerm :: ModuleIdent -> ValueEnv -> ConstrTerm -> ConstrTerm
> qualTerm _ _ (LiteralPattern l) = LiteralPattern l > qualTerm _ _ (LiteralPattern l) = LiteralPattern l
> qualTerm _ _ (NegativePattern op l) = NegativePattern op l > qualTerm _ _ (NegativePattern op l) = NegativePattern op l
> qualTerm _ _ (VariablePattern v) = VariablePattern v > qualTerm _ _ (VariablePattern v) = VariablePattern v
> qualTerm m tyEnv (ConstructorPattern c ts) = > qualTerm m tyEnv (ConstructorPattern c ts) =
> ConstructorPattern (qualIdent m tyEnv c) (map (qualTerm m tyEnv) ts) > ConstructorPattern (qualIdent m tyEnv c) (map (qualTerm m tyEnv) ts)
> qualTerm m tyEnv (InfixPattern t1 op t2) = > qualTerm m tyEnv (InfixPattern t1 op t2) =
> InfixPattern (qualTerm m tyEnv t1) > InfixPattern (qualTerm m tyEnv t1) (qualIdent m tyEnv op) (qualTerm m tyEnv t2)
> (qualIdent m tyEnv op) > qualTerm m tyEnv (ParenPattern t) = ParenPattern (qualTerm m tyEnv t)
> (qualTerm m tyEnv t2) > qualTerm m tyEnv (TuplePattern p ts) = TuplePattern p (map (qualTerm m tyEnv) ts)
> qualTerm m tyEnv (ParenPattern t) = ParenPattern (qualTerm m tyEnv t) > qualTerm m tyEnv (ListPattern p ts) = ListPattern p (map (qualTerm m tyEnv) ts)
> qualTerm m tyEnv (TuplePattern p ts) = TuplePattern p (map (qualTerm m tyEnv) ts) > qualTerm m tyEnv (AsPattern v t) = AsPattern v (qualTerm m tyEnv t)
> qualTerm m tyEnv (ListPattern p ts) = ListPattern p (map (qualTerm m tyEnv) ts) > qualTerm m tyEnv (LazyPattern p t) = LazyPattern p (qualTerm m tyEnv t)
> qualTerm m tyEnv (AsPattern v t) = AsPattern v (qualTerm m tyEnv t) > qualTerm m tyEnv (FunctionPattern f ts) =
> qualTerm m tyEnv (LazyPattern p t) = LazyPattern p (qualTerm m tyEnv t)
> qualTerm m tyEnv (FunctionPattern f ts) =
> FunctionPattern (qualIdent m tyEnv f) (map (qualTerm m tyEnv) ts) > FunctionPattern (qualIdent m tyEnv f) (map (qualTerm m tyEnv) ts)
> qualTerm m tyEnv (InfixFuncPattern t1 op t2) = > qualTerm m tyEnv (InfixFuncPattern t1 op t2) =
> InfixFuncPattern (qualTerm m tyEnv t1) > InfixFuncPattern (qualTerm m tyEnv t1) (qualIdent m tyEnv op) (qualTerm m tyEnv t2)
> (qualIdent m tyEnv op) > qualTerm m tyEnv (RecordPattern fs rt) =
> (qualTerm m tyEnv t2) > RecordPattern (map (qualFieldPattern m tyEnv) fs) ((qualTerm m tyEnv) `fmap` rt)
> qualTerm m tyEnv (RecordPattern fs rt) =
> RecordPattern (map (qualFieldPattern m tyEnv) fs)
> (maybe Nothing (Just . qualTerm m tyEnv) rt)
> qualFieldPattern :: ModuleIdent -> ValueEnv -> Field ConstrTerm > qualFieldPattern :: ModuleIdent -> ValueEnv -> Field ConstrTerm
> -> Field ConstrTerm > -> Field ConstrTerm
...@@ -148,17 +143,16 @@ declarations groups as well as function arguments remain unchanged. ...@@ -148,17 +143,16 @@ declarations groups as well as function arguments remain unchanged.
> qualFieldExpr m tyEnv (Field p l e) = Field p l (qualExpr m tyEnv e) > qualFieldExpr m tyEnv (Field p l e) = Field p l (qualExpr m tyEnv e)
> qualOp :: ModuleIdent -> ValueEnv -> InfixOp -> InfixOp > qualOp :: ModuleIdent -> ValueEnv -> InfixOp -> InfixOp
> qualOp m tyEnv (InfixOp op) = InfixOp (qualIdent m tyEnv op) > qualOp m tyEnv (InfixOp op) = InfixOp (qualIdent m tyEnv op)
> qualOp m tyEnv (InfixConstr op) = InfixConstr (qualIdent m tyEnv op) > qualOp m tyEnv (InfixConstr op) = InfixConstr (qualIdent m tyEnv op)
> qualIdent :: ModuleIdent -> ValueEnv -> QualIdent -> QualIdent > qualIdent :: ModuleIdent -> ValueEnv -> QualIdent -> QualIdent
> qualIdent m tyEnv x > qualIdent m tyEnv x
> | not (isQualified x) && uniqueId (unqualify x) /= 0 = x > | not (isQualified x) && uniqueId (unqualify x) /= 0 = x
> | otherwise = > | otherwise = case qualLookupValue x tyEnv of
> case (qualLookupValue x tyEnv) of > [y] -> origName y
> [y] -> origName y > _ -> case qualLookupValue (qualQualify m x) tyEnv of
> _ -> case (qualLookupValue (qualQualify m x) tyEnv) of > [y] -> origName y
> [y] -> origName y > _ -> qualQualify m x
> _ -> qualQualify m x
\end{verbatim} \end{verbatim}
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