Qual.hs 9 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1 2 3 4 5
{- |
    Module      :  $Header$
    Description :  Proper Qualification
    Copyright   :  (c) 2001 - 2004 Wolfgang Lux
                       2005        Martin Engelke
6
                       2011 - 2015 Björn Peemöller
Björn Peemöller 's avatar
Björn Peemöller committed
7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
    License     :  OtherLicense

    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.
-}
23
{-# LANGUAGE CPP #-}
Björn Peemöller 's avatar
Björn Peemöller committed
24 25
module Transformations.Qual (qual) where

26
#if __GLASGOW_HASKELL__ < 710
27 28
import           Control.Applicative        ((<$>), (<*>))
#endif
Björn Peemöller 's avatar
Björn Peemöller committed
29
import qualified Control.Monad.Reader as R (Reader, asks, runReader)
Björn Peemöller 's avatar
Björn Peemöller committed
30 31
import           Data.Traversable
import           Prelude hiding            (mapM)
Björn Peemöller 's avatar
Björn Peemöller committed
32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48

import Curry.Base.Ident
import Curry.Syntax

import Base.TopEnv         (origName)

import Env.TypeConstructor (TCEnv   , qualLookupTC)
import Env.Value           (ValueEnv, qualLookupValue)

data QualEnv = QualEnv
  { moduleIdent :: ModuleIdent
  , tyConsEnv   :: TCEnv
  , valueEnv    :: ValueEnv
  }

type Qual a = a -> R.Reader QualEnv a

49 50 51 52 53 54 55 56 57 58 59
qual :: ModuleIdent -> TCEnv -> ValueEnv -> Module -> Module
qual m tcEnv tyEnv mdl = R.runReader (qModule mdl) (QualEnv m tcEnv tyEnv)

qModule :: Qual Module
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
60
qExportSpec (Just (Exporting p es)) = (Just . Exporting p) <$> mapM qExport es
61 62

qExport :: Qual Export
63 64 65
qExport (Export            x) = Export <$> qIdent x
qExport (ExportTypeWith t cs) = flip ExportTypeWith cs <$> qConstr t
qExport (ExportTypeAll     t) = ExportTypeAll <$> qConstr t
66
qExport m@(ExportModule    _) = return m
Björn Peemöller 's avatar
Björn Peemöller committed
67 68 69

qDecl :: Qual Decl
qDecl i@(InfixDecl     _ _ _ _) = return i
70 71 72 73 74 75
qDecl (DataDecl      p n vs cs) = DataDecl p n vs     <$> mapM qConstrDecl cs
qDecl (NewtypeDecl   p n vs nc) = NewtypeDecl p n vs  <$> qNewConstrDecl nc
qDecl (TypeDecl      p n vs ty) = TypeDecl p n vs     <$> qTypeExpr ty
qDecl (TypeSig         p fs ty) = TypeSig p fs        <$> qTypeExpr ty
qDecl (FunctionDecl    p f eqs) = FunctionDecl p f    <$> mapM qEquation eqs
qDecl (ForeignDecl  p c x n ty) = ForeignDecl p c x n <$> qTypeExpr ty
76
qDecl e@(ExternalDecl      _ _) = return e
77
qDecl (PatternDecl     p t rhs) = PatternDecl p <$> qPattern t <*> qRhs rhs
Björn Peemöller 's avatar
Björn Peemöller committed
78
qDecl vs@(FreeDecl         _ _) = return vs
Björn Peemöller 's avatar
Björn Peemöller committed
79 80

qConstrDecl :: Qual ConstrDecl
81
qConstrDecl (ConstrDecl p vs      n tys) = ConstrDecl p vs n
82
                                          <$> mapM qTypeExpr tys
83
qConstrDecl (ConOpDecl  p vs ty1 op ty2) = flip (ConOpDecl p vs) op
84
                                          <$> qTypeExpr ty1 <*> qTypeExpr ty2
85 86
qConstrDecl (RecordDecl p vs       c fs) = RecordDecl p vs c
                                          <$> mapM qFieldDecl fs
Björn Peemöller 's avatar
Björn Peemöller committed
87 88 89

qNewConstrDecl :: Qual NewConstrDecl
qNewConstrDecl (NewConstrDecl p vs n ty)
90
  = NewConstrDecl p vs n <$> qTypeExpr ty
91
qNewConstrDecl (NewRecordDecl p vs n (f, ty))
92
  = (\ty' -> NewRecordDecl p vs n (f, ty')) <$> qTypeExpr ty
93 94

qFieldDecl :: Qual FieldDecl
95
qFieldDecl (FieldDecl p fs ty) = FieldDecl p fs <$> qTypeExpr ty
Björn Peemöller 's avatar
Björn Peemöller committed
96 97

qTypeExpr :: Qual TypeExpr
98 99
qTypeExpr (ConstructorType c tys) = ConstructorType <$> qConstr c
                                                    <*> mapM qTypeExpr tys
Björn Peemöller 's avatar
Björn Peemöller committed
100
qTypeExpr v@(VariableType      _) = return v
101 102 103 104
qTypeExpr (TupleType         tys) = TupleType <$> mapM qTypeExpr tys
qTypeExpr (ListType           ty) = ListType  <$> qTypeExpr ty
qTypeExpr (ArrowType     ty1 ty2) = ArrowType <$> qTypeExpr ty1
                                              <*> qTypeExpr ty2
105
qTypeExpr (ParenType          ty) = ParenType <$> qTypeExpr ty
Björn Peemöller 's avatar
Björn Peemöller committed
106 107

