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

AbstractCurry: Qualify global declarations for easier meta-programming

This change also qualifies the names in global (top-level) declarations
although the names can only be notated unqualified in Curry. This is to
faciliate the meta-programming, for instance the retrieval of a function
declaration. In addition, primitive entities such as tuples, unit and
list constructors are qualified for the same reason.
parent 0c8dc9bc
...@@ -66,7 +66,7 @@ trModule (Module _ mid _ is ds) = do ...@@ -66,7 +66,7 @@ trModule (Module _ mid _ is ds) = do
mid' = moduleName mid mid' = moduleName mid
is' = map cvImportDecl is is' = map cvImportDecl is
ts' = concat <$> mapM (withLocalEnv . trTypeDecl ) ds ts' = concat <$> mapM (withLocalEnv . trTypeDecl ) ds
fs' = concat <$> mapM (withLocalEnv . trFuncDecl ) ds fs' = concat <$> mapM (withLocalEnv . trFuncDecl True) ds
os' = concat <$> mapM (withLocalEnv . trInfixDecl) ds os' = concat <$> mapM (withLocalEnv . trInfixDecl) ds
cvImportDecl :: ImportDecl -> String cvImportDecl :: ImportDecl -> String
...@@ -74,33 +74,33 @@ cvImportDecl (ImportDecl _ mid _ _ _) = moduleName mid ...@@ -74,33 +74,33 @@ cvImportDecl (ImportDecl _ mid _ _ _) = moduleName mid
trTypeDecl :: Decl -> GAC [CTypeDecl] trTypeDecl :: Decl -> GAC [CTypeDecl]
trTypeDecl (DataDecl _ t vs cs) = (\t' v vs' cs' -> [CType t' v vs' cs']) trTypeDecl (DataDecl _ t vs cs) = (\t' v vs' cs' -> [CType t' v vs' cs'])
<$> trLocalIdent t <*> getVisibility t <$> trGlobalIdent t <*> getVisibility t
<*> mapM genTVarIndex vs <*> mapM trConsDecl cs <*> mapM genTVarIndex vs <*> mapM trConsDecl cs
trTypeDecl (TypeDecl _ t vs ty) = (\t' v vs' ty' -> [CTypeSyn t' v vs' ty']) trTypeDecl (TypeDecl _ t vs ty) = (\t' v vs' ty' -> [CTypeSyn t' v vs' ty'])
<$> trLocalIdent t <*> getVisibility t <$> trGlobalIdent t <*> getVisibility t
<*> mapM genTVarIndex vs <*> trTypeExpr ty <*> mapM genTVarIndex vs <*> trTypeExpr ty
trTypeDecl (NewtypeDecl _ t vs nc) = (\t' v vs' nc' -> [CNewType t' v vs' nc']) trTypeDecl (NewtypeDecl _ t vs nc) = (\t' v vs' nc' -> [CNewType t' v vs' nc'])
<$> trLocalIdent t <*> getVisibility t <$> trGlobalIdent t <*> getVisibility t
<*> mapM genTVarIndex vs <*> trNewConsDecl nc <*> mapM genTVarIndex vs <*> trNewConsDecl nc
trTypeDecl _ = return [] trTypeDecl _ = return []
trConsDecl :: ConstrDecl -> GAC CConsDecl trConsDecl :: ConstrDecl -> GAC CConsDecl
trConsDecl (ConstrDecl _ _ c tys) = CCons trConsDecl (ConstrDecl _ _ c tys) = CCons
<$> trLocalIdent c <*> getVisibility c <*> mapM trTypeExpr tys <$> trGlobalIdent c <*> getVisibility c <*> mapM trTypeExpr tys
trConsDecl (ConOpDecl p vs ty1 op ty2) = trConsDecl $ trConsDecl (ConOpDecl p vs ty1 op ty2) = trConsDecl $
ConstrDecl p vs op [ty1, ty2] ConstrDecl p vs op [ty1, ty2]
trConsDecl (RecordDecl _ _ c fs) = CRecord trConsDecl (RecordDecl _ _ c fs) = CRecord
<$> trLocalIdent c <*> getVisibility c <*> (concat <$> mapM trFieldDecl fs) <$> trGlobalIdent c <*> getVisibility c <*> (concat <$> mapM trFieldDecl fs)
trFieldDecl :: FieldDecl -> GAC [CFieldDecl] trFieldDecl :: FieldDecl -> GAC [CFieldDecl]
trFieldDecl (FieldDecl _ ls ty) = T.forM ls $ \l -> trFieldDecl (FieldDecl _ ls ty) = T.forM ls $ \l ->
CField <$> trLocalIdent l <*> getVisibility l <*> trTypeExpr ty CField <$> trGlobalIdent l <*> getVisibility l <*> trTypeExpr ty
trNewConsDecl :: NewConstrDecl -> GAC CConsDecl trNewConsDecl :: NewConstrDecl -> GAC CConsDecl
trNewConsDecl (NewConstrDecl _ _ nc ty) = CCons trNewConsDecl (NewConstrDecl _ _ nc ty) = CCons
<$> trLocalIdent nc <*> getVisibility nc <*> ((:[]) <$> trTypeExpr ty) <$> trGlobalIdent nc <*> getVisibility nc <*> ((:[]) <$> trTypeExpr ty)
trNewConsDecl (NewRecordDecl p _ nc (l, ty)) = CRecord trNewConsDecl (NewRecordDecl p _ nc (l, ty)) = CRecord
<$> trLocalIdent nc <*> getVisibility nc <*> trFieldDecl (FieldDecl p [l] ty) <$> trGlobalIdent nc <*> getVisibility nc <*> trFieldDecl (FieldDecl p [l] ty)
trTypeExpr :: TypeExpr -> GAC CTypeExpr trTypeExpr :: TypeExpr -> GAC CTypeExpr
trTypeExpr (ConstructorType q ts) = CTCons <$> trQual q trTypeExpr (ConstructorType q ts) = CTCons <$> trQual q
...@@ -117,27 +117,29 @@ trTypeExpr (ArrowType ty1 ty2) = CFuncType <$> trTypeExpr ty1 ...@@ -117,27 +117,29 @@ trTypeExpr (ArrowType ty1 ty2) = CFuncType <$> trTypeExpr ty1
trInfixDecl :: Decl -> GAC [COpDecl] trInfixDecl :: Decl -> GAC [COpDecl]
trInfixDecl (InfixDecl _ fix mprec ops) = mapM trInfix (reverse ops) trInfixDecl (InfixDecl _ fix mprec ops) = mapM trInfix (reverse ops)
where where
trInfix op = COp <$> trLocalIdent op <*> return (cvFixity fix) trInfix op = COp <$> trGlobalIdent op <*> return (cvFixity fix)
<*> return (fromInteger (mkPrec mprec)) <*> return (fromInteger (mkPrec mprec))
cvFixity InfixL = CInfixlOp cvFixity InfixL = CInfixlOp
cvFixity InfixR = CInfixrOp cvFixity InfixR = CInfixrOp
cvFixity Infix = CInfixOp cvFixity Infix = CInfixOp
trInfixDecl _ = return [] trInfixDecl _ = return []
trFuncDecl :: Decl -> GAC [CFuncDecl] trFuncDecl :: Bool -> Decl -> GAC [CFuncDecl]
trFuncDecl (FunctionDecl _ f eqs) = (\f' a v ty rs -> [CFunc f' a v ty rs]) trFuncDecl global (FunctionDecl _ f eqs)
<$> trLocalIdent f <*> getArity f <*> getVisibility f = (\f' a v ty rs -> [CFunc f' a v ty rs])
<*> (getType f >>= trTypeExpr) <$> trFuncName global f <*> getArity f <*> getVisibility f
<*> mapM trEquation eqs <*> getType f <*> mapM trEquation eqs
trFuncDecl (ForeignDecl _ _ _ f _) = (\f' a v ty rs -> [CFunc f' a v ty rs]) trFuncDecl global (ForeignDecl _ _ _ f _)
<$> trLocalIdent f <*> getArity f <*> getVisibility f = (\f' a v ty rs -> [CFunc f' a v ty rs])
<*> (getType f >>= trTypeExpr) <$> trFuncName global f <*> getArity f <*> getVisibility f
<*> return [] <*> getType f <*> return []
trFuncDecl (ExternalDecl _ fs) = T.forM fs $ \f -> CFunc trFuncDecl global (ExternalDecl _ fs) = T.forM fs $ \f -> CFunc
<$> trLocalIdent f <*> getArity f <*> getVisibility f <$> trFuncName global f <*> getArity f <*> getVisibility f
<*> (getType f >>= trTypeExpr) <*> getType f <*> return []
<*> return [] trFuncDecl _ _ = return []
trFuncDecl _ = return []
trFuncName :: Bool -> Ident -> GAC QName
trFuncName global = if global then trGlobalIdent else trLocalIdent
trEquation :: Equation -> GAC CRule trEquation :: Equation -> GAC CRule
trEquation (Equation _ lhs rhs) = inNestedScope trEquation (Equation _ lhs rhs) = inNestedScope
...@@ -172,9 +174,9 @@ insertDeclLhs s@(TypeSig _ _ _) = do ...@@ -172,9 +174,9 @@ insertDeclLhs s@(TypeSig _ _ _) = do
insertDeclLhs _ = return () insertDeclLhs _ = return ()
trLocalDecl :: Decl -> GAC [CLocalDecl] trLocalDecl :: Decl -> GAC [CLocalDecl]
trLocalDecl f@(FunctionDecl _ _ _) = map CLocalFunc <$> trFuncDecl f trLocalDecl f@(FunctionDecl _ _ _) = map CLocalFunc <$> trFuncDecl False f
trLocalDecl f@(ForeignDecl _ _ _ _ _) = map CLocalFunc <$> trFuncDecl f trLocalDecl f@(ForeignDecl _ _ _ _ _) = map CLocalFunc <$> trFuncDecl False f
trLocalDecl f@(ExternalDecl _ _) = map CLocalFunc <$> trFuncDecl f trLocalDecl f@(ExternalDecl _ _) = map CLocalFunc <$> trFuncDecl False f
trLocalDecl (PatternDecl _ p rhs) = (\p' rhs' -> [CLocalPat p' rhs']) trLocalDecl (PatternDecl _ p rhs) = (\p' rhs' -> [CLocalPat p' rhs'])
<$> trPat p <*> trRhs rhs <$> trPat p <*> trRhs rhs
trLocalDecl (FreeDecl _ vs) = (\vs' -> [CLocalVars vs']) trLocalDecl (FreeDecl _ vs) = (\vs' -> [CLocalVars vs'])
...@@ -192,10 +194,9 @@ trExpr :: Expression -> GAC CExpr ...@@ -192,10 +194,9 @@ trExpr :: Expression -> GAC CExpr
trExpr (Literal l) = return (CLit $ cvLiteral l) trExpr (Literal l) = return (CLit $ cvLiteral l)
trExpr (Variable v) trExpr (Variable v)
| isQualified v = CSymbol <$> trQual v | isQualified v = CSymbol <$> trQual v
| otherwise = lookupVarIndex v' >>= \mvi -> case mvi of | otherwise = lookupVarIndex (unqualify v) >>= \mvi -> case mvi of
Just vi -> return (CVar vi) Just vi -> return (CVar vi)
_ -> CSymbol <$> trLocalIdent v' _ -> CSymbol <$> trQual v
where v' = unqualify v
trExpr (Constructor c) = CSymbol <$> trQual c trExpr (Constructor c) = CSymbol <$> trQual c
trExpr (Paren e) = trExpr e trExpr (Paren e) = trExpr e
trExpr (Typed e ty) = CTyped <$> trExpr e <*> trTypeExpr ty trExpr (Typed e ty) = CTyped <$> trExpr e <*> trTypeExpr ty
...@@ -294,7 +295,15 @@ cvLiteral (Float _ f) = CFloatc f ...@@ -294,7 +295,15 @@ cvLiteral (Float _ f) = CFloatc f
cvLiteral (String _ s) = CStringc s cvLiteral (String _ s) = CStringc s
trQual :: QualIdent -> GAC QName trQual :: QualIdent -> GAC QName
trQual qid = return (maybe "" moduleName (qidModule qid), idName (qidIdent qid)) trQual qid
| n `elem` [unitId, listId, nilId, consId] = return ("Prelude", idName n)
| isTupleId n = return ("Prelude", idName n)
| otherwise
= return (maybe "" moduleName (qidModule qid), idName n)
where n = qidIdent qid
trGlobalIdent :: Ident -> GAC QName
trGlobalIdent i = S.gets moduleId >>= \m -> return (moduleName m, idName i)
trLocalIdent :: Ident -> GAC QName trLocalIdent :: Ident -> GAC QName
trLocalIdent i = return ("", idName i) trLocalIdent i = return ("", idName i)
...@@ -443,8 +452,8 @@ getArity f = do ...@@ -443,8 +452,8 @@ getArity f = do
[Value _ a _] -> a [Value _ a _] -> a
_ -> internalError $ "GenAbstractCurry.getArity: " ++ show f _ -> internalError $ "GenAbstractCurry.getArity: " ++ show f
getType :: Ident -> GAC TypeExpr getType :: Ident -> GAC CTypeExpr
getType f = S.gets untypedAcy >>= getType' f getType f = S.gets untypedAcy >>= getType' f >>= trTypeExpr
getType' :: Ident -> Bool -> GAC TypeExpr getType' :: Ident -> Bool -> GAC TypeExpr
getType' f True = do getType' f True = do
......
module Qual where
f :: a -> ()
f x = g (Qual.g x)
where g y = y
g :: a -> ()
g _ = ()
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