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

Adapted generation of AbstractCurry and FlatCurry to handle Haskell's record syntax

parent c0d85adc
......@@ -3,6 +3,7 @@
Description : Generation of AbstractCurry program terms
Copyright : (c) 2005 , Martin Engelke
2011 - 2015, Björn Peemöller
2015, Jan Tikovsky
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -80,10 +81,18 @@ trConsDecl (ConstrDecl _ _ c tys) = CCons
<$> trLocalIdent c <*> getVisibility c <*> mapM trTypeExpr tys
trConsDecl (ConOpDecl p vs ty1 op ty2) = trConsDecl $
ConstrDecl p vs op [ty1, ty2]
trConsDecl (RecordDecl _ _ c fs) = CRecord
<$> trLocalIdent c <*> getVisibility c <*> (concat <$> mapM trFieldDecl fs)
trFieldDecl :: FieldDecl -> GAC [CFieldDecl]
trFieldDecl (FieldDecl _ ls ty) = T.forM ls $ \l ->
CFieldDecl <$> trLocalIdent l <*> getVisibility l <*> trTypeExpr ty
trNewConsDecl :: NewConstrDecl -> GAC CConsDecl
trNewConsDecl (NewConstrDecl _ _ nc ty) = CCons
trNewConsDecl (NewConstrDecl _ _ nc ty) = CCons
<$> trLocalIdent nc <*> getVisibility nc <*> ((:[]) <$> trTypeExpr ty)
trNewConsDecl (NewRecordDecl p _ nc (l, ty)) = CRecord
<$> trLocalIdent nc <*> getVisibility nc <*> trFieldDecl (FieldDecl p [l] ty)
trTypeExpr :: TypeExpr -> GAC CTypeExpr
trTypeExpr (ConstructorType q ts) = CTCons <$> trQual q
......@@ -96,10 +105,6 @@ trTypeExpr (TupleType tys) = trTypeExpr $ case tys of
trTypeExpr (ListType ty) = trTypeExpr $ ConstructorType qListId [ty]
trTypeExpr (ArrowType ty1 ty2) = CFuncType <$> trTypeExpr ty1
<*> trTypeExpr ty2
trTypeExpr (RecordType fss) = CRecordType <$> mapM trFieldType fs
where
trFieldType (l, ty) = (,) <$> return (idName l) <*> trTypeExpr ty
fs = [ (l, ty) | (ls, ty) <- fss, l <- ls ]
trInfixDecl :: Decl -> GAC [COpDecl]
trInfixDecl (InfixDecl _ fix mprec ops) = mapM trInfix (reverse ops)
......@@ -166,23 +171,27 @@ trLocalDecl (FreeDecl _ vs) = (\vs' -> [CLocalVars vs'])
trLocalDecl _ = return [] -- can not occur (types etc.)
trExpr :: Expression -> GAC CExpr
trExpr (Literal l) = return (CLit $ cvLiteral l)
trExpr (Variable v)
trExpr (Literal l) = return (CLit $ cvLiteral l)
trExpr (Variable v)
| isQualified v = CSymbol <$> trQual v
| otherwise = lookupVarIndex v' >>= \mvi -> case mvi of
Just vi -> return (CVar vi)
_ -> CSymbol <$> trLocalIdent v'
where v' = unqualify v
trExpr (Constructor c) = CSymbol <$> trQual c
trExpr (Paren e) = trExpr e
trExpr (Typed e ty) = CTyped <$> trExpr e <*> trTypeExpr ty
trExpr (Tuple _ es) = trExpr $ case es of
trExpr (Constructor c) = CSymbol <$> trQual c
trExpr (Paren e) = trExpr e
trExpr (Typed e ty) = CTyped <$> trExpr e <*> trTypeExpr ty
trExpr (Record c fs) = CRecConstr <$> trQual c
<*> mapM (trField trExpr) fs
trExpr (RecordUpdate e fs) = CRecUpdate <$> trExpr e
<*> mapM (trField trExpr) fs
trExpr (Tuple _ es) = trExpr $ case es of
[] -> Variable qUnitId
[x] -> x
_ -> foldl Apply (Variable $ qTupleId $ length es) es
trExpr (List _ es) = trExpr $
trExpr (List _ es) = trExpr $
foldr (Apply . Apply (Constructor qConsId)) (Constructor qNilId) es
trExpr (ListCompr _ e ds) = inNestedScope $ flip CListComp
trExpr (ListCompr _ e ds) = inNestedScope $ flip CListComp
<$> mapM trStatement ds <*> trExpr e
trExpr (EnumFrom e) = trExpr
$ apply (Variable qEnumFromId ) [e]
......@@ -214,10 +223,6 @@ trExpr (IfThenElse _ e1 e2 e3) = trExpr
$ apply (Variable qIfThenElseId) [e1,e2,e3]
trExpr (Case _ ct e bs) = CCase (cvCaseType ct)
<$> trExpr e <*> mapM trAlt bs
trExpr (RecordConstr fs) = CRecConstr <$> mapM (trField trExpr) fs
trExpr (RecordSelection e l) = CRecSelect <$> trExpr e <*> return (idName l)
trExpr (RecordUpdate fs e) = CRecUpdate <$> mapM (trField trExpr) fs
<*> trExpr e
cvCaseType :: CaseType -> CCaseType
cvCaseType Flex = CFlex
......@@ -240,6 +245,8 @@ trPat (VariablePattern v) = CPVar <$> getVarIndex v
trPat (ConstructorPattern c ps) = CPComb <$> trQual c <*> mapM trPat ps
trPat (InfixPattern p1 op p2) = trPat $ ConstructorPattern op [p1, p2]
trPat (ParenPattern p) = trPat p
trPat (RecordPattern c fs) = CPRecord <$> trQual c
<*> mapM (trField trPat) fs
trPat (TuplePattern _ ps) = trPat $ case ps of
[] -> ConstructorPattern qUnitId []
[ty] -> ty
......@@ -253,8 +260,6 @@ trPat (AsPattern v p) = CPAs <$> getVarIndex v<*> trPat p
trPat (LazyPattern _ p) = CPLazy <$> trPat p
trPat (FunctionPattern f ps) = CPFuncComb <$> trQual f <*> mapM trPat ps
trPat (InfixFuncPattern p1 f p2) = trPat (FunctionPattern f [p1, p2])
trPat (RecordPattern fs mr) = CPRecord <$> mapM (trField trPat) fs
<*> T.mapM trPat mr
trField :: (a -> GAC b) -> Field a -> GAC (CField b)
trField act (Field _ l x) = (,) <$> return (idName l) <*> act x
......
......@@ -153,7 +153,7 @@ getConstrTypes :: TCEnv -> ValueEnv -> [(QualIdent, IL.Type)]
getConstrTypes tcEnv tyEnv =
[ mkConstrType tqid conid argtys argc
| (_, (_, DataType tqid argc dts):_) <- Map.toList $ topEnvMap tcEnv
, Just (DataConstr conid _ argtys) <- dts
, (DataConstr conid _ argtys) <- dts
]
where
mkConstrType tqid conid argtypes targnum = (conname, contype)
......@@ -174,12 +174,11 @@ visitModule (IL.Module mid imps decls) = do
datas <- mapM visitDataDecl (filter isDataDecl decls)
newtys <- mapM visitNewtypeDecl (filter isNewtypeDecl decls)
types <- genTypeSynonyms
recrds <- genRecordTypes
funcs <- mapM visitFuncDecl (filter isFuncDecl decls)
modid <- visitModuleIdent mid
imps' <- imports
is <- mapM visitModuleIdent $ nub $ imps ++ (map extractMid imps')
return $ Prog modid is (recrds ++ types ++ datas ++ newtys) funcs ops
return $ Prog modid is (types ++ datas ++ newtys) funcs ops
)
( do
ds <- filterM isPublicDataDecl decls
......@@ -187,7 +186,6 @@ visitModule (IL.Module mid imps decls) = do
datas <- mapM visitDataDecl ds
newtys <- mapM visitNewtypeDecl nts
types <- genTypeSynonyms
recrds <- genRecordTypes
fs <- filterM isPublicFuncDecl decls
funcs <- mapM visitFuncDecl fs
expimps <- getExportedImports
......@@ -197,7 +195,7 @@ visitModule (IL.Module mid imps decls) = do
modid <- visitModuleIdent mid
imps' <- imports
is <- mapM visitModuleIdent $ nub $ imps ++ (map extractMid imps')
return $ Prog modid is (itypes ++ recrds ++ types ++ datas ++ newtys) (ifuncs ++ funcs) (iops ++ ops)
return $ Prog modid is (itypes ++ types ++ datas ++ newtys) (ifuncs ++ funcs) (iops ++ ops)
)
where extractMid (CS.IImportDecl _ mid1) = mid1
......@@ -360,10 +358,10 @@ visitFuncIDecl _ = internalError "GenFlatCurry: no function interface"
--
visitTypeIDecl :: CS.IDecl -> FlatState TypeDecl
visitTypeIDecl (CS.IDataDecl _ t vs cs) = do
visitTypeIDecl (CS.IDataDecl _ t vs cs hs) = do
let mid = fromMaybe (internalError "GenFlatCurry: no module name") (qidModule t)
is = [0 .. length vs - 1]
cdecls <- mapM (visitConstrIDecl mid $ zip vs is) $ catMaybes cs
cdecls <- mapM (visitConstrIDecl mid $ zip vs is) [c | c <- cs, constrId c `notElem` hs]
qname <- visitQualTypeIdent t
return $ Type qname Public is cdecls
visitTypeIDecl (CS.ITypeDecl _ t vs ty) = do
......@@ -622,10 +620,10 @@ genFixity CS.InfixL = InfixlOp
genFixity CS.InfixR = InfixrOp
genFixity CS.Infix = InfixOp
-- The intermediate language (IL) does not represent type synonyms
-- (and also no record declarations). For this reason an interface
-- representation of all type synonyms is generated (see "ModuleSummary")
-- from the abstract syntax representation of the Curry program.
-- The intermediate language (IL) does not represent type synonyms.
-- For this reason an interface representation of all type synonyms
-- is generated (see "ModuleSummary") from the abstract syntax
-- representation of the Curry program.
-- The function 'typeSynonyms' returns this list of type synonyms.
genTypeSynonyms :: FlatState [TypeDecl]
genTypeSynonyms = typeSynonyms >>= mapM genTypeSynonym
......@@ -636,121 +634,12 @@ genTypeSynonym (CS.ITypeDecl _ qid params ty) = do
let is = [0 .. (length params) - 1]
tyEnv <- gets typeEnvE
tcEnv <- gets tConsEnvE
let ty' = elimRecordTypes tyEnv tcEnv ty
texpr <- visitType $ snd $ cs2ilType (zip params is) ty'
texpr <- visitType $ snd $ cs2ilType (zip params is) ty
qname <- visitQualTypeIdent qid
vis <- getVisibility False qid
return $ TypeSyn qname vis is texpr
genTypeSynonym _ = internalError "GenFlatCurry: no type synonym interface"
-- In order to provide an interface for record declarations, 'genRecordTypes'
-- generates dummy data declarations representing records together
-- with their typed labels. For the record declaration
--
-- type Rec = {l_1 :: t_1,..., l_n :: t_n}
--
-- the following data declaration will be generated:
--
-- data Rec' = l_1' t_1 | ... | l_n' t_n
--
-- Rec' and l_i' are unique idenfifiers which encode the original names
-- Rec and l_i.
-- When reading an interface file containing such declarations, it is
-- now possible to reconstruct the original record declaration. Since
-- usual FlatCurry code is used, these declaration should not have any
-- effects on the behaviour of the Curry program. But to ensure correctness,
-- these dummies should be generated for the interface file as well as for
-- the corresponding FlatCurry file.
genRecordTypes :: FlatState [TypeDecl]
genRecordTypes = records >>= mapM genRecordType
--
genRecordType :: CS.IDecl -> FlatState TypeDecl
genRecordType (CS.ITypeDecl _ qid params (CS.RecordType fs)) = do
let is = [0 .. (length params) - 1]
(mid, ident) = (qidModule qid, qidIdent qid)
qname <- visitQualIdent ((maybe qualify qualifyWith mid) (recordExtId ident))
labels <- mapM (genRecordLabel mid (zip params is)) fs
return (Type qname Public is labels)
genRecordType _ = internalError "GenFlatCurry.genRecordType: no pattern match"
--
genRecordLabel :: Maybe ModuleIdent -> [(Ident, Int)] -> ([Ident], CS.TypeExpr)
-> FlatState ConsDecl
genRecordLabel modid vis ([ident],ty) = do
tyEnv <- gets typeEnvE
tcEnv <- gets tConsEnvE
let ty' = elimRecordTypes tyEnv tcEnv ty
texpr <- visitType (snd (cs2ilType vis ty'))
qname <- visitQualIdent ((maybe qualify qualifyWith modid)
(labelExtId ident))
return (Cons qname 1 Public [texpr])
genRecordLabel _ _ _ = internalError "GenFlatCurry.genRecordLabel: no pattern match"
-- FlatCurry provides no possibility of representing record types like
-- {l_1::t_1, l_2::t_2, ..., l_n::t_n}. So they have to be transformed to
-- to the corresponding type constructors which are defined in the record
-- declarations.
-- Unlike data declarations or function type annotations, type synonyms and
-- record declarations are not generated from the intermediate language.
-- So the transformation has only to be performed in these cases.
elimRecordTypes :: ValueEnv -> TCEnv -> CS.TypeExpr -> CS.TypeExpr
elimRecordTypes tyEnv tcEnv (CS.ConstructorType qid tys)
= CS.ConstructorType qid (map (elimRecordTypes tyEnv tcEnv) tys)
elimRecordTypes _ _ (CS.VariableType ident)
= CS.VariableType ident
elimRecordTypes tyEnv tcEnv (CS.TupleType tys)
= CS.TupleType (map (elimRecordTypes tyEnv tcEnv) tys)
elimRecordTypes tyEnv tcEnv (CS.ListType ty)
= CS.ListType (elimRecordTypes tyEnv tcEnv ty)
elimRecordTypes tyEnv tcEnv (CS.ArrowType ty1 ty2)
= CS.ArrowType (elimRecordTypes tyEnv tcEnv ty1)
(elimRecordTypes tyEnv tcEnv ty2)
elimRecordTypes tyEnv tcEnv (CS.RecordType fss)
= let fs = flattenRecordTypeFields fss
in case (lookupValue (fst (head fs)) tyEnv) of
[Label _ record _] ->
case (qualLookupTC record tcEnv) of
[AliasType _ n (TypeRecord fs')] ->
let ms = foldl (matchTypeVars fs) Map.empty fs'
types = map (\i -> maybe
(CS.VariableType
(mkIdent ("#tvar" ++ show i)))
(elimRecordTypes tyEnv tcEnv)
(Map.lookup i ms))
[0 .. n-1]
in CS.ConstructorType record types
_ -> internalError ("GenFlatCurry.elimRecordTypes: "
++ "no record type")
_ -> internalError ("GenFlatCurry.elimRecordTypes: "
++ "no label")
matchTypeVars :: [(Ident,CS.TypeExpr)] -> Map.Map Int CS.TypeExpr
-> (Ident, Type) -> Map.Map Int CS.TypeExpr
matchTypeVars fs ms (l,ty) = maybe ms (match ms ty) (lookup l fs)
where
match ms1 (TypeVariable i) typeexpr = Map.insert i typeexpr ms1
match ms1 (TypeConstructor _ tys) (CS.ConstructorType _ typeexprs)
= matchList ms1 tys typeexprs
match ms1 (TypeConstructor _ tys) (CS.ListType typeexpr)
= matchList ms1 tys [typeexpr]
match ms1 (TypeConstructor _ tys) (CS.TupleType typeexprs)
= matchList ms1 tys typeexprs
match ms1 (TypeArrow ty1 ty2) (CS.ArrowType typeexpr1 typeexpr2)
= matchList ms1 [ty1,ty2] [typeexpr1,typeexpr2]
match ms1 (TypeRecord fs') (CS.RecordType fss)
= foldl (matchTypeVars (flattenRecordTypeFields fss)) ms1 fs'
match _ ty1 typeexpr
= internalError ("GenFlatCurry.matchTypeVars: "
++ show ty1 ++ "\n" ++ show typeexpr)
matchList ms1 tys
= foldl (\ms' (ty',typeexpr) -> match ms' ty' typeexpr) ms1 . zip tys
flattenRecordTypeFields :: [([Ident], CS.TypeExpr)] -> [(Ident, CS.TypeExpr)]
flattenRecordTypeFields = concatMap (\ (ls, ty) -> map (\l -> (l, ty)) ls)
cs2ilType :: [(Ident,Int)] -> CS.TypeExpr -> ([(Ident,Int)], IL.Type)
cs2ilType ids (CS.ConstructorType qid typeexprs)
= let (ids', ilTypeexprs) = mapAccumL cs2ilType ids typeexprs
......@@ -826,11 +715,6 @@ isTypeIDecl (CS.IDataDecl _ _ _ _) = True
isTypeIDecl (CS.ITypeDecl _ _ _ _) = True
isTypeIDecl _ = False
--
isRecordIDecl :: CS.IDecl -> Bool
isRecordIDecl (CS.ITypeDecl _ _ _ (CS.RecordType (_:_))) = True
isRecordIDecl _ = False
--
isFuncIDecl :: CS.IDecl -> Bool
isFuncIDecl (CS.IFunctionDecl _ _ _ _) = True
......@@ -863,10 +747,6 @@ exports = gets exportsE
imports :: FlatState [CS.IImportDecl]
imports = gets importsE
--
records :: FlatState [CS.IDecl]
records = gets (filter isRecordIDecl . interfaceE)
--
fixities :: FlatState [CS.IDecl]
fixities = gets fixitiesE
......@@ -893,15 +773,17 @@ lookupIdArity :: QualIdent -> FlatState (Maybe Int)
lookupIdArity qid = gets (lookupA . typeEnvE)
where
lookupA tyEnv = case qualLookupValue qid tyEnv of
[DataConstructor _ a _] -> Just a
[NewtypeConstructor _ _] -> Just 1
[Value _ a _] -> Just a
[] -> case lookupValue (unqualify qid) tyEnv of
[DataConstructor _ a _] -> Just a
[NewtypeConstructor _ _] -> Just 1
[Value _ a _] -> Just a
_ -> Nothing
_ -> Nothing
[DataConstructor _ a _ _] -> Just a
[NewtypeConstructor _ _ _] -> Just 1
[Value _ a _] -> Just a
[Label _ _ _] -> Just 1
[] -> case lookupValue (unqualify qid) tyEnv of
[DataConstructor _ a _ _] -> Just a
[NewtypeConstructor _ _ _] -> Just 1
[Value _ a _] -> Just a
[Label _ _ _] -> Just 1
_ -> Nothing
_ -> Nothing
ttrans :: TCEnv -> ValueEnv -> Type -> IL.Type
ttrans _ _ (TypeVariable v) = IL.TypeVariable v
......@@ -911,14 +793,6 @@ ttrans _ _ (TypeConstrained [] v) = IL.TypeVariable v
ttrans tcEnv tyEnv (TypeConstrained (v:_) _) = ttrans tcEnv tyEnv v
ttrans _ _ (TypeSkolem k) = internalError $
"Generators.GenFlatCurry.ttrans: skolem type " ++ show k
ttrans _ _ (TypeRecord []) = internalError $
"Generators.GenFlatCurry.ttrans: empty type record"
ttrans tcEnv tyEnv (TypeRecord ((l, _):_)) = case lookupValue l tyEnv of
[Label _ rec _ ] -> case qualLookupTC rec tcEnv of
[AliasType _ n (TypeRecord _)] ->
IL.TypeConstructor rec (map IL.TypeVariable [0 .. n - 1])
_ -> internalError $ "Generators.GenFlatCurry.ttrans: unknown record type " ++ show rec
_ -> internalError $ "Generators.GenFlatCurry.ttrans: ambigous record label " ++ show l
-- Constructor (:) receives special treatment throughout the
-- whole implementation. We won't depart from that for mere
......@@ -1033,42 +907,44 @@ bindIdentExport ident isConstr env =
--
bindEnvIDecl :: ModuleIdent -> Map.Map Ident IdentExport -> CS.IDecl -> Map.Map Ident IdentExport
bindEnvIDecl mid env (CS.IDataDecl _ qid _ mcdecls)
bindEnvIDecl mid env (CS.IDataDecl _ qid _ cdecls hs)
= maybe env
(\ident -> foldl bindEnvConstrDecl (bindIdentExport ident False env)
(catMaybes mcdecls))
(\ident -> let env' = bindIdentExport ident False env
env'' = foldl bindEnvConstrDecl env'
[c | c <- cdecls, constrId c `notElem` hs]
in foldl bindEnvLabel env'' [l | l <- labels, l `notElem` hs])
(localIdent mid qid)
bindEnvIDecl mid env (CS.INewtypeDecl _ qid _ ncdecl)
where
labels = nub $ concatMap recordLabels cdecls
bindEnvIDecl mid env (CS.INewtypeDecl _ qid _ ncdecl hs)
= maybe env
(\ident -> bindEnvNewConstrDecl (bindIdentExport ident False env) ncdecl)
(\ident -> let env' = bindIdentExport ident False env
env'' = if ncId `notElem` hs then bindEnvNewConstrDecl env' ncdecl
else env'
in foldl bindEnvLabel env'' [l | l <- labels, l `notElem` hs]
(localIdent mid qid)
where
ncId = nconstrId ncdecl
labels = nrecordLabels ncdecl
bindEnvIDecl mid env (CS.ITypeDecl _ qid _ texpr)
= maybe env (\ident -> bindEnvITypeDecl env ident texpr) (localIdent mid qid)
= maybe env (\ident -> bindIdentExport ident False env) (localIdent mid qid)
bindEnvIDecl mid env (CS.IFunctionDecl _ qid _ _)
= maybe env (\ident -> bindIdentExport ident False env) (localIdent mid qid)
bindEnvIDecl _ env _ = env
--
bindEnvITypeDecl :: Map.Map Ident IdentExport -> Ident -> CS.TypeExpr
-> Map.Map Ident IdentExport
bindEnvITypeDecl env ident (CS.RecordType fs)
= bindIdentExport ident False (foldl (bindEnvRecordLabel ident) env fs)
bindEnvITypeDecl env ident _ = bindIdentExport ident False env
--
bindEnvConstrDecl :: Map.Map Ident IdentExport -> CS.ConstrDecl -> Map.Map Ident IdentExport
bindEnvConstrDecl env (CS.ConstrDecl _ _ ident _) = bindIdentExport ident True env
bindEnvConstrDecl env (CS.ConOpDecl _ _ _ ident _) = bindIdentExport ident True env
bindEnvConstrDecl env (CS.RecordDecl _ _ ident _) = bindIdentExport ident True env
bindEnvLabel :: Map.Map Ident IdentExport -> Ident -> Map.Map Ident IdentExport
bindEnvLabel env l = bindIdentExport l False env
--
bindEnvNewConstrDecl :: Map.Map Ident IdentExport -> CS.NewConstrDecl -> Map.Map Ident IdentExport
bindEnvNewConstrDecl env (CS.NewConstrDecl _ _ ident _) = bindIdentExport ident False env
--
bindEnvRecordLabel :: Ident -> Map.Map Ident IdentExport -> ([Ident],CS.TypeExpr) -> Map.Map Ident IdentExport
bindEnvRecordLabel r env ([lab], _) = bindIdentExport (recSelectorId (qualify r) lab) False expo
where expo = (bindIdentExport (recUpdateId (qualify r) lab) False env)
bindEnvRecordLabel _ _ _ = internalError "GenFlatCurry.bindEnvRecordLabel: no pattern match"
bindEnvNewConstrDecl env (CS.NewRecordDecl _ _ ident _) = bindIdentExport ident False env
splitoffArgTypes :: IL.Type -> [Ident] -> [(Ident, IL.Type)]
splitoffArgTypes (IL.TypeArrow l r) (i:is) = (i, l):splitoffArgTypes r is
......
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