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