Add OverloadedLists, allowing list syntax to be overloaded
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 14 Feb 2013 13:04:14 +0000 (13:04 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 14 Feb 2013 13:04:14 +0000 (13:04 +0000)
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.

27 files changed:
compiler/deSugar/Check.lhs
compiler/deSugar/Coverage.lhs
compiler/deSugar/DsArrows.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/Match.lhs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsExpr.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsUtils.lhs
compiler/main/DynFlags.hs
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/TysWiredIn.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnPat.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/utils/Outputable.lhs
docs/users_guide/flags.xml
docs/users_guide/glasgow_exts.xml

index 2932b01..0819604 100644 (file)
@@ -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)
index 133f0e1..45183ba 100644 (file)
@@ -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
index 4fb5174..76b2796 100644 (file)
@@ -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
 
index cfda20a..226eee2 100644 (file)
@@ -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
index 4f5ba2d..ae7a3cc 100644 (file)
@@ -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 }
index 5b0f3b1..43a3af7 100644 (file)
@@ -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}
 
index ce15071..8caf987 100644 (file)
@@ -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 }
index c6f8bf1..b4de840 100644 (file)
@@ -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 '_'
index 64bda89..3a8e433 100644 (file)
@@ -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
index 6ae9ea7..325bd2e 100644 (file)
@@ -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
 
index 9bfef01..66e42b5 100644 (file)
@@ -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 ),
index 6ea422f..6d60f38 100644 (file)
@@ -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 $>) $ 
index 8c7b0a7..b077032 100644 (file)
@@ -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)
 
index a67580a..19acf48 100644 (file)
@@ -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
index e83fcb5..8ee2d3f 100644 (file)
@@ -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,
 
index 038e775..90061b1 100644 (file)
@@ -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
 
index ba41a27..7e1df1c 100644 (file)
@@ -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) ->
index 9738585..a039f36 100644 (file)
@@ -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
index 2733013..7766dd7 100644 (file)
@@ -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
 %************************************************************************
 
 \begin{code}
-tcExpr (ArithSeq _ seq@(From expr)) res_ty
-  = do { (coi, elt_ty) <- matchExpectedListTy res_ty
-       ; expr' <- tcPolyExpr expr elt_ty
-       ; enum_from <- newMethodFromName (ArithSeqOrigin seq) 
-                             enumFromName elt_ty 
-       ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) }
-
-tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
-  = do { (coi, elt_ty) <- matchExpectedListTy res_ty
-       ; expr1' <- tcPolyExpr expr1 elt_ty
-       ; expr2' <- tcPolyExpr expr2 elt_ty
-       ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) 
-                             enumFromThenName elt_ty 
-       ; return $ mkHsWrapCo coi 
-                    (ArithSeq enum_from_then (FromThen expr1' expr2')) }
-
-tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
-  = do { (coi, elt_ty) <- matchExpectedListTy res_ty
-       ; expr1' <- tcPolyExpr expr1 elt_ty
-       ; expr2' <- tcPolyExpr expr2 elt_ty
-       ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) 
-                             enumFromToName elt_ty 
-       ; return $ mkHsWrapCo coi 
-                     (ArithSeq enum_from_to (FromTo expr1' expr2')) }
-
-tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
-  = do { (coi, elt_ty) <- matchExpectedListTy res_ty
-       ; expr1' <- tcPolyExpr expr1 elt_ty
-       ; expr2' <- tcPolyExpr expr2 elt_ty
-       ; expr3' <- tcPolyExpr expr3 elt_ty
-       ; eft <- newMethodFromName (ArithSeqOrigin seq) 
-                     enumFromThenToName elt_ty 
-       ; return $ mkHsWrapCo coi 
-                     (ArithSeq eft (FromThenTo expr1' expr2' expr3')) }
+tcExpr (ArithSeq _ witness seq) res_ty
+  = tcArithSeq witness seq res_ty
 
 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
   = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
@@ -851,6 +825,61 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
 
 %************************************************************************
 %*                                                                     *
+               Arithmetic sequences [a..b] etc
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType
+           -> TcM (HsExpr TcId)
+
+tcArithSeq witness seq@(From expr) res_ty
+  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
+       ; expr' <- tcPolyExpr expr elt_ty
+       ; enum_from <- newMethodFromName (ArithSeqOrigin seq) 
+                             enumFromName elt_ty 
+       ; return $ mkHsWrapCo coi (ArithSeq enum_from wit' (From expr')) }
+     
+tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
+  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
+       ; expr1' <- tcPolyExpr expr1 elt_ty
+       ; expr2' <- tcPolyExpr expr2 elt_ty
+       ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) 
+                             enumFromThenName elt_ty 
+       ; return $ mkHsWrapCo coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) }
+     
+tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
+  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
+       ; expr1' <- tcPolyExpr expr1 elt_ty
+       ; expr2' <- tcPolyExpr expr2 elt_ty
+       ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) 
+                             enumFromToName elt_ty 
+       ; return $ mkHsWrapCo coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) }
+
+tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
+  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
+        ; expr1' <- tcPolyExpr expr1 elt_ty
+        ; expr2' <- tcPolyExpr expr2 elt_ty
+        ; expr3' <- tcPolyExpr expr3 elt_ty
+        ; eft <- newMethodFromName (ArithSeqOrigin seq) 
+                             enumFromThenToName elt_ty
+        ; return $ mkHsWrapCo coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) }
+
+-----------------
+arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType 
+              -> TcM (TcCoercion, TcType, Maybe (SyntaxExpr Id))
+arithSeqEltType Nothing res_ty
+  = do { (coi, elt_ty) <- matchExpectedListTy res_ty
+       ; return (coi, elt_ty, Nothing) }
+arithSeqEltType (Just fl) res_ty
+  = do { list_ty <- newFlexiTyVarTy liftedTypeKind
+       ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty)
+       ; (coi, elt_ty) <- matchExpectedListTy list_ty
+       ; return (coi, elt_ty, Just fl') }
+\end{code}
+
+%************************************************************************
+%*                                                                     *
                Applications
 %*                                                                     *
 %************************************************************************
index ede85a3..2e3e166 100644 (file)
@@ -97,7 +97,8 @@ hsPatType (LazyPat pat)               = hsLPatType pat
 hsPatType (LitPat lit)                = hsLitType lit
 hsPatType (AsPat var _)               = idType (unLoc var)
 hsPatType (ViewPat _ _ ty)            = ty
-hsPatType (ListPat _ ty)              = mkListTy ty
+hsPatType (ListPat _ ty Nothing)      = mkListTy ty
+hsPatType (ListPat _ _ (Just (ty,_))) = ty
 hsPatType (PArrPat _ ty)              = mkPArrTy ty
 hsPatType (TuplePat _ _ ty)           = ty
 hsPatType (ConPatOut { pat_ty = ty }) = ty
@@ -647,10 +648,14 @@ zonkExpr env (HsDo do_or_lc stmts ty)
     zonkTcTypeToType env ty             `thenM` \ new_ty   ->
     returnM (HsDo do_or_lc new_stmts new_ty)
 
-zonkExpr env (ExplicitList ty exprs)
+zonkExpr env (ExplicitList ty wit exprs)
   = zonkTcTypeToType env ty    `thenM` \ new_ty ->
+    zonkWit env wit             `thenM` \ new_wit ->
     zonkLExprs env exprs       `thenM` \ new_exprs ->
-    returnM (ExplicitList new_ty new_exprs)
+    returnM (ExplicitList new_ty new_wit new_exprs)
+   where zonkWit _ Nothing = returnM Nothing
+         zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln ->
+                                  returnM (Just new_fln)
 
 zonkExpr env (ExplicitPArr ty exprs)
   = zonkTcTypeToType env ty    `thenM` \ new_ty ->
@@ -675,10 +680,14 @@ zonkExpr env (ExprWithTySigOut e ty)
 
 zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
 
-zonkExpr env (ArithSeq expr info)
+zonkExpr env (ArithSeq expr wit info)
   = zonkExpr env expr          `thenM` \ new_expr ->
+    zonkWit env wit             `thenM` \ new_wit  ->
     zonkArithSeq env info      `thenM` \ new_info ->
-    returnM (ArithSeq new_expr new_info)
+    returnM (ArithSeq new_expr new_wit new_info)
+   where zonkWit _ Nothing = returnM Nothing
+         zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln ->
+                                  returnM (Just new_fln)
 
 zonkExpr env (PArrSeq expr info)
   = zonkExpr env expr          `thenM` \ new_expr ->
@@ -987,10 +996,17 @@ zonk_pat env (ViewPat expr pat ty)
        ; ty' <- zonkTcTypeToType env ty
        ; return (env', ViewPat expr' pat' ty') }
 
