[project @ 2002-05-27 15:28:07 by simonpj]
authorsimonpj <unknown>
Mon, 27 May 2002 15:28:09 +0000 (15:28 +0000)
committersimonpj <unknown>
Mon, 27 May 2002 15:28:09 +0000 (15:28 +0000)
Allow infix type constructors

This commit adds infix type constructors (but not yet class constructors).
The documentation describes what should be the case.  Lots of tiresome
changes, but nothing exciting.

Allows infix type constructors everwhere a type can occur, and in a data
or type synonym decl.  E.g.

data a :*: b = ....

You can give fixity decls for type constructors, but the fixity decl
applies both to the tycon and the corresponding data con.

16 files changed:
ghc/compiler/basicTypes/BasicTypes.lhs
ghc/compiler/hsSyn/HsTypes.lhs
ghc/compiler/main/BinIface.hs
ghc/compiler/parser/ParseUtil.lhs
ghc/compiler/parser/Parser.y
ghc/compiler/rename/Rename.lhs
ghc/compiler/rename/RnBinds.lhs
ghc/compiler/rename/RnEnv.lhs
ghc/compiler/rename/RnExpr.lhs
ghc/compiler/rename/RnHiFiles.lhs
ghc/compiler/rename/RnHsSyn.lhs
ghc/compiler/rename/RnMonad.lhs
ghc/compiler/rename/RnTypes.lhs
ghc/compiler/typecheck/TcMonoType.lhs
ghc/docs/users_guide/glasgow_exts.sgml
ghc/docs/users_guide/intro.sgml

index 42e5e9f..62a68a9 100644 (file)
@@ -21,7 +21,9 @@ module BasicTypes(
        Unused, unused,
 
        Fixity(..), FixityDirection(..),
-       defaultFixity, maxPrecedence, negateFixity, negatePrecedence,
+       defaultFixity, maxPrecedence, 
+       arrowFixity, negateFixity, negatePrecedence,
+       compareFixity,
 
        IPName(..), ipNameName, mapIPName,
 
@@ -156,10 +158,39 @@ defaultFixity = Fixity maxPrecedence InfixL
 negateFixity :: Fixity
 negateFixity     = Fixity negatePrecedence InfixL      -- Precedence of unary negate is wired in as infixl 6!
 
+arrowFixity :: Fixity  -- Fixity of '->' in types
+arrowFixity = Fixity 0 InfixR
+
 negatePrecedence :: Int
 negatePrecedence = 6
 \end{code}
 
+Consider
+
+\begin{verbatim}
+       a `op1` b `op2` c
+\end{verbatim}
+@(compareFixity op1 op2)@ tells which way to arrange appication, or
+whether there's an error.
+
+\begin{code}
+compareFixity :: Fixity -> Fixity
+             -> (Bool,         -- Error please
+                 Bool)         -- Associate to the right: a op1 (b op2 c)
+compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
+  = case prec1 `compare` prec2 of
+       GT -> left
+       LT -> right
+       EQ -> case (dir1, dir2) of
+                       (InfixR, InfixR) -> right
+                       (InfixL, InfixL) -> left
+                       _                -> error_please
+  where
+    right       = (False, True)
+    left         = (False, False)
+    error_please = (True,  False)
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *
index 837dc91..738ab16 100644 (file)
@@ -5,7 +5,7 @@
 
 \begin{code}
 module HsTypes (
-         HsType(..), HsTyVarBndr(..),
+         HsType(..), HsTyVarBndr(..), HsTyOp(..),
        , HsContext, HsPred(..)
        , HsTupCon(..), hsTupParens, mkHsTupCon,
         , hsUsOnce, hsUsMany
@@ -102,9 +102,9 @@ data HsType name
 
   | HsTupleTy          (HsTupCon name)
                        [HsType name]   -- Element types (length gives arity)
-  -- Generics
-  | HsOpTy             (HsType name) name (HsType name)
-  | HsNumTy             Integer
+
+  | HsOpTy             (HsType name) (HsTyOp name) (HsType name)
+  | HsNumTy             Integer                -- Generics only
 
   -- these next two are only used in interfaces
   | HsPredTy           (HsPred name)
@@ -113,6 +113,11 @@ data HsType name
                        Kind            -- A type with a kind signature
 
 
+data HsTyOp name = HsArrow | HsTyOp name
+       -- Function arrows from *source* get read in as HsOpTy t1 HsArrow t2
+       -- But when we generate or parse interface files, we use HsFunTy.
+       -- This keeps interfaces a bit smaller, because there are a lot of arrows
+
 -----------------------
 hsUsOnce, hsUsMany :: HsType RdrName
 hsUsOnce = HsTyVar (mkUnqual tvName FSLIT("."))  -- deep magic
@@ -209,6 +214,10 @@ NB: these types get printed into interface files, so
 instance (Outputable name) => Outputable (HsType name) where
     ppr ty = pprHsType ty
 
+instance (Outputable name) => Outputable (HsTyOp name) where
+    ppr HsArrow    = ftext FSLIT("->")
+    ppr (HsTyOp n) = ppr n
+
 instance (Outputable name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar name)       = ppr name
     ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind
@@ -475,11 +484,15 @@ eq_hsType env (HsPredTy p1) (HsPredTy p2)
   = eq_hsPred env p1 p2
 
 eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2)
-  = eq_hsVar env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2
+  = eq_hsOp env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2
 
 eq_hsType env ty1 ty2 = False
 
 
+eq_hsOp env (HsTyOp n1) (HsTyOp n2) = eq_hsVar env n1 n2
+eq_hsOp env HsArrow     HsArrow     = True
+eq_hsOp env op1                op2         = False
+
 -------------------
 eq_hsContext env a b = eqListBy (eq_hsPred env) a b
 
index f6e439e..e9e1694 100644 (file)
@@ -615,6 +615,17 @@ instance (Binary name) => Binary (HsTupCon name) where
          ac <- get bh
          return (HsTupCon aa ab ac)
 
+instance (Binary name) => Binary (HsTyOp name) where
+    put_ bh HsArrow    = putByte bh 0
+    put_ bh (HsTyOp n) = do putByte bh 1
+                           put_ bh n
+
+    get bh = do h <- getByte bh
+               case h of
+                 0 -> return HsArrow
+                 1 -> do a <- get bh
+                         return (HsTyOp a)
+
 instance (Binary name) => Binary (HsType name) where
     put_ bh (HsForAllTy aa ab ac) = do
            putByte bh 0
index a9ae3ff..2a9ae46 100644 (file)
@@ -28,6 +28,7 @@ module ParseUtil (
        , checkContext        -- HsType -> P HsContext
        , checkPred           -- HsType -> P HsPred
        , checkTyVars         -- [HsTyVar] -> P [HsType]
+       , checkTyClHdr        -- HsType -> (name,[tyvar])
        , checkInstType       -- HsType -> P HsType
        , checkPattern        -- HsExp -> P HsPat
        , checkPatterns       -- SrcLoc -> [HsExp] -> P [HsPat]
@@ -117,6 +118,23 @@ checkTyVars tvs = mapP chk tvs
                  chk (HsTyVar tv)               = returnP (UserTyVar tv)
                  chk other                      = parseError "Type found where type variable expected"
 
+checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar])
+-- The header of a type or class decl should look like
+--     (C a, D b) => T a b
+-- or  T a b
+-- or  a + b
+-- etc
+checkTyClHdr ty
+  = go ty []
+  where
+    go (HsTyVar tc) acc 
+       | not (isRdrTyVar tc) = checkTyVars acc         `thenP` \ tvs ->
+                               returnP (tc, tvs)
+    go (HsOpTy t1 (HsTyOp tc) t2) acc  = checkTyVars (t1:t2:acc)       `thenP` \ tvs ->
+                                        returnP (tc, tvs)
+    go (HsAppTy t1 t2) acc    = go t1 (t2:acc)
+    go other          acc    = parseError "Malformed LHS to type of class declaration"
+
 checkContext :: RdrNameHsType -> P RdrNameContext
 checkContext (HsTupleTy _ ts)  -- (Eq a, Ord b) shows up as a tuple type
   = mapP checkPred ts
