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) (
+ -> seq (sanityTop p_o_specs) (
case head args of
"--data-decl"
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 = pOptDef [] (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 = pOptDef "" 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
- (pOpt (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 predicate p
- = do x <- try p
- if predicate x
- then return x
- else pzero
-
-------------------------------------------------------------------
--- Helpful additions to Daan's parser stuff ----------------------
-------------------------------------------------------------------
-
-alts :: [Parser a] -> Parser a
-alts [] = pzero
-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)
-
-pOpt :: Parser a -> Parser (Maybe a)
-pOpt p
- = (do x <- p; return (Just x)) <|> return Nothing
-
-pOptDef :: a -> Parser a -> Parser a
-pOptDef 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