{- | 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