-- | This module provides a more flexible way to process Haskell code —
-- using an open-recursive traversal.
--
-- You can look at "Language.Haskell.Exts" source as an example
-- of how to use this module.
{-# OPTIONS -fno-warn-name-shadowing #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE ImplicitParams        #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE MonoLocalBinds        #-}

module Language.Haskell.Names.Open.Base
  ( Resolvable (..)
  , intro
  , mergeLocalScopes
  , alg
  , Scope (..)
  , setWcNames
  , gTable
  , exprV
  , exprT
  , rmap
  , wcNames
  , nameCtx
  , NameContext (..)
  , initialScope
  , binderV
  , Alg (..)
  , binderT
  , defaultRtraverse
  , lTable
  ) where

import           Fay.Compiler.Prelude
import           Language.Haskell.Names.GetBound
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
import qualified Language.Haskell.Names.LocalSymbolTable  as Local
import           Language.Haskell.Names.RecordWildcards

import           Control.Monad.Identity
import           Data.Generics.Traversable
import           Data.Lens.Light
import           GHC.Exts                                 (Constraint)
import           Language.Haskell.Exts

-- | Describes how we should treat names in the current context
data NameContext
  = BindingT
  | BindingV
  | ReferenceT
  | ReferenceV
  | Other

-- | Contains information about the node's enclosing scope. Can be
-- accessed through the lenses: 'gTable', 'lTable', 'nameCtx', 'wcNames'.
data Scope = Scope
  { Scope -> Table
_gTable  :: Global.Table
  , Scope -> Table
_lTable  :: Local.Table
  , Scope -> NameContext
_nameCtx :: NameContext
  , Scope -> WcNames
_wcNames :: WcNames
  }

makeLens ''Scope

-- | Create an initial scope
initialScope :: Global.Table -> Scope
initialScope :: Table -> Scope
initialScope Table
tbl = Table -> Table -> NameContext -> WcNames -> Scope
Scope Table
tbl Table
Local.empty NameContext
Other []

-- | 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
  { 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 :: 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

data ConstraintProxy (p :: * -> Constraint) = ConstraintProxy

defaultRtraverse
  :: (GTraversable Resolvable a, Applicative f, ?alg :: Alg f)
  => a -> Scope -> f a
defaultRtraverse :: a -> Scope -> f a
defaultRtraverse a
a Scope
sc =
  let ?c = ConstraintProxy :: ConstraintProxy Resolvable
  in (forall d. Resolvable d => d -> f d) -> a -> f a
forall (c :: * -> Constraint) a (f :: * -> *).
(GTraversable c a, Applicative f) =>
(forall d. c d => d -> f d) -> a -> f a
gtraverse @Resolvable (\d
a -> d -> Scope -> f d
forall (w :: * -> *) d.
(?alg::Alg w, Resolvable d) =>
d -> Scope -> w d
alg d
a 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 (Typeable a, GTraversable Resolvable a) => Resolvable a where
  rtraverse :: 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 b. Resolvable b => Scope -> b -> b) -> Scope -> a -> a
rmap forall b. Resolvable b => Scope -> b -> b
f Scope
sc =
  let ?alg = Alg $ \a sc -> Identity (f sc 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
rtraverse Scope
sc

intro :: (SrcInfo l, GetBound a l) => a -> Scope -> Scope
intro :: 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 (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

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