Print references and applications

package.yaml

@@ -29,16 +29,23 @@ dependencies:
   - frelude
   - containers
   - mtl
+  - prettyprinter
+  - unordered-containers
 
 default-extensions:
   - ConstraintKinds
+  - DeriveAnyClass
   - DeriveGeneric
+  - DerivingStrategies
+  - EmptyCase
   - FlexibleContexts
   - FlexibleInstances
   - GADTs
   - GeneralizedNewtypeDeriving
   - LambdaCase
+  - NamedFieldPuns
   - NamedWildCards
+  - NoImplicitPrelude
   - OverloadedStrings
   - ScopedTypeVariables
   - StandaloneDeriving
@@ -48,10 +55,6 @@ default-extensions:
   - TypeSynonymInstances
   - UnicodeSyntax
   - ViewPatterns
-  - DerivingStrategies
-  - EmptyCase
-  - NoImplicitPrelude
-  - DeriveAnyClass
 
 library:
   source-dirs: src

src/Data/Language/Ruby.hs

@@ -10,10 +10,12 @@ module Data.Language.Ruby
   , Send(..)
   ) where
 
-import Data.Aeson (parseJSON, Value(String, Null, Array), withArray)
+import Data.Aeson (parseJSON, Value(..), withArray)
 import Frelude
 import qualified Data.Aeson.Types as Aeson
 import qualified Data.Vector as Vector
+import Data.Coerce
+import Data.Word
 
 kebabCase :: String -> String
 kebabCase = Aeson.camelTo2 '-'
@@ -50,7 +52,7 @@ deriving stock instance Generic Definition
 instance ToJSON Definition where
   toEncoding = Aeson.genericToEncoding opts
     where
-    opts = opts { Aeson.constructorTagModifier = go }
+    opts = aesonOptions { Aeson.constructorTagModifier = go }
     go = \case
       "DefModule" -> "module"
       "DefFunction" -> "function"
@@ -125,7 +127,7 @@ newtype Args = Args Value
 
 deriving stock instance Show Args
 instance Ord Args where
-  compare = error "Unimplemented"
+  compare = coerce compareValue
 deriving stock instance Eq Args
 deriving stock instance Generic Args
 instance ToJSON Args where
@@ -147,7 +149,28 @@ newtype Name = Name Value
 
 deriving stock instance Show Name
 instance Ord Name where
-  compare = error "Unimplemented"
+  compare = coerce compareValue
 deriving stock instance Eq Name
 deriving newtype instance ToJSON Name
 deriving newtype instance FromJSON Name
+
+compareValue :: Aeson.Value -> Aeson.Value -> Ordering
+compareValue v0 v1 = case (v0, v1) of
+  -- This case is buggy:
+  (Object o0, Object o1)    -> compare (fst <$> toList o0) (fst <$> toList o1)
+  (Array a0, Array a1)      -> foldMap (uncurry compareValue) $ zip (toList a0) (toList a1)
+  (String s0, String s1)    -> compare s0 s1
+  (Number n0, Number n1)    -> compare n0 n1
+  (Bool b0, Bool b1)        -> compare b0 b1
+  (Null, Null)              -> EQ
+  _                         -> (compare `on` cons) v0 v1
+    where
+    -- Enumerate constructors.
+    cons :: Aeson.Value -> Word8
+    cons = \case
+      Object{} -> 0
+      Array{}  -> 1
+      String{} -> 2
+      Number{} -> 3
+      Bool{}   -> 4
+      Null{}   -> 5

src/Rubyhs.hs

@@ -11,6 +11,12 @@ import Frelude
 import System.Environment (getArgs)
 import System.Process (readProcess)
 import qualified Data.ByteString.Lazy.Char8 as ByteString
+import Rubyhs.References (references)
+import qualified Rubyhs.References as References
+import Data.Text.Prettyprint.Doc.Render.Text (renderStrict)
+import Data.Text.Prettyprint.Doc (layoutCompact)
+import Data.HashMap.Strict (HashMap)
+import GHC.Exts (fromList, toList)
 
 main :: IO ()
 main = getArgs >>= traverse_ run
@@ -20,10 +26,16 @@ run p = do
   json <- runParser p
   block <- decodeFail @_ @Block $ ByteString.pack json
   ByteString.putStrLn $ encode block
+  let References.Env{declarations, applications} = references block
+  printEm declarations
+  printEm applications
+  where
+  go (x, y) = (renderStrict $ layoutCompact $ pretty x, y)
+  printEm x = ByteString.putStrLn $ encode $ fromList @(HashMap _ _) $ go <$> toList x
 
 decodeFail :: MonadFail m => FromJSON a => ByteString -> m a
 decodeFail s = case eitherDecode s of
-  Left err -> fail err
+  Left err -> Frelude.fail err
   Right a -> pure a
 
 runParser :: FilePath -> IO String

src/Rubyhs/References.hs

@@ -1,31 +1,45 @@
-{-# LANGUAGE DuplicateRecordFields, OverloadedLists, InstanceSigs, RecordWildCards #-}
+{-# LANGUAGE DuplicateRecordFields, OverloadedLists, InstanceSigs #-}
 {-# OPTIONS_GHC -Wall #-}
 module Rubyhs.References
   ( References(entries)
   , Entry(..)
   , FQN(..)
   , references
+  , Env(..)
   ) where
 
 import Frelude
-import Data.List.NonEmpty (NonEmpty)
 import Data.Language.Ruby
-import Data.Map
+import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Kind
 import Control.Monad.State
 import qualified Data.Aeson as Aeson
+import Data.List
 
 data Entry a = Entry
   { node :: a
   , fqn :: FQN
   }
 
-newtype FQN = FQN (NonEmpty Name)
+newtype FQN = FQN ([] Name)
 
+deriving stock instance Show FQN
 deriving newtype instance Semigroup FQN
 instance Monoid FQN where
-  mempty = FQN $ pure $ Name Aeson.Null
+  -- mempty is the top level.
+  mempty = FQN mempty
+deriving newtype instance Aeson.ToJSON FQN
+instance Aeson.ToJSONKey FQN where
+instance IsList FQN where
+  type Item FQN = Name
+  fromList l = FQN $ fromList l
+  toList (FQN l) = toList l
+instance Pretty FQN where
+  pretty = pretty . intercalate "::" . fmap go . toList
+    where
+    go (Name (Aeson.Array [_, _, Aeson.String n])) = convertString n
+    go x = show x
 
 deriving newtype instance Eq FQN
 deriving newtype instance Ord FQN