References always use FQNs

This commit is contained in:
Frederik Hanghøj Iversen 2019-10-15 21:50:19 +02:00
parent 00f0e154c4
commit 5b78c6c363
1 changed files with 32 additions and 12 deletions

View File

@ -20,7 +20,6 @@ import Data.Kind
import Control.Monad.State import Control.Monad.State
import Data.Aeson ((.=)) import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.List
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
@ -38,12 +37,15 @@ deriving stock instance Eq Namespace
deriving stock instance Ord Namespace deriving stock instance Ord Namespace
instance IsList Namespace where instance IsList Namespace where
type Item Namespace = Text type Item Namespace = Text
fromList = Namespace . fromList fromList = coerce
toList (Namespace l) = toList l toList = coerce
deriving newtype instance Semigroup Namespace deriving newtype instance Semigroup Namespace
deriving newtype instance Monoid Namespace deriving newtype instance Monoid Namespace
instance ToJSON Namespace where instance ToJSON Namespace where
toJSON = Aeson.String . Text.intercalate "::" . coerce 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
@ -66,7 +68,7 @@ deriving stock instance Show FQN
deriving stock instance Eq FQN deriving stock instance Eq FQN
deriving stock instance Ord FQN deriving stock instance Ord FQN
instance Pretty Namespace where instance Pretty Namespace where
pretty = pretty . prettyNamespace pretty = pretty . showNamespace
instance Aeson.ToJSON FQN where instance Aeson.ToJSON FQN where
toJSON = Aeson.String . prettyFQN toJSON = Aeson.String . prettyFQN
@ -77,10 +79,7 @@ instance Pretty FQN where
prettyFQN :: FQN -> Text prettyFQN :: FQN -> Text
prettyFQN FQN{name, namespace} = case namespace of prettyFQN FQN{name, namespace} = case namespace of
[] -> name [] -> name
_ -> prettyNamespace namespace <> "." <> name _ -> convertString (showNamespace namespace) <> "." <> name
prettyNamespace :: Namespace -> Text
prettyNamespace = convertString . intercalate "::" . fmap convertString . reverse . toList
newtype Context = Context Node newtype Context = Context Node
@ -119,7 +118,7 @@ instance ToJSON Result where
prettyContext :: Node -> Text prettyContext :: Node -> Text
prettyContext = \case prettyContext = \case
NodeFunction fun -> prettyFQN fun NodeFunction fun -> prettyFQN fun
NodeModule ns -> prettyNamespace ns NodeModule ns -> showNamespace ns
instance MyMonad (State Env) where instance MyMonad (State Env) where
declaration q = modify go declaration q = modify go
@ -188,7 +187,13 @@ instance References Ruby.Namespace where
entries = \case entries = \case
Ruby.Namespace xs -> do Ruby.Namespace xs -> do
Context c <- getContext Context c <- getContext
application c (NodeModule (Namespace ((\(Name (Aeson.String t)) -> t) <$> xs))) let
ctxt = case c of
NodeFunction FQN{namespace} -> namespace
NodeModule namespace -> namespace
-- TODO Hacky:
ns = Namespace ((\(Name (Aeson.String t)) -> t) <$> xs)
application c (NodeModule $ ctxt `onTop` ns)
instance References Module where instance References Module where
entries Module{name, block} = do entries Module{name, block} = do
@ -214,10 +219,25 @@ qual namespace (Name o) = case o of
Aeson.String name -> FQN { namespace , name } Aeson.String name -> FQN { namespace , name }
_ -> error $ show o _ -> error $ show o
onTop' :: Eq a => [a] -> [a] -> [a]
onTop' [] y = y
onTop' x [] = x
onTop' (x:xss) ys@(y:yss) = if
| x == y -> pure x <> yss
| otherwise -> pure x <> xss `onTop'` ys
onTop :: Namespace -> Namespace -> Namespace
onTop (Namespace xs) (Namespace ys) = Namespace $ reverse $ reverse xs `onTop'` reverse ys
instance References Send where instance References Send where
entries Send{namespace, name} = do entries Send{namespace, name} = do
Context c <- getContext Context c <- getContext
application c $ NodeFunction $ qual (fromNS namespace) name let
ctxt = case c of
NodeFunction FQN{namespace = ns} -> ns
NodeModule ns -> ns
application c $ NodeFunction $ qual (ctxt `onTop` fromNS namespace) name
where where
fromNS :: Ruby.Namespace -> Namespace fromNS :: Ruby.Namespace -> Namespace
fromNS (Ruby.Namespace l) = Namespace $ go <$> l fromNS (Ruby.Namespace l) = Namespace $ go <$> l