diff --git a/package.yaml b/package.yaml index 4d52fe3..cf34c55 100644 --- a/package.yaml +++ b/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 diff --git a/src/Data/Language/Ruby.hs b/src/Data/Language/Ruby.hs index aea2dbd..843e161 100644 --- a/src/Data/Language/Ruby.hs +++ b/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 diff --git a/src/Rubyhs.hs b/src/Rubyhs.hs index c97606c..cd1c37a 100644 --- a/src/Rubyhs.hs +++ b/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 diff --git a/src/Rubyhs/References.hs b/src/Rubyhs/References.hs index 5d53aa9..7b7f25c 100644 --- a/src/Rubyhs/References.hs +++ b/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