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)
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
%************************************************************************