Import of record fields now works, LabelEnv became obsolete

TODO

@@ -2,14 +2,15 @@ Completed
 =========
 - Anonymous free variables implemented
 - hierarchically structured modules
-
-Still to do
-===========
-- !!! Check correctness of created FlatCurry files by comparison with the old frontend !!!
 - Records: There is no way to explicitly import a record with its fields:
     import CompilerOpts                -- okay, works
     import CompilerOpts (Options)      -- okay, but no field labels imported
     import CompilerOpts (Options (..)) -- fails: Options is not a data type
+
+Still to do
+===========
+- !!! Check correctness of created FlatCurry files by comparison
+  !!! with the old frontend
 - Module pragmas
 - type classes
 - option to disable nondeterminism by overlapping

curry-frontend.cabal

@@ -65,7 +65,6 @@ Executable cymake
     , CurryDeps
     , Env.Eval
     , Env.Interface
-    , Env.Label
     , Env.ModuleAlias
     , Env.OpPrec
     , Env.TypeConstructors

src/CompilerEnv.hs

@@ -11,16 +11,12 @@
     This module defines an environment for a module containing the information
     needed throughout the compilation of the module.
 -}
-
--- TODO: rename to Base.ModuleEnv ?
-
 module CompilerEnv where
 
 import Curry.Base.Ident (ModuleIdent)
 
 import Env.Eval
 import Env.Interface
-import Env.Label
 import Env.ModuleAlias
 import Env.OpPrec
 import Env.TypeConstructors
@@ -34,7 +30,6 @@ data CompilerEnv = CompilerEnv
   , aliasEnv     :: AliasEnv     -- ^ aliases for imported modules
   , evalAnnotEnv :: EvalEnv      -- ^ evaluation annotations
   , interfaceEnv :: InterfaceEnv -- ^ declarations of imported interfaces
-  , labelEnv     :: LabelEnv     -- ^ record labels
   , opPrecEnv    :: PEnv         -- ^ operator precedences
   , tyConsEnv    :: TCEnv        -- ^ type constructors
   , valueEnv     :: ValueEnv     -- ^ functions and data constructors
@@ -46,7 +41,6 @@ initCompilerEnv mid = CompilerEnv
   , aliasEnv     = initAliasEnv
   , evalAnnotEnv = initEEnv
   , interfaceEnv = initInterfaceEnv
-  , labelEnv     = initLabelEnv
   , opPrecEnv    = initPEnv
   , tyConsEnv    = initTCEnv
   , valueEnv     = initDCEnv

src/Env/Label.hs

-{- |
-    Module      :  $Header$
-    Description :  Environment for record labels
-    Copyright   :  (c) 2002-2004, Wolfgang Lux
-                       2011, Björn Peemöller   (bjp@informatik.uni-kiel.de)
-    License     :  OtherLicense
-
-    Maintainer  :  bjp@informatik.uni-kiel.de
-    Stability   :  experimental
-    Portability :  portable
-
-    The label environment is used to store information of labels.
-    Unlike usual identifiers like in functions, types etc. identifiers
-    of labels are always represented unqualified. Since the common type
-    environment (type \texttt{ValueEnv}) has some problems with handling
-    imported unqualified identifiers, it is necessary to process the type
-    information for labels seperately.
--}
-module Env.Label where
-
-import qualified Data.Map as Map (Map, empty, insertWith)
-
-import Curry.Base.Ident (Ident, QualIdent)
-
-import Base.Types
-
-data LabelInfo = LabelType Ident QualIdent Type deriving Show
-
-type LabelEnv = Map.Map Ident [LabelInfo]
-
-initLabelEnv :: LabelEnv
-initLabelEnv = Map.empty
-
-bindLabelType :: Ident -> QualIdent -> Type -> LabelEnv -> LabelEnv
-bindLabelType l r ty = Map.insertWith (++) l [LabelType l r ty]

src/Imports.hs

