acw/bang
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Finish being able to parse the first example file.

Browse Source
This commit is contained in:
Adam Wick
2011-02-03 20:27:05 -05:00
parent 17ca2f7899
commit a64b8aa81c
4 changed files with 65 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
hsrc/Main.hs
View File

@@ -28,14 +28,15 @@ main = do
Right ress -> do
mapM_ putStrLn ress
putStrLn "Successful lex."
_ -> fail "Unacceptable arguments."
pullTokens :: Parser [String]
pullTokens = do
tok <- scan
case tok of
Lexeme pos tok -> do
let res = show pos ++ " " ++ show tok
if tok == TokEOF
Lexeme pos tok' -> do
let res = show pos ++ " " ++ show tok'
if tok' == TokEOF
then return [res]
else return (res :) `ap` pullTokens

33
hsrc/Syntax/AST.hs
View File

@@ -38,18 +38,18 @@ data Show a => Decl a =
| DeclNewtype a [Type]
| DeclClass a [Type]
| DeclInstance a [Type]
| DeclValue a [Type] Type (Expr a)
| DeclValue a [Type] Type QualifiedName (Expr a)
| DeclExport a (Decl a)
deriving (Show)
addTypeRestrictions :: Show a => [Type] -> Decl a -> Decl a
addTypeRestrictions rs (DeclData s _ a b c) = DeclData s rs a b c
addTypeRestrictions rs (DeclType s _) = DeclType s rs
addTypeRestrictions rs (DeclNewtype s _) = DeclNewtype s rs
addTypeRestrictions rs (DeclClass s _) = DeclClass s rs
addTypeRestrictions rs (DeclInstance s _) = DeclInstance s rs
addTypeRestrictions rs (DeclValue s _ a b) = DeclValue s rs a b
addTypeRestrictions rs (DeclExport s d) =
addTypeRestrictions rs (DeclData s _ a b c) = DeclData s rs a b c
addTypeRestrictions rs (DeclType s _) = DeclType s rs
addTypeRestrictions rs (DeclNewtype s _) = DeclNewtype s rs
addTypeRestrictions rs (DeclClass s _) = DeclClass s rs
addTypeRestrictions rs (DeclInstance s _) = DeclInstance s rs
addTypeRestrictions rs (DeclValue s _ n a b) = DeclValue s rs n a b
addTypeRestrictions rs (DeclExport s d) =
DeclExport s (addTypeRestrictions rs d)
data DataClause a = DataClause a QualifiedName [Maybe QualifiedName] [Type]
@@ -62,20 +62,23 @@ data Show a => Expr a =
| App a (Expr a) [Expr a]
| Block a [Stmt a]
| Lambda a [QualifiedName] (Expr a)
| Let a Type QualifiedName (Expr a) (Expr a)
deriving (Show)
getSpecial :: Show a => Expr a -> a
getSpecial (Const a _) = a
getSpecial (VarRef a _) = a
getSpecial (Cond a _ _ _) = a
getSpecial (App a _ _) = a
getSpecial (Block a _) = a
getSpecial (Lambda a _ _) = a
getSpecial (Const a _) = a
getSpecial (VarRef a _) = a
getSpecial (Cond a _ _ _) = a
getSpecial (App a _ _) = a
getSpecial (Block a _) = a
getSpecial (Lambda a _ _) = a
getSpecial (Let a _ _ _ _) = a
data Show a => Stmt a =
SExpr a (Expr a)
| SBind a QualifiedName (Stmt a)
| SCase a (Expr a) [(Pattern,Maybe (Expr a),Expr a)]
| SLet a Type QualifiedName (Expr a)
| SCase a (Expr a) [(Pattern,Maybe (Expr a),Stmt a)]
deriving (Show)
data Pattern =

3
hsrc/Syntax/Lexer.x
View File

