{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE NamedFieldPuns         #-}
{-# LANGUAGE NoImplicitPrelude      #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE UndecidableInstances   #-}
module Language.Haskell.Names.GetBound
  ( GetBound(..)
  ) where

import           Fay.Compiler.Prelude
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
import           Language.Haskell.Names.RecordWildcards
import           Language.Haskell.Names.SyntaxUtils

import           Data.Generics.Uniplate.Data
import           Language.Haskell.Exts


-- | Get bound value identifiers.
class GetBound a l | a -> l where
    -- | For record wildcards we need to know which fields the given
    -- constructor has. So we pass the global table for that.
    getBound :: Global.Table -> a -> [Name l]

-- XXX account for shadowing?
instance (GetBound a l) => GetBound [a] l where
    getBound :: Table -> [a] -> [Name l]
getBound Table
ctx [a]
xs = (a -> [Name l]) -> [a] -> [Name l]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Table -> a -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx) [a]
xs

instance (GetBound a l) => GetBound (Maybe a) l where
    getBound :: Table -> Maybe a -> [Name l]
getBound Table
ctx = [Name l] -> (a -> [Name l]) -> Maybe a -> [Name l]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Table -> a -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx)

instance (GetBound a l, GetBound b l) => GetBound (a, b) l where
    getBound :: Table -> (a, b) -> [Name l]
getBound Table
ctx (a
a, b
b) = Table -> a -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx a
a [Name l] -> [Name l] -> [Name l]
forall a. [a] -> [a] -> [a]
++ Table -> b -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx b
b

instance (Data l) => GetBound (Binds l) l where
    getBound :: Table -> Binds l -> [Name l]
getBound Table
ctx Binds l
e = case Binds l
e of
      BDecls l
