Commit 3234a4ad authored by Simon Peyton Jones's avatar Simon Peyton Jones

Add OverloadedLists, allowing list syntax to be overloaded

This work was all done by
   Achim Krause <achim.t.krause@gmail.com>
   George Giorgidze <giorgidze@gmail.com>
   Weijers Jeroen <jeroen.weijers@uni-tuebingen.de>

It allows list syntax, such as [a,b], [a..b] and so on, to be
overloaded so that it works for a variety of types.

The design is described here:
    http://hackage.haskell.org/trac/ghc/wiki/OverloadedLists

Eg. you can use it for maps, so that
        [(1,"foo"), (4,"bar")] :: Map Int String

The main changes
 * The ExplicitList constructor of HsExpr gets witness field
 * Ditto ArithSeq constructor
 * Ditto the ListPat constructor of HsPat

Everything else flows from this.
parent 6571f4f1
...@@ -141,8 +141,9 @@ untidy b (L loc p) = L loc (untidy' b p) ...@@ -141,8 +141,9 @@ untidy b (L loc p) = L loc (untidy' b p)
untidy' _ (LitPat lit) = LitPat (untidy_lit lit) untidy' _ (LitPat lit) = LitPat (untidy_lit lit)
untidy' _ p@(ConPatIn _ (PrefixCon [])) = p untidy' _ p@(ConPatIn _ (PrefixCon [])) = p
untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps))) untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps)))
untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing
untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty untidy' _ (TuplePat pats box ty) = TuplePat (map untidy_no_pars pats) box ty
untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"
untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
untidy' _ (LazyPat {}) = panic "Check.untidy: LazyPat" untidy' _ (LazyPat {}) = panic "Check.untidy: LazyPat"
...@@ -568,15 +569,15 @@ is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon ...@@ -568,15 +569,15 @@ is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon
is_nil _ = False is_nil _ = False
is_list :: Pat Name -> Bool is_list :: Pat Name -> Bool
is_list (ListPat _ _) = True is_list (ListPat _ _ Nothing) = True
is_list _ = False is_list _ = False
return_list :: DataCon -> Pat Name -> Bool return_list :: DataCon -> Pat Name -> Bool
return_list id q = id == consDataCon && (is_nil q || is_list q) return_list id q = id == consDataCon && (is_nil q || is_list q)
make_list :: LPat Name -> Pat Name -> Pat Name make_list :: LPat Name -> Pat Name -> Pat Name
make_list p q | is_nil q = ListPat [p] placeHolderType make_list p q | is_nil q = ListPat [p] placeHolderType Nothing
make_list p (ListPat ps ty) = ListPat (p:ps) ty make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing
make_list _ _ = panic "Check.make_list: Invalid argument" make_list _ _ = panic "Check.make_list: Invalid argument"
make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat
...@@ -647,7 +648,8 @@ might_fail_pat (ViewPat _ p _) = not (isIrrefutableHsPat p) ...@@ -647,7 +648,8 @@ might_fail_pat (ViewPat _ p _) = not (isIrrefutableHsPat p)
might_fail_pat (ParPat p) = might_fail_lpat p might_fail_pat (ParPat p) = might_fail_lpat p
might_fail_pat (AsPat _ p) = might_fail_lpat p might_fail_pat (AsPat _ p) = might_fail_lpat p
might_fail_pat (SigPatOut p _ ) = might_fail_lpat p might_fail_pat (SigPatOut p _ ) = might_fail_lpat p
might_fail_pat (ListPat ps _) = any might_fail_lpat ps might_fail_pat (ListPat ps _ Nothing) = any might_fail_lpat ps
might_fail_pat (ListPat _ _ (Just _)) = True
might_fail_pat (TuplePat ps _ _) = any might_fail_lpat ps might_fail_pat (TuplePat ps _ _) = any might_fail_lpat ps
might_fail_pat (PArrPat ps _) = any might_fail_lpat ps might_fail_pat (PArrPat ps _) = any might_fail_lpat ps
might_fail_pat (BangPat p) = might_fail_lpat p might_fail_pat (BangPat p) = might_fail_lpat p
...@@ -682,11 +684,12 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat ...@@ -682,11 +684,12 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat
-- guard says "this equation might fall through". -- guard says "this equation might fall through".
tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id)) tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
tidy_pat (ViewPat _ _ ty) = WildPat ty tidy_pat (ViewPat _ _ ty) = WildPat ty
tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty
tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps }) tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps })
= pat { pat_args = tidy_con id ps } = pat { pat_args = tidy_con id ps }
tidy_pat (ListPat ps ty) tidy_pat (ListPat ps ty Nothing)
= unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty)
(mkNilPat list_ty) (mkNilPat list_ty)
(map tidy_lpat ps) (map tidy_lpat ps)
......
...@@ -519,10 +519,14 @@ addTickHsExpr (HsDo cxt stmts srcloc) ...@@ -519,10 +519,14 @@ addTickHsExpr (HsDo cxt stmts srcloc)
forQual = case cxt of forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox ListComp -> Just $ BinBox QualBinBox
_ -> Nothing _ -> Nothing
addTickHsExpr (ExplicitList ty es) = addTickHsExpr (ExplicitList ty wit es) =
liftM2 ExplicitList liftM3 ExplicitList
(return ty) (return ty)
(mapM (addTickLHsExpr) es) (addTickWit wit)
(mapM (addTickLHsExpr) es)
where addTickWit Nothing = return Nothing
addTickWit (Just fln) = do fln' <- addTickHsExpr fln
return (Just fln')
addTickHsExpr (ExplicitPArr ty es) = addTickHsExpr (ExplicitPArr ty es) =
liftM2 ExplicitPArr liftM2 ExplicitPArr
(return ty) (return ty)
...@@ -543,10 +547,14 @@ addTickHsExpr (ExprWithTySigOut e ty) = ...@@ -543,10 +547,14 @@ addTickHsExpr (ExprWithTySigOut e ty) =
(addTickLHsExprNever e) -- No need to tick the inner expression (addTickLHsExprNever e) -- No need to tick the inner expression
-- for expressions with signatures -- for expressions with signatures
(return ty) (return ty)
addTickHsExpr (ArithSeq ty arith_seq) = addTickHsExpr (ArithSeq ty wit arith_seq) =
liftM2 ArithSeq liftM3 ArithSeq
(return ty) (return ty)
(addTickWit wit)
(addTickArithSeqInfo arith_seq) (addTickArithSeqInfo arith_seq)
where addTickWit Nothing = return Nothing
addTickWit (Just fl) = do fl' <- addTickHsExpr fl
return (Just fl')
addTickHsExpr (HsTickPragma _ (L pos e0)) = do addTickHsExpr (HsTickPragma _ (L pos e0)) = do
e2 <- allocTickBox (ExpBox False) False False pos $ e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0 addTickHsExpr e0
......
...@@ -1091,7 +1091,7 @@ collectl (L _ pat) bndrs ...@@ -1091,7 +1091,7 @@ collectl (L _ pat) bndrs
go (AsPat (L _ a) pat) = a : collectl pat bndrs go (AsPat (L _ a) pat) = a : collectl pat bndrs
go (ParPat pat) = collectl pat bndrs go (ParPat pat) = collectl pat bndrs
go (ListPat pats _) = foldr collectl bndrs pats go (ListPat pats _ _) = foldr collectl bndrs pats
go (PArrPat pats _) = foldr collectl bndrs pats go (PArrPat pats _) = foldr collectl bndrs pats
go (TuplePat pats _ _) = foldr collectl bndrs pats go (TuplePat pats _ _) = foldr collectl bndrs pats
......
...@@ -350,8 +350,8 @@ dsExpr (HsMultiIf res_ty alts) ...@@ -350,8 +350,8 @@ dsExpr (HsMultiIf res_ty alts)
\underline{\bf Various data construction things} \underline{\bf Various data construction things}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code} \begin{code}
dsExpr (ExplicitList elt_ty xs) dsExpr (ExplicitList elt_ty wit xs)
= dsExplicitList elt_ty xs = dsExplicitList elt_ty wit xs
-- We desugar [:x1, ..., xn:] as -- We desugar [:x1, ..., xn:] as
-- singletonP x1 +:+ ... +:+ singletonP xn -- singletonP x1 +:+ ... +:+ singletonP xn
...@@ -368,17 +368,13 @@ dsExpr (ExplicitPArr ty xs) = do ...@@ -368,17 +368,13 @@ dsExpr (ExplicitPArr ty xs) = do
unary fn x = mkApps (Var fn) [Type ty, x] unary fn x = mkApps (Var fn) [Type ty, x]
binary fn x y = mkApps (Var fn) [Type ty, x, y] binary fn x y = mkApps (Var fn) [Type ty, x, y]
dsExpr (ArithSeq expr (From from)) dsExpr (ArithSeq expr witness seq)
= App <$> dsExpr expr <*> dsLExpr from = case witness of
Nothing -> dsArithSeq expr seq
dsExpr (ArithSeq expr (FromTo from to)) Just fl -> do {
= mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] ; fl' <- dsExpr fl
; newArithSeq <- dsArithSeq expr seq
dsExpr (ArithSeq expr (FromThen from thn)) ; return (App fl' newArithSeq)}
= mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
dsExpr (ArithSeq expr (FromThenTo from thn to))
= mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
dsExpr (PArrSeq expr (FromTo from to)) dsExpr (PArrSeq expr (FromTo from to))
= mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
...@@ -673,9 +669,9 @@ makes all list literals be generated via the simple route. ...@@ -673,9 +669,9 @@ makes all list literals be generated via the simple route.
\begin{code} \begin{code}
dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr dsExplicitList :: PostTcType -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -> DsM CoreExpr
-- See Note [Desugaring explicit lists] -- See Note [Desugaring explicit lists]
dsExplicitList elt_ty xs dsExplicitList elt_ty Nothing xs
= do { dflags <- getDynFlags = do { dflags <- getDynFlags
; xs' <- mapM dsLExpr xs ; xs' <- mapM dsLExpr xs
; let (dynamic_prefix, static_suffix) = spanTail is_static xs' ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'
...@@ -700,9 +696,25 @@ dsExplicitList elt_ty xs ...@@ -700,9 +696,25 @@ dsExplicitList elt_ty xs
; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix' ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'
; return (foldr (App . App (Var c)) folded_suffix prefix) } ; return (foldr (App . App (Var c)) folded_suffix prefix) }
dsExplicitList elt_ty (Just fln) xs
= do { fln' <- dsExpr fln
; list <- dsExplicitList elt_ty Nothing xs
; dflags <- getDynFlags
; return (App (App fln' (mkIntExprInt dflags (length xs))) list) }
spanTail :: (a -> Bool) -> [a] -> ([a], [a]) spanTail :: (a -> Bool) -> [a] -> ([a], [a])
spanTail f xs = (reverse rejected, reverse satisfying) spanTail f xs = (reverse rejected, reverse satisfying)
where (satisfying, rejected) = span f $ reverse xs where (satisfying, rejected) = span f $ reverse xs
dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr
dsArithSeq expr (From from)
= App <$> dsExpr expr <*> dsLExpr from
dsArithSeq expr (FromTo from to)
= mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
dsArithSeq expr (FromThen from thn)
= mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
dsArithSeq expr (FromThenTo from thn to)
= mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]
\end{code} \end{code}
Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
......
...@@ -970,7 +970,7 @@ repE e@(HsDo ctxt sts _) ...@@ -970,7 +970,7 @@ repE e@(HsDo ctxt sts _)
| otherwise | otherwise
= notHandled "mdo, monad comprehension and [: :]" (ppr e) = notHandled "mdo, monad comprehension and [: :]" (ppr e)
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 (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
...@@ -987,7 +987,7 @@ repE (RecordUpd e flds _ _ _) ...@@ -987,7 +987,7 @@ repE (RecordUpd e flds _ _ _)
repRecUpd x fs } repRecUpd x fs }
repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 } repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
repE (ArithSeq _ aseq) = repE (ArithSeq _ _ aseq) =
case aseq of case aseq of
From e -> do { ds1 <- repLE e; repFrom ds1 } From e -> do { ds1 <- repLE e; repFrom ds1 }
FromThen e1 e2 -> do FromThen e1 e2 -> do
...@@ -1259,7 +1259,8 @@ repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } ...@@ -1259,7 +1259,8 @@ repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } 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 _ Nothing) = do { qs <- repLPs ps; repPlist qs }
repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p}
repP (TuplePat ps boxed _) repP (TuplePat ps boxed _)
| isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
| otherwise = do { qs <- repLPs ps; repPunboxedTup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
......
...@@ -17,7 +17,7 @@ module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ...@@ -17,7 +17,7 @@ module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat
#include "HsVersions.h" #include "HsVersions.h"
import {-#SOURCE#-} DsExpr (dsLExpr) import {-#SOURCE#-} DsExpr (dsLExpr, dsExpr)
import DynFlags import DynFlags
import HsSyn import HsSyn
...@@ -53,7 +53,7 @@ import qualified Data.Map as Map ...@@ -53,7 +53,7 @@ import qualified Data.Map as Map
\end{code} \end{code}
This function is a wrapper of @match@, it must be called from all the parts where This function is a wrapper of @match@, it must be called from all the parts where
it was called match, but only substitutes the firs call, .... it was called match, but only substitutes the first call, ....
if the associated flags are declared, warnings will be issued. if the associated flags are declared, warnings will be issued.
It can not be called matchWrapper because this name already exists :-( It can not be called matchWrapper because this name already exists :-(
...@@ -327,12 +327,13 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty ...@@ -327,12 +327,13 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty
PgBang -> matchBangs vars ty (dropGroup eqns) PgBang -> matchBangs vars ty (dropGroup eqns)
PgCo _ -> matchCoercion vars ty (dropGroup eqns) PgCo _ -> matchCoercion vars ty (dropGroup eqns)
PgView _ _ -> matchView vars ty (dropGroup eqns) PgView _ _ -> matchView vars ty (dropGroup eqns)
PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
-- FIXME: we should also warn about view patterns that should be -- FIXME: we should also warn about view patterns that should be
-- commoned up but are not -- commoned up but are not
-- print some stuff to see what's getting grouped -- print some stuff to see what's getting grouped
-- use -dppr-debug to see the resolution of overloaded lits -- use -dppr-debug to see the resolution of overloaded literals
debug eqns = debug eqns =
let gs = map (\group -> foldr (\ (p,_) -> \acc -> let gs = map (\group -> foldr (\ (p,_) -> \acc ->
case p of PgView e _ -> e:acc case p of PgView e _ -> e:acc
...@@ -391,19 +392,33 @@ matchView (var:vars) ty (eqns@(eqn1:_)) ...@@ -391,19 +392,33 @@ matchView (var:vars) ty (eqns@(eqn1:_))
; return (mkViewMatchResult var' viewExpr' var match_result) } ; return (mkViewMatchResult var' viewExpr' var match_result) }
matchView _ _ _ = panic "matchView" matchView _ _ _ = panic "matchView"
matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
-- Since overloaded list patterns are treated as view patterns,
-- the code is roughly the same as for matchView
= do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1
; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand
; match_result <- match (var':vars) ty $
map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
; e' <- dsExpr e
; return (mkViewMatchResult var' e' var match_result) }
matchOverloadedList _ _ _ = panic "matchOverloadedList"
-- decompose the first pattern and leave the rest alone -- decompose the first pattern and leave the rest alone
decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
= eqn { eqn_pats = extractpat pat : pats} = eqn { eqn_pats = extractpat pat : pats}
decomposeFirstPat _ _ = panic "decomposeFirstPat" decomposeFirstPat _ _ = panic "decomposeFirstPat"
getCoPat, getBangPat, getViewPat :: Pat Id -> Pat Id getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id
getCoPat (CoPat _ pat _) = pat getCoPat (CoPat _ pat _) = pat
getCoPat _ = panic "getCoPat" getCoPat _ = panic "getCoPat"
getBangPat (BangPat pat ) = unLoc pat getBangPat (BangPat pat ) = unLoc pat
getBangPat _ = panic "getBangPat" getBangPat _ = panic "getBangPat"
getViewPat (ViewPat _ pat _) = unLoc pat getViewPat (ViewPat _ pat _) = unLoc pat
getViewPat _ = panic "getBangPat" getViewPat _ = panic "getViewPat"
getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing
getOLPat _ = panic "getOLPat"
\end{code} \end{code}
Note [Empty case alternatives] Note [Empty case alternatives]
...@@ -536,7 +551,7 @@ tidy1 v (LazyPat pat) ...@@ -536,7 +551,7 @@ tidy1 v (LazyPat pat)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
; return (mkCoreLets sel_binds, WildPat (idType v)) } ; return (mkCoreLets sel_binds, WildPat (idType v)) }
tidy1 _ (ListPat pats ty) tidy1 _ (ListPat pats ty Nothing)
= return (idDsWrapper, unLoc list_ConPat) = return (idDsWrapper, unLoc list_ConPat)
where where
list_ty = mkListTy ty list_ty = mkListTy ty
...@@ -831,7 +846,8 @@ data PatGroup ...@@ -831,7 +846,8 @@ data PatGroup
| PgView (LHsExpr Id) -- view pattern (e -> p): | PgView (LHsExpr Id) -- view pattern (e -> p):
-- the LHsExpr is the expression e -- the LHsExpr is the expression e
Type -- the Type is the type of p (equivalently, the result type of e) Type -- the Type is the type of p (equivalently, the result type of e)
| PgOverloadedList
groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]] groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
-- If the result is of form [g1, g2, g3], -- If the result is of form [g1, g2, g3],
-- (a) all the (pg,eq) pairs in g1 have the same pg -- (a) all the (pg,eq) pairs in g1 have the same pg
...@@ -885,7 +901,7 @@ sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 ...@@ -885,7 +901,7 @@ sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2
-- always have the same type, so this boils down to saying that -- always have the same type, so this boils down to saying that
-- the two coercions are identical. -- the two coercions are identical.
sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
-- ViewPats are in the same gorup iff the expressions -- ViewPats are in the same group iff the expressions
-- are "equal"---conservatively, we use syntactic equality -- are "equal"---conservatively, we use syntactic equality
sameGroup _ _ = False sameGroup _ _ = False
...@@ -1002,6 +1018,7 @@ patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust ...@@ -1002,6 +1018,7 @@ patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust
patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False)
patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern
patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))
patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList
patGroup _ pat = pprPanic "patGroup" (ppr pat) patGroup _ pat = pprPanic "patGroup" (ppr pat)
\end{code} \end{code}
......
...@@ -545,11 +545,11 @@ cvtl e = wrapL (cvt e) ...@@ -545,11 +545,11 @@ cvtl e = wrapL (cvt e)
; return $ HsCase e' (mkMatchGroup ms') } ; return $ HsCase e' (mkMatchGroup ms') }
cvt (DoE ss) = cvtHsDo DoExpr ss cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss cvt (CompE ss) = cvtHsDo ListComp ss
cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' } cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
cvt (ListE xs) cvt (ListE xs)
| Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
-- Note [Converting strings] -- Note [Converting strings]
| otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' } | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void Nothing xs' }
-- Infix expressions -- Infix expressions
cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
...@@ -806,7 +806,7 @@ cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' ...@@ -806,7 +806,7 @@ cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s'
cvtp TH.WildP = return $ WildPat void cvtp TH.WildP = return $ WildPat void
cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void Nothing }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
; return $ SigPatIn p' (mkHsWithBndrs t') } ; return $ SigPatIn p' (mkHsWithBndrs t') }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
......
...@@ -179,8 +179,9 @@ data HsExpr id ...@@ -179,8 +179,9 @@ data HsExpr id
[ExprLStmt id] -- "do":one or more stmts [ExprLStmt id] -- "do":one or more stmts
PostTcType -- Type of the whole expression PostTcType -- Type of the whole expression
| ExplicitList -- syntactic list | ExplicitList -- syntactic list
PostTcType -- Gives type of components of list PostTcType -- Gives type of components of list
(Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness
[LHsExpr id] [LHsExpr id]
| ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:]
...@@ -215,8 +216,9 @@ data HsExpr id ...@@ -215,8 +216,9 @@ data HsExpr id
(LHsType Name) -- Retain the signature for (LHsType Name) -- Retain the signature for
-- round-tripping purposes -- round-tripping purposes
| ArithSeq -- arithmetic sequence | ArithSeq -- Arithmetic sequence
PostTcExpr PostTcExpr
(Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromList witness
(ArithSeqInfo id) (ArithSeqInfo id)
| PArrSeq -- arith. sequence for parallel array | PArrSeq -- arith. sequence for parallel array
...@@ -500,7 +502,7 @@ ppr_expr (HsLet binds expr) ...@@ -500,7 +502,7 @@ ppr_expr (HsLet binds expr)
ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ exprs) ppr_expr (ExplicitList _ _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (ExplicitPArr _ exprs) ppr_expr (ExplicitPArr _ exprs)
...@@ -519,7 +521,7 @@ ppr_expr (ExprWithTySigOut expr sig) ...@@ -519,7 +521,7 @@ ppr_expr (ExprWithTySigOut expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon) = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
4 (ppr sig) 4 (ppr sig)
ppr_expr (ArithSeq _ info) = brackets (ppr info) ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
ppr_expr (PArrSeq _ info) = paBrackets (ppr info) ppr_expr (PArrSeq _ info) = paBrackets (ppr info)
ppr_expr EWildPat = char '_' ppr_expr EWildPat = char '_'
......
...@@ -67,8 +67,12 @@ data Pat id ...@@ -67,8 +67,12 @@ data Pat id
| BangPat (LPat id) -- Bang pattern | BangPat (LPat id) -- Bang pattern
------------ Lists, tuples, arrays --------------- ------------ Lists, tuples, arrays ---------------
| ListPat [LPat id] -- Syntactic list | ListPat [LPat id] -- Syntactic list
PostTcType -- The type of the elements PostTcType -- The type of the elements
(Maybe (PostTcType, SyntaxExpr id)) -- For rebindable syntax
-- For OverloadedLists a Just (ty,fn) gives
-- overall type of the pattern, and the toList
-- function to convert the scrutinee to a list value
| TuplePat [LPat id] -- Tuple | TuplePat [LPat id] -- Tuple
Boxity -- UnitPat is TuplePat [] Boxity -- UnitPat is TuplePat []
...@@ -245,7 +249,7 @@ pprPat (BangPat pat) = char '!' <> pprParendLPat pat ...@@ -245,7 +249,7 @@ pprPat (BangPat pat) = char '!' <> pprParendLPat pat
pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat] pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat]
pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
pprPat (ParPat pat) = parens (ppr pat) pprPat (ParPat pat) = parens (ppr pat)
pprPat (ListPat pats _) = brackets (interpp'SP pats) pprPat (ListPat pats _ _) = brackets (interpp'SP pats)
pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) pprPat (PArrPat pats _) = paBrackets (interpp'SP pats)
pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
...@@ -401,7 +405,7 @@ isIrrefutableHsPat pat ...@@ -401,7 +405,7 @@ isIrrefutableHsPat pat
go1 (SigPatIn pat _) = go pat go1 (SigPatIn pat _) = go pat
go1 (SigPatOut pat _) = go pat go1 (SigPatOut pat _) = go pat
go1 (TuplePat pats _ _) = all go pats go1 (TuplePat pats _ _) = all go pats
go1 (ListPat {}) = False go1 (ListPat {}) = False
go1 (PArrPat {}) = False -- ? go1 (PArrPat {}) = False -- ?
go1 (ConPatIn {}) = False -- Conservative go1 (ConPatIn {}) = False -- Conservative
......
...@@ -344,7 +344,7 @@ nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) ...@@ -344,7 +344,7 @@ nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
nlHsPar e = noLoc (HsPar e) nlHsPar e = noLoc (HsPar e)
nlHsIf cond true false = noLoc (mkHsIf cond true false) nlHsIf cond true false = noLoc (mkHsIf cond true false)
nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches)) nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
nlList exprs = noLoc (ExplicitList placeHolderType exprs) nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs)
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
nlHsTyVar :: name -> LHsType name nlHsTyVar :: name -> LHsType name
...@@ -566,7 +566,7 @@ collect_lpat (L _ pat) bndrs ...@@ -566,7 +566,7 @@ collect_lpat (L _ pat) bndrs
go (ViewPat _ pat _) = collect_lpat pat bndrs go (ViewPat _ pat _) = collect_lpat pat bndrs
go (ParPat pat) = collect_lpat pat bndrs go (ParPat pat) = collect_lpat pat bndrs
go (ListPat pats _) = foldr collect_lpat bndrs pats go (ListPat pats _ _) = foldr collect_lpat bndrs pats
go (PArrPat pats _) = foldr collect_lpat bndrs pats go (PArrPat pats _) = foldr collect_lpat bndrs pats
go (TuplePat pats _ _) = foldr collect_lpat bndrs pats go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
...@@ -751,7 +751,7 @@ lPatImplicits = hs_lpat ...@@ -751,7 +751,7 @@ lPatImplicits = hs_lpat
hs_pat (AsPat _ pat) = hs_lpat pat hs_pat (AsPat _ pat) = hs_lpat pat
hs_pat (ViewPat _ pat _) = hs_lpat pat hs_pat (ViewPat _ pat _) = hs_lpat pat
hs_pat (ParPat pat) = hs_lpat pat hs_pat (ParPat pat) = hs_lpat pat
hs_pat (ListPat pats _) = hs_lpats pats hs_pat (ListPat pats _ _) = hs_lpats pats
hs_pat (PArrPat pats _) = hs_lpats pats hs_pat (PArrPat pats _) = hs_lpats pats
hs_pat (TuplePat pats _ _) = hs_lpats pats hs_pat (TuplePat pats _ _) = hs_lpats pats
......
...@@ -480,6 +480,7 @@ data ExtensionFlag ...@@ -480,6 +480,7 @@ data ExtensionFlag
| Opt_BangPatterns | Opt_BangPatterns
| Opt_TypeFamilies | Opt_TypeFamilies
| Opt_OverloadedStrings | Opt_OverloadedStrings
| Opt_OverloadedLists
| Opt_DisambiguateRecordFields | Opt_DisambiguateRecordFields
| Opt_RecordWildCards | Opt_RecordWildCards
| Opt_RecordPuns | Opt_RecordPuns
...@@ -2594,6 +2595,7 @@ xFlags = [ ...@@ -2594,6 +2595,7 @@ xFlags = [
deprecatedForExtension "NamedFieldPuns" ), deprecatedForExtension "NamedFieldPuns" ),
( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ),
( "OverloadedStrings", Opt_OverloadedStrings, nop ), ( "OverloadedStrings", Opt_OverloadedStrings, nop ),
( "OverloadedLists", Opt_OverloadedLists, nop),
( "GADTs", Opt_GADTs, nop ), ( "GADTs", Opt_GADTs, nop ),
( "GADTSyntax", Opt_GADTSyntax, nop ), ( "GADTSyntax", Opt_GADTSyntax, nop ),
( "ViewPatterns", Opt_ViewPatterns, nop ), ( "ViewPatterns", Opt_ViewPatterns, nop ),
......
...@@ -1617,12 +1617,12 @@ tup_tail :: { [HsTupArg RdrName] } ...@@ -1617,12 +1617,12 @@ tup_tail :: { [HsTupArg RdrName] }
-- avoiding another shift/reduce-conflict. -- avoiding another shift/reduce-conflict.
list :: { LHsExpr RdrName } list :: { LHsExpr RdrName }
: texp { L1 $ ExplicitList placeHolderType [$1] } : texp { L1 $ ExplicitList placeHolderType Nothing [$1] }
| lexps { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) } | lexps { L1 $ ExplicitList placeHolderType Nothing (reverse (unLoc $1)) }
| texp '..' { LL $ ArithSeq noPostTcExpr (From $1) } | texp '..' { LL $ ArithSeq noPostTcExpr Nothing (From $1) }
| texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr Nothing (FromThen $1 $3) }
| texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } | texp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromThenTo $1 $3 $5) }
| texp '|' flattenedpquals | texp '|' flattenedpquals
{% checkMonadComp >>= \ ctxt -> {% checkMonadComp >>= \ ctxt ->
return (sL (comb2 $1 $>) $ return (sL (comb2 $1 $>) $
......
...@@ -619,8 +619,8 @@ checkAPat msg loc e0 = do ...@@ -619,8 +619,8 @@ checkAPat msg loc e0 = do
_ -> patFail msg loc e0 _ -> patFail msg loc e0
HsPar e -> checkLPat msg e >>= (return . ParPat) HsPar e -> checkLPat msg e >>= (return . ParPat)
ExplicitList _ es -> do ps <- mapM (checkLPat msg) es ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es
return (ListPat ps placeHolderType) return (ListPat ps placeHolderType Nothing)
ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es
return (PArrPat ps placeHolderType) return (PArrPat ps placeHolderType)
......
...@@ -227,13 +227,19 @@ basicKnownKeyNames ...@@ -227,13 +227,19 @@ basicKnownKeyNames
-- Stable pointers -- Stable pointers
newStablePtrName, newStablePtrName,
-- GHC Extensions -- GHC Extensions
groupWithName, groupWithName,
-- Strings and lists -- Strings and lists
unpackCStringName, unpackCStringName,
unpackCStringFoldrName, unpackCStringUtf8Name, unpackCStringFoldrName, unpackCStringUtf8Name,
-- Overloaded lists
isListClassName,
fromListName,
fromListNName,
toListName,
-- List operations -- List operations
concatName, filterName, mapName, concatName, filterName, mapName,
zipName, foldrName, buildName, augmentName, appendName, zipName, foldrName, buildName, augmentName, appendName,
...@@ -570,6 +576,11 @@ plus_RDR = varQual_RDR gHC_NUM (fsLit "+") ...@@ -570,6 +576,11 @@ plus_RDR = varQual_RDR gHC_NUM (fsLit "+")
fromString_RDR :: RdrName fromString_RDR :: RdrName
fromString_RDR = nameRdrName fromStringName fromString_RDR = nameRdrName fromStringName
fromList_RDR, fromListN_RDR, toList_RDR :: RdrName
fromList_RDR = nameRdrName fromListName
fromListN_RDR = nameRdrName fromListNName
toList_RDR = nameRdrName toListName
compose_RDR :: RdrName compose_RDR :: RdrName
compose_RDR = varQual_RDR gHC_BASE (fsLit ".") compose_RDR = varQual_RDR gHC_BASE (fsLit ".")
...@@ -1002,6 +1013,13 @@ concatName = varQual gHC_LIST (fsLit "concat") concatIdKey ...@@ -1002,6 +1013,13 @@ concatName = varQual gHC_LIST (fsLit "concat") concatIdKey
filterName = varQual gHC_LIST (fsLit "filter") filterIdKey filterName = varQual gHC_LIST (fsLit "filter") filterIdKey
zipName = varQual gHC_LIST (fsLit "zip") zipIdKey zipName = varQual gHC_LIST (fsLit "zip") zipIdKey
-- Overloaded lists
isListClassName, fromListName, fromListNName, toListName :: Name
isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey
fromListName = methName gHC_EXTS (fsLit "fromList") fromListClassOpKey
fromListNName = methName gHC_EXTS (fsLit "fromListN") fromListNClassOpKey
toListName = methName gHC_EXTS (fsLit "toList") toListClassOpKey
-- Class Show -- Class Show
showClassName :: Name showClassName :: Name
showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey
...@@ -1743,6 +1761,12 @@ mzipIdKey = mkPreludeMiscIdUnique 196 ...@@ -1743,6 +1761,12 @@ mzipIdKey = mkPreludeMiscIdUnique 196
ghciStepIoMClassOpKey :: Unique ghciStepIoMClassOpKey :: Unique
ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197
-- Overloaded lists
isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique
isListClassKey = mkPreludeMiscIdUnique 198
fromListClassOpKey = mkPreludeMiscIdUnique 199
fromListNClassOpKey = mkPreludeMiscIdUnique 500
toListClassOpKey = mkPreludeMiscIdUnique 501
---------------- Template Haskell -------------------