    module Vectorise.Type.TyConDecl
    	(vectTyConDecls)
    where
    import Vectorise.Type.Type
    import Vectorise.Monad
    import BuildTyCl
    import Class
    import Type
    import TyCon
    import DataCon
    import BasicTypes
    import Var
    import Name
    import Outputable
    import Util
    import Control.Monad

    -- | Vectorise some (possibly recursively defined) type constructors.
    vectTyConDecls :: [TyCon] -> VM [TyCon]
    vectTyConDecls tcs = fixV $ \tcs' ->
      do
        mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
        mapM vectTyConDecl tcs

    -- | Vectorise a single type construcrtor.
    vectTyConDecl :: TyCon -> VM TyCon
    vectTyConDecl tycon
        -- a type class constructor.
        -- TODO: check for no stupid theta, fds, assoc types.
        | isClassTyCon tycon
        , Just cls		<- tyConClass_maybe tycon

        = do    -- make the name of the vectorised class tycon.
    	    name'	<- cloneName mkVectTyConOcc (tyConName tycon)

                -- vectorise right of definition.
                rhs'        <- vectAlgTyConRhs tycon (algTyConRhs tycon)

                -- vectorise method selectors.
                -- This also adds a mapping between the original and vectorised method selector
                -- to the state.
                methods'	<- mapM vectMethod
    			$  [(id, defMethSpecOfDefMeth meth)
    				| (id, meth)	<- classOpItems cls]

                -- keep the original recursiveness flag.
                let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)

    	    -- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
                cls'     <- liftDs
                 	    $  buildClass
                                 False               -- include unfoldings on dictionary selectors.
                                 name'               -- new name  V_T:Class
                                 (tyConTyVars tycon) -- keep original type vars
                                 []                  -- no stupid theta
                                 []                  -- no functional dependencies
                                 []                  -- no associated types
                                 methods'            -- method info
                                 rec_flag            -- whether recursive

                let tycon'  = mkClassTyCon name'
    			     (tyConKind tycon)
    			     (tyConTyVars tycon)
    			     rhs'
    			     cls'
    			     rec_flag

                return $ tycon'

        -- a regular algebraic type constructor.
        -- TODO: check for stupid theta, generaics, GADTS etc
        | isAlgTyCon tycon
        = do    name'	<- cloneName mkVectTyConOcc (tyConName tycon)
                rhs'	<- vectAlgTyConRhs tycon (algTyConRhs tycon)
                let rec_flag =  boolToRecFlag (isRecursiveTyCon tycon)

                liftDs $ buildAlgTyCon
                                name'               -- new name
                                (tyConTyVars tycon) -- keep original type vars.
                                []                  -- no stupid theta.
                                rhs'                -- new constructor defs.
                                rec_flag            -- FIXME: is this ok?
                                False               -- FIXME: no generics
                                False               -- not GADT syntax
                                NoParentTyCon
                                Nothing             -- not a family instance

        -- some other crazy thing that we don't handle.
        | otherwise
        = cantVectorise "Can't vectorise type constructor: " (ppr tycon)

    -- | Vectorise a class method.
    vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
    vectMethod (id, defMeth)
     = do
    	-- Vectorise the method type.
    	typ'	<- vectType (varType id)

    	-- Create a name for the vectorised method.
    	id'	<- cloneId mkVectOcc id typ'
    	defGlobalVar id id'

    	-- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
    	-- to the types of each method. However, the types we get back from vectType
    	-- above already already have these, so we need to chop them off here otherwise
    	-- we'll get two copies in the final version.
    	let (_tyvars, tyBody) = splitForAllTys typ'
    	let (_dict,   tyRest) = splitFunTy tyBody

    	return	(Var.varName id', defMeth, tyRest)

    -- | Vectorise the RHS of an algebraic type.
    vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
    vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
                                 , is_enum   = is_enum
                                 })
      = do
          data_cons' <- mapM vectDataCon data_cons
          zipWithM_ defDataCon data_cons data_cons'
          return $ DataTyCon { data_cons = data_cons'
                             , is_enum   = is_enum
                             }

    vectAlgTyConRhs tc _
    	= cantVectorise "Can't vectorise type definition:" (ppr tc)

    -- | Vectorise a data constructor.
    --   Vectorises its argument and return types.
    vectDataCon :: DataCon -> VM DataCon
    vectDataCon dc
      | not . null $ dataConExTyVars dc
      = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)

      | not . null $ dataConEqSpec   dc
      = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)

      | otherwise
      = do
          name'    <- cloneName mkVectDataConOcc name
          tycon'   <- vectTyCon tycon
          arg_tys  <- mapM vectType rep_arg_tys

          liftDs $ buildDataCon
    		name'
                    False                          -- not infix
                    (map (const HsNoBang) arg_tys) -- strictness annots on args.
                    []                             -- no labelled fields
                    univ_tvs                       -- universally quantified vars
                    []                             -- no existential tvs for now
                    []                             -- no eq spec for now
                    []                             -- no context
                    arg_tys                        -- argument types
    		(mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
                    tycon'                         -- representation tycon
      where
        name        = dataConName dc
        univ_tvs    = dataConUnivTyVars dc
        rep_arg_tys = dataConRepArgTys dc
        tycon       = dataConTyCon dc