Commit 3234a4ad by Simon Peyton Jones

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:

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