147 lines
3.8 KiB
Haskell
147 lines
3.8 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields, OverloadedLists, InstanceSigs #-}
|
|
{-# OPTIONS_GHC -Wall #-}
|
|
module Rubyhs.References
|
|
( References(entries)
|
|
, Entry(..)
|
|
, FQN(..)
|
|
, references
|
|
, Env(..)
|
|
, Result(..)
|
|
) where
|
|
|
|
import Frelude
|
|
import Data.Language.Ruby
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
import Data.Kind
|
|
import Control.Monad.State
|
|
import Data.Aeson ((.=))
|
|
import qualified Data.Aeson as Aeson
|
|
import Data.List
|
|
import Data.HashMap.Strict (HashMap)
|
|
import Data.Text.Prettyprint.Doc.Render.Text (renderStrict)
|
|
import Data.Text.Prettyprint.Doc (layoutCompact)
|
|
|
|
data Entry a = Entry
|
|
{ node :: a
|
|
, fqn :: FQN
|
|
}
|
|
|
|
-- Names are in reverse order.
|
|
newtype FQN = FQN ([] Name)
|
|
|
|
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 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
|
|
}
|
|
|
|
data Result = Result
|
|
{ declarations :: Map FQN [Name]
|
|
, applications :: Map FQN [Name]
|
|
}
|
|
instance ToJSON Result where
|
|
toJSON Result{declarations,applications} = Aeson.object
|
|
[ "declarations" .= f declarations
|
|
, "applications" .= f applications
|
|
]
|
|
where
|
|
f :: Map FQN [Name] -> HashMap Text [Name]
|
|
f x = fromList $ go <$> toList x
|
|
go (x, y) = (renderStrict $ layoutCompact $ pretty x, y)
|
|
|
|
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
|
|
go env@Env{declarations} = env { declarations = Map.insertWith mappend q (pure n) declarations }
|
|
application q n = modify go
|
|
where
|
|
go :: Env -> Env
|
|
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 -> Result
|
|
references q = Result{declarations, applications}
|
|
where
|
|
Env{declarations,applications} = 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
|