{- | 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 spi li ps m es is ds) = do es' <- qExportSpec es ds' <- mapM qDecl ds return (Module spi li 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 spi x) = Export spi <$> qIdent x qExport (ExportTypeWith spi t cs) = flip (ExportTypeWith spi) cs <$> qConstr t qExport (ExportTypeAll spi t) = ExportTypeAll spi <$> 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 li cx cls tv ds) = ClassDecl p li <$> qContext cx <*> pure cls <*> pure tv <*> mapM qDecl ds qDecl (InstanceDecl p li cx qcls ty ds) = InstanceDecl p li <$> qContext cx <*> qClass qcls <*> qTypeExpr ty <*> mapM qDecl ds qConstrDecl :: Qual ConstrDecl qConstrDecl (ConstrDecl p n tys) = ConstrDecl p n <$> mapM qTypeExpr tys qConstrDecl (ConOpDecl p ty1 op ty2) = ConOpDecl p <$> qTypeExpr ty1 <*> pure op <*> qTypeExpr ty2 qConstrDecl (RecordDecl p c fs) = RecordDecl p c <$> 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 spi cls ty) = Constraint spi <$> qClass cls <*> qTypeExpr ty qContext :: Qual Context qContext = mapM qConstraint qTypeExpr :: Qual TypeExpr qTypeExpr (ConstructorType spi c) = ConstructorType spi <$> qConstr c qTypeExpr (ApplyType spi ty1 ty2) = ApplyType spi <$> qTypeExpr ty1 <*> qTypeExpr ty2 qTypeExpr v@(VariableType _ _) = return v qTypeExpr (TupleType spi tys) = TupleType spi <$> mapM qTypeExpr tys qTypeExpr (ListType spi ty) = ListType spi <$> qTypeExpr ty qTypeExpr (ArrowType spi ty1 ty2) = ArrowType spi <$> qTypeExpr ty1 <*> qTypeExpr ty2 qTypeExpr (ParenType spi ty) = ParenType spi <$> qTypeExpr ty qTypeExpr (ForallType spi vs ty) = ForallType spi vs <$> qTypeExpr ty qQualTypeExpr :: Qual QualTypeExpr qQualTypeExpr (QualTypeExpr spi cx ty) = QualTypeExpr spi <$> 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 sp f ts) = FunLhs sp f <$> mapM qPattern ts qLhs (OpLhs sp t1 op t2) = flip (OpLhs sp) op <$> qPattern t1 <*> qPattern t2 qLhs (ApLhs sp lhs ts) = ApLhs sp <$> 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 spi a c ts) = ConstructorPattern spi a <$> qIdent c <*> mapM qPattern ts qPattern (InfixPattern spi a t1 op t2) = InfixPattern spi a <$> qPattern t1 <*> qIdent op <*> qPattern t2 qPattern (ParenPattern spi t) = ParenPattern spi <$> qPattern t qPattern (RecordPattern spi a c fs) = RecordPattern spi a <$> qIdent c <*> mapM (qField qPattern) fs qPattern (TuplePattern spi ts) = TuplePattern spi <$> mapM qPattern ts qPattern (ListPattern spi a ts) = ListPattern spi a <$> mapM qPattern ts qPattern (AsPattern spi v t) = AsPattern spi v <$> qPattern t qPattern (LazyPattern spi t) = LazyPattern spi <$> qPattern t qPattern (FunctionPattern spi a f ts) = FunctionPattern spi a <$> qIdent f <*> mapM qPattern ts qPattern (InfixFuncPattern spi a t1 op t2) = InfixFuncPattern spi a <$> qPattern t1 <*> qIdent op <*> qPattern t2 qRhs :: Qual (Rhs a) qRhs (SimpleRhs spi li e ds) = SimpleRhs spi li <$> qExpr e <*> mapM qDecl ds qRhs (GuardedRhs spi li es ds) = GuardedRhs spi li <$> 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 spi a v) = Variable spi a <$> qIdent v qExpr (Constructor spi a c) = Constructor spi a <$> qIdent c qExpr (Paren spi e) = Paren spi <$> qExpr e qExpr (Typed spi e qty) = Typed spi <$> qExpr e <*> qQualTypeExpr qty qExpr (Record spi a c fs) = Record spi a <$> qIdent c <*> mapM (qField qExpr) fs qExpr (RecordUpdate spi e fs) = RecordUpdate spi <$> qExpr e <*> mapM (qField qExpr) fs qExpr (Tuple spi es) = Tuple spi <$> mapM qExpr es qExpr (List spi a es) = List spi a <$> mapM qExpr es qExpr (ListCompr spi e qs) = ListCompr spi <$> qExpr e <*> mapM qStmt qs qExpr (EnumFrom spi e) = EnumFrom spi <$> qExpr e qExpr (EnumFromThen spi e1 e2) = EnumFromThen spi <$> qExpr e1 <*> qExpr e2 qExpr (EnumFromTo spi e1 e2) = EnumFromTo spi <$> qExpr e1 <*> qExpr e2 qExpr (EnumFromThenTo spi e1 e2 e3) = EnumFromThenTo spi <$> qExpr e1 <*> qExpr e2 <*> qExpr e3 qExpr (UnaryMinus spi e) = UnaryMinus spi <$> qExpr e qExpr (Apply spi e1 e2) = Apply spi <$> qExpr e1 <*> qExpr e2 qExpr (InfixApply spi e1 op e2) = InfixApply spi <$> qExpr e1 <*> qInfixOp op <*> qExpr e2 qExpr (LeftSection spi e op) = LeftSection spi <$> qExpr e <*> qInfixOp op qExpr (RightSection spi op e) = RightSection spi <$> qInfixOp op <*> qExpr e qExpr (Lambda spi ts e) = Lambda spi <$> mapM qPattern ts <*> qExpr e qExpr (Let spi li ds e) = Let spi li <$> mapM qDecl ds <*> qExpr e qExpr (Do spi li sts e) = Do spi li <$> mapM qStmt sts <*> qExpr e qExpr (IfThenElse spi e1 e2 e3) = IfThenElse spi <$> qExpr e1 <*> qExpr e2 <*> qExpr e3 qExpr (Case spi li ct e as) = Case spi li ct <$> qExpr e <*> mapM qAlt as qStmt :: Qual (Statement a) qStmt (StmtExpr spi e) = StmtExpr spi <$> qExpr e qStmt (StmtBind spi t e) = StmtBind spi <$> qPattern t <*> qExpr e qStmt (StmtDecl spi li ds) = StmtDecl spi li <$> 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