{-# OPTIONS -fno-warn-name-shadowing #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoMonoLocalBinds  #-}
{-# LANGUAGE TypeFamilies      #-}
module Language.Haskell.Names.Exports
  ( processExports
  ) where

import           Fay.Compiler.Prelude

import           Fay.Compiler.ModuleT
import           Language.Haskell.Names.GlobalSymbolTable as Global
import           Language.Haskell.Names.ModuleSymbols
import           Language.Haskell.Names.ScopeUtils
import           Language.Haskell.Names.SyntaxUtils
import           Language.Haskell.Names.Types             (Error (..), GName (..), ModuleNameS, NameInfo (..),
                                                           Scoped (..), Symbols (..), mkTy, mkVal, st_origName)

import           Control.Monad.Writer                     (WriterT (WriterT), runWriterT)
import qualified Data.Map                                 as Map
import qualified Data.Set                                 as Set
import           Language.Haskell.Exts

processExports
  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, Eq l)
  => Global.Table
  -> Module l
  -> m (Maybe (ExportSpecList (Scoped l)), Symbols)
processExports tbl m =
  case getExportSpecList m of
    Nothing ->
      return (Nothing, moduleSymbols tbl m)
    Just exp ->
      liftM (first Just) $ resolveExportSpecList tbl exp

resolveExportSpecList
  :: (MonadModule m, ModuleInfo m ~ Symbols)
  => Global.Table
  -> ExportSpecList l
  -> m (ExportSpecList (Scoped l), Symbols)
resolveExportSpecList tbl (ExportSpecList l specs) =
  liftM (first $ ExportSpecList $ none l) $
  runWriterT $
  mapM (WriterT . resolveExportSpec tbl) specs

resolveExportSpec
  :: (MonadModule m, ModuleInfo m ~ Symbols)
  => Global.Table
  -> ExportSpec l
  -> m (ExportSpec (Scoped l), Symbols)
resolveExportSpec tbl exp =
  case exp of
    EVar l qn -> return $
      case Global.lookupValue qn tbl of
        Global.Error err ->
          (scopeError err exp, mempty)
        Global.Result i ->
          let s = mkVal i
          in
            (EVar (Scoped (Export s) l)
              (Scoped (GlobalValue i) <$> qn), s)
        Global.Special {} -> error "Global.Special in export list?"
    EAbs l ns qn -> return $
      case Global.lookupType qn tbl of
        Global.Error err ->
          (scopeError err exp, mempty)
        Global.Result i ->
          let s = mkTy i
          in
            (EAbs (Scoped (Export s) l) (noScope ns)
              (Scoped (GlobalType i) <$> qn), s)
        Global.Special {} -> error "Global.Special in export list?"
    EThingWith l (EWildcard wcl wcn) qn [] -> return $
      case Global.lookupType qn tbl of
        Global.Error err ->
          (scopeError err exp, mempty)
        Global.Result i ->
          let
            subs = mconcat
              [ mkVal info
              | info <- allValueInfos
              , Just n' <- return $ sv_parent info
              , n' == st_origName i ]
            s = mkTy i <> subs
          in
            ( EThingWith (Scoped (Export s) l)
                         (EWildcard (Scoped (Export s) wcl) wcn)
                         (Scoped (GlobalType i) <$> qn)
                         []
            , s
            )
        Global.Special {} -> error "Global.Special in export list?"
    EThingWith _ (EWildcard _ _) _qn _cns -> error "Name resolution: CNames are not supported in wildcard exports"
    EThingWith l (NoWildcard wcl) qn cns -> return $
      case Global.lookupType qn tbl of
        Global.Error err ->
          (scopeError err exp, mempty)
        Global.Result i ->
          let
            (cns', subs) =
              resolveCNames
                (Global.toSymbols tbl)
                (st_origName i)
                (\cn -> ENotInScope (UnQual (ann cn) (unCName cn))) -- FIXME better error
                cns
            s = mkTy i <> subs
          in
            ( EThingWith (Scoped (Export s) l)
                         (NoWildcard (Scoped (Export s) wcl))
                         (Scoped (GlobalType i) <$> qn)
                         cns'
            , s
            )
        Global.Special {} -> error "Global.Special in export list?"
    EModuleContents _ (ModuleName _ mod) ->
      -- FIXME ambiguity check
      let
        filterByPrefix
          :: Ord i
          => ModuleNameS
          -> Map.Map GName (Set.Set i)
          -> Set.Set i
        filterByPrefix prefix m =
          Set.unions
            [ i | (GName { gModule = prefix' }, i) <- Map.toList m, prefix' == prefix ]

        filterEntities
          :: Ord i
          => Map.Map GName (Set.Set i)
          -> Set.Set i
        filterEntities ents =
          Set.intersection
            (filterByPrefix mod ents)
            (filterByPrefix ""  ents)

        eVals = filterEntities $ Global.values tbl
        eTyps = filterEntities $ Global.types tbl

        s = Symbols eVals eTyps
      in
        return (Scoped (Export s) <$> exp, s)
  where
    allValueInfos =
      Set.toList $ Map.foldl' Set.union Set.empty $ Global.values tbl