Various fixes

This commit is contained in:
Frederik Hanghøj Iversen 2019-10-20 22:43:48 +02:00
parent f84f91327c
commit 0c1e79f1fc

View file

@ -42,6 +42,8 @@ graph b = span $ Graph.graphFromEdges $ go <$> toList ys
go (x, xs) = (x, prettyContext x, prettyContext <$> toList xs) go (x, xs) = (x, prettyContext x, prettyContext <$> toList xs)
Result ys = references b Result ys = references b
-- The elements appear in reverse order. I expect this to cause all
-- sorts of issues.
newtype Namespace = Namespace [Text] newtype Namespace = Namespace [Text]
deriving stock instance Show Namespace deriving stock instance Show Namespace
deriving stock instance Eq Namespace deriving stock instance Eq Namespace
@ -53,13 +55,11 @@ instance IsList Namespace where
deriving newtype instance Semigroup Namespace deriving newtype instance Semigroup Namespace
deriving newtype instance Monoid Namespace deriving newtype instance Monoid Namespace
instance FromJSON Namespace where instance FromJSON Namespace where
parseJSON = Aeson.withText "Namespace" $ \t -> Namespace <$> (traverse pure $ Text.splitOn "::" t) parseJSON = Aeson.withText "Namespace"
$ \t -> Namespace <$> (traverse pure $ reverse $ Text.splitOn "::" t)
instance ToJSON Namespace where instance ToJSON Namespace where
toJSON = Aeson.String . showNamespace toJSON = Aeson.String . showNamespace
showNamespace :: Namespace -> Text
showNamespace = Text.intercalate "::" . coerce
-- Names are in reverse order. -- Names are in reverse order.
data FQN = FQN data FQN = FQN
{ namespace :: Namespace { namespace :: Namespace
@ -79,6 +79,8 @@ instance FromJSON Node where
nodeParser :: Text -> Aeson.Parser Node nodeParser :: Text -> Aeson.Parser Node
nodeParser = \t -> case Text.splitOn "." t of nodeParser = \t -> case Text.splitOn "." t of
[mods,fun] -> fmap NodeDef (FQN <$> Aeson.parseJSON (Aeson.String mods) <*> pure fun) [mods,fun] -> fmap NodeDef (FQN <$> Aeson.parseJSON (Aeson.String mods) <*> pure fun)
-- The top-level
[[]] -> pure $ NodeModule mempty
[mods] -> [mods] ->
if beginsWithCapital mods if beginsWithCapital mods
then NodeModule <$> Aeson.parseJSON (Aeson.String mods) then NodeModule <$> Aeson.parseJSON (Aeson.String mods)
@ -112,6 +114,14 @@ prettyFQN FQN{name, namespace} = case namespace of
[] -> name [] -> name
_ -> convertString (showNamespace namespace) <> "." <> name _ -> convertString (showNamespace namespace) <> "." <> name
prettyContext :: Node -> Text
prettyContext = \case
NodeDef fun -> prettyFQN fun
NodeModule ns -> showNamespace ns
showNamespace :: Namespace -> Text
showNamespace = Text.intercalate "::" . reverse . coerce
newtype Context = Context Node newtype Context = Context Node
deriving stock instance Eq Context deriving stock instance Eq Context
@ -119,9 +129,12 @@ deriving stock instance Ord Context
deriving newtype instance ToJSON Context deriving newtype instance ToJSON Context
-- HACK: Not really a semigroup as is evident from the implementation. -- HACK: Not really a semigroup as is evident from the implementation.
instance Semigroup Context where instance Semigroup Context where
Context c0 <> Context c1 = case (c0, c1) of -- I think that the order must be swapped because they modules are in reverse order.
(NodeModule n0, NodeModule n1) -> Context $ NodeModule $ n0 <> n1 Context c0 <> Context c1 = case traceShowId (c0, c1) of
(NodeModule n0, NodeDef (FQN n1 f)) -> Context $ NodeDef $ FQN (n0 <> n1) f -- (NodeModule n0, NodeModule n1) -> Context $ NodeModule $ n0 <> n1
(NodeModule n0, NodeModule n1) -> Context $ NodeModule $ n1 <> n0
-- (NodeModule n0, NodeDef (FQN n1 f)) -> Context $ NodeDef $ FQN (n0 <> n1) f
(NodeModule n0, NodeDef (FQN n1 f)) -> Context $ NodeDef $ FQN (n1 <> n0) f
(NodeDef{}, NodeModule{}) -> error "Cannot append module to function context." (NodeDef{}, NodeModule{}) -> error "Cannot append module to function context."
(NodeDef{}, NodeDef{}) -> error "Cannot append function to function context." (NodeDef{}, NodeDef{}) -> error "Cannot append function to function context."
@ -145,11 +158,6 @@ instance ToJSON Result where
where where
go :: (Node, Set Node) -> (Text, Aeson.Value) go :: (Node, Set Node) -> (Text, Aeson.Value)
go (x, y) = (prettyContext x, Aeson.toJSON y) go (x, y) = (prettyContext x, Aeson.toJSON y)
prettyContext :: Node -> Text
prettyContext = \case
NodeDef fun -> prettyFQN fun
NodeModule ns -> showNamespace ns
instance MyMonad (State Env) where instance MyMonad (State Env) where
declaration q = modify go declaration q = modify go
@ -290,8 +298,8 @@ instance References Ruby.Def where
instance References Ruby.Defs where instance References Ruby.Defs where
-- TODO: The field `context` is also relevant here! -- TODO: The field `context` is also relevant here!
entries Ruby.Defs{atom, begin} entries Ruby.Defs{atom, begin, args}
= entries $ Ruby.Def{atom,begin,args=error "hack"} = entries $ Ruby.Def{atom,begin,args}
qual :: Namespace -> Ruby.Atom -> FQN qual :: Namespace -> Ruby.Atom -> FQN
qual namespace (Ruby.Atom name) = FQN { namespace , name } qual namespace (Ruby.Atom name) = FQN { namespace , name }