Add some tests

Do not reverse namespaces.

src/Rubyhs/References.hs

@@ -12,6 +12,7 @@ module Rubyhs.References
   , Node(..)
   ) where
 
+import qualified Prelude
 import Frelude
 import qualified Data.Language.Ruby as Ruby
 import Data.HashMap.Strict (HashMap)
@@ -56,7 +57,7 @@ deriving newtype instance Semigroup Namespace
 deriving newtype instance Monoid Namespace
 instance FromJSON Namespace where
   parseJSON = Aeson.withText "Namespace"
-    $ \t -> Namespace <$> (traverse pure $ reverse $ Text.splitOn "::" t)
+    $ \t -> Namespace <$> (traverse pure $ Text.splitOn "::" t)
 instance ToJSON Namespace where
   toJSON = Aeson.String . showNamespace
 
@@ -120,7 +121,7 @@ prettyContext = \case
   NodeModule ns -> showNamespace ns
 
 showNamespace :: Namespace -> Text
-showNamespace = Text.intercalate "::" . reverse . coerce
+showNamespace = Text.intercalate "::" . coerce
 
 newtype Context = Context Node
 
@@ -130,13 +131,16 @@ deriving newtype instance ToJSON Context
 -- HACK: Not really a semigroup as is evident from the implementation.
 instance Semigroup Context where
   -- I think that the order must be swapped because they modules are in reverse order.
-  Context c0 <> Context c1 = case traceShowId (c0, c1) of
+  Context c0 <> Context c1 = Context $ c0 <> c1
+instance Semigroup Node where
+  c0 <> c1 = case (c0, c1) of
     -- (NodeModule n0, NodeModule n1)      -> Context $ NodeModule $ n0 <> n1
-    (NodeModule n0, NodeModule n1)      -> Context $ NodeModule $ n1 <> n0
+    (NodeModule n0, NodeModule n1)      -> NodeModule $ n0 <> n1
     -- (NodeModule n0, NodeDef (FQN n1 f)) -> Context $ NodeDef $ FQN (n0 <> n1) f
-    (NodeModule n0, NodeDef (FQN n1 f)) -> Context $ NodeDef $ FQN (n1 <> n0) f
+    (NodeModule n0, NodeDef (FQN n1 f)) -> NodeDef $ FQN (n0 <> n1) f
     (NodeDef{}, NodeModule{})           -> error "Cannot append module to function context."
-    (NodeDef{}, NodeDef{})              -> error "Cannot append function to function context."
+    -- (NodeDef{}, NodeDef{})              -> error "Cannot append function to function context."
+    (NodeDef (FQN n0 _), NodeDef (FQN n1 a1)) -> NodeDef $ FQN (n0 <> n1) a1
 
 class Monad m => MyMonad (m :: Type -> Type) where
   declaration :: Node -> m ()
@@ -166,17 +170,20 @@ instance MyMonad (State Env) where
     go env@Env{declarations} = env { declarations = Set.insert q declarations }
   application n = do
     Context c <- getContext
+    decls <- gets declarations
+    n' <- findClosest decls n
     let
