-
+{-# OPTIONS -cpp #-}
------------------------------------------------------------------
-- A primop-table mangling program --
------------------------------------------------------------------
module Main where
+#if __GLASGOW_HASKELL__ >= 504
+import Text.ParserCombinators.Parsec
+#else
import Parsec
+#endif
+
import Monad
import Char
import List
"--make-haskell-wrappers"
-> putStr (gen_wrappers p_o_specs)
+ "--make-haskell-source"
+ -> putStr (gen_hs_source p_o_specs)
+
"--make-latex-doc"
-> putStr (gen_latex_doc p_o_specs)
)
"--primop-tag",
"--primop-list",
"--make-haskell-wrappers",
+ "--make-haskell-source",
"--make-latex-doc"
]
-- Code generators -----------------------------------------------
------------------------------------------------------------------
+gen_hs_source (Info defaults entries)
+ = "module GHC.Prim (\n"
+ ++ unlines (map (("\t" ++) . hdr) entries)
+ ++ ") where\n\n{-\n"
+ ++ unlines (map opt defaults) ++ "-}\n"
+ ++ unlines (map ent entries) ++ "\n\n\n"
+ where opt (OptionFalse n) = n ++ " = False"
+ opt (OptionTrue n) = n ++ " = True"
+ opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
+
+ hdr s@(Section {}) = sec s
+ hdr o@(PrimOpSpec {}) = wrap (name o) ++ ","
+
+ ent s@(Section {}) = ""
+ ent o@(PrimOpSpec {}) = spec o
+
+ sec s = "\n-- * " ++ escape (title s) ++ "\n"
+ ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n"
+
+ spec o = comm ++ decl
+ where decl = wrap (name o) ++ " :: " ++ pty (ty o)
+ comm = case (desc o) of
+ [] -> ""
+ d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d)
+
+ pty (TyF 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))) ++ " #)"
+ pbty t = paty t
+
+ paty (TyVar tv) = tv
+ paty t = "(" ++ pty t ++ ")"
+
+ wrap nm | isLower (head nm) = nm
+ | otherwise = "(" ++ nm ++ ")"
+ unlatex s = case s of
+ '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
+ '{':'\\':'t':'t':cs -> markup "@" "@" cs
+ c : cs -> c : unlatex cs
+ [] -> []
+ markup s t cs = s ++ mk (dropWhile isSpace cs)
+ where mk "" = t
+ mk ('\n':cs) = ' ' : mk cs
+ mk ('}':cs) = t ++ unlatex cs
+ mk (c:cs) = c : mk cs
+ escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
+ where special = "/'`\"@<"
+
gen_latex_doc (Info defaults entries)
= "\\primopdefaults{"
++ mk_options defaults
) where (first:rest) = filter is_primop entries
gen_primop_tag (Info defaults entries)
- = unlines (zipWith f (filter is_primop entries) [1..])
+ = unlines (max_def : zipWith f primop_entries [1..])
where
+ primop_entries = filter is_primop entries
f i n = "tagOf_PrimOp " ++ cons i
++ " = _ILIT(" ++ show n ++ ") :: FastInt"
+ max_def = "maxPrimOpTag = " ++ show (length primop_entries) ++ " :: Int"
gen_data_decl (Info defaults entries)
= let conss = map cons (filter is_primop entries)
++ listify (map ppType argTys) ++ " "
++ "(" ++ ppType resTy ++ ")"
-sl_name i = "SLIT(\"" ++ name i ++ "\") "
+sl_name i = "FSLIT(\"" ++ name i ++ "\") "
ppTyVar "a" = "alphaTyVar"
ppTyVar "b" = "betaTyVar"
ppType (TyApp "ThreadId#" []) = "threadIdPrimTy"
ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy"
ppType (TyApp "BCO#" []) = "bcoPrimTy"
-ppType (TyApp "Unit" []) = "unitTy" -- dodgy
+ppType (TyApp "()" []) = "unitTy" -- unitTy is TysWiredIn's name for ()
ppType (TyVar "a") = "alphaTy"
ppType (TyApp "MVar#" [x,y]) = "mkMVarPrimTy " ++ ppType x
++ " " ++ ppType y
+ppType (TyApp "TVar#" [x,y]) = "mkTVarPrimTy " ++ ppType x
+ ++ " " ++ ppType y
ppType (TyUTup ts) = "(mkTupleTy Unboxed " ++ show (length ts)
++ " "
++ listify (map ppType ts) ++ ")"
]
pTyvar = sat (`notElem` ["section","primop","with"]) pName
-pTycon = pConstructor
+pTycon = alts [pConstructor, lexeme (string "()")]
pName = lexeme (then2 (:) lower (many isIdChar))
pConstructor = lexeme (then2 (:) upper (many isIdChar))