Merge branch 'master' into type-nats

Conflicts:
	compiler/typecheck/TcCanonical.lhs
	compiler/typecheck/TcSMonad.lhs

3 files changed, 44 insertions, 35 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index f235465758..21984eced9 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -1562,8 +1562,8 @@ failSpanMsgP span msg = P $ \_ -> PFailed span msg
 getPState :: P PState
 getPState = P $ \s -> POk s s
 
-getDynFlags :: P DynFlags
-getDynFlags = P $ \s -> POk s (dflags s)
+instance HasDynFlags P where
+    getDynFlags = P $ \s -> POk s (dflags s)
 
 withThisPackage :: (PackageId -> a) -> P a
 withThisPackage f
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 33ddd28c8c..6e75793962 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -35,7 +35,7 @@ import RdrName
 import TcEvidence       ( emptyTcEvBinds )
 import TysPrim          ( liftedTypeKindTyConName, eqPrimTyCon )
 import TysWiredIn       ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
-                          unboxedSingletonTyCon, unboxedSingletonDataCon,
+                          unboxedUnitTyCon, unboxedUnitDataCon,
                           listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR, eqTyCon_RDR )
 import Type             ( funTyCon )
 import ForeignCall      ( Safety(..), CExportSpec(..), CLabelString,
@@ -1047,20 +1047,22 @@ btype :: { LHsType RdrName }
         | atype                         { $1 }
 
 atype :: { LHsType RdrName }
-        : gtycon                        { L1 (HsTyVar (unLoc $1)) }
-        | tyvar                         { L1 (HsTyVar (unLoc $1)) }
-        | strict_mark atype             { LL (HsBangTy (unLoc $1) $2) }  -- Constructor sigs only
-        | '{' fielddecls '}'            {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only
-        | '(' ctype ',' comma_types1 ')'  { LL $ HsTupleTy HsBoxedOrConstraintTuple  ($2:$4) }
-        | '(#' comma_types1 '#)'        { LL $ HsTupleTy HsUnboxedTuple $2     }
-        | '[' ctype ']'                 { LL $ HsListTy  $2 }
-        | '[:' ctype ':]'               { LL $ HsPArrTy  $2 }
-        | '(' ctype ')'                 { LL $ HsParTy   $2 }
-        | '(' ctype '::' kind ')'       { LL $ HsKindSig $2 $4 }
-        | quasiquote                    { L1 (HsQuasiQuoteTy (unLoc $1)) }
-        | '$(' exp ')'                  { LL $ mkHsSpliceTy $2 }
-        | TH_ID_SPLICE                  { LL $ mkHsSpliceTy $ L1 $ HsVar $
-                                          mkUnqual varName (getTH_ID_SPLICE $1) }
+        : ntgtycon                       { L1 (HsTyVar (unLoc $1)) }      -- Not including unit tuples
+        | tyvar                          { L1 (HsTyVar (unLoc $1)) }      -- (See Note [Unit tuples])
+        | strict_mark atype              { LL (HsBangTy (unLoc $1) $2) }  -- Constructor sigs only
+        | '{' fielddecls '}'             {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only
+        | '(' ')'                        { LL $ HsTupleTy HsBoxedOrConstraintTuple []      }
+        | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) }
+        | '(#' '#)'                      { LL $ HsTupleTy HsUnboxedTuple           []      }       
+        | '(#' comma_types1 '#)'         { LL $ HsTupleTy HsUnboxedTuple           $2      }
+        | '[' ctype ']'                  { LL $ HsListTy  $2 }
+        | '[:' ctype ':]'                { LL $ HsPArrTy  $2 }
+        | '(' ctype ')'                  { LL $ HsParTy   $2 }
+        | '(' ctype '::' kind ')'        { LL $ HsKindSig $2 $4 }
+        | quasiquote                     { L1 (HsQuasiQuoteTy (unLoc $1)) }
+        | '$(' exp ')'                   { LL $ mkHsSpliceTy $2 }
+        | TH_ID_SPLICE                   { LL $ mkHsSpliceTy $ L1 $ HsVar $
+                                           mkUnqual varName (getTH_ID_SPLICE $1) }
                                                       -- see Note [Promotion] for the followings
         | SIMPLEQUOTE qconid                          { LL $ HsTyVar $ unLoc $2 }
         | SIMPLEQUOTE  '(' ')'                        { LL $ HsTyVar $ getRdrName unitDataCon }
@@ -1780,7 +1782,7 @@ con_list : con                  { L1 [$1] }
 sysdcon :: { Located DataCon }  -- Wired in data constructors
         : '(' ')'               { LL unitDataCon }
         | '(' commas ')'        { LL $ tupleCon BoxedTuple ($2 + 1) }
-        | '(#' '#)'             { LL $ unboxedSingletonDataCon }
+        | '(#' '#)'             { LL $ unboxedUnitDataCon }
         | '(#' commas '#)'      { LL $ tupleCon UnboxedTuple ($2 + 1) }
         | '[' ']'               { LL nilDataCon }
 
@@ -1792,24 +1794,31 @@ qconop :: { Located RdrName }
         : qconsym               { $1 }
         | '`' qconid '`'        { LL (unLoc $2) }
 
------------------------------------------------------------------------------
+----------------------------------------------------------------------------
 -- Type constructors
 
-gtycon  :: { Located RdrName }  -- A "general" qualified tycon
-        : oqtycon                       { $1 }
+
+-- See Note [Unit tuples] in HsTypes for the distinction 
+-- between gtycon and ntgtycon
+gtycon :: { Located RdrName }  -- A "general" qualified tycon, including unit tuples
+        : ntgtycon                      { $1 }
         | '(' ')'                       { LL $ getRdrName unitTyCon }
+        | '(#' '#)'                     { LL $ getRdrName unboxedUnitTyCon }
+
+ntgtycon :: { Located RdrName }  -- A "general" qualified tycon, excluding unit tuples
+        : oqtycon                       { $1 }
         | '(' commas ')'                { LL $ getRdrName (tupleTyCon BoxedTuple ($2 + 1)) }
-        | '(#' '#)'                     { LL $ getRdrName unboxedSingletonTyCon }
         | '(#' commas '#)'              { LL $ getRdrName (tupleTyCon UnboxedTuple ($2 + 1)) }
         | '(' '->' ')'                  { LL $ getRdrName funTyCon }
         | '[' ']'                       { LL $ listTyCon_RDR }
         | '[:' ':]'                     { LL $ parrTyCon_RDR }
         | '(' '~#' ')'                  { LL $ getRdrName eqPrimTyCon }
 
-oqtycon :: { Located RdrName }  -- An "ordinary" qualified tycon
+oqtycon :: { Located RdrName }  -- An "ordinary" qualified tycon;
+                                -- These can appear in export lists
         : qtycon                        { $1 }
         | '(' qtyconsym ')'             { LL (unLoc $2) }
-        | '(' '~' ')'                   { LL $ eqTyCon_RDR } -- In here rather than gtycon because I want to write it in the GHC.Types export list
+        | '(' '~' ')'                   { LL $ eqTyCon_RDR }
 
 qtyconop :: { Located RdrName } -- Qualified or unqualified
         : qtyconsym                     { $1 }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 30f5a47c74..928eb03647 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -56,7 +56,7 @@ import BasicTypes       ( maxPrecedence, Activation(..), RuleMatchInfo,
                           InlinePragma(..), InlineSpec(..) )
 import TcEvidence       ( idHsWrapper )
 import Lexer
-import TysWiredIn       ( unitTyCon )
+import TysWiredIn       ( unitTyCon, unitDataCon )
 import ForeignCall
 import OccName          ( srcDataName, varName, isDataOcc, isTcOcc,
                           occNameString )
@@ -361,10 +361,12 @@ splitCon :: LHsType RdrName
 splitCon ty
  = split ty []
  where
-   split (L _ (HsAppTy t u)) ts = split t (u : ts)
-   split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
-                                     return (data_con, mk_rest ts)
-   split (L l _) _              = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
+   split (L _ (HsAppTy t u)) ts    = split t (u : ts)
+   split (L l (HsTyVar tc))  ts    = do data_con <- tyConToDataCon l tc
+                                        return (data_con, mk_rest ts)
+   split (L l (HsTupleTy _ [])) [] = return (L l (getRdrName unitDataCon), PrefixCon [])
+                                         -- See Note [Unit tuples] in HsTypes
+   split (L l _) _                 = parseErrorSDoc l (text "parse error in constructor in data/newtype declaration:" <+> ppr ty)
 
    mk_rest [L _ (HsRecTy flds)] = RecCon flds
    mk_rest ts                   = PrefixCon ts
@@ -536,12 +538,13 @@ checkTyClHdr ty
     goL (L l ty) acc = go l ty acc
 
     go l (HsTyVar tc) acc 
-        | isRdrTc tc         = return (L l tc, acc)
-                                     
+        | isRdrTc tc          = return (L l tc, acc)
     go _ (HsOpTy t1 (_, ltc@(L _ tc)) t2) acc
         | isRdrTc tc         = return (ltc, t1:t2:acc)
     go _ (HsParTy ty)    acc = goL ty acc
     go _ (HsAppTy t1 t2) acc = goL t1 (t2:acc)
+    go l (HsTupleTy _ []) [] = return (L l (getRdrName unitTyCon), [])
+                                   -- See Note [Unit tuples] in HsTypes
     go l _               _   = parseErrorSDoc l (text "Malformed head of type or class declaration:" <+> ppr ty)
 
 -- Check that associated type declarations of a class are all kind signatures.
@@ -561,14 +564,11 @@ checkContext (L l orig_t)
   = check orig_t
  where
   check (HsTupleTy _ ts)        -- (Eq a, Ord b) shows up as a tuple type
-    = return (L l ts)
+    = return (L l ts)           -- Ditto ()
 
   check (HsParTy ty)    -- to be sure HsParTy doesn't get into the way
     = check (unLoc ty)
 
-  check (HsTyVar t)     -- Empty context shows up as a unit type ()
-    | t == getRdrName unitTyCon = return (L l [])
-
   check _
     = return (L l [L l orig_t])