further fix for floating point primitives

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsTypes.lhs

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 03d414a..f1343a3 100644 (file)
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -1,4 +1,4 @@
-]%
+%
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[HsTypes]{Abstract syntax: user-defined types}
@@ -17,14 +17,11 @@ module HsTypes (
        mkExplicitHsForAllTy, mkImplicitHsForAllTy, 
        hsTyVarName, hsTyVarNames, replaceTyVarName,
        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
-       splitHsInstDeclTy,
+       splitHsInstDeclTy, splitHsFunType,
        
        -- Type place holder
        PostTcType, placeHolderType,
 
-       -- Name place holder
-       SyntaxName, placeHolderName,
-
        -- Printing
        pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr
     ) where
@@ -36,12 +33,9 @@ import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 import Type            ( Type )
 import Kind            ( {- instance Outputable Kind -}, Kind,
                          pprParendKind, pprKind, isLiftedTypeKind )
-import Name            ( Name, mkInternalName )
-import OccName         ( mkVarOcc )
 import BasicTypes      ( IPName, Boxity, tupleParens )
-import PrelNames       ( unboundKey )
-import SrcLoc          ( noSrcLoc, Located(..), unLoc, noSrcSpan )
-import CmdLineOpts     ( opt_PprStyle_Debug )
+import SrcLoc          ( Located(..), unLoc, noSrcSpan )
+import StaticFlags     ( opt_PprStyle_Debug )
 import Outputable
 \end{code}
 
@@ -60,18 +54,6 @@ type PostTcType = Type               -- Used for slots in the abstract syntax
 
 placeHolderType :: PostTcType  -- Used before typechecking
 placeHolderType  = panic "Evaluated the place holder for a PostTcType"
-
-
-type SyntaxName = Name         -- These names are filled in by the renamer
-                               -- Before then they are a placeHolderName (so that
-                               --      we can still print the HsSyn)
-                               -- They correspond to "rebindable syntax";
-                               -- See RnEnv.lookupSyntaxName
-
-placeHolderName :: SyntaxName
-placeHolderName = mkInternalName unboundKey 
-                       (mkVarOcc FSLIT("syntaxPlaceHolder")) 
-                       noSrcLoc
 \end{code}
 
 %************************************************************************
@@ -195,10 +177,14 @@ mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty
 mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty
 
 -- mk_forall_ty makes a pure for-all type (no context)
-mk_forall_ty Explicit [] ty                          = unLoc ty        -- Explicit for-all with no tyvars
-mk_forall_ty exp  tvs  (L _ (HsParTy ty))                    = mk_forall_ty exp tvs ty
+mk_forall_ty exp  tvs  (L _ (HsParTy ty))                  = mk_forall_ty exp tvs ty
 mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty
-mk_forall_ty exp  tvs  ty                            = HsForAllTy exp tvs (L noSrcSpan []) ty
+mk_forall_ty exp  tvs  ty                                  = HsForAllTy exp tvs (L noSrcSpan []) ty
+       -- Even if tvs is empty, we still make a HsForAll!
+       -- In the Implicit case, this signals the place to do implicit quantification
+       -- In the Explicit case, it prevents implicit quantification    
+       --      (see the sigtype production in Parser.y.pp)
+       --      so that (forall. ty) isn't implicitly quantified
 
 Implicit `plus` Implicit = Implicit
 exp1     `plus` exp2     = Explicit
@@ -208,7 +194,7 @@ type LHsTyVarBndr name = Located (HsTyVarBndr name)
 data HsTyVarBndr name
   = UserTyVar name
   | KindedTyVar name Kind
-       -- *** NOTA BENE *** A "monotype" in a pragma can have
+       --  *** NOTA BENE *** A "monotype" in a pragma can have
        -- for-alls in it, (mostly to do with dictionaries).  These
        -- must be explicitly Kinded.
 
@@ -253,6 +239,16 @@ splitHsInstDeclTy inst_ty
   where
     split_tau tvs cxt (HsPredTy (HsClassP cls tys)) = (tvs, cxt, cls, tys)
     split_tau tvs cxt (HsParTy (L _ ty))           = split_tau tvs cxt ty
+
+-- Splits HsType into the (init, last) parts
+-- Breaks up any parens in the result type: 
+--     splitHsFunType (a -> (b -> c)) = ([a,b], c)
+splitHsFunType :: LHsType name -> ([LHsType name], LHsType name)
+splitHsFunType (L l (HsFunTy x y)) = (x:args, res)
+  where
+  (args, res) = splitHsFunType y
+splitHsFunType (L _ (HsParTy ty))  = splitHsFunType ty
+splitHsFunType other              = ([], other)
 \end{code}