Allow primclass and class constraints in primops

In preparation for the primitive class Coercible

5 files changed, 48 insertions, 9 deletions

diff --git a/utils/genprimopcode/Lexer.x b/utils/genprimopcode/Lexer.x
index 3ee35d4dab..ff18e17373 100644
--- a/utils/genprimopcode/Lexer.x
+++ b/utils/genprimopcode/Lexer.x
@@ -33,6 +33,7 @@ words :-
                                                }
                                     }
     <0>         "->"                { mkT TArrow }
+    <0>         "=>"                { mkT TDArrow }
     <0>         "="                 { mkT TEquals }
     <0>         ","                 { mkT TComma }
     <0>         "("                 { mkT TOpenParen }
@@ -43,6 +44,7 @@ words :-
     <0>         "primop"            { mkT TPrimop }
     <0>         "pseudoop"          { mkT TPseudoop }
     <0>         "primtype"          { mkT TPrimtype }
+    <0>         "primclass"         { mkT TPrimclass }
     <0>         "with"              { mkT TWith }
     <0>         "defaults"          { mkT TDefaults }
     <0>         "True"              { mkT TTrue }
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index 333a2d3e46..5e1c9ab84b 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -134,6 +134,7 @@ gen_hs_source (Info defaults entries) =
         ++ "-- module directly.\n"
         ++ "--\n" 
         ++ "-----------------------------------------------------------------------------\n"
+        ++ "{-# LANGUAGE MultiParamTypeClasses #-}\n"
         ++ "module GHC.Prim (\n"
         ++ unlines (map (("\t" ++) . hdr) entries)
         ++ ") where\n"
@@ -148,16 +149,19 @@ gen_hs_source (Info defaults entries) =
            opt (OptionInteger n v) = n ++ " = " ++ show v
            opt (OptionFixity mf) = "fixity" ++ " = " ++ show mf
 
-           hdr s@(Section {})                    = sec s
-           hdr (PrimOpSpec { name = n })         = wrapOp n ++ ","
-           hdr (PseudoOpSpec { name = n })       = wrapOp n ++ ","
-           hdr (PrimTypeSpec { ty = TyApp n _ }) = wrapTy n ++ ","
-           hdr (PrimTypeSpec {})                 = error "Illegal type spec"
+           hdr s@(Section {})                      = sec s
+           hdr (PrimOpSpec { name = n })           = wrapOp n ++ ","
+           hdr (PseudoOpSpec { name = n })         = wrapOp n ++ ","
+           hdr (PrimTypeSpec { ty = TyApp n _ })   = wrapTy n ++ ","
+           hdr (PrimTypeSpec {})                   = error "Illegal type spec"
+           hdr (PrimClassSpec { cls = TyApp n _ }) = wrapTy n ++ ","
+           hdr (PrimClassSpec {})                  = error "Illegal class spec"
 
-           ent   (Section {})      = []
-           ent o@(PrimOpSpec {})   = spec o
-           ent o@(PrimTypeSpec {}) = spec o
-           ent o@(PseudoOpSpec {}) = spec o
+           ent   (Section {})       = []
+           ent o@(PrimOpSpec {})    = spec o
+           ent o@(PrimTypeSpec {})  = spec o
+           ent o@(PrimClassSpec {}) = spec o
+           ent o@(PseudoOpSpec {})  = spec o
 
            sec s = "\n-- * " ++ escape (title s) ++ "\n"
                         ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"
@@ -174,6 +178,8 @@ gen_hs_source (Info defaults entries) =
                               wrapOp n ++ " = let x = x in x" ]
                         PrimTypeSpec { ty = t }   ->
                             [ "data " ++ pprTy t ]
+                        PrimClassSpec { cls = t }   ->
+                            [ "class " ++ pprTy t ]
                         Section { } -> []
 
                    comm = case (desc o) of
@@ -204,6 +210,7 @@ pprTy :: Ty -> String
 pprTy = pty
     where
           pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
+          pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
           pty t      = pbty t
           pbty (TyApp tc ts) = tc ++ concat (map (' ' :) (map paty ts))
           pbty (TyUTup ts)   = "(# "
@@ -274,6 +281,7 @@ gen_ext_core_source entries =
         valEnt _                             = ""
         valEntry name' ty' = parens name' (mkForallTy (freeTvars ty') (pty ty'))
             where pty (TyF t1 t2) = mkFunTy (pty t1) (pty t2)
+                  pty (TyC t1 t2) = mkFunTy (pty t1) (pty t2)
                   pty (TyApp tc ts) = mkTconApp (mkTcon tc) (map pty ts)  
                   pty (TyUTup ts)   = mkUtupleTy (map pty ts)
                   pty (TyVar tv)    = paren $ "Tvar \"" ++ tv ++ "\""
@@ -295,6 +303,7 @@ gen_ext_core_source entries =
                   vKind _   = "Klifted"
 
                   freeTvars (TyF t1 t2)   = freeTvars t1 `union` freeTvars t2
+                  freeTvars (TyC t1 t2)   = freeTvars t1 `union` freeTvars t2
                   freeTvars (TyApp _ tys) = freeTvarss tys
                   freeTvars (TyVar v)     = [v]
                   freeTvars (TyUTup tys)  = freeTvarss tys
@@ -360,6 +369,13 @@ gen_latex_doc (Info defaults entries)
                  ++ d ++ "}{"
                  ++ mk_options o
                  ++ "}\n"
+           mk_entry (PrimClassSpec {cls=t,desc=d,opts=o}) =
+                 "\\primclassspec{"
+                 ++ latex_encode (mk_source_ty t) ++ "}{"
+                 ++ latex_encode (mk_core_ty t) ++ "}{"
+                 ++ d ++ "}{"
+                 ++ mk_options o
+                 ++ "}\n"
            mk_entry (PseudoOpSpec {name=n,ty=t,desc=d,opts=o}) =
                  "\\pseudoopspec{"
                  ++ latex_encode (zencode n) ++ "}{"
@@ -370,6 +386,7 @@ gen_latex_doc (Info defaults entries)
                  ++ "}\n"
            mk_source_ty typ = pty typ
              where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
+                   pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
                    pty t = pbty t
                    pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts)))
                    pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
@@ -379,6 +396,7 @@ gen_latex_doc (Info defaults entries)
            
            mk_core_ty typ = foralls ++ (pty typ)
              where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
+                   pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
                    pty t = pbty t
                    pbty (TyApp tc ts) = (zencode tc) ++ (concat (map (' ':) (map paty ts)))
                    pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts))))
@@ -394,6 +412,7 @@ gen_latex_doc (Info defaults entries)
                    tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs)
                    tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs)
            tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2
+           tvars_of (TyC t1 t2) = tvars_of t1 `union` tvars_of t2
            tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts)
            tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts)
            tvars_of (TyVar tv) = [tv]
@@ -712,6 +731,7 @@ ppType (TyUTup ts)               = "(mkTupleTy UnboxedTuple "
                                    ++ listify (map ppType ts) ++ ")"
 
 ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
+ppType (TyC s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
 
 ppType other
    = error ("ppType: can't handle: " ++ show other ++ "\n")
@@ -726,16 +746,19 @@ listify ss = "[" ++ concat (intersperse ", " ss) ++ "]"
 
 flatTys :: Ty -> ([Ty],Ty)
 flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
+flatTys (TyC t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
 flatTys other       = ([],other)
 
 tvsIn :: Ty -> [TyVar]
 tvsIn (TyF t1 t2)    = tvsIn t1 ++ tvsIn t2
+tvsIn (TyC t1 t2)    = tvsIn t1 ++ tvsIn t2
 tvsIn (TyApp _ tys)  = concatMap tvsIn tys
 tvsIn (TyVar tv)     = [tv]
 tvsIn (TyUTup tys)   = concatMap tvsIn tys
 
 tyconsIn :: Ty -> [TyCon]
 tyconsIn (TyF t1 t2)    = tyconsIn t1 `union` tyconsIn t2
+tyconsIn (TyC t1 t2)    = tyconsIn t1 `union` tyconsIn t2
 tyconsIn (TyApp tc tys) = foldr union [tc] $ map tyconsIn tys
 tyconsIn (TyVar _)      = []
 tyconsIn (TyUTup tys)   = foldr union [] $ map tyconsIn tys
diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y
index c5c6080548..eb76cb0407 100644
--- a/utils/genprimopcode/Parser.y
+++ b/utils/genprimopcode/Parser.y
@@ -23,6 +23,7 @@ import Syntax
 
 %token
     '->'            { TArrow }
+    '=>'            { TDArrow }
     '='             { TEquals }
     ','             { TComma }
     '('             { TOpenParen }
@@ -35,6 +36,7 @@ import Syntax
     primop          { TPrimop }
     pseudoop        { TPseudoop }
     primtype        { TPrimtype }
+    primclass       { TPrimclass }
     with            { TWith }
     defaults        { TDefaults }
     true            { TTrue }
@@ -88,6 +90,7 @@ pEntries : pEntry pEntries { $1 : $2 }
 pEntry :: { Entry }
 pEntry : pPrimOpSpec   { $1 }
        | pPrimTypeSpec { $1 }
+       | pPrimClassSpec { $1 }
        | pPseudoOpSpec { $1 }
        | pSection      { $1 }
 
@@ -108,6 +111,10 @@ pPrimTypeSpec :: { Entry }
 pPrimTypeSpec : primtype pType pDesc pWithOptions
                 { PrimTypeSpec { ty = $2, desc = $3, opts = $4 } }
 
+pPrimClassSpec :: { Entry }
+pPrimClassSpec : primclass pType pDesc pWithOptions
+                { PrimClassSpec { cls = $2, desc = $3, opts = $4 } }
+
 pPseudoOpSpec :: { Entry }
 pPseudoOpSpec : pseudoop string pType pDesc pWithOptions
                 { PseudoOpSpec { name = $2, ty = $3, desc = $4, opts = $5 } }
@@ -142,6 +149,7 @@ pInside : '{' pInsides '}' { "{" ++ $2 ++ "}" }
 
 pType :: { Ty }
 pType : paT '->' pType { TyF $1 $3 }
+      | paT '=>' pType { TyC $1 $3 }
       | paT            { $1 }
 
 -- Atomic types
diff --git a/utils/genprimopcode/ParserM.hs b/utils/genprimopcode/ParserM.hs
index 5109814022..8093675651 100644
--- a/utils/genprimopcode/ParserM.hs
+++ b/utils/genprimopcode/ParserM.hs
@@ -58,6 +58,7 @@ init_state = St {
 
 data Token = TEOF
            | TArrow
+           | TDArrow
            | TEquals
            | TComma
            | TOpenParen
@@ -70,6 +71,7 @@ data Token = TEOF
            | TPrimop
            | TPseudoop
            | TPrimtype
+           | TPrimclass
            | TWith
            | TDefaults
            | TTrue
diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs
index 9d13f91e96..333ea2c4c7 100644
--- a/utils/genprimopcode/Syntax.hs
+++ b/utils/genprimopcode/Syntax.hs
@@ -26,6 +26,9 @@ data Entry
     | PrimTypeSpec { ty    :: Ty,      -- name in prog text
                      desc  :: String,      -- description
                      opts  :: [Option] }   -- default overrides
+    | PrimClassSpec { cls   :: Ty,      -- name in prog text
+                      desc  :: String,      -- description
+                      opts  :: [Option] }   -- default overrides
     | Section { title :: String,         -- section title
                 desc  :: String }        -- description
     deriving Show
@@ -51,6 +54,7 @@ data Category
 -- types
 data Ty
    = TyF    Ty Ty
+   | TyC    Ty Ty -- We only allow one constraint, keeps the grammar simpler
    | TyApp  TyCon [Ty]
    | TyVar  TyVar
    | TyUTup [Ty]   -- unboxed tuples; just a TyCon really,