diff --git a/src/Rubyhs/References.hs b/src/Rubyhs/References.hs index ea94ffa..70d0708 100644 --- a/src/Rubyhs/References.hs +++ b/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 diff --git a/test/Main.hs b/test/Main.hs index 5dba7ef..afc62eb 100644 --- a/test/Main.hs +++ b/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 diff --git a/test/tests/closest.json b/test/tests/closest.json new file mode 100644 index 0000000..530f472 --- /dev/null +++ b/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": [] +} diff --git a/test/tests/closest.rb b/test/tests/closest.rb new file mode 100644 index 0000000..834b85c --- /dev/null +++ b/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) diff --git a/test/tests/deeper.json b/test/tests/deeper.json new file mode 100644 index 0000000..bdda486 --- /dev/null +++ b/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": [] +} diff --git a/test/tests/deeper.rb b/test/tests/deeper.rb new file mode 100644 index 0000000..041acfb --- /dev/null +++ b/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 diff --git a/test/tests/nested.json b/test/tests/nested.json new file mode 100644 index 0000000..ddbac8f --- /dev/null +++ b/test/tests/nested.json @@ -0,0 +1,5 @@ +{ + "A": [], + "A::B": [], + "A::B.b": [] +} diff --git a/test/tests/nested.rb b/test/tests/nested.rb new file mode 100644 index 0000000..ebdaf73 --- /dev/null +++ b/test/tests/nested.rb @@ -0,0 +1,6 @@ +module A + module B + def self.b + end + end +end