-- | This module provides a more flexible way to process Haskell code —
-- using an open-recursive traversal.
--
-- You can look at "Language.Haskell.Exts.Annotated" source as an example
-- of how to use this module.
{-# LANGUAGE RankNTypes, FlexibleInstances, FlexibleContexts, UndecidableInstances, DefaultSignatures, TemplateHaskell, ScopedTypeVariables #-}
{-# LANGUAGE ImplicitParams, KindSignatures, TypeApplications #-}
{-# LANGUAGE MonoLocalBinds #-}
module Language.Haskell.Names.Open.Base where

import qualified Language.Haskell.Names.GlobalSymbolTable as Global
import qualified Language.Haskell.Names.LocalSymbolTable as Local
import Language.Haskell.Names.GetBound
import Language.Haskell.Names.RecordWildcards
import Language.Haskell.Exts
import Control.Monad.Identity
import Data.List
import Data.Lens.Light
import Data.Generics.Traversable
import Data.Typeable
import Data.Monoid
import Data.Functor.Constant

-- | Describes how we should treat names in the current context
data NameContext
  = BindingT
  | BindingV
  | ReferenceT
  | ReferenceV
  | ReferenceUV
      -- ^ Reference a method in an instance declaration
      -- Unqualified names also match qualified names in scope
      -- https://www.haskell.org/pipermail/haskell-prime/2008-April/002569.html
  | ReferenceUT
      -- ^ Reference an associated type in an instance declaration
      -- Unqualified names also match qualified names in scope
      -- https://www.haskell.org/pipermail/haskell-prime/2008-April/002569.html
  | ReferenceRS
      -- ^ Reference a record field selector
  | SignatureV
      -- ^ A type signature contains an always unqualified 'Name' that always
      -- refers to a value bound in the same module.
  | Other

-- | Pattern synonyms can work in different modes depending on if we are on the
-- left hand side or right hand side
data PatSynMode
  = PatSynLeftHandSide
      -- ^ Bind QName's too
  | PatSynRightHandSide
      -- ^ Supress bindings, force references instead (even for Name)

-- | Contains information about the node's enclosing scope. Can be
-- accessed through the lenses: 'gTable', 'lTable', 'nameCtx',
-- 'instanceQualification', 'wcNames'.
-- If we enter an instance with a qualified class name we have to
-- remember the qualification to resolve method names.
data Scope = Scope
  { Scope -> ModuleName ()
_moduName :: ModuleName ()
  , Scope -> Table
_gTable :: Global.Table
  , Scope -> Table
_lTable :: Local.Table
  , Scope -> NameContext
_nameCtx :: NameContext
  , Scope -> Maybe (QName ())
_instClassName :: Maybe (QName ())
  , Scope -> WcNames
_wcNames :: WcNames
  , Scope -> Maybe PatSynMode
_patSynMode :: Maybe PatSynMode
  }

makeLens ''Scope

-- | Create an initial scope
initialScope :: ModuleName () -> Global.Table -> Scope
initialScope :: ModuleName () -> Table -> Scope
initialScope ModuleName ()
moduleName Table
tbl = ModuleName ()
-> Table
-> Table
-> NameContext
-> Maybe (QName ())
-> WcNames
-> Maybe PatSynMode
-> Scope
Scope ModuleName ()
moduleName Table
tbl Table
Local.empty NameContext
Other Maybe (QName ())
forall a. Maybe a
Nothing [] Maybe PatSynMode
forall a. Maybe a
Nothing

-- | Merge local tables of two scopes. The other fields of the scopes are
-- assumed to be the same.
mergeLocalScopes :: Scope -> Scope -> Scope
mergeLocalScopes :: Scope -> Scope -> Scope
mergeLocalScopes Scope
sc1 Scope
sc2 =
  Lens Scope Table -> (Table -> Table) -> Scope -> Scope
forall a b. Lens a b -> (b -> b) -> a -> a
modL Lens Scope Table
lTable (Table -> Table -> Table
forall a. Semigroup a => a -> a -> a
<> Scope
sc2 Scope -> Lens Scope Table -> Table
forall b c. b -> Lens b c -> c
^. Lens Scope Table
lTable) Scope
sc1

-- | The algebra for 'rtraverse'. It's newtype-wrapped because an implicit
-- parameter cannot be polymorphic.
newtype Alg w = Alg
  { forall (w :: * -> *).
Alg w -> forall d. Resolvable d => d -> Scope -> w d
runAlg :: forall d . Resolvable d => d -> Scope -> w d }

alg :: (?alg :: Alg w, Resolvable d) => d -> Scope -> w d
alg :: forall (w :: * -> *) d.
(?alg::Alg w, Resolvable d) =>
d -> Scope -> w d
alg = Alg w -> forall d. Resolvable d => d -> Scope -> w d
forall (w :: * -> *).
Alg w -> forall d. Resolvable d => d -> Scope -> w d
runAlg ?alg::Alg w
Alg w
?alg

defaultRtraverse
  :: (GTraversable Resolvable a, Applicative f, ?alg :: Alg f)
  => a -> Scope -> f a
defaultRtraverse :: forall a (f :: * -> *).
(GTraversable Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
defaultRtraverse a
a Scope
sc = forall (c :: * -> Constraint) a (f :: * -> *).
(GTraversable c a, Applicative f) =>
(forall d. c d => d -> f d) -> a -> f a
gtraverse @Resolvable (\d
d -> d -> Scope -> f d
forall (w :: * -> *) d.
(?alg::Alg w, Resolvable d) =>
d -> Scope -> w d
alg d
d Scope
sc) a
a

-- | A type that implements 'Resolvable' provides a way to perform
-- a shallow scope-aware traversal.

-- There is a generic implementation, 'defaultRtraverse', which is based on
-- 'GTraversable'. It can be used when there the scope of all the immediate
-- children is the same as the scope of the current node.
--
-- We use 'Typeable' here rather than a class-based approach.
-- Otherwise, hand-written instances would carry extremely long lists of
-- constraints, saying that the subterms satisfy the user-supplied class.
class Typeable a => Resolvable a where
  rtraverse
    :: (Applicative f, ?alg :: Alg f)
    => a -> Scope -> f a

instance {-# OVERLAPPABLE #-} (Typeable a, GTraversable Resolvable a) => Resolvable a where
  rtraverse :: forall (f :: * -> *).
(Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
rtraverse = a -> Scope -> f a
forall a (f :: * -> *).
(GTraversable Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
defaultRtraverse

-- | Analogous to 'gmap', but for 'Resolvable'
rmap
  :: Resolvable a
  => (forall b. Resolvable b => Scope -> b -> b)
  -> Scope -> a -> a
rmap :: forall a.
Resolvable a =>
(forall b. Resolvable b => Scope -> b -> b) -> Scope -> a -> a
rmap forall b. Resolvable b => Scope -> b -> b
f Scope
sc =
  let ?alg = (forall d. Resolvable d => d -> Scope -> Identity d)
-> Alg Identity
forall (w :: * -> *).
(forall d. Resolvable d => d -> Scope -> w d) -> Alg w
Alg ((forall d. Resolvable d => d -> Scope -> Identity d)
 -> Alg Identity)
-> (forall d. Resolvable d => d -> Scope -> Identity d)
-> Alg Identity
forall a b. (a -> b) -> a -> b
$ \d
a Scope
sc -> d -> Identity d
forall a. a -> Identity a
Identity (Scope -> d -> d
forall b. Resolvable b => Scope -> b -> b
f Scope
sc d
a)
  in Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (a -> Identity a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Scope -> Identity a) -> Scope -> a -> Identity a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Scope -> Identity a
forall a (f :: * -> *).
(Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
forall (f :: * -> *).
(Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
rtraverse Scope
sc

-- | Analogous to 'gmap', but for 'Resolvable'
rfoldMap
  :: (Monoid r, Resolvable a)
  => (forall b. Resolvable b => Scope -> b -> r)
  -> Scope -> a -> r
rfoldMap :: forall r a.
(Monoid r, Resolvable a) =>
(forall b. Resolvable b => Scope -> b -> r) -> Scope -> a -> r
rfoldMap forall b. Resolvable b => Scope -> b -> r
f Scope
sc =
  let ?alg = (forall d. Resolvable d => d -> Scope -> Constant r d)
-> Alg (Constant r)
forall (w :: * -> *).
(forall d. Resolvable d => d -> Scope -> w d) -> Alg w
Alg ((forall d. Resolvable d => d -> Scope -> Constant r d)
 -> Alg (Constant r))
-> (forall d. Resolvable d => d -> Scope -> Constant r d)
-> Alg (Constant r)
forall a b. (a -> b) -> a -> b
$ \d
a Scope
sc -> r -> Constant r d
forall {k} a (b :: k). a -> Constant a b
Constant (Scope -> d -> r
forall b. Resolvable b => Scope -> b -> r
f Scope
sc d
a)
  in Constant r a -> r
forall {k} a (b :: k). Constant a b -> a
getConstant (Constant r a -> r) -> (a -> Constant r a) -> a -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Scope -> Constant r a) -> Scope -> a -> Constant r a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Scope -> Constant r a
forall a (f :: * -> *).
(Resolvable a, Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
forall (f :: * -> *).
(Applicative f, ?alg::Alg f) =>
a -> Scope -> f a
rtraverse Scope
sc

intro :: (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro :: forall l a. (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro a
node Scope
sc =
  Lens Scope Table -> (Table -> Table) -> Scope -> Scope
forall a b. Lens a b -> (b -> b) -> a -> a
modL Lens Scope Table
lTable
    (\Table
tbl -> (Table -> Name l -> Table) -> Table -> [Name l] -> Table
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Name l -> Table -> Table) -> Table -> Name l -> Table
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name l -> Table -> Table
forall l. SrcInfo l => Name l -> Table -> Table
Local.addValue) Table
tbl ([Name l] -> Table) -> [Name l] -> Table
forall a b. (a -> b) -> a -> b
$
      Table -> a -> [Name l]
forall a l. GetBound a l => Table -> a -> [Name l]
getBound (Scope
sc Scope -> Lens Scope Table -> Table
forall b c. b -> Lens b c -> c
^. Lens Scope Table
gTable) a
node)
    Scope
sc

setNameCtx :: NameContext -> Scope -> Scope
setNameCtx :: NameContext -> Scope -> Scope
setNameCtx = Lens Scope NameContext -> NameContext -> Scope -> Scope
forall a b. Lens a b -> b -> a -> a
setL Lens Scope NameContext
nameCtx

setWcNames :: WcNames -> Scope -> Scope
setWcNames :: WcNames -> Scope -> Scope
setWcNames = Lens Scope WcNames -> WcNames -> Scope -> Scope
forall a b. Lens a b -> b -> a -> a
setL Lens Scope WcNames
wcNames

getWcNames :: Scope -> WcNames
getWcNames :: Scope -> WcNames
getWcNames = Lens Scope WcNames -> Scope -> WcNames
forall a b. Lens a b -> a -> b
getL Lens Scope WcNames
wcNames

binderV :: Scope -> Scope
binderV :: Scope -> Scope
binderV = NameContext -> Scope -> Scope
setNameCtx NameContext
BindingV

binderT :: Scope -> Scope
binderT :: Scope -> Scope
binderT = NameContext -> Scope -> Scope
setNameCtx NameContext
BindingT

exprV :: Scope -> Scope
exprV :: Scope -> Scope
exprV = NameContext -> Scope -> Scope
setNameCtx NameContext
ReferenceV

exprT :: Scope -> Scope
exprT :: Scope -> Scope
exprT = NameContext -> Scope -> Scope
setNameCtx NameContext
ReferenceT

signatureV :: Scope -> Scope
signatureV :: Scope -> Scope
signatureV = NameContext -> Scope -> Scope
setNameCtx NameContext
SignatureV

exprUV :: Scope -> Scope
exprUV :: Scope -> Scope
exprUV = NameContext -> Scope -> Scope
setNameCtx NameContext
ReferenceUV

exprUT :: Scope -> Scope
exprUT :: Scope -> Scope
exprUT = NameContext -> Scope -> Scope
setNameCtx NameContext
ReferenceUT

exprRS :: Scope -> Scope
exprRS :: Scope -> Scope
exprRS = NameContext -> Scope -> Scope
setNameCtx NameContext
ReferenceRS

setInstClassName :: Maybe (QName ()) -> Scope -> Scope
setInstClassName :: Maybe (QName ()) -> Scope -> Scope
setInstClassName Maybe (QName ())
m = Lens Scope (Maybe (QName ())) -> Maybe (QName ()) -> Scope -> Scope
forall a b. Lens a b -> b -> a -> a
setL Lens Scope (Maybe (QName ()))
instClassName Maybe (QName ())
m

setPatSynMode :: PatSynMode -> Scope -> Scope
setPatSynMode :: PatSynMode -> Scope -> Scope
setPatSynMode = Lens Scope (Maybe PatSynMode) -> Maybe PatSynMode -> Scope -> Scope
forall a b. Lens a b -> b -> a -> a
setL Lens Scope (Maybe PatSynMode)
patSynMode (Maybe PatSynMode -> Scope -> Scope)
-> (PatSynMode -> Maybe PatSynMode) -> PatSynMode -> Scope -> Scope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatSynMode -> Maybe PatSynMode
forall a. a -> Maybe a
Just