References
This commit is contained in:
parent
e72e08c3c2
commit
be9e51c14d
|
@ -27,6 +27,8 @@ dependencies:
|
|||
- vector
|
||||
- bytestring
|
||||
- frelude
|
||||
- containers
|
||||
- mtl
|
||||
|
||||
default-extensions:
|
||||
- ConstraintKinds
|
||||
|
|
|
@ -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
|
||||
|
|
108
src/Rubyhs/References.hs
Normal file
108
src/Rubyhs/References.hs
Normal file
|
@ -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
|
Loading…
Reference in a new issue