@@ -35,19 +35,18 @@ import Env.Value
 
 import CompilerEnv
 import CompilerOpts
-import Records (importLabels, recordExpansion1, recordExpansion2)
+import Records (expandTCValueEnv, expandValueEnv)
 
 -- |The function 'importModules' brings the declarations of all
 -- imported interfaces into scope for the current module.
 importModules :: Options -> Module -> InterfaceEnv -> CompilerEnv
 importModules opts (Module mid _ imps _) iEnv
-  = recordExpansion1 opts
+  = expandTCValueEnv opts
   $ importUnifyData
   $ foldl importModule initEnv imps
   where
     initEnv = (initCompilerEnv mid)
       { aliasEnv     = importAliases     imps -- import module aliases
-      , labelEnv     = importLabels iEnv imps -- import record labels
       , interfaceEnv = iEnv                   -- imported interfaces
       }
     importModule env (ImportDecl _ m q asM is) = case Map.lookup m iEnv of
@@ -98,6 +97,16 @@ importInterface m q is i env = env
   ts = isVisible is (Set.fromList $ foldr addType  [] expandedSpec)
   vs = isVisible is (Set.fromList $ foldr addValue [] expandedSpec)
 
+addType :: Import -> [Ident] -> [Ident]
+addType (Import            _) tcs = tcs
+addType (ImportTypeWith tc _) tcs = tc : tcs
+addType (ImportTypeAll     _) _   = internalError "Imports.addType"
+
+addValue :: Import -> [Ident] -> [Ident]
+addValue (Import            f) fs = f : fs
+addValue (ImportTypeWith _ cs) fs = cs ++ fs
+addValue (ImportTypeAll     _) _  = internalError "Imports.addValue"
+
 isVisible :: Maybe ImportSpec -> Set.Set Ident -> Ident -> Bool
 isVisible (Just (Importing _ _)) xs = (`Set.member`    xs)
 isVisible (Just (Hiding    _ _)) xs = (`Set.notMember` xs)
@@ -185,7 +194,7 @@ bindTy m (INewtypeDecl _ tc tvs nc) env =
   bindNewConstr m tc' tvs (constrType tc' tvs) nc env
   where tc' = qualQualify m tc
 bindTy m (ITypeDecl _ r _ (RecordType fs _)) env =
