Add test-case

package.yaml

@@ -34,6 +34,7 @@ dependencies:
   - optparse-applicative
   - temporary
   - text
+  - hashable
 
 default-extensions:
   - ConstraintKinds
@@ -76,7 +77,7 @@ executables:
 
 tests:
   test:
-    main:                Spec.hs
+    main:                Main.hs
     source-dirs:         test
     ghc-options:
       - -threaded
@@ -84,3 +85,7 @@ tests:
       - -with-rtsopts=-N
     dependencies:
       - rubyhs
+      - tasty
+      - tasty-hunit
+      - filepath
+      - directory

src/Rubyhs.hs

@@ -3,7 +3,7 @@
 module Rubyhs (main) where
 
 import Data.Foldable (traverse_)
-import Data.Map (Map)
+import Data.HashMap.Strict (HashMap)
 import Data.Set (Set)
 import Data.Tree (Tree(Node), Forest)
 import Frelude
@@ -31,7 +31,7 @@ main = do
         Just dotPath -> drawDot dotPath x
   traverse_ act begins
 
-drawDot :: FilePath -> Map Ruby.Node (Set Ruby.Node)  -> IO ()
+drawDot :: FilePath -> HashMap Ruby.Node (Set Ruby.Node)  -> IO ()
 drawDot p
   = Text.writeFile p
   . Graphviz.digraph

src/Rubyhs/References.hs

@@ -15,17 +15,21 @@ module Rubyhs.References
 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.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Aeson.Encoding.Internal as Aeson
 import Data.Kind
 import Control.Monad.State
 import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types 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
+import Data.Hashable
+import qualified Data.Char as Char
 
 span :: G node key -> Forest node
 span (g, f, _) = fmap ((\(x, _, _) -> x) . f) <$> Graph.dff g
@@ -49,6 +53,8 @@ instance IsList Namespace where
   toList = coerce
 deriving newtype instance Semigroup Namespace
 deriving newtype instance Monoid Namespace
+instance FromJSON Namespace where
+  parseJSON = Aeson.withText "Namespace" $ \t -> Namespace <$> (traverse pure $ Text.splitOn "::" t)
 instance ToJSON Namespace where
   toJSON = Aeson.String . showNamespace
 
@@ -63,14 +69,32 @@ data FQN = FQN
 
 data Node = NodeDef FQN | NodeModule Namespace
 
+beginsWithCapital :: Text -> Bool
+beginsWithCapital = Char.isUpper . Text.head
+
 deriving stock instance Show Node
 deriving stock instance Eq Node
 deriving stock instance Ord Node
-
+instance FromJSON Node where
+  parseJSON = Aeson.withText "Node" $ nodeParser
+nodeParser :: Text -> Aeson.Parser Node
+nodeParser = \t -> case Text.splitOn "." t of
+    [mods,fun] -> fmap NodeDef (FQN <$> Aeson.parseJSON (Aeson.String mods) <*> pure fun)
+    [mods]     ->
+      if beginsWithCapital mods
+      then NodeModule <$> Aeson.parseJSON (Aeson.String mods)
+      else pure $ NodeDef $ FQN mempty mods
+    _          -> empty
+instance Aeson.FromJSONKey Node where
+  fromJSONKey = Aeson.FromJSONKeyTextParser nodeParser
+instance Aeson.ToJSONKey Node where
+  toJSONKey = Aeson.ToJSONKeyText prettyContext (\n -> Aeson.text $ prettyContext n)
 instance ToJSON Node where
   toJSON = \case
     NodeDef q -> Aeson.toJSON q
     NodeModule m -> Aeson.toJSON m
+instance Hashable Node where
+  hashWithSalt n a = hashWithSalt @Text n $ prettyContext a
 
 deriving stock instance Show FQN
 deriving stock instance Eq FQN
@@ -110,11 +134,13 @@ class Monad m => MyMonad (m :: Type -> Type) where
 
 data Env = Env
   { declarations :: Set Node
-  , applications :: Map Node (Set Node)
+  , applications :: HashMap Node (Set Node)
   , context      :: Context
   }
 
-newtype Result = Result (Map Node (Set Node))
+newtype Result = Result (HashMap Node (Set Node))
+-- HACK: FromJSON and ToJSON don't agree.
+deriving newtype instance FromJSON Result
 instance ToJSON Result where
   toJSON (Result a) = Aeson.Object $ fromList $ go <$> toList a
     where
@@ -135,7 +161,7 @@ instance MyMonad (State Env) where
     Context c <- getContext
     let
       go env@Env{applications}
-        = env { applications = Map.insertWith mappend c (Set.singleton n) applications }
+        = env { applications = HashMap.insertWith mappend c (Set.singleton n) applications }
     modify go
   getContext = gets Rubyhs.References.context
   writeContext q = modify go
@@ -153,7 +179,7 @@ class References a where
   entries :: MyMonad m => a -> m ()
 
 references :: Ruby.Begin -> Result
-references q = Result $ Map.unionWith mappend applications declarations'
+references q = Result $ HashMap.unionWith mappend applications declarations'
   where
   Env{declarations,applications} = execState (entries @_ @(State Env) q) emptyEnv
   emptyEnv = Env mempty mempty (Context $ NodeModule mempty)

test/Main.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE BangPatterns #-}
+module Main (main) where
+
+import Data.List
+import Data.Ord
+import Frelude
+import Test.Tasty
+import Test.Tasty.HUnit
+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"]
+  where
+  go :: String -> TestTree
+  go s = testCase s $ do
+    let basename = "tests" </> s
+    begin <- Ruby.parseFile @Ruby.Begin $ basename <.> "rb"
+    json  <- decodeFile @(HashMap Ruby.Node (Set Ruby.Node)) $ basename <.> "json"
+    let (Ruby.Result refs) = Ruby.references begin
+    when (refs /= json)
+      $ assertFailure
+      $ "Expected " <> convertString (Aeson.encode refs) <> " but got " <> convertString (Aeson.encode json)
+
+decodeFile :: FromJSON a => FilePath -> IO a
+decodeFile p = Aeson.eitherDecodeFileStrict' p >>= \case
+  Left err -> error err
+  Right a -> pure a

test/Spec.hs

@@ -1,2 +0,0 @@
-main :: IO ()
-main = putStrLn "Test suite not yet implemented"

test/tests/mod.json

@@ -0,0 +1,7 @@
+{
+  "A.b": [
+    "A.a"
+  ],
+  "A.a": [],
+  "A": []
+}

test/tests/mod.rb

@@ -0,0 +1,8 @@
+module A
+  def a
+  end
+
+  def b
+    a
+  end
+end

test/tests/simple.json

@@ -0,0 +1,6 @@
+{
+  "a": [],
+  "b": [
+    "a"
+  ]
+}

test/tests/simple.rb

@@ -0,0 +1,6 @@
+def a
+end
+
+def b
+  a
+end