module E.FromHs(
    convertDecls,
    convertRules,
    createInstanceRules,
    procAllSpecs,
    getMainFunction
    ) where

import Data.Char
import Control.Monad.Error
import Control.Monad.Identity
import Control.Monad.RWS
import Data.List(isPrefixOf,nub)
import Prelude
import Text.Printf
import qualified Data.Map as Map
import qualified Data.Traversable as T
import qualified Text.PrettyPrint.HughesPJ as PPrint

import C.FFI
import C.Prims as CP
import DataConstructors
import Doc.DocLike
import Doc.PPrint
import E.E
import E.Eta
import E.Eval(eval)
import E.LetFloat(atomizeAp)
import E.PrimDecode
import E.Rules
import E.Show(render)
import E.Subst
import E.Traverse
import E.TypeCheck
import E.Values
import FrontEnd.Class
import FrontEnd.HsSyn as HS
import FrontEnd.Rename(unRename)
import FrontEnd.SrcLoc
import FrontEnd.Syn.Traverse(getNamesFromHsPat)
import FrontEnd.Tc.Main(isTypePlaceholder)
import FrontEnd.Tc.Module(TiData(..))
import FrontEnd.Tc.Type hiding(Rule(..))
import FrontEnd.Warning
import Info.Types
import Name.Id
import Name.Name as Name
import Name.Names
import Name.VConsts
import Options
import PackedString
import StringTable.Atom
import Support.CanType
import Support.FreeVars
import Util.Gen
import Util.NameMonad
import Util.SetLike
import qualified FlagOpts as FO
import qualified FrontEnd.Tc.Type as T(Rule(..))
import qualified FrontEnd.Tc.Type as Type
import qualified Info.Info as Info

ump sl e = EError (show sl ++ ": Unmatched pattern") e

r_bits32       = ELit litCons { litName = rt_bits32, litType = eHash }
r_bits_max_    = ELit litCons { litName = rt_bits_max_, litType = eHash }
r_bits_ptr_    = ELit litCons { litName = rt_bits_ptr_, litType = eHash }

createIf e a b = do
    [tv] <- newVars [Unknown]
    return $ createIfv tv e a b

createIfv v e a b = res where
    tv = v { tvrType = tBoolzh }
    ic = eCase (EVar tv) [Alt lTruezh a, Alt lFalsezh b] Unknown
    res = eCase e [Alt (litCons { litName = dc_Boolzh, litArgs = [tv], litType = tBool }) ic] Unknown

ifzh e a b = eCase e [Alt lTruezh a, Alt lFalsezh b] Unknown

newVars :: UniqueProducer m => [E] -> m [TVr]
newVars xs = f xs [] where
    f [] xs = return $ reverse xs
    f (x:xs) ys = do
        s <- newUniq
        f xs (tVr (anonymous s) x:ys)

