Add network submodule.
[ghc.git] / compiler / typecheck / TcGenFunctor.hs
index 3862839..61e2864 100644 (file)
@@ -7,6 +7,7 @@ The deriving code for the Functor, Foldable, and Traversable classes
 -}
 
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module TcGenFunctor (
         FFoldType(..), functorLikeTraverse,
@@ -15,7 +16,8 @@ module TcGenFunctor (
         gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds
     ) where
 
-import BasicTypes ( LexicalFixity(..) )
+import GhcPrelude
+
 import Bag
 import DataCon
 import FastString
@@ -34,6 +36,7 @@ import Util
 import Var
 import VarSet
 import MkId (coerceId)
+import TysWiredIn (true_RDR, false_RDR)
 
 import Data.Maybe (catMaybes, isJust)
 
@@ -124,7 +127,7 @@ so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expa
 It is better to produce too many lambdas than to eta expand, see ticket #7436.
 -}
 
-gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
 -- When the argument is phantom, we can use  fmap _ = coerce
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
 gen_Functor_binds loc tycon
@@ -136,7 +139,7 @@ gen_Functor_binds loc tycon
     fmap_eqns = [mkSimpleMatch fmap_match_ctxt
                                [nlWildPat]
                                coerce_Expr]
-    fmap_match_ctxt = FunRhs fmap_name Prefix
+    fmap_match_ctxt = mkPrefixFunRhs fmap_name
 
 gen_Functor_binds loc tycon
   = (listToBag [fmap_bind, replace_bind], emptyBag)
@@ -146,7 +149,7 @@ gen_Functor_binds loc tycon
 
     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
     fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
-    fmap_match_ctxt = FunRhs fmap_name Prefix
+    fmap_match_ctxt = mkPrefixFunRhs fmap_name
 
     fmap_eqn con = flip evalState bs_RDRs $
                      match_for_con fmap_match_ctxt [f_Pat] con =<< parts
@@ -155,7 +158,7 @@ gen_Functor_binds loc tycon
 
     fmap_eqns = map fmap_eqn data_cons
 
-    ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
+    ft_fmap :: FFoldType (State [RdrName] (LHsExpr GhcPs))
     ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
                    -- fmap f = \x -> x
                  , ft_var  = return f_Expr
@@ -176,12 +179,12 @@ gen_Functor_binds loc tycon
                  , ft_bad_app = panic "in other argument in ft_fmap"
                  , ft_co_var = panic "contravariant in ft_fmap" }
 
-    -- See Note [deriving <$]
+    -- See Note [Deriving <$]
     replace_name = L loc replace_RDR
 
     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
     replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
-    replace_match_ctxt = FunRhs replace_name Prefix
+    replace_match_ctxt = mkPrefixFunRhs replace_name
 
     replace_eqn con = flip evalState bs_RDRs $
         match_for_con replace_match_ctxt [z_Pat] con =<< parts
@@ -220,16 +223,16 @@ gen_Functor_binds loc tycon
 
     -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
     match_for_con :: HsMatchContext RdrName
-                  -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
-                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
+                  -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
     match_for_con ctxt = mkSimpleConMatch ctxt $
         \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
 
--- See Note [deriving <$]
-data Replacer = Immediate {replace :: LHsExpr RdrName}
-              | Nested {replace :: LHsExpr RdrName}
+-- See Note [Deriving <$]
+data Replacer = Immediate {replace :: LHsExpr GhcPs}
+              | Nested {replace :: LHsExpr GhcPs}
 
-{- Note [deriving <$]
+{- Note [Deriving <$]
    ~~~~~~~~~~~~~~~~~~
 
 We derive the definition of <$. Allowing this to take the default definition
@@ -428,8 +431,8 @@ foldDataConArgs ft con
     -- The kind checks have ensured the last type parameter is of kind *.
 
 -- Make a HsLam using a fresh variable from a State monad
-mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
-            -> State [RdrName] (LHsExpr RdrName)
+mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
+            -> State [RdrName] (LHsExpr GhcPs)
 -- (mkSimpleLam fn) returns (\x. fn(x))
 mkSimpleLam lam = do
     (n:names) <- get
@@ -437,9 +440,9 @@ mkSimpleLam lam = do
     body <- lam (nlHsVar n)
     return (mkHsLam [nlVarPat n] body)
 
-mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
-             -> State [RdrName] (LHsExpr RdrName))
-             -> State [RdrName] (LHsExpr RdrName)
+mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
+             -> State [RdrName] (LHsExpr GhcPs))
+             -> State [RdrName] (LHsExpr GhcPs)
 mkSimpleLam2 lam = do
     (n1:n2:names) <- get
     put names
