From a698ac82eaf365ed0fc52d80b96e50cb3fbc1302 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Fri, 11 Oct 2019 14:03:01 +0200 Subject: [PATCH] stuff --- ruby/test.rb | 8 ++- src/Data/Language/Ruby.hs | 22 +++++++- src/Rubyhs.hs | 1 + src/Rubyhs/References.hs | 114 +++++++++++++++++++++++++------------- 4 files changed, 103 insertions(+), 42 deletions(-) diff --git a/ruby/test.rb b/ruby/test.rb index 926c233..6f603dd 100644 --- a/ruby/test.rb +++ b/ruby/test.rb @@ -10,7 +10,13 @@ module M module N def f - g + M::foo + h + end + + module A::B + def k + end end def g diff --git a/src/Data/Language/Ruby.hs b/src/Data/Language/Ruby.hs index 843e161..ddb6163 100644 --- a/src/Data/Language/Ruby.hs +++ b/src/Data/Language/Ruby.hs @@ -8,6 +8,7 @@ module Data.Language.Ruby , Module(..) , Name(..) , Send(..) + , Namespace(..) ) where import Data.Aeson (parseJSON, Value(..), withArray) @@ -65,8 +66,26 @@ instance FromJSON Definition where <|> (DefFunction <$> parseJSON val) <|> (DefSend <$> parseJSON val) +newtype Namespace = Namespace [Name] + +deriving newtype instance Semigroup Namespace +deriving newtype instance Monoid Namespace +deriving stock instance Show Namespace +deriving stock instance Ord Namespace +deriving stock instance Eq Namespace +deriving stock instance Generic Namespace +instance ToJSON Namespace where + toEncoding = Aeson.genericToEncoding aesonOptions + +instance FromJSON Namespace where + parseJSON = \case + Null -> pure mempty + Array [String "const", namespace, String name] -> (<> Namespace [Name $ String name]) <$> parseJSON namespace + x -> error $ show x + data Send = Send { args :: Args + , namespace :: Namespace , name :: Name } @@ -79,9 +98,10 @@ instance ToJSON Send where instance FromJSON Send where parseJSON = withArray "Send" $ \ as -> case Vector.toList as of - (String "send" : _ : name : args) + (String "send" : namespace : name : args) -> Send <$> parseJSON (Array $ Vector.fromList args) + <*> parseJSON namespace <*> parseJSON name _ -> empty diff --git a/src/Rubyhs.hs b/src/Rubyhs.hs index 39a8f0f..10a081e 100644 --- a/src/Rubyhs.hs +++ b/src/Rubyhs.hs @@ -20,6 +20,7 @@ run :: FilePath -> IO () run p = do json <- runParser p block <- decodeFail @_ @Block $ ByteString.pack json + -- ByteString.putStrLn $ encode block ByteString.putStrLn $ encode $ references block decodeFail :: MonadFail m => FromJSON a => ByteString -> m a diff --git a/src/Rubyhs/References.hs b/src/Rubyhs/References.hs index 44ec58b..ebca064 100644 --- a/src/Rubyhs/References.hs +++ b/src/Rubyhs/References.hs @@ -7,10 +7,12 @@ module Rubyhs.References , references , Env(..) , Result(..) + , Namespace(..) ) where import Frelude -import Data.Language.Ruby +import Data.Language.Ruby hiding (Namespace) +import qualified Data.Language.Ruby as Ruby import Data.Map (Map) import qualified Data.Map as Map import Data.Kind @@ -21,59 +23,74 @@ import Data.List import Data.HashMap.Strict (HashMap) import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) import Data.Text.Prettyprint.Doc (layoutCompact) +import Data.Set (Set) +import qualified Data.Set as Set data Entry a = Entry { node :: a , fqn :: FQN } +newtype Namespace = Namespace [Text] +deriving stock instance Show Namespace +deriving stock instance Eq Namespace +deriving stock instance Ord Namespace +instance IsList Namespace where + type Item Namespace = Text + fromList = Namespace . fromList + toList (Namespace l) = toList l +deriving newtype instance Semigroup Namespace +deriving newtype instance Monoid Namespace + -- Names are in reverse order. -newtype FQN = FQN ([] Name) +data FQN = FQN + { namespace :: Namespace + , name :: Text + } deriving stock instance Show FQN -deriving newtype instance Semigroup FQN -instance Monoid FQN where - -- 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 . reverse . toList - where - go (Name (Aeson.Array [_, _, Aeson.String n])) = convertString n - go x = show x +deriving stock instance Eq FQN +deriving stock instance Ord FQN +instance Pretty Namespace where + pretty = pretty . prettyNamespace -deriving newtype instance Eq FQN -deriving newtype instance Ord FQN +instance Aeson.ToJSON FQN where + toJSON = Aeson.String . prettyFQN +instance Aeson.ToJSONKey FQN where +instance Pretty FQN where + pretty = pretty . prettyFQN + +prettyFQN :: FQN -> Text +prettyFQN FQN{namespace, name} = case namespace of + [] -> name + _ -> prettyNamespace namespace <> "." <> name + +prettyNamespace :: Namespace -> Text +prettyNamespace = convertString . intercalate "::" . fmap convertString . reverse . toList class Monad m => MyMonad (m :: Type -> Type) where - declaration :: FQN -> Name -> m () - application :: FQN -> Name -> m () - getContext :: m FQN - writeContext :: FQN -> m () + declaration :: FQN -> m () + application :: Namespace -> FQN -> m () + getContext :: m Namespace + writeContext :: Namespace -> m () data Env = Env - { declarations :: Map FQN [Name] - , applications :: Map FQN [Name] - , context :: FQN + { declarations :: Set FQN + , applications :: Map Namespace (Set FQN) + , context :: Namespace } data Result = Result - { declarations :: Map FQN [Name] - , applications :: Map FQN [Name] + { declarations :: Set FQN + , applications :: Map Namespace (Set FQN) } instance ToJSON Result where toJSON Result{declarations,applications} = Aeson.object - [ "declarations" .= f declarations + [ "declarations" .= declarations , "applications" .= f applications ] where - f :: Map FQN [Name] -> HashMap Text [Name] - f x = fromList $ go <$> toList x + f x = fromList @(HashMap _ _) $ go <$> toList x go (x, y) = (renderStrict $ layoutCompact $ pretty x, y) instance Semigroup Env where @@ -83,20 +100,20 @@ instance Monoid Env where mempty = Env mempty mempty mempty instance MyMonad (State Env) where - declaration q n = modify go + declaration q = modify go where go :: Env -> Env - go env@Env{declarations} = env { declarations = Map.insertWith mappend q (pure n) declarations } + go env@Env{declarations} = env { declarations = Set.insert q declarations } application q n = modify go where go :: Env -> Env - go env@Env{applications} = env { applications = Map.insertWith mappend q (pure n) applications } + go env@Env{applications} = env { applications = Map.insertWith mappend q (Set.singleton n) applications } getContext = gets context writeContext q = modify go where go env = env { context = q } -updateContext :: MyMonad m => (FQN -> FQN) -> m () +updateContext :: MyMonad m => (Namespace -> Namespace) -> m () updateContext f = getContext >>= \c -> writeContext (f c) locally :: MyMonad m => m a -> m a @@ -109,7 +126,12 @@ locally act = do appendToContext :: MyMonad m => Name -> m () appendToContext n = updateContext go where - go (FQN ns) = FQN $ pure n <> ns + go q = name2ns n <> q + +name2ns :: Name -> Namespace +name2ns (Name o) = case o of + Aeson.Array [_, _, Aeson.String s] -> [s] + _ -> error $ show o class References a where entries :: MyMonad m => a -> m () @@ -136,11 +158,23 @@ instance References Module where instance References Function where entries Function{name, block} = do - c <- getContext - declaration c name + namespace <- getContext + declaration $ qual namespace name entries block +qual :: Namespace -> Name -> FQN +qual namespace (Name o) = case o of + Aeson.String name -> FQN { namespace , name } + _ -> error $ show o + instance References Send where - entries Send{name} = do + entries Send{namespace, name} = do c <- getContext - application c name + application c $ qual (fromNS namespace) name + where + fromNS :: Ruby.Namespace -> Namespace + fromNS (Ruby.Namespace l) = Namespace $ go <$> l + go :: Name -> Text + go (Name o) = case o of + Aeson.String s -> s + _ -> error $ show o