From c073f23aba6d88a9479a20ccb53bb98a338638db Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Thu, 10 Feb 2011 13:45:28 +0000 Subject: [PATCH] Add unboxed tuple support to Template Haskell --- compiler/deSugar/DsMeta.hs | 51 ++++++++++++++++++++++++++++++++------------ compiler/hsSyn/Convert.lhs | 14 ++++++++++++ 2 files changed, 51 insertions(+), 14 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 5da376b..af67979 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -614,10 +614,14 @@ repTy (HsPArrTy t) = do t1 <- repLTy t tcon <- repTy (HsTyVar (tyConName parrTyCon)) repTapp tcon t1 -repTy (HsTupleTy _ tys) = do +repTy (HsTupleTy Boxed tys) = do tys1 <- repLTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 +repTy (HsTupleTy Unboxed tys) = do + tys1 <- repLTys tys + tcon <- repUnboxedTupleTyCon (length tys) + repTapps tcon tys1 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) `nlHsAppTy` ty2) repTy (HsParTy t) = repLTy t @@ -738,9 +742,9 @@ repE e@(HsDo ctxt sts body _) repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple es boxed) - | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e) | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) - | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs } + | isBoxed boxed = do { xs <- repLEs [e | Present e <- es]; repTup xs } + | otherwise = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs } repE (RecordCon c _ flds) = do { x <- lookupLOcc c; @@ -1020,9 +1024,9 @@ repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } repP (ParPat p) = repLP p repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } -repP p@(TuplePat ps boxed _) - | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p) - | otherwise = do { qs <- repLPs ps; repPtup qs } +repP (TuplePat ps boxed _) + | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } + | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of @@ -1247,6 +1251,9 @@ repPvar (MkC s) = rep2 varPName [s] repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) repPtup (MkC ps) = rep2 tupPName [ps] +repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) +repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] + repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ) repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] @@ -1297,6 +1304,9 @@ repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) repTup (MkC es) = rep2 tupEName [es] +repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) +repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] + repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] @@ -1518,6 +1528,10 @@ repTupleTyCon :: Int -> DsM (Core TH.TypeQ) -- Note: not Core Int; it's easier to be direct here repTupleTyCon i = rep2 tupleTName [mkIntExprInt i] +repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ) +-- Note: not Core Int; it's easier to be direct here +repUnboxedTupleTyCon i = rep2 unboxedTupleTName [mkIntExprInt i] + repArrowTyCon :: DsM (Core TH.TypeQ) repArrowTyCon = rep2 arrowTName [] @@ -1668,7 +1682,8 @@ templateHaskellNames = [ charLName, stringLName, integerLName, intPrimLName, wordPrimLName, floatPrimLName, doublePrimLName, rationalLName, -- Pat - litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName, + litPName, varPName, tupPName, unboxedTupPName, + conPName, tildePName, bangPName, infixPName, asPName, wildPName, recPName, listPName, sigPName, viewPName, -- FieldPat fieldPatName, @@ -1678,7 +1693,8 @@ templateHaskellNames = [ clauseName, -- Exp varEName, conEName, litEName, appEName, infixEName, - infixAppName, sectionLName, sectionRName, lamEName, tupEName, + infixAppName, sectionLName, sectionRName, lamEName, + tupEName, unboxedTupEName, condEName, letEName, caseEName, doEName, compEName, fromEName, fromThenEName, fromToEName, fromThenToEName, listEName, sigEName, recConEName, recUpdEName, @@ -1805,11 +1821,12 @@ doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey rationalLName = libFun (fsLit "rationalL") rationalLIdKey -- data Pat = ... -litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName, +litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name litPName = libFun (fsLit "litP") litPIdKey varPName = libFun (fsLit "varP") varPIdKey tupPName = libFun (fsLit "tupP") tupPIdKey +unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey conPName = libFun (fsLit "conP") conPIdKey infixPName = libFun (fsLit "infixP") infixPIdKey tildePName = libFun (fsLit "tildeP") tildePIdKey @@ -1835,7 +1852,7 @@ clauseName = libFun (fsLit "clause") clauseIdKey -- data Exp = ... varEName, conEName, litEName, appEName, infixEName, infixAppName, - sectionLName, sectionRName, lamEName, tupEName, condEName, + sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName, letEName, caseEName, doEName, compEName :: Name varEName = libFun (fsLit "varE") varEIdKey conEName = libFun (fsLit "conE") conEIdKey @@ -1847,6 +1864,7 @@ sectionLName = libFun (fsLit "sectionL") sectionLIdKey sectionRName = libFun (fsLit "sectionR") sectionRIdKey lamEName = libFun (fsLit "lamE") lamEIdKey tupEName = libFun (fsLit "tupE") tupEIdKey +unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey condEName = libFun (fsLit "condE") condEIdKey letEName = libFun (fsLit "letE") letEIdKey caseEName = libFun (fsLit "caseE") caseEIdKey @@ -1939,12 +1957,13 @@ varStrictTypeName :: Name varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey -- data Type = ... -forallTName, varTName, conTName, tupleTName, arrowTName, +forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName, listTName, appTName, sigTName :: Name forallTName = libFun (fsLit "forallT") forallTIdKey varTName = libFun (fsLit "varT") varTIdKey conTName = libFun (fsLit "conT") conTIdKey tupleTName = libFun (fsLit "tupleT") tupleTIdKey +unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey arrowTName = libFun (fsLit "arrowT") arrowTIdKey listTName = libFun (fsLit "listT") listTIdKey appTName = libFun (fsLit "appT") appTIdKey @@ -2084,11 +2103,12 @@ liftStringIdKey :: Unique liftStringIdKey = mkPreludeMiscIdUnique 218 -- data Pat = ... -litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, +litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique litPIdKey = mkPreludeMiscIdUnique 220 varPIdKey = mkPreludeMiscIdUnique 221 tupPIdKey = mkPreludeMiscIdUnique 222 +unboxedTupPIdKey = mkPreludeMiscIdUnique 362 conPIdKey = mkPreludeMiscIdUnique 223 infixPIdKey = mkPreludeMiscIdUnique 312 tildePIdKey = mkPreludeMiscIdUnique 224 @@ -2115,7 +2135,8 @@ clauseIdKey = mkPreludeMiscIdUnique 232 -- data Exp = ... varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, - sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey, + sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey, + condEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey, fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique @@ -2129,6 +2150,7 @@ sectionLIdKey = mkPreludeMiscIdUnique 246 sectionRIdKey = mkPreludeMiscIdUnique 247 lamEIdKey = mkPreludeMiscIdUnique 248 tupEIdKey = mkPreludeMiscIdUnique 249 +unboxedTupEIdKey = mkPreludeMiscIdUnique 263 condEIdKey = mkPreludeMiscIdUnique 250 letEIdKey = mkPreludeMiscIdUnique 251 caseEIdKey = mkPreludeMiscIdUnique 252 @@ -2217,12 +2239,13 @@ varStrictTKey :: Unique varStrictTKey = mkPreludeMiscIdUnique 287 -- data Type = ... -forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey, +forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey :: Unique forallTIdKey = mkPreludeMiscIdUnique 290 varTIdKey = mkPreludeMiscIdUnique 291 conTIdKey = mkPreludeMiscIdUnique 292 tupleTIdKey = mkPreludeMiscIdUnique 294 +unboxedTupleTIdKey = mkPreludeMiscIdUnique 361 arrowTIdKey = mkPreludeMiscIdUnique 295 listTIdKey = mkPreludeMiscIdUnique 296 appTIdKey = mkPreludeMiscIdUnique 293 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index dcef02f..b5e6c41 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -268,6 +268,7 @@ cvt_tyinst_hdr cxt tc tys collect (VarT tv) = return [PlainTV tv] collect (ConT _) = return [] collect (TupleT _) = return [] + collect (UnboxedTupleT _) = return [] collect ArrowT = return [] collect ListT = return [] collect (AppT t1 t2) @@ -464,6 +465,8 @@ cvtl e = wrapL (cvt e) ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed } + cvt (UnboxedTupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens) + cvt (UnboxedTupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed } cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; ; return $ HsIf (Just noSyntaxExpr) x' y' z' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds @@ -626,6 +629,8 @@ cvtp (TH.LitP l) cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' } cvtp (TupP [p]) = cvtp p cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void } +cvtp (UnboxedTupP [p]) = cvtp p +cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void } cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 ; return $ ConPatIn s' (InfixCon p1' p2') } @@ -697,6 +702,15 @@ cvtType ty -> failWith (ptext (sLit "Illegal 1-tuple type constructor")) | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys' + UnboxedTupleT n + | length tys' == n -- Saturated + -> if n==1 then return (head tys') -- Singleton tuples treated + -- like nothing (ie just parens) + else returnL (HsTupleTy Unboxed tys') + | n == 1 + -> failWith (ptext (sLit "Illegal 1-unboxed-tuple type constructor")) + | otherwise + -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys' ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys' -- 1.7.10.4