SUBDIRS += lndir
endif
-
# Utils that we don't build by default:
# nofib-analyse
# 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
+
--- /dev/null
+
+{
+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
+}
+
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 --
-------------------------------------------------------------------
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
+
--- /dev/null
+
+{
+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 }
+ | paT { $1 }
+
+-- Atomic types
+paT :: { Ty }
+paT : pTycon ppTs { TyApp $1 $2 }
+ | pUnboxedTupleTy { $1 }
+ | '(' pType ')' { $2 }
+ | lowerName { TyVar $1 }
+
+pUnboxedTupleTy :: { Ty }
+pUnboxedTupleTy : '(#' pCommaTypes '#)' { TyUTup $2 }
+
+pCommaTypes :: { [Ty] }
+pCommaTypes : pType ',' pCommaTypes { $1 : $3 }
+ | pType { [$1] }
+
+ppTs :: { [Ty] }
+ppTs : ppT ppTs { $1 : $2 }
+ | {- empty -} { [] }
+
+-- Primitive types
+ppT :: { Ty }
+ppT : lowerName { TyVar $1 }
+ | pTycon { TyApp $1 [] }
+
+pTycon :: { String }
+pTycon : upperName { $1 }
+ | '(' ')' { "()" }
+
+{
+parse :: String -> Either String Info
+parse = run_parser parsex
+}
+
--- /dev/null
+
+module ParserM (
+ -- Parser Monad
+ ParserM(..), AlexInput, run_parser,
+ -- Parser state
+ St,
+ StartCode, start_code, set_start_code,
+ inc_brace_depth, dec_brace_depth,
+ -- Tokens
+ Token(..),
+ -- Actions
+ Action, andBegin, mkT, mkTv,
+ -- Positions
+ get_pos, show_pos,
+ -- Input
+ alexGetChar, alexInputPrevChar, input, position,
+ -- Other
+ happyError
+ ) where
+
+import Syntax
+
+-- Parser Monad
+newtype ParserM a = ParserM (AlexInput -> St -> Either String (AlexInput, St, a))
+
+instance Monad ParserM where
+ ParserM m >>= k = ParserM $ \i s -> case m i s of
+ Right (i', s', x) ->
+ case k x of
+ ParserM y -> y i' s'
+ Left err ->
+ Left err
+ return a = ParserM $ \i s -> Right (i, s, a)
+ fail err = ParserM $ \_ _ -> Left err
+
+run_parser :: ParserM a -> (String -> Either String a)
+run_parser (ParserM f)
+ = \s -> case f (AlexInput init_pos s) init_state of
+ Left es -> Left es
+ Right (_, _, x) -> Right x
+
+-- Parser state
+
+data St = St {
+ start_code :: !StartCode,
+ brace_depth :: !Int
+ }
+ deriving Show
+type StartCode = Int
+
+init_state :: St
+init_state = St {
+ start_code = 0,
+ brace_depth = 0
+ }
+
+-- Tokens
+
+data Token = TEOF
+ | TArrow
+ | TEquals
+ | TComma
+ | TOpenParen
+ | TCloseParen
+ | TOpenParenHash
+ | THashCloseParen
+ | TOpenBrace
+ | TCloseBrace
+ | TSection
+ | TPrimop
+ | TPseudoop
+ | TPrimtype
+ | TWith
+ | TDefaults
+ | TTrue
+ | TFalse
+ | TDyadic
+ | TMonadic
+ | TCompare
+ | TGenPrimOp
+ | TThatsAllFolks
+ | TLowerName String
+ | TUpperName String
+ | TString String
+ | TNoBraces String
+ deriving Show
+
+-- Actions
+
+type Action = String -> ParserM Token
+
+set_start_code :: StartCode -> ParserM ()
+set_start_code sc = ParserM $ \i st -> Right (i, st { start_code = sc }, ())
+
+inc_brace_depth :: ParserM ()
+inc_brace_depth = ParserM $ \i st ->
+ Right (i, st { brace_depth = brace_depth st + 1 }, ())
+
+dec_brace_depth :: ParserM ()
+dec_brace_depth = ParserM $ \i st ->
+ let bd = brace_depth st - 1
+ sc = if bd == 0 then 0 else 1
+ in Right (i, st { brace_depth = bd, start_code = sc }, ())
+
+andBegin :: Action -> StartCode -> Action
+(act `andBegin` sc) x = do set_start_code sc
+ act x
+
+mkT :: Token -> Action
+mkT t = mkTv (const t)
+
+mkTv :: (String -> Token) -> Action
+mkTv f str = ParserM (\i st -> Right (i, st, f str))
+
+-- Positions
+
+data Pos = Pos !Int{- Line -} !Int{- Column -}
+
+get_pos :: ParserM Pos
+get_pos = ParserM $ \i@(AlexInput p _) st -> Right (i, st, p)
+
+alexMove :: Pos -> Char -> Pos
+alexMove (Pos l _) '\n' = Pos (l+1) 1
+alexMove (Pos l c) '\t' = Pos l ((c+8) `div` 8 * 8)
+alexMove (Pos l c) _ = Pos l (c+1)
+
+init_pos :: Pos
+init_pos = Pos 1 1
+
+show_pos :: Pos -> String
+show_pos (Pos l c) = "line " ++ show l ++ ", column " ++ show c
+
+-- Input
+
+data AlexInput = AlexInput {position :: !Pos, input :: String}
+
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar (AlexInput p (x:xs)) = Just (x, AlexInput (alexMove p x) xs)
+alexGetChar (AlexInput _ []) = Nothing
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar _ = error "Lexer doesn't implement alexInputPrevChar"
+
+happyError :: ParserM a
+happyError = do p <- get_pos
+ fail $ "Parse error at " ++ show_pos p
+
--- /dev/null
+
+module Syntax where
+
+import Data.List
+
+------------------------------------------------------------------
+-- 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 ().
+-}
+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
+
projects / ghc-hetmet.git / commitdiff