{-# 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 m = M.singleton (H.ModuleName () (T.unpack $ view sourcedName m)) (map toSymbol $ view moduleExports m)

instance ToEnvironment [Module] where
        environment = M.unions . map environment

fromSymbol :: N.Symbol -> Symbol
fromSymbol s = Symbol sid Nothing Nothing info where
        sid = SymbolId (fromName_ $ N.symbolName s) mid
        mid = case N.symbolModule s of
                H.ModuleName _ m -> ModuleId (fromString m) NoLocation
        info = case s of
                N.Value _ _ -> Function mempty
                N.Method _ _ p -> Method mempty (fromName_ p)
                N.Selector _ _ p cs -> Selector mempty (fromName_ p) (map fromName_ cs)
                N.Constructor _ _ p -> Constructor mempty (fromName_ p)
                N.Type _ _ -> Type mempty mempty
                N.NewType _ _ -> NewType mempty mempty
                N.Data _ _ -> Data mempty mempty
                N.Class _ _ -> Class mempty mempty
                N.TypeFam _ _ a -> TypeFam mempty mempty (fmap fromName_ a)
                N.DataFam _ _ a -> DataFam mempty mempty (fmap fromName_ a)
                N.PatternConstructor _ _ p -> PatConstructor mempty (fmap fromName_ p)
                N.PatternSelector _ _ p c -> PatSelector mempty (fmap fromName_ p) (fromName_ c)

toSymbol :: Symbol -> N.Symbol
toSymbol s = case view symbolInfo s of
        Function _ -> N.Value m n
        Method _ p -> N.Method m n (toName_ p)
        Selector _ p cs -> N.Selector m n (toName_ p) (map toName_ cs)
        Constructor _ p -> N.Constructor m n (toName_ p)
        Type _ _ -> N.Type m n
        NewType _ _ -> N.NewType m n
        Data _ _ -> N.Data m n
        Class _ _ -> N.Class m n
        TypeFam _ _ a -> N.TypeFam m n (fmap toName_ a)
        DataFam _ _ a -> N.DataFam m n (fmap toName_ a)
        PatConstructor _ p -> N.PatternConstructor m n (fmap toName_ p)
        PatSelector _ p c -> N.PatternSelector m n (fmap toName_ p) (toName_ c)
        where
                m = toModuleName_ $ view sourcedModuleName s
                n = toName_ $ view sourcedName s