{-# LANGUAGE OverloadedStrings #-}
module Apigen.Parser.SymbolTable where

import           Apigen.Types               (Decl)
import           Control.Arrow              (Arrow (first))
import           Control.Monad.State.Strict (State)
import qualified Control.Monad.State.Strict as State
import           Data.Bifunctor             (Bifunctor (bimap))
import           Data.HashMap.Strict        (HashMap)
import qualified Data.HashMap.Strict        as HashMap
import qualified Data.List                  as List
import qualified Data.Maybe                 as Maybe
import           Data.Text                  (Text)
import qualified Data.Text                  as Text
import           Data.Tuple.Extra           (both)
import           Language.Cimple            (Lexeme)

type Name = ([Text], [Text])
type SId = Int
type Sym = Decl (Lexeme SId)
type NameToSId = HashMap Name SId
type SIdToName = HashMap SId Name

type M s a = State (SIdToName, s) a

displayWithin :: [Text] -> Name -> String
displayWithin :: [Text] -> Name -> String
displayWithin [Text]
curNs = (String, String) -> String
addNamespace ((String, String) -> String)
-> (Name -> (String, String)) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String) -> (Text, Text) -> (String, String)
forall a b. (a -> b) -> (a, a) -> (b, b)
both Text -> String
Text.unpack ((Text, Text) -> (String, String))
-> (Name -> (Text, Text)) -> Name -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Text) -> ([Text] -> Text) -> Name -> (Text, Text)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Text -> [Text] -> Text
Text.intercalate Text
"_" ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
stripCurrent) (Text -> [Text] -> Text
Text.intercalate Text
"_")
  where
    addNamespace :: (String, String) -> String
addNamespace ([], []  ) = String
"this"
    addNamespace ([], String
name) = String
name
    addNamespace (String
ns, []  ) = String
ns String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"::this"
    addNamespace (String
ns, String
name) = String
ns String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"::" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name

    stripCurrent :: [Text] -> [Text]
stripCurrent [Text]
ns = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
Maybe.fromMaybe [Text]
ns ([Text] -> [Text] -> Maybe [Text]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [Text]
curNs [Text]
ns)

display :: Name -> String
display :: Name -> String
display = [Text] -> Name -> String
displayWithin []

mustLookup :: SIdToName -> SId -> Name
mustLookup :: SIdToName -> SId -> Name
mustLookup SIdToName
syms SId
sym =
    case SId -> SIdToName -> Maybe Name
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup SId
sym SIdToName
syms of
        Maybe Name
Nothing   -> String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"symbol lookup failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SId -> String
forall a. Show a => a -> String
show SId
sym
        Just Name
name -> Name
name

mustLookupM :: SId -> M s Name
mustLookupM :: SId -> M s Name
mustLookupM = ((SIdToName -> Name)
-> StateT (SIdToName, s) Identity SIdToName -> M s Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((SIdToName, s) -> SIdToName
forall a b. (a, b) -> a
fst ((SIdToName, s) -> SIdToName)
-> StateT (SIdToName, s) Identity (SIdToName, s)
-> StateT (SIdToName, s) Identity SIdToName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (SIdToName, s) Identity (SIdToName, s)
forall s (m :: * -> *). MonadState s m => m s
State.get)) ((SIdToName -> Name) -> M s Name)
-> (SId -> SIdToName -> Name) -> SId -> M s Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SIdToName -> SId -> Name) -> SId -> SIdToName -> Name
forall a b c. (a -> b -> c) -> b -> a -> c
flip SIdToName -> SId -> Name
mustLookup

resolve :: Traversable t => SIdToName -> t (Lexeme SId) -> t (Lexeme Name)
resolve :: SIdToName -> t (Lexeme SId) -> t (Lexeme Name)
resolve SIdToName
st = ((Lexeme SId -> Lexeme Name) -> t (Lexeme SId) -> t (Lexeme Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Lexeme SId -> Lexeme Name) -> t (Lexeme SId) -> t (Lexeme Name))
-> ((SId -> Name) -> Lexeme SId -> Lexeme Name)
-> (SId -> Name)
-> t (Lexeme SId)
-> t (Lexeme Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SId -> Name) -> Lexeme SId -> Lexeme Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ((SId -> Name) -> t (Lexeme SId) -> t (Lexeme Name))
-> (SId -> Name) -> t (Lexeme SId) -> t (Lexeme Name)
forall a b. (a -> b) -> a -> b
$ SIdToName -> SId -> Name
mustLookup SIdToName
st

