Spelling fixes in comments [ci skip]
[ghc.git] / compiler / basicTypes / PatSyn.hs
index 2546ff4..823c838 100644 (file)
@@ -5,7 +5,7 @@
 \section[PatSyn]{@PatSyn@: Pattern synonyms}
 -}
 
-{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
 
 module PatSyn (
         -- * Main data types
@@ -13,28 +13,29 @@ module PatSyn (
 
         -- ** Type deconstruction
         patSynName, patSynArity, patSynIsInfix,
-        patSynArgs, patSynType,
+        patSynArgs,
         patSynMatcher, patSynBuilder,
-        patSynExTyVars, patSynSig,
-        patSynInstArgTys, patSynInstResTy,
-        tidyPatSynIds
+        patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig,
+        patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
+        patSynFieldType,
+
+        tidyPatSynIds, pprPatSynType
     ) where
 
 #include "HsVersions.h"
 
 import Type
-import TcType( mkSigmaTy )
 import Name
 import Outputable
 import Unique
 import Util
 import BasicTypes
-import FastString
 import Var
+import FieldLabel
 
 import qualified Data.Data as Data
-import qualified Data.Typeable
 import Data.Function
+import Data.List
 
 {-
 ************************************************************************
@@ -44,37 +45,54 @@ import Data.Function
 ************************************************************************
 -}
 
--- | A pattern synonym
+-- | Pattern Synonym
+--
 -- See Note [Pattern synonym representation]
--- See Note [Patten synonym signatures]
+-- See Note [Pattern synonym signature contexts]
 data PatSyn
   = MkPatSyn {
         psName        :: Name,
-        psUnique      :: Unique,      -- Cached from Name
+        psUnique      :: Unique,       -- Cached from Name
 
         psArgs        :: [Type],
-        psArity       :: Arity,       -- == length psArgs
-        psInfix       :: Bool,        -- True <=> declared infix
+        psArity       :: Arity,        -- == length psArgs
+        psInfix       :: Bool,         -- True <=> declared infix
+        psFieldLabels :: [FieldLabel], -- List of fields for a
+                                       -- record pattern synonym
+                                       -- INVARIANT: either empty if no
+                                       -- record pat syn or same length as
+                                       -- psArgs
+
+        -- Universially-quantified type variables
+        psUnivTyVars  :: [TyVarBinder],
+
+        -- Required dictionaries (may mention psUnivTyVars)
+        psReqTheta    :: ThetaType,
+
+        -- Existentially-quantified type vars
+        psExTyVars    :: [TyVarBinder],
+
+        -- Provided dictionaries (may mention psUnivTyVars or psExTyVars)
+        psProvTheta   :: ThetaType,
 
-        psUnivTyVars  :: [TyVar],     -- Universially-quantified type variables
-        psReqTheta    :: ThetaType,   -- Required dictionaries
-        psExTyVars    :: [TyVar],     -- Existentially-quantified type vars
-        psProvTheta   :: ThetaType,   -- Provided dictionaries
-        psOrigResTy   :: Type,        -- Mentions only psUnivTyVars
+        -- Result type
+        psOrigResTy   :: Type,         -- Mentions only psUnivTyVars
 
         -- See Note [Matchers and builders for pattern synonyms]
         psMatcher     :: (Id, Bool),
              -- Matcher function.
              -- If Bool is True then prov_theta and arg_tys are empty
              -- and type is
-             --   forall (r :: ?) univ_tvs. req_theta
+             --   forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs.
+             --                          req_theta
              --                       => res_ty
              --                       -> (forall ex_tvs. Void# -> r)
              --                       -> (Void# -> r)
              --                       -> r
              --
              -- Otherwise type is
-             --   forall (r :: ?) univ_tvs. req_theta
+             --   forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs.
+             --                          req_theta
              --                       => res_ty
              --                       -> (forall ex_tvs. prov_theta => arg_tys -> r)
              --                       -> (Void# -> r)
@@ -84,13 +102,12 @@ data PatSyn
              -- Nothing  => uni-directional pattern synonym
              -- Just (builder, is_unlifted) => bi-directional
              -- Builder function, of type
-             --  forall univ_tvs, ex_tvs. (prov_theta, req_theta)
+             --  forall univ_tvs, ex_tvs. (req_theta, prov_theta)
              --                       =>  arg_tys -> res_ty
              -- See Note [Builder for pattern synonyms with unboxed type]
   }
-  deriving Data.Typeable.Typeable
 
-{- Note [Patten synonym signatures]
+{- Note [Pattern synonym signature contexts]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In a pattern synonym signature we write
    pattern P :: req => prov => t1 -> ... tn -> res_ty
@@ -114,7 +131,7 @@ Example 2:
       data T2 where
         MkT2 :: (Num a, Eq a) => a -> a -> T2
 
-      patttern P2 :: () => (Num a, Eq a) => a -> T2
+      pattern P2 :: () => (Num a, Eq a) => a -> T2
       pattern P2 x = MkT2 3 x
 
   When we match against P2 we get a Num dictionary provided.
@@ -144,8 +161,8 @@ so pattern P has type
 
 with the following typeclass constraints:
 
-        provides: (Show (Maybe t), Ord b)
         requires: (Eq t, Num t)
+        provides: (Show (Maybe t), Ord b)
 
 In this case, the fields of MkPatSyn will be set as follows:
 
@@ -198,7 +215,7 @@ For *bidirectional* pattern synonyms, we also generate a "builder"
 function which implements the pattern synonym in an expression
 context. For our running example, it will be:
 
-        $bP :: forall t b. (Show (Maybe t), Ord b, Eq t, Num t)
+        $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b)
             => b -> T (Maybe t)
         $bP x = MkT [x] (Just 42)
 
@@ -225,6 +242,21 @@ This means that when typechecking an occurrence of P in an expression,
 we must remember that the builder has this void argument. This is
 done by TcPatSyn.patSynBuilderOcc.
 
+Note [Pattern synonyms and the data type Type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The type of a pattern synonym is of the form (See Note
+[Pattern synonym signatures]):
+
+    forall univ_tvs. req => forall ex_tvs. prov => ...
+
+We cannot in general represent this by a value of type Type:
+
+ - if ex_tvs is empty, then req and prov cannot be distinguished from
+   each other
+ - if req is empty, then univ_tvs and ex_tvs cannot be distinguished
+   from each other, and moreover, prov is seen as the "required" context
+   (as it is the only context)
+
 
 ************************************************************************
 *                                                                      *
@@ -237,13 +269,6 @@ instance Eq PatSyn where
     (==) = (==) `on` getUnique
     (/=) = (/=) `on` getUnique
 
-instance Ord PatSyn where
-    (<=) = (<=) `on` getUnique
-    (<) = (<) `on` getUnique
-    (>=) = (>=) `on` getUnique
-    (>) = (>) `on` getUnique
-    compare = compare `on` getUnique
-
 instance Uniquable PatSyn where
     getUnique = psUnique
 
@@ -274,45 +299,42 @@ instance Data.Data PatSyn where
 -- | Build a new pattern synonym
 mkPatSyn :: Name
          -> Bool                 -- ^ Is the pattern synonym declared infix?
-         -> ([TyVar], ThetaType) -- ^ Universially-quantified type variables
+         -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type variables
                                  --   and required dicts
-         -> ([TyVar], ThetaType) -- ^ Existentially-quantified type variables
+         -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type variables
                                  --   and provided dicts
          -> [Type]               -- ^ Original arguments
          -> Type                 -- ^ Original result type
          -> (Id, Bool)           -- ^ Name of matcher
          -> Maybe (Id, Bool)     -- ^ Name of builder
+         -> [FieldLabel]         -- ^ Names of fields for
+                                 --   a record pattern synonym
          -> PatSyn
+ -- NB: The univ and ex vars are both in TyBinder form and TyVar form for
+ -- convenience. All the TyBinders should be Named!
 mkPatSyn name declared_infix
          (univ_tvs, req_theta)
          (ex_tvs, prov_theta)
          orig_args
          orig_res_ty
-         matcher builder
+         matcher builder field_labels
     = MkPatSyn {psName = name, psUnique = getUnique name,
-                psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
+                psUnivTyVars = univ_tvs,
+                psExTyVars = ex_tvs,
                 psProvTheta = prov_theta, psReqTheta = req_theta,
                 psInfix = declared_infix,
                 psArgs = orig_args,
                 psArity = length orig_args,
                 psOrigResTy = orig_res_ty,
                 psMatcher = matcher,
-                psBuilder = builder }
+                psBuilder = builder,
+                psFieldLabels = field_labels
+                }
 
 -- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
 patSynName :: PatSyn -> Name
 patSynName = psName
 
-patSynType :: PatSyn -> Type
--- The full pattern type, used only in error messages
--- See Note [Patten synonym signatures]
-patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
-                     , psExTyVars   = ex_tvs,   psProvTheta = prov_theta
-                     , psArgs = orig_args, psOrigResTy = orig_res_ty })
-  = mkSigmaTy univ_tvs req_theta $
-    mkSigmaTy ex_tvs prov_theta $
-    mkFunTys orig_args orig_res_ty
-
 -- | Should the 'PatSyn' be presented infix?
 patSynIsInfix :: PatSyn -> Bool
 patSynIsInfix = psInfix
@@ -324,14 +346,30 @@ patSynArity = psArity
 patSynArgs :: PatSyn -> [Type]
 patSynArgs = psArgs
 
+patSynFieldLabels :: PatSyn -> [FieldLabel]
+patSynFieldLabels = psFieldLabels
+
+-- | Extract the type for any given labelled field of the 'DataCon'
+patSynFieldType :: PatSyn -> FieldLabelString -> Type
+patSynFieldType ps label
+  = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of
+      Just (_, ty) -> ty
+      Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)
+
+patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder]
+patSynUnivTyVarBinders = psUnivTyVars
+
 patSynExTyVars :: PatSyn -> [TyVar]
-patSynExTyVars = psExTyVars
+patSynExTyVars ps = binderVars (psExTyVars ps)
+
+patSynExTyVarBinders :: PatSyn -> [TyVarBinder]
+patSynExTyVarBinders = psExTyVars
 
 patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
 patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
                     , psProvTheta = prov, psReqTheta = req
                     , psArgs = arg_tys, psOrigResTy = res_ty })