-  foldr (bindRecLabel m r') env fs
+  foldr (bindRecordLabels m r') env fs
   where r' = qualifyWith m $ fromRecordExtId $ unqualify r
 bindTy m (IFunctionDecl _ f a ty) env = Map.insert (unqualify f)
   (Value (qualQualify m f) a (polyType (toQualType m [] ty))) env
@@ -213,11 +222,15 @@ constrType' m tvs evs ty = ForAllExist (length tvs) (length evs)
 qualifyLike :: QualIdent -> Ident -> QualIdent
 qualifyLike x = maybe qualify qualifyWith (qualidMod x)
 
-bindRecLabel :: ModuleIdent -> QualIdent -> ([Ident], TypeExpr) -> ExpValueEnv
-             -> ExpValueEnv
-bindRecLabel m r (ls, ty) env = foldr bindL env ls
+bindRecordLabels :: ModuleIdent -> QualIdent -> ([Ident], TypeExpr)
+                 -> ExpValueEnv -> ExpValueEnv
+bindRecordLabels m r (ls, ty) env = foldr bindLbl env ls
   where
-  bindL l = Map.insert l $ Label (qualify l) r $ polyType $ toQualType m [] ty
+  bindLbl l = Map.insert l (lblInfo l)
+  lblInfo l = Label (qualify l) r (polyType $ toQualType m [] ty)
+
+constrType :: QualIdent -> [Ident] -> TypeExpr
+constrType tc tvs = ConstructorType tc $ map VariableType tvs
 
 -- ---------------------------------------------------------------------------
 -- Expansion of the import specification
@@ -307,40 +320,33 @@ expandHide' m tyEnv f tcImport = case Map.lookup f tyEnv of
 
 expandTypeWith ::  ModuleIdent -> ExpTCEnv -> Ident -> [Ident] -> Import
 expandTypeWith m tcEnv tc cs = case Map.lookup tc tcEnv of
-  Just (DataType _ _ cs') -> ImportTypeWith tc
-    (map (checkConstr [c | Just (DataConstr c _ _) <- cs']) cs)
-  Just (RenamingType _ _ (DataConstr c _ _)) ->
-    ImportTypeWith tc (map (checkConstr [c]) cs)
-  Just _  -> errorMessage $ errNonDataType tc
-  Nothing -> errorMessage $ errUndefinedEntity m tc
+  Just (DataType     _ _                cs') -> ImportTypeWith tc $
+    map (checkConstr [c | Just (DataConstr c _ _) <- cs']) cs
+  Just (RenamingType _ _ (DataConstr c _ _)) -> ImportTypeWith tc $
+    map (checkConstr [c]) cs
+  Just (AliasType    _ _ (TypeRecord  fs _)) -> ImportTypeWith tc $
+    map (checkLabel [l | (l, _) <- fs] . renameLabel) cs
+  Just (AliasType _ _ _) -> errorMessage $ errNonDataType tc
+  Nothing                -> errorMessage $ errUndefinedEntity m tc
   where
-    checkConstr cs' c
-      | c `elem` cs' = c
-      | otherwise    = errorMessage $ errUndefinedDataConstr tc c
+  checkConstr cs' c
+    | c `elem` cs' = c
+    | otherwise    = errorMessage $ errUndefinedDataConstr tc c
+  checkLabel ls' l
+    | l `elem` ls' = l
+    | otherwise    = errorMessage $ errUndefinedLabel tc l
+
 
 expandTypeAll :: ModuleIdent -> ExpTCEnv -> Ident -> Import
 expandTypeAll m tcEnv tc = case Map.lookup tc tcEnv of
-  Just (DataType _ _ cs) ->
-    ImportTypeWith tc [c | Just (DataConstr c _ _) <- cs]
-  Just (RenamingType _ _ (DataConstr c _ _)) ->
-    ImportTypeWith tc [c]
-  Just _  -> errorMessage $ errNonDataType tc
-  Nothing -> errorMessage $ errUndefinedEntity m tc
-
--- Auxiliary functions:
-
-addType :: Import -> [Ident] -> [Ident]
-addType (Import            _) tcs = tcs
-addType (ImportTypeWith tc _) tcs = tc : tcs
-addType (ImportTypeAll     _) _   = internalError "Imports.addType"
-
-addValue :: Import -> [Ident] -> [Ident]
-addValue (Import            f) fs = f : fs
-addValue (ImportTypeWith _ cs) fs = cs ++ fs
-addValue (ImportTypeAll     _) _  = internalError "Imports.addValue"
-
-constrType :: QualIdent -> [Ident] -> TypeExpr
-constrType tc tvs = ConstructorType tc $ map VariableType tvs
+  Just (DataType     _ _                 cs) -> ImportTypeWith tc
+    [c | Just (DataConstr c _ _) <- cs]
+  Just (RenamingType _ _ (DataConstr c _ _)) -> ImportTypeWith tc
+    [c]
+  Just (AliasType    _ _ (TypeRecord  fs _)) -> ImportTypeWith tc
+    [l | (l, _) <- fs]
+  Just (AliasType _ _ _) -> errorMessage $ errNonDataType tc
+  Nothing                -> errorMessage $ errUndefinedEntity m tc
 
 -- ---------------------------------------------------------------------------
 
@@ -363,7 +369,7 @@ importUnifyData' tcEnv = fmap (setInfo allTyCons) tcEnv
 
 -- |
 qualifyEnv :: Options -> CompilerEnv -> CompilerEnv
-qualifyEnv opts env = recordExpansion2 opts
+qualifyEnv opts env = expandValueEnv opts
                     $ qualifyLocal env
                     $ foldl (flip importInterfaceIntf) initEnv
                     $ Map.elems
@@ -412,6 +418,10 @@ errUndefinedDataConstr :: Ident -> Ident -> Message
 errUndefinedDataConstr tc c = posErr c $
   name c ++ " is not a data constructor of type " ++ name tc
 
+errUndefinedLabel :: Ident -> Ident -> Message
+errUndefinedLabel tc c = posErr c $
+  name c ++ " is not a label of record type " ++ name tc
+
 errNonDataType :: Ident -> Message
 errNonDataType tc = posErr tc $ name tc ++ " is not a data type"
 

src/Records.hs

@@ -13,145 +13,123 @@
     /Note:/ the record types for the current module are expanded within the
     type check.
 -}
-module Records where
+module Records (expandTCValueEnv, expandValueEnv) where
 
-import Data.List (find)
-import qualified Data.Map as Map (lookup, elems)
-import Data.Maybe (fromMaybe)
-
-import Curry.Base.Ident
-import Curry.Syntax
-
-import Base.CurryTypes (toType)
-import Base.Messages
-import Base.TopEnv
+import Base.Messages (internalError)
 import Base.Types
-import Base.TypeSubst
+import Base.TypeSubst (expandAliasType)
 
-import Env.Interface
-import Env.Label
 import Env.TypeConstructors
 import Env.Value
 
 import CompilerEnv
 import CompilerOpts
 
--- ---------------------------------------------------------------------------
--- Import defined record labels
--- ---------------------------------------------------------------------------
-
--- Unlike usual identifiers like in functions, types etc., identifiers
--- of labels are always represented unqualified within the whole context
--- of compilation. Since the common type environment (type \texttt{ValueEnv})
--- has some problems with handling imported unqualified identifiers, it is
--- necessary to add the type information for labels seperately. For this reason
--- the function \texttt{importLabels} generates an environment containing
--- all imported labels and the function \texttt{addImportedLabels} adds this
--- content to a value environment.
-
-importLabels :: InterfaceEnv -> [ImportDecl] -> LabelEnv
-importLabels mEnv ds = foldl importLabelTypes initLabelEnv ds
-  where
-  importLabelTypes :: LabelEnv -> ImportDecl -> LabelEnv
-  importLabelTypes lEnv (ImportDecl p m _ asM is) = case Map.lookup m mEnv of
-    Just (Interface _ _ ds') -> 
-      foldl (importLabelType p (fromMaybe m asM) is) lEnv ds'
-    Nothing  -> 
-      internalError "Records.importLabels"
-
-  importLabelType p m is lEnv (ITypeDecl _ r _ (RecordType fs _)) =
-    foldl (insertLabelType p m r' (getImportSpec r' is)) lEnv fs
-    where r' = qualifyWith m (fromRecordExtId (unqualify r))
-  importLabelType _ _ _  lEnv _ = lEnv
-
-  insertLabelType _ _ r (Just (ImportTypeAll _)) lEnv ([l],ty) =
-    bindLabelType l r (toType [] ty) lEnv
-  insertLabelType _ _ r (Just (ImportTypeWith _ ls)) lEnv ([l],ty)
-    | l `elem` ls = bindLabelType l r (toType [] ty) lEnv
-    | otherwise   = lEnv
-  insertLabelType _ _ _ _ lEnv _ = lEnv
-
-  getImportSpec r (Just (Importing _ is')) =
-    find (isImported (unqualify r)) is'
-  getImportSpec r Nothing = Just (ImportTypeAll (unqualify r))
-  getImportSpec _ _ = Nothing
-
-  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) tyEnv' =
-    let m' = fromMaybe m (qualidMod r)
-    in  importTopEnv m' l
-                     (Label (qualify l) (qualQualify m' r) (polyType ty))
-               tyEnv'
-
-recordExpansion1 :: Options -> CompilerEnv -> CompilerEnv
-recordExpansion1 opts env
-  | enabled   = env { tyConsEnv = tcEnv', valueEnv = tyEnv' }
-  | otherwise = env
-  where
-    enabled  = Records `elem` optExtensions opts
-    tcEnv'   = fmap (expandRecordTC    tcEnv) tcEnv
-    tyEnv'   = fmap (expandRecordTypes tcEnv) tyEnvLbl
-    tyEnvLbl = addImportedLabels m lEnv tyEnv
-    m        = moduleIdent env
-    lEnv     = labelEnv env
-    tcEnv    = tyConsEnv env
-    tyEnv    = valueEnv env
-
-recordExpansion2 :: Options -> CompilerEnv -> CompilerEnv
-recordExpansion2 opts env
-  | enabled  = env { valueEnv = tyEnv' }
+expandTCValueEnv :: Options -> CompilerEnv -> CompilerEnv
+expandTCValueEnv opts env
+  | enabled   = env' { tyConsEnv = tcEnv' }
   | otherwise = env
   where
-    enabled  = Records `elem` optExtensions opts
-    tyEnv'   = fmap (expandRecordTypes tcEnv) tyEnvLbl
-    tyEnvLbl = addImportedLabels m lEnv tyEnv
-    m        = moduleIdent env
-    lEnv     = labelEnv env
-    tcEnv    = tyConsEnv env
-    tyEnv    = valueEnv env
+  enabled = Records `elem` optExtensions opts
+  tcEnv'  = fmap (expandRecordTC tcEnv) tcEnv
+  tcEnv   = tyConsEnv env'
+  env'    = expandValueEnv opts env
 
 expandRecordTC :: TCEnv -> TypeInfo -> TypeInfo
 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 _     _  _)) =
+  DataType qid n $ map (fmap expandData) args
+  where
+  expandData (DataConstr c m tys) =
+    DataConstr c m $ map (expandRecords tcEnv) tys
+expandRecordTC tcEnv (RenamingType qid n (DataConstr c m [ty])) =
+  RenamingType qid n (DataConstr c m [expandRecords tcEnv ty])
+expandRecordTC _     (RenamingType _   _ (DataConstr    _ _ _)) =
   internalError "Records.expandRecordTC"
 expandRecordTC tcEnv (AliasType qid n ty) =
   AliasType qid n (expandRecords tcEnv ty)
 
-expandData :: TCEnv -> DataConstr -> DataConstr
-expandData tcEnv (DataConstr ident n tys) =
-  DataConstr ident n (map (expandRecords tcEnv) tys)
+expandValueEnv :: Options -> CompilerEnv -> CompilerEnv
+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) tyEnv -- $ addImportedLabels m lEnv tyEnv
+--   m        = moduleIdent env
+--   lEnv     = labelEnv env
 
 expandRecordTypes :: TCEnv -> ValueInfo -> ValueInfo
-expandRecordTypes tcEnv (DataConstructor qid arty (ForAllExist n m ty)) =
-  DataConstructor qid arty (ForAllExist n m (expandRecords tcEnv ty))
+expandRecordTypes tcEnv (DataConstructor  qid a (ForAllExist n m ty)) =
+  DataConstructor qid a (ForAllExist n m (expandRecords tcEnv ty))
 expandRecordTypes tcEnv (NewtypeConstructor qid (ForAllExist n m ty)) =
   NewtypeConstructor qid (ForAllExist n m (expandRecords tcEnv ty))
-expandRecordTypes tcEnv (Value qid arty (ForAll n ty)) =
-  Value qid arty (ForAll n (expandRecords tcEnv ty))
+expandRecordTypes tcEnv (Value qid a (ForAll n ty)) =
+  Value qid a (ForAll n (expandRecords tcEnv ty))
 expandRecordTypes tcEnv (Label qid r (ForAll n ty)) =
   Label qid r (ForAll n (expandRecords tcEnv ty))
 
 expandRecords :: TCEnv -> Type -> Type
-expandRecords tcEnv (TypeConstructor qid tys) =
-  case qualLookupTC qid tcEnv of
-    [AliasType _ _ rty@(TypeRecord _ _)]
-      -> expandRecords tcEnv
-           (expandAliasType (map (expandRecords tcEnv) tys) rty)
-    _ -> TypeConstructor qid (map (expandRecords tcEnv) tys)
+expandRecords tcEnv (TypeConstructor qid tys) = case qualLookupTC qid tcEnv of
+  [AliasType _ _ rty@(TypeRecord _ _)]
+    -> expandRecords tcEnv $ expandAliasType (map (expandRecords tcEnv) tys) rty
+  _ -> TypeConstructor qid $ map (expandRecords tcEnv) tys
 expandRecords tcEnv (TypeConstrained tys v) =
   TypeConstrained (map (expandRecords tcEnv) tys) v
 expandRecords tcEnv (TypeArrow ty1 ty2) =
   TypeArrow (expandRecords tcEnv ty1) (expandRecords tcEnv ty2)
 expandRecords tcEnv (TypeRecord fs rv) =
-  TypeRecord (map (\ (l,ty) -> (l,expandRecords tcEnv ty)) fs) rv
+  TypeRecord (map (\ (l, ty) -> (l, expandRecords tcEnv ty)) fs) rv
 expandRecords _ ty = ty
+
+-- ---------------------------------------------------------------------------
+-- Import defined record labels
+-- ---------------------------------------------------------------------------
+
+-- Unlike usual identifiers like in functions, types etc., identifiers
+-- of labels are always represented unqualified within the whole context
+-- of compilation. Since the common type environment (type \texttt{ValueEnv})
+-- has some problems with handling imported unqualified identifiers, it is
+-- necessary to add the type information for labels seperately. For this reason
+-- the function \texttt{importLabels} generates an environment containing
+-- all imported labels and the function \texttt{addImportedLabels} adds this
+-- content to a value environment.
+
+-- importLabels :: InterfaceEnv -> [ImportDecl] -> LabelEnv
+-- importLabels mEnv ds = foldl importLabelTypes initLabelEnv ds
+--   where
+--   importLabelTypes :: LabelEnv -> ImportDecl -> LabelEnv
+--   importLabelTypes lEnv (ImportDecl _ m _ asM is) = case Map.lookup m mEnv of
+--     Just (Interface _ _ ds') ->
+--       foldl (importLabelType (fromMaybe m asM) is) lEnv ds'
+--     Nothing  ->
+--       internalError "Records.importLabels"
+--
+--   importLabelType m is lEnv (ITypeDecl _ r _ (RecordType fs _)) =
+--     foldl (insertLabelType r' (getImportSpec r' is)) lEnv fs
+--     where r' = qualifyWith m $ fromRecordExtId $ unqualify r
+--   importLabelType _ _  lEnv _ = lEnv
+--
+--   insertLabelType r (Just (ImportTypeAll     _)) lEnv ([l], ty) =
+--     bindLabelType l r (toType [] ty) lEnv
+--   insertLabelType r (Just (ImportTypeWith _ ls)) lEnv ([l], ty)
+--     | l `elem` ls = bindLabelType l r (toType [] ty) lEnv
+--     | otherwise   = lEnv
+--   insertLabelType _ _ lEnv _ = lEnv
+--
+--   getImportSpec r (Just (Importing _ is')) = find (isImported (unqualify r)) is'
+--   getImportSpec r Nothing                  = Just $ ImportTypeAll $ unqualify r
+--   getImportSpec _ _                        = Nothing
+--
+--   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)

test/RecordTest.curry

@@ -3,4 +3,8 @@ module RecordTest where
 type Record =
   { intField  :: Int
   , boolField :: Bool
-  }
\ No newline at end of file
+  }
+
+empty = { intField = 0, boolField = False }
+
+full = { intField = 1, boolField = True }
\ No newline at end of file

test/RecordTest2.curry

+module RecordTest2 where
+
+import RecordTest (Record(boolField))