curry-frontend-1.0.1: src/Transformations/Qual.hs
{- |
Module : $Header$
Description : Proper Qualification
Copyright : (c) 2001 - 2004 Wolfgang Lux
2005 Martin Engelke
2011 - 2015 Björn Peemöller
2016 - 2017 Finn Teegen
License : BSD-3-clause
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
After checking the module and before starting the translation into the
intermediate language, the compiler properly qualifies all type
constructors, data constructors and (global) functions
occurring in a pattern or expression such that their module prefix
matches the module of their definition.
This is done also for functions and constructors declared
in the current module.
Only functions and variables declared in local declarations groups
as well as function arguments remain unchanged.
-}
{-# LANGUAGE CPP #-}
module Transformations.Qual (qual) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>), pure)
#endif
import qualified Control.Monad.Reader as R (Reader, asks, runReader)
import Data.Traversable
import Prelude hiding (mapM)
import Curry.Base.Ident
import Curry.Syntax
import Base.TopEnv (origName)
import Env.TypeConstructor (TCEnv , qualLookupTypeInfo)
import Env.Value (ValueEnv, qualLookupValue)
data QualEnv = QualEnv
{ moduleIdent :: ModuleIdent
, tyConsEnv :: TCEnv
, valueEnv :: ValueEnv
}
type Qual a = a -> R.Reader QualEnv a
qual :: ModuleIdent -> TCEnv -> ValueEnv -> Module a -> Module a
qual m tcEnv tyEnv mdl = R.runReader (qModule mdl) (QualEnv m tcEnv tyEnv)
qModule :: Qual (Module a)
qModule (Module ps m es is ds) = do
es' <- qExportSpec es
ds' <- mapM qDecl ds
return (Module ps m es' is ds')
qExportSpec :: Qual (Maybe ExportSpec)
qExportSpec Nothing = return Nothing
qExportSpec (Just (Exporting p es)) = (Just . Exporting p) <$> mapM qExport es
qExport :: Qual Export
qExport (Export x) = Export <$> qIdent x
qExport (ExportTypeWith t cs) = flip ExportTypeWith cs <$> qConstr t
qExport (ExportTypeAll t) = ExportTypeAll <$> qConstr t
qExport m@(ExportModule _) = return m
qDecl :: Qual (Decl a)
qDecl i@(InfixDecl _ _ _ _) = return i
qDecl (DataDecl p n vs cs clss) = DataDecl p n vs <$>
mapM qConstrDecl cs <*> mapM qClass clss
qDecl e@(ExternalDataDecl _ _ _) = return e
qDecl (NewtypeDecl p n vs nc clss) = NewtypeDecl p n vs <$>
qNewConstrDecl nc <*> mapM qClass clss
qDecl (TypeDecl p n vs ty) = TypeDecl p n vs <$> qTypeExpr ty
qDecl (TypeSig p fs qty) = TypeSig p fs <$> qQualTypeExpr qty
qDecl (FunctionDecl a p f eqs) = FunctionDecl a p f <$> mapM qEquation eqs
qDecl e@(ExternalDecl _ _) = return e
qDecl (PatternDecl p t rhs) = PatternDecl p <$> qPattern t <*> qRhs rhs
qDecl vs@(FreeDecl _ _) = return vs
qDecl (DefaultDecl p tys) = DefaultDecl p <$> mapM qTypeExpr tys
qDecl (ClassDecl p cx cls tv ds) = ClassDecl p <$>
qContext cx <*> pure cls <*> pure tv <*> mapM qDecl ds
qDecl (InstanceDecl p cx qcls ty ds) = InstanceDecl p <$>
qContext cx <*> qClass qcls <*> qTypeExpr ty <*> mapM qDecl ds
qConstrDecl :: Qual ConstrDecl
qConstrDecl (ConstrDecl p vs cx n tys) =
flip (ConstrDecl p vs) n <$> qContext cx <*> mapM qTypeExpr tys
qConstrDecl (ConOpDecl p vs cx ty1 op ty2) =
ConOpDecl p vs <$> qContext cx <*> qTypeExpr ty1 <*> pure op <*> qTypeExpr ty2
qConstrDecl (RecordDecl p vs cx c fs) =
flip (RecordDecl p vs) c <$> qContext cx <*> mapM qFieldDecl fs
qNewConstrDecl :: Qual NewConstrDecl
qNewConstrDecl (NewConstrDecl p n ty)
= NewConstrDecl p n <$> qTypeExpr ty
qNewConstrDecl (NewRecordDecl p n (f, ty))
= (\ty' -> NewRecordDecl p n (f, ty')) <$> qTypeExpr ty
qFieldDecl :: Qual FieldDecl
qFieldDecl (FieldDecl p fs ty) = FieldDecl p fs <$> qTypeExpr ty
qConstraint :: Qual Constraint
qConstraint (Constraint cls ty) = Constraint <$> qClass cls <*> qTypeExpr ty
qContext :: Qual Context
qContext = mapM qConstraint
qTypeExpr :: Qual TypeExpr
qTypeExpr (ConstructorType c) = ConstructorType <$> qConstr c
qTypeExpr (ApplyType ty1 ty2) = ApplyType <$> qTypeExpr ty1
<*> qTypeExpr ty2
qTypeExpr v@(VariableType _) = return v
qTypeExpr (TupleType tys) = TupleType <$> mapM qTypeExpr tys
qTypeExpr (ListType ty) = ListType <$> qTypeExpr ty
qTypeExpr (ArrowType ty1 ty2) = ArrowType <$> qTypeExpr ty1
<*> qTypeExpr ty2
qTypeExpr (ParenType ty) = ParenType <$> qTypeExpr ty
qTypeExpr (ForallType vs ty) = ForallType vs <$> qTypeExpr ty
qQualTypeExpr :: Qual QualTypeExpr
qQualTypeExpr (QualTypeExpr cx ty) = QualTypeExpr <$> qContext cx
<*> qTypeExpr ty
qEquation :: Qual (Equation a)
qEquation (Equation p lhs rhs) = Equation p <$> qLhs lhs <*> qRhs rhs
qLhs :: Qual (Lhs a)
qLhs (FunLhs f ts) = FunLhs f <$> mapM qPattern ts
qLhs (OpLhs t1 op t2) = flip OpLhs op <$> qPattern t1 <*> qPattern t2
qLhs (ApLhs lhs ts) = ApLhs <$> qLhs lhs <*> mapM qPattern ts
qPattern :: Qual (Pattern a)
qPattern l@(LiteralPattern _ _) = return l
qPattern n@(NegativePattern _ _) = return n
qPattern v@(VariablePattern _ _) = return v
qPattern (ConstructorPattern a c ts) = ConstructorPattern a
<$> qIdent c <*> mapM qPattern ts
qPattern (InfixPattern a t1 op t2) = InfixPattern a <$> qPattern t1
<*> qIdent op
<*> qPattern t2
qPattern (ParenPattern t) = ParenPattern <$> qPattern t
qPattern (RecordPattern a c fs) = RecordPattern a <$> qIdent c
<*> mapM (qField qPattern) fs
qPattern (TuplePattern ts) = TuplePattern <$> mapM qPattern ts
qPattern (ListPattern a ts) = ListPattern a <$> mapM qPattern ts
qPattern (AsPattern v t) = AsPattern v <$> qPattern t
qPattern (LazyPattern t) = LazyPattern <$> qPattern t
qPattern (FunctionPattern a f ts) = FunctionPattern a <$> qIdent f
<*> mapM qPattern ts
qPattern (InfixFuncPattern a t1 op t2) = InfixFuncPattern a <$> qPattern t1
<*> qIdent op
<*> qPattern t2
qRhs :: Qual (Rhs a)
qRhs (SimpleRhs p e ds) = SimpleRhs p <$> qExpr e <*> mapM qDecl ds
qRhs (GuardedRhs es ds) = GuardedRhs <$> mapM qCondExpr es <*> mapM qDecl ds
qCondExpr :: Qual (CondExpr a)
qCondExpr (CondExpr p g e) = CondExpr p <$> qExpr g <*> qExpr e
qExpr :: Qual (Expression a)
qExpr l@(Literal _ _) = return l
qExpr (Variable a v) = Variable a <$> qIdent v
qExpr (Constructor a c) = Constructor a <$> qIdent c
qExpr (Paren e) = Paren <$> qExpr e
qExpr (Typed e qty) = Typed <$> qExpr e
<*> qQualTypeExpr qty
qExpr (Record a c fs) =
Record a <$> qIdent c <*> mapM (qField qExpr) fs
qExpr (RecordUpdate e fs) = RecordUpdate <$> qExpr e
<*> mapM (qField qExpr) fs
qExpr (Tuple es) = Tuple <$> mapM qExpr es
qExpr (List a es) = List a <$> mapM qExpr es
qExpr (ListCompr e qs) = ListCompr <$> qExpr e <*> mapM qStmt qs
qExpr (EnumFrom e) = EnumFrom <$> qExpr e
qExpr (EnumFromThen e1 e2) = EnumFromThen <$> qExpr e1 <*> qExpr e2
qExpr (EnumFromTo e1 e2) = EnumFromTo <$> qExpr e1 <*> qExpr e2
qExpr (EnumFromThenTo e1 e2 e3) = EnumFromThenTo <$> qExpr e1 <*> qExpr e2
<*> qExpr e3
qExpr (UnaryMinus e) = UnaryMinus <$> qExpr e
qExpr (Apply e1 e2) = Apply <$> qExpr e1 <*> qExpr e2
qExpr (InfixApply e1 op e2) = InfixApply <$> qExpr e1 <*> qInfixOp op
<*> qExpr e2
qExpr (LeftSection e op) = LeftSection <$> qExpr e <*> qInfixOp op
qExpr (RightSection op e) = RightSection <$> qInfixOp op <*> qExpr e
qExpr (Lambda ts e) = Lambda <$> mapM qPattern ts <*> qExpr e
qExpr (Let ds e) = Let <$> mapM qDecl ds <*> qExpr e
qExpr (Do sts e) = Do <$> mapM qStmt sts <*> qExpr e
qExpr (IfThenElse e1 e2 e3) = IfThenElse <$> qExpr e1 <*> qExpr e2
<*> qExpr e3
qExpr (Case ct e as) = Case ct <$> qExpr e <*> mapM qAlt as
qStmt :: Qual (Statement a)
qStmt (StmtExpr e) = StmtExpr <$> qExpr e
qStmt (StmtBind t e) = StmtBind <$> qPattern t <*> qExpr e
qStmt (StmtDecl ds) = StmtDecl <$> mapM qDecl ds
qAlt :: Qual (Alt a)
qAlt (Alt p t rhs) = Alt p <$> qPattern t <*> qRhs rhs
qField :: Qual a -> Qual (Field a)
qField q (Field p l x) = Field p <$> qIdent l <*> q x
qInfixOp :: Qual (InfixOp a)
qInfixOp (InfixOp a op) = InfixOp a <$> qIdent op
qInfixOp (InfixConstr a op) = InfixConstr a <$> qIdent op
qIdent :: Qual QualIdent
qIdent x | isQualified x = x'
| hasGlobalScope (unqualify x) = x'
| otherwise = return x
where
x' = do
m <- R.asks moduleIdent
tyEnv <- R.asks valueEnv
return $ case qualLookupValue x tyEnv of
[y] -> origName y
_ -> case qualLookupValue qmx tyEnv of
[y] -> origName y
_ -> qmx
where qmx = qualQualify m x
qConstr :: Qual QualIdent
qConstr x = do
m <- R.asks moduleIdent
tcEnv <- R.asks tyConsEnv
return $ case qualLookupTypeInfo x tcEnv of
[y] -> origName y
_ -> case qualLookupTypeInfo qmx tcEnv of
[y] -> origName y
_ -> qmx
where qmx = qualQualify m x
qClass :: Qual QualIdent
qClass = qConstr