Commit 3234a4ad by 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) untidy' _ (LitPat lit) = LitPat (untidy_lit lit) untidy' _ p@(ConPatIn _ (PrefixCon [])) = p 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' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat" untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" untidy' _ (LazyPat {}) = panic "Check.untidy: LazyPat" ... ... @@ -568,15 +569,15 @@ is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon is_nil _ = False is_list :: Pat Name -> Bool is_list (ListPat _ _) = True is_list (ListPat _ _ Nothing) = True is_list _ = False return_list :: DataCon -> Pat Name -> Bool return_list id q = id == consDataCon && (is_nil q || is_list q) make_list :: LPat Name -> Pat Name -> Pat Name make_list p q | is_nil q = ListPat [p] placeHolderType make_list p (ListPat ps ty) = ListPat (p:ps) ty make_list p q | is_nil q = ListPat [p] placeHolderType Nothing make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing make_list _ _ = panic "Check.make_list: Invalid argument" make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat ... ... @@ -647,7 +648,8 @@ might_fail_pat (ViewPat _ p _) = not (isIrrefutableHsPat p) might_fail_pat (ParPat 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 (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 (PArrPat ps _) = any might_fail_lpat ps might_fail_pat (BangPat p) = might_fail_lpat p ... ... @@ -682,11 +684,12 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat -- guard says "this equation might fall through". tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id)) tidy_pat (ViewPat _ _ ty) = WildPat ty tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = 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) (mkNilPat list_ty) (map tidy_lpat ps) ... ...  ... ... @@ -519,10 +519,14 @@ addTickHsExpr (HsDo cxt stmts srcloc) forQual = case cxt of ListComp -> Just$ BinBox QualBinBox _ -> Nothing addTickHsExpr (ExplicitList ty es) = liftM2 ExplicitList addTickHsExpr (ExplicitList ty wit es) = liftM3 ExplicitList (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) = liftM2 ExplicitPArr (return ty) ... ... @@ -543,10 +547,14 @@ addTickHsExpr (ExprWithTySigOut e ty) = (addTickLHsExprNever e) -- No need to tick the inner expression -- for expressions with signatures (return ty) addTickHsExpr (ArithSeq ty arith_seq) = liftM2 ArithSeq addTickHsExpr (ArithSeq ty wit arith_seq) = liftM3 ArithSeq (return ty) (addTickWit wit) (addTickArithSeqInfo arith_seq) where addTickWit Nothing = return Nothing addTickWit (Just fl) = do fl' <- addTickHsExpr fl return (Just fl') addTickHsExpr (HsTickPragma _ (L pos e0)) = do e2 <- allocTickBox (ExpBox False) False False pos $addTickHsExpr e0 ... ...  ... ... @@ -1091,7 +1091,7 @@ collectl (L _ pat) bndrs go (AsPat (L _ a) pat) = a : 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 (TuplePat pats _ _) = foldr collectl bndrs pats ... ...  ... ... @@ -350,8 +350,8 @@ dsExpr (HsMultiIf res_ty alts) \underline{\bf Various data construction things} % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs dsExpr (ExplicitList elt_ty wit xs) = dsExplicitList elt_ty wit xs -- We desugar [:x1, ..., xn:] as -- singletonP x1 +:+ ... +:+ singletonP xn ... ... @@ -368,17 +368,13 @@ dsExpr (ExplicitPArr ty xs) = do unary fn x = mkApps (Var fn) [Type ty, x] binary fn x y = mkApps (Var fn) [Type ty, x, y] dsExpr (ArithSeq expr (From from)) = App <$> dsExpr expr <*> dsLExpr from dsExpr (ArithSeq expr (FromTo from to)) = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] dsExpr (ArithSeq expr (FromThen from thn)) = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] dsExpr (ArithSeq expr (FromThenTo from thn to)) = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to] dsExpr (ArithSeq expr witness seq) = case witness of Nothing -> dsArithSeq expr seq Just fl -> do { ; fl' <- dsExpr fl ; newArithSeq <- dsArithSeq expr seq ; return (App fl' newArithSeq)} dsExpr (PArrSeq expr (FromTo from to)) = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] ... ... @@ -673,9 +669,9 @@ makes all list literals be generated via the simple route. \begin{code} dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr dsExplicitList :: PostTcType -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] -> DsM CoreExpr -- See Note [Desugaring explicit lists] dsExplicitList elt_ty xs dsExplicitList elt_ty Nothing xs = do { dflags <- getDynFlags ; xs' <- mapM dsLExpr xs ; let (dynamic_prefix, static_suffix) = spanTail is_static xs' ... ... @@ -700,9 +696,25 @@ dsExplicitList elt_ty xs ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix' ; 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 f xs = (reverse rejected, reverse satisfying) 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} Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're ... ...  ... ... @@ -970,7 +970,7 @@ repE e@(HsDo ctxt sts _) | otherwise = 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@(ExplicitTuple es boxed) | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) ... ... @@ -987,7 +987,7 @@ repE (RecordUpd e flds _ _ _) repRecUpd x fs } repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 } repE (ArithSeq _ aseq) = repE (ArithSeq _ _ aseq) = case aseq of From e -> do { ds1 <- repLE e; repFrom ds1 } FromThen e1 e2 -> do ... ... @@ -1259,7 +1259,8 @@ repP (LazyPat p) = do { p1 <- repLP p; repPtilde 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 (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 _) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } ... ...  ... ... @@ -17,7 +17,7 @@ module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat #include "HsVersions.h" import {-#SOURCE#-} DsExpr (dsLExpr) import {-#SOURCE#-} DsExpr (dsLExpr, dsExpr) import DynFlags import HsSyn ... ... @@ -53,7 +53,7 @@ import qualified Data.Map as Map \end{code} 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. It can not be called matchWrapper because this name already exists :-( ... ... @@ -327,12 +327,13 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty PgBang -> matchBangs vars ty (dropGroup eqns) PgCo _ -> matchCoercion 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 -- commoned up but are not -- 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 = let gs = map (\group -> foldr (\ (p,_) -> \acc -> case p of PgView e _ -> e:acc ... ... @@ -391,19 +392,33 @@ matchView (var:vars) ty (eqns@(eqn1:_)) ; return (mkViewMatchResult var' viewExpr' var match_result) } 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 decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) = eqn { eqn_pats = extractpat pat : pats} decomposeFirstPat _ _ = panic "decomposeFirstPat" getCoPat, getBangPat, getViewPat :: Pat Id -> Pat Id getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id getCoPat (CoPat _ pat _) = pat getCoPat _ = panic "getCoPat" getBangPat (BangPat pat ) = unLoc pat getBangPat _ = panic "getBangPat" 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} Note [Empty case alternatives] ... ... @@ -536,7 +551,7 @@ tidy1 v (LazyPat pat) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } tidy1 _ (ListPat pats ty) tidy1 _ (ListPat pats ty Nothing) = return (idDsWrapper, unLoc list_ConPat) where list_ty = mkListTy ty ... ... @@ -831,7 +846,8 @@ data PatGroup | PgView (LHsExpr Id) -- view pattern (e -> p): -- the LHsExpr is the expression e Type -- the Type is the type of p (equivalently, the result type of e) | PgOverloadedList groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]] -- If the result is of form [g1, g2, g3], -- (a) all the (pg,eq) pairs in g1 have the same pg ... ... @@ -885,7 +901,7 @@ sameGroup (PgCo t1) (PgCo t2) = t1 eqType t2 -- always have the same type, so this boils down to saying that -- the two coercions are identical. 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 sameGroup _ _ = False ... ... @@ -1002,6 +1018,7 @@ patGroup _ (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust patGroup _ (NPlusKPat _ olit _ _) = PgNpK (hsOverLitKey olit False) patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p)) patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList patGroup _ pat = pprPanic "patGroup" (ppr pat) \end{code} ... ...
 ... ... @@ -545,11 +545,11 @@ cvtl e = wrapL (cvt e) ; return $HsCase e' (mkMatchGroup ms') } cvt (DoE ss) = cvtHsDo DoExpr 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) | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } -- 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 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' cvtp TH.WildP = return $WildPat void cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; 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 ; return$ SigPatIn p' (mkHsWithBndrs t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ViewPat e' p' void } ... ...  ... ... @@ -179,8 +179,9 @@ data HsExpr id [ExprLStmt id] -- "do":one or more stmts PostTcType -- Type of the whole expression | ExplicitList -- syntactic list PostTcType -- Gives type of components of list | ExplicitList -- syntactic list PostTcType -- Gives type of components of list (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromListN witness [LHsExpr id] | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] ... ... @@ -215,8 +216,9 @@ data HsExpr id (LHsType Name) -- Retain the signature for -- round-tripping purposes | ArithSeq -- arithmetic sequence | ArithSeq -- Arithmetic sequence PostTcExpr (Maybe (SyntaxExpr id)) -- For OverloadedLists, the fromList witness (ArithSeqInfo id) | PArrSeq -- arith. sequence for parallel array ... ... @@ -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 (ExplicitList _ exprs) ppr_expr (ExplicitList _ _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitPArr _ exprs) ... ... @@ -519,7 +521,7 @@ ppr_expr (ExprWithTySigOut expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 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 EWildPat = char '_' ... ...  ... ... @@ -67,8 +67,12 @@ data Pat id | BangPat (LPat id) -- Bang pattern ------------ Lists, tuples, arrays --------------- | ListPat [LPat id] -- Syntactic list PostTcType -- The type of the elements | ListPat [LPat id] -- Syntactic list 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 Boxity -- UnitPat is TuplePat [] ... ... @@ -245,7 +249,7 @@ pprPat (BangPat pat) = char '!' <> pprParendLPat pat pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat] pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", 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 (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) ... ... @@ -401,7 +405,7 @@ isIrrefutableHsPat pat go1 (SigPatIn pat _) = go pat go1 (SigPatOut pat _) = go pat go1 (TuplePat pats _ _) = all go pats go1 (ListPat {}) = False go1 (ListPat {}) = False go1 (PArrPat {}) = False -- ? go1 (ConPatIn {}) = False -- Conservative ... ...  ... ... @@ -344,7 +344,7 @@ nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) nlHsPar e = noLoc (HsPar e) nlHsIf cond true false = noLoc (mkHsIf cond true false) 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 nlHsTyVar :: name -> LHsType name ... ... @@ -566,7 +566,7 @@ collect_lpat (L _ pat) bndrs go (ViewPat _ 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 (TuplePat pats _ _) = foldr collect_lpat bndrs pats ... ... @@ -751,7 +751,7 @@ lPatImplicits = hs_lpat hs_pat (AsPat _ pat) = hs_lpat pat hs_pat (ViewPat _ 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 (TuplePat pats _ _) = hs_lpats pats ... ...  ... ... @@ -480,6 +480,7 @@ data ExtensionFlag | Opt_BangPatterns | Opt_TypeFamilies | Opt_OverloadedStrings | Opt_OverloadedLists | Opt_DisambiguateRecordFields | Opt_RecordWildCards | Opt_RecordPuns ... ... @@ -2594,6 +2595,7 @@ xFlags = [ deprecatedForExtension "NamedFieldPuns" ), ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), ( "OverloadedStrings", Opt_OverloadedStrings, nop ), ( "OverloadedLists", Opt_OverloadedLists, nop), ( "GADTs", Opt_GADTs, nop ), ( "GADTSyntax", Opt_GADTSyntax, nop ), ( "ViewPatterns", Opt_ViewPatterns, nop ), ... ...  ... ... @@ -1617,12 +1617,12 @@ tup_tail :: { [HsTupArg RdrName] } -- avoiding another shift/reduce-conflict. list :: { LHsExpr RdrName } : texp { L1$ ExplicitList placeHolderType [$1] } | lexps { L1$ ExplicitList placeHolderType (reverse (unLoc $1)) } | texp '..' { LL$ ArithSeq noPostTcExpr (From $1) } | texp ',' exp '..' { LL$ ArithSeq noPostTcExpr (FromThen $1$3) } | texp '..' exp { LL $ArithSeq noPostTcExpr (FromTo$1 $3) } | texp ',' exp '..' exp { LL$ ArithSeq noPostTcExpr (FromThenTo $1$3 $5) } : texp { L1$ ExplicitList placeHolderType Nothing [$1] } | lexps { L1$ ExplicitList placeHolderType Nothing (reverse (unLoc $1)) } | texp '..' { LL$ ArithSeq noPostTcExpr Nothing (From $1) } | texp ',' exp '..' { LL$ ArithSeq noPostTcExpr Nothing (FromThen $1$3) } | texp '..' exp { LL $ArithSeq noPostTcExpr Nothing (FromTo$1 $3) } | texp ',' exp '..' exp { LL$ ArithSeq noPostTcExpr Nothing (FromThenTo $1$3 $5) } | texp '|' flattenedpquals {% checkMonadComp >>= \ ctxt -> return (sL (comb2$1 $>)$ ... ...
 ... ... @@ -619,8 +619,8 @@ checkAPat msg loc e0 = do _ -> patFail msg loc e0 HsPar e -> checkLPat msg e >>= (return . ParPat) ExplicitList _ es -> do ps <- mapM (checkLPat msg) es return (ListPat ps placeHolderType) ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es return (ListPat ps placeHolderType Nothing) ExplicitPArr _ es -> do ps <- mapM (checkLPat msg) es return (PArrPat ps placeHolderType) ... ...
 ... ... @@ -227,13 +227,19 @@ basicKnownKeyNames -- Stable pointers newStablePtrName, -- GHC Extensions -- GHC Extensions groupWithName, -- Strings and lists unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, -- Overloaded lists isListClassName, fromListName, fromListNName, toListName, -- List operations concatName, filterName, mapName, zipName, foldrName, buildName, augmentName, appendName, ... ... @@ -570,6 +576,11 @@ plus_RDR = varQual_RDR gHC_NUM (fsLit "+") fromString_RDR :: RdrName 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 = varQual_RDR gHC_BASE (fsLit ".") ... ... @@ -1002,6 +1013,13 @@ concatName = varQual gHC_LIST (fsLit "concat") concatIdKey filterName = varQual gHC_LIST (fsLit "filter") filterIdKey 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 showClassName :: Name showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey ... ... @@ -1743,6 +1761,12 @@ mzipIdKey = mkPreludeMiscIdUnique 196 ghciStepIoMClassOpKey :: Unique ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 -- Overloaded lists isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique isListClassKey = mkPreludeMiscIdUnique 198 fromListClassOpKey = mkPreludeMiscIdUnique 199 fromListNClassOpKey = mkPreludeMiscIdUnique 500 toListClassOpKey = mkPreludeMiscIdUnique 501 ---------------- Template Haskell ------------------- -- USES IdUniques 200-499 ... ...
 ... ... @@ -48,7 +48,7 @@ module TysWiredIn ( wordTyCon, wordDataCon, wordTyConName, wordTy, -- * List listTyCon, nilDataCon, consDataCon, consDataConName, listTyCon, nilDataCon, nilDataConName, consDataCon, consDataConName, listTyCon_RDR, consDataCon_RDR, listTyConName, mkListTy, mkPromotedListTy, ... ...
 ... ... @@ -11,6 +11,7 @@ module RnEnv ( lookupLocalOccRn_maybe, lookupTypeOccRn, lookupKindOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, reportUnboundName, HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, ... ... @@ -543,9 +544,11 @@ lookupLocalOccRn_maybe rdr_name -- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name = do opt_name <- lookupOccRn_maybe rdr_name maybe (unboundName WL_Any rdr_name) return opt_name lookupOccRn rdr_name = do { mb_name <- lookupOccRn_maybe rdr_name ; case mb_name of Just name -> return name Nothing -> reportUnboundName rdr_name } lookupKindOccRn :: RdrName -> RnM Name -- Looking up a name occurring in a kind ... ... @@ -553,7 +556,7 @@ lookupKindOccRn rdr_name = do { mb_name <- lookupOccRn_maybe rdr_name ; case mb_name of Just name -> return name Nothing -> unboundName WL_Any rdr_name } Nothing -> reportUnboundName rdr_name } -- lookupPromotedOccRn looks up an optionally promoted RdrName. lookupTypeOccRn :: RdrName -> RnM Name ... ... @@ -571,13 +574,13 @@ lookup_demoted rdr_name = do { data_kinds <- xoptM Opt_DataKinds ; mb_demoted_name <- lookupOccRn_maybe demoted_rdr ; case mb_demoted_name of Nothing -> unboundName WL_Any rdr_name Nothing -> reportUnboundName rdr_name Just demoted_name | data_kinds -> return demoted_name | otherwise -> unboundNameX WL_Any rdr_name suggest_dk } | otherwise = unboundName WL_Any rdr_name = reportUnboundName rdr_name where suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?") ... ... @@ -1354,6 +1357,9 @@ data WhereLooking = WL_Any -- Any binding | WL_Global -- Any top-level binding (local or imported) | WL_LocalTop -- Any top-level binding in this module reportUnboundName :: RdrName -> RnM Name reportUnboundName rdr = unboundName WL_Any rdr unboundName :: WhereLooking -> RdrName -> RnM Name unboundName wl rdr = unboundNameX wl rdr empty ... ...
 ... ... @@ -53,6 +53,7 @@ import Outputable import SrcLoc import FastString import Control.Monad import TysWiredIn ( nilDataConName ) \end{code} ... ... @@ -108,14 +109,18 @@ finishHsVar name ; return (e, unitFV name) } } rnExpr (HsVar v) = do { opt_TypeHoles <- xoptM Opt_TypeHoles ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v) then do { mb_name <- lookupOccRn_maybe v ; case mb_name of Nothing -> return (HsUnboundVar v, emptyFVs) Just n -> finishHsVar n } else do { name <- lookupOccRn v ; finishHsVar name } } = do { mb_name <- lookupOccRn_maybe v ; case mb_name of { Nothing -> do { opt_TypeHoles <- xoptM Opt_TypeHoles ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v) then return (HsUnboundVar v, emptyFVs) else do { n <- reportUnboundName v; finishHsVar n } } ; Just name | name == nilDataConName -- Treat [] as an ExplicitList, so that -- OverloadedLists works correctly -> rnExpr (ExplicitList placeHolderType Nothing []) | otherwise -> finishHsVar name } } rnExpr (HsIPVar v) = return (HsIPVar v, emptyFVs) ... ... @@ -249,9 +254,15 @@ rnExpr (HsDo do_or_lc stmts _) = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } rnExpr (ExplicitList _ exps) = rnExprs exps thenM \ (exps', fvs) -> return (ExplicitList placeHolderType exps', fvs) rnExpr (ExplicitList _ _ exps) = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists ; (exps', fvs) <- rnExprs exps ; if opt_OverloadedLists then do { ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName ; return (ExplicitList placeHolderType (Just from_list_n_name) exps', fvs plusFV fvs') } else return (ExplicitList placeHolderType Nothing exps', fvs) } rnExpr (ExplicitPArr _ exps) = rnExprs exps thenM \ (exps', fvs) -> ... ... @@ -299,9 +310,15 @@ rnExpr (HsType a) = rnLHsType HsTypeCtx a thenM \ (t, fvT) -> return (HsType t, fvT) rnExpr (ArithSeq _ seq) = rnArithSeq seq thenM \ (new_seq, fvs) -> return (ArithSeq noPostTcExpr new_seq, fvs) rnExpr (ArithSeq _ _ seq) = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists ; (new_seq, fvs) <- rnArithSeq seq ; if opt_OverloadedLists then do { ; (from_list_name, fvs') <- lookupSyntaxName fromListName ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs plusFV fvs') } else return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } rnExpr (PArrSeq _ seq) = rnArithSeq seq thenM \ (new_seq, fvs) -> ... ...
 ... ... @@ -61,6 +61,8 @@ import SrcLoc import FastString import Literal ( inCharRange ) import Control.Monad ( when ) import TysWiredIn ( nilDataCon ) import DataCon ( dataConName ) \end{code} ... ... @@ -375,11 +377,20 @@ rnPatAndThen mk p@(ViewPat expr pat ty) rnPatAndThen mk (ConPatIn con stuff) -- rnConPatAndThen takes care of reconstructing the pattern = rnConPatAndThen mk con stuff rnPatAndThen mk (ListPat pats _) = do { pats' <- rnLPatsAndThen mk pats ; return (ListPat pats' placeHolderType) } -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. = case unLoc con == nameRdrName (dataConName nilDataCon) of True -> do { ol_flag <- liftCps $xoptM Opt_OverloadedLists ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing) else rnConPatAndThen mk con stuff} False -> rnConPatAndThen mk con stuff rnPatAndThen mk (ListPat pats _ _) = do { opt_OverloadedLists <- liftCps$ xoptM Opt_OverloadedLists ; pats' <- rnLPatsAndThen mk pats ; case opt_OverloadedLists of True -> do { (to_list_name,_) <- liftCps $lookupSyntaxName toListName ; return (ListPat pats' placeHolderType (Just (placeHolderType, to_list_name)))} False -> return (ListPat pats' placeHolderType Nothing) } rnPatAndThen mk (PArrPat pats _) = do { pats' <- rnLPatsAndThen mk pats ... ...  ... ... @@ -15,8 +15,8 @@ module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, tcCheckId, addExprErrCtxt ) where addExprErrCtxt) where #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ ... ... @@ -401,12 +401,18 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty ; return$ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } tcExpr (ExplicitList _ exprs) res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty ; exprs' <- mapM (tc_elt elt_ty) exprs ; return $mkHsWrapCo coi (ExplicitList elt_ty exprs') } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty tcExpr (ExplicitList _ witness exprs) res_ty = case witness of Nothing -> do { (coi, elt_ty) <- matchExpectedListTy res_ty ; exprs' <- mapM (tc_elt elt_ty) exprs ; return$ mkHsWrapCo coi (ExplicitList elt_ty Nothing exprs') } Just fln -> do { list_ty <- newFlexiTyVarTy liftedTypeKind ; fln' <- tcSyntaxOp ListOrigin fln (mkFunTys [intTy, list_ty] res_ty) ; (coi, elt_ty) <- matchExpectedListTy list_ty ; exprs' <- mapM (tc_elt elt_ty) exprs ; return \$ mkHsWrapCo coi (ExplicitList elt_ty (Just fln') exprs') } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty ... ... @@ -757,40 +763,8 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty %************************************************************************