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

Labels are re-entered into the ValueEnv after qualification

parent 446b09a5
......@@ -959,10 +959,13 @@ lookupIdType qid = do
aEnv <- gets typeEnvE
lt <- gets localTypes
ct <- gets constrTypes
m <- gets moduleIdE
tyEnv <- gets typeEnvE
tcEnv <- gets tConsEnvE
case Map.lookup qid lt `mplus` Map.lookup qid ct of
Just t -> trace' ("lookupIdType local " ++ show (qid, t)) $ liftM Just (visitType t) -- local name or constructor
Nothing -> case [ t | Value _ _ (ForAll _ t) <- qualLookupValue qid aEnv ] of
t : _ -> liftM Just (visitType (translType t)) -- imported name
t : _ -> liftM Just (visitType (translType m tyEnv tcEnv t)) -- imported name
[] -> case qualidMod qid of
Nothing -> trace' ("no type for " ++ show qid) $ return Nothing -- no known type
Just _ -> lookupIdType qid {qualidMod = Nothing}
......
......@@ -461,9 +461,17 @@ expandValueEnv opts env
tcEnv = tyConsEnv env
tyEnv = valueEnv env
enabled = Records `elem` optExtensions opts
tyEnv' = fmap (expandRecordTypes tcEnv) tyEnv -- $ addImportedLabels m lEnv tyEnv
-- m = moduleIdent env
-- lEnv = labelEnv 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.
addImportedLabels :: ModuleIdent -> ValueEnv -> ValueEnv
addImportedLabels m tyEnv = foldr addLabelType tyEnv (allImports tyEnv)
where
addLabelType (_, Label l r ty) = importTopEnv (fromMaybe m (qualidMod r))
(unqualify l) (Label l r ty)
addLabelType _ = id
expandRecordTypes :: TCEnv -> ValueInfo -> ValueInfo
expandRecordTypes tcEnv (DataConstructor qid a (ForAllExist n m ty)) =
......@@ -526,11 +534,3 @@ expandRecords _ ty = ty
-- isImported r (Import r' ) = r == r'
-- isImported r (ImportTypeWith r' _) = r == r'
-- isImported r (ImportTypeAll r' ) = r == r'
-- addImportedLabels :: ModuleIdent -> LabelEnv -> ValueEnv -> ValueEnv
-- addImportedLabels m lEnv tyEnv =
-- foldr addLabelType tyEnv (concat $ Map.elems lEnv)
-- where
-- addLabelType (LabelType l r ty) = importTopEnv m' l lblInfo
-- where lblInfo = Label (qualify l) (qualQualify m' r) (polyType ty)
-- m' = fromMaybe m (qualidMod r)
......@@ -12,12 +12,16 @@
-}
module Transformations where
import Curry.Base.Ident
import Curry.Syntax
import Base.Types
import Env.Value
import Env.TypeConstructor
import Transformations.CaseCompletion as CC (completeCase)
import Transformations.CurryToIL as IL (ilTrans, translType)
import Transformations.CurryToIL as IL (ilTrans, translType')
import Transformations.Desugar as DS (desugar)
import Transformations.Lift as L (lift)
import Transformations.Qual as Q (qual)
......@@ -38,8 +42,8 @@ ilTrans flat mdl env = (il, env)
where il = IL.ilTrans flat (valueEnv env) (tyConsEnv env) (evalAnnotEnv env) mdl
-- |Translate a type into its representation in the intermediate language
translType :: Type -> IL.Type
translType = IL.translType
translType :: ModuleIdent -> ValueEnv -> TCEnv -> Type -> IL.Type
translType = IL.translType'
-- |Remove syntactic sugar
desugar :: Module -> CompilerEnv -> (Module, CompilerEnv)
......
......@@ -18,7 +18,7 @@ data structures, we can use only a qualified import for the
\texttt{IL} module.
\begin{verbatim}
> module Transformations.CurryToIL (ilTrans, translType) where
> module Transformations.CurryToIL (ilTrans, translType') where
> import Data.List (nub, partition)
> import qualified Data.Map as Map (Map, empty, insert, lookup)
......@@ -170,7 +170,7 @@ them back into their corresponding type constructors.
> IL.TypeArrow (translType ty1) (translType ty2)
> translType (TypeSkolem k) =
> IL.TypeConstructor (qualify (mkIdent ("_" ++ show k))) []
> translType (TypeRecord _ _) = error "Translation of record not defined" -- TODO
> translType rec@(TypeRecord _ _) = error $ "Translation of record not defined: " ++ show rec -- TODO
> elimRecordTypes :: ModuleIdent -> ValueEnv -> TCEnv -> Int -> Type -> Type
> elimRecordTypes m tyEnv tcEnv n (TypeConstructor t tys) =
......
......@@ -430,11 +430,12 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> case (lookupValue l tyEnv) of
> [Label _ r _] -> desugarRecordConstr p r fs'
> _ -> internalError "Desugar.desugarExpr: illegal record construction"
> desugarExpr p (RecordSelection e l) =
> do tyEnv <- getValueEnv
> case lookupValue l tyEnv of
> [Label _ r _] -> desugarRecordSelection p r l e
> _ -> internalError "Desugar.desugarExpr: illegal record selection"
> desugarExpr p (RecordSelection e l) = do
> tyEnv <- getValueEnv
> case lookupValue l tyEnv of
> [Label _ r _] -> desugarRecordSelection p r l e
> other -> internalError $ "Desugar.desugarExpr: "
> ++ "Illegal record selection, " ++ show l ++ " could only be resolved to " ++ show other ++ "\n" ++ show tyEnv
> desugarExpr p (RecordUpdate fs rexpr)
> | null fs = internalError "Desugar.desugarExpr: empty record update"
> | otherwise = do
......
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