Commit 03ffa2bf authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Replace genprimopcode's parsec parser with an alex+happy parser

This use was the only thing keeping parsec in core-packages, and
we already have a dependency on alex+happy anyway.
parent 6c53f40f
......@@ -22,7 +22,6 @@ ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
SUBDIRS += lndir
endif
# Utils that we don't build by default:
# nofib-analyse
......@@ -43,3 +42,10 @@ endif
# a Haskell compiler and if you want it.
include $(TOP)/mk/target.mk
# genprimopcode is needed to boot in ghc/compiler...
ifneq "$(BootingFromHc)" "YES"
boot ::
$(MAKE) -C genprimopcode
endif
{
module Lexer (lex_tok) where
import Control.Monad.State (StateT, get)
import ParserM (ParserM (..), mkT, mkTv, Token(..), St, start_code,
StartCode, Action, set_start_code,
inc_brace_depth, dec_brace_depth,
show_pos, position, input,
AlexInput, alexGetChar, alexInputPrevChar)
}
words :-
<0> $white+ ;
<0> "--" [^\n]* \n ;
"{" { \i -> do {
set_start_code in_braces;
inc_brace_depth;
mkT TOpenBrace i
}
}
"}" { \i -> do {
dec_brace_depth;
mkT TCloseBrace i
}
}
<0> "->" { mkT TArrow }
<0> "=" { mkT TEquals }
<0> "," { mkT TComma }
<0> "(" { mkT TOpenParen }
<0> ")" { mkT TCloseParen }
<0> "(#" { mkT TOpenParenHash }
<0> "#)" { mkT THashCloseParen }
<0> "section" { mkT TSection }
<0> "primop" { mkT TPrimop }
<0> "pseudoop" { mkT TPseudoop }
<0> "primtype" { mkT TPrimtype }
<0> "with" { mkT TWith }
<0> "defaults" { mkT TDefaults }
<0> "True" { mkT TTrue }
<0> "False" { mkT TFalse }
<0> "Dyadic" { mkT TDyadic }
<0> "Monadic" { mkT TMonadic }
<0> "Compare" { mkT TCompare }
<0> "GenPrimOp" { mkT TGenPrimOp }
<0> "thats_all_folks" { mkT TThatsAllFolks }
<0> [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName }
<0> [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName }
<0> \" [^\"]* \" { mkTv (TString . tail . init) }
<in_braces> [^\{\}]+ { mkTv TNoBraces }
<in_braces> \n { mkTv TNoBraces }
{
get_tok :: ParserM Token
get_tok = ParserM $ \i st ->
case alexScan i (start_code st) of
AlexEOF -> Right (i, st, TEOF)
AlexError _ -> Left ("Lexical error at " ++ show_pos (position i))
AlexSkip i' _ -> case get_tok of
ParserM f -> f i' st
AlexToken i' l a -> case a $ take l $ input i of
ParserM f -> f i' st
lex_tok :: (Token -> ParserM a) -> ParserM a
lex_tok cont = get_tok >>= cont
}
......@@ -5,11 +5,8 @@
module Main where
#if __GLASGOW_HASKELL__ >= 504
import Text.ParserCombinators.Parsec
#else
import Parsec
#endif
import Parser
import Syntax
import Monad
import Char
......@@ -26,11 +23,10 @@ main = getArgs >>= \args ->
)
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"
......@@ -550,358 +546,3 @@ tvsIn (TyUTup tys) = concatMap tvsIn tys
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 --
------------------------------------------------------------------
......@@ -3,19 +3,5 @@ include $(TOP)/mk/boilerplate.mk
HS_PROG = genprimopcode
SRC_HC_OPTS += -Wall
ifeq "$(ghc_ge_504)" "NO"
SRC_HC_OPTS += -package text
endif
ifeq "$(ghc_ge_602)" "YES"
SRC_HC_OPTS += -package parsec
endif
# genprimopcode is needed to boot in ghc/compiler...
ifneq "$(BootingFromHc)" "YES"
boot :: all
endif
include $(TOP)/mk/target.mk
{
module Parser (parse) where
import Lexer (lex_tok)
import ParserM (Token(..), ParserM, run_parser, get_pos, show_pos,
happyError)
import Syntax
}
%name parsex
%tokentype { Token }
%monad { ParserM }
%lexer { lex_tok } { TEOF }
%token
'->' { TArrow }
'=' { TEquals }
',' { TComma }
'(' { TOpenParen }
')' { TCloseParen }
'(#' { TOpenParenHash }
'#)' { THashCloseParen }
'{' { TOpenBrace }
'}' { TCloseBrace }
section { TSection }
primop { TPrimop }
pseudoop { TPseudoop }
primtype { TPrimtype }
with { TWith }
defaults { TDefaults }
true { TTrue }
false { TFalse }
dyadic { TDyadic }
monadic { TMonadic }
compare { TCompare }
genprimop { TGenPrimOp }
thats_all_folks { TThatsAllFolks }
lowerName { TLowerName $$ }
upperName { TUpperName $$ }
string { TString $$ }
noBraces { TNoBraces $$ }
%%
info :: { Info }
info : pDefaults pEntries thats_all_folks { Info $1 $2 }
pDefaults :: { [Option] }
pDefaults : defaults pOptions { $2 }
pOptions :: { [Option] }
pOptions : pOption pOptions { $1 : $2 }
| {- empty -} { [] }
pOption :: { Option }
pOption : lowerName '=' false { OptionFalse $1 }
| lowerName '=' true { OptionTrue $1 }
| lowerName '=' pStuffBetweenBraces { OptionString $1 $3 }
pEntries :: { [Entry] }
pEntries : pEntry pEntries { $1 : $2 }
| {- empty -} { [] }
pEntry :: { Entry }
pEntry : pPrimOpSpec { $1 }
| pPrimTypeSpec { $1 }
| pPseudoOpSpec { $1 }
| pSection { $1 }
pPrimOpSpec :: { Entry }
pPrimOpSpec : primop upperName string pCategory pType
pDesc pWithOptions
{ PrimOpSpec {
cons = $2,
name = $3,
cat = $4,
ty = $5,
desc = $6,
opts = $7
}
}
pPrimTypeSpec :: { Entry }
pPrimTypeSpec : primtype pType pDesc pWithOptions
{ PrimTypeSpec { ty = $2, desc = $3, opts = $4 } }
pPseudoOpSpec :: { Entry }
pPseudoOpSpec : pseudoop string pType pDesc pWithOptions
{ PseudoOpSpec { name = $2, ty = $3, desc = $4, opts = $5 } }
pSection :: { Entry }
pSection : section string pDesc { Section { title = $2, desc = $3 } }
pWithOptions :: { [Option] }
pWithOptions : with pOptions { $2 }
| {- empty -} { [] }
pCategory :: { Category }
pCategory : dyadic { Dyadic }
| monadic { Monadic }
| compare { Compare }
| genprimop { GenPrimOp }
pDesc :: { String }
pDesc : pStuffBetweenBraces { $1 }
| {- empty -} { "" }
pStuffBetweenBraces :: { String }
pStuffBetweenBraces : '{' pInsides '}' { $2 }
pInsides :: { String }
pInsides : pInside pInsides { $1 ++ $2 }
| {- empty -} { "" }
pInside :: { String }
pInside : '{' pInsides '}' { "{" ++ $2 ++ "}" }
| noBraces { $1 }
pType :: { Ty }
pType : paT '->' pType { TyF $1 $3 }