resolveM :: Traversable t => t (Lexeme SId) -> State (SIdToName, s) (t (Lexeme Name))
resolveM :: t (Lexeme SId) -> State (SIdToName, s) (t (Lexeme Name))
resolveM = ((SIdToName -> t (Lexeme Name))
-> StateT (SIdToName, s) Identity SIdToName
-> State (SIdToName, s) (t (Lexeme Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((SIdToName, s) -> SIdToName
forall a b. (a, b) -> a
fst ((SIdToName, s) -> SIdToName)
-> StateT (SIdToName, s) Identity (SIdToName, s)
-> StateT (SIdToName, s) Identity SIdToName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (SIdToName, s) Identity (SIdToName, s)
forall s (m :: * -> *). MonadState s m => m s
State.get)) ((SIdToName -> t (Lexeme Name))
 -> State (SIdToName, s) (t (Lexeme Name)))
-> (t (Lexeme SId) -> SIdToName -> t (Lexeme Name))
-> t (Lexeme SId)
-> State (SIdToName, s) (t (Lexeme Name))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SIdToName -> t (Lexeme SId) -> t (Lexeme Name))
-> t (Lexeme SId) -> SIdToName -> t (Lexeme Name)
forall a b c. (a -> b -> c) -> b -> a -> c
flip SIdToName -> t (Lexeme SId) -> t (Lexeme Name)
forall (t :: * -> *).
Traversable t =>
SIdToName -> t (Lexeme SId) -> t (Lexeme Name)
resolve

renameM :: (Name -> Name) -> SId -> M s ()
renameM :: (Name -> Name) -> SId -> M s ()
renameM Name -> Name
f SId
nm = do
    Name
bs <- SId -> M s Name
forall s. SId -> M s Name
mustLookupM SId
nm
    ((SIdToName, s) -> (SIdToName, s)) -> M s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (((SIdToName, s) -> (SIdToName, s)) -> M s ())
-> ((SIdToName, s) -> (SIdToName, s)) -> M s ()
forall a b. (a -> b) -> a -> b
$ (SIdToName -> SIdToName) -> (SIdToName, s) -> (SIdToName, s)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((SIdToName -> SIdToName) -> (SIdToName, s) -> (SIdToName, s))
-> (SIdToName -> SIdToName) -> (SIdToName, s) -> (SIdToName, s)
forall a b. (a -> b) -> a -> b
$ SId -> Name -> SIdToName -> SIdToName
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert SId
nm (Name -> Name
f Name
bs)

insert :: Name -> M s SId
insert :: Name -> M s SId
insert Name
name = do
    SIdToName
st <- (SIdToName, s) -> SIdToName
forall a b. (a, b) -> a
fst ((SIdToName, s) -> SIdToName)
-> StateT (SIdToName, s) Identity (SIdToName, s)
-> StateT (SIdToName, s) Identity SIdToName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (SIdToName, s) Identity (SIdToName, s)
forall s (m :: * -> *). MonadState s m => m s
State.get
    let num :: SId
num = SIdToName -> SId
forall k v. HashMap k v -> SId
HashMap.size SIdToName
st
    ((SIdToName, s) -> (SIdToName, s))
-> StateT (SIdToName, s) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (((SIdToName, s) -> (SIdToName, s))
 -> StateT (SIdToName, s) Identity ())
-> ((SIdToName, s) -> (SIdToName, s))
-> StateT (SIdToName, s) Identity ()
forall a b. (a -> b) -> a -> b
$ (SIdToName -> SIdToName) -> (SIdToName, s) -> (SIdToName, s)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((SIdToName -> SIdToName) -> (SIdToName, s) -> (SIdToName, s))
-> (SIdToName -> SIdToName) -> (SIdToName, s) -> (SIdToName, s)
forall a b. (a -> b) -> a -> b
$ SId -> Name -> SIdToName -> SIdToName
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert SId
num Name
name
    SId -> M s SId
forall (m :: * -> *) a. Monad m => a -> m a
return SId
num