Commit c0d85adc authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky
Browse files

Adapted transformations to handle Haskell's record syntax

parent 3ff76be4
......@@ -3,6 +3,7 @@
Description : CaseCompletion
Copyright : (c) 2005 , Martin Engelke
2011 - 2014, Björn Peemöller
2015 , Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -371,14 +372,18 @@ getCCFromIDecls mid cs (CS.Interface _ _ ds) = complementary cs cinfos
declaresConstr (CS.ConstrDecl _ _ cid _) qid = unqualify qid == cid
declaresConstr (CS.ConOpDecl _ _ _ oid _) qid = unqualify qid == oid
declaresConstr (CS.RecordDecl _ _ cid _) qid = unqualify qid == cid
isNewConstrDecl qid (CS.NewConstrDecl _ _ cid _) = unqualify qid == cid
isNewConstrDecl qid (CS.NewRecordDecl _ _ cid _) = unqualify qid == cid
extractConstrDecls (CS.IDataDecl _ _ _ cs') = catMaybes cs'
extractConstrDecls _ = []
constrInfo (CS.ConstrDecl _ _ cid tys) = (qualifyWith mid cid, length tys)
constrInfo (CS.ConOpDecl _ _ _ oid _) = (qualifyWith mid oid, 2)
constrInfo (CS.RecordDecl _ _ cid fs) = (qualifyWith mid cid, length ls)
where ls = [l | FieldDecl _ ls _ <- fs, l <- ls]
-- Compute complementary constructors
complementary :: [QualIdent] -> [(QualIdent, Int)] -> [(QualIdent, Int)]
......
......@@ -3,6 +3,7 @@
Description : Translation of Curry into IL
Copyright : (c) 1999 - 2003 Wolfgang Lux
Martin Engelke
2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -162,61 +163,13 @@ trForeign f cc (Just ie) = do
-- constrained type variables and skolem types. The former are fixed and
-- the later are replaced by fresh type constructors.
-- Due to possible occurrence of record types, it is necessary to transform
-- them back into their corresponding type constructors first.
trType :: Type -> TransM IL.Type
trType ty = trTy <$> elimRecordTypes (maximum $ 0 : typeVars ty) ty
where
trTy (TypeConstructor tc tys) = IL.TypeConstructor tc (map trTy tys)
trTy (TypeVariable tv) = IL.TypeVariable tv
trTy (TypeConstrained tys _) = trTy (head tys)
trTy (TypeArrow ty1 ty2) = IL.TypeArrow (trTy ty1) (trTy ty2)
trTy (TypeSkolem k) = IL.TypeConstructor
trType (TypeConstructor tc tys) = IL.TypeConstructor tc (map trTy tys)
trType (TypeVariable tv) = IL.TypeVariable tv
trType (TypeConstrained tys _) = trTy (head tys)
trType (TypeArrow ty1 ty2) = IL.TypeArrow (trTy ty1) (trTy ty2)
trType (TypeSkolem k) = IL.TypeConstructor
(qualify (mkIdent ("_" ++ show k))) []
trTy rec@(TypeRecord _)
= internalError $ "Translation of record not defined: " ++ show rec
elimRecordTypes :: Int -> Type -> TransM Type
elimRecordTypes n (TypeConstructor t tys)
= TypeConstructor t <$> mapM (elimRecordTypes n) tys
elimRecordTypes _ v@(TypeVariable _) = return v
elimRecordTypes n (TypeConstrained tys v)
= flip TypeConstrained v <$> mapM (elimRecordTypes n) tys
elimRecordTypes n (TypeArrow t1 t2)
= TypeArrow <$> elimRecordTypes n t1 <*> elimRecordTypes n t2
elimRecordTypes _ s@(TypeSkolem _) = return s
elimRecordTypes n (TypeRecord fs)
| null fs = internalError "CurryToIL.elimRecordTypes: empty record type"
| otherwise = do
(r, n', fs') <- recordInfo (fst $ head fs)
let vs = foldl (matchTypeVars fs) Map.empty fs'
tys = mapM (\i -> maybe (return $ TypeVariable (i+n))
(elimRecordTypes n)
(Map.lookup i vs))
[0 .. n'-1]
TypeConstructor r <$> tys
matchTypeVars :: [(Ident, Type)] -> Map.Map Int Type -> (Ident, Type)
-> Map.Map Int Type
matchTypeVars fs vs (l, ty) = maybe vs (match' vs ty) (lookup l fs)
where
match' vs' (TypeVariable i) ty'
= Map.insert i ty' vs'
match' vs' (TypeConstructor _ tys) (TypeConstructor _ tys')
= matchList vs' tys tys'
match' vs' (TypeConstrained tys _) (TypeConstrained tys' _)
= matchList vs' tys tys'
match' vs' (TypeArrow ty1 ty2) (TypeArrow ty1' ty2')
= matchList vs' [ty1,ty2] [ty1',ty2']
match' vs' (TypeSkolem _) (TypeSkolem _) = vs'
match' vs' (TypeRecord fs1) (TypeRecord fs2)
= foldl (matchTypeVars fs2) vs' fs1
match' _ ty1 ty2
= internalError ("CurryToIL.matchTypeVars: " ++ show ty1 ++ "\n" ++ show ty2)
matchList vs1 tys tys' =
foldl (\vs' (ty1,ty2) -> match' vs' ty1 ty2) vs1 (zip tys tys')
-- Functions:
-- Each function in the program is translated into a function of the
......@@ -559,17 +512,6 @@ constrType c = do
[NewtypeConstructor _ (ForAllExist _ _ ty)] -> return ty
_ -> internalError $ "CurryToIL.constrType: " ++ show c
recordInfo :: Ident -> TransM (QualIdent, Int, [(Ident, Type)])
recordInfo f = do
tyEnv <- getValueEnv
case lookupValue f tyEnv of
[Label _ r _] -> do
tcEnv <- getTCEnv
case qualLookupTC r tcEnv of
[AliasType _ n (TypeRecord fs)] -> return (r, n, fs)
_ -> internalError $ "CurryToIL.recordInfo: " ++ show f
_ -> internalError $ "CurryToIL.recordInfo: " ++ show f
-- The list of import declarations in the intermediate language code is
-- determined by collecting all module qualifiers used in the current
-- module.
......
......@@ -4,6 +4,7 @@
Copyright : (c) 2001 - 2004 Wolfgang Lux
Martin Engelke
2011 - 2015 Björn Peemöller
2015 Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -68,7 +69,7 @@ import Control.Arrow (first, second)
import Control.Monad (mplus)
import qualified Control.Monad.State as S (State, runState, gets, modify)
import Data.List ((\\), nub, tails)
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, catMaybes)
import qualified Data.Set as Set (Set, empty, member, insert)
import Curry.Base.Ident
......@@ -279,6 +280,8 @@ dsNonLinear env (InfixPattern t1 op t2) = do
return (env2, InfixPattern t1' op t2')
dsNonLinear env (ParenPattern t) = second ParenPattern
<$> dsNonLinear env t
dsNonLinear env (RecordPattern c fs) =
second (RecordPattern c) <$> mapAccumM (dsField dsNonLinear) env fs
dsNonLinear env (TuplePattern pos ts) = second (TuplePattern pos)
<$> mapAccumM dsNonLinear env ts
dsNonLinear env (ListPattern pos ts) = second (ListPattern pos)
......@@ -291,13 +294,6 @@ dsNonLinear env (LazyPattern r t) = second (LazyPattern r)
<$> dsNonLinear env t
dsNonLinear env fp@(FunctionPattern _ _) = dsNonLinearFuncPat env fp
dsNonLinear env fp@(InfixFuncPattern _ _ _) = dsNonLinearFuncPat env fp
dsNonLinear env (RecordPattern fs r) = do
(env1, fs') <- mapAccumM dsField env fs
(env2, r' ) <- case r of
Nothing -> return (env1, Nothing)
Just r0 -> second Just <$> dsNonLinear env1 r0
return (env2, RecordPattern fs' r')
where dsField e (Field p i t) = second (Field p i) <$> dsNonLinear e t
dsNonLinearFuncPat :: NonLinearEnv -> Pattern -> DsM (NonLinearEnv, Pattern)
dsNonLinearFuncPat (vis, eqs) fp = do
......@@ -321,6 +317,8 @@ substPat s (ConstructorPattern c ps) = ConstructorPattern c
substPat s (InfixPattern p1 op p2) = InfixPattern (substPat s p1) op
(substPat s p2)
substPat s (ParenPattern p) = ParenPattern (substPat s p)
substPat s (RecordPattern c fs) = RecordPattern c (map substField fs)
where substField (Field pos l pat) = Field pos l (substPat s pat)
substPat s (TuplePattern pos ps) = TuplePattern pos $ map (substPat s) ps
substPat s (ListPattern pos ps) = ListPattern pos $ map (substPat s) ps
substPat s (AsPattern v p) = AsPattern (fromMaybe v (lookup v s))
......@@ -329,9 +327,6 @@ substPat s (LazyPattern r p) = LazyPattern r (substPat s p)
substPat s (FunctionPattern f ps) = FunctionPattern f $ map (substPat s) ps
substPat s (InfixFuncPattern p1 op p2) = InfixFuncPattern (substPat s p1) op
(substPat s p2)
substPat s (RecordPattern fs p) = RecordPattern (map substField fs)
(substPat s <$> p)
where substField (Field pos i t) = Field pos i (substPat s t)
-- -----------------------------------------------------------------------------
-- Desugaring of functional patterns
......@@ -374,6 +369,8 @@ elimFP bs (InfixPattern t1 op t2) = do
(bs2, t2') <- elimFP bs1 t2
return (bs2, InfixPattern t1' op t2')
elimFP bs (ParenPattern t) = second ParenPattern <$> elimFP bs t
elimFP bs (RecordPattern c fs) =
second (RecordPattern c) <$> mapAccumM (dsField elimFP) bs fs
elimFP bs (TuplePattern pos ts) = second (TuplePattern pos)
<$> mapAccumM elimFP bs ts
elimFP bs (ListPattern pos ts) = second (ListPattern pos)
......@@ -386,9 +383,6 @@ elimFP bs p@(FunctionPattern _ _) = do
elimFP bs p@(InfixFuncPattern _ _ _) = do
v <- freshMonoTypeVar "_#funpatt" p
return ((p, v) : bs, VariablePattern v)
elimFP bs (RecordPattern fs r) = second (flip RecordPattern r)
<$> mapAccumM elimField bs fs
where elimField b (Field p i t) = second (Field p i) <$> elimFP b t
genFPExpr :: Position -> [Ident] -> [LazyBinding] -> ([Decl], [Expression])
genFPExpr p vs bs
......@@ -443,6 +437,19 @@ fp2Expr t = internalError $
-- 't' is a variable or an as-pattern are replaced by 't' in combination
-- with a local declaration for 'v'.
-- Record patterns are transformed into normal constructor patterns by
-- rearranging fields in the order of the record's declaration, adding
-- fresh variables in place of omitted fields, and discarding the field
-- labels.
-- Note: By rearranging fields here we loose the ability to comply
-- strictly with the Haskell 98 pattern matching semantics, which matches
-- fields of a record pattern in the order of their occurrence in the
-- pattern. However, keep in mind that Haskell matches alternatives from
-- top to bottom and arguments within an equation or alternative from
-- left to right, which is not the case in Curry except for rigid case
-- expressions.
dsPattern :: Position -> [Decl] -> Pattern -> DsM ([Decl], Pattern)
dsPattern _ ds v@(VariablePattern _) = return (ds, v)
dsPattern p ds (LiteralPattern l) = do
......@@ -457,33 +464,30 @@ dsPattern p ds (ConstructorPattern c [t]) = do
(if isNewtypeConstr tyEnv c then id else second (constrPat c)) <$>
(dsPattern p ds t)
where constrPat c' t' = ConstructorPattern c' [t']
dsPattern p ds (ConstructorPattern c ts) =
dsPattern p ds (ConstructorPattern c ts) =
second (ConstructorPattern c) <$> mapAccumM (dsPattern p) ds ts
dsPattern p ds (InfixPattern t1 op t2) =
dsPattern p ds (InfixPattern t1 op t2) =
dsPattern p ds (ConstructorPattern op [t1,t2])
dsPattern p ds (ParenPattern t) = dsPattern p ds t
dsPattern p ds (TuplePattern pos ts) =
dsPattern p ds (ParenPattern t) = dsPattern p ds t
dsPattern p ds (RecordPattern c fs) = do
tyEnv <- getValueEnv
let (ls, _) = conType c tyEnv
ts = map (dsLabel (VariablePattern anonId) (map field2Tuple fs)) ls
dsPattern p ds (ConstructorPattern c ts)
dsPattern p ds (TuplePattern pos ts) =
dsPattern p ds (ConstructorPattern (tupleConstr ts) ts)
where tupleConstr ts' = addRef pos $
if null ts' then qUnitId else qTupleId (length ts')
dsPattern p ds (ListPattern pos ts) =
dsPattern p ds (ListPattern pos ts) =
second (dsList pos cons nil) <$> mapAccumM (dsPattern p) ds ts
where nil p' = ConstructorPattern (addRef p' qNilId) []
cons p' t ts' = ConstructorPattern (addRef p' qConsId) [t,ts']
dsPattern p ds (AsPattern v t) = dsAs p v <$> dsPattern p ds t
dsPattern p ds (LazyPattern r t) = dsLazy r p ds t
dsPattern p ds (FunctionPattern f ts) =
dsPattern p ds (AsPattern v t) = dsAs p v <$> dsPattern p ds t
dsPattern p ds (LazyPattern r t) = dsLazy r p ds t
dsPattern p ds (FunctionPattern f ts) =
second (FunctionPattern f) <$> mapAccumM (dsPattern p) ds ts
dsPattern p ds (InfixFuncPattern t1 f t2) =
dsPattern p ds (FunctionPattern f [t1,t2])
dsPattern p ds (RecordPattern fs _)
| null fs = internalError "Desugar.dsPattern: empty record"
| otherwise = do
r <- recordFromField (fieldLabel (head fs))
fs' <- (map fst . snd) <$> lookupRecord r
let ts = map (dsLabel (map field2Tuple fs)) fs'
dsPattern p ds (ConstructorPattern r ts)
where dsLabel fs' l = fromMaybe (VariablePattern anonId) (lookup l fs')
dsLiteral :: Literal -> DsM (Either Literal ([SrcRef], [Literal]))
dsLiteral c@(Char _ _) = return $ Left c
......@@ -570,21 +574,57 @@ booleanGuards _ _ [] = False
booleanGuards tyEnv tcEnv (CondExpr _ g _ : es) =
not (null es) || typeOf tyEnv tcEnv g == boolType
-- Record construction expressions are transformed into normal
-- constructor applications by rearranging fields in the order of the
-- record's declaration, passing `Prelude.undefined` in place of
-- omitted fields, and discarding the field labels. The transformation of
-- record update expressions is a bit more involved as we must match the
-- updated expression with all valid constructors of the expression's
-- type. As stipulated by the Haskell 98 Report, a record update
-- expression @e { l_1 = e_1, ..., l_k = e_k }@ succeeds only if @e@ reduces to
-- a value @C e'_1 ... e'_n@ such that @C@'s declaration contains all
-- field labels @l_1,...,l_k@. In contrast to Haskell we do not report
-- an error if this is not the case but rather fail only the current
-- solution.
dsExpr :: Position -> Expression -> DsM Expression
dsExpr p (Literal l) =
dsExpr p (Literal l) =
dsLiteral l >>=
either (return . Literal) (\ (pos, ls) -> dsExpr p $ List pos $ map Literal ls)
dsExpr _ var@(Variable v)
| isAnonId (unqualify v) = return prelUnknown
| otherwise = return var
dsExpr _ c@(Constructor _) = return c
dsExpr p (Paren e) = dsExpr p e
dsExpr p (Typed e ty) = Typed <$> dsExpr p e <*> dsTypeExpr ty
dsExpr p (Tuple pos es) = apply (Constructor $ tupleConstr es)
| isAnonId (unqualify v) = return prelUnknown
| otherwise = return var
dsExpr _ c@(Constructor _) = return c
dsExpr p (Paren e) = dsExpr p e
dsExpr p (Typed e ty) = Typed <$> dsExpr p e <*> dsTypeExpr ty
dsExpr p (Record c fs) = do
tyEnv <- getValueEnv
let (ls, _) = conType c tyEnv
es = map (dsLabel prelFailed (map field2Tuple fs)) ls
dsExpr p $ apply (Constructor c) es
dsExpr p (RecordUpdate e fs) = do
tyEnv <- getValueEnv
tcEnv <- getTyConsEnv
ty <- getTypeOf e
let (TypeConstructor tc _) = arrowBase ty
alts <- mapM (updateAlt tc) (constructors tc)
dsExpr p $ Case (srcRefOf p) Flex e (map (caseAlt p) (concat alts))
where
ls = map fieldLabel fs
updateAlt _ (DataConstr _ _ _) = return []
updateAlt tc' (RecordConstr c _ labels tys)
| all (`elem` labels) ls = do
vs <- mapM (freshMonoTypeVar "_#rec" . VariablePattern) labels
let es = map (\v -> dsLabel (mkVar v) (map field2Tuple fs) v) vs
qc = qualifyLike tc' c
return [(constrPat qc vs, apply (Constructor qc) es)]
| otherwise = return []
constrPat qc' vs' = ConstructorPattern qc' (map VariablePattern vs')
dsExpr p (Tuple pos es) = apply (Constructor $ tupleConstr es)
<$> mapM (dsExpr p) es
where tupleConstr es1 = addRef pos
$ if null es1 then qUnitId else qTupleId (length es1)
dsExpr p (List pos es) = dsList pos cons nil <$> mapM (dsExpr p) es
dsExpr p (List pos es) = dsList pos cons nil <$> mapM (dsExpr p) es
where nil p' = Constructor (addRef p' qNilId)
cons p' = Apply . Apply (Constructor $ addRef p' qConsId)
dsExpr p (ListCompr r e [] ) = dsExpr p (List [r,r] [e])
......@@ -653,20 +693,13 @@ dsExpr p (Case r ct e alts)
mkCase m1 v e1 alts1
| v `elem` qfv m1 alts1 = Let [varDecl p v e1] (Case r ct (mkVar v) alts1)
| otherwise = Case r ct e1 alts1
dsExpr p (RecordConstr fs)
| null fs = internalError "Desugar.dsExpr: empty record construction"
| otherwise = do
r <- recordFromField (fieldLabel (head fs))
dsRecordConstr p r (map field2Tuple fs)
dsExpr p (RecordSelection e l) = do
m <- getModuleIdent
r <- recordFromField l
dsExpr p (Apply (Variable (qualRecSelectorId m r l)) e)
dsExpr p (RecordUpdate fs rexpr)
| null fs = internalError "Desugar.dsExpr: empty record update"
| otherwise = do
r <- recordFromField (fieldLabel (head fs))
dsRecordUpdate p r rexpr (map field2Tuple fs)
dsLabel :: a -> [(Ident, a)] -> Ident -> a
dsLabel def fs l = fromMaybe def (lookup l fs)
dsField :: (a -> b -> DsM (a, b)) -> a -> Field b -> DsM (a, Field b)
dsField ds z (Field p l x) = do (z', x') <- ds z x
return (z', Field p l x')
dsTypeExpr :: TypeExpr -> DsM TypeExpr
dsTypeExpr ty = do
......@@ -686,8 +719,6 @@ expandType _ tc@(TypeConstrained _ _) = tc
expandType tcEnv (TypeArrow ty1 ty2) =
TypeArrow (expandType tcEnv ty1) (expandType tcEnv ty2)
expandType _ ts@(TypeSkolem _) = ts
expandType tcEnv (TypeRecord fs) =
TypeRecord (map (\ (l, ty) -> (l, expandType tcEnv ty)) fs)
-- If an alternative in a case expression has boolean guards and all of
-- these guards return 'False', the enclosing case expression does
......@@ -731,80 +762,64 @@ isCompatible _ _ = False
-- Desugaring of Records
-- -----------------------------------------------------------------------------
recordFromField :: Ident -> DsM QualIdent
recordFromField lbl = do
tyEnv <- getValueEnv
case lookupValue lbl tyEnv of
[Label _ r _] -> return r
_ -> internalError $
"Desugar.recordFromField: unknown label: " ++ show lbl
lookupRecord :: QualIdent -> DsM (Int, [(Ident, Type)])
lookupRecord r = do
tcEnv <- getTyConsEnv
case qualLookupTC r tcEnv of
[AliasType _ n (TypeRecord fs)] -> return (n, fs)
_ ->
internalError $ "Desugar.lookupRecord: no record: " ++ show r
-- As an extension to the Curry language the compiler supports Haskell's
-- record syntax, which introduces field labels for data and renaming
-- types. Field labels can be used in constructor declarations, patterns,
-- and expressions. For further convenience, an implicit selector
-- function is introduced for each field label.
-- Generate selection functions for record labels and replace record
-- constructor declarations by normal constructor declarations
dsRecordDecl :: Decl -> DsM [Decl]
dsRecordDecl (TypeDecl p r vs (RecordType fss)) = do
m <- getModuleIdent
let qr = qualifyWith m r
(n, fs') <- lookupRecord qr
let tys = concatMap (\ (ls, ty) -> replicate (length ls) ty) fss
--tys' = map (elimRecordTypes tyEnv) tys
rdecl = DataDecl p r vs [ConstrDecl p [] r tys]
rty' = TypeConstructor qr (map TypeVariable [0 .. n - 1])
rcts' = ForAllExist 0 n (foldr TypeArrow rty' (map snd fs'))
rfuncs <- mapM (genRecordFuncs p qr rty' (map fst fs')) fs'
modifyValueEnv
(bindGlobalInfo (flip DataConstructor (length tys)) m r rcts')
return $ rdecl : concat rfuncs
dsRecordDecl (DataDecl p tc tvs cs) = do
m <- getModuleIdent
let qcs = map (qualifyWith m . constrId) cs
selFuns <- mapM (genSelectFunc p qcs) labels
return $ DataDecl p tc tvs (map unlabelConstr cs) : selFuns
where
labels = nub $ concatMap recordLabels cs
dsRecordDecl (NewtypeDecl p tc tvs nc) = do
m <- getModuleIdent
let qc = qualifyWith m (nconstrId nc)
selFun <- mapM (genSelectFunc p [qc]) (nrecordLabels nc)
return $ NewtypeDecl p tc tvs (unlabelNewConstr nc) : selFun
dsRecordDecl d = return [d]
genRecordFuncs :: Position -> QualIdent -> Type -> [Ident] -> (Ident, Type)
-> DsM [Decl]
genRecordFuncs p r rty ls (l, ty) = do
m <- getModuleIdent
let (selId, selFunc) = genSelectFunc p r ls l
(updId, updFunc) = genUpdateFunc p r ls l
selType = polyType (TypeArrow rty ty)
updType = polyType (TypeArrow rty $ TypeArrow ty rty)
modifyValueEnv (bindFun m selId 1 selType . bindFun m updId 2 updType)
return [selFunc, updFunc]
genSelectFunc :: Position -> QualIdent -> [Ident] -> Ident -> (Ident, Decl)
genSelectFunc p r ls l = (selId, funDecl p selId [cpatt] (mkVar l))
-- Generate selection function for a record label
genSelectFunc :: Position -> [QualIdent] -> Ident -> DsM Decl
genSelectFunc p qcs l = do
m <- getModuleIdent
tyEnv <- getValueEnv
eqs <- concat <$> mapM (selectorEqn l) qcs
let (_, ty) = conType (head qcs) tyEnv
(tys, rty) = arrowUnapply (instType ty)
selType = polyType (TypeArrow rty (tys !! n))
selId = qualifyWith m l
modifyValueEnv $ bindFun m selId 1 selType
return $ FunctionDecl p selId [funEqn selId [pat] e | (pat, e) <- eqs]
where
selId = recSelectorId r l
cpatt = ConstructorPattern r (map VariablePattern ls)
funEqn f ps e = Equation p (FunLhs f ps) (SimpleRhs p e [])
genUpdateFunc :: Position -> QualIdent -> [Ident] -> Ident -> (Ident, Decl)
genUpdateFunc p r ls l = (updId, funDecl p updId [cpatt1, cpatt2] cexpr)
where
updId = recUpdateId r l
vs = [ VariablePattern (if v == l then anonId else v) | v <- ls]
cpatt1 = ConstructorPattern r vs
cpatt2 = VariablePattern l
cexpr = apply (Constructor r) (map mkVar ls)
dsRecordConstr :: Position -> QualIdent -> [(Ident, Expression)]
-> DsM Expression
dsRecordConstr p r fs = do
fs' <- (map fst . snd) <$> lookupRecord r
let cts = map (\ l -> fromMaybe (internalError "Desugar.dsRecordConstr")
(lookup l fs)) fs'
dsExpr p (apply (Constructor r) cts)
dsRecordUpdate :: Position -> QualIdent -> Expression
-> [(Ident, Expression)] -> DsM Expression
dsRecordUpdate p r rexpr fs = do
m <- getModuleIdent
dsExpr p (foldl (genRecordUpdate m r) rexpr fs)
where
genRecordUpdate m1 r1 rexpr1 (l,e) =
apply (Variable $ qualRecUpdateId m1 r1 l) [rexpr1, e]
-- Generate pattern and rhs for selection function and
-- add its type to the value environment
selectorEqn :: Ident -> QualIdent -> DsM [(Pattern, Expression)]
selectorEqn l qc = do
tyEnv <- getValueEnv
let (ls, _) = conType qc tyEnv
case elemIndex l ls of
Just n -> do vs <- mapM (freshMonoTypeVar "_#rec" . VariablePattern) ls
return [(ConstructorPattern qc vs, Variable (vs !! n))]
Nothing -> return []
-- Transform record constructor declarations into normal declarations
unlabelConstr :: ConstrDecl -> ConstrDecl
unlabelConstr (RecordDecl p evs c fs) = ConstrDecl p evs c tys
where tys = [ty | FieldDecl _ ls ty <- fs, _ <- ls]
unlabelConstr c = c
unlabelNewConstr :: NewConstrDecl -> NewConstrDecl
unlabelNewConstr (NewRecordDecl p evs nc (_, ty)) = NewConstrDecl p evs nc ty
unlabelNewConstr c = c
-- -----------------------------------------------------------------------------
-- Desugaring of List Comprehension
......@@ -978,3 +993,23 @@ apply = foldl Apply
mkVar :: Ident -> Expression
mkVar = Variable . qualify
-- The function 'instType' instantiates the universally quantified
-- type variables of a type scheme with fresh type variables. Since this
-- function is used only to instantiate the closed types of record
-- constructors (Recall that no existentially quantified type
-- variables are allowed for records), the compiler can reuse the same
-- monomorphic type variables for every instantiated type.
instType :: ExistTypeScheme -> Type
instType (ForAllExist _ _ ty) = inst ty
where inst (TypeConstructor tc tys) = TypeConstructor tc (map inst tys)
inst (TypeVariable tv) = TypeVariable (-1 - tv)
inst (TypeArrow ty1 ty2) = TypeArrow (inst ty1) (inst ty2)
constructors :: QualIdent -> TCEnv -> [DataConstr]
constructors c tcEnv = case qualLookupTC c of
[DataType _ _ cs] -> cs
[RenamingType _ _ c ] -> [c]
_ -> internalError $
"Transformations.Desugar.constructors: " ++ show c
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