{- |
    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.Base.SpanInfo
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 NoSpanInfo 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))