_ [Decl l]
ds -> Table -> [Decl l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx [Decl l]
ds
      IPBinds l
_ [IPBind l]
_ -> []  -- XXX doesn't bind regular identifiers

instance (Data l) => GetBound (Decl l) l where
    getBound :: Table -> Decl l -> [Name l]
getBound Table
ctx Decl l
e = case Decl l
e of
      TypeDecl{} -> []
      TypeFamDecl{} -> []
      DataDecl l
_ DataOrNew l
_ Maybe (Context l)
_ DeclHead l
_ [QualConDecl l]
ds [Deriving l]
_ -> Table -> [QualConDecl l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx [QualConDecl l]
ds
      GDataDecl l
_ DataOrNew l
_ Maybe (Context l)
_ DeclHead l
_ Maybe (Kind l)
_ [GadtDecl l]
ds [Deriving l]
_ -> Table -> [GadtDecl l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx [GadtDecl l]
ds
      DataFamDecl{} -> []
      TypeInsDecl{} -> []
      DataInsDecl l
_ DataOrNew l
_ Kind l
_ [QualConDecl l]
ds [Deriving l]
_ -> Table -> [QualConDecl l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx [QualConDecl l]
ds
      GDataInsDecl l
_ DataOrNew l
_ Kind l
_ Maybe (Kind l)
_ [GadtDecl l]
ds [Deriving l]
_ -> Table -> [GadtDecl l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx [GadtDecl l]
ds
      ClassDecl l
_ Maybe (Context l)
_ DeclHead l
_ [FunDep l]
_ Maybe [ClassDecl l]
mds -> Table -> Maybe [ClassDecl l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx Maybe [ClassDecl l]
mds
      InstDecl{} -> []
      DerivDecl{} -> []
      InfixDecl{} -> []
      DefaultDecl{} -> []
      SpliceDecl{} -> []
      TypeSig{} -> []
      FunBind l
_ [] -> [Char] -> [Name l]
forall a. HasCallStack => [Char] -> a
error [Char]
"getBound: FunBind []"
      FunBind l
_ (Match l
_ Name l
n [Pat l]
_ Rhs l
_ Maybe (Binds l)
_ : [Match l]
_) -> [Name l
n]
      FunBind l
_ (InfixMatch l
_ Pat l
_ Name l
n [Pat l]
_ Rhs l
_ Maybe (Binds l)
_ : [Match l]
_) -> [Name l
n]
      PatBind l
_ Pat l
p Rhs l
_ Maybe (Binds l)
_ -> Table -> Pat l -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx Pat l
p
      ForImp l
_ CallConv l
_ Maybe (Safety l)
_ Maybe [Char]
_ Name l
n Kind l
_ -> [Name l
n]
      ForExp l
_ CallConv l
_ Maybe [Char]
_ Name l
n Kind l
_ -> [Name l
n]
      RulePragmaDecl{} -> []
      DeprPragmaDecl{} -> []
      WarnPragmaDecl{} -> []
      InlineSig{} -> []
      SpecSig{} -> []
      SpecInlineSig{} -> []
      InstSig{} -> []
      AnnPragma{} -> []
      InlineConlikeSig{} -> []
      ClosedTypeFamDecl{} -> []
      MinimalPragma{} -> []
      Decl l
_ -> [Char] -> [Name l]
forall a. HasCallStack => [Char] -> a
error [Char]
"Unsupported syntax"

instance (Data l) => GetBound (QualConDecl l) l where
    getBound :: Table -> QualConDecl l -> [Name l]
getBound Table
ctx (QualConDecl l
_ Maybe [TyVarBind l]
_ Maybe (Context l)
_ ConDecl l
d) = Table -> ConDecl l -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx ConDecl l
d

instance (Data l) => GetBound (GadtDecl l) l where
    getBound :: Table -> GadtDecl l -> [Name l]
getBound Table
_ctx (GadtDecl l
_l Name l
conName Maybe [TyVarBind l]
_tyvarBinds Maybe (Context l)
_context Maybe [FieldDecl l]
mbFieldDecls Type l
_ty) =
      -- GADT constructor name
      [Name l
conName] [Name l] -> [Name l] -> [Name l]
forall a. [a] -> [a] -> [a]
++
      -- GADT selector names
      [ Name l
fieldName
      | Just [FieldDecl l]
fieldDecls <- Maybe [FieldDecl l] -> [Maybe [FieldDecl l]]
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [FieldDecl l]
mbFieldDecls
      , FieldDecl l
_l' [Name l]
fieldNames Type l
_fieldTy <- [FieldDecl l]
fieldDecls
      , Name l
fieldName <- [Name l]
fieldNames
      ]

instance (Data l) => GetBound (ConDecl l) l where
    getBound :: Table -> ConDecl l -> [Name l]
getBound Table
ctx ConDecl l
e = case ConDecl l
e of
      ConDecl l
_ Name l
n [Type l]
_ -> [Name l
n]
      InfixConDecl l
_ Type l
_ Name l
n Type l
_ -> [Name l
n]
      RecDecl l
_ Name l
n [FieldDecl l]
fs -> Name l
n Name l -> [Name l] -> [Name l]
forall a. a -> [a] -> [a]
: Table -> [FieldDecl l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx [FieldDecl l]
fs

instance (Data l) => GetBound (FieldDecl l) l where
    getBound :: Table -> FieldDecl l -> [Name l]
getBound Table
_ctx (FieldDecl l
_ [Name l]
ns Type l
_) = [Name l]
ns

instance (Data l) => GetBound (ClassDecl l) l where
    getBound :: Table -> ClassDecl l -> [Name l]
getBound Table
_ctx ClassDecl l
e = case ClassDecl l
e of
      ClsDecl l
_ Decl l
d -> Decl l -> [Name l]
forall l. Decl l -> [Name l]
getBoundSign Decl l
d
      ClsDataFam{} -> []
      ClsTyFam{} -> []
      ClsTyDef{} -> []
      ClsDefSig{} -> []

instance (Data l) => GetBound (Match l) l where
    getBound :: Table -> Match l -> [Name l]
getBound Table
_ctx Match l
e = case Match l
e of
      Match l
_ Name l
n [Pat l]
_ Rhs l
_ Maybe (Binds l)
_ -> [Name l
n]
      InfixMatch l
_ Pat l
_ Name l
n [Pat l]
_ Rhs l
_ Maybe (Binds l)
_ -> [Name l
n]

instance (Data l) => GetBound (Stmt l) l where
  getBound :: Table -> Stmt l -> [Name l]
getBound Table
ctx Stmt l
e =
    case Stmt l
e of
      Generator l
_ Pat l
pat Exp l
_ -> Table -> Pat l -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx Pat l
pat
      LetStmt l
_ Binds l
bnds    -> Table -> Binds l -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx Binds l
bnds
      RecStmt l
_ [Stmt l]
stmts   -> Table -> [Stmt l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx [Stmt l]
stmts
      Qualifier {} -> []

instance (Data l) => GetBound (QualStmt l) l where
  getBound :: Table -> QualStmt l -> [Name l]
getBound Table
ctx QualStmt l
e =
    case QualStmt l
e of
      QualStmt l
_ Stmt l
stmt -> Table -> Stmt l -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx Stmt l
stmt
      QualStmt l
_ -> []

instance (Data l) => GetBound (Pat l) l where
  getBound :: Table -> Pat l -> [Name l]
getBound Table
gt Pat l
p =
    [ Name l
n | Pat l
p' <- Pat l -> [Pat l]
forall on. Uniplate on => on -> [on]
universe (Pat l -> [Pat l]) -> Pat l -> [Pat l]
forall a b. (a -> b) -> a -> b
$ (Pat l -> Pat l) -> Pat l -> Pat l
forall on. Uniplate on => (on -> on) -> on -> on
transform Pat l -> Pat l
forall l. Pat l -> Pat l
dropExp Pat l
p, Name l
n <- Pat l -> [Name l]
varp Pat l
p' ]

    where

      varp :: Pat l -> [Name l]
varp (PVar l
_ Name l
n) = [Name l
n]
      varp (PAsPat l
_ Name l
n Pat l
_) = [Name l
n]
      varp (PNPlusK l
_ Name l
n Integer
_) = [Name l
n]
      varp (PRec l
_ QName l
con [PatField l]
fs) =
        [ Name l
n
        | -- (lazily) compute elided fields for the case when 'f' below is a wildcard
          let elidedFields :: [Name ()]
elidedFields = (WcField -> Name ()) -> [WcField] -> [Name ()]
forall a b. (a -> b) -> [a] -> [b]
map WcField -> Name ()
wcFieldName ([WcField] -> [Name ()]) -> [WcField] -> [Name ()]
forall a b. (a -> b) -> a -> b
$ Table -> QName l -> [PatField l] -> [WcField]
forall l. Table -> QName l -> [PatField l] -> [WcField]
patWcNames Table
gt QName l
con [PatField l]
fs
        , PatField l
f <- [PatField l]
fs
        , Name l
n <- [Name ()] -> PatField l -> [Name l]
getRecVars [Name ()]
elidedFields PatField l
f
        ]
      varp Pat l
_ = []

      -- must remove nested Exp so universe doesn't descend into them
      dropExp :: Pat l -> Pat l
dropExp (PViewPat l
_ Exp l
_ Pat l
x) = Pat l
x
      dropExp Pat l
x = Pat l
x

      getRecVars :: [Name ()] -> PatField l -> [Name l]
      getRecVars :: [Name ()] -> PatField l -> [Name l]
getRecVars [Name ()]
_ PFieldPat {} = [] -- this is already found by the generic algorithm
      getRecVars [Name ()]
_ (PFieldPun l
_ QName l
qn) = [QName l -> Name l
forall l. QName l -> Name l
qNameToName QName l
qn]
      getRecVars [Name ()]
elidedFields (PFieldWildcard l
l) = (Name () -> Name l) -> [Name ()] -> [Name l]
forall a b. (a -> b) -> [a] -> [b]
map (l
l l -> Name () -> Name l
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) [Name ()]
elidedFields

getBoundSign :: Decl l -> [Name l]
getBoundSign :: Decl l -> [Name l]
getBoundSign (TypeSig l
_ [Name l]
ns Type l
_) = [Name l]
ns
getBoundSign Decl l
_ = []