@@ -454,11 +457,11 @@ mkSimpleLam2 lam = do
 -- and its arguments, applying an expression (from @insides@) to each of the
 -- respective arguments of @con@.
 mkSimpleConMatch :: Monad m => HsMatchContext RdrName
-                 -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
-                 -> [LPat RdrName]
+                 -> (RdrName -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
+                 -> [LPat GhcPs]
                  -> DataCon
-                 -> [LHsExpr RdrName]
-                 -> m (LMatch RdrName (LHsExpr RdrName))
+                 -> [LHsExpr GhcPs]
+                 -> m (LMatch GhcPs (LHsExpr GhcPs))
 mkSimpleConMatch ctxt fold extra_pats con insides = do
     let con_name = getRdrName con
     let vars_needed = takeList insides as_RDRs
@@ -490,12 +493,12 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do
 -- See Note [Generated code for DeriveFoldable and DeriveTraversable]
 mkSimpleConMatch2 :: Monad m
                   => HsMatchContext RdrName
-                  -> (LHsExpr RdrName -> [LHsExpr RdrName]
-                                      -> m (LHsExpr RdrName))
-                  -> [LPat RdrName]
+                  -> (LHsExpr GhcPs -> [LHsExpr GhcPs]
+                                      -> m (LHsExpr GhcPs))
+                  -> [LPat GhcPs]
                   -> DataCon
-                  -> [Maybe (LHsExpr RdrName)]
-                  -> m (LMatch RdrName (LHsExpr RdrName))
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> m (LMatch GhcPs (LHsExpr GhcPs))
 mkSimpleConMatch2 ctxt fold extra_pats con insides = do
     let con_name = getRdrName con
         vars_needed = takeList insides as_RDRs
@@ -523,9 +526,9 @@ mkSimpleConMatch2 ctxt fold extra_pats con insides = do
                      (noLoc emptyLocalBinds)
 
 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
-mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
-                                 -> m (LMatch RdrName (LHsExpr RdrName)))
-                  -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
+mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a]
+                                 -> m (LMatch GhcPs (LHsExpr GhcPs)))
+                  -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
 mkSimpleTupleCase match_for_con tc insides x
   = do { let data_con = tyConSingleDataCon tc
        ; match <- match_for_con [] data_con insides
@@ -596,9 +599,49 @@ derived Foldable instance for GADT is:
 
 See Note [DeriveFoldable with ExistentialQuantification].
 
+Note [Deriving null]
+~~~~~~~~~~~~~~~~~~~~
+
+In some cases, deriving the definition of 'null' can produce much better
+results than the default definition. For example, with
+
+  data SnocList a = Nil | Snoc (SnocList a) a
+
+the default definition of 'null' would walk the entire spine of a
+nonempty snoc-list before concluding that it is not null. But looking at
+the Snoc constructor, we can immediately see that it contains an 'a', and
+so 'null' can return False immediately if it matches on Snoc. When we
+derive 'null', we keep track of things that cannot be null. The interesting
+case is type application. Given
+
+  data Wrap a = Wrap (Foo (Bar a))
+
+we use
+
+  null (Wrap fba) = all null fba
+
+but if we see
+
+  data Wrap a = Wrap (Foo a)
+
+we can just use
+
+  null (Wrap fa) = null fa
+
+Indeed, we allow this to happen even for tuples:
+
+  data Wrap a = Wrap (Foo (a, Int))
+
+produces
+
+  null (Wrap fa) = null fa
+
+As explained in Note [Deriving <$], giving tuples special performance treatment
+could surprise users if they switch to other types, but Ryan Scott seems to
+think it's okay to do it for now.
 -}
 
-gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
 -- When the parameter is phantom, we can use foldMap _ _ = mempty
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
 gen_Foldable_binds loc tycon
@@ -610,7 +653,7 @@ gen_Foldable_binds loc tycon
     foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
                                   [nlWildPat, nlWildPat]
                                   mempty_Expr]