index 7b26472..6c0fccb 100644 (file)
@@ -1,6 +1,6 @@
 {-                                                             -*-haskell-*-
 -----------------------------------------------------------------------------
-$Id: Parser.y,v 1.97 2002/05/10 13:34:18 simonpj Exp $
+$Id: Parser.y,v 1.98 2002/05/27 15:28:08 simonpj Exp $
 
 Haskell grammar.
 
@@ -48,24 +48,16 @@ import Outputable
 -----------------------------------------------------------------------------
 Conflicts: 21 shift/reduce, -=chak[4Feb2]
 
-9 for abiguity in 'if x then y else z + 1'
+11 for abiguity in 'if x then y else z + 1'            [State 128]
        (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
        8 because op might be: - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM
-1 for ambiguity in 'if x then y else z :: T'
-       (shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
-1 for ambiguity in 'if x then y else z with ?x=3'
-       (shift parses as 'if x then y else (z with ?x=3)'
 
-3 for ambiguity in 'case x of y :: a -> b'
-       (don't know whether to reduce 'a' as a btype or shift the '->'.
-        conclusion:  bogus expression anyway, doesn't matter)
-
-1 for ambiguity in '{-# RULES "name" [ ... #-}
+1 for ambiguity in '{-# RULES "name" [ ... #-}         [State 210]
        we don't know whether the '[' starts the activation or not: it
        might be the start of the declaration with the activation being
        empty.  --SDM 1/4/2002
 
-1 for ambiguity in '{-# RULES "name" forall = ... #-}' 
+1 for ambiguity in '{-# RULES "name" forall = ... #-}'         [State 412]
        since 'forall' is a valid variable name, we don't know whether
        to treat a forall on the input as the beginning of a quantifier
        or the beginning of the rule itself.  Resolving to shift means
@@ -73,13 +65,28 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2]
        This saves explicitly defining a grammar for the rule lhs that
        doesn't include 'forall'.
 
-1 for ambiguity in 'let ?x ...'
+1 for ambiguity in 'let ?x ...'                                [State 278]
        the parser can't tell whether the ?x is the lhs of a normal binding or
        an implicit binding.  Fortunately resolving as shift gives it the only
        sensible meaning, namely the lhs of an implicit binding.
 
-6 for conflicts between `fdecl' and `fdeclDEPRECATED', which are resolved
-  correctly, and moreover, should go away when `fdeclDEPRECATED' is removed.
+
+8 for ambiguity in 'e :: a `b` c'.  Does this mean     [States 238,267]
+       (e::a) `b` c, or 
+       (e :: (a `b` c))
+
+6 for conflicts between `fdecl' and `fdeclDEPRECATED',         [States 402,403]
+  which are resolved correctly, and moreover, 
+  should go away when `fdeclDEPRECATED' is removed.
+
+1 for ambiguity in 'if x then y else z :: T'
+       (shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
+1 for ambiguity in 'if x then y else z with ?x=3'
+       (shift parses as 'if x then y else (z with ?x=3)'
+3 for ambiguity in 'case x of y :: a -> b'
+       (don't know whether to reduce 'a' as a btype or shift the '->'.
+        conclusion:  bogus expression anyway, doesn't matter)
+
 
 -----------------------------------------------------------------------------
 -}
@@ -407,12 +414,13 @@ topdecls :: { [RdrBinding] }
        | topdecl                       { [$1] }
 
 topdecl :: { RdrBinding }
-       : srcloc 'type' tycon tv_bndrs '=' ctype        
+       : srcloc 'type' syn_hdr '=' ctype       
                -- Note ctype, not sigtype.
                -- We allow an explicit for-all but we don't insert one
                -- in   type Foo a = (b,b)
                -- Instead we just say b is out of scope
-               { RdrHsDecl (TyClD (TySynonym $3 $4 $6 $1)) }
+               { let (tc,tvs) = $3
+                 in RdrHsDecl (TyClD (TySynonym tc tvs $5 $1)) }
 
 
        | srcloc 'data' tycl_hdr constrs deriving
@@ -442,6 +450,11 @@ topdecl :: { RdrBinding }
        | '{-# RULES' rules '#-}'                       { $2 }
        | decl                                          { $1 }
 
+syn_hdr :: { (RdrName, [RdrNameHsTyVar]) }     -- We don't retain the syntax of an infix
+                                               -- type synonym declaration. Oh well.
+       : tycon tv_bndrs                { ($1, $2) }
+       | tv_bndr tyconop tv_bndr       { ($2, [$1,$3]) }
+
 -- tycl_hdr parses the header of a type or class decl,
 -- which takes the form
 --     T a b
@@ -449,6 +462,12 @@ topdecl :: { RdrBinding }
 --     (Eq a, Ord b) => T a b
 -- Rather a lot of inlining here, else we get reduce/reduce errors
 tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) }
+       : context '=>' type             {% checkTyClHdr $3      `thenP` \ (tc,tvs) ->
+                                          returnP ($1, tc, tvs) }
+       | type                          {% checkTyClHdr $1      `thenP` \ (tc,tvs) ->
+                                          returnP ([], tc, tvs) }
+
+{-
        : '(' comma_types1 ')' '=>' gtycon tv_bndrs
                {% mapP checkPred $2    `thenP` \ cxt ->
                  returnP (cxt, $5, $6) }
@@ -477,6 +496,15 @@ tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) }
                -- an error in the renamer if some non-H98 form is used and
                -- -fglasgow-exts is not given.)  -=chak 
 
+atypes0        :: { [RdrNameHsType] }
+       : atypes1                       { $1 }
+       | {- empty -}                   { [] }
+
+atypes1        :: { [RdrNameHsType] }
+       : atype                         { [$1] }
+       | atype atypes1                 { $1 : $2 }
+-}
+
 decls  :: { [RdrBinding] }
        : decls ';' decl                { $3 : $1 }
        | decls ';'                     { $1 }
@@ -760,14 +788,13 @@ context :: { RdrNameContext }
        : btype                         {% checkContext $1 }
 
 type :: { RdrNameHsType }
-       : gentype '->' type             { HsFunTy $1 $3 }
-       | ipvar '::' type               { mkHsIParamTy $1 $3 }
+       : ipvar '::' gentype            { mkHsIParamTy $1 $3 }
        | gentype                       { $1 }
 
 gentype :: { RdrNameHsType }
         : btype                         { $1 }
--- Generics
-        | atype tyconop atype           { HsOpTy $1 $2 $3 }
+        | btype qtyconop gentype        { HsOpTy $1 (HsTyOp $2) $3 }
+       | btype '->' gentype            { HsOpTy $1 HsArrow $3 }
 
 btype :: { RdrNameHsType }
        : btype atype                   { HsAppTy $1 $2 }
@@ -800,14 +827,6 @@ comma_types1       :: { [RdrNameHsType] }
        : type                          { [$1] }
        | type  ',' comma_types1        { $1 : $3 }
 
-atypes0        :: { [RdrNameHsType] }
-       : atypes1                       { $1 }
-       | {- empty -}                   { [] }
-
-atypes1        :: { [RdrNameHsType] }
-       : atype                         { [$1] }
-       | atype atypes1                 { $1 : $2 }
-
 tv_bndrs :: { [RdrNameHsTyVar] }
         : tv_bndr tv_bndrs             { $1 : $2 }
         | {- empty -}                  { [] }
@@ -1009,11 +1028,7 @@ aexp1    :: { RdrNameHsExpr }
         : aexp1 '{' fbinds '}'                         {% (mkRecConstrOrUpdate $1 
                                                        (reverse $3)) }
        | aexp2                                 { $1 }
-
--- Here was the syntax for type applications that I was planning
--- but there are difficulties (e.g. what order for type args)
--- so it's not enabled yet.
---     | var_or_con '{|' gentype '|}'          { (HsApp $1 (HsType $3)) }
+       | var_or_con '{|' gentype '|}'          { HsApp $1 (HsType $3) }
 
 
 var_or_con :: { RdrNameHsExpr }
@@ -1273,6 +1288,26 @@ qconop :: { RdrName }
        | '`' qconid '`'        { $2 }
 
 -----------------------------------------------------------------------------
+-- Type constructors
+
+tycon  :: { RdrName }  -- Unqualified
+       : CONID                 { mkUnqual tcClsName $1 }
+
+tyconop        :: { RdrName }  -- Unqualified
+       : CONSYM                { mkUnqual tcClsName $1 }
+       | '`' tyvar '`'         { $2 }
+       | '`' tycon '`'         { $2 }
+
+qtycon :: { RdrName }  -- Qualified or unqualified
+       : QCONID                { mkQual tcClsName $1 }
+       | tycon                 { $1 }
+
+qtyconop :: { RdrName }        -- Qualified or unqualified
+         : QCONSYM             { mkQual tcClsName $1 }
+         | '`' QCONID '`'      { mkQual tcClsName $2 }
+         | tyconop             { $1 }
+
+-----------------------------------------------------------------------------
 -- Any operator
 
 op     :: { RdrName }   -- used in infix decls
@@ -1327,27 +1362,7 @@ special_id
        | 'ccall'               { FSLIT("ccall") }
 
 -----------------------------------------------------------------------------
--- ConIds
-
-qconid :: { RdrName }  -- Qualified or unqualifiedb
-       : conid                 { $1 }
-       | QCONID                { mkQual dataName $1 }
-
-conid  :: { RdrName }
-       : CONID                 { mkUnqual dataName $1 }
-
------------------------------------------------------------------------------
--- ConSyms
-
-qconsym :: { RdrName } -- Qualified or unqualifiedb
-       : consym                { $1 }
-       | QCONSYM               { mkQual dataName $1 }
-
-consym :: { RdrName }
-       : CONSYM                { mkUnqual dataName $1 }
-
------------------------------------------------------------------------------
--- VarSyms
+-- Variables 
 
 qvarsym :: { RdrName }
        : varsym                { $1 }
@@ -1376,6 +1391,24 @@ special_sym : '!'        { FSLIT("!") }
            | '*'       { FSLIT("*") }
 
 -----------------------------------------------------------------------------
+-- Data constructors
+
+qconid :: { RdrName }  -- Qualified or unqualifiedb
+       : conid                 { $1 }
+       | QCONID                { mkQual dataName $1 }
+
+conid  :: { RdrName }
+       : CONID                 { mkUnqual dataName $1 }
+
+qconsym :: { RdrName } -- Qualified or unqualified
+       : consym                { $1 }
+       | QCONSYM               { mkQual dataName $1 }
+
+consym :: { RdrName }
+       : CONSYM                { mkUnqual dataName $1 }
+
+
+-----------------------------------------------------------------------------
 -- Literals
 
 literal :: { HsLit }
@@ -1411,20 +1444,6 @@ modid    :: { ModuleName }
                                        '.':unpackFS (snd $1)))
                                }
 
-tycon  :: { RdrName }
-       : CONID                 { mkUnqual tcClsName $1 }
-
-tyconop        :: { RdrName }
-       : CONSYM                { mkUnqual tcClsName $1 }
-
-qtycon :: { RdrName }  -- Qualified or unqualified
-       : QCONID                { mkQual tcClsName $1 }
-       | tycon                 { $1 }
-
-qtyconop :: { RdrName }        -- Qualified or unqualified
-         : QCONSYM             { mkQual tcClsName $1 }
-         | tyconop             { $1 }
-
 commas :: { Int }
        : commas ','                    { $1 + 1 }
        | ','                           { 2 }
index 5c18868..54dadd0 100644 (file)
@@ -44,7 +44,7 @@ import RnEnv          ( availsToNameSet,
                          unitAvailEnv, availEnvElts, availNames,
                          plusAvailEnv, groupAvails, warnUnusedImports, 
                          warnUnusedLocalBinds, warnUnusedModules, 
-                         lookupSrcName, getImplicitStmtFVs, 
+                         lookupSrcName, getImplicitStmtFVs, mkTopFixityEnv,
                          getImplicitModuleFVs, newGlobalName, unQualInScope,
                          ubiquitousNames, lookupOccRn, checkMain,
                          plusGlobalRdrEnv, mkGlobalRdrEnv
@@ -223,12 +223,12 @@ renameExtCore dflags hit hst pcs this_module
     recordLocalSlurps binders                                  `thenRn_`
     closeDecls rn_local_decls fvs                              `thenRn` \ final_decls ->                 
 
-       -- Bail out if we fail
+       -- Bail out if we fail (but dump debug output anyway for debugging)
+    rnDump final_decls                         `thenRn_` 
     checkErrsRn                                `thenRn` \ no_errs_so_far ->
     if not no_errs_so_far then
         returnRn (print_unqualified, Nothing)
     else
-    rnDump final_decls []              `thenRn_` 
     let
        mod_iface = ModIface {  mi_module   = this_module,
                                mi_package  = opt_InPackage,
@@ -426,7 +426,6 @@ rename ghci_mode this_module
     checkErrsRn                                `thenRn` \ no_errs_so_far ->
     if not no_errs_so_far then
        -- Found errors already, so exit now
-       rnDump [] []            `thenRn_`
        returnRn (print_unqualified, Nothing)
     else
        
@@ -476,13 +475,12 @@ rename ghci_mode this_module
     checkErrsRn                                        `thenRn` \ no_errs_so_far ->
     if not no_errs_so_far then
        -- Found errors already, so exit now
-        rnDump [] rn_local_decls               `thenRn_` 
+        rnDump rn_local_decls                  `thenRn_` 
        returnRn (print_unqualified, Nothing)
     else
 
        -- SLURP IN ALL THE NEEDED DECLARATIONS
     slurpImpDecls needed_fvs                   `thenRn` \ rn_imp_decls ->
-    rnDump rn_imp_decls rn_local_decls         `thenRn_` 
 
        -- GENERATE THE VERSION/USAGE INFO
     mkImportInfo mod_name imports              `thenRn` \ my_usages ->
@@ -530,6 +528,9 @@ rename ghci_mode this_module
                               rr_main     = maybe_main_name }
     in
 
+    rnDump final_decls                         `thenRn_` 
+    rnStats rn_imp_decls               `thenRn_`
+
        -- REPORT UNUSED NAMES, AND DEBUG DUMP 
     reportUnusedNames mod_iface print_unqualified 
                      imports full_avail_env gbl_env
@@ -553,31 +554,14 @@ rename ghci_mode this_module
 \begin{code}
 fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv
 fixitiesFromLocalDecls gbl_env decls
-  = foldlRn getFixities emptyNameEnv decls                             `thenRn` \ env -> 
+  = mkTopFixityEnv gbl_env (foldr get_fix_sigs [] decls)               `thenRn` \ env ->
     traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env)))   `thenRn_`
     returnRn env
   where
-    getFixities :: LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv
-    getFixities acc (FixD fix)
-      = fix_decl acc fix
-
-    getFixities acc (TyClD (ClassDecl { tcdSigs = sigs}))
-      = foldlRn fix_decl acc [sig | FixSig sig <- sigs]
-               -- Get fixities from class decl sigs too.
-    getFixities acc other_decl
-      = returnRn acc
-
-    fix_decl acc sig@(FixitySig rdr_name fixity loc)
-       =       -- Check for fixity decl for something not declared
-         pushSrcLocRn loc                      $
-         lookupSrcName gbl_env rdr_name        `thenRn` \ name ->
-
-               -- Check for duplicate fixity decl
-         case lookupNameEnv acc name of
-           Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')     `thenRn_`
-                                        returnRn acc ;
-
-           Nothing                   -> returnRn (extendNameEnv acc name (FixitySig name fixity loc))
+    get_fix_sigs (FixD fix) acc = fix:acc
+    get_fix_sigs (TyClD (ClassDecl { tcdSigs = sigs})) acc
+       = [sig | FixSig sig <- sigs] ++ acc     -- Get fixities from class decl sigs too.
+    get_fix_sigs other_decl acc = acc
 \end{code}
 
 
@@ -793,21 +777,21 @@ closeIfaceDecls dflags hit hst pcs
                map TyClD tycl_decls
        needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
                 unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
-                unionManyNameSets (map tyClDeclFVs tycl_decls)
+                unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
+                ubiquitousNames
+                       -- Data type decls with record selectors,
+                       -- which may appear in the decls, need unpackCString
+                       -- and friends. It's easier to just grab them right now.
+
        local_names    = foldl add emptyNameSet tycl_decls
        add names decl = addListToNameSet names (map fst (tyClDeclSysNames decl ++ tyClDeclNames decl))
     in
-
     recordLocalSlurps local_names      `thenRn_`
 
        -- Do the transitive closure
-    closeDecls decls (needed `plusFV` implicit_fvs) `thenRn` \closed_decls ->
-    rnDump [] closed_decls `thenRn_`
+    closeDecls decls needed            `thenRn` \closed_decls ->
+    rnDump closed_decls                        `thenRn_`
     returnRn closed_decls
-  where
-    implicit_fvs = ubiquitousNames     -- Data type decls with record selectors,
-                                       -- which may appear in the decls, need unpackCString
-                                       -- and friends. It's easier to just grab them right now.
 \end{code}
 
 %*********************************************************
@@ -979,23 +963,31 @@ printMinimalImports this_mod unqual imps
        where
          n_mod = moduleName (nameModule n)
 
-rnDump  :: [RenamedHsDecl]     -- Renamed imported decls
-       -> [RenamedHsDecl]      -- Renamed local decls
+rnDump  :: [RenamedHsDecl]     -- Renamed decls
        -> RnMG ()
-rnDump imp_decls local_decls
+rnDump decls
   = doptRn Opt_D_dump_rn_trace         `thenRn` \ dump_rn_trace ->
     doptRn Opt_D_dump_rn_stats         `thenRn` \ dump_rn_stats ->
     doptRn Opt_D_dump_rn       `thenRn` \ dump_rn ->
     getIfacesRn                        `thenRn` \ ifaces ->
 
-    ioToRnM (do { dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
-                           "Renamer statistics"
-                           (getRnStats imp_decls ifaces) ;
+    ioToRnM ( dumpIfSet dump_rn "Renamer:" 
+                       (vcat (map ppr decls)) )
+                               `thenRn_`
+
+    returnRn ()
 
-                 dumpIfSet dump_rn "Renamer:" 
-                           (vcat (map ppr (local_decls ++ imp_decls)))
-    })                         `thenRn_`
+rnStats :: [RenamedHsDecl]     -- Imported decls
+       -> RnMG ()
+rnStats imp_decls
+  = doptRn Opt_D_dump_rn_trace         `thenRn` \ dump_rn_trace ->
+    doptRn Opt_D_dump_rn_stats         `thenRn` \ dump_rn_stats ->
+    doptRn Opt_D_dump_rn       `thenRn` \ dump_rn ->
+    getIfacesRn                        `thenRn` \ ifaces ->
 
+    ioToRnM (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
+                      "Renamer statistics"
+                       (getRnStats imp_decls ifaces))  `thenRn_`
     returnRn ()
 \end{code}
 
@@ -1048,11 +1040,6 @@ getRnStats imported_decls ifaces
 %************************************************************************
 
 \begin{code}
-dupFixityDecl rdr_name loc1 loc2
-  = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
-         ptext SLIT("at ") <+> ppr loc1,
-         ptext SLIT("and") <+> ppr loc2]
-
 badDeprec d
   = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
         nest 4 (ppr d)]
index 8bc83e2..af0f982 100644 (file)
@@ -27,7 +27,7 @@ import RnMonad
 import RnTypes         ( rnHsSigType, rnHsType )
 import RnExpr          ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
 import RnEnv           ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr,
-                         lookupSigOccRn, bindPatSigTyVars,
+                         lookupSigOccRn, bindPatSigTyVars, extendNestedFixityEnv,
                          warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
                        )
 import CmdLineOpts     ( DynFlag(..) )
@@ -233,7 +233,7 @@ rnMonoBinds mbinds sigs     thing_inside -- Non-empty monobinds
     let
        fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ]
     in
-    extendFixityEnv fixity_sigs $
+    extendNestedFixityEnv fixity_sigs $
 
     rn_mono_binds siglist mbinds          `thenRn` \ (binds, bind_fvs) ->
 
index 1cb95da..3f4ca43 100644 (file)
@@ -8,13 +8,14 @@ module RnEnv where            -- Export everything
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} RnHiFiles
+import {-# SOURCE #-} RnHiFiles( loadInterface )
 
 import FlattenInfo      ( namesNeededForFlattening )
 import HsSyn
-import RdrHsSyn                ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars )
+import RnHsSyn         ( RenamedFixitySig )
+import RdrHsSyn                ( RdrNameIE, RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars )
 import RdrName         ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
-                         mkRdrUnqual, mkRdrQual, 
+                         mkRdrUnqual, mkRdrQual, setRdrNameOcc,
                          lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv,
                          unqualifyRdrName
                        )
@@ -24,18 +25,19 @@ import HscTypes             ( Provenance(..), pprNameProvenance, hasBetterProv,
                          AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), 
                          ModIface(..), GhciMode(..),
                          Deprecations(..), lookupDeprec,
-                         extendLocalRdrEnv
+                         extendLocalRdrEnv, lookupFixity
                        )
 import RnMonad
 import Name            ( Name, 
                          getSrcLoc, nameIsLocalOrFrom,
                          mkInternalName, mkExternalName,
                          mkIPName, nameOccName, nameModule_maybe,
-                         setNameModuleAndLoc
+                         setNameModuleAndLoc, nameModule
                        )
 import NameEnv
 import NameSet
-import OccName         ( OccName, occNameUserString, occNameFlavour )
+import OccName         ( OccName, occNameUserString, occNameFlavour, 
+                         isDataSymOcc, setOccNameSpace, tcName )
 import Module          ( ModuleName, moduleName, mkVanillaModule, 
                          mkSysModuleNameFS, moduleNameFS, WhereFrom(..) )
 import PrelNames       ( mkUnboundName, 
@@ -54,10 +56,11 @@ import SrcLoc               ( SrcLoc, noSrcLoc )
 import Outputable
 import ListSetOps      ( removeDups, equivClasses )
 import Util            ( sortLt )
-import BasicTypes      ( mapIPName )
+import BasicTypes      ( mapIPName, defaultFixity )
 import List            ( nub )
 import UniqFM          ( lookupWithDefaultUFM )
 import Maybe           ( mapMaybe )
+import Maybes          ( orElse, catMaybes )
 import CmdLineOpts
 import FastString      ( FastString )
 \end{code}
@@ -240,9 +243,9 @@ lookupTopBndrRn rdr_name
        Just name -> returnRn name
        Nothing   -> failWithRn (mkUnboundName rdr_name)
                                (unknownNameErr rdr_name)
-  where
-    lookup_local mod global_env rdr_name
-      = case lookupRdrEnv global_env rdr_name of
+
+lookup_local mod global_env rdr_name
+  = case lookupRdrEnv global_env rdr_name of
          Nothing   -> Nothing
          Just gres -> case [n | GRE n _ _ <- gres, nameIsLocalOrFrom mod n] of
                         []     -> Nothing
@@ -420,6 +423,103 @@ lookupSysBinder rdr_name
 
 %*********************************************************
 %*                                                     *
+\subsection{Looking up fixities}
+%*                                                     *
+%*********************************************************
+
+lookupFixity is a bit strange.  
+
+* Nested local fixity decls are put in the local fixity env, which we
+  find with getFixtyEnv
+
+* Imported fixities are found in the HIT or PIT
+
+* Top-level fixity decls in this module may be for Names that are
+    either  Global        (constructors, class operations)
+    or             Local/Exported (everything else)
+  (See notes with RnNames.getLocalDeclBinders for why we have this split.)
+  We put them all in the local fixity environment
+
+\begin{code}
+lookupFixityRn :: Name -> RnMS Fixity
+lookupFixityRn name
+  = getModuleRn                                `thenRn` \ this_mod ->
+    if nameIsLocalOrFrom this_mod name
+    then       -- It's defined in this module
+       getFixityEnv                    `thenRn` \ local_fix_env ->
+       returnRn (lookupLocalFixity local_fix_env name)
+
+    else       -- It's imported
+      -- For imported names, we have to get their fixities by doing a
+      -- loadHomeInterface, and consulting the Ifaces that comes back
+      -- from that, because the interface file for the Name might not
+      -- have been loaded yet.  Why not?  Suppose you import module A,
+      -- which exports a function 'f', thus;
+      --        module CurrentModule where
+      --         import A( f )
+      --       module A( f ) where
+      --         import B( f )
+      -- Then B isn't loaded right away (after all, it's possible that
+      -- nothing from B will be used).  When we come across a use of
+      -- 'f', we need to know its fixity, and it's then, and only
+      -- then, that we load B.hi.  That is what's happening here.
+        loadInterface doc name_mod ImportBySystem      `thenRn` \ iface ->
+       returnRn (lookupFixity (mi_fixities iface) name)
+  where
+    doc      = ptext SLIT("Checking fixity for") <+> ppr name
+    name_mod = moduleName (nameModule name)
+
+--------------------------------
+lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity
+lookupLocalFixity env name
+  = case lookupNameEnv env name of 
+       Just (FixitySig _ fix _) -> fix
+       Nothing                  -> defaultFixity
+
+extendNestedFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a
+-- Used for nested fixity decls
+-- No need to worry about type constructors here,
+-- Should check for duplicates but we don't
+extendNestedFixityEnv fixes enclosed_scope
+  = getFixityEnv       `thenRn` \ fix_env ->
+    let
+       new_fix_env = extendNameEnvList fix_env fixes
+    in
+    setFixityEnv new_fix_env enclosed_scope
+
+mkTopFixityEnv :: GlobalRdrEnv -> [RdrNameFixitySig] -> RnMG LocalFixityEnv
+mkTopFixityEnv gbl_env fix_sigs 
+  = getModuleRn                                `thenRn` \ mod -> 
+    let
+               -- GHC extension: look up both the tycon and data con 
+               -- for con-like things
+               -- If neither are in scope, report an error; otherwise
+               -- add both to the fixity env
+       go fix_env (FixitySig rdr_name fixity loc)
+         = case catMaybes (map (lookup_local mod gbl_env) rdr_names) of
+                 [] -> addErrRn (unknownNameErr rdr_name)      `thenRn_`
+                       returnRn fix_env
+                 ns -> foldlRn add fix_env ns
+
+         where
+           add fix_env name 
+             = case lookupNameEnv fix_env name of
+                 Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc')       `thenRn_`
+                                              returnRn fix_env
+                 Nothing -> returnRn (extendNameEnv fix_env name (FixitySig name fixity loc))
+           
+           rdr_names | isDataSymOcc occ = [rdr_name, rdr_name_tc]
+                     | otherwise            = [rdr_name]
+
+           occ         = rdrNameOcc rdr_name
+           rdr_name_tc = setRdrNameOcc rdr_name (setOccNameSpace occ tcName)
+    in
+    foldlRn go emptyLocalFixityEnv fix_sigs
+\end{code}
+
+
+%*********************************************************
+%*                                                     *
 \subsection{Implicit free vars and sugar names}
 %*                                                     *
 %*********************************************************
@@ -1080,5 +1180,10 @@ warnDeprec name txt
     addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> 
                     quotes (ppr name) <+> text "is deprecated:", 
                     nest 4 (ppr txt) ])
+
+dupFixityDecl rdr_name loc1 loc2
+  = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+         ptext SLIT("at ") <+> ppr loc1,
+         ptext SLIT("and") <+> ppr loc2]
 \end{code}
 
index 1a18cb3..9760ae8 100644 (file)
@@ -24,12 +24,11 @@ import RdrHsSyn
 import RnHsSyn
 import RnMonad
 import RnEnv
-import RnTypes         ( rnHsTypeFVs )
-import RnHiFiles       ( lookupFixityRn )
+import RnTypes         ( rnHsTypeFVs, precParseErr, sectionPrecErr )
 import CmdLineOpts     ( DynFlag(..), opt_IgnoreAsserts )
 import Literal         ( inIntRange, inCharRange )
 import BasicTypes      ( Fixity(..), FixityDirection(..), IPName(..),
-                         defaultFixity, negateFixity )
+                         defaultFixity, negateFixity, compareFixity )
 import PrelNames       ( hasKey, assertIdKey, 
                          eqClassName, foldrName, buildName, eqStringName,
                          cCallableClassName, cReturnableClassName, 
@@ -155,8 +154,8 @@ rnPat (RecPatIn con rpats)
     rnRpats rpats      `thenRn` \ (rpats', fvs) ->
     returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
 
-rnPat (TypePatIn name) =
-    rnHsTypeFVs (text "type pattern") name     `thenRn` \ (name', fvs) ->
+rnPat (TypePatIn name)
+  = rnHsTypeFVs (text "type pattern") name     `thenRn` \ (name', fvs) ->
     returnRn (TypePatIn name', fvs)
 \end{code}
 
@@ -444,7 +443,7 @@ rnExpr (HsType a)
   = rnHsTypeFVs doc a  `thenRn` \ (t, fvT) -> 
     returnRn (HsType t, fvT)
   where 
-    doc = text "renaming a type pattern"
+    doc = text "in a type argument"
 
 rnExpr (ArithSeqIn seq)
   = rn_seq seq                         `thenRn` \ (new_seq, fvs) ->
@@ -811,30 +810,6 @@ checkSectionPrec direction section op arg
                  (pp_arg_op, arg_fix) section)
 \end{code}
 
-Consider
-\begin{verbatim}
-       a `op1` b `op2` c
-\end{verbatim}
-@(compareFixity op1 op2)@ tells which way to arrange appication, or
-whether there's an error.
-
-\begin{code}
-compareFixity :: Fixity -> Fixity
-             -> (Bool,         -- Error please
-                 Bool)         -- Associate to the right: a op1 (b op2 c)
-compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
-  = case prec1 `compare` prec2 of
-       GT -> left
-       LT -> right
-       EQ -> case (dir1, dir2) of
-                       (InfixR, InfixR) -> right
-                       (InfixL, InfixL) -> left
-                       _                -> error_please
-  where
-    right       = (False, True)
-    left         = (False, False)
-    error_please = (True,  False)
-\end{code}
 
 %************************************************************************
 %*                                                                     *
@@ -932,7 +907,6 @@ mkAssertExpr =
 
 \begin{code}
 ppr_op op = quotes (ppr op)    -- Here, op can be a Name or a (Var n), where n is a Name
-ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 pp_prefix_minus = ptext SLIT("prefix `-'")
 
 dupFieldErr str (dup:rest)
@@ -940,17 +914,6 @@ dupFieldErr str (dup:rest)
           quotes (ppr dup),
          ptext SLIT("in record"), text str]
 
-precParseErr op1 op2 
-  = hang (ptext SLIT("precedence parsing error"))
-      4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), 
-              ppr_opfix op2,
-              ptext SLIT("in the same infix expression")])
-
-sectionPrecErr op arg_op section
- = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
-        nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
-        nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
-
 nonStdGuardErr guard
   = hang (ptext
     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
index d5fd399..3bd71f9 100644 (file)
@@ -9,8 +9,6 @@ module RnHiFiles (
        tryLoadInterface, loadOrphanModules,
        loadExports, loadFixDecls, loadDeprecs,
 
-       lookupFixityRn, 
-
        getTyClDeclBinders
    ) where
 
@@ -34,7 +32,7 @@ import HsSyn          ( TyClDecl(..), InstDecl(..), RuleDecl(..),
                        )
 import RdrHsSyn                ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
 import RnHsSyn         ( extractHsTyNames_s )
-import BasicTypes      ( Version, defaultFixity )
+import BasicTypes      ( Version )
 import RnTypes         ( rnHsType )
 import RnEnv
 import RnMonad
@@ -48,7 +46,7 @@ import NameSet
 import Module
 import RdrName         ( rdrNameOcc )
 import SrcLoc          ( mkSrcLoc )
-import Maybes          ( maybeToBool, orElse )
+import Maybes          ( maybeToBool )
 import StringBuffer     ( hGetStringBuffer )
 import FastString      ( mkFastString )
 import ErrUtils         ( Message )
@@ -612,58 +610,6 @@ myTry = Exception.try
 \end{code}
 
 %*********************************************************
-%*                                                     *
-\subsection{Looking up fixities}
-%*                                                     *
-%*********************************************************
-
-@lookupFixityRn@ has to be in RnIfaces (or RnHiFiles), instead of
-its obvious home in RnEnv,  because it calls @loadHomeInterface@.
-
-lookupFixity is a bit strange.  
-
-* Nested local fixity decls are put in the local fixity env, which we
-  find with getFixtyEnv
-
-* Imported fixities are found in the HIT or PIT
-
-* Top-level fixity decls in this module may be for Names that are
-    either  Global        (constructors, class operations)
-    or             Local/Exported (everything else)
-  (See notes with RnNames.getLocalDeclBinders for why we have this split.)
-  We put them all in the local fixity environment
-
-\begin{code}
-lookupFixityRn :: Name -> RnMS Fixity
-lookupFixityRn name
-  = getModuleRn                                `thenRn` \ this_mod ->
-    if nameIsLocalOrFrom this_mod name
-    then       -- It's defined in this module
-       getFixityEnv                    `thenRn` \ local_fix_env ->
-       returnRn (lookupLocalFixity local_fix_env name)
-
-    else       -- It's imported
-      -- For imported names, we have to get their fixities by doing a
-      -- loadHomeInterface, and consulting the Ifaces that comes back
-      -- from that, because the interface file for the Name might not
-      -- have been loaded yet.  Why not?  Suppose you import module A,
-      -- which exports a function 'f', thus;
-      --        module CurrentModule where
-      --         import A( f )
-      --       module A( f ) where
-      --         import B( f )
-      -- Then B isn't loaded right away (after all, it's possible that
-      -- nothing from B will be used).  When we come across a use of
-      -- 'f', we need to know its fixity, and it's then, and only
-      -- then, that we load B.hi.  That is what's happening here.
-       loadHomeInterface doc name              `thenRn` \ iface ->
-       returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
-  where
-    doc      = ptext SLIT("Checking fixity for") <+> ppr name
-\end{code}
-
-
-%*********************************************************
 %*                                                      *
 \subsection{Errors}
 %*                                                      *
index 2759f54..a65430a 100644 (file)
@@ -82,7 +82,8 @@ extractHsTyNames ty
     get (HsFunTy ty1 ty2)      = get ty1 `unionNameSets` get ty2
     get (HsPredTy p)          = extractHsPredTyNames p
     get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets`
-                                unitNameSet tycon
+                                case tycon of { HsTyOp n -> unitNameSet n ; 
+                                                HsArrow  -> emptyNameSet }
     get (HsNumTy n)            = emptyNameSet
     get (HsTyVar tv)          = unitNameSet tv
     get (HsKindSig ty k)       = get ty
index 966e1bc..6fdcd33 100644 (file)
@@ -182,12 +182,7 @@ isCmdLineMode CmdLineMode = True
 isCmdLineMode _ = False
 \end{code}
 
-%===================================================
-\subsubsection{                ENVIRONMENTS}
-%===================================================
-
 \begin{code}
---------------------------------
 type LocalFixityEnv = NameEnv RenamedFixitySig
        -- We keep the whole fixity sig so that we
        -- can report line-number info when there is a duplicate
@@ -195,14 +190,9 @@ type LocalFixityEnv = NameEnv RenamedFixitySig
 
 emptyLocalFixityEnv :: LocalFixityEnv
 emptyLocalFixityEnv = emptyNameEnv
-
-lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity
-lookupLocalFixity env name
-  = case lookupNameEnv env name of 
-       Just (FixitySig _ fix _) -> fix
-       Nothing                  -> defaultFixity
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
 \subsection{Interface file stuff}
@@ -731,13 +721,9 @@ getFixityEnv :: RnMS LocalFixityEnv
 getFixityEnv rn_down (SDown {rn_fixenv = fixity_env})
   = return fixity_env
 
-extendFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a
-extendFixityEnv fixes enclosed_scope
-               rn_down l_down@(SDown {rn_fixenv = fixity_env})
-  = let
-       new_fixity_env = extendNameEnvList fixity_env fixes
-    in
-    enclosed_scope rn_down (l_down {rn_fixenv = new_fixity_env})
+setFixityEnv :: LocalFixityEnv -> RnMS a -> RnMS a
+setFixityEnv fixes enclosed_scope rn_down l_down
+  = enclosed_scope rn_down (l_down {rn_fixenv = fixes})
 \end{code}
 
 %================
index 6366201..fd6a218 100644 (file)
@@ -4,14 +4,15 @@
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
-module RnTypes (  rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs, rnContext ) where
+module RnTypes (  rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs, 
+                 rnContext, precParseErr, sectionPrecErr ) where
 
-import CmdLineOpts     ( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches) )
+import CmdLineOpts     ( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches, Opt_GlasgowExts) )
 
 import HsSyn
 import RdrHsSyn        ( RdrNameContext, RdrNameHsType, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars )
 import RnHsSyn ( RenamedContext, RenamedHsType, extractHsTyNames, tupleTyCon_name )
-import RnEnv   ( lookupOccRn, newIPName, bindTyVarsRn )
+import RnEnv   ( lookupOccRn, newIPName, bindTyVarsRn, lookupFixityRn )
 import RnMonad
 
 import PrelInfo        ( cCallishClassKeys )
@@ -19,6 +20,7 @@ import RdrName        ( elemRdrEnv )
 import NameSet ( FreeVars )
 import Unique  ( Uniquable(..) )
 
+import BasicTypes      ( compareFixity, arrowFixity )
 import List            ( nub )
 import ListSetOps      ( removeDupsEq )
 import Outputable
@@ -97,11 +99,17 @@ rnHsType doc (HsTyVar tyvar)
   = lookupOccRn tyvar          `thenRn` \ tyvar' ->
     returnRn (HsTyVar tyvar')
 
-rnHsType doc (HsOpTy ty1 opname ty2)
-  = lookupOccRn opname `thenRn` \ name' ->
-    rnHsType doc ty1   `thenRn` \ ty1' ->
-    rnHsType doc ty2   `thenRn` \ ty2' -> 
-    returnRn (HsOpTy ty1' name' ty2')
+rnHsType doc (HsOpTy ty1 op ty2)
+  = (case op of
+       HsArrow  -> returnRn HsArrow
+       HsTyOp n -> lookupOccRn n    `thenRn` \ n' ->
+                   returnRn (HsTyOp n')
+    )                          `thenRn` \ op' ->
+    rnHsType doc ty1           `thenRn` \ ty1' ->
+    rnHsType doc ty2           `thenRn` \ ty2' -> 
+    lookupTyFixityRn op'       `thenRn` \ fix ->
+    mkHsOpTyRn op' fix ty1' ty2'
+
 
 rnHsType doc (HsNumTy i)
   | i == 1    = returnRn (HsNumTy i)
@@ -151,6 +159,7 @@ rnHsType doc (HsPredTy pred)
 rnHsTypes doc tys = mapRn (rnHsType doc) tys
 \end{code}
 
+
 \begin{code}
 rnForAll doc forall_tyvars ctxt ty
   = bindTyVarsRn doc forall_tyvars     $ \ new_tyvars ->
@@ -159,6 +168,69 @@ rnForAll doc forall_tyvars ctxt ty
     returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
 \end{code}
 
+
+%*********************************************************
+%*                                                     *
+\subsection{Fixities}
+%*                                                     *
+%*********************************************************
+
+Infix types are read in a *right-associative* way, so that
+       a `op` b `op` c
+is always read in as
+       a `op` (b `op` c)
+
+mkHsOpTyRn rearranges where necessary.  The two arguments
+have already been renamed and rearranged.  It's made rather tiresome
+by the presence of ->
+
+\begin{code}
+lookupTyFixityRn HsArrow    = returnRn arrowFixity
+lookupTyFixityRn (HsTyOp n) 
+  = doptRn Opt_GlasgowExts                     `thenRn` \ glaExts ->
+    warnCheckRn glaExts (infixTyConWarn n)     `thenRn_`
+    lookupFixityRn n
+
+-- Building (ty1 `op1` (ty21 `op2` ty22))
+mkHsOpTyRn :: HsTyOp Name -> Fixity 
+          -> RenamedHsType -> RenamedHsType 
+          -> RnMS RenamedHsType
+
+mkHsOpTyRn op1 fix1 ty1 ty2@(HsOpTy ty21 op2 ty22)
+  = lookupTyFixityRn op2               `thenRn` \ fix2 ->
+    let
+       (nofix_error, associate_right) = compareFixity fix1 fix2
+    in
+    if nofix_error then
+       addErrRn (precParseErr (quotes (ppr op1),fix1) 
+                              (quotes (ppr op2),fix2)) `thenRn_`
+       returnRn (HsOpTy ty1 op1 ty2)
+    else 
+    if not associate_right then
+       -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
+       mkHsOpTyRn op1 fix1 ty1 ty21            `thenRn` \ new_ty ->
+       returnRn (HsOpTy new_ty op2 ty22)
+    else
+    returnRn (HsOpTy ty1 op1 ty2)
+
+mkHsOpTyRn op fix ty1 ty2                      -- Default case, no rearrangment
+  = ASSERT( not_op_ty ty1 )
+    returnRn (HsOpTy ty1 op ty2)
+
+mkHsFunTyRn ty1 ty2                    -- Precedence of function arrow is 0
+  = returnRn (HsFunTy ty1 ty2)         -- so no rearrangement reqd.  Change
+                                       -- this if fixity of -> increases.
+
+not_op_ty (HsOpTy _ _ _) = False
+not_op_ty other         = True
+\end{code}
+
+%*********************************************************
+%*                                                     *
+\subsection{Contexts and predicates}
+%*                                                     *
+%*********************************************************
+
 \begin{code}
 rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext
 rnContext doc ctxt
@@ -201,6 +273,13 @@ rnPred doc (HsIParam n ty)
     returnRn (HsIParam name ty')
 \end{code}
 
+
+%*********************************************************
+%*                                                     *
+\subsection{Errors}
+%*                                                     *
+%*********************************************************
+
 \end{code}
 \begin{code}
 forAllWarn doc ty tyvar
@@ -230,4 +309,20 @@ dupClassAssertWarn ctxt (assertion : dups)
 naughtyCCallContextErr (HsClassP clas _)
   = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), 
         ptext SLIT("in a context")]
+
+precParseErr op1 op2 
+  = hang (ptext SLIT("precedence parsing error"))
+      4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), 
+              ppr_opfix op2,
+              ptext SLIT("in the same infix expression")])
+
+sectionPrecErr op arg_op section
+ = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
+        nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
+        nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
+
+infixTyConWarn op
+  = ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op)
+
+ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 \end{code}
\ No newline at end of file
index 90d5f8b..cd1ba2b 100644 (file)
@@ -18,7 +18,7 @@ module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, tcHsPred,
 
 #include "HsVersions.h"
 
-import HsSyn           ( HsType(..), HsTyVarBndr(..),
+import HsSyn           ( HsType(..), HsTyVarBndr(..), HsTyOp(..),
                           Sig(..), HsPred(..), pprParendHsType, HsTupCon(..), hsTyVarNames )
 import RnHsSyn         ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig, extractHsTyVars )
 import TcHsSyn         ( TcId )
@@ -287,10 +287,12 @@ kcHsType (HsFunTy ty1 ty2)
     kcTypeType ty2     `thenTc_`
     returnTc liftedTypeKind
 
-kcHsType (HsNumTy _)           -- The unit type for generics
-  = returnTc liftedTypeKind
+kcHsType (HsOpTy ty1 HsArrow ty2)
+  = kcTypeType ty1     `thenTc_`
+    kcTypeType ty2     `thenTc_`
+    returnTc liftedTypeKind
 
-kcHsType ty@(HsOpTy ty1 op ty2)
+kcHsType ty@(HsOpTy ty1 (HsTyOp op) ty2)
   = kcTyVar op                         `thenTc` \ op_kind ->
     kcHsType ty1                       `thenTc` \ ty1_kind ->
     kcHsType ty2                       `thenTc` \ ty2_kind ->
@@ -298,6 +300,9 @@ kcHsType ty@(HsOpTy ty1 op ty2)
     kcAppKind op_kind  ty1_kind                `thenTc` \ op_kind' ->
     kcAppKind op_kind' ty2_kind
    
+kcHsType (HsNumTy _)           -- The unit type for generics
+  = returnTc liftedTypeKind
+
 kcHsType (HsPredTy pred)
   = kcHsPred pred              `thenTc_`
     returnTc liftedTypeKind
@@ -426,15 +431,20 @@ tc_type (HsFunTy ty1 ty2)
     tc_type ty2                        `thenTc` \ tau_ty2 ->
     returnTc (mkFunTy tau_ty1 tau_ty2)
 
-tc_type (HsNumTy n)
-  = ASSERT(n== 1)
-    returnTc (mkTyConApp genUnitTyCon [])
+tc_type (HsOpTy ty1 HsArrow ty2)
+  = tc_type ty1 `thenTc` \ tau_ty1 ->
+    tc_type ty2 `thenTc` \ tau_ty2 ->
+    returnTc (mkFunTy tau_ty1 tau_ty2)
 
-tc_type (HsOpTy ty1 op ty2)
+tc_type (HsOpTy ty1 (HsTyOp op) ty2)
   = tc_type ty1 `thenTc` \ tau_ty1 ->
     tc_type ty2 `thenTc` \ tau_ty2 ->
     tc_fun_type op [tau_ty1,tau_ty2]
 
+tc_type (HsNumTy n)
+  = ASSERT(n== 1)
+    returnTc (mkTyConApp genUnitTyCon [])
+
 tc_type (HsAppTy ty1 ty2) = tc_app ty1 [ty2]
 
 tc_type (HsPredTy pred)
index 05b299a..528e13f 100644 (file)
@@ -218,6 +218,59 @@ types.</para>
 Nevertheless, they can be useful when defining "phantom types".</para>
 </sect2>
 
+<sect2 id="infix-tycons">
+<title>Infix type constructors</title>
+
+<para>
+GHC allows type constructors to be operators, and to be written infix, very much 
+like expressions.  More specifically:
+<itemizedlist>
+<listitem><para>
+  A type constructor can be an operator, beginning with a colon; e.g. <literal>:*:</literal>.
+  The lexical syntax is the same as that for data constructors.
+  </para></listitem>
+<listitem><para>
+  Types can be written infix.  For example <literal>Int :*: Bool</literal>.  
+  </para></listitem>
+<listitem><para>
+  Back-quotes work
+  as for expressions, both for type constructors and type variables;  e.g. <literal>Int `Either` Bool</literal>, or
+  <literal>Int `a` Bool</literal>.  Similarly, parentheses work the same; e.g.  <literal>(:*:) Int Bool</literal>.
+  </para></listitem>
+<listitem><para>
+  Fixities may be declared for type constructors just as for data constructors.  However,
+  one cannot distinguish between the two in a fixity declaration; a fixity declaration
+  sets the fixity for a data constructor and the corresponding type constructor.  For example:
+<screen>
+  infixl 7 T, :*:
+</screen>
+  sets the fixity for both type constructor <literal>T</literal> and data constructor <literal>T</literal>,
+  and similarly for <literal>:*:</literal>.
+  <literal>Int `a` Bool</literal>.
+  </para></listitem>
+<listitem><para>
+  Function arrow is <literal>infixr</literal> with fixity 0.  (This might change; I'm not sure what it should be.)
+  </para></listitem>
+<listitem><para>
+  Data type and type-synonym declarations can be written infix.  E.g.
+<screen>
+  data a :*: b = Foo a b
+  type a :+: b = Either a b
+</screen>
+  </para></listitem>
+<listitem><para>
+  The only thing that differs between operators in types and operators in expressions is that
+  ordinary non-constructor operators, such as <literal>+</literal> and <literal>*</literal>
+  are not allowed in types. Reason: the uniform thing to do would be to make them type
+  variables, but that's not very useful.  A less uniform but more useful thing would be to
+  allow them to be type <emphasis>constructors</emphasis>.  But that gives trouble in export
+  lists.  So for now we just exclude them.
+  </para></listitem>
+
+</itemizedlist>
+</para>
+</sect2>
+
 <sect2 id="class-method-types">
 <title>Class method types
 </title>
@@ -1825,7 +1878,7 @@ declarations.  Define your own instances!
 </sect2>
 
 <sect2 id="scoped-type-variables">
-<title>Scoped Type Variables
+<title>Scoped type variables
 </title>
 
 <para>
index af38b51..d1f838e 100644 (file)
     <para>Glasgow Haskell is a changing system so there are sure to be
     bugs in it. </para>
 
-    <para>To repot a bug, either:</para>
+    <para>To report a bug, either:</para>
 
     <itemizedlist>
       <listitem>