{-# 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 ctx :: Table
ctx xs :: [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 ctx :: 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 ctx :: Table
ctx (a :: a
a, b :: 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 ctx :: Table
ctx e :: Binds l
e = case Binds l
e of
      BDecls _ ds :: [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 _ _ -> []  -- XXX doesn't bind regular identifiers

instance (Data l) => GetBound (Decl l) l where
    getBound :: Table -> Decl l -> [Name l]
getBound ctx :: Table
ctx e :: Decl l
e = case Decl l
e of
      TypeDecl{} -> []
      TypeFamDecl{} -> []
      DataDecl _ _ _ _ ds :: [QualConDecl l]
ds _ -> Table -> [QualConDecl l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx [QualConDecl l]
ds
      GDataDecl _ _ _ _ _ ds :: [GadtDecl l]
ds _ -> Table -> [GadtDecl l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx [GadtDecl l]
ds
      DataFamDecl{} -> []
      TypeInsDecl{} -> []
      DataInsDecl _ _ _ ds :: [QualConDecl l]
ds _ -> Table -> [QualConDecl l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx [QualConDecl l]
ds
      GDataInsDecl _ _ _ _ ds :: [GadtDecl l]
ds _ -> Table -> [GadtDecl l] -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx [GadtDecl l]
ds
      ClassDecl _ _ _ _ mds :: 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 _ [] -> [Char] -> [Name l]
forall a. HasCallStack => [Char] -> a
error "getBound: FunBind []"
      FunBind _ (Match _ n :: Name l
n _ _ _ : _) -> [Name l
n]
      FunBind _ (InfixMatch _ _ n :: Name l
n _ _ _ : _) -> [Name l
n]
      PatBind _ p :: Pat l
p _ _ -> Table -> Pat l -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx Pat l
p
      ForImp _ _ _ _ n :: Name l
n _ -> [Name l
n]
      ForExp _ _ _ n :: Name l
n _ -> [Name l
n]
      RulePragmaDecl{} -> []
      DeprPragmaDecl{} -> []
      WarnPragmaDecl{} -> []
      InlineSig{} -> []
      SpecSig{} -> []
      SpecInlineSig{} -> []
      InstSig{} -> []
      AnnPragma{} -> []
      InlineConlikeSig{} -> []
      ClosedTypeFamDecl{} -> []
      MinimalPragma{} -> []
      _ -> [Char] -> [Name l]
forall a. HasCallStack => [Char] -> a
error "Unsupported syntax"

instance (Data l) => GetBound (QualConDecl l) l where
    getBound :: Table -> QualConDecl l -> [Name l]
getBound ctx :: Table
ctx (QualConDecl _ _ _ d :: 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 _ctx :: Table
_ctx (GadtDecl _l :: l
_l conName :: Name l
conName _tyvarBinds :: Maybe [TyVarBind l]
_tyvarBinds _context :: Maybe (Context l)
_context mbFieldDecls :: Maybe [FieldDecl l]
mbFieldDecls _ty :: 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 fieldDecls :: [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
_l' fieldNames :: [Name l]
fieldNames _fieldTy :: 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 ctx :: Table
ctx e :: ConDecl l
e = case ConDecl l
e of
      ConDecl _ n :: Name l
n _ -> [Name l
n]
      InfixConDecl _ _ n :: Name l
n _ -> [Name l
n]
      RecDecl _ n :: Name l
n fs :: [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 _ctx :: Table
_ctx (FieldDecl _ ns :: [Name l]
ns _) = [Name l]
ns

instance (Data l) => GetBound (ClassDecl l) l where
    getBound :: Table -> ClassDecl l -> [Name l]
getBound _ctx :: Table
_ctx e :: ClassDecl l
e = case ClassDecl l
e of
      ClsDecl _ d :: 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 _ctx :: Table
_ctx e :: Match l
e = case Match l
e of
      Match _ n :: Name l
n _ _ _ -> [Name l
n]
      InfixMatch _ _ n :: Name l
n _ _ _ -> [Name l
n]

instance (Data l) => GetBound (Stmt l) l where
  getBound :: Table -> Stmt l -> [Name l]
getBound ctx :: Table
ctx e :: Stmt l
e =
    case Stmt l
e of
      Generator _ pat :: Pat l
pat _ -> Table -> Pat l -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx Pat l
pat
      LetStmt _ bnds :: 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 _ stmts :: [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 ctx :: Table
ctx e :: QualStmt l
e =
    case QualStmt l
e of
      QualStmt _ stmt :: Stmt l
stmt -> Table -> Stmt l -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound Table
ctx Stmt l
stmt
      _ -> []

instance (Data l) => GetBound (Pat l) l where
  getBound :: Table -> Pat l -> [Name l]
getBound gt :: Table
gt p :: 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 _ n :: Name l
n) = [Name l
n]
      varp (PAsPat _ n :: Name l
n _) = [Name l
n]
      varp (PNPlusK _ n :: Name l
n _) = [Name l
n]
      varp (PRec _ con :: QName l
con fs :: [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 _ = []

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

      getRecVars :: [Name ()] -> PatField l -> [Name l]
      getRecVars :: [Name ()] -> PatField l -> [Name l]
getRecVars _ PFieldPat {} = [] -- this is already found by the generic algorithm
      getRecVars _ (PFieldPun _ qn :: QName l
qn) = [QName l -> Name l
forall l. QName l -> Name l
qNameToName QName l
qn]
      getRecVars elidedFields :: [Name ()]
elidedFields (PFieldWildcard l :: 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 _ ns :: [Name l]
ns _) = [Name l]
ns
getBoundSign _ = []