{- |
    Module      :  $Header$
    Description :  Extraction of free and bound variables
    Copyright   :  (c)             Wolfgang Lux
                       2011 - 2015 Björn Peemöller
                       2015        Jan Tikovsky
                       2016        Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    The compiler needs to compute the lists of free and bound variables for
    various different entities. We will devote three type classes to that
    purpose. The 'QualExpr' class is expected to take into account
    that it is possible to use a qualified name to refer to a function
    defined in the current module and therefore @M.x@ and @x@, where
    @M@ is the current module name, should be considered the same name.
    However, note that this is correct only after renaming all local
    definitions as @M.x@ always denotes an entity defined at the
    top-level.
-}
module Base.Expr (Expr (..), QualExpr (..), QuantExpr (..)) where

import           Data.List        (nub)
import qualified Data.Set  as Set (fromList, notMember)

import Curry.Base.Ident
import Curry.Syntax

class Expr e where
  -- |Free variables in an 'Expr'
  fv :: e -> [Ident]

class QualExpr e where
  -- |Free qualified variables in an 'Expr'
  qfv :: ModuleIdent -> e -> [Ident]

class QuantExpr e where
  -- |Bounded variables in an 'Expr'
  bv :: e -> [Ident]

instance Expr e => Expr [e] where
  fv = concatMap fv

instance QualExpr e => QualExpr [e] where
  qfv m = concatMap (qfv m)

instance QuantExpr e => QuantExpr [e] where
  bv = concatMap bv

-- The 'Decl' instance of 'QualExpr' returns all free
-- variables on the right hand side, regardless of whether they are bound
-- on the left hand side. This is more convenient as declarations are
-- usually processed in a declaration group where the set of free
-- variables cannot be computed independently for each declaration.

instance QualExpr (Decl a) where
  qfv m (FunctionDecl  _ _ _ eqs) = qfv m eqs
  qfv m (PatternDecl     _ _ rhs) = qfv m rhs
  qfv m (ClassDecl    _ _ _ _ ds) = qfv m ds
  qfv m (InstanceDecl _ _ _ _ ds) = qfv m ds
  qfv _ _                         = []

instance QuantExpr (Decl a) where
  bv (TypeSig          _ vs _) = vs
  bv (FunctionDecl    _ _ f _) = [f]
  bv (ExternalDecl       _ vs) = bv vs
  bv (PatternDecl       _ t _) = bv t
  bv (FreeDecl           _ vs) = bv vs
  bv (ClassDecl    _ _ _ _ ds) = concatMap methods ds
  bv _                         = []

instance QualExpr (Equation a) where
  qfv m (Equation _ lhs rhs) = filterBv lhs $ qfv m lhs ++ qfv m rhs

instance QuantExpr (Lhs a) where
  bv = bv . snd . flatLhs

instance QualExpr (Lhs a) where
  qfv m lhs = qfv m $ snd $ flatLhs lhs

instance QualExpr (Rhs a) where
  qfv m (SimpleRhs _ e ds) = filterBv ds $ qfv m e  ++ qfv m ds
  qfv m (GuardedRhs es ds) = filterBv ds $ qfv m es ++ qfv m ds

instance QualExpr (CondExpr a) where
  qfv m (CondExpr _ g e) = qfv m g ++ qfv m e

