References

This commit is contained in:
Frederik Hanghøj Iversen 2019-10-03 16:13:34 +02:00
parent e72e08c3c2
commit be9e51c14d
3 changed files with 126 additions and 0 deletions

View file

@ -27,6 +27,8 @@ dependencies:
- vector
- bytestring
- frelude
- containers
- mtl
default-extensions:
- ConstraintKinds

View file

@ -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
View 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