diff --git a/package.yaml b/package.yaml index 8f151fa..e67f687 100644 --- a/package.yaml +++ b/package.yaml @@ -33,6 +33,7 @@ dependencies: - unordered-containers - optparse-applicative - temporary + - text default-extensions: - ConstraintKinds diff --git a/src/Data/Language/Ruby.hs b/src/Data/Language/Ruby.hs index 31e4b61..b265928 100644 --- a/src/Data/Language/Ruby.hs +++ b/src/Data/Language/Ruby.hs @@ -49,6 +49,9 @@ data Statement | StmtFunction Function | StmtSend Send | StmtRBlock RBlock + -- TODO: We should also handle modules here. Otherwise we cannot + -- cover the case where a function references a module. + | StmtConst Namespace | StmtAnything Anything deriving stock instance Show Statement @@ -64,6 +67,7 @@ instance ToJSON Statement where "StmtFunction" -> "function" "StmtSend" -> "send" "StmtRBlock" -> "block" + "StmtConst" -> "const" x -> x instance FromJSON Statement where @@ -72,6 +76,7 @@ instance FromJSON Statement where <|> (StmtFunction <$> parseJSON v) <|> (StmtSend <$> parseJSON v) <|> (StmtRBlock <$> parseJSON v) + <|> (StmtConst <$> parseJSON v) <|> (StmtAnything <$> parseJSON v) newtype Anything = Anything Value diff --git a/src/Rubyhs/References.hs b/src/Rubyhs/References.hs index 6699d6b..24aa28a 100644 --- a/src/Rubyhs/References.hs +++ b/src/Rubyhs/References.hs @@ -24,6 +24,8 @@ import Data.List import Data.HashMap.Strict (HashMap) import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Coerce data Entry a = Entry { node :: a @@ -40,6 +42,8 @@ instance IsList Namespace where toList (Namespace l) = toList l deriving newtype instance Semigroup Namespace deriving newtype instance Monoid Namespace +instance ToJSON Namespace where + toJSON = Aeson.String . Text.intercalate "::" . coerce -- Names are in reverse order. data FQN = FQN @@ -47,6 +51,17 @@ data FQN = FQN , name :: Text } +data Node = NodeFunction FQN | NodeModule Namespace + +deriving stock instance Show Node +deriving stock instance Eq Node +deriving stock instance Ord Node + +instance ToJSON Node where + toJSON = \case + NodeFunction q -> Aeson.toJSON q + NodeModule m -> Aeson.toJSON m + deriving stock instance Show FQN deriving stock instance Eq FQN deriving stock instance Ord FQN @@ -60,47 +75,51 @@ instance Pretty FQN where pretty = pretty . prettyFQN prettyFQN :: FQN -> Text -prettyFQN FQN{namespace, name} = case namespace of +prettyFQN FQN{name, namespace} = case namespace of [] -> name _ -> prettyNamespace namespace <> "." <> name prettyNamespace :: Namespace -> Text prettyNamespace = convertString . intercalate "::" . fmap convertString . reverse . toList -data Context = ContextFun FQN | ContextMod Namespace +newtype Context = Context Node deriving stock instance Eq Context deriving stock instance Ord Context +deriving newtype instance ToJSON Context class Monad m => MyMonad (m :: Type -> Type) where - declaration :: FQN -> m () - application :: Context -> FQN -> m () + declaration :: Node -> m () + application :: Node -> Node -> m () getContext :: m Context writeContext :: Context -> m () data Env = Env - { declarations :: Set FQN - , applications :: Map Context (Set FQN) + { declarations :: Set Node + , applications :: Map Node (Set Node) , context :: Context } data Result = Result - { declarations :: Set FQN - , applications :: Map Context (Set FQN) + { declarations :: Set Node + , applications :: Map Node (Set Node) } instance ToJSON Result where toJSON Result{declarations,applications} = Aeson.object [ "declarations" .= declarations - , "applications" .= f applications + , "applications" .= f ] where - f x = fromList @(HashMap _ _) $ go <$> toList x - go (x, y) = (prettyContext x, y) + f :: HashMap Text (Set Node) + f = fromList @(HashMap _ _) $ go <$> toList applications + -- go :: (Node, Set Node) -> (Text, Set Node) + go :: (Node, Set Node) -> (Text, Set Node) + go (x, y) = (prettyContext x, y) -prettyContext :: Context -> Text +prettyContext :: Node -> Text prettyContext = \case - ContextFun q -> prettyFQN q - ContextMod ns -> prettyNamespace ns + NodeFunction fun -> prettyFQN fun + NodeModule ns -> prettyNamespace ns instance MyMonad (State Env) where declaration q = modify go @@ -129,8 +148,8 @@ locally act = do appendToContext :: MyMonad m => Name -> m () appendToContext n = updateContext go where - go (ContextMod q) = ContextMod $ name2ns n <> q - go _ = error "Cannot append module to context in function context" + go (Context (NodeModule q)) = Context $ NodeModule $ name2ns n <> q + go (Context NodeFunction{}) = error "Cannot append module to context in function context" name2ns :: Name -> Namespace name2ns (Name o) = go o @@ -149,7 +168,7 @@ references :: Block -> Result references q = Result{declarations, applications} where Env{declarations,applications} = execState (entries @_ @(State Env) q) emptyEnv - emptyEnv = Env mempty mempty (ContextMod mempty) + emptyEnv = Env mempty mempty (Context $ NodeModule mempty) instance References Block where entries :: forall m . MyMonad m => Block -> m () @@ -157,26 +176,37 @@ instance References Block where instance References Statement where entries = \case - StmtModule m -> entries m + StmtModule m -> entries m StmtFunction f -> entries f - StmtSend s -> entries s + StmtSend s -> entries s + StmtConst c -> entries c -- TODO: - StmtRBlock{} -> pure () + StmtRBlock{} -> pure () StmtAnything{} -> pure () +instance References Ruby.Namespace where + entries = \case + Ruby.Namespace xs -> do + Context c <- getContext + application c (NodeModule (Namespace ((\(Name (Aeson.String t)) -> t) <$> xs))) + instance References Module where entries Module{name, block} = do appendToContext name + c <- getContext >>= \case + Context (NodeModule c) -> pure c + _ -> error "..." + declaration $ NodeModule c entries block instance References Function where entries Function{name, block} = do namespace <- getContext >>= \case - ContextMod c -> pure c - _ -> error "Cannot have a function declaration in a function context" - declaration $ qual namespace name + Context (NodeModule c) -> pure c + Context NodeFunction{} -> error "Cannot have a function declaration in a function context" + declaration $ NodeFunction $ qual namespace name locally $ do - writeContext (ContextFun $ qual namespace name) + writeContext (Context $ NodeFunction $ qual namespace name) entries block qual :: Namespace -> Name -> FQN @@ -186,8 +216,8 @@ qual namespace (Name o) = case o of instance References Send where entries Send{namespace, name} = do - c <- getContext - application c $ qual (fromNS namespace) name + Context c <- getContext + application c $ NodeFunction $ qual (fromNS namespace) name where fromNS :: Ruby.Namespace -> Namespace fromNS (Ruby.Namespace l) = Namespace $ go <$> l