-    foldMap_match_ctxt = FunRhs foldMap_name Prefix
+    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
 
 gen_Foldable_binds loc tycon
   | null data_cons  -- There's no real point producing anything but
@@ -618,7 +661,7 @@ gen_Foldable_binds loc tycon
   = (unitBag foldMap_bind, emptyBag)
 
   | otherwise
-  = (listToBag [foldr_bind, foldMap_bind], emptyBag)
+  = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)
   where
     data_cons = tyConDataCons tycon
 
@@ -642,10 +685,33 @@ gen_Foldable_binds loc tycon
       where
         parts = sequence $ foldDataConArgs ft_foldMap con
 
+    -- Given a list of NullM results, produce Nothing if any of
+    -- them is NotNull, and otherwise produce a list of Maybes
+    -- with Justs representing unknowns and Nothings representing
+    -- things that are definitely null.
+    convert :: [NullM a] -> Maybe [Maybe a]
+    convert = traverse go where
+      go IsNull = Just Nothing
+      go NotNull = Nothing
+      go (NullM a) = Just (Just a)
+
+    null_name = L loc null_RDR
+    null_match_ctxt = mkPrefixFunRhs null_name
+    null_bind = mkRdrFunBind null_name null_eqns
+    null_eqns = map null_eqn data_cons
+    null_eqn con
+      = flip evalState bs_RDRs $ do
+          parts <- sequence $ foldDataConArgs ft_null con
+          case convert parts of
+            Nothing -> return $
+              mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]
+                false_Expr (noLoc emptyLocalBinds)
+            Just cp -> match_null [] con cp
+
     -- Yields 'Just' an expression if we're folding over a type that mentions
     -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
     -- See Note [FFoldType and functorLikeTraverse]
-    ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
+    ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
     ft_foldr
       = FT { ft_triv    = return Nothing
              -- foldr f = \x z -> z
@@ -667,19 +733,19 @@ gen_Foldable_binds loc tycon
            , ft_fun     = panic "function in ft_foldr"
            , ft_bad_app = panic "in other argument in ft_foldr" }
 
-    match_foldr :: LHsExpr RdrName
-                -> [LPat RdrName]
+    match_foldr :: LHsExpr GhcPs
+                -> [LPat GhcPs]
                 -> DataCon
-                -> [Maybe (LHsExpr RdrName)]
-                -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
+                -> [Maybe (LHsExpr GhcPs)]
+                -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
     match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
       where
         -- g1 v1 (g2 v2 (.. z))
-        mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName
+        mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
         mkFoldr = foldr nlHsApp z
 
     -- See Note [FFoldType and functorLikeTraverse]
-    ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
+    ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
     ft_foldMap
       = FT { ft_triv = return Nothing
              -- foldMap f = \x -> mempty
@@ -697,17 +763,70 @@ gen_Foldable_binds loc tycon
            , ft_fun = panic "function in ft_foldMap"
            , ft_bad_app = panic "in other argument in ft_foldMap" }
 
-    match_foldMap :: [LPat RdrName]
+    match_foldMap :: [LPat GhcPs]
                   -> DataCon
-                  -> [Maybe (LHsExpr RdrName)]
-                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
     match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
       where
         -- mappend v1 (mappend v2 ..)
-        mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName
+        mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
         mkFoldMap [] = mempty_Expr
         mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
 
