{-# LANGUAGE FlexibleInstances #-}

module HsDev.Symbols.HaskellNames (
	ToEnvironment(..),
	fromSymbol, toSymbol
	) where

import Control.Lens (view)
import Data.String
import qualified Data.Map.Strict as M
import qualified Data.Text as T (unpack)
import qualified Language.Haskell.Exts as H
import qualified Language.Haskell.Names as N

import HsDev.Symbols.Types

class ToEnvironment a where
	environment :: a -> N.Environment

instance ToEnvironment Module where
	environment :: Module -> Environment
environment Module
m = ModuleName () -> [Symbol] -> Environment
forall k a. k -> a -> Map k a
M.singleton (() -> String -> ModuleName ()
forall l. l -> String -> ModuleName l
H.ModuleName () (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Getting Text Module Text -> Module -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Module Text
forall a. Sourced a => Lens' a Text
sourcedName Module
m)) ((Symbol -> Symbol) -> [Symbol] -> [Symbol]
forall a b. (a -> b) -> [a] -> [b]
map Symbol -> Symbol
toSymbol ([Symbol] -> [Symbol]) -> [Symbol] -> [Symbol]
forall a b. (a -> b) -> a -> b
$ Getting [Symbol] Module [Symbol] -> Module -> [Symbol]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Symbol] Module [Symbol]
Lens' Module [Symbol]
moduleExports Module
m)

instance ToEnvironment [Module] where
	environment :: [Module] -> Environment
environment = [Environment] -> Environment
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions ([Environment] -> Environment)
-> ([Module] -> [Environment]) -> [Module] -> Environment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Module -> Environment) -> [Module] -> [Environment]
forall a b. (a -> b) -> [a] -> [b]
map Module -> Environment
forall a. ToEnvironment a => a -> Environment
environment

fromSymbol :: N.Symbol -> Symbol
fromSymbol :: Symbol -> Symbol
fromSymbol Symbol
s = SymbolId -> Maybe Text -> Maybe Position -> SymbolInfo -> Symbol
Symbol SymbolId
sid Maybe Text
forall a. Maybe a
Nothing Maybe Position
forall a. Maybe a
Nothing SymbolInfo
info where
	sid :: SymbolId
sid = Text -> ModuleId -> SymbolId
SymbolId (Name () -> Text
fromName_ (Name () -> Text) -> Name () -> Text
forall a b. (a -> b) -> a -> b
$ Symbol -> Name ()
N.symbolName Symbol
s) ModuleId
mid
	mid :: ModuleId
mid = case Symbol -> ModuleName ()
N.symbolModule Symbol
s of
		H.ModuleName ()
_ String
m -> Text -> ModuleLocation -> ModuleId
ModuleId (String -> Text
forall a. IsString a => String -> a
fromString String
m) ModuleLocation
NoLocation
	info :: SymbolInfo
info = case Symbol
s of
		N.Value ModuleName ()
_ Name ()
_ -> Maybe Text -> SymbolInfo
Function Maybe Text
forall a. Monoid a => a
mempty
		N.Method ModuleName ()
_ Name ()
_ Name ()
p -> Maybe Text -> Text -> SymbolInfo
Method Maybe Text
forall a. Monoid a => a
mempty (Name () -> Text
fromName_ Name ()
p)
		N.Selector ModuleName ()
_ Name ()
_ Name ()
p [Name ()]
cs -> Maybe Text -> Text -> [Text] -> SymbolInfo
Selector Maybe Text
forall a. Monoid a => a
mempty (Name () -> Text
fromName_ Name ()
p) ((Name () -> Text) -> [Name ()] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Name () -> Text
fromName_ [Name ()]
cs)
		N.Constructor ModuleName ()
_ Name ()
_ Name ()
p -> [Text] -> Text -> SymbolInfo
Constructor [Text]
forall a. Monoid a => a
mempty (Name () -> Text
fromName_ Name ()
p)
		N.Type ModuleName ()
_ Name ()
_ -> [Text] -> [Text] -> SymbolInfo
Type [Text]
forall a. Monoid a => a
mempty [Text]
forall a. Monoid a => a
mempty
		N.NewType ModuleName ()
_ Name ()
_ -> [Text] -> [Text] -> SymbolInfo
NewType [Text]
forall a. Monoid a => a
mempty [Text]
forall a. Monoid a => a
mempty
		N.Data ModuleName ()
_ Name ()
_ -> [Text] -> [Text] -> SymbolInfo
Data [Text]
forall a. Monoid a => a
mempty [Text]
forall a. Monoid a => a
mempty
		N.Class ModuleName ()
_ Name ()
_ -> [Text] -> [Text] -> SymbolInfo
Class [Text]
forall a. Monoid a => a
mempty [Text]
forall a. Monoid a => a
mempty
		N.TypeFam ModuleName ()
_ Name ()
_ Maybe (Name ())
a -> [Text] -> [Text] -> Maybe Text -> SymbolInfo
TypeFam [Text]
forall a. Monoid a => a
mempty [Text]
forall a. Monoid a => a
mempty ((Name () -> Text) -> Maybe (Name ()) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name () -> Text
fromName_ Maybe (Name ())
a)
		N.DataFam ModuleName ()