@@ -21,7 +21,7 @@ $bindigit = [01]
$typestart = [A-Z\_]
$valstart = [a-z\_]
$identrest = [a-zA-Z0-9\_\.]
$opident = [\~\!\@\#\$\%\^\&\*\+\-\=\.\:\<\>\?\_]
$opident = [\~\!\@\#\$\%\^\&\*\+\-\=\.\<\>\?\_]
$escape_char = [abfnrtv'\"\\]
:-
@@ -42,6 +42,7 @@ $escape_char = [abfnrtv'\"\\]
$typestart $identrest* { emitS TokTypeIdent }
$valstart $identrest* { emitS TokValIdent }
$opident+ { emitS TokOpIdent }
":"+ { emitS TokOpIdent }
-- Characters and Strings
['].['] { emitS TokChar }

61
hsrc/Syntax/Parser.y
View File

@@ -27,6 +27,8 @@ import qualified Codec.Binary.UTF8.Generic as UTF8
'instance' { Lexeme $$ (TokValIdent "instance") }
'qualified' { Lexeme $$ (TokValIdent "qualified") }
'as' { Lexeme $$ (TokValIdent "as") }
'let' { Lexeme $$ (TokValIdent "let") }
'in' { Lexeme $$ (TokValIdent "in") }
'case' { Lexeme $$ (TokValIdent "case") }
'of' { Lexeme $$ (TokValIdent "of") }
'restrict' { Lexeme $$ (TokValIdent "restrict") }
@@ -206,7 +208,7 @@ instance_decl :: { Decl Position }
value_decl :: { Decl Position }
: value_ident optional_args optional_type value_body
{% postProcessDeclVal $1 $2 $3 $4 }
{% postProcessDeclVal DeclValue $1 $2 $3 $4 }
optional_args :: { Maybe [(QualifiedName, Maybe Type)] }
@@ -268,23 +270,25 @@ statements :: { [Stmt Position] }
statement :: { Stmt Position }
: assignment_statement ';' { $1 }
| case_statement ';' { $1 }
| case_statement { $1 }
| expression ';' { SExpr $2 $1 }
assignment_statement :: { Stmt Position }
: value_ident '=' expression -- FIXME: Too restrictive!
{ SBind $2 $1 (SExpr $2 $3) }
| 'let' value_ident optional_args optional_type value_body
{% postProcessDeclVal (\ s _ t n e -> SLet s t n e) $2 $3 $4 $5 }
case_statement :: { Stmt Position }
: 'case' expression 'of' case_items
: 'case' expression '{' case_items '}'
{ SCase $1 $2 $4 }
case_items :: { [(Pattern,Maybe (Expr Position),(Expr Position))] }
case_items :: { [(Pattern,Maybe (Expr Position),(Stmt Position))] }
: case_item { [$1] }
| case_items case_item { $1 ++ [$2] }
case_item :: { (Pattern, Maybe (Expr Position), (Expr Position)) }
: pattern mguard '->' expression { ($1, $2, $4) }
case_item :: { (Pattern, Maybe (Expr Position), (Stmt Position)) }
: pattern mguard '->' statement { ($1, $2, $4) }
mguard :: { Maybe (Expr Position) }
: { Nothing }
@@ -297,8 +301,8 @@ infix_operator :: { QualifiedName }
| '`' VAL_IDENT '`' { makeQualified $2 }
pattern_primary :: { Pattern }
: TYPE_IDENT { PVar (makeQualified $1) }
| VAL_IDENT { PVar (makeQualified $1) }
: TYPE_IDENT { PVar (makeQualified $1) }
| VAL_IDENT { PVar (makeQualified $1) }
| '[' ']' { PVar (QualifiedName ["Data","List"] "NULL") }
| INTVAL { let (Lexeme _ (TokInt (base, val))) = $1
in PConst (ConstInteger base val) }
@@ -338,11 +342,18 @@ primary_expression :: { Expr Position }
in Const src (ConstChar val) }
| STRVAL { let (Lexeme src (TokString val)) = $1
in Const src (ConstString val) }
| TYPE_IDENT { let l@(Lexeme src (TokTypeIdent name)) = $1
in VarRef src (makeQualified l) }
| VAL_IDENT { let l@(Lexeme src (TokValIdent name)) = $1
in VarRef src (makeQualified l) }
let_expression :: {Expr Position}
: 'let' value_ident optional_args optional_type value_body 'in' let_expression
{% postProcessDeclVal (\ s _ t n b -> Let s t n b $7) $2 $3 $4 $5 }
| primary_expression { $1 }
conditional_expression :: { Expr Position }
: primary_expression { $1 }
: let_expression { $1 }
infix_expression :: { Expr Position }
: infix_expression infix_operator conditional_expression
@@ -403,15 +414,17 @@ makeQualified' str = QualifiedName prefixes name
let (pre,rest) = span (/= '.') val
in if rest == ""
then ([], pre)
else let (pres, name) = loop rest
else let (pres, name) = loop (tail rest)
in (pre:pres, name)
postProcessDeclVal :: QualifiedName ->
Maybe [(QualifiedName, Maybe Type)] ->
Maybe Type ->
(Position, Expr Position) ->
Parser (Decl Position)
postProcessDeclVal name margs mrettype (src, body) = do
postProcessDeclVal ::
(Position -> [Type] -> Type -> QualifiedName -> Expr Position -> a) ->
QualifiedName ->
Maybe [(QualifiedName, Maybe Type)] ->
Maybe Type ->
(Position, Expr Position) ->
Parser a
postProcessDeclVal builder name margs mrettype (src, body) = do
final_type <- case mrettype of
Nothing -> do
name <- gensym
@@ -420,11 +433,19 @@ postProcessDeclVal name margs mrettype (src, body) = do
return x
case margs of
Nothing ->
return (DeclValue src [] final_type body)
return (builder src [] final_type name body)
Just [] ->
fail "Need to figure out empty arg items."
Just args ->
fail "Need to figure out non-empty arg items."
Just args -> do
let anames = map fst args
atypes <- forM (map snd args) $ \ x ->
case x of
Nothing -> do
name <- gensym
return (TVar name Star)
Just x ->
return x
let ftype = foldr TAp final_type atypes
return (builder src [] ftype name (Lambda src anames body))
}