diff --git a/package.yaml b/package.yaml index 4d5a0c2..4d52fe3 100644 --- a/package.yaml +++ b/package.yaml @@ -27,6 +27,8 @@ dependencies: - vector - bytestring - frelude + - containers + - mtl default-extensions: - ConstraintKinds diff --git a/src/Data/Language/Ruby.hs b/src/Data/Language/Ruby.hs index 56325ed..aea2dbd 100644 --- a/src/Data/Language/Ruby.hs +++ b/src/Data/Language/Ruby.hs @@ -27,6 +27,8 @@ aesonOptions = Aeson.defaultOptions newtype Block = Block [Definition] deriving stock instance Show Block +deriving stock instance Ord Block +deriving stock instance Eq Block deriving stock instance Generic Block instance ToJSON Block where toEncoding = Aeson.genericToEncoding aesonOptions @@ -42,6 +44,8 @@ data Definition | DefSend Send deriving stock instance Show Definition +deriving stock instance Ord Definition +deriving stock instance Eq Definition deriving stock instance Generic Definition instance ToJSON Definition where toEncoding = Aeson.genericToEncoding opts @@ -65,6 +69,8 @@ data Send = Send } deriving stock instance Show Send +deriving stock instance Ord Send +deriving stock instance Eq Send deriving stock instance Generic Send instance ToJSON Send where toEncoding = Aeson.genericToEncoding aesonOptions @@ -83,6 +89,8 @@ data Module = Module } deriving stock instance Show Module +deriving stock instance Ord Module +deriving stock instance Eq Module deriving stock instance Generic Module instance ToJSON Module where toEncoding = Aeson.genericToEncoding aesonOptions @@ -107,6 +115,8 @@ data Function = Function } deriving stock instance Show Function +deriving stock instance Ord Function +deriving stock instance Eq Function deriving stock instance Generic Function instance ToJSON Function where toEncoding = Aeson.genericToEncoding aesonOptions @@ -114,6 +124,9 @@ instance ToJSON Function where newtype Args = Args Value deriving stock instance Show Args +instance Ord Args where + compare = error "Unimplemented" +deriving stock instance Eq Args deriving stock instance Generic Args instance ToJSON Args where toEncoding = Aeson.genericToEncoding aesonOptions @@ -133,5 +146,8 @@ instance FromJSON Function where newtype Name = Name Value deriving stock instance Show Name +instance Ord Name where + compare = error "Unimplemented" +deriving stock instance Eq Name deriving newtype instance ToJSON Name deriving newtype instance FromJSON Name diff --git a/src/Rubyhs/References.hs b/src/Rubyhs/References.hs new file mode 100644 index 0000000..5d53aa9 --- /dev/null +++ b/src/Rubyhs/References.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DuplicateRecordFields, OverloadedLists, InstanceSigs, RecordWildCards #-} +{-# OPTIONS_GHC -Wall #-} +module Rubyhs.References + ( References(entries) + , Entry(..) + , FQN(..) + , references + ) where + +import Frelude +import Data.List.NonEmpty (NonEmpty) +import Data.Language.Ruby +import Data.Map +import qualified Data.Map as Map +import Data.Kind +import Control.Monad.State +import qualified Data.Aeson as Aeson + +data Entry a = Entry + { node :: a + , fqn :: FQN + } + +newtype FQN = FQN (NonEmpty Name) + +deriving newtype instance Semigroup FQN +instance Monoid FQN where + mempty = FQN $ pure $ Name Aeson.Null + +deriving newtype instance Eq FQN +deriving newtype instance Ord FQN + +class Monad m => MyMonad (m :: Type -> Type) where + declaration :: FQN -> Name -> m () + application :: FQN -> Name -> m () + getContext :: m FQN + writeContext :: FQN -> m () + +data Env = Env + { declarations :: Map FQN [Name] + , applications :: Map FQN [Name] + , context :: FQN + } + +instance Semigroup Env where + Env a0 a1 a2 <> Env b0 b1 b2 = Env (a0 <> b0) (a1 <> b1) (a2 <> b2) + +instance Monoid Env where + mempty = Env mempty mempty mempty + +instance MyMonad (State Env) where + declaration q n = modify go + where + go env@Env{declarations} = env { declarations = Map.insertWith mappend q (pure n) declarations } + application q n = modify go + where + go env@Env{applications} = env { applications = Map.insertWith mappend q (pure n) applications } + getContext = gets context + writeContext q = modify go + where + go env = env { context = q } + +updateContext :: MyMonad m => (FQN -> FQN) -> m () +updateContext f = getContext >>= \c -> writeContext (f c) + +locally :: MyMonad m => m a -> m a +locally act = do + old <- getContext + res <- act + writeContext old + pure res + +appendToContext :: MyMonad m => Name -> m () +appendToContext n = updateContext go + where + go (FQN ns) = FQN $ pure n <> ns + +class References a where + entries :: MyMonad m => a -> m () + +references :: Block -> Env +references q = execState (entries @_ @(State Env) q) mempty + +instance References Block where + entries :: forall m . MyMonad m => Block -> m () + entries (Block defs) = traverse_ (locally . entries) defs + +instance References Definition where + entries = \case + DefModule m -> entries m + DefFunction f -> entries f + DefSend s -> entries s + +instance References Module where + entries Module{name, block} = do + appendToContext name + entries block + +instance References Function where + entries Function{name, block} = do + c <- getContext + declaration c name + entries block + +instance References Send where + entries Send{name} = do + c <- getContext + application c name