module Main where
-#if __GLASGOW_HASKELL__ >= 504
-import Text.ParserCombinators.Parsec
-#else
-import Parsec
-#endif
+import Parser
+import Syntax
import Monad
import Char
)
else
do s <- getContents
- let pres = parse pTop "" s
- case pres of
+ case parse s of
Left err -> error ("parse error at " ++ (show err))
- Right p_o_specs
- -> myseq (sanityTop p_o_specs) (
+ Right p_o_specs@(Info _ entries)
+ -> seq (sanityTop p_o_specs) (
case head args of
"--data-decl"
"strictness"
"primOpStrictness" p_o_specs)
- "--usage"
- -> putStr (gen_switch_from_attribs
- "usage"
- "primOpUsg" p_o_specs)
-
"--primop-primop-info"
-> putStr (gen_primop_info p_o_specs)
"--make-haskell-source"
-> putStr (gen_hs_source p_o_specs)
+ "--make-ext-core-source"
+ -> putStr (gen_ext_core_source entries)
+
"--make-latex-doc"
-> putStr (gen_latex_doc p_o_specs)
+
+ _ -> error "Should not happen, known_args out of sync?"
)
known_args :: [String]
"--needs-wrapper",
"--can-fail",
"--strictness",
- "--usage",
"--primop-primop-info",
"--primop-tag",
"--primop-list",
"--make-haskell-wrappers",
"--make-haskell-source",
+ "--make-ext-core-source",
"--make-latex-doc"
]
gen_hs_source (Info defaults entries) =
"-----------------------------------------------------------------------------\n"
++ "-- |\n"
- ++ "-- Module : GHC.Arr\n"
+ ++ "-- Module : GHC.Prim\n"
++ "-- \n"
++ "-- Maintainer : cvs-ghc@haskell.org\n"
++ "-- Stability : internal\n"
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 (Section {}) = ""
ent o@(PrimOpSpec {}) = 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
escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
where special = "/'`\"@<"
+-- Generates the type environment that the stand-alone External Core tools use.
+gen_ext_core_source :: [Entry] -> String
+gen_ext_core_source entries =
+ "-----------------------------------------------------------------------\n"
+ ++ "-- This module is automatically generated by the GHC utility\n"
+ ++ "-- \"genprimopcode\". Do not edit!\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
+ ++ " ]\n"
+ ++ "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
+ TyApp tc args -> parens tc (tcKind tc args)
+ _ -> error ("tcEnt: type in PrimTypeSpec is not a type"
+ ++ " constructor: " ++ show t)
+ tcEnt _ = ""
+ -- hack alert!
+ -- The primops.txt.pp format doesn't have enough information in it to
+ -- print out some of the information that ext-core needs (like kinds,
+ -- and later on in this code, module names) so we special-case. An
+ -- alternative would be to refer to things indirectly and hard-wire
+ -- certain things (e.g., the kind of the Any constructor, here) into
+ -- ext-core's Prims module again.
+ tcKind "Any" _ = "Klifted"
+ tcKind tc [] | last tc == '#' = "Kunlifted"
+ tcKind tc [] | otherwise = "Klifted"
+ -- assumes that all type arguments are lifted (are they?)
+ tcKind tc (v:as) = "(Karrow Klifted " ++ tcKind tc as
+ ++ ")"
+ valEnt (PseudoOpSpec {name=n, ty=t}) = valEntry n t
+ valEnt (PrimOpSpec {name=n, ty=t}) = valEntry n t
+ valEnt _ = ""
+ valEntry name ty = parens name (mkForallTy (freeTvars ty) (pty ty))
+ where pty (TyF 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 ++ "\""
+
+ mkFunTy s1 s2 = "Tapp " ++ (paren ("Tapp (Tcon tcArrow)"
+ ++ " " ++ paren s1))
+ ++ " " ++ paren s2
+ mkTconApp tc args = foldl tapp tc args
+ mkTcon tc = paren $ "Tcon " ++ paren (qualify True tc)
+ mkUtupleTy args = foldl tapp (tcUTuple (length args)) args
+ mkForallTy [] t = t
+ mkForallTy vs t = foldr
+ (\ v s -> "Tforall " ++
+ (paren (quot v ++ ", " ++ vKind v)) ++ " "
+ ++ paren s) t vs
+
+ -- hack alert!
+ vKind "o" = "Kopen"
+ vKind _ = "Klifted"
+
+ freeTvars (TyF t1 t2) = freeTvars t1 `union` freeTvars t2
+ freeTvars (TyApp _ tys) = freeTvarss tys
+ freeTvars (TyVar v) = [v]
+ freeTvars (TyUTup tys) = freeTvarss tys
+ freeTvarss = nub . concatMap freeTvars
+
+ tapp s nextArg = paren $ "Tapp " ++ s ++ " " ++ paren nextArg
+ tcUTuple n = paren $ "Tcon " ++ paren (qualify False $ "Z"
+ ++ show n ++ "H")
+
+ 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 == "ByteArr#" = qualify True "ByteArray#"
+ qualify _ tc | tc == "MutArr#" = qualify True "MutableArray#"
+ qualify _ tc | tc == "MutByteArr#" =
+ qualify True "MutableByteArray#"
+ qualify _ tc | tc == "Bool" = "Just boolMname" ++ ", "
+ ++ ze True tc
+ qualify _ tc | tc == "()" = "Just baseMname" ++ ", "
+ ++ ze True tc
+ 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 ++ "\""
+
gen_latex_doc :: Info -> String
gen_latex_doc (Info defaults entries)
= "\\primopdefaults{"
++ 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 (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) ++ "}{"
++ "}"
- 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
- Just (OptionString _ s) -> s -- for now
- 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
= 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 _ entries)
- = unlines (max_def : zipWith f primop_entries [1 :: Int ..])
+ = unlines (max_def_type : max_def :
+ tagOf_type : zipWith f primop_entries [1 :: Int ..])
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"
+ primop_entries = filter is_primop entries
+ tagOf_type = "tagOf_PrimOp :: PrimOp -> FastInt"
+ f i n = "tagOf_PrimOp " ++ cons i ++ " = _ILIT(" ++ show n ++ ")"
+ max_def_type = "maxPrimOpTag :: Int"
+ max_def = "maxPrimOpTag = " ++ show (length primop_entries)
gen_data_decl :: Info -> String
gen_data_decl (Info _ entries)
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
- ++ fn_name ++ " other = " ++ getAltRhs xx ++ "\n"
+ -> unlines alternatives
+ ++ fn_name ++ " _ = " ++ getAltRhs xx ++ "\n"
------------------------------------------------------------------
-- Create PrimOpInfo text from PrimOpSpecs -----------------------
-> case ty i of
TyF t1 (TyF _ _)
-> "mkCompare " ++ sl_name i ++ ppType t1
+ _ -> error "Type error in comparison op"
Monadic
-> case ty i of
TyF t1 _
-> "mkMonadic " ++ sl_name i ++ ppType t1
+ _ -> error "Type error in monadic op"
Dyadic
-> case ty i of
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 ++ "\") "
+sl_name i = "(fsLit \"" ++ name i ++ "\") "
ppTyVar :: String -> String
ppTyVar "a" = "alphaTyVar"
ppTyVar "c" = "gammaTyVar"
ppTyVar "s" = "deltaTyVar"
ppTyVar "o" = "openAlphaTyVar"
+ppTyVar _ = error "Unknown type var"
ppType :: Ty -> String
ppType (TyApp "Bool" []) = "boolTy"
arity :: Ty -> Int
arity = length . fst . flatTys
-------------------------------------------------------------------
--- Abstract syntax -----------------------------------------------
-------------------------------------------------------------------
-
--- info for all primops; the totality of the info in primops.txt(.pp)
-data Info
- = Info [Option] [Entry] -- defaults, primops
- deriving Show
-
--- info for one primop
-data Entry
- = PrimOpSpec { cons :: String, -- PrimOp name
- name :: String, -- name in prog text
- ty :: Ty, -- type
- cat :: Category, -- category
- desc :: String, -- description
- opts :: [Option] } -- default overrides
- | PseudoOpSpec { name :: String, -- name in prog text
- ty :: Ty, -- type
- desc :: String, -- description
- opts :: [Option] } -- default overrides
- | PrimTypeSpec { ty :: Ty, -- name in prog text
- desc :: String, -- description
- opts :: [Option] } -- default overrides
- | Section { title :: String, -- section title
- desc :: String } -- description
- deriving Show
-
-is_primop :: Entry -> Bool
-is_primop (PrimOpSpec _ _ _ _ _ _) = True
-is_primop _ = False
-
--- a binding of property to value
-data Option
- = OptionFalse String -- name = False
- | OptionTrue String -- name = True
- | OptionString String String -- name = { ... unparsed stuff ... }
- deriving Show
-
--- categorises primops
-data Category
- = Dyadic | Monadic | Compare | GenPrimOp
- deriving Show
-
--- types
-data Ty
- = TyF Ty Ty
- | TyApp TyCon [Ty]
- | TyVar TyVar
- | TyUTup [Ty] -- unboxed tuples; just a TyCon really,
- -- but convenient like this
- deriving (Eq,Show)
-
-type TyVar = String
-type TyCon = String
-
-
-------------------------------------------------------------------
--- Sanity checking -----------------------------------------------
-------------------------------------------------------------------
-
-{- Do some simple sanity checks:
- * all the default field names are unique
- * for each PrimOpSpec, all override field names are unique
- * for each PrimOpSpec, all overriden field names
- have a corresponding default value
- * that primop types correspond in certain ways to the
- Category: eg if Comparison, the type must be of the form
- T -> T -> Bool.
- Dies with "error" if there's a problem, else returns ().
--}
-myseq :: () -> a -> a
-myseq () x = x
-
-myseqAll :: [()] -> a -> a
-myseqAll (():ys) x = myseqAll ys x
-myseqAll [] x = x
-
-sanityTop :: Info -> ()
-sanityTop (Info defs entries)
- = let opt_names = map get_attrib_name defs
- primops = filter is_primop entries
- in
- if length opt_names /= length (nub opt_names)
- then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
- else myseqAll (map (sanityPrimOp opt_names) primops) ()
-
-sanityPrimOp :: [String] -> Entry -> ()
-sanityPrimOp def_names p
- = let p_names = map get_attrib_name (opts p)
- p_names_ok
- = length p_names == length (nub p_names)
- && all (`elem` def_names) p_names
- ty_ok = sane_ty (cat p) (ty p)
- in
- if not p_names_ok
- then error ("attribute names are non-unique or have no default in\n" ++
- "info for primop " ++ cons p ++ "\n")
- else
- if not ty_ok
- then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
- " category " ++ show (cat p) ++ "\n")
- else ()
-
-sane_ty :: Category -> Ty -> Bool
-sane_ty Compare (TyF t1 (TyF t2 td))
- | t1 == t2 && td == TyApp "Bool" [] = True
-sane_ty Monadic (TyF t1 td)
- | t1 == td = True
-sane_ty Dyadic (TyF t1 (TyF t2 _))
- | t1 == t2 && t2 == t2 = True
-sane_ty GenPrimOp _
- = True
-sane_ty _ _
- = False
-
-get_attrib_name :: Option -> String
-get_attrib_name (OptionFalse nm) = nm
-get_attrib_name (OptionTrue nm) = nm
-get_attrib_name (OptionString nm _) = nm
-
-lookup_attrib :: String -> [Option] -> Maybe Option
-lookup_attrib _ [] = Nothing
-lookup_attrib nm (a:as)
- = if get_attrib_name a == nm then Just a else lookup_attrib nm as
-
-------------------------------------------------------------------
--- The parser ----------------------------------------------------
-------------------------------------------------------------------
-
-keywords :: [String]
-keywords = [ "section", "primop", "pseudoop", "primtype", "with"]
-
--- Due to lack of proper lexing facilities, a hack to zap any
--- leading comments
-pTop :: Parser Info
-pTop = then4 (\_ ds es _ -> Info ds es)
- pCommentAndWhitespace pDefaults (many pEntry)
- (lit "thats_all_folks")
-
-pEntry :: Parser Entry
-pEntry
- = alts [pPrimOpSpec, pPrimTypeSpec, pPseudoOpSpec, pSection]
-
-pSection :: Parser Entry
-pSection = then3 (\_ n d -> Section {title = n, desc = d})
- (lit "section") stringLiteral pDesc
-
-pDefaults :: Parser [Option]
-pDefaults = then2 sel22 (lit "defaults") (many pOption)
-
-pOption :: Parser Option
-pOption
- = alts [
- 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
- ]
-
-pPrimOpSpec :: Parser Entry
-pPrimOpSpec
- = then7 (\_ c n k t d o -> PrimOpSpec { cons = c, name = n, ty = t,
- cat = k, desc = d, opts = o } )
- (lit "primop") pConstructor stringLiteral
- pCategory pType pDesc pOptions
-
-pPrimTypeSpec :: Parser Entry
-pPrimTypeSpec
- = then4 (\_ t d o -> PrimTypeSpec { ty = t, desc = d, opts = o } )
- (lit "primtype") pType pDesc pOptions
-
-pPseudoOpSpec :: Parser Entry
-pPseudoOpSpec
- = then5 (\_ n t d o -> PseudoOpSpec { name = n, ty = t, desc = d,
- opts = o } )
- (lit "pseudoop") stringLiteral pType pDesc pOptions
-
-pOptions :: Parser [Option]
-pOptions = optdef [] (then2 sel22 (lit "with") (many pOption))
-
-pCategory :: Parser Category
-pCategory
- = alts [
- apply (const Dyadic) (lit "Dyadic"),
- apply (const Monadic) (lit "Monadic"),
- apply (const Compare) (lit "Compare"),
- apply (const GenPrimOp) (lit "GenPrimOp")
- ]
-
-pDesc :: Parser String
-pDesc = optdef "" pStuffBetweenBraces
-
-pStuffBetweenBraces :: Parser String
-pStuffBetweenBraces
- = lexeme (
- do char '{'
- ass <- many pInsides
- char '}'
- return (concat ass) )
-
-pInsides :: Parser String
-pInsides
- = (do char '{'
- stuff <- many pInsides
- char '}'
- return ("{" ++ (concat stuff) ++ "}"))
- <|>
- (do c <- satisfy (/= '}')
- return [c])
-
--------------------
--- Parsing types --
--------------------
-
-pType :: Parser Ty
-pType = then2 (\t maybe_tt -> case maybe_tt of
- Just tt -> TyF t tt
- Nothing -> t)
- paT
- (opt (then2 sel22 (lit "->") pType))
-
--- Atomic types
-paT :: Parser Ty
-paT = alts [ then2 TyApp pTycon (many ppT),
- pUnboxedTupleTy,
- then3 sel23 (lit "(") pType (lit ")"),
- ppT
- ]
-
--- the magic bit in the middle is: T (,T)* so to speak
-pUnboxedTupleTy :: Parser Ty
-pUnboxedTupleTy
- = then3 (\ _ ts _ -> TyUTup ts)
- (lit "(#")
- (then2 (:) pType (many (then2 sel22 (lit ",") pType)))
- (lit "#)")
-
--- Primitive types
-ppT :: Parser Ty
-ppT = alts [apply TyVar pTyvar,
- apply (\tc -> TyApp tc []) pTycon
- ]
-
-pTyvar :: Parser String
-pTyvar = sat (`notElem` keywords) pName
-
-pTycon :: Parser String
-pTycon = alts [pConstructor, lexeme (string "()")]
-
-pName :: Parser String
-pName = lexeme (then2 (:) lower (many isIdChar))
-
-pConstructor :: Parser String
-pConstructor = lexeme (then2 (:) upper (many isIdChar))
-
-isIdChar :: Parser Char
-isIdChar = satisfy (`elem` idChars)
-
-idChars :: [Char]
-idChars = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "#_"
-
-sat :: (a -> Bool) -> Parser a -> Parser a
-sat pred p
- = do x <- try p
- if pred x
- then return x
- else pzero
-
-------------------------------------------------------------------
--- Helpful additions to Daan's parser stuff ----------------------
-------------------------------------------------------------------
-
-alts :: [Parser a] -> Parser a
-alts [p1] = try p1
-alts (p1:p2:ps) = (try p1) <|> alts (p2:ps)
-
-then2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
-then2 f p1 p2
- = do x1 <- p1 ; x2 <- p2 ; return (f x1 x2)
-
-then3 :: (a -> b -> c -> d) -> Parser a -> Parser b -> Parser c -> Parser d
-then3 f p1 p2 p3
- = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; return (f x1 x2 x3)
-
-then4 :: (a -> b -> c -> d -> e) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e
-then4 f p1 p2 p3 p4
- = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; return (f x1 x2 x3 x4)
-
-then5 :: (a -> b -> c -> d -> e -> f) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f
-then5 f p1 p2 p3 p4 p5
- = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5
- return (f x1 x2 x3 x4 x5)
-
-then6 :: (a -> b -> c -> d -> e -> f -> g) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f -> Parser g
-then6 f p1 p2 p3 p4 p5 p6
- = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6
- return (f x1 x2 x3 x4 x5 x6)
-
-then7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e -> Parser f -> Parser g -> Parser h
-then7 f p1 p2 p3 p4 p5 p6 p7
- = 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
- = (do x <- p; return (Just x)) <|> return Nothing
-
-optdef :: a -> Parser a -> Parser a
-optdef d p
- = (do x <- p; return x) <|> return d
-
-sel12 :: a -> b -> a
-sel12 a _ = a
-
-sel22 :: a -> b -> b
-sel22 _ b = b
-
-sel23 :: a -> b -> c -> b
-sel23 _ b _ = b
-
-apply :: (a -> b) -> Parser a -> Parser b
-apply f p = liftM f p
-
--- Hacks for zapping whitespace and comments, unfortunately needed
--- because Daan won't let us have a lexer before the parser :-(
-lexeme :: Parser p -> Parser p
-lexeme p = then2 sel12 p pCommentAndWhitespace
-
-lit :: String -> Parser ()
-lit s = apply (const ()) (lexeme (string s))
-
-pCommentAndWhitespace :: Parser ()
-pCommentAndWhitespace
- = apply (const ()) (many (alts [pLineComment,
- apply (const ()) (satisfy isSpace)]))
- <|>
- return ()
-
-pLineComment :: Parser ()
-pLineComment
- = try (then3 (\_ _ _ -> ()) (string "--") (many (satisfy (/= '\n'))) (char '\n'))
-
-stringLiteral :: Parser String
-stringLiteral = lexeme (
- do { between (char '"')
- (char '"' <?> "end of string")
- (many (noneOf "\""))
- }
- <?> "literal string")
-
-------------------------------------------------------------------
--- end --
-------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff