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