+    -- See Note [FFoldType and functorLikeTraverse]
+    -- Yields NullM an expression if we're folding over an expression
+    -- that may or may not be null. Yields IsNull if it's certainly
+    -- null, and yields NotNull if it's certainly not null.
+    -- See Note [Deriving null]
+    ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))
+    ft_null
+      = FT { ft_triv = return IsNull
+             -- null = \_ -> True
+           , ft_var  = return NotNull
+             -- null = \_ -> False
+           , ft_tup  = \t g -> do
+               gg  <- sequence g
+               case convert gg of
+                 Nothing -> pure NotNull
+                 Just ggg ->
+                   NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg)
+             -- null = \x -> case x of (..,)
+           , ft_ty_app = \_ g -> flip fmap g $ \nestedResult ->
+                              case nestedResult of
+                                -- If e definitely contains the parameter,
+                                -- then we can test if (G e) contains it by
+                                -- simply checking if (G e) is null
+                                NotNull -> NullM null_Expr
+                                -- This case is unreachable--it will actually be
+                                -- caught by ft_triv
+                                IsNull -> IsNull
+                                -- The general case uses (all null),
+                                -- (all (all null)), etc.
+                                NullM nestedTest -> NullM $
+                                                    nlHsApp all_Expr nestedTest
+             -- null fa = null fa, or null fa = all null fa, or null fa = True
+           , ft_forall = \_ g -> g
+           , ft_co_var = panic "contravariant in ft_null"
+           , ft_fun = panic "function in ft_null"
+           , ft_bad_app = panic "in other argument in ft_null" }
+
+    match_null :: [LPat GhcPs]
+                  -> DataCon
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
+    match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs)
+      where
+        -- v1 && v2 && ..
+        mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs
+        mkNull [] = true_Expr
+        mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs
+
+data NullM a =
+    IsNull   -- Definitely null
+  | NotNull  -- Definitely not null
+  | NullM a  -- Unknown
+
 {-
 ************************************************************************
 *                                                                      *
@@ -748,7 +867,7 @@ removes all such types from consideration.
 See Note [Generated code for DeriveFoldable and DeriveTraversable].
 -}
 
-gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
 -- When the argument is phantom, we can use traverse = pure . coerce
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
 gen_Traversable_binds loc tycon
@@ -761,7 +880,7 @@ gen_Traversable_binds loc tycon
         [mkSimpleMatch traverse_match_ctxt
                        [nlWildPat, z_Pat]
                        (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
-    traverse_match_ctxt = FunRhs traverse_name Prefix
+    traverse_match_ctxt = mkPrefixFunRhs traverse_name
 
 gen_Traversable_binds loc tycon
   = (unitBag traverse_bind, emptyBag)
@@ -782,7 +901,7 @@ gen_Traversable_binds loc tycon
     -- Yields 'Just' an expression if we're folding over a type that mentions
     -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
     -- See Note [FFoldType and functorLikeTraverse]
-    ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
+    ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
     ft_trav
       = FT { ft_triv    = return Nothing
              -- traverse f = pure x
@@ -803,15 +922,15 @@ gen_Traversable_binds loc tycon
 
     -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
     --                    (g2 a2) <*> ...
-    match_for_con :: [LPat RdrName]
+    match_for_con :: [LPat GhcPs]
                   -> DataCon
-                  -> [Maybe (LHsExpr RdrName)]
-                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
     match_for_con = mkSimpleConMatch2 CaseAlt $
                                              \con xs -> return (mkApCon con xs)
       where
         -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
-        mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName
+        mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
         mkApCon con [] = nlHsApps pure_RDR [con]
         mkApCon con [x] = nlHsApps fmap_RDR [con,x]
         mkApCon con (x1:x2:xs) =
@@ -821,7 +940,8 @@ gen_Traversable_binds loc tycon
 -----------------------------------------------------------------------
 
 f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr,
-    traverse_Expr, coerce_Expr, pure_Expr :: LHsExpr RdrName
+    traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,
+    all_Expr, null_Expr :: LHsExpr GhcPs
 f_Expr        = nlHsVar f_RDR
 z_Expr        = nlHsVar z_RDR
 fmap_Expr     = nlHsVar fmap_RDR
@@ -831,6 +951,10 @@ foldMap_Expr  = nlHsVar foldMap_RDR
 traverse_Expr = nlHsVar traverse_RDR
 coerce_Expr   = nlHsVar (getRdrName coerceId)
 pure_Expr     = nlHsVar pure_RDR
+true_Expr     = nlHsVar true_RDR
+false_Expr    = nlHsVar false_RDR
+all_Expr      = nlHsVar all_RDR
+null_Expr     = nlHsVar null_RDR
 
 f_RDR, z_RDR :: RdrName
 f_RDR = mkVarUnqual (fsLit "f")
@@ -840,11 +964,11 @@ as_RDRs, bs_RDRs :: [RdrName]
 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
 
-as_Vars, bs_Vars :: [LHsExpr RdrName]
+as_Vars, bs_Vars :: [LHsExpr GhcPs]
 as_Vars = map nlHsVar as_RDRs
 bs_Vars = map nlHsVar bs_RDRs
 
-f_Pat, z_Pat :: LPat RdrName
+f_Pat, z_Pat :: LPat GhcPs
 f_Pat = nlVarPat f_RDR
 z_Pat = nlVarPat z_RDR