Commit c073f23a authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Add unboxed tuple support to Template Haskell

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