_ Name ()
_ Maybe (Name ())
a -> [Text] -> [Text] -> Maybe Text -> SymbolInfo
DataFam [Text]
forall a. Monoid a => a
mempty [Text]
forall a. Monoid a => a
mempty ((Name () -> Text) -> Maybe (Name ()) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name () -> Text
fromName_ Maybe (Name ())
a)
		N.PatternConstructor ModuleName ()
_ Name ()
_ Maybe (Name ())
p -> [Text] -> Maybe Text -> SymbolInfo
PatConstructor [Text]
forall a. Monoid a => a
mempty ((Name () -> Text) -> Maybe (Name ()) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name () -> Text
fromName_ Maybe (Name ())
p)
		N.PatternSelector ModuleName ()
_ Name ()
_ Maybe (Name ())
p Name ()
c -> Maybe Text -> Maybe Text -> Text -> SymbolInfo
PatSelector Maybe Text
forall a. Monoid a => a
mempty ((Name () -> Text) -> Maybe (Name ()) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name () -> Text
fromName_ Maybe (Name ())
p) (Name () -> Text
fromName_ Name ()
c)

toSymbol :: Symbol -> N.Symbol
toSymbol :: Symbol -> Symbol
toSymbol Symbol
s = case Getting SymbolInfo Symbol SymbolInfo -> Symbol -> SymbolInfo
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting SymbolInfo Symbol SymbolInfo
Lens' Symbol SymbolInfo
symbolInfo Symbol
s of
	Function Maybe Text
_ -> ModuleName () -> Name () -> Symbol
N.Value ModuleName ()
m Name ()
n
	Method Maybe Text
_ Text
p -> ModuleName () -> Name () -> Name () -> Symbol
N.Method ModuleName ()
m Name ()
n (Text -> Name ()
toName_ Text
p)
	Selector Maybe Text
_ Text
p [Text]
cs -> ModuleName () -> Name () -> Name () -> [Name ()] -> Symbol
N.Selector ModuleName ()
m Name ()
n (Text -> Name ()
toName_ Text
p) ((Text -> Name ()) -> [Text] -> [Name ()]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Name ()
toName_ [Text]
cs)
	Constructor [Text]
_ Text
p -> ModuleName () -> Name () -> Name () -> Symbol
N.Constructor ModuleName ()
m Name ()
n (Text -> Name ()
toName_ Text
p)
	Type [Text]
_ [Text]
_ -> ModuleName () -> Name () -> Symbol
N.Type ModuleName ()
m Name ()
n
	NewType [Text]
_ [Text]
_ -> ModuleName () -> Name () -> Symbol
N.NewType ModuleName ()
m Name ()
n
	Data [Text]
_ [Text]
_ -> ModuleName () -> Name () -> Symbol
N.Data ModuleName ()
m Name ()
n
	Class [Text]
_ [Text]
_ -> ModuleName () -> Name () -> Symbol
N.Class ModuleName ()
m Name ()
n
	TypeFam [Text]
_ [Text]
_ Maybe Text
a -> ModuleName () -> Name () -> Maybe (Name ()) -> Symbol
N.TypeFam ModuleName ()
m Name ()
n ((Text -> Name ()) -> Maybe Text -> Maybe (Name ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Name ()
toName_ Maybe Text
a)
	DataFam [Text]
_ [Text]
_ Maybe Text
a -> ModuleName () -> Name () -> Maybe (Name ()) -> Symbol
N.DataFam ModuleName ()
m Name ()
n ((Text -> Name ()) -> Maybe Text -> Maybe (Name ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Name ()
toName_ Maybe Text
a)
	PatConstructor [Text]
_ Maybe Text
p -> ModuleName () -> Name () -> Maybe (Name ()) -> Symbol
N.PatternConstructor ModuleName ()
m Name ()
n ((Text -> Name ()) -> Maybe Text -> Maybe (Name ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Name ()
toName_ Maybe Text
p)
	PatSelector Maybe Text
_ Maybe Text
p Text
c -> ModuleName () -> Name () -> Maybe (Name ()) -> Name () -> Symbol
N.PatternSelector ModuleName ()
m Name ()
n ((Text -> Name ()) -> Maybe Text -> Maybe (Name ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Name ()
toName_ Maybe Text
p) (Text -> Name ()
toName_ Text
c)
	where
		m :: ModuleName ()
m = Text -> ModuleName ()
toModuleName_ (Text -> ModuleName ()) -> Text -> ModuleName ()
forall a b. (a -> b) -> a -> b
$ Getting Text Symbol Text -> Symbol -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Symbol Text
forall a. Sourced a => Lens' a Text
sourcedModuleName Symbol
s
		n :: Name ()
n = Text -> Name ()
toName_ (Text -> Name ()) -> Text -> Name ()
forall a b. (a -> b) -> a -> b
$ Getting Text Symbol Text -> Symbol -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Symbol Text
forall a. Sourced a => Lens' a Text
sourcedName Symbol
s