2019-10-11 09:08:36 +00:00
|
|
|
{-# LANGUAGE DuplicateRecordFields, OverloadedLists, InstanceSigs #-}
|
2019-10-03 14:13:34 +00:00
|
|
|
{-# OPTIONS_GHC -Wall #-}
|
|
|
|
module Rubyhs.References
|
|
|
|
( References(entries)
|
|
|
|
, Entry(..)
|
|
|
|
, FQN(..)
|
|
|
|
, references
|
2019-10-11 09:08:36 +00:00
|
|
|
, Env(..)
|
2019-10-11 09:37:11 +00:00
|
|
|
, Result(..)
|
2019-10-11 12:03:01 +00:00
|
|
|
, Namespace(..)
|
2019-10-03 14:13:34 +00:00
|
|
|
) where
|
|
|
|
|
|
|
|
import Frelude
|
2019-10-11 12:03:01 +00:00
|
|
|
import Data.Language.Ruby hiding (Namespace)
|
|
|
|
import qualified Data.Language.Ruby as Ruby
|
2019-10-11 09:08:36 +00:00
|
|
|
import Data.Map (Map)
|
2019-10-03 14:13:34 +00:00
|
|
|
import qualified Data.Map as Map
|
|
|
|
import Data.Kind
|
|
|
|
import Control.Monad.State
|
2019-10-11 09:37:11 +00:00
|
|
|
import Data.Aeson ((.=))
|
2019-10-03 14:13:34 +00:00
|
|
|
import qualified Data.Aeson as Aeson
|
2019-10-11 09:08:36 +00:00
|
|
|
import Data.List
|
2019-10-11 09:37:11 +00:00
|
|
|
import Data.HashMap.Strict (HashMap)
|
|
|
|
import Data.Text.Prettyprint.Doc.Render.Text (renderStrict)
|
|
|
|
import Data.Text.Prettyprint.Doc (layoutCompact)
|
2019-10-11 12:03:01 +00:00
|
|
|
import Data.Set (Set)
|
|
|
|
import qualified Data.Set as Set
|
2019-10-03 14:13:34 +00:00
|
|
|
|
|
|
|
data Entry a = Entry
|
|
|
|
{ node :: a
|
|
|
|
, fqn :: FQN
|
|
|
|
}
|
|
|
|
|
2019-10-11 12:03:01 +00:00
|
|
|
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
|
|
|
|
|
2019-10-11 09:37:11 +00:00
|
|
|
-- Names are in reverse order.
|
2019-10-11 12:03:01 +00:00
|
|
|
data FQN = FQN
|
|
|
|
{ namespace :: Namespace
|
|
|
|
, name :: Text
|
|
|
|
}
|
2019-10-03 14:13:34 +00:00
|
|
|
|
2019-10-11 09:08:36 +00:00
|
|
|
deriving stock instance Show FQN
|
2019-10-11 12:03:01 +00:00
|
|
|
deriving stock instance Eq FQN
|
|
|
|
deriving stock instance Ord FQN
|
|
|
|
instance Pretty Namespace where
|
|
|
|
pretty = pretty . prettyNamespace
|
|
|
|
|
|
|
|
instance Aeson.ToJSON FQN where
|
|
|
|
toJSON = Aeson.String . prettyFQN
|
2019-10-11 09:08:36 +00:00
|
|
|
instance Aeson.ToJSONKey FQN where
|
|
|
|
instance Pretty FQN where
|
2019-10-11 12:03:01 +00:00
|
|
|
pretty = pretty . prettyFQN
|
|
|
|
|
|
|
|
prettyFQN :: FQN -> Text
|
|
|
|
prettyFQN FQN{namespace, name} = case namespace of
|
|
|
|
[] -> name
|
|
|
|
_ -> prettyNamespace namespace <> "." <> name
|
2019-10-03 14:13:34 +00:00
|
|
|
|
2019-10-11 12:03:01 +00:00
|
|
|
prettyNamespace :: Namespace -> Text
|
|
|
|
prettyNamespace = convertString . intercalate "::" . fmap convertString . reverse . toList
|
2019-10-03 14:13:34 +00:00
|
|
|
|
|
|
|
class Monad m => MyMonad (m :: Type -> Type) where
|
2019-10-11 12:03:01 +00:00
|
|
|
declaration :: FQN -> m ()
|
|
|
|
application :: Namespace -> FQN -> m ()
|
|
|
|
getContext :: m Namespace
|
|
|
|
writeContext :: Namespace -> m ()
|
2019-10-03 14:13:34 +00:00
|
|
|
|
|
|
|
data Env = Env
|
2019-10-11 12:03:01 +00:00
|
|
|
{ declarations :: Set FQN
|
|
|
|
, applications :: Map Namespace (Set FQN)
|
|
|
|
, context :: Namespace
|
2019-10-03 14:13:34 +00:00
|
|
|
}
|
|
|
|
|
2019-10-11 09:37:11 +00:00
|
|
|
data Result = Result
|
2019-10-11 12:03:01 +00:00
|
|
|
{ declarations :: Set FQN
|
|
|
|
, applications :: Map Namespace (Set FQN)
|
2019-10-11 09:37:11 +00:00
|
|
|
}
|
|
|
|
instance ToJSON Result where
|
|
|
|
toJSON Result{declarations,applications} = Aeson.object
|
2019-10-11 12:03:01 +00:00
|
|
|
[ "declarations" .= declarations
|
2019-10-11 09:37:11 +00:00
|
|
|
, "applications" .= f applications
|
|
|
|
]
|
|
|
|
where
|
2019-10-11 12:03:01 +00:00
|
|
|
f x = fromList @(HashMap _ _) $ go <$> toList x
|
2019-10-11 09:37:11 +00:00
|
|
|
go (x, y) = (renderStrict $ layoutCompact $ pretty x, y)
|
|
|
|
|
2019-10-03 14:13:34 +00:00
|
|
|
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
|
2019-10-11 12:03:01 +00:00
|
|
|
declaration q = modify go
|
2019-10-03 14:13:34 +00:00
|
|
|
where
|
2019-10-11 09:37:11 +00:00
|
|
|
go :: Env -> Env
|
2019-10-11 12:03:01 +00:00
|
|
|
go env@Env{declarations} = env { declarations = Set.insert q declarations }
|
2019-10-03 14:13:34 +00:00
|
|
|
application q n = modify go
|
|
|
|
where
|
2019-10-11 09:37:11 +00:00
|
|
|
go :: Env -> Env
|
2019-10-11 12:03:01 +00:00
|
|
|
go env@Env{applications} = env { applications = Map.insertWith mappend q (Set.singleton n) applications }
|
2019-10-03 14:13:34 +00:00
|
|
|
getContext = gets context
|
|
|
|
writeContext q = modify go
|
|
|
|
where
|
|
|
|
go env = env { context = q }
|
|
|
|
|
2019-10-11 12:03:01 +00:00
|
|
|
updateContext :: MyMonad m => (Namespace -> Namespace) -> m ()
|
2019-10-03 14:13:34 +00:00
|
|
|
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
|
2019-10-11 12:03:01 +00:00
|
|
|
go q = name2ns n <> q
|
|
|
|
|
|
|
|
name2ns :: Name -> Namespace
|
2019-10-11 14:26:15 +00:00
|
|
|
name2ns (Name o) = go o
|
|
|
|
where
|
|
|
|
go :: Aeson.Value -> Namespace
|
|
|
|
go = \case
|
|
|
|
Aeson.Array [Aeson.String "const", x, Aeson.String s] -> case x of
|
|
|
|
Aeson.Null -> [s]
|
|
|
|
_ -> go x <> [s]
|
|
|
|
_ -> error $ show o
|
2019-10-03 14:13:34 +00:00
|
|
|
|
|
|
|
class References a where
|
|
|
|
entries :: MyMonad m => a -> m ()
|
|
|
|
|
2019-10-11 09:37:11 +00:00
|
|
|
references :: Block -> Result
|
|
|
|
references q = Result{declarations, applications}
|
|
|
|
where
|
|
|
|
Env{declarations,applications} = execState (entries @_ @(State Env) q) mempty
|
2019-10-03 14:13:34 +00:00
|
|
|
|
|
|
|
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
|
2019-10-11 12:03:01 +00:00
|
|
|
namespace <- getContext
|
|
|
|
declaration $ qual namespace name
|
2019-10-03 14:13:34 +00:00
|
|
|
entries block
|
|
|
|
|
2019-10-11 12:03:01 +00:00
|
|
|
qual :: Namespace -> Name -> FQN
|
|
|
|
qual namespace (Name o) = case o of
|
|
|
|
Aeson.String name -> FQN { namespace , name }
|
|
|
|
_ -> error $ show o
|
|
|
|
|
2019-10-03 14:13:34 +00:00
|
|
|
instance References Send where
|
2019-10-11 12:03:01 +00:00
|
|
|
entries Send{namespace, name} = do
|
2019-10-03 14:13:34 +00:00
|
|
|
c <- getContext
|
2019-10-11 12:03:01 +00:00
|
|
|
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
|