| isAlgTyCon tcon = tdef: tdefs
where
tdef | isNewTyCon tcon =
- C.Newtype (qtc tcon) (map make_tbind tyvars)
+ C.Newtype (qtc tcon)
(case newTyConCo_maybe tcon of
- Just co -> (qtc co,
- map make_tbind vs,
- make_kind (mkCoKind l r))
- where (vs,l,r) = coercionAxiom co
+ Just co -> qtc co
Nothing -> pprPanic ("MkExternalCore: newtype tcon\
should have a coercion: ") (ppr tcon))
- repclause
+ (map make_tbind tyvars)
+ (make_ty (snd (newTyConRhs tcon)))
| otherwise =
C.Data (qtc tcon) (map make_tbind tyvars)
(map make_cdef (tyConDataCons tcon))
- where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing
- | otherwise = Just (make_ty (snd (newTyConRhs tcon)))
tyvars = tyConTyVars tcon
- coercionAxiom co =
- case isCoercionTyCon_maybe co of
- -- See Note [Newtype coercions] in
- -- types/TyCon
- Just (arity,coKindFun) | (l,r) <- (coKindFun $ map mkTyVarTy vs) ->
- -- Here we eta-expand the newtype coercion,
- -- which makes the ext-core typechecker somewhat simpler.
- (tyvars,mkAppTys l extraVs,mkAppTys r extraVs)
- where (vs, extraVs) = (take arity tyvars,
- map mkTyVarTy $ drop arity tyvars)
- Nothing -> pprPanic "MkExternalCore: coercion tcon lacks a kind fun"
- (ppr tcon)
collect_tdefs _ tdefs = tdefs
make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
make_vbind :: Var -> C.Vbind
-make_vbind v = (make_var_id (Var.varName v), make_ty (idType v))
+make_vbind v = (make_var_id (Var.varName v), make_ty (varType v))
make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg
make_vdef topLevel b =
let local = not topLevel || localN
rhs <- make_exp e
-- use local flag to determine where to add the module name
- return (local, make_qid local True vName, make_ty (idType v),rhs)
+ return (local, make_qid local True vName, make_ty (varType v),rhs)
where vName = Var.varName v
make_exp :: CoreExpr -> CoreM C.Exp
let vName = Var.varName v
isLocal <- isALocal vName
return $
- case globalIdDetails v of
+ case globalIdVarDetails v of
FCallId (CCall (CCallSpec (StaticTarget nm) callconv _))
- -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (idType v))
+ -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v))
FCallId (CCall (CCallSpec DynamicTarget callconv _))
- -> C.DynExternal (showSDoc (ppr callconv)) (make_ty (idType v))
+ -> C.DynExternal (showSDoc (ppr callconv)) (make_ty (varType v))
FCallId _
-> pprPanic "MkExternalCore died: can't handle non-{static,dynamic}-C foreign call"
(ppr v)
return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts
make_exp (Note (SCC _) e) = make_exp e >>= (return . C.Note "SCC") -- temporary
make_exp (Note (CoreNote s) e) = make_exp e >>= (return . C.Note s) -- hdaume: core annotations
-make_exp (Note InlineMe e) = make_exp e >>= (return . C.Note "InlineMe")
make_exp _ = error "MkExternalCore died: make_exp"
make_alt :: CoreAlt -> CoreM C.Alt
make_ty' (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
make_ty' (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
make_ty' (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
-make_ty' (TyConApp tc ts) = foldl C.Tapp (C.Tcon (qtc tc))
- (map make_ty ts)
+make_ty' (TyConApp tc ts) = make_tyConApp tc ts
+
-- Newtypes are treated just like any other type constructor; not expanded
-- Reason: predTypeRep does substitution and, while substitution deals
-- correctly with name capture, it's only correct if you see the uniques!
make_ty' (PredTy p) = make_ty (predTypeRep p)
+make_tyConApp :: TyCon -> [Type] -> C.Ty
+make_tyConApp tc [t1, t2] | tc == transCoercionTyCon =
+ C.TransCoercion (make_ty t1) (make_ty t2)
+make_tyConApp tc [t] | tc == symCoercionTyCon =
+ C.SymCoercion (make_ty t)
+make_tyConApp tc [t1, t2] | tc == unsafeCoercionTyCon =
+ C.UnsafeCoercion (make_ty t1) (make_ty t2)
+make_tyConApp tc [t] | tc == leftCoercionTyCon =
+ C.LeftCoercion (make_ty t)
+make_tyConApp tc [t] | tc == rightCoercionTyCon =
+ C.RightCoercion (make_ty t)
+make_tyConApp tc [t1, t2] | tc == instCoercionTyCon =
+ C.InstCoercion (make_ty t1) (make_ty t2)
+-- this fails silently if we have an application
+-- of a wired-in coercion tycon to the wrong number of args.
+-- Not great...
+make_tyConApp tc ts =
+ foldl C.Tapp (C.Tcon (qtc tc))
+ (map make_ty ts)
make_kind :: Kind -> C.Kind