{-# OPTIONS -fno-warn-name-shadowing #-}
module Language.Haskell.Names.ScopeUtils
  ( computeSymbolTable
  , noScope
  , none
  , resolveCNames
  , scopeError
  , sv_parent
  ) where

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

import           Data.Lens.Light
import qualified Data.Set                                 as Set
import           Language.Haskell.Exts

scopeError :: Functor f => Error l -> f l -> f (Scoped l)
scopeError :: Error l -> f l -> f (Scoped l)
scopeError Error l
e f l
f = NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped (Error l -> NameInfo l
forall l. Error l -> NameInfo l
ScopeError Error l
e) (l -> Scoped l) -> f l -> f (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f l
f

none :: l -> Scoped l
none :: l -> Scoped l
none = NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped NameInfo l
forall l. NameInfo l
None

noScope :: (Annotated a) => a l -> a (Scoped l)
noScope :: a l -> a (Scoped l)
noScope = (l -> Scoped l) -> a l -> a (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap l -> Scoped l
forall l. l -> Scoped l
none

sv_parent :: SymValueInfo n -> Maybe n
sv_parent :: SymValueInfo n -> Maybe n
sv_parent (SymSelector { sv_typeName :: forall name. SymValueInfo name -> name
sv_typeName = n
n }) = n -> Maybe n
forall a. a -> Maybe a
Just n
n
sv_parent (SymConstructor { sv_typeName :: forall name. SymValueInfo name -> name
sv_typeName = n
n }) = n -> Maybe n
forall a. a -> Maybe a
Just n
n
sv_parent (SymMethod { sv_className :: forall name. SymValueInfo name -> name
sv_className = n
n }) = n -> Maybe n
forall a. a -> Maybe a
Just n
n
sv_parent SymValueInfo n
_ = Maybe n
forall a. Maybe a
Nothing

computeSymbolTable
  :: Bool
    -- ^ If 'True' (\"qualified\"), then only the qualified names are
    -- inserted.
    --
    -- If 'False', then both qualified and unqualified names are insterted.
  -> ModuleName l
  -> Symbols
  -> Global.Table
computeSymbolTable :: Bool -> ModuleName l -> Symbols -> Table
computeSymbolTable Bool
qual (ModuleName l
_ String
mod) Symbols
syms =
  ([(GName, SymValueInfo OrigName)], [(GName, SymTypeInfo OrigName)])
-> Table
Global.fromLists (([(GName, SymValueInfo OrigName)],
  [(GName, SymTypeInfo OrigName)])
 -> Table)
-> ([(GName, SymValueInfo OrigName)],
    [(GName, SymTypeInfo OrigName)])
-> Table
forall a b. (a -> b) -> a -> b
$
    if Bool
qual
      then ([(GName, SymValueInfo OrigName)], [(GName, SymTypeInfo OrigName)])
renamed
      else ([(GName, SymValueInfo OrigName)], [(GName, SymTypeInfo OrigName)])
renamed ([(GName, SymValueInfo OrigName)], [(GName, SymTypeInfo OrigName)])
-> ([(GName, SymValueInfo OrigName)],
    [(GName, SymTypeInfo OrigName)])
-> ([(GName, SymValueInfo OrigName)],
    [(GName, SymTypeInfo OrigName)])
forall a. Semigroup a => a -> a -> a
<> ([(GName, SymValueInfo OrigName)], [(GName, SymTypeInfo OrigName)])
unqualified
  where
    vs :: [SymValueInfo OrigName]
vs = Set (SymValueInfo OrigName) -> [SymValueInfo OrigName]
forall a. Set a -> [a]
Set.toList (Set (SymValueInfo OrigName) -> [SymValueInfo OrigName])
-> Set (SymValueInfo OrigName) -> [SymValueInfo OrigName]
forall a b. (a -> b) -> a -> b
$ Symbols
symsSymbols
-> Lens Symbols (Set (SymValueInfo OrigName))
-> Set (SymValueInfo OrigName)
forall b c. b -> Lens b c -> c
^.Lens Symbols (Set (SymValueInfo OrigName))
valSyms
    ts :: [SymTypeInfo OrigName]
ts = Set (SymTypeInfo OrigName) -> [SymTypeInfo OrigName]
forall a. Set a -> [a]
Set.toList (Set (SymTypeInfo OrigName) -> [SymTypeInfo OrigName])
-> Set (SymTypeInfo OrigName) -> [SymTypeInfo OrigName]
forall a b. (a -> b) -> a -> b
$ Symbols
symsSymbols
-> Lens Symbols (Set (SymTypeInfo OrigName))
-> Set (SymTypeInfo OrigName)
forall b c. b -> Lens b c -> c
^.Lens Symbols (Set (SymTypeInfo OrigName))
tySyms
    renamed :: ([(GName, SymValueInfo OrigName)], [(GName, SymTypeInfo OrigName)])
renamed = String
-> ([(GName, SymValueInfo OrigName)],
    [(GName, SymTypeInfo OrigName)])
renameSyms String
mod
    unqualified :: ([(GName, SymValueInfo OrigName)], [(GName, SymTypeInfo OrigName)])
unqualified = String
-> ([(GName, SymValueInfo OrigName)],
    [(GName, SymTypeInfo OrigName)])
renameSyms String
""
    renameSyms :: String
-> ([(GName, SymValueInfo OrigName)],
    [(GName, SymTypeInfo OrigName)])
renameSyms String
mod = ((SymValueInfo OrigName -> (GName, SymValueInfo OrigName))
-> [SymValueInfo OrigName] -> [(GName, SymValueInfo OrigName)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SymValueInfo OrigName -> (GName, SymValueInfo OrigName)
forall (i :: * -> *).
HasOrigName i =>
String -> i OrigName -> (GName, i OrigName)
rename String
mod) [SymValueInfo OrigName]
vs, (SymTypeInfo OrigName -> (GName, SymTypeInfo OrigName))
-> [SymTypeInfo OrigName] -> [(GName, SymTypeInfo OrigName)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SymTypeInfo OrigName -> (GName, SymTypeInfo OrigName)
forall (i :: * -> *).
HasOrigName i =>
String -> i OrigName -> (GName, i OrigName)
rename String
mod) [SymTypeInfo OrigName]
ts)
    rename :: HasOrigName i => ModuleNameS -> i OrigName -> (GName, i OrigName)
    rename :: String -> i OrigName -> (GName, i OrigName)
rename String
m i OrigName
v = ((OrigName -> GName
origGName (OrigName -> GName)
-> (i OrigName -> OrigName) -> i OrigName -> GName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i OrigName -> OrigName
forall (i :: * -> *) n. HasOrigName i => i n -> n
origName (i OrigName -> GName) -> i OrigName -> GName
forall a b. (a -> b) -> a -> b
$ i OrigName
v) { gModule :: String
gModule = String
m }, i OrigName
v)

resolveCName
  :: Symbols
  -> OrigName
  -> (CName l -> Error l) -- ^ error for "not found" condition
  -> CName l
  -> (CName (Scoped l), Symbols)
resolveCName :: Symbols
-> OrigName
-> (CName l -> Error l)
-> CName l
-> (CName (Scoped l), Symbols)
resolveCName Symbols
syms OrigName
parent CName l -> Error l
notFound CName l
cn =
  let
    vs :: [SymValueInfo OrigName]
vs =
      [ SymValueInfo OrigName
info
      | SymValueInfo OrigName
info <- Set (SymValueInfo OrigName) -> [SymValueInfo OrigName]
forall a. Set a -> [a]
Set.toList (Set (SymValueInfo OrigName) -> [SymValueInfo OrigName])
-> Set (SymValueInfo OrigName) -> [SymValueInfo OrigName]
forall a b. (a -> b) -> a -> b
$ Symbols
symsSymbols
-> Lens Symbols (Set (SymValueInfo OrigName))
-> Set (SymValueInfo OrigName)
forall b c. b -> Lens b c -> c
^.Lens Symbols (Set (SymValueInfo OrigName))
valSyms
      , let name :: String
name = GName -> String
gName (GName -> String) -> (OrigName -> GName) -> OrigName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrigName -> GName
origGName (OrigName -> String) -> OrigName -> String
forall a b. (a -> b) -> a -> b
$ SymValueInfo OrigName -> OrigName
forall name. SymValueInfo name -> name
sv_origName SymValueInfo OrigName
info
      , Name l -> String
forall l. Name l -> String
nameToString (CName l -> Name l
forall l. CName l -> Name l
unCName CName l
cn) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name
      , Just OrigName
p <- Maybe OrigName -> [Maybe OrigName]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OrigName -> [Maybe OrigName])
-> Maybe OrigName -> [Maybe OrigName]
forall a b. (a -> b) -> a -> b
$ SymValueInfo OrigName -> Maybe OrigName
forall n. SymValueInfo n -> Maybe n
sv_parent SymValueInfo OrigName
info
      , OrigName
p OrigName -> OrigName -> Bool
forall a. Eq a => a -> a -> Bool
== OrigName
parent
      ]
  in
    case [SymValueInfo OrigName]
vs of
      [] -> (Error l -> CName l -> CName (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (CName l -> Error l
notFound CName l
cn) CName l
cn, Symbols
forall a. Monoid a => a
mempty)
      [SymValueInfo OrigName
i] -> (NameInfo l -> l -> Scoped l
forall l. NameInfo l -> l -> Scoped l
Scoped (SymValueInfo OrigName -> NameInfo l
forall l. SymValueInfo OrigName -> NameInfo l
GlobalValue SymValueInfo OrigName
i) (l -> Scoped l) -> CName l -> CName (Scoped l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CName l
cn, SymValueInfo OrigName -> Symbols
mkVal SymValueInfo OrigName
i)
      [SymValueInfo OrigName]
_ -> (Error l -> CName l -> CName (Scoped l)
forall (f :: * -> *) l. Functor f => Error l -> f l -> f (Scoped l)
scopeError (String -> Error l
forall l. String -> Error l
EInternal String
"resolveCName") CName l
cn, Symbols
forall a. Monoid a => a
mempty)

resolveCNames
  :: Symbols
  -> OrigName
  -> (CName l -> Error l) -- ^ error for "not found" condition
  -> [CName l]
  -> ([CName (Scoped l)], Symbols)
resolveCNames :: Symbols
-> OrigName
-> (CName l -> Error l)
-> [CName l]
-> ([CName (Scoped l)], Symbols)
resolveCNames Symbols
syms OrigName
orig CName l -> Error l
notFound =
  ([Symbols] -> Symbols)
-> ([CName (Scoped l)], [Symbols]) -> ([CName (Scoped l)], Symbols)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [Symbols] -> Symbols
forall a. Monoid a => [a] -> a
mconcat (([CName (Scoped l)], [Symbols]) -> ([CName (Scoped l)], Symbols))
-> ([CName l] -> ([CName (Scoped l)], [Symbols]))
-> [CName l]
-> ([CName (Scoped l)], Symbols)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CName (Scoped l), Symbols)] -> ([CName (Scoped l)], [Symbols])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(CName (Scoped l), Symbols)] -> ([CName (Scoped l)], [Symbols]))
-> ([CName l] -> [(CName (Scoped l), Symbols)])
-> [CName l]
-> ([CName (Scoped l)], [Symbols])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CName l -> (CName (Scoped l), Symbols))
-> [CName l] -> [(CName (Scoped l), Symbols)]
forall a b. (a -> b) -> [a] -> [b]
map (Symbols
-> OrigName
-> (CName l -> Error l)
-> CName l
-> (CName (Scoped l), Symbols)
forall l.
Symbols
-> OrigName
-> (CName l -> Error l)
-> CName l
-> (CName (Scoped l), Symbols)
resolveCName Symbols
syms OrigName
orig CName l -> Error l
notFound)