{-------------------------------------------------------------------------------

        Copyright:              The Hatchet Team (see file Contributors)

        Module:                 DataConsAssump

        Description:            Computes the type assumptions of data
                                constructors in a module

                                For example:
                                        MyCons :: a -> MyList a
                                        Just :: a -> Maybe a
                                        True :: Bool

                                Note Well:

                                from section 4.2 of the Haskell Report:

                                "These declarations may only appear at the
                                 top level of a module."

        Primary Authors:        Bernie Pope

        Notes:                  See the file License for license information

-------------------------------------------------------------------------------}

module FrontEnd.DataConsAssump (dataConsEnv) where

import Control.Monad.Identity
import qualified Data.Map as Map

import FrontEnd.HsSyn
import FrontEnd.KindInfer
import FrontEnd.Tc.Type
import Name.Name
import Support.FreeVars

{-# NOINLINE dataConsEnv #-}
dataConsEnv :: KindEnv -> [HsDecl] -> Map.Map Name Sigma
dataConsEnv kt decls
   = Map.unions $ map (dataDeclEnv (error "dataConsenvModName") kt) decls

-- we should only apply this function to data decls and newtype decls
-- howver the fall through case is just there for completeness

dataDeclEnv :: Module -> KindEnv -> (HsDecl) -> Map.Map Name Sigma
dataDeclEnv modName kt HsDataDecl { hsDeclContext = context, hsDeclName = typeName, hsDeclArgs = args, hsDeclCons = condecls }
   = Map.unions $ map (conDeclType modName kt preds resultType) $ condecls
   where
   typeName' = toName TypeConstructor typeName
   typeKind = kindOf typeName' kt
   resultType = foldl tAp tycon argVars
   tycon = TCon (Tycon typeName' typeKind)
   argVars = map fromHsNameToTyVar $ zip argKinds args
   argKinds = init $ unfoldKind typeKind
   fromHsNameToTyVar :: (Kind, HsName) -> Type
   fromHsNameToTyVar (k, n)
      = TVar (tyvar (toName TypeVal n) k)
   preds = hsContextToPreds kt context

--dataDeclEnv modName kt (HsNewTypeDecl _sloc context typeName args condecl _)
--   = conDeclType modName kt preds resultType condecl
--   where
--   typeName' = toName TypeConstructor typeName
--   typeKind = kindOf typeName' kt
--   resultType = foldl tAp tycon argVars
--   tycon = TCon (Tycon typeName' typeKind)
--   argVars = map fromHsNameToTyVar $ zip argKinds args
--   argKinds = init $ unfoldKind typeKind
--   fromHsNameToTyVar :: (Kind, HsName) -> Type
--   fromHsNameToTyVar (k, n)
--      = TVar (tyvar (toName TypeVal n) k)
--   preds = hsContextToPreds kt context

dataDeclEnv _modName _kt _anyOtherDecl
   = Map.empty

hsContextToPreds :: KindEnv -> HsContext -> [Pred]
hsContextToPreds kt assts = map (hsAsstToPred kt) assts

-- XXX we ignore predicates on data constructors because they don't mean anything

conDeclType :: Module -> KindEnv -> [Pred] -> Type -> HsConDecl -> Map.Map Name Sigma
conDeclType modName kt preds tResult (HsConDecl { hsConDeclName = conName, hsConDeclConArg = bangTypes })
   = Map.singleton (toName DataConstructor conName) $ tForAll (freeVars qualConType) qualConType
   where
   conType = foldr fn tResult (map (bangTypeToType kt) bangTypes)
   qualConType = preds :=> conType
conDeclType modName kt preds tResult rd@HsRecDecl { hsConDeclName = conName }
   = Map.singleton (toName DataConstructor conName) $ tForAll (freeVars qualConType) qualConType
   where
   conType = foldr fn tResult (map (bangTypeToType kt) (hsConDeclArgs rd))
   qualConType = preds :=> conType

bangTypeToType :: KindEnv -> HsBangType -> Type
bangTypeToType kt (HsBangedTy t) = runIdentity $ hsTypeToType kt t
bangTypeToType kt (HsUnBangedTy t) = runIdentity $ hsTypeToType kt t