rubyhs/src/Rubyhs/References.hs

{-# LANGUAGE DuplicateRecordFields, OverloadedLists, InstanceSigs #-}
{-# OPTIONS_GHC -Wall #-}
module Rubyhs.References
  ( References(entries)
  , FQN(..)
  , references
  , Env(..)
  , Result(..)
  , Context(..)
  , graph
  , prettyContext
  , Node(..)
  ) where

import Frelude
-- import Data.Language.Ruby hiding (context)
import qualified Data.Language.Ruby as Ruby
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Kind
import Control.Monad.State
import qualified Data.Aeson as Aeson
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Coerce
import Data.Graph (Graph, Vertex, Forest)
import qualified Data.Graph as Graph

span :: G node key -> Forest node
span (g, f, _) = fmap ((\(x, _, _) -> x) . f) <$> Graph.dff g

type G node key = (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)

graph :: Ruby.Begin -> Forest Node
graph b = span $ Graph.graphFromEdges $ go <$> toList ys
  where
  go :: (Node, Set Node) -> (Node, Text, [Text])
  go (x, xs) = (x, prettyContext x, prettyContext <$> toList xs)
  Result ys = references b

newtype Namespace = Namespace [Text]
deriving stock instance Show Namespace
deriving stock instance Eq Namespace
deriving stock instance Ord Namespace
instance IsList Namespace where
  type Item Namespace = Text
  fromList = coerce
  toList = coerce
deriving newtype instance Semigroup Namespace
deriving newtype instance Monoid Namespace
instance ToJSON Namespace where
  toJSON = Aeson.String . showNamespace

showNamespace :: Namespace -> Text
showNamespace = Text.intercalate "::" . coerce

-- Names are in reverse order.
data FQN = FQN
  { namespace :: Namespace
  , name :: Text
  }

data Node = NodeDef FQN | NodeModule Namespace

deriving stock instance Show Node
deriving stock instance Eq Node
deriving stock instance Ord Node

instance ToJSON Node where
  toJSON = \case
    NodeDef q -> Aeson.toJSON q
    NodeModule m -> Aeson.toJSON m

deriving stock instance Show FQN
deriving stock instance Eq FQN
deriving stock instance Ord FQN
instance Pretty Namespace where
  pretty = pretty . showNamespace

instance Aeson.ToJSON FQN where
  toJSON = Aeson.String . prettyFQN
instance Aeson.ToJSONKey FQN where
instance Pretty FQN where
  pretty = pretty . prettyFQN

prettyFQN :: FQN -> Text
prettyFQN FQN{name, namespace} = case namespace of
  [] -> name
  _ -> convertString (showNamespace namespace) <> "." <> name

newtype Context = Context Node

deriving stock instance Eq Context
deriving stock instance Ord Context
deriving newtype instance ToJSON Context
-- HACK: Not really a semigroup as is evident from the implementation.
instance Semigroup Context where
  Context c0 <> Context c1 = case (c0, c1) of
    (NodeModule n0, NodeModule n1)      -> Context $ NodeModule $ n0 <> n1
    (NodeModule n0, NodeDef (FQN n1 f)) -> Context $ NodeDef $ FQN (n0 <> n1) f
    (NodeDef{}, NodeModule{})           -> error "Cannot append module to function context."
    (NodeDef{}, NodeDef{})              -> error "Cannot append function to function context."

class Monad m => MyMonad (m :: Type -> Type) where
  declaration :: Node -> m ()
  application :: Node -> m ()
  getContext :: m Context
  writeContext :: Context -> m ()

data Env = Env
  { declarations :: Set Node
  , applications :: Map Node (Set Node)
  , context      :: Context
  }

newtype Result = Result (Map Node (Set Node))
instance ToJSON Result where
  toJSON (Result a) = Aeson.Object $ fromList $ go <$> toList a
    where
    go :: (Node, Set Node) -> (Text, Aeson.Value)
    go (x, y) = (prettyContext x, Aeson.toJSON y)

prettyContext :: Node -> Text
prettyContext = \case
  NodeDef fun -> prettyFQN fun
  NodeModule ns -> showNamespace ns
  
instance MyMonad (State Env) where
  declaration q = modify go
    where
    go :: Env -> Env
    go env@Env{declarations} = env { declarations = Set.insert q declarations }
  application n = do
    Context c <- getContext
    let
      go env@Env{applications}
        = env { applications = Map.insertWith mappend c (Set.singleton n) applications }
    modify go
  getContext = gets Rubyhs.References.context
  writeContext q = modify go
    where
    go env = env { Rubyhs.References.context = q }

locally :: MyMonad m => m a -> m a
locally act = do
  old <- getContext
  res <- act
  writeContext old
  pure res

class References a where
  entries :: MyMonad m => a -> m ()

references :: Ruby.Begin -> Result
references q = Result $ Map.unionWith mappend applications declarations'
  where
  Env{declarations,applications} = execState (entries @_ @(State Env) q) emptyEnv
  emptyEnv = Env mempty mempty (Context $ NodeModule mempty)
  declarations' = fromList $ (\x -> (x, mempty)) <$> toList declarations

instance References Ruby.Begin where
  entries :: forall m . MyMonad m => Ruby.Begin -> m ()
  entries (Ruby.Begin defs) = traverse_ (locally . entries) defs

instance References Ruby.Statement where
  entries = \case
    Ruby.StmtModule m   -> entries m
    Ruby.StmtDef f      -> entries f
    Ruby.StmtDefs f     -> entries f
    Ruby.StmtSend s     -> entries s
    Ruby.StmtConst c    -> entries c
    Ruby.StmtBlock b    -> entries b
    Ruby.StmtCasgn c    -> entries c
    Ruby.StmtArray a    -> entries a
    Ruby.StmtSym s      -> entries s
    Ruby.StmtStr s      -> entries s
    Ruby.StmtLvasgn a   -> entries a
    Ruby.StmtLvar a     -> entries a
    Ruby.StmtIvar a     -> entries a
    Ruby.StmtSelf s     -> entries s
    Ruby.StmtCbase s    -> entries s
    Ruby.StmtNil n      -> entries n
    Ruby.StmtAnything a -> entries a

instance References Ruby.Block where
  entries Ruby.Block{send,args,begin} = do
    entries send
    entries args
    entries begin
instance References Ruby.Args where
  entries = const $ pure ()
-- TODO: We have to make a "declaration" for the constant here as
-- well!
instance References Ruby.Casgn where
  entries Ruby.Casgn{rhs} = entries rhs
instance References Ruby.Sym where
  entries _ = pure ()
instance References Ruby.Str where
  entries _ = pure ()
instance References Ruby.Lvasgn where
  entries _ = pure ()
instance References Ruby.Lvar where
  entries _ = pure ()
instance References Ruby.Ivar where
  entries _ = pure ()
instance References Ruby.Self where
  entries _ = pure ()
instance References Ruby.Cbase where
  entries _ = pure ()
instance References Ruby.Nil where
  entries _ = pure ()
instance References Ruby.Array where
  entries Ruby.Array{statements} = traverse_ entries statements
instance References Ruby.Anything where
  entries = const $ pure ()

instance References Ruby.Const where
  entries con = application $ NodeModule $ constToNamespace con

updateContext :: MyMonad m => (Context -> Context) -> m ()
updateContext f = getContext >>= \c -> writeContext (f c)

instance References Ruby.Module where
  entries Ruby.Module{name, begin} = do
    updateContext $ (<>) $ Context $ NodeModule $ constToNamespace name
    c <- getContext >>= \case
      Context (NodeModule c) -> pure c
      _ -> error "..."
    declaration $ NodeModule c
    entries begin

atomToNode :: MyMonad m => Ruby.Atom -> m Node
atomToNode (Ruby.Atom name) = do
  namespace <- getContext >>= \case
    Context (NodeModule c) -> pure c
    -- We could allow this and just say that the function defined in
    -- another function sits in the same context as the surrounding
    -- function.
    Context NodeDef{} -> error "Cannot have a function declaration in a function context"
  pure $ NodeDef $ FQN namespace name

instance References Ruby.Def where
  entries Ruby.Def{atom, begin} = do
    node <- atomToNode atom
    declaration node
    locally $ do
      writeContext (Context node)
      entries begin

instance References Ruby.Defs where
  -- TODO: The field `context` is also relevant here!
  entries Ruby.Defs{atom, begin}
    = entries $ Ruby.Def{atom,begin,args=error "hack"}

qual :: Namespace -> Ruby.Atom -> FQN
qual namespace (Ruby.Atom name) = FQN { namespace , name }

instance References Ruby.Send where
  entries Ruby.Send{context, atom, args} = do
    application $ NodeDef $ qual (statementToNamespace context) atom
    traverse_ entries args

statementToNamespace :: Ruby.Statement -> Namespace
statementToNamespace = go mempty
  where
  go acc = \case
    Ruby.StmtConst c    -> acc <> constToNamespace c
    -- The nil-case and cbase-case should produce different results,
    -- surely.  `Namespace` may not be a good representation.
    Ruby.StmtNil{}      -> acc
    Ruby.StmtCbase{}    -> acc
    -- The send-, ivar- and lvar- case cannot be handled because of the way
    -- we've defined `Namespace`.
    Ruby.StmtSend{}     -> acc
    Ruby.StmtIvar{}     -> acc
    Ruby.StmtLvar{}     -> acc
    _              -> error "Can only build namespaces from sequences of `const` statements"

constToNamespace :: Ruby.Const -> Namespace
constToNamespace Ruby.Const{context, atom} = statementToNamespace context <> [k]
  where
  Ruby.Atom k = atom