-  = (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty)
+  = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty)
 
 patSynMatcher :: PatSyn -> (Id,Bool)
 patSynMatcher = psMatcher
@@ -357,10 +395,10 @@ patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
                            , psExTyVars = ex_tvs, psArgs = arg_tys })
                  inst_tys
   = ASSERT2( length tyvars == length inst_tys
-          , ptext (sLit "patSynInstArgTys") <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
+          , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
     map (substTyWith tyvars inst_tys) arg_tys
   where
-    tyvars = univ_tvs ++ ex_tvs
+    tyvars = binderVars (univ_tvs ++ ex_tvs)
 
 patSynInstResTy :: PatSyn -> [Type] -> Type
 -- Return the type of whole pattern
@@ -372,5 +410,20 @@ patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
                           , psOrigResTy = res_ty })
                 inst_tys
   = ASSERT2( length univ_tvs == length inst_tys
-           , ptext (sLit "patSynInstResTy") <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
-    substTyWith univ_tvs inst_tys res_ty
+           , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
+    substTyWith (binderVars univ_tvs) inst_tys res_ty
+
+-- | Print the type of a pattern synonym. The foralls are printed explicitly
+pprPatSynType :: PatSyn -> SDoc
+pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs,  psReqTheta  = req_theta
+                        , psExTyVars   = ex_tvs,    psProvTheta = prov_theta
+                        , psArgs       = orig_args, psOrigResTy = orig_res_ty })
+  = sep [ pprForAll univ_tvs
+        , pprThetaArrowTy req_theta
+        , ppWhen insert_empty_ctxt $ parens empty <+> darrow
+        , pprType sigma_ty ]
+  where
+    sigma_ty = mkForAllTys ex_tvs  $
+               mkFunTys prov_theta $
+               mkFunTys orig_args orig_res_ty
+    insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)