tipe t = f t where
    f (TAp (TAp (TCon arr) a1) a2) | tyconName arr == tc_Arrow = f (TArrow a1 a2)
    f (TAp t1 t2) = eAp (f t1) (f t2)
    f (TArrow t1 t2) =  EPi (tVr emptyId (f t1)) (f t2)
    f (TCon (Tycon n k)) | Just n' <- Map.lookup n primitiveAliases = ELit litCons { litName = n', litType = kind k }
    f (TCon (Tycon n k)) =  ELit litCons { litName = n, litType = kind k }
    f (TVar tv) = EVar (cvar [] tv)
    f (TMetaVar mv) = cmvar mv
    f (TForAll vs (ps :=> t)) = foldr EPi (f t) (map (cvar $ freeVars ps) vs)
    f (TExists xs (_ :=> t)) = let
        xs' = map (kind . tyvarKind) xs
        in ELit litCons { litName = unboxedNameTuple TypeConstructor (length xs' + 1), litArgs = f t:xs', litType = eHash }
    f TAssoc {} = error "E.FromHs.tipe TAssoc"
    cvar fvs tv@Tyvar { tyvarName = n, tyvarKind = k }
        | tv `elem` fvs = setProperty prop_SCRUTINIZED (tVr (lt n) (kind k))
        | otherwise = tVr (lt n) (kind k)
    cmvar MetaVar { metaKind = k } = tAbsurd (kind k)
    lt n | nameType n == TypeVal = toId n  -- verifies namespace
         | otherwise = error "E.FromHs.lt"

kind (KBase KUTuple) = eHash
kind (KBase KHash) = eHash
kind (KBase Star) = eStar
kind (KBase KQuest) = eStar      -- XXX why do these still exist?
kind (KBase KQuestQuest) = eStar
kind (Kfun k1 k2) = EPi (tVr emptyId (kind k1)) (kind k2)
kind (KVar _) = error "Kind variable still existing."
kind _ = error "E.FromHs.kind: unknown"

fromTyvar (Tyvar n k) = tVr (toId n) (kind k)

fromSigma (TForAll vs (_ :=> t)) = (map fromTyvar vs, tipe t)
fromSigma t = ([], tipe t)

monadicLookup' k m = case Map.lookup k m of
    Just x  -> return x
    Nothing -> fail $ "key not found: " ++ show k

convertValue n = do
    assumps <- asks ceAssumps
    dataTable <- asks ceDataTable
    t <- monadicLookup' n assumps
    let ty = removeNewtypes dataTable (tipe t)
    cc <- asks ceCoerce
    lm <- case Map.lookup n cc of
        Nothing -> do
            let (vs,_) = fromSigma t
            return (flip (foldr eLam) vs)
        Just CTId -> do return id
        Just ~(CTAbs ts) -> do return $ \e -> foldr eLam e (map fromTyvar ts)
    return (tVr (toId n) ty,ty,lm)

--convertType t = do
--    dataTable <- asks ceDataTable
--    return $ removeNewtypes dataTable (tipe t)

matchesConv ms = map v ms where
    v (HsMatch _ _ ps rhs wh) = (ps,rhs,wh)

altConv as = map v as where
    v (HsAlt _ p rhs wh) = ([p],rhs,wh)

argTypes e = span (sortSortLike . getType) (map tvrType xs) where
    (_,xs) = fromPi e
argTypes' :: E -> ([E],E)
argTypes' e = let (x,y) = fromPi e in (map tvrType y,x)

getMainFunction :: Monad m => DataTable -> Name -> (Map.Map Name (TVr,E)) -> m (TVr,E)
getMainFunction dataTable name ds = do
  mt <- case Map.lookup name ds of
    Just x -> return x
    Nothing -> fail $ "Could not find main function: " ++ show name
  let funcs = runIdentity $ T.mapM (\n -> return . EVar . fst $ runEither (show n) $ monadicLookup' n ds) sFuncNames
  nameToEntryPoint dataTable (fst mt) (toName Name.Val "theMain") Nothing funcs

nameToEntryPoint :: Monad m => DataTable -> TVr -> Name -> Maybe FfiExport -> FuncNames E -> m (TVr,E)
nameToEntryPoint dataTable main cname ffi ds = ans where
    ans = do
        let runMain      = func_runMain ds
            runExpr      = func_runExpr ds
            runNoWrapper = func_runNoWrapper ds
            runRaw       = func_runRaw ds
        let e = case extractIO (getType maine) of
                Just x | not (fopts FO.Wrapper) -> EAp (EAp runNoWrapper x) maine
                Just x ->  EAp (EAp runMain  x ) maine
                Nothing | fopts FO.Raw -> EAp (EAp runRaw ty) maine
                Nothing ->  EAp (EAp runExpr ty) maine
            ne = ELam worldVar (EAp e (EVar worldVar))
            worldVar = tvr { tvrIdent = va1, tvrType = tWorld__ }
            theMainTvr =  tVr (toId cname) (infertype dataTable ne)
            tvm@(TVr { tvrType =  ty}) =  main
            maine = foldl EAp (EVar tvm) [ tAbsurd k |  TVr { tvrType = k } <- xs, sortKindLike k ]
            (_,xs) = fromPi ty
        return (tvrInfo_u (case ffi of Just ffi -> Info.insert ffi; Nothing -> id) $ setProperty prop_EXPORTED theMainTvr,ne)

-- | create a RULE for each instance attached to the class methods.
-- These rules allow early specialization of monomorphic code, and are
-- eventually used in E.TypeAnalysis.expandPlaceholder to fill out
-- the generic class method bodies.

{-# NOINLINE createInstanceRules #-}
createInstanceRules :: Monad m => DataTable -> ClassHierarchy -> [(TVr,E)] -> m Rules
createInstanceRules dataTable classHierarchy funcs = return $ fromRules ans where
    ans = concatMap cClass (classRecords classHierarchy)
    cClass classRecord = concat [ method classRecord n mve |
        (n,TForAll _ (_ :=> t)) <- classAssumps classRecord, mve <- findName n ]
    method classRecord methodName (methodVar,_) = as where
        ty = tvrType methodVar
        defaultName = defaultInstanceName methodName
        as = [ rule t | Inst { instHead = _ :=> IsIn _ t } <- snub (findClassInsts classHierarchy (className classRecord)) ]
        rule t = makeRule ("Rule.{" ++ show name ++ "}") (toModule (show name),0)
                RuleSpecialization ruleFvs methodVar (vp:map EVar args) (removeNewtypes dataTable body) where
            ruleFvs = [ t | ~(EVar t) <- vs] ++ args
            (vp,vs) = valToPat' (removeNewtypes dataTable $ tipe t)
            name = instanceName methodName (getTypeCons t)
            bodyt = foldl eAp ty (vp:map EVar args)
            body = case findName name of
                Just (n,_) -> runIdentity $ do actuallySpecializeE (EVar n) bodyt
                Nothing -> case findName defaultName of
                    Just (deftvr,_) | otherwise -> runIdentity $ do actuallySpecializeE (EVar deftvr) bodyt
                    Nothing -> EError ( show methodName ++ ": undefined at type " ++  PPrint.render (pprint t)) bodyt
                    --Just (deftvr,_) -> eLet tv vp $ runIdentity $ do actuallySpecializeE (EVar deftvr) (foldl eAp ty $ EVar tv:map EVar args) where -- foldl EAp (EAp (EVar deftvr) (EVar tv)) (map EVar args) where
                    --    tv = tvr { tvrIdent = head [ n | n <- newIds (freeVars vp `mappend` fromList (map tvrIdent args))], tvrType = getType vp }
                    --Just (deftvr,_) | null vs -> foldl EAp (EAp (EVar deftvr) vp) (map EVar args)

        -- this assumes the class argument is always the first type parameter
        (_,_:args') = fromPi ty
        (args,_) = span (sortKindLike . tvrType)  args'

        someIds = newIds (fromList $ map tvrIdent args')
        valToPat' (ELit LitCons { litAliasFor = af,  litName = x, litArgs = ts, litType = t }) = ans where
            ans = (ELit litCons { litAliasFor = af, litName = x, litArgs = ts', litType = t },ts')
            ts' = [ EVar (tVr j (getType z)) | z <- ts | j <- someIds]
        valToPat' (EPi tv@TVr { tvrType =  a} b)  = (EPi tvr { tvrType =  a'} b',[a',b']) where
            a' = EVar (tVr ja (getType a))
            b' = EVar (tVr jb (getType b))
            (ja:jb:_) = someIds
        valToPat' x = error $ "FromHs.valToPat': " ++ show x

    funcsMap = Map.fromList [ (n,(v,e)) | (v,e) <- funcs, let Just n = fromId (tvrIdent v) ]
    findName name = case Map.lookup name funcsMap of
        Nothing -> fail $ "Cannot find: " ++ show name
        Just n -> return n

getTypeCons (TCon (Tycon n _)) = n
getTypeCons (TAp a _) = getTypeCons a
getTypeCons (TArrow {}) = tc_Arrow
getTypeCons x = error $ "getTypeCons: " ++ show x

unbox :: DataTable -> E -> Id -> (E -> E) -> E
unbox dataTable e _vn wtd | getType (getType e) == eHash = wtd e
unbox dataTable e vn wtd = eCase e [Alt (litCons { litName = cna, litArgs = [tvra], litType = te }) (wtd (EVar tvra))] Unknown where
    te = getType e
    tvra = tVr vn sta
    Just (ExtTypeBoxed cna sta _) = lookupExtTypeInfo dataTable te

createFunc :: [E] -> ([TVr] -> C (E -> E,E)) -> C E
createFunc es ee = do
    dataTable <- getDataTable
    xs <- flip mapM es $ \te -> do
        eti <- ffiTypeInfo ExtTypeVoid te return
        [n] <- newVars [te]
        case eti of
            ExtTypeVoid -> fail "createFunc: attempt to pass a void argument"
            ExtTypeBoxed cn sta _ -> do
                [n'] <- newVars [sta]
                return (n,n',Just cn)
            ExtTypeRaw _ -> do
                return (n,n,Nothing)
    let tvrs' = [ n' | (_,n',_) <- xs ]
        tvrs = [ t | (t,_,_) <- xs]
    (me,innerE) <- ee tvrs'
    let eee = me $ foldr esr innerE xs
        esr (tvr,tvr',Just cn) e = eCase (EVar tvr) [Alt (litCons { litName = cn, litArgs = [tvr'], litType = tvrType tvr }) e] Unknown
        esr (_,_,Nothing) e = e
    return $ foldr ELam eee tvrs

instance GenName String where
   genNames i = map (('x':) . show) [i..]

{-# NOINLINE convertRules #-}
convertRules :: Module -> TiData -> ClassHierarchy -> Map.Map Name Type -> DataTable -> [HsDecl] -> IO Rules
convertRules mod tiData classHierarchy assumps dataTable hsDecls = ans where
    ans = do
        rawRules <- concatMapM g hsDecls
        return $ fromRules [ makeRule n (mod,i) (if catalyst then RuleCatalyst else RuleUser) vs head args e2 | (catalyst,n,vs,e1,e2) <- rawRules, let (EVar head,args) = fromAp e1 | i <- [1..] ]
    g (HsPragmaRules rs) = mapM f rs
    g _ = return []
    f pr = do
        let ce = convertE tiData classHierarchy assumps dataTable (hsRuleSrcLoc pr)
        e1 <- ce (hsRuleLeftExpr pr)
        e2 <- ce (hsRuleRightExpr pr)
        (ts,cs) <- runNameMT $ do
            ts <- flip mapM (filter (sortKindLike . getType) $ freeVars e1) $ \tvr -> do
                --return (tvrIdent tvr,tvr)
                nn <- newNameFrom (map (:'\'':[]) ['a' ..])
                return (tvrIdent tvr,tvr { tvrIdent = toId (toName TypeVal nn) })
            cs <- flip mapM [toTVr assumps dataTable (toName Val v) | (v,_) <- hsRuleFreeVars pr ] $ \tvr -> do
                let ur = show $ unRename (toUnqualified $ runIdentity $ fromId (tvrIdent tvr))
                nn <- newNameFrom (ur:map (\v -> ur ++ show v) [1 ::Int ..])
                return (tvrIdent tvr,tvr { tvrIdent = toId (toName Val nn) })
            return (ts,cs)
        let smt = substMap $ fromList [ (x,EVar y)| (x,y) <- ts ]
            sma = substMap $ fromList [ (x,EVar y)| (x,y) <- cs' ]
            cs' =  [ (x,(tvrType_u smt y))| (x,y) <- cs ]
            e2' = deNewtype dataTable $ smt $ sma e2
        --e2 <- atomizeAp False dataTable Stats.theStats mainModule e2'
        let e2 = atomizeAp mempty False dataTable e2'
        return (hsRuleIsMeta pr,hsRuleString pr,( snds (cs' ++ ts) ),eval $ smt $ sma e1,e2)

convertE :: TiData -> ClassHierarchy -> Map.Map Name Type
    -> DataTable -> SrcLoc -> HsExp -> IO E
convertE tiData classHierarchy assumps dataTable srcLoc exp = do
    [(_,_,e)] <- convertDecls tiData mempty classHierarchy assumps dataTable
        [HsPatBind srcLoc (HsPVar v_silly) (HsUnGuardedRhs exp) []]
    return e

v_silly = toName Val ("Jhc@","silly")

data CeEnv = CeEnv {
    ceAssumps :: Map.Map Name Type,
    ceCoerce :: Map.Map Name CoerceTerm,
    ceFuncs  :: FuncNames E,
    ceProps  :: IdMap Properties,
    ceSrcLoc :: SrcLoc,
    ceDataTable :: DataTable
    }

newtype C a = Ce (RWST CeEnv [Warning] Int IO a)
    deriving(Monad,Functor,MonadIO,MonadReader CeEnv,MonadState Int,MonadError IOError)

instance MonadWarn C where
    addWarning w = liftIO (addWarning w)

instance MonadSrcLoc C where
    getSrcLoc = asks ceSrcLoc

instance MonadSetSrcLoc C where
    withSrcLoc sl = local (\ce -> ce { ceSrcLoc = sl })

instance UniqueProducer C where
    newUniq = do
        i <- get
        put $! (i + 1)
        return i

instance DataTableMonad C where
    getDataTable = asks ceDataTable

applyCoersion :: CoerceTerm -> E -> C E
applyCoersion CTId e = return e
applyCoersion ct e = etaReduce `liftM` f ct e where
    f CTId e = return e
    f (CTAp ts) e = return $ foldl eAp e (map tipe ts)
    f (CTAbs ts) e = return $ foldr eLam e (map fromTyvar ts)
    f (CTCompose ct1 ct2) e = f ct1 =<< (f ct2 e)
    f (CTFun CTId) e = return e
    f (CTFun ct) e = do
        let EPi TVr { tvrType = ty } _ = getType e
        [y] <- newVars [ty]
        fgy <- f ct (EAp e (EVar y))
        return (eLam y fgy)

fromTuple_ :: Monad m => E -> m [E]
fromTuple_ (ELit LitCons { litName = n, litArgs = as }) | Just c <- fromUnboxedNameTuple n, c == length as = return as
fromTuple_ e = fail "fromTuple_ : not unboxed tuple"

{-# NOINLINE convertDecls #-}
convertDecls :: TiData -> IdMap Properties
    -> ClassHierarchy -> Map.Map Name Type -> DataTable
    -> [HsDecl] -> IO [(Name,TVr,E)]
convertDecls tiData props classHierarchy assumps dataTable hsDecls = res where
    res = do
        (a,ws) <- evalRWST ans ceEnv 2
        mapM_ addWarning ws
        return a
    ceEnv = CeEnv {
        ceCoerce = tiCoerce tiData,
        ceAssumps = assumps,
        ceFuncs = funcs,
        ceProps = props,
        ceSrcLoc = bogusASrcLoc,
        ceDataTable = dataTable
        }
    Identity funcs = T.mapM (return . EVar . toTVr assumps dataTable) sFuncNames
    Ce ans = do
        nds <- mapM cDecl' hsDecls
        return (map anninst $ concat nds)
    doNegate e = eAp (eAp (func_negate funcs) (getType e)) e
    anninst (a,b,c)
        | "Instance@" `isPrefixOf` show a = (a,setProperty prop_INSTANCE b, deNewtype dataTable c)
        | otherwise = (a,b, deNewtype dataTable c)

    -- first argument builds the actual call primitive, given
    -- (a) the C argtypes
    -- (b) the C return type
    -- (c) the extra return variables passed back in pointers
    -- (d) the arguments themselves
    -- (e) the real return type
    -- ccallHelper returns a function expression to perform the call, when given the arguments
    invalidDecl s = addWarn InvalidDecl s >> fail s
    ccallHelper :: ([ExtType] -> ExtType -> [ExtType] -> [E] -> E -> E) -> E -> C E
    ccallHelper myPrim ty = do
        let (ts,isIO,rt) = extractIO' ty
        es <- newVars [ t |  t <- ts, not (sortKindLike t) ]
        let (rt':ras) = case fromTuple_ rt of
                Just (x:ys@(_:_)) -> (x:ys)
                _ -> [rt]
        ras' <- forM ras $ \t -> ffiTypeInfo ExtTypeVoid t return
        ffiTypeInfo Unknown rt' $ \pt -> do
        cts <- forM  (filter (not . sortKindLike) ts) $ \t -> do ffiTypeInfo ExtTypeVoid t $ return
        [tvrWorld, tvrWorld2] <- newVars [tWorld__,tWorld__]
        let cFun = createFunc (map tvrType es)
            prim = myPrim (map extTypeInfoExtType cts) (extTypeInfoExtType pt) (map extTypeInfoExtType ras')
        case (isIO,pt,ras') of
            (True,ExtTypeVoid,[]) -> cFun $ \rs -> return (ELam tvrWorld,
                eStrictLet tvrWorld2 (prim (EVar tvrWorld :[EVar t | t <- rs ]) tWorld__)
                    (eJustIO (EVar tvrWorld2) vUnit))
            (False,ExtTypeVoid,_) -> invalidDecl  "pure foreign function must return a non void value"
            (True,_,(_:_)) -> invalidDecl "IO-like functions may not return a tuple"
            (_,ExtTypeBoxed cn rtt' _,[]) -> do
                [rtVar,rtVar'] <- newVars [rt',rtt']
                let rttIO' = ltTuple' [tWorld__, rtt']
                case isIO of
                    False -> cFun $ \rs -> return (id,
                        eStrictLet rtVar' (prim [ EVar t | t <- rs ] rtt')
                            (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }))
                    True -> cFun $ \rs -> return $ (,) (ELam tvrWorld) $
                        eCaseTup' (prim (EVar tvrWorld:[EVar t | t <- rs ]) rttIO') [tvrWorld2,rtVar']
                            (eLet rtVar (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
                                (eJustIO (EVar tvrWorld2) (EVar rtVar)))
            (True,ExtTypeRaw  _,[]) -> do
                let rttIO' = ltTuple' [tWorld__, rt']
                cFun $ \rs -> return (ELam tvrWorld,prim (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')
            (False,ExtTypeRaw  _,[]) -> do
                cFun $ \rs -> return (id,prim [EVar t | t <- rs ] rt')
            (False,_,(_:_)) -> do
                let rets = (rt':ras)
                rets' <- mapM unboxedVersion rets
                cFun $ \rs -> do
                fun <- extractUnboxedTup (prim [ EVar t | t <- rs ] (ltTuple' rets')) $ \vs -> do
                    rv <- zipWithM marshallFromC vs rets
                    return $ eTuple' rv
                return (id,fun)
            -- _ -> invalidDecl "foreign declaration is of incorrect form."

    --isExtTypeRaw ExtTypeRaw {} = True
    --isExtTypeRaw _ = False

    cDecl,cDecl' :: HsDecl -> C [(Name,TVr,E)]
    cDecl' d = withSrcLoc (srcLoc d) $ catchError (cDecl d) $ \ (e :: IOError) -> do
        warn (srcLoc d) InvalidDecl $ "caught error processing decl: " ++ show e
        return []
    cDecl (HsForeignDecl sLoc (FfiSpec (Import cn req) _ Primitive) n _) = do
        let name      = toName Name.Val n
        (var,ty,lamt) <- convertValue name
        let (ts,rt)   = argTypes' ty
        es <- newVars [ t |  t <- ts, not (sortKindLike t) ]
        result <- processPrim dataTable sLoc (toAtom cn)
            [ EVar e | e <- es, not (tvrType e == tUnit)] rt req
        return [(name,setProperty prop_INLINE var,
                 lamt $ foldr ($) result (map ELam es))]
    cDecl (HsForeignDecl _ (FfiSpec (ImportAddr rcn req) _ _) n _) = do
        let name       = toName Name.Val n
        (var,ty,lamt)  <- convertValue name
        let (_ts,rt)   = argTypes' ty
            expr x     = return [(name,setProperty prop_INLINE var,lamt x)]
            prim       = (AddrOf req $ packString rcn)
        -- this needs to be a boxed value since we can't have top-level
        -- unboxed values yet.
        ffiTypeInfo [] rt $ \eti -> do
        case eti of
            ExtTypeBoxed cn st _ -> do
                [uvar] <- newVars [st]
                expr $ eStrictLet uvar (EPrim prim [] st) (ELit (litCons { litName = cn, litArgs = [EVar uvar], litType = rt }))
            _ -> invalidDecl "foreign import of address must be of a boxed type"

    cDecl (HsForeignDecl _ (FfiSpec (Import rcn req) safe CCall) n _) = do
        let name = toName Name.Val n
        (var,ty,lamt) <- convertValue name
        result <- ccallHelper
                     (\cts crt cras args rt ->
                      EPrim (Func req (packString rcn) cts crt cras safe) args rt)
                     ty
        return [(name,setProperty prop_INLINE var,lamt result)]
    cDecl (HsForeignDecl _ (FfiSpec Dynamic _ CCall) n _) = do
        -- XXX ensure that the type is of form FunPtr /ft/ -> /ft/
        let name = toName Name.Val n
        (var,ty,lamt) <- convertValue name
        --let ((fptrTy:_), _) = argTypes' ty
        --    fty = discardArgs 1 ty
        result <- ccallHelper
                     (\cts crt cras args rt ->
                      EPrim (IFunc mempty (tail cts) crt) args rt)
                     ty
        return [(name,setProperty prop_INLINE var,lamt result)]

    cDecl (HsForeignDecl _ (FfiSpec (Import rcn _) _ DotNet) n _) = do
        (var,ty,lamt) <- convertValue (toName Name.Val n)
        let (ts,isIO,rt') = extractIO' ty
        es <- newVars [ t |  t <- ts, not (sortKindLike t) ]
        ffiTypeInfo [] rt' $ \pt -> do
        [tvrWorld, tvrWorld2] <- newVars [tWorld__,tWorld__]
        dnet <- parseDotNetFFI rcn
        let cFun = createFunc (map tvrType es)
            prim rs rtt = EPrim dnet
        result <- case (isIO,pt) of
            (True,ExtTypeVoid) -> cFun $ \rs -> return $  (,) (ELam tvrWorld) $
                        eStrictLet tvrWorld2 (prim rs "void" (EVar tvrWorld:[EVar t | t <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit)
            (False,ExtTypeVoid) -> invalidDecl "pure foreign function must return a valid value"
            _ -> do
                ExtTypeBoxed cn rtt' rtt <- lookupExtTypeInfo dataTable rt'
                [rtVar,rtVar'] <- newVars [rt',rtt']
                let _rttIO = ltTuple [tWorld__, rt']
                    rttIO' = ltTuple' [tWorld__, rtt']
                case isIO of
                    False -> cFun $ \rs -> return $ (,) id $ eStrictLet rtVar' (prim rs rtt [ EVar t | t <- rs ] rtt') (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
                    True -> cFun $ \rs -> return $ (,) (ELam tvrWorld) $
                                eCaseTup' (prim rs rtt (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')  [tvrWorld2,rtVar'] (eLet rtVar (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }) (eJustIO (EVar tvrWorld2) (EVar rtVar)))
        return [(toName Name.Val n,var,lamt result)]

    cDecl x@HsForeignDecl {} = invalidDecl ("Unsupported foreign declaration: "++ show x)

    cDecl (HsForeignExport _ ffi@FfiExport { ffiExportCName = ecn } n _) = do
        let name = ffiExportName ffi
        fn <- convertVar name
        tn <- convertVar (toName Name.Val n)

        (var,ty,lamt) <- convertValue name
        let --(argTys,retTy') = argTypes' ty
            --(isIO,retTy) = extractIO' retTy'
            (argTys,isIO,retTy) = extractIO' ty

        --retCTy <- if retTy == tUnit
         --         then return unboxedTyUnit
         --         else liftM (\(_, _, x) -> rawType x) $ lookupCType' dataTable retTy

        aets <- forM argTys $ \ty -> do
            ffiTypeInfo (Unknown,undefined,undefined) ty $ \eti -> do
--            eti <- lookupExtTypeInfo dataTable ty
            ty' <- case eti of
                ExtTypeVoid -> invalidDecl "attempt to foreign export function with void argument"
                ExtTypeRaw _ -> do return ty
                ExtTypeBoxed _ ty' _  -> do return ty'
            [v] <- newVars [ty']
            e <- marshallFromC (EVar v) ty
            return (e,v,ty')

        let argEs   = [ e | (e,_,_) <- aets ]
            argTvrs = [ v | (_,v,_) <- aets ]
            argCTys = [ t | (_,_,t) <- aets ]
        fe <- actuallySpecializeE (EVar tn) ty
        let inner = foldl EAp fe argEs

        retE <- case isIO of
                  False -> marshallToC inner retTy
                  True -> do [world_, world__, ret] <- newVars [tWorld__, tWorld__, retTy]
                             retMarshall <- if retTy == tUnit
                                            then return (ELit (unboxedTuple []))
                                            else marshallToC (EVar ret) retTy
                             return (eLam world_ (eCaseTup' (eAp inner (EVar world_))
                                                            [world__, ret]
                                                            (ELit (unboxedTuple [EVar world__, retMarshall]))))

        let retCTy' = typeInfer dataTable retE

        -- trace ("retE: "++pprint retE) $ return ()

        let result = foldr ELam retE argTvrs

        realRetCTy:realArgCTys <- mapM (\x -> extTypeInfoExtType `liftM`  lookupExtTypeInfo dataTable x) (retTy:argTys)

        return [(name,
                 tvrInfo_u (Info.insert ffi { ffiExportArgTypes = realArgCTys, ffiExportRetType = realRetCTy } )
                           (fmap (const (foldr tFunc retCTy' argCTys)) $
                              setProperty prop_EXPORTED fn),
                 result)]

    cDecl (HsPatBind sl (HsPVar n) (HsUnGuardedRhs exp) []) | n == v_silly = do
        e <- cExpr exp
        return [(v_silly,tvr,e)]
    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do
        let name = toName Name.Val n
        (var,ty,lamt) <- convertValue name
        rhs <- cRhs sl rhs
        lv <- hsLetE wh rhs
        return [(name,var,lamt lv)]
    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do
        let name = toName Name.Val n
        (var,ty,lamt) <- convertValue name
        rhs <- cRhs sl rhs
        lv <- hsLetE wh rhs
        return [(name,var,lamt lv)]

    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do
        let name = toName Name.Val n
        (var,ty,lamt) <- convertValue name
        rhs <- cRhs sl rhs
        lv <- hsLetE wh rhs
        return [(name,var,lamt lv)]
    cDecl (HsFunBind [(HsMatch sl n ps rhs wh)]) | all isHsPVar ps = do
        let name = toName Name.Val n
        (var,ty,lamt) <- convertValue name
        rhs <- cRhs sl rhs
        lv <- hsLetE wh rhs
        lps <- lp ps lv
        return [(name,var,lamt lps )]
    cDecl (HsFunBind ms@((HsMatch sl n ps _ _):_)) = do
        let name = toName Name.Val n
        (var,t,lamt) <- convertValue name
        let (targs,eargs) = argTypes t
            numberPatterns = length ps
        bs' <- newVars (take numberPatterns eargs)
        let bs  = map EVar bs'
            rt = discardArgs (length targs + numberPatterns) t
            z e = foldr eLam e bs'
        ms <- cMatchs bs (matchesConv ms) (ump sl rt)
        return [(name,var,lamt $ z ms )]
    cDecl cd@(HsClassDecl {}) = cClassDecl cd
    cDecl _ = return []
    cExpr :: HsExp -> C E
    cExpr (HsAsPat n' (HsCon n)) = return $ constructionExpression dataTable (toName DataConstructor n) rt where
        t' = getAssump n'
        (_,rt) = argTypes' (tipe t')
    cExpr (HsLit (HsStringPrim s)) = return $ EPrim (PrimString (packString s)) [] r_bits_ptr_
    cExpr (HsLit (HsString s)) = return $ E.Values.toE s
    cExpr (HsAsPat n' (HsLit (HsIntPrim i))) = ans where
        t' = getAssump n'
        ans = return $ ELit (LitInt (fromIntegral i) (tipe t'))
    cExpr (HsAsPat n' (HsLit (HsCharPrim i))) = ans where
        t' = getAssump n'
        ans = return $ ELit (LitInt (fromIntegral $ ord i) (tipe t'))
    cExpr (HsAsPat n' (HsLit (HsInt i))) = ans where
        t' = getAssump n'
        ty = tipe t'
        -- XXX this can allow us to create integer literals out of things that
        -- arn't in Num if we arn't careful
        ans = case lookupExtTypeInfo dataTable ty of
            Just (ExtTypeBoxed cn st _) -> return $ ELit (litCons { litName = cn, litArgs = [ELit (LitInt (fromIntegral i) st)], litType = ty })
            _ -> return $ intConvert' funcs ty i
            --Just (cn,st,it) ->
    --cExpr (HsLit (HsInt i)) = return $ intConvert i
    cExpr (HsLit (HsChar ch)) = return $ toE ch
    cExpr (HsLit (HsCharPrim ch)) = return $ toEzh ch
    cExpr (HsLit (HsFrac i))  = return $ toE i
    cExpr (HsLambda sl ps e) | all isHsPVar ps = do
        e <- cExpr e
        lp ps e
    cExpr (HsInfixApp e1 v e2) = do
        v <- cExpr v
        e1 <- cExpr e1
        e2 <- cExpr e2
        return $ eAp (eAp v e1) e2
    cExpr (HsLeftSection op e) = liftM2 eAp (cExpr op) (cExpr e)
    cExpr (HsApp (HsRightSection e op) e') = do
        op <- cExpr op
        e' <- cExpr e'
        e <- cExpr e
        return $ eAp (eAp op e') e
    cExpr (HsRightSection e op) = do
        cop <- cExpr op
        ce <- cExpr e
        let (_,TVr { tvrType = ty}:_) = fromPi (getType cop)
        [var] <- newVars [ty]
        return $ eLam var (eAp (eAp cop (EVar var)) ce)
    cExpr (HsApp e1 e2) = liftM2 eAp (cExpr e1) (cExpr e2)
    cExpr (HsParen e) = cExpr e
    cExpr (HsExpTypeSig _ e _) = cExpr e
    cExpr (HsNegApp e) = liftM doNegate (cExpr e)
    cExpr (HsLet dl e) = hsLet dl e
    cExpr (HsIf e a b) = join $ liftM3 createIf (cExpr e) (cExpr a) (cExpr b)
    cExpr (HsCase _ []) = error "empty case"
    cExpr (HsAsPat n HsError { hsExpString = msg }) = do
        ty <- convertTyp (toName Name.Val n)
        return $ EError msg ty
    cExpr (HsAsPat n hs@(HsCase e alts)) = do
        ty <- convertTyp (toName Name.Val n)
        scrut <- cExpr e
        cMatchs [scrut] (altConv alts) (EError ("No Match in Case expression at " ++ show (srcLoc hs))  ty)
    cExpr (HsTuple es) = liftM eTuple (mapM cExpr es)
    cExpr (HsUnboxedTuple es) = liftM eTuple' (mapM cExpr es)
    cExpr (HsAsPat n (HsList xs)) = do
        ty <- convertTyp (toName Name.Val n)
        let cl (x:xs) = liftM2 eCons (cExpr x) (cl xs)
            cl [] = return $ eNil ty
        cl xs
    cExpr (HsVar n) = do
        t <- convertVar (toName Name.Val n)
        return (EVar t)
    cExpr (HsAsPat n' e) = do
        e <- cExpr e
        cc <- asks ceCoerce
        case Map.lookup (toName Val n') cc of
            Nothing -> return e
            Just c -> applyCoersion c e
    cExpr e = invalidDecl ("Cannot convert: " ++ show e)
    hsLetE [] e = return  e
    hsLetE dl e = do
        nds <- mconcatMapM cDecl dl
        return $ eLetRec [ (b,c) | (_,b,c) <- nds] e
    hsLet dl e = do
        e <- cExpr e
        hsLetE dl e

    cMatchs :: [E] -> [([HsPat],HsRhs,[HsDecl])] -> E -> C E
    cMatchs bs ms els = do
        pg <- processGuards ms
        convertMatches bs pg els

    cGuard (HsUnGuardedRhs e) = liftM const $ cExpr e
    cGuard (HsGuardedRhss (HsGuardedRhs _ g e:gs)) = do
        g <- cExpr g
        e <- cExpr e
        fg <- cGuard (HsGuardedRhss gs)
        [nv] <- newVars [Unknown]
        return (\els -> createIfv nv g e (fg els))
    cGuard (HsGuardedRhss []) = return id

    getAssump n  = case Map.lookup (toName Name.Val n) assumps of
        Just z -> z
        Nothing -> error $ "Lookup failed: " ++ (show n)
    lp  [] e = return e
    lp  (HsPVar n:ps) e = do
        v <- convertVar (toName Name.Val n)
        eLam v `liftM` lp ps e
    lp  p e  =  error $ "unsupported pattern:" <+> tshow p  <+> tshow e
    cRhs sl (HsUnGuardedRhs e) = cExpr e
    cRhs sl (HsGuardedRhss []) = error "HsGuardedRhss: empty"
    cRhs sl (HsGuardedRhss gs@(HsGuardedRhs _ _ e:_)) = f gs where
        f (HsGuardedRhs _ g e:gs) = join $ liftM3 createIf (cExpr g) (cExpr e) (f gs)
        f [] = do
            e <- cExpr e
            return $ ump sl $ getType e
    processGuards xs = flip mapM xs $ \ (ps,e,wh) -> do
        cg <- cGuard e
        nds <- mconcatMapM cDecl wh
        let elet = eLetRec [ (b,c) | (_,b,c) <- nds]
        return (ps,elet . cg )

    cClassDecl (HsClassDecl _ chead decls) = do
        props <- asks ceProps
        let cr = findClassRecord classHierarchy className
            className = hsClassHead chead
            cClass classRecord =  [ f n (toId n) (removeNewtypes dataTable $ tipe t) | (n,t) <- classAssumps classRecord ] where
                f n i t = (n,setProperties [prop_METHOD,prop_PLACEHOLDER] $ tVr i t, foldr ELam (EPrim (primPrim ("Placeholder: " ++ show n)) [] ft) args)  where
                    (ft',as) = fromPi t
                    (args,rargs) = case mlookup i props of
                        Just p | getProperty prop_NOETA p -> span (sortKindLike . getType) as
                        _ -> (as,[])
                    ft = foldr EPi ft' rargs
        return (cClass cr)
    cClassDecl _ = error "cClassDecl"

convertVar n = do
    (t,_,_) <- convertValue n
    return t
convertTyp n = do
    (_,t,_) <- convertValue n
    return t

toTVr assumps dataTable n = tVr (toId n) typeOfName where
    typeOfName = case Map.lookup n assumps of
        Just z -> removeNewtypes dataTable (tipe z)
        Nothing -> error $ "convertVal.Lookup failed: " ++ (show n)

integer_cutoff = 500000000

intConvert i | abs i > integer_cutoff  =  ELit (litCons { litName = dc_Integer, litArgs = [ELit $ LitInt (fromInteger i) r_bits_max_], litType = tInteger })
intConvert i =  ELit (litCons { litName = dc_Int, litArgs = [ELit $ LitInt (fromInteger i) r_bits32], litType = tInt })

intConvert' funcs typ i = EAp (EAp fun typ) (ELit (litCons { litName = con, litArgs = [ELit $ LitInt (fromInteger i) rawtyp], litType = ltype }))  where
    (con,ltype,fun,rawtyp) = case abs i > integer_cutoff of
        True -> (dc_Integer,tInteger,f_fromInteger,r_bits_max_)
        False -> (dc_Int,tInt,f_fromInt,r_bits32)
    f_fromInt = func_fromInt funcs
    f_fromInteger = func_fromInteger funcs

litconvert (HsChar i) t | t == tChar =  LitInt (fromIntegral $ ord i) tCharzh
litconvert (HsCharPrim i) t | t == tCharzh =  LitInt (fromIntegral $ ord i) tCharzh
litconvert (HsIntPrim i) t  =  LitInt (fromIntegral i) t
litconvert e t = error $ "litconvert: shouldn't happen: " ++ show (e,t)

fromHsPLitInt (HsPLit l@(HsInt _)) = return l
fromHsPLitInt (HsPLit l@(HsFrac _)) = return l
fromHsPLitInt x = fail $ "fromHsPLitInt: " ++ show x

tidyPat
    :: HsPat
    -> E
    -> C (HsPat,E -> E)
tidyPat p b = f p where
    f HsPWildCard = return (HsPWildCard,id)
    f (HsPVar n) | isTypePlaceholder n = return (HsPWildCard,id)
    f (HsPAsPat n p) | isTypePlaceholder n = f p
    f (HsPTypeSig _ p _) = f p
    f p@HsPLit {} = return (p,id)
    f (HsPVar n) = do
        v <- convertVar (toName Name.Val n)
        return (HsPWildCard,if EVar v /=  b then eLet v b else id)
    f (HsPAsPat n p) = do
        (p',g') <- f p
        v <- convertVar (toName Name.Val n)
        return (p',(if EVar v /= b then eLet v b else id) . g')
    f pa@(HsPApp n [p]) = do
        dataTable <- getDataTable
        patCons <- getConstructor (toName DataConstructor n) dataTable
        case conChildren patCons of
            DataAlias ErasedAlias -> f p
            _ -> return (pa,id)
    f p@HsPApp {} = return (p,id)
    f (HsPIrrPat (Located ss p)) = f p >>= \ (p',fe) -> case p' of
        HsPWildCard -> return (p',fe)
        _ -> do
            (lbv,bv) <- varify b
            let f n = do
                v <- convertVar (toName Name.Val n)
                fe <- convertMatches [bv] [([p],const (EVar v))] (EError (show ss ++ ": Irrefutable pattern match failed") (getType v))
                return (v,fe)
            zs <- mapM f (getNamesFromHsPat p)
            return (HsPWildCard,lbv . eLetRec zs)
    f ~(HsPBangPat (Located ss (HsPAsPat v p))) = do
        (p',fe) <- f p
        v <- convertVar (toName Name.Val v)
        return (p',eStrictLet v b . fe)

-- converts a value to an updatable closure if it isn't one already.
varify b@EVar {} = return (id,b)
varify b = do
    [bv] <- newVars [getType b]
    return (eLet bv b,EVar bv)

tidyHeads
    :: E
    -> [([HsPat],E->E)]  -- [(pats,else -> value)]
    -> C [(HsPat,[HsPat],E->E)]  -- pulls the head off of each pattern, tidying it up perhaps
tidyHeads b ps = mapM f ps where
    f (~(p:ps),fe) = do
        (p',fe') <- tidyPat p b
        return (p',ps,fe' . fe)

convertMatches
    :: [E]               -- input expressions we are matching against.
    -> [([HsPat],E->E)]  -- [(pats,else -> value)]
    -> E                 -- else, what to do if nothing matches
    -> C E
convertMatches bs ms err = do
    assumps <- asks ceAssumps
    dataTable <- getDataTable
    funcs <- asks ceFuncs
    let fromInt = func_fromInt funcs
        fromInteger = func_fromInteger funcs
        fromRational = func_fromRational funcs
        isJoinPoint (EAp (EVar x) _) | getProperty prop_JOINPOINT x = True
        isJoinPoint _ = False

        match :: [E] -> [([HsPat],E->E)] -> E -> C E
        -- when we run out of arguments, we should run out of patterns. simply fold the transformers.
        match  [] ps err = return $ foldr f err ps where f (~[],fe) err = fe err
        -- when we are out of patterns, return the error term
        match _ [] err = return err
        match ~(b:bs) ps err = do
            (b',mf) <- if isEVar b then return (b,id) else do
                [ev] <- newVars [getType b]
                return $ (EVar ev, eLet ev b)
            pps <- tidyHeads b' ps
            let patternGroups = groupUnder (isHsPWildCard . fst3) pps
                f [] err = return err
                f (ps:pss) err = do
                    err' <- f pss err
                    if isEVar err' || isEError err' || isJoinPoint err' then matchGroup b' bs ps err' else do
                        [ev] <- newVars [EPi tvr { tvrType = unboxedTyUnit } $ getType err']
                        let ev' = setProperties [prop_ONESHOT, prop_JOINPOINT] ev
                        nm <- matchGroup b' bs ps (EAp (EVar ev') unboxedUnit)
                        return $ eLetRec [(ev',ELam (setProperty prop_ONESHOT tvr { tvrType = unboxedTyUnit }) err')] nm
            liftM mf $ f patternGroups err
        matchGroup b bs ps err
            | all (isHsPWildCard . fst3) ps = match bs [ (ps,e) | (_,ps,e) <- ps] err
            | Just () <- mapM_ (fromHsPLitInt . fst3) ps = do
                let tb = getType b
                (lbv,bv) <- varify b
                let gps = [ (p,[ (ps,e) |  (_,ps,e) <- xs ]) | (p,xs) <- sortGroupUnderF fst3 ps]
                    eq = EAp (func_equals funcs) tb
                    f els (HsPLit (HsInt i),ps) = do
                        let ip | abs i > integer_cutoff  = (EAp (EAp fromInteger tb) (intConvert i))
                               | otherwise =  (EAp (EAp fromInt tb) (intConvert i))
                        m <- match bs ps err
                        createIf (EAp (EAp eq bv) ip) m els
                    f els ~(HsPLit (HsFrac i),ps) = do
                        let ip = (EAp (EAp fromRational tb) (toE i))
                        m <- match bs ps err
                        createIf (EAp (EAp eq bv) ip) m els
                e <- foldlM f err gps
                return $ lbv e
            | all (isHsPString . fst3) ps = do
                (lbv,bv) <- varify b
                (eqString,_,_) <- convertValue v_eqString
                (eqUnpackedString,_,_) <- convertValue v_eqUnpackedString
                let gps = [ (p,[ (ps,fe) |  (_,ps,fe) <- xs ]) | (p,xs) <- sortGroupUnderF fst3 ps]
                    f els (HsPLit (HsString ""),ps) = do
                        m <- match bs ps err
                        return $ eCase bv [Alt (litCons { litName = dc_EmptyList, litType = tString }) m] els
                    f els ~(HsPLit (HsString s),ps) = do
                        m <- match bs ps err
                        let (s',packed) = packupString s
                        if packed
                            then return $ ifzh (EAp (EAp (EVar eqUnpackedString) s') bv) m els
                            else return $ ifzh (EAp (EAp (EVar eqString) s') bv) m els
                e <- foldlM f err gps
                return $ lbv e
            | all (isHsPLit . fst3) ps = do
                let gps = [ (p,[ (ps,fe) |  (_,ps,fe) <- xs ]) | (p,xs) <- sortGroupUnderF fst3 ps]
                    f (~(HsPLit l),ps) = do
                        m <- match bs ps err
                        return (Alt (litconvert l (getType b)) m)
                as@(_:_) <- mapM f gps
                [TVr { tvrIdent = vr }] <- newVars [Unknown]
                return $ unbox dataTable b vr $ \tvr -> eCase tvr as err
            | Just ps <- mapM pappConvert ps = do
                let gps =  sortGroupUnderF (hsPatName . fst3) ps
                    (Just patCons) = getConstructor (toName DataConstructor $ fst $ head gps) dataTable
                    f (name,ps) = do
                        let spats = hsPatPats $ fst3 (head ps)
                            _nargs = length spats
                        vs <- newVars (slotTypesHs dataTable (toName DataConstructor name) (getType b))
                        ps' <- mapM pp ps
                        m <- match (map EVar vs ++ bs) ps' err
                        deconstructionExpression dataTable (toName DataConstructor name) (getType b) vs m
                    pp (~(HsPApp n ps),rps,e)  = do
                        return $ (ps ++ rps , e)
                as@(_:_) <- mapM f gps
                case conVirtual patCons of
                    Nothing -> return $ eCase b as err
                    Just sibs -> do
                        let (Just Constructor { conChildren = DataNormal [vCons] }) = getConstructor (conInhabits patCons) dataTable
                            (Just Constructor { conOrigSlots = [SlotNormal rtype] }) = getConstructor vCons dataTable
                        [z] <- newVars [rtype]
                        let err' = if length sibs <= length as then Unknown else err
                        return $ eCase b [Alt litCons { litName = vCons, litArgs = [z], litType = getType b } (eCase (EVar z) as err')] Unknown
            | otherwise = error $ "Heterogenious list: " ++ show (map fst3 ps)
        pappConvert (p@HsPApp {},x,y) = return (p,x,y)
        pappConvert (HsPLit (HsString ""),ps,b) = return (HsPApp (nameName $ dc_EmptyList) [],ps,b)
        pappConvert (HsPLit (HsString (c:cs)),ps,b) = return (HsPApp (nameName $ dc_Cons) [HsPLit (HsChar c),HsPLit (HsString cs)],ps,b)
        pappConvert _ = fail "pappConvert"
        isHsPString (HsPLit HsString {}) = True
        isHsPString _ = False
    match bs ms err

packupString :: String -> (E,Bool)
packupString s | all (\c -> c > '\NUL' && c <= '\xff') s = (EPrim (PrimString (packString s)) [] r_bits_ptr_,True)
packupString s = (toE s,False)

actuallySpecializeE :: Monad m
    => E   -- ^ the general expression
    -> E   -- ^ the specific type
    -> m E -- ^ the specialized value
actuallySpecializeE ge st = do
    -- trace (pprint (ge, getType ge, st)) $ return ()
    liftM (foldl EAp ge)
          (specializeE (getType ge) st)

specializeE :: Monad m
    => E   -- ^ the general type
    -> E   -- ^ the specific type
    -> m [E]  -- ^ what to apply the general type to to get the specific one
specializeE gt st = do
    let f zs x | Just mm <- match (const Nothing) zs x st = mapM (g mm) (reverse zs) where
            g mm tvr = case lookup tvr mm of
                Just x -> return x
                Nothing -> fail $ "specializeE: variable not bound: " ++ pprint (((gt,st),(mm,tvr)),(zs,x))
        f zs (EPi vbind exp) = f (vbind:zs) exp
        f _ _ = fail $ render (text "specializeE: attempt to specialize types that do not unify:"
                               <$> pprint (gt,st)
                               <$> tshow  gt
                               <$> tshow st)
    f [] gt

procAllSpecs :: Monad m => DataTable -> [Type.Rule] -> [(TVr,E)] -> m ([(TVr,E)],Rules)
procAllSpecs dataTable rs ds = do
    let specMap = Map.fromListWith (++) [ (toId n,[r]) | r@Type.RuleSpec { Type.ruleName = n } <- rs]
        f (t,e) | Just rs <- Map.lookup (tvrIdent t) specMap = do
            hs <- mapM (makeSpec dataTable (t,e)) rs
            return (unzip hs)
        f _ = return mempty
    (nds,rules) <- mconcat `liftM` mapM f ds
    return $ (nds,fromRules rules)

makeSpec :: Monad m => DataTable -> (TVr,E) -> T.Rule -> m ((TVr,E),Rule)
makeSpec dataTable (t,e) T.RuleSpec { T.ruleType = rt, T.ruleUniq = (Module m,ui), T.ruleSuper = ss } = do
    let nt = removeNewtypes dataTable $ tipe rt
    as <- specializeE (getType t) nt
    let ntvr = tvr { tvrIdent = toId newName, tvrType = getType nbody, tvrInfo = setProperties (prop_SPECIALIZATION:sspec) mempty }
        Just nn = fromId (tvrIdent t)
        (ntype,Just (show -> m),q) = nameParts nn
        newName = toName ntype (Just $ toModule ("Spec@." ++ m ++ "." ++ show ui),'f':m ++ "." ++ q)
        sspec = if ss then [prop_SUPERSPECIALIZE] else []
        ar = makeRule ("Specialize.{" ++ show newName) (toModule m,ui) RuleSpecialization bvars t as (foldl eAp (EVar ntvr) (map EVar bvars))
        bvars = nub $ freeVars as
        nbody = foldr ELam (foldl EAp e as) bvars
    return ((ntvr,nbody),ar)
makeSpec _ _ _ = fail "E.FromHs.makeSpec: invalid specialization"

deNewtype :: DataTable -> E -> E
deNewtype dataTable e = removeNewtypes dataTable (f e) where
    f ECase { eCaseScrutinee = e, eCaseAlts = ((Alt (LitCons { litName = n, litArgs = [v], litType = t }) z):_) } | alias == DataAlias ErasedAlias = f (eLet v e z) where
        Identity Constructor { conChildren = alias } = getConstructor n dataTable
    f ECase { eCaseScrutinee = e, eCaseAlts =  ((Alt (LitCons { litName = n, litArgs = [v], litType = t }) z):_) } | alias == DataAlias RecursiveAlias = f $ eLet v (prim_unsafeCoerce e (getType v)) z where
        Identity Constructor { conChildren = alias } = getConstructor n dataTable
    f e = runIdentity $ emapE (return . f) e

ffiTypeInfo bad t cont = do
    dataTable <- getDataTable
    case lookupExtTypeInfo dataTable t of
        Just r -> cont r
        Nothing -> do
            sl <- getSrcLoc
            liftIO $ warn sl InvalidFFIType $ printf "Type '%s' cannot be used in a foreign declaration" (pprint t :: String)
            return bad

unboxedVersion t = do
    ffiTypeInfo Unknown t $ \eti -> case eti of
        ExtTypeBoxed _ uv _ -> return uv
        ExtTypeRaw _ -> return t
        ExtTypeVoid -> return (eTuple' [])

marshallToC e te = do
    ffiTypeInfo Unknown te $ \eti -> do
    case eti of
        ExtTypeBoxed cna sta _ -> do
            [tvra] <- newVars [sta]
            return $ eCase e
                           [Alt (litCons { litName = cna, litArgs = [tvra], litType = te })
                                (EVar tvra)]
                           Unknown
        ExtTypeRaw _ -> return e
        ExtTypeVoid -> fail "marshallToC: trying to marshall void"
marshallFromC ce te = do
    ffiTypeInfo Unknown te $ \eti -> do
    case eti of
        ExtTypeBoxed cna _ _ -> return $ ELit (litCons { litName = cna, litArgs = [ce], litType = te })
        ExtTypeRaw _ -> return ce
        ExtTypeVoid -> fail "marshallFromC: trying to marshall void"

extractUnboxedTup :: E -> ([E] -> C E) -> C E
extractUnboxedTup e f = do
    vs <- newVars $ concat (fromTuple_ (getType e))
    a <- f (map EVar vs)
    return $ eCaseTup' e vs a