diff --git a/package.yaml b/package.yaml index 66f9249..8e49fd0 100644 --- a/package.yaml +++ b/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 diff --git a/src/Rubyhs.hs b/src/Rubyhs.hs index db02ad5..afddaa7 100644 --- a/src/Rubyhs.hs +++ b/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 diff --git a/src/Rubyhs/References.hs b/src/Rubyhs/References.hs index 36e3b22..2cf411d 100644 --- a/src/Rubyhs/References.hs +++ b/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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..a859029 --- /dev/null +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index cd4753f..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented" diff --git a/test/tests/mod.json b/test/tests/mod.json new file mode 100644 index 0000000..f364750 --- /dev/null +++ b/test/tests/mod.json @@ -0,0 +1,7 @@ +{ + "A.b": [ + "A.a" + ], + "A.a": [], + "A": [] +} diff --git a/test/tests/mod.rb b/test/tests/mod.rb new file mode 100644 index 0000000..8aafd8d --- /dev/null +++ b/test/tests/mod.rb @@ -0,0 +1,8 @@ +module A + def a + end + + def b + a + end +end diff --git a/test/tests/simple.json b/test/tests/simple.json new file mode 100644 index 0000000..edec06a --- /dev/null +++ b/test/tests/simple.json @@ -0,0 +1,6 @@ +{ + "a": [], + "b": [ + "a" + ] +} diff --git a/test/tests/simple.rb b/test/tests/simple.rb new file mode 100644 index 0000000..876bbfa --- /dev/null +++ b/test/tests/simple.rb @@ -0,0 +1,6 @@ +def a +end + +def b + a +end