-zonk_pat env (ListPat pats ty)
+zonk_pat env (ListPat pats ty Nothing)
   = do { ty' <- zonkTcTypeToType env ty
        ; (env', pats') <- zonkPats env pats
-       ; return (env', ListPat pats' ty') }
+       ; return (env', ListPat pats' ty' Nothing) }
+                                         
+zonk_pat env (ListPat pats ty (Just (ty2,wit)))
+  = do { wit' <- zonkExpr env wit
+        ; ty2' <- zonkTcTypeToType env ty2
+        ; ty' <- zonkTcTypeToType env ty
+       ; (env', pats') <- zonkPats env pats
+       ; return (env', ListPat pats' ty' (Just (ty2',wit'))) }
 
 zonk_pat env (PArrPat pats ty)
   = do { ty' <- zonkTcTypeToType env ty
index 9775ea7..cde55a6 100644 (file)
@@ -181,7 +181,7 @@ tcHsSigTypeNC ctxt (L loc hs_ty)
           -- The kind is checked by checkValidType, and isn't necessarily
           -- of kind * in a Template Haskell quote eg [t| Maybe |]
 
-          -- Generalise here: see Note [ generalisation]
+          -- Generalise here: see Note [Kind generalisation]
         ; ty <- tcCheckHsTypeAndGen hs_ty kind
 
           -- Zonk to expose kind information to checkValidType
index 2889c53..6c480c4 100644 (file)
@@ -30,6 +30,7 @@ import Id
 import Var
 import Name
 import TcEnv
+--import TcExpr
 import TcMType
 import TcValidity( arityErr )
 import TcType
@@ -451,11 +452,20 @@ tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside
 
 ------------------------
 -- Lists, tuples, arrays
-tc_pat penv (ListPat pats _) pat_ty thing_inside
-  = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy pat_ty
+tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside
+  = do { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy pat_ty      
         ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty)
                                     pats penv thing_inside
-       ; return (mkHsWrapPat coi (ListPat pats' elt_ty) pat_ty, res) 
+       ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res) 
+        }
+
+tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside
+  = do { list_pat_ty <- newFlexiTyVarTy liftedTypeKind
+        ; e' <- tcSyntaxOp ListOrigin e (mkFunTy pat_ty list_pat_ty)
+        ; (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy list_pat_ty
+        ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty)
+                                    pats penv thing_inside
+       ; return (mkHsWrapPat coi (ListPat pats' elt_ty (Just (pat_ty,e'))) list_pat_ty, res) 
         }
 
 tc_pat penv (PArrPat pats _) pat_ty thing_inside
index c103385..4f4b166 100644 (file)
@@ -1475,7 +1475,7 @@ tcGhciStmts stmts
                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
                 -- if they were overloaded, since they aren't applied to anything.)
             ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
-                       (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
+                       (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ;
             mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
                                  (nlHsVar id) ;
             stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
index 0b28f4d..e70f674 100644 (file)
@@ -1543,7 +1543,8 @@ data CtOrigin
   | FunDepOrigin
   | HoleOrigin
   | UnboundOccurrenceOf RdrName
-
+  | ListOrigin          -- An overloaded list
+  
 pprO :: CtOrigin -> SDoc
 pprO (GivenOrigin sk)      = ppr sk
 pprO (OccurrenceOf name)   = hsep [ptext (sLit "a use of"), quotes (ppr name)]
@@ -1580,6 +1581,7 @@ pprO AnnOrigin             = ptext (sLit "an annotation")
 pprO FunDepOrigin          = ptext (sLit "a functional dependency")
 pprO HoleOrigin            = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_")
 pprO (UnboundOccurrenceOf name) = hsep [ptext (sLit "an undeclared identifier"), quotes (ppr name)]
+pprO ListOrigin            = ptext (sLit "an overloaded list")
 
 instance Outputable CtOrigin where
   ppr = pprO
index 4e741b4..9e83634 100644 (file)
@@ -260,7 +260,9 @@ pprDeeper d = SDoc $ \ctx -> case ctx of
 
 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
 -- Truncate a list that list that is longer than the current depth
-pprDeeperList f ds = SDoc work
+pprDeeperList f ds 
+  | null ds   = f []
+  | otherwise = SDoc work
  where
   work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
    | n==0      = Pretty.text "..."
index f856f66..299b4d5 100644 (file)
             <entry><option>-XNoOverloadedStrings</option></entry>
           </row>
           <row>
+            <entry><option>-XOverloadedLists</option></entry>
+            <entry>Enable <link linkend="overloaded-lists">overloaded lists</link>.
+            </entry>
+            <entry>dynamic</entry>
+            <entry><option>-XNoOverloadedLists</option></entry>
+          </row>
+          <row>
             <entry><option>-XGADTs</option></entry>
             <entry>Enable <link linkend="gadt">generalised algebraic data types</link>.
             </entry>
index 9dae355..c088eee 100644 (file)
@@ -4656,6 +4656,163 @@ to work since it gets translated into an equality comparison.
 </para>
 </sect2>
 
+<sect2 id="overloaded-lists">
+<title>Overloaded lists</title>
+
+<para> GHC supports <emphasis>overloading of the list notation</emphasis>.
+Before turning our attention to the overloading, let us recap the notation for
+constructing lists. In Haskell, the list notation can be be used in the
+following seven ways:
+
+<programlisting>
+[]          -- Empty list 
+[x]         -- x : []
+[x,y,z]     -- x : y : z : []
+[x .. ]     -- enumFrom x
+[x,y ..]    -- enumFromThen x y
+[x .. y]    -- enumFromTo x y
+[x,y .. z]  -- enumFromThenTo x y z
+</programlisting>
+
+When the <option>OverloadedLists</option> extension is turned on, the
+aforementioned seven notations are desugared as follows: </para>
+
+<programlisting>
+[]          -- fromListN 0 []
+[x]         -- fromListN 1 (x : [])
+[x,y,z]     -- fromListN 3 (x : y : z : [])
+[x .. ]     -- fromList (enumFrom x)
+[x,y ..]    -- fromList (enumFromThen x y)
+[x .. y]    -- fromList (enumFromTo x y)
+[x,y .. z]  -- fromList (enumFromThenTo x y z)
+</programlisting>
+
+<para> This extension allows programmers to use the list notation for
+construction of structures like: <literal>Set</literal>,
+<literal>Map</literal>, <literal>IntMap</literal>, <literal>Vector</literal>,
+<literal>Text</literal> and <literal>Array</literal>. The following code
+listing gives a few examples:</para>
+
+<programlisting>
+['0' .. '9']             :: Set Char
+[1 .. 10]                :: Vector Int
+[("default",0), (k1,v1)] :: Map String Int
+['a' .. 'z']             :: Text
+</programlisting>
+<para>
+List patterns are also overloaded. When the <option>OverloadedLists</option> 
+extension is turned on, these definitions are desugared as follows
+<programlisting>
+f [] = ...          -- f (toList -> []) = ...
+g [x,y,z] = ...     -- g (toList -> [x,y,z]) = ...
+</programlisting>
+(Here we are using view-pattern syntax for the translation, see <xref linkend="view-patterns"/>.)
+</para>
+<para> During the typechecking and desugaring phases, GHC uses whatever is in
+scope with the names of <literal>toList</literal>, <literal>fromList</literal> and
+<literal>fromListN</literal>. That is, these functions are rebindable;
+c.f. <xref linkend="rebindable-syntax"/> </para>
+
+<para>That said, the <literal>GHC.Exts</literal> module exports the
+<literal>IsList</literal> class that can be used to overload
+these functions for different
+structures. The type class is defined as follows:</para>
+
+<programlisting>
+class IsList l where
+  type Item l
+
+  fromList :: [Item l] -> l
+  toList   :: l -> [Item l]
+
+  fromListN :: Int -> [Item l] -> l
+  fromListN _ = fromList
+</programlisting>
+
+<para>The <literal>FromList</literal> class and its methods are intended to be
+used in conjunction with the <option>OverloadedLists</option> extension. 
+<itemizedlist>
+<listitem> <para> The type function
+<literal>Item</literal> returns the type of items of the
+structure <literal>l</literal>.
+</para></listitem>
+<listitem><para> 
+The function <literal>fromList</literal> 
+constructs the structure <literal>l</literal> from the given list of
+<literal>Item l</literal>. 
+</para></listitem>
+<listitem><para> 
+The function <literal>fromListN</literal> takes the
+input list's length as a hint. Its behaviour should be equivalent to
+<literal>fromList</literal>. The hint can be used for more efficient
+construction of the structure <literal>l</literal> compared to
+<literal>fromList</literal>. If the given hint is not equal to the input
+list's length the behaviour of <literal>fromListN</literal> is not
+specified.
+</para></listitem>
+<listitem><para> 
+The function <literal>toList</literal> should be 
+the inverse of <literal>fromList</literal>.
+</para></listitem>
+</itemizedlist>
+</para>
+<para>In the following, we give several example instances of the
+<literal>FromList</literal> type class:</para>
+
+<programlisting>
+instance FromList [a] where
+  type Item [a] = a
+  fromList = id
+  toList = id
+
+instance (Ord a) => FromList (Set a) where
+  type Item (Set a) = a
+  fromList = Set.fromList
+  toList = Set.toList
+
+instance (Ord k) => FromList (Map k v) where
+  type Item (Map k v) = (k,v)
+  fromList = Map.fromList 
+  toList = Map.toList
+
+instance FromList (IntMap v) where
+  type Item (IntMap v) = (Int,v)
+  fromList = IntMap.fromList 
+  toList = IntMap.toList
+
+instance FromList Text where
+  type Item Text = Char
+  fromList = Text.pack
+  toList = Text.unpack
+
+instance FromList (Vector a) where
+  type Item (Vector a) = a
+  fromList  = Vector.fromList
+  fromListN = Vector.fromListN
+  toList = Vector.toList
+</programlisting>
+
+<para>Currently, the <literal>IsList</literal> class is not accompanied with
+defaulting rules. Although feasible, not much thought has gone into how to
+specify the meaning of the default declarations like:</para>
+
+<programlisting>
+default ([a])
+</programlisting>
+
+<para>The current implementation of the <option>OverloadedLists</option>
+extension can be improved by handling the lists that are only populated with
+literals in a special way. More specifically, the compiler could allocate such
+lists statically using a compact representation and allow
+<literal>IsList</literal> instances to take advantage of the compact
+representation. Equipped with this capability the
+<option>OverloadedLists</option> extension will be in a good position to
+subsume the <option>OverloadedStrings</option> extension (currently, as a
+special case, string literals benefit from statically allocated compact
+representation).</para>
+
+</sect2>
+
 </sect1>
 
 <sect1 id="type-families">