content: {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE MonadComprehensions #-}
  
  module Language.Haskell.Exference.BindingsFromHaskellSrc
    ( getDecls
    , declToBinding
    , getDataConss
    , getClassMethods
    , getDataTypes
    )
  where
  
  
  
  import Language.Haskell.Exts.Syntax
  import Language.Haskell.Exts.Pretty
  import Language.Haskell.Exference.Core.FunctionBinding
  import Language.Haskell.Exference.TypeFromHaskellSrc
  import Language.Haskell.Exference.TypeDeclsFromHaskellSrc
  import Language.Haskell.Exference.Core.Types
  import Language.Haskell.Exference.Core.TypeUtils
  import Language.Haskell.Exference.FunctionDecl
  
  import Control.Applicative ( (<$>), (<*>) )
  
  import Control.Monad ( join )
  import Control.Monad.Identity
  import Control.Monad.Trans.Maybe
  import Control.Monad.Trans.Either
  import Control.Monad.State.Strict
  import qualified Data.Map as M
  import Data.List ( find )
  
  import Control.Monad.Trans.MultiRWS
  import Data.HList.ContainsType
  
  import Debug.Trace
  
  
  
  getDecls
    :: (Monad m, Functor m)
    => [QualifiedName]
    -> [HsTypeClass]
    -> TypeDeclMap
    -> [Module]
    -> MultiRWST r w s m [Either String HsFunctionDecl]
  getDecls ds tcs tDeclMap modules = fmap (>>= either (return.Left) (map Right))
                                  $ sequence
                                  $ do
    Module _loc mn _pragma _warning _mexp _imp decls <- modules
    d <- decls
    return $ runEitherT $ transformDecl tcs ds mn tDeclMap d
  
  transformDecl
    :: (Monad m, Functor m)
    => [HsTypeClass]
    -> [QualifiedName]
    -> ModuleName
    -> TypeDeclMap
    -> Decl
    -> EitherT String (MultiRWST r w s m) [HsFunctionDecl]
  transformDecl tcs ds mn tDeclMap (TypeSig _loc names qtype)
    = insName qtype $ do
        (ctype, _) <- convertType tcs (Just mn) ds tDeclMap qtype
        return $ helper mn ctype <$> names
  transformDecl _ _ _ _ _ = return []
  
  transformDecl'
    :: (MonadMultiState ConvData m, Monad m, Functor m)
    => [HsTypeClass]
    -> [QualifiedName]
    -> ModuleName
    -> TypeDeclMap
    -> Decl
    -> EitherT String m [HsFunctionDecl]
  transformDecl' tcs ds mn tDeclMap (TypeSig _loc names qtype)
    = insName qtype $ do
        ctype <- convertTypeInternal tcs (Just mn) ds tDeclMap qtype
        return $ helper mn ctype <$> names
  transformDecl' _ _ _ _ _ = return []
  
  insName :: (Functor m, Monad m)
          => Type -> EitherT String m a -> EitherT String m a
  insName qtype = bimapEitherT (\x -> x ++ " in " ++ prettyPrint qtype) id
  
  helper :: ModuleName -> HsType -> Name -> HsFunctionDecl
  helper mn t x = (convertModuleName mn x, forallify t)
  
  getDataConss
    :: (Monad m)
    => [HsTypeClass]
    -> [QualifiedName]
    -> TypeDeclMap
    -> [Module]
    -> MultiRWST
         r
         w
         s
         m
         [Either String ([HsFunctionDecl], DeconstructorBinding)]
  getDataConss tcs ds tDeclMap modules = sequence $ do
    Module _loc moduleName _pragma _warning _mexp _imp decls <- modules
    DataDecl _loc _newtflag cntxt name params conss _derives <- decls
    let
      rTypeM :: ( MonadMultiState ConvData m )
             => EitherT String m HsType
      rTypeM = do
        let rName = convertModuleName moduleName name
        ps  <- mapM pTransform params
        return $ (forallify . foldl TypeApp (TypeCons rName)) ps
      pTransform :: MonadMultiState ConvData m => TyVarBind -> EitherT String m HsType
      pTransform (KindedVar _ _) = left "KindedVar"
      pTransform (UnkindedVar n) = TypeVar <$> getVar n
    --let
    --  tTransform (UnBangedTy t) = convertTypeInternal t
    --  tTransform x              = lift $ left $ "unknown Type: " ++ show x
    let
      typeM :: ( MonadMultiState ConvData m )
            => QualConDecl
            -> EitherT String m (QualifiedName, [HsType])
      typeM (QualConDecl _loc cbindings ccntxt conDecl) = do
        case cntxt of
          [] -> right ()
          _  -> left "context in data type"
        case (cbindings, ccntxt) of
          ([],[]) -> right ()
          _       -> left "constraint or existential type for constructor"
        (cname,tys) <- case conDecl of
          ConDecl c t -> right (c, t)
          x           -> left $ "unknown ConDecl: " ++ show x
        convTs <- convertTypeInternal tcs (Just moduleName) ds tDeclMap `mapM` tys
        let qName = convertModuleName moduleName cname
        return $ (qName, convTs)
    let
      addConsMsg = (++) $ show name ++ ": "
    let
      convAction :: ( MonadMultiState ConvData m )
                 => EitherT String m ([HsFunctionDecl], DeconstructorBinding)
      convAction = do
        rtype  <- rTypeM
        consDatas <- mapM typeM conss
        return $ ( [ (n, foldr TypeArrow rtype ts)
                   | (n, ts) <- consDatas
                   ]
                 , (rtype, consDatas, False)
                 )
          -- TODO: actually determine if stuff is recursive or not
    return $ do
      convResult <- withMultiStateA (ConvData 0 M.empty) $ runEitherT convAction
      return $ either (Left . addConsMsg) Right convResult
      -- TODO: replace this by bimap..
  
  getClassMethods
    :: (Monad m, Functor m)
    => [HsTypeClass]
    -> [QualifiedName]
    -> TypeDeclMap
    -> [Module]
    -> MultiRWST r w s m [Either String HsFunctionDecl]
  getClassMethods tcs ds tDeclMap modules = fmap join $ sequence $ do
    Module _loc moduleName _pragma _warning _mexp _imp decls <- modules
    ClassDecl _ _ name@(Ident nameStr) vars _ cdecls <- decls
    return $ do
      let errorMod = (++) ("class method for "++show name++": ")
      let tcsTuples = (\tc -> (tclass_name tc, tc)) <$> tcs
      let searchF (QualifiedName _ n) = n==nameStr
          searchF _                   = False
      let maybeClass = snd <$> find (searchF . fst) tcsTuples
      case maybeClass of
        Nothing -> return [Left $ "unknown type class: "++show name]
        Just cls -> do
          let cnstrA = HsConstraint cls <$> mapM ((TypeVar <$>) . tyVarTransform) vars
          --     action :: ( MonadMultiState ConvData m ) => m [Either String [HsFunctionDecl]]
          rEithers <- withMultiStateA (ConvData 0 M.empty) $ do
            cnstrE <- runEitherT cnstrA
            case cnstrE of
              Left x -> return [Left x]
              Right cnstr ->
                mapM ( runEitherT
                     . fmap (map (addConstraint cnstr))
                     . transformDecl' tcs ds moduleName tDeclMap)
                  $ [ d | ClsDecl d <- cdecls ]
          let _ = rEithers :: [Either String [HsFunctionDecl]]
          return $ concatMap (either (return . Left . errorMod) (map Right))
                 $ rEithers
    where
      addConstraint :: HsConstraint -> HsFunctionDecl -> HsFunctionDecl
      addConstraint c (n, TypeForall vs cs t) = (n, TypeForall vs (c:cs) t)
      addConstraint _ _                       = error "addConstraint for non-forall type = bad"
        --(n, ForallType [] [c] t)
  
  getDataTypes :: [Module] -> [QualifiedName]
  getDataTypes modules = d1 ++ d2
   where
    d1 = do
      Module _loc moduleName _pragma _warning _mexp _imp decls <- modules
      DataDecl _ _ _ name _ _ _ <- decls
      return $ convertModuleName moduleName name
    d2 = do
      Module _loc moduleName _pragma _warning _mexp _imp decls <- modules
      TypeDecl _ name _ _ <- decls
      return $ convertModuleName moduleName name
  