"--make-latex-doc"
-> putStr (gen_latex_doc p_o_specs)
+
+ _ -> error "Should not happen, known_args out of sync?"
)
known_args :: [String]
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"
- ent s@(Section {}) = ""
+ ent (Section {}) = ""
ent o@(PrimOpSpec {}) = spec o
ent o@(PrimTypeSpec {}) = spec o
ent o@(PseudoOpSpec {}) = spec o
PrimOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pty t
PseudoOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pty t
PrimTypeSpec { ty = t } -> "data " ++ pty t
+ Section { } -> ""
comm = case (desc o) of
[] -> ""
'{':'\\':'i':'t':cs -> markup "/" "/" cs
c : cs -> c : unlatex cs
[] -> []
- markup s t cs = s ++ mk (dropWhile isSpace cs)
+ markup s t xs = s ++ mk (dropWhile isSpace xs)
where mk "" = t
mk ('\n':cs) = ' ' : mk cs
mk ('}':cs) = t ++ unlatex cs
++ mk_options defaults
++ "}\n"
++ (concat (map mk_entry entries))
- where mk_entry (PrimOpSpec {cons=cons,name=name,ty=ty,cat=cat,desc=desc,opts=opts}) =
+ where mk_entry (PrimOpSpec {cons=constr,name=n,ty=t,cat=c,desc=d,opts=o}) =
"\\primopdesc{"
- ++ latex_encode cons ++ "}{"
- ++ latex_encode name ++ "}{"
- ++ latex_encode (zencode name) ++ "}{"
- ++ latex_encode (show cat) ++ "}{"
- ++ latex_encode (mk_source_ty ty) ++ "}{"
- ++ latex_encode (mk_core_ty ty) ++ "}{"
- ++ desc ++ "}{"
- ++ mk_options opts
+ ++ latex_encode constr ++ "}{"
+ ++ latex_encode n ++ "}{"
+ ++ latex_encode (zencode n) ++ "}{"
+ ++ latex_encode (show c) ++ "}{"
+ ++ latex_encode (mk_source_ty t) ++ "}{"
+ ++ latex_encode (mk_core_ty t) ++ "}{"
+ ++ d ++ "}{"
+ ++ mk_options o
++ "}\n"
- mk_entry (Section {title=title,desc=desc}) =
+ mk_entry (Section {title=ti,desc=d}) =
"\\primopsection{"
- ++ latex_encode title ++ "}{"
- ++ desc ++ "}\n"
- mk_source_ty t = pty t
+ ++ latex_encode ti ++ "}{"
+ ++ d ++ "}\n"
+ mk_entry (PrimTypeSpec {ty=t,desc=d,opts=o}) =
+ "\\primtypespec{"
+ ++ 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) ++ "}{"
+ ++ latex_encode (mk_source_ty t) ++ "}{"
+ ++ latex_encode (mk_core_ty t) ++ "}{"
+ ++ d ++ "}{"
+ ++ mk_options o
+ ++ "}\n"
+ mk_source_ty typ = pty typ
where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
pty t = pbty t
pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts)))
paty (TyVar tv) = tv
paty t = "(" ++ pty t ++ ")"
- mk_core_ty t = foralls ++ (pty t)
+ mk_core_ty typ = foralls ++ (pty typ)
where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
pty t = pbty t
pbty (TyApp tc ts) = (zencode tc) ++ (concat (map (' ':) (map paty ts)))
utuplenm 1 = "(# #)"
utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)"
foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars)
- tvars = tvars_of t
+ tvars = tvars_of typ
tbinds [] = ". "
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 (TyApp tc ts) = foldl union [] (map tvars_of ts)
+ 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]
- mk_options opts =
+ mk_options o =
"\\primoptions{"
- ++ mk_has_side_effects opts ++ "}{"
- ++ mk_out_of_line opts ++ "}{"
- ++ mk_commutable opts ++ "}{"
- ++ mk_needs_wrapper opts ++ "}{"
- ++ mk_can_fail opts ++ "}{"
- ++ latex_encode (mk_strictness opts) ++ "}{"
- ++ latex_encode (mk_usage opts)
+ ++ mk_has_side_effects o ++ "}{"
+ ++ mk_out_of_line o ++ "}{"
+ ++ mk_commutable o ++ "}{"
+ ++ mk_needs_wrapper o ++ "}{"
+ ++ mk_can_fail o ++ "}{"
+ ++ latex_encode (mk_strictness o) ++ "}{"
+ ++ latex_encode (mk_usage o)
++ "}"
- mk_has_side_effects opts = mk_bool_opt opts "has_side_effects" "Has side effects." "Has no side effects."
- mk_out_of_line opts = mk_bool_opt opts "out_of_line" "Implemented out of line." "Implemented in line."
- mk_commutable opts = mk_bool_opt opts "commutable" "Commutable." "Not commutable."
- mk_needs_wrapper opts = mk_bool_opt opts "needs_wrapper" "Needs wrapper." "Needs no wrapper."
- mk_can_fail opts = mk_bool_opt opts "can_fail" "Can fail." "Cannot fail."
+ mk_has_side_effects o = mk_bool_opt o "has_side_effects" "Has side effects." "Has no side effects."
+ mk_out_of_line o = mk_bool_opt o "out_of_line" "Implemented out of line." "Implemented in line."
+ mk_commutable o = mk_bool_opt o "commutable" "Commutable." "Not commutable."
+ mk_needs_wrapper o = mk_bool_opt o "needs_wrapper" "Needs wrapper." "Needs no wrapper."
+ mk_can_fail o = mk_bool_opt o "can_fail" "Can fail." "Cannot fail."
- mk_bool_opt opts opt_name if_true if_false =
- case lookup_attrib opt_name opts of
+ mk_bool_opt o opt_name if_true if_false =
+ case lookup_attrib opt_name o of
Just (OptionTrue _) -> if_true
Just (OptionFalse _) -> if_false
+ Just (OptionString _ _) -> error "String value for boolean option"
Nothing -> ""
- mk_strictness opts =
- case lookup_attrib "strictness" opts of
+ mk_strictness o =
+ case lookup_attrib "strictness" o of
Just (OptionString _ s) -> s -- for now
+ Just _ -> error "Boolean value for strictness"
Nothing -> ""
- mk_usage opts =
- case lookup_attrib "usage" opts of
+ mk_usage o =
+ case lookup_attrib "usage" o of
Just (OptionString _ s) -> s -- for now
+ Just _ -> error "Boolean value for usage"
Nothing -> ""
- zencode cs =
- case maybe_tuple cs of
+ zencode xs =
+ case maybe_tuple xs of
Just n -> n -- Tuples go to Z2T etc
- Nothing -> concat (map encode_ch cs)
+ Nothing -> concat (map encode_ch xs)
where
maybe_tuple "(# #)" = Just("Z1H")
maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
- (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H")
- other -> Nothing
+ (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
+ _ -> Nothing
maybe_tuple "()" = Just("Z0T")
maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of
- (n, ')' : cs) -> Just ('Z' : shows (n+1) "T")
- other -> Nothing
- maybe_tuple other = Nothing
+ (n, ')' : _) -> Just ('Z' : shows (n+1) "T")
+ _ -> Nothing
+ maybe_tuple _ = Nothing
count_commas :: Int -> String -> (Int, String)
count_commas n (',' : cs) = count_commas (n+1) cs
latex_encode (c:cs) = c:(latex_encode cs)
gen_wrappers :: Info -> String
-gen_wrappers (Info defaults entries)
+gen_wrappers (Info _ entries)
= "{-# OPTIONS -fno-implicit-prelude #-}\n"
-- Dependencies on Prelude must be explicit in libraries/base, but we
-- don't need the Prelude here so we add -fno-implicit-prelude.
]
gen_primop_list :: Info -> String
-gen_primop_list (Info defaults entries)
+gen_primop_list (Info _ entries)
= unlines (
[ " [" ++ cons first ]
++
- map (\pi -> " , " ++ cons pi) rest
+ map (\p -> " , " ++ cons p) rest
++
[ " ]" ]
) where (first:rest) = filter is_primop entries
gen_primop_tag :: Info -> String
-gen_primop_tag (Info defaults entries)
- = unlines (max_def : zipWith f primop_entries [1..])
+gen_primop_tag (Info _ entries)
+ = unlines (max_def : zipWith f primop_entries [1 :: Int ..])
where
primop_entries = filter is_primop entries
f i n = "tagOf_PrimOp " ++ cons i
max_def = "maxPrimOpTag = " ++ show (length primop_entries) ++ " :: Int"
gen_data_decl :: Info -> String
-gen_data_decl (Info defaults entries)
+gen_data_decl (Info _ entries)
= let conss = map cons (filter is_primop entries)
in "data PrimOp\n = " ++ head conss ++ "\n"
++ unlines (map (" | "++) (tail conss))
gen_switch_from_attribs :: String -> String -> Info -> String
gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
= let defv = lookup_attrib attrib_name defaults
- alts = catMaybes (map mkAlt (filter is_primop entries))
+ alternatives = catMaybes (map mkAlt (filter is_primop entries))
getAltRhs (OptionFalse _) = "False"
getAltRhs (OptionTrue _) = "True"
case defv of
Nothing -> error ("gen_switch_from: " ++ attrib_name)
Just xx
- -> unlines alts
+ -> unlines alternatives
++ fn_name ++ " other = " ++ getAltRhs xx ++ "\n"
------------------------------------------------------------------
------------------------------------------------------------------
gen_primop_info :: Info -> String
-gen_primop_info (Info defaults entries)
+gen_primop_info (Info _ entries)
= unlines (map mkPOItext (filter is_primop entries))
mkPOItext :: Entry -> String
= case cat i of
Compare
-> case ty i of
- TyF t1 (TyF t2 td)
+ TyF t1 (TyF _ _)
-> "mkCompare " ++ sl_name i ++ ppType t1
+ _ -> error "Type error in comparison op"
Monadic
-> case ty i of
- TyF t1 td
+ TyF t1 _
-> "mkMonadic " ++ sl_name i ++ ppType t1
+ _ -> error "Type error in monadic op"
Dyadic
-> case ty i of
- TyF t1 (TyF t2 td)
+ TyF t1 (TyF _ _)
-> "mkDyadic " ++ sl_name i ++ ppType t1
+ _ -> error "Type error in dyadic op"
GenPrimOp
-> let (argTys, resTy) = flatTys (ty i)
tvs = nub (tvsIn (ty i))
++ listify (map ppTyVar tvs) ++ " "
++ listify (map ppType argTys) ++ " "
++ "(" ++ ppType resTy ++ ")"
-
+
sl_name :: Entry -> String
sl_name i = "FSLIT(\"" ++ name i ++ "\") "
ppTyVar "c" = "gammaTyVar"
ppTyVar "s" = "deltaTyVar"
ppTyVar "o" = "openAlphaTyVar"
+ppTyVar _ = error "Unknown type var"
ppType :: Ty -> String
ppType (TyApp "Bool" []) = "boolTy"
tvsIn :: Ty -> [TyVar]
tvsIn (TyF t1 t2) = tvsIn t1 ++ tvsIn t2
-tvsIn (TyApp tc tys) = concatMap tvsIn tys
+tvsIn (TyApp _ tys) = concatMap tvsIn tys
tvsIn (TyVar tv) = [tv]
tvsIn (TyUTup tys) = concatMap tvsIn tys
| t1 == t2 && td == TyApp "Bool" [] = True
sane_ty Monadic (TyF t1 td)
| t1 == td = True
-sane_ty Dyadic (TyF t1 (TyF t2 td))
+sane_ty Dyadic (TyF t1 (TyF t2 _))
| t1 == t2 && t2 == t2 = True
-sane_ty GenPrimOp any_old_thing
+sane_ty GenPrimOp _
= True
sane_ty _ _
= False
get_attrib_name (OptionString nm _) = nm
lookup_attrib :: String -> [Option] -> Maybe Option
-lookup_attrib nm [] = Nothing
+lookup_attrib _ [] = Nothing
lookup_attrib nm (a:as)
= if get_attrib_name a == nm then Just a else lookup_attrib nm as
pOption :: Parser Option
pOption
= alts [
- then3 (\nm eq ff -> OptionFalse nm) pName (lit "=") (lit "False"),
- then3 (\nm eq tt -> OptionTrue nm) pName (lit "=") (lit "True"),
- then3 (\nm eq zz -> OptionString nm zz)
+ then3 (\nm _ _ -> OptionFalse nm) pName (lit "=") (lit "False"),
+ then3 (\nm _ _ -> OptionTrue nm) pName (lit "=") (lit "True"),
+ then3 (\nm _ zz -> OptionString nm zz)
pName (lit "=") pStuffBetweenBraces
]
(lit "pseudoop") stringLiteral pType pDesc pOptions
pOptions :: Parser [Option]
-pOptions = optdef [] (then2 sel22 (lit "with") (many pOption))
+pOptions = pOptDef [] (then2 sel22 (lit "with") (many pOption))
pCategory :: Parser Category
pCategory
]
pDesc :: Parser String
-pDesc = optdef "" pStuffBetweenBraces
+pDesc = pOptDef "" pStuffBetweenBraces
pStuffBetweenBraces :: Parser String
pStuffBetweenBraces
Just tt -> TyF t tt
Nothing -> t)
paT
- (opt (then2 sel22 (lit "->") pType))
+ (pOpt (then2 sel22 (lit "->") pType))
-- Atomic types
paT :: Parser Ty
idChars = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "#_"
sat :: (a -> Bool) -> Parser a -> Parser a
-sat pred p
+sat predicate p
= do x <- try p
- if pred x
+ if predicate x
then return x
else pzero
------------------------------------------------------------------
alts :: [Parser a] -> Parser a
+alts [] = pzero
alts [p1] = try p1
alts (p1:p2:ps) = (try p1) <|> alts (p2:ps)
= do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6 ; x7 <- p7
return (f x1 x2 x3 x4 x5 x6 x7)
-opt :: Parser a -> Parser (Maybe a)
-opt p
+pOpt :: Parser a -> Parser (Maybe a)
+pOpt p
= (do x <- p; return (Just x)) <|> return Nothing
-optdef :: a -> Parser a -> Parser a
-optdef d p
+pOptDef :: a -> Parser a -> Parser a
+pOptDef d p
= (do x <- p; return x) <|> return d
sel12 :: a -> b -> a
-sel12 a b = a
+sel12 a _ = a
sel22 :: a -> b -> b
-sel22 a b = b
+sel22 _ b = b
sel23 :: a -> b -> c -> b
-sel23 a b c = b
+sel23 _ b _ = b
apply :: (a -> b) -> Parser a -> Parser b
apply f p = liftM f p
projects / ghc-hetmet.git / blobdiff