-      n' = case n of
-        -- TODO: Maybe check if there is `a` is a function in the
-        -- current closure.
-        (NodeDef (FQN [] a)) -> NodeDef $ FQN (nodeNs c) a
-        -- Look for the closest enclosing scope that has a reference
-        -- to `c`.  For now we'll just guess that it is a fully
-        -- qualified reference.
-        NodeDef{} -> n
-        -- Ditto as above.
-        NodeModule{} -> n
+      -- n' = findCloses n
+      -- case n of
+      --   -- TODO: Maybe check if there is `a` is a function in the
+      --   -- current closure.
+      --   (NodeDef (FQN [] a)) -> NodeDef $ FQN (nodeNs c) a
+      --   -- Look for the closest enclosing scope that has a reference
+      --   -- to `c`.  For now we'll just guess that it is a fully
+      --   -- qualified reference.
+      --   NodeDef{} -> n
+      --   -- Ditto as above.
+      --   NodeModule{} -> n
       go env@Env{applications}
         = env { applications = HashMap.insertWith mappend c (Set.singleton n') applications }
     modify go
@@ -185,10 +192,24 @@ instance MyMonad (State Env) where
     where
     go env = env { Rubyhs.References.context = q }
 
-nodeNs :: Node -> Namespace
-nodeNs = \case
-  (NodeDef (FQN a _)) -> a
-  NodeModule n -> n
+findClosest :: MyMonad m => Set Node -> Node -> m Node
+findClosest decls n = do
+  Context c <- getContext
+  pure $ go $ c
+  where
+  go :: Node -> Node
+  go c = case Set.member (c <> n) decls of
+    True  -> c <> n
+    False -> case c of
+      NodeModule [] -> case n of  -- Last resort
+        NodeDef (FQN _ a) -> NodeDef (FQN mempty a)
+        x -> x
+      _ -> go $ drop c
+  drop :: Node -> Node
+  drop = \case
+    (NodeDef (FQN a _)) -> NodeModule a
+    (NodeModule (Namespace [])) -> error "__IMPOSSIBLE__"
+    (NodeModule (Namespace xs)) -> NodeModule $ Namespace $ reverse $ Prelude.tail $ reverse xs
 
 locally :: MyMonad m => m a -> m a
 locally act = do
@@ -271,7 +292,7 @@ updateContext f = getContext >>= \c -> writeContext (f c)
 
 instance References Ruby.Module where
   entries Ruby.Module{name, begin} = do
-    updateContext $ (<>) $ Context $ NodeModule $ constToNamespace name
+    updateContext $ (<> (Context $ NodeModule $ constToNamespace name))
     c <- getContext >>= \case
       Context (NodeModule c) -> pure c
       _ -> error "..."
@@ -280,12 +301,12 @@ instance References Ruby.Module where
 
 atomToNode :: MyMonad m => Ruby.Atom -> m Node
 atomToNode (Ruby.Atom name) = do
-  namespace <- getContext >>= \case
-    Context (NodeModule c) -> pure c
+  namespace <- getContext >>= pure . \case
+    Context (NodeModule c) -> 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"
+    Context (NodeDef (FQN ns _)) -> ns
   pure $ NodeDef $ FQN namespace name
 
 instance References Ruby.Def where

test/Main.hs

@@ -1,8 +1,7 @@
 {-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -Wall #-}
 module Main (main) where
 
-import Data.List
-import Data.Ord
 import Frelude
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -10,19 +9,15 @@ import qualified Data.Language.Ruby as Ruby
 import qualified Rubyhs.References as Ruby
 import qualified Data.Aeson as Aeson
 import System.FilePath
-import Data.Map (Map)
 import Data.HashMap.Strict (HashMap)
 import Data.Set (Set)
 import System.Directory (withCurrentDirectory)
-import Debug.Trace
-import System.IO
-import qualified Data.ByteString.Lazy.Char8 as ByteString
 
 main :: IO ()
 main = withCurrentDirectory "test" $ defaultMain $ testGroup "Unit tests" tests
 
 tests :: [TestTree]
-tests = go <$> ["mod", "simple"]
+tests = go <$> ["mod", "simple", "nested", "closest"]
   where
   go :: String -> TestTree
   go s = testCase s $ do

test/tests/closest.json

@@ -0,0 +1,13 @@
+{
+  "": [
+    "puts",
+    "A::B1.b1"
+  ],
+  "A": [],
+  "A::B0": [],
+  "A::B0.b0": [],
+  "A::B1.b1": [
+    "A::B0.b0"
+  ],
+  "A::B1": []
+}

test/tests/closest.rb

@@ -0,0 +1,14 @@
+module A
+  module B0
+    def self.b0
+      :b0
+    end
+  end
+  module B1
+    def self.b1
+      B0.b0
+    end
+  end
+end
+
+puts(A::B1.b1)

test/tests/deeper.json

@@ -0,0 +1,12 @@
+{
+  "A": [],
+  "A::B": [
+    "puts",
+    "A::B.a",
+    "A::B::A::B.a"
+  ],
+  "A::B.a": [],
+  "A::B::A": [],
+  "A::B::A::B": [],
+  "A::B::A::B.a": []
+}

test/tests/deeper.rb

@@ -0,0 +1,21 @@
+module A
+  module B
+    def self.a
+      :shallow
+    end
+
+    puts(A::B.a)
+
+    module A
+      module B
+        def self.a
+          :deep
+        end
+      end
+    end
+
+    # Had The inner A::B not been declared this would refer to the one
+    # that returns :shallow.
+    puts(A::B.a)
+  end
+end

test/tests/nested.json

@@ -0,0 +1,5 @@
+{
+  "A": [],
+  "A::B": [],
+  "A::B.b": []
+}

test/tests/nested.rb

@@ -0,0 +1,6 @@
+module A
+  module B
+    def self.b
+    end
+  end
+end