Commit ec3c7841 authored by andy@galois.com's avatar andy@galois.com

Adding arrows to the acceptable code for hpc

parent dd8c1ab2
......@@ -266,20 +266,28 @@ addTickHsExpr (HsWrap w e) =
liftM2 HsWrap
(return w)
(addTickHsExpr e) -- explicitly no tick on inside
addTickHsExpr (HsArrApp {}) = error "addTickHsExpr: HsArrApp "
addTickHsExpr (HsArrForm {}) = error "addTickHsExpr: HsArrForm"
addTickHsExpr (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp
(addTickLHsExpr e1)
(addTickLHsExpr e2)
(return ty1)
(return arr_ty)
(return lr)
addTickHsExpr (HsArrForm e fix cmdtop) =
liftM3 HsArrForm
(addTickLHsExpr e)
(return fix)
(mapM (liftL addTickHsCmdTop) cmdtop)
addTickHsExpr e@(HsType ty) = return e
-- Should never happen in expression content.
addTickHsExpr (EAsPat _ _) = error "addTickHsExpr: EAsPat _ _"
addTickHsExpr (ELazyPat _) = error "addTickHsExpr: ELazyPat _"
addTickHsExpr (EWildPat) = error "addTickHsExpr: EWildPat"
addTickHsExpr (HsBinTick _ _ _) = error "addTickhsExpr: HsBinTick _ _ _"
addTickHsExpr (HsTick _ _) = error "addTickhsExpr: HsTick _ _"
addTickHsExpr e@(HsType ty) = return e
-- catch all, and give an error message.
--addTickHsExpr e = error ("addTickLhsExpr: " ++ showSDoc (ppr e))
addTickMatchGroup (MatchGroup matches ty) = do
let isOneOfMany = True -- AJG: for now
matches' <- mapM (liftL (addTickMatch isOneOfMany)) matches
......
......@@ -586,6 +586,12 @@ dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args)
returnDs (mkApps (App core_op (Type env_ty)) core_args,
unionVarSets fv_sets)
dsCmd ids local_vars env_ids stack res_ty (HsTick ix expr)
= dsLCmd ids local_vars env_ids stack res_ty expr `thenDs` \ (expr1,id_set) ->
mkTickBox ix expr1 `thenDs` \ expr2 ->
return (expr2,id_set)
-- A | ys |- c :: [ts] t (ys <= xs)
-- ---------------------
-- A | xs |- c :: [ts] t ---> arr_ts (\ (xs) -> (ys)) >>> c
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment