Fix some inconsistencies in the code and docs of primitives

[ghc-hetmet.git] / utils / genprimopcode / Main.hs

diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index 8cfbed3..24820d8 100644 (file)
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -190,7 +190,9 @@ gen_ext_core_source entries =
    ++ "-- This module is automatically generated by the GHC utility\n"
    ++ "-- \"genprimopcode\". Do not edit!\n"
    ++ "-----------------------------------------------------------------------\n"
-   ++ "module PrimEnv(primTcs, primVals) where\nimport Core\nimport Encoding\n\n"
+   ++ "module Language.Core.PrimEnv(primTcs, primVals, intLitTypes, ratLitTypes,"
+   ++ "\n charLitTypes, stringLitTypes) where\nimport Language.Core.Core"
+   ++ "\nimport Language.Core.Encoding\n\n"
    ++ "primTcs :: [(Tcon, Kind)]\n"
    ++ "primTcs = [\n"
    ++ printList tcEnt entries 
@@ -198,7 +200,24 @@ gen_ext_core_source entries =
    ++ "primVals :: [(Var, Ty)]\n"
    ++ "primVals = [\n"
    ++ printList valEnt entries
+   ++ "]\n"
+   ++ "intLitTypes :: [Ty]\n"
+   ++ "intLitTypes = [\n"
+   ++ printList tyEnt (intLitTys entries)
+   ++ "]\n"
+   ++ "ratLitTypes :: [Ty]\n"
+   ++ "ratLitTypes = [\n"
+   ++ printList tyEnt (ratLitTys entries)
+   ++ "]\n"
+   ++ "charLitTypes :: [Ty]\n"
+   ++ "charLitTypes = [\n"
+   ++ printList tyEnt (charLitTys entries)
+   ++ "]\n"
+   ++ "stringLitTypes :: [Ty]\n"
+   ++ "stringLitTypes = [\n"
+   ++ printList tyEnt (stringLitTys entries)
    ++ "]\n\n"
+
   where printList f = concat . intersperse ",\n" . filter (not . null) . map f   
         tcEnt  (PrimTypeSpec {ty=t}) = 
            case t of
@@ -253,20 +272,31 @@ gen_ext_core_source entries =
                   tapp s nextArg = paren $ "Tapp " ++ s ++ " " ++ paren nextArg
                   tcUTuple n = paren $ "Tcon " ++ paren (qualify False $ "Z" 
                                                           ++ show n ++ "H")
-                  -- more hacks. might be better to do this on the ext-core side,
-                  -- as per earlier comment
-                  qualify _ tc | tc == "ByteArr#" = qualify True "ByteArray#"
-                  qualify _ tc | tc == "MutArr#" = qualify True "MutableArray#"
-                  qualify _ tc | tc == "MutByteArr#" = 
-                     qualify True "MutableByteArray#"
-                  qualify _ tc | tc == "Bool" = "Just boolMname" ++ ", " 
+
+        tyEnt (PrimTypeSpec {ty=(TyApp tc args)}) = "   " ++ paren ("Tcon " ++
+                                                       (paren (qualify True tc)))
+        tyEnt _ = ""
+
+        -- more hacks. might be better to do this on the ext-core side,
+        -- as per earlier comment
+        qualify _ tc | tc == "Bool" = "Just boolMname" ++ ", " 
                                                 ++ ze True tc
-                  qualify _ tc | tc == "()"  = "Just baseMname" ++ ", "
+        qualify _ tc | tc == "()"  = "Just baseMname" ++ ", "
                                                 ++ ze True tc
-                  qualify enc tc = "Just primMname" ++ ", " ++ (ze enc tc)
-                  ze enc tc      = (if enc then "zEncodeString " else "")
+        qualify enc tc = "Just primMname" ++ ", " ++ (ze enc tc)
+        ze enc tc      = (if enc then "zEncodeString " else "")
                                       ++ "\"" ++ tc ++ "\""
 
+        intLitTys = prefixes ["Int", "Word", "Addr", "Char"]
+        ratLitTys = prefixes ["Float", "Double"]
+        charLitTys = prefixes ["Char"]
+        stringLitTys = prefixes ["Addr"]
+        prefixes ps = filter (\ t ->
+                        case t of
+                          (PrimTypeSpec {ty=(TyApp tc args)}) ->
+                            any (\ p -> p `isPrefixOf` tc) ps
+                          _ -> False)
+
         parens n ty = "      (zEncodeString \"" ++ n ++ "\", " ++ ty ++ ")"
         paren s = "(" ++ s ++ ")"
         quot s = "\"" ++ s ++ "\""
@@ -431,9 +461,9 @@ gen_latex_doc (Info defaults entries)
 
 gen_wrappers :: Info -> String
 gen_wrappers (Info _ entries)
-   = "{-# OPTIONS -fno-implicit-prelude #-}\n" 
+   = "{-# LANGUAGE NoImplicitPrelude #-}\n" 
        -- Dependencies on Prelude must be explicit in libraries/base, but we
-       -- don't need the Prelude here so we add -fno-implicit-prelude.
+       -- don't need the Prelude here so we add NoImplicitPrelude.
      ++ "module GHC.PrimopWrappers where\n" 
      ++ "import qualified GHC.Prim\n" 
      ++ unlines (map f (filter (not.dodgy) (filter is_primop entries)))
@@ -547,7 +577,7 @@ mkPOI_RHS_text i
                       ++ "(" ++ ppType resTy ++ ")"
 
 sl_name :: Entry -> String
-sl_name i = "FSLIT(\"" ++ name i ++ "\") "
+sl_name i = "(fsLit \"" ++ name i ++ "\") "
 
 ppTyVar :: String -> String
 ppTyVar "a" = "alphaTyVar"
@@ -570,7 +600,7 @@ ppType (TyApp "Word64#"     []) = "word64PrimTy"
 ppType (TyApp "Addr#"       []) = "addrPrimTy"
 ppType (TyApp "Float#"      []) = "floatPrimTy"
 ppType (TyApp "Double#"     []) = "doublePrimTy"
-ppType (TyApp "ByteArr#"    []) = "byteArrayPrimTy"
+ppType (TyApp "ByteArray#"  []) = "byteArrayPrimTy"
 ppType (TyApp "RealWorld"   []) = "realWorldTy"
 ppType (TyApp "ThreadId#"   []) = "threadIdPrimTy"
 ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy"
@@ -585,10 +615,10 @@ ppType (TyVar "o")               = "openAlphaTy"
 ppType (TyApp "State#" [x])      = "mkStatePrimTy " ++ ppType x
 ppType (TyApp "MutVar#" [x,y])   = "mkMutVarPrimTy " ++ ppType x 
                                    ++ " " ++ ppType y
-ppType (TyApp "MutArr#" [x,y])   = "mkMutableArrayPrimTy " ++ ppType x 
-                                   ++ " " ++ ppType y
+ppType (TyApp "MutableArray#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x
+                                    ++ " " ++ ppType y
 
-ppType (TyApp "MutByteArr#" [x]) = "mkMutableByteArrayPrimTy " 
+ppType (TyApp "MutableByteArray#" [x]) = "mkMutableByteArrayPrimTy " 
                                    ++ ppType x
 
 ppType (TyApp "Array#" [x])      = "mkArrayPrimTy " ++ ppType x