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

Import of record fields now works, LabelEnv became obsolete

parent c064369e
......@@ -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
......
......@@ -65,7 +65,6 @@ Executable cymake
, CurryDeps
, Env.Eval
, Env.Interface
, Env.Label
, Env.ModuleAlias
, Env.OpPrec
, Env.TypeConstructors
......
......@@ -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
......
{- |
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]
......@@ -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"
......
......@@ -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)
......@@ -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
module RecordTest2 where
import RecordTest (Record(boolField))
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