References

package.yaml

@@ -27,6 +27,8 @@ dependencies:
   - vector
   - bytestring
   - frelude
+  - containers
+  - mtl
 
 default-extensions:
   - ConstraintKinds

src/Data/Language/Ruby.hs

@@ -27,6 +27,8 @@ aesonOptions = Aeson.defaultOptions
 newtype Block = Block [Definition]
 
 deriving stock instance Show Block
+deriving stock instance Ord Block
+deriving stock instance Eq Block
 deriving stock instance Generic Block
 instance ToJSON Block where
   toEncoding = Aeson.genericToEncoding aesonOptions
@@ -42,6 +44,8 @@ data Definition
   | DefSend Send
 
 deriving stock instance Show Definition
+deriving stock instance Ord Definition
+deriving stock instance Eq Definition
 deriving stock instance Generic Definition
 instance ToJSON Definition where
   toEncoding = Aeson.genericToEncoding opts
@@ -65,6 +69,8 @@ data Send = Send
   }
 
 deriving stock instance Show Send
+deriving stock instance Ord Send
+deriving stock instance Eq Send
 deriving stock instance Generic Send
 instance ToJSON Send where
   toEncoding = Aeson.genericToEncoding aesonOptions
@@ -83,6 +89,8 @@ data Module = Module
   }
 
 deriving stock instance Show Module
+deriving stock instance Ord Module
+deriving stock instance Eq Module
 deriving stock instance Generic Module
 instance ToJSON Module where
   toEncoding = Aeson.genericToEncoding aesonOptions
@@ -107,6 +115,8 @@ data Function = Function
   }
 
 deriving stock instance Show Function
+deriving stock instance Ord Function
+deriving stock instance Eq Function
 deriving stock instance Generic Function
 instance ToJSON Function where
   toEncoding = Aeson.genericToEncoding aesonOptions
@@ -114,6 +124,9 @@ instance ToJSON Function where
 newtype Args = Args Value
 
 deriving stock instance Show Args
+instance Ord Args where
+  compare = error "Unimplemented"
+deriving stock instance Eq Args
 deriving stock instance Generic Args
 instance ToJSON Args where
   toEncoding = Aeson.genericToEncoding aesonOptions
@@ -133,5 +146,8 @@ instance FromJSON Function where
 newtype Name = Name Value
 
 deriving stock instance Show Name
+instance Ord Name where
+  compare = error "Unimplemented"
+deriving stock instance Eq Name
 deriving newtype instance ToJSON Name
 deriving newtype instance FromJSON Name

src/Rubyhs/References.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE DuplicateRecordFields, OverloadedLists, InstanceSigs, RecordWildCards #-}
+{-# OPTIONS_GHC -Wall #-}
+module Rubyhs.References
+  ( References(entries)
+  , Entry(..)
+  , FQN(..)
+  , references
+  ) where
+
+import Frelude
+import Data.List.NonEmpty (NonEmpty)
+import Data.Language.Ruby
+import Data.Map
+import qualified Data.Map as Map
+import Data.Kind
+import Control.Monad.State
+import qualified Data.Aeson as Aeson
+
+data Entry a = Entry
+  { node :: a
+  , fqn :: FQN
+  }
+
+newtype FQN = FQN (NonEmpty Name)
+
+deriving newtype instance Semigroup FQN
+instance Monoid FQN where
+  mempty = FQN $ pure $ Name Aeson.Null
+
+deriving newtype instance Eq FQN
+deriving newtype instance Ord FQN
+
+class Monad m => MyMonad (m :: Type -> Type) where
+  declaration :: FQN -> Name -> m ()
+  application :: FQN -> Name -> m ()
+  getContext :: m FQN
+  writeContext :: FQN -> m ()
+
+data Env = Env
+  { declarations :: Map FQN [Name]
+  , applications :: Map FQN [Name]
+  , context      :: FQN
+  }
+
+instance Semigroup Env where
+  Env a0 a1 a2 <> Env b0 b1 b2 = Env (a0 <> b0) (a1 <> b1) (a2 <> b2)
+
+instance Monoid Env where
+  mempty = Env mempty mempty mempty
+  
+instance MyMonad (State Env) where
+  declaration q n = modify go
+    where
+    go env@Env{declarations} = env { declarations = Map.insertWith mappend q (pure n) declarations }
+  application q n = modify go
+    where
+    go env@Env{applications} = env { applications = Map.insertWith mappend q (pure n) applications }
+  getContext = gets context
+  writeContext q = modify go
+    where
+    go env = env { context = q }
+
+updateContext :: MyMonad m => (FQN -> FQN) -> m ()
+updateContext f = getContext >>= \c -> writeContext (f c)
+
+locally :: MyMonad m => m a -> m a
+locally act = do
+  old <- getContext
+  res <- act
+  writeContext old
+  pure res
+
+appendToContext :: MyMonad m => Name -> m ()
+appendToContext n = updateContext go
+  where
+  go (FQN ns) = FQN $ pure n <> ns
+
+class References a where
+  entries :: MyMonad m => a -> m ()
+
+references :: Block -> Env
+references q = execState (entries @_ @(State Env) q) mempty
+
+instance References Block where
+  entries :: forall m . MyMonad m => Block -> m ()
+  entries (Block defs) = traverse_ (locally . entries) defs
+
+instance References Definition where
+  entries = \case
+    DefModule m -> entries m
+    DefFunction f -> entries f
+    DefSend s -> entries s
+
+instance References Module where
+  entries Module{name, block} = do
+    appendToContext name
+    entries block
+
+instance References Function where
+  entries Function{name, block} = do
+    c <- getContext
+    declaration c name
+    entries block
+
+instance References Send where
+  entries Send{name} = do
+    c <- getContext
+    application c name