qEquation :: Qual Equation
108
qEquation (Equation p lhs rhs) = Equation p <$> qLhs lhs <*> qRhs rhs
Björn Peemöller 's avatar
Björn Peemöller committed
109 110

qLhs :: Qual Lhs
111 112 113
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
Björn Peemöller 's avatar
Björn Peemöller committed
114

115
qPattern :: Qual Pattern
Björn Peemöller 's avatar
Björn Peemöller committed
116 117 118
qPattern l@(LiteralPattern        _) = return l
qPattern n@(NegativePattern     _ _) = return n
qPattern v@(VariablePattern       _) = return v
119 120 121 122 123
qPattern (ConstructorPattern   c ts) = ConstructorPattern
                                       <$> qIdent c <*> mapM qPattern ts
qPattern (InfixPattern     t1 op t2) = InfixPattern <$> qPattern t1
                                       <*> qIdent op <*> qPattern t2
qPattern (ParenPattern            t) = ParenPattern   <$> qPattern t
124 125
qPattern (RecordPattern        c fs) = RecordPattern  <$> qIdent c
                                       <*> mapM (qField qPattern) fs
126 127 128 129 130 131 132 133
qPattern (TuplePattern         p ts) = TuplePattern p <$> mapM qPattern ts
qPattern (ListPattern          p ts) = ListPattern  p <$> mapM qPattern ts
qPattern (AsPattern             v t) = AsPattern    v <$> qPattern t
qPattern (LazyPattern           p t) = LazyPattern  p <$> qPattern t
qPattern (FunctionPattern      f ts) = FunctionPattern <$> qIdent f
                                                       <*> mapM qPattern ts
qPattern (InfixFuncPattern t1 op t2) = InfixFuncPattern <$> qPattern t1
                                       <*> qIdent op <*> qPattern t2
Björn Peemöller 's avatar
Björn Peemöller committed
134 135

qRhs :: Qual Rhs
136 137
qRhs (SimpleRhs p e ds) = SimpleRhs p <$> qExpr e           <*> mapM qDecl ds
qRhs (GuardedRhs es ds) = GuardedRhs  <$> mapM qCondExpr es <*> mapM qDecl ds
Björn Peemöller 's avatar
Björn Peemöller committed
138 139

qCondExpr :: Qual CondExpr
140
qCondExpr (CondExpr p g e) = CondExpr p <$> qExpr g <*> qExpr e
Björn Peemöller 's avatar
Björn Peemöller committed
141 142 143

qExpr :: Qual Expression
qExpr l@(Literal             _) = return l
144 145 146 147
qExpr (Variable              v) = Variable       <$> qIdent v
qExpr (Constructor           c) = Constructor    <$> qIdent c
qExpr (Paren                 e) = Paren          <$> qExpr e
qExpr (Typed              e ty) = Typed          <$> qExpr e <*> qTypeExpr ty
148 149 150
qExpr (Record             c fs) = Record <$> qIdent c <*> mapM (qField qExpr) fs
qExpr (RecordUpdate       e fs) = RecordUpdate   <$> qExpr e
                                                 <*> mapM (qField qExpr) fs
151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
qExpr (Tuple              p es) = Tuple p        <$> mapM qExpr es
qExpr (List               p es) = List p         <$> mapM qExpr es
qExpr (ListCompr        p e qs) = ListCompr p    <$> 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         op e) = UnaryMinus op  <$> 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           r ts e) = Lambda r     <$> 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   r e1 e2 e3) = IfThenElse r <$> qExpr e1 <*> qExpr e2
                                                            <*> qExpr e3
qExpr (Case          r ct e as) = Case r ct    <$> qExpr e <*> mapM qAlt as
Björn Peemöller 's avatar
Björn Peemöller committed
171 172

qStmt :: Qual Statement
173 174 175
qStmt (StmtExpr p   e) = StmtExpr p <$> qExpr e
qStmt (StmtBind p t e) = StmtBind p <$> qPattern t <*> qExpr e
qStmt (StmtDecl    ds) = StmtDecl   <$> mapM qDecl ds
Björn Peemöller 's avatar
Björn Peemöller committed
176 177

qAlt :: Qual Alt
178
qAlt (Alt p t rhs) = Alt p <$> qPattern t <*> qRhs rhs
Björn Peemöller 's avatar
Björn Peemöller committed
179

180
qField :: Qual a -> Qual (Field a)
181
qField q (Field p l x) = Field p <$> qIdent l <*> q x
182

Björn Peemöller 's avatar
Björn Peemöller committed
183
qInfixOp :: Qual InfixOp
184 185
qInfixOp (InfixOp     op) = InfixOp     <$> qIdent op
qInfixOp (InfixConstr op) = InfixConstr <$> qIdent op
Björn Peemöller 's avatar
Björn Peemöller committed
186 187

qIdent :: Qual QualIdent
Björn Peemöller 's avatar
Björn Peemöller committed
188 189 190 191 192 193 194 195
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
Björn Peemöller 's avatar
Björn Peemöller committed
196 197 198 199
      [y] -> origName y
      _   -> case qualLookupValue qmx tyEnv of
        [y] -> origName y
        _   -> qmx
Björn Peemöller 's avatar
Björn Peemöller committed
200
        where qmx = qualQualify m x
Björn Peemöller 's avatar
Björn Peemöller committed
201 202 203 204 205 206 207 208 209 210 211

qConstr :: Qual QualIdent
qConstr x = do
  m     <- R.asks moduleIdent
  tcEnv <- R.asks tyConsEnv
  return $ case qualLookupTC x tcEnv of
    [y] -> origName y
    _   -> case qualLookupTC qmx tcEnv of
      [y] -> origName y
      _   -> qmx
      where qmx = qualQualify m x