diff options
author | Joachim Breitner <mail@joachim-breitner.de> | 2013-09-13 14:06:46 +0200 |
---|---|---|
committer | Joachim Breitner <mail@joachim-breitner.de> | 2013-09-13 21:57:44 +0200 |
commit | e239753c349f925b576b72dc3445934cba8bcd50 (patch) | |
tree | ab133f742c6be5ea1887a403028db8842810fa13 /utils/genprimopcode | |
parent | c228418c968263d5501dafee348665def7f7a53d (diff) | |
download | haskell-e239753c349f925b576b72dc3445934cba8bcd50.tar.gz |
Allow primclass and class constraints in primops
In preparation for the primitive class Coercible
Diffstat (limited to 'utils/genprimopcode')
-rw-r--r-- | utils/genprimopcode/Lexer.x | 2 | ||||
-rw-r--r-- | utils/genprimopcode/Main.hs | 41 | ||||
-rw-r--r-- | utils/genprimopcode/Parser.y | 8 | ||||
-rw-r--r-- | utils/genprimopcode/ParserM.hs | 2 | ||||
-rw-r--r-- | utils/genprimopcode/Syntax.hs | 4 |
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, |