instance QualExpr (Expression a) where
  qfv _ (Literal             _ _) = []
  qfv m (Variable            _ v) = maybe [] return $ localIdent m v
  qfv _ (Constructor         _ _) = []
  qfv m (Paren                 e) = qfv m e
  qfv m (Typed               e _) = qfv m e
  qfv m (Record           _ _ fs) = qfv m fs
  qfv m (RecordUpdate       e fs) = qfv m e ++ qfv m fs
  qfv m (Tuple                es) = qfv m es
  qfv m (List               _ es) = qfv m es
  qfv m (ListCompr          e qs) = foldr (qfvStmt m) (qfv m e) qs
  qfv m (EnumFrom              e) = qfv m e
  qfv m (EnumFromThen      e1 e2) = qfv m e1 ++ qfv m e2
  qfv m (EnumFromTo        e1 e2) = qfv m e1 ++ qfv m e2
  qfv m (EnumFromThenTo e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
  qfv m (UnaryMinus            e) = qfv m e
  qfv m (Apply             e1 e2) = qfv m e1 ++ qfv m e2
  qfv m (InfixApply     e1 op e2) = qfv m op ++ qfv m e1 ++ qfv m e2
  qfv m (LeftSection        e op) = qfv m op ++ qfv m e
  qfv m (RightSection       op e) = qfv m op ++ qfv m e
  qfv m (Lambda             ts e) = filterBv ts $ qfv m e
  qfv m (Let                ds e) = filterBv ds $ qfv m ds ++ qfv m e
  qfv m (Do                sts e) = foldr (qfvStmt m) (qfv m e) sts
  qfv m (IfThenElse     e1 e2 e3) = qfv m e1 ++ qfv m e2 ++ qfv m e3
  qfv m (Case           _ e alts) = qfv m e ++ qfv m alts

qfvStmt :: ModuleIdent -> (Statement a) -> [Ident] -> [Ident]
qfvStmt m st fvs = qfv m st ++ filterBv st fvs

instance QualExpr (Statement a) where
  qfv m (StmtExpr   e) = qfv m e
  qfv m (StmtDecl  ds) = filterBv ds $ qfv m ds
  qfv m (StmtBind _ e) = qfv m e

instance QualExpr (Alt a) where
  qfv m (Alt _ t rhs) = filterBv t $ qfv m rhs

instance QuantExpr (Var a) where
  bv (Var _ v) = [v]

instance QuantExpr a => QuantExpr (Field a) where
  bv (Field _ _ t) = bv t

instance QualExpr a => QualExpr (Field a) where
  qfv m (Field _ _ t) = qfv m t

instance QuantExpr (Statement a) where
  bv (StmtExpr   _) = []
  bv (StmtBind t _) = bv t
  bv (StmtDecl  ds) = bv ds

instance QualExpr (InfixOp a) where
  qfv m (InfixOp     a op) = qfv m $ Variable a op
  qfv _ (InfixConstr _ _ ) = []

instance QuantExpr (Pattern a) where
  bv (LiteralPattern         _ _) = []
  bv (NegativePattern        _ _) = []
  bv (VariablePattern        _ v) = [v]
  bv (ConstructorPattern  _ _ ts) = bv ts
  bv (InfixPattern     _ t1 _ t2) = bv t1 ++ bv t2
  bv (ParenPattern             t) = bv t
  bv (RecordPattern       _ _ fs) = bv fs
  bv (TuplePattern            ts) = bv ts
  bv (ListPattern           _ ts) = bv ts
  bv (AsPattern              v t) = v : bv t
  bv (LazyPattern              t) = bv t
  bv (FunctionPattern     _ _ ts) = nub $ bv ts
  bv (InfixFuncPattern _ t1 _ t2) = nub $ bv t1 ++ bv t2

instance QualExpr (Pattern a) where
  qfv _ (LiteralPattern          _ _) = []
  qfv _ (NegativePattern         _ _) = []
  qfv _ (VariablePattern         _ _) = []
  qfv m (ConstructorPattern   _ _ ts) = qfv m ts
  qfv m (InfixPattern      _ t1 _ t2) = qfv m [t1, t2]
  qfv m (ParenPattern              t) = qfv m t
  qfv m (RecordPattern        _ _ fs) = qfv m fs
  qfv m (TuplePattern             ts) = qfv m ts
  qfv m (ListPattern            _ ts) = qfv m ts
  qfv m (AsPattern              _ ts) = qfv m ts
  qfv m (LazyPattern               t) = qfv m t
  qfv m (FunctionPattern      _ f ts)
    = maybe [] return (localIdent m f) ++ qfv m ts
  qfv m (InfixFuncPattern _ t1 op t2)
    = maybe [] return (localIdent m op) ++ qfv m [t1, t2]

instance Expr Constraint where
  fv (Constraint _ ty) = fv ty

instance QuantExpr Constraint where
  bv _ = []

instance Expr QualTypeExpr where
  fv (QualTypeExpr _ ty) = fv ty

instance QuantExpr QualTypeExpr where
  bv (QualTypeExpr _ ty) = bv ty

instance Expr TypeExpr where
  fv (ConstructorType     _) = []
  fv (ApplyType     ty1 ty2) = fv ty1 ++ fv ty2
  fv (VariableType       tv) = [tv]
  fv (TupleType         tys) = fv tys
  fv (ListType           ty) = fv ty
  fv (ArrowType     ty1 ty2) = fv ty1 ++ fv ty2
  fv (ParenType          ty) = fv ty
  fv (ForallType      vs ty) = filter (`notElem` vs) $ fv ty

instance QuantExpr TypeExpr where
  bv (ConstructorType     _) = []
  bv (ApplyType     ty1 ty2) = bv ty1 ++ bv ty2
  bv (VariableType        _) = []
  bv (TupleType         tys) = bv tys
  bv (ListType           ty) = bv ty
  bv (ArrowType     ty1 ty2) = bv ty1 ++ bv ty2
  bv (ParenType          ty) = bv ty
  bv (ForallType     tvs ty) = tvs ++ bv ty

filterBv :: QuantExpr e => e -> [Ident] -> [Ident]
filterBv e = filter (`Set.notMember` Set.fromList (bv e))