Rethinking the rethinking.
This commit is contained in:
509
src/Syntax/Parser.y
Normal file
509
src/Syntax/Parser.y
Normal file
@@ -0,0 +1,509 @@
|
||||
{
|
||||
{-# OPTIONS_GHC -w #-}
|
||||
|
||||
-- vim: filetype=haskell
|
||||
|
||||
module Syntax.Parser where
|
||||
|
||||
import Syntax.AST
|
||||
import Syntax.Lexer
|
||||
import Syntax.ParserCore
|
||||
|
||||
import MonadLib
|
||||
import qualified Codec.Binary.UTF8.Generic as UTF8
|
||||
|
||||
}
|
||||
|
||||
%token
|
||||
|
||||
-- reserved words
|
||||
'module' { Lexeme $$ (TokValIdent "module" ) }
|
||||
'export' { Lexeme $$ (TokValIdent "export" ) }
|
||||
'import' { Lexeme $$ (TokValIdent "import" ) }
|
||||
'datatype' { Lexeme $$ (TokValIdent "datatype") }
|
||||
'type' { Lexeme $$ (TokValIdent "type" ) }
|
||||
'newtype' { Lexeme $$ (TokValIdent "newtype" ) }
|
||||
'class' { Lexeme $$ (TokValIdent "class" ) }
|
||||
'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") }
|
||||
|
||||
-- symbols
|
||||
'=' { Lexeme $$ (TokOpIdent "=") }
|
||||
'|' { Lexeme $$ (TokOpIdent "|") }
|
||||
'->' { Lexeme $$ (TokOpIdent "->") }
|
||||
'@' { Lexeme $$ (TokOpIdent "@") }
|
||||
'::' { Lexeme $$ (TokOpIdent "::") }
|
||||
'\\' { Lexeme $$ LLambda }
|
||||
'(' { Lexeme $$ LParen }
|
||||
')' { Lexeme $$ RParen }
|
||||
'[' { Lexeme $$ LSquare }
|
||||
']' { Lexeme $$ RSquare }
|
||||
'{' { Lexeme $$ LBrace }
|
||||
'}' { Lexeme $$ RBrace }
|
||||
';' { Lexeme $$ Semi }
|
||||
',' { Lexeme $$ Comma }
|
||||
'`' { Lexeme $$ BTick }
|
||||
|
||||
-- identifiers
|
||||
TYPE_IDENT { Lexeme _ (TokTypeIdent _) }
|
||||
VAL_IDENT { Lexeme _ (TokValIdent _) }
|
||||
OP_IDENT { Lexeme _ (TokOpIdent _) }
|
||||
|
||||
-- values
|
||||
INTVAL { Lexeme _ (TokInt _) }
|
||||
FLOATVAL { Lexeme _ (TokFloat _) }
|
||||
CHARVAL { Lexeme _ (TokChar _) }
|
||||
STRVAL { Lexeme _ (TokString _) }
|
||||
|
||||
%monad { Parser } { (>>=) } { return }
|
||||
%name parseModule top_module
|
||||
%tokentype { Lexeme }
|
||||
|
||||
%lexer { lexer } { Lexeme initPosition TokEOF }
|
||||
|
||||
%%
|
||||
|
||||
top_module :: { Module Position } : 'module' TYPE_IDENT module_decls {
|
||||
let (imports,items) = $3
|
||||
in Module (makeQualified $2) imports items
|
||||
}
|
||||
|
||||
module_decls :: { ([Import], [Decl Position]) }
|
||||
: module_decls module_decl { $1 `pappend` $2 }
|
||||
| module_decl { $1 }
|
||||
|
||||
module_decl :: { ([Import], [Decl Position]) }
|
||||
: import_decl ';' { ([$1], []) }
|
||||
| decl ';' { ([], [$1]) }
|
||||
|
||||
-- Import Declarations ------------------------------------------------------
|
||||
|
||||
import_decl :: { Import }
|
||||
: 'import' mqualified TYPE_IDENT mimport_list mas
|
||||
{ Import (makeQualified $3) $2 $4 $5 }
|
||||
|
||||
mqualified :: { Bool }
|
||||
: { False }
|
||||
| 'qualified' { True }
|
||||
|
||||
mimport_list :: { Maybe [ImportName] }
|
||||
: { Nothing }
|
||||
| '(' ')' { Just [] }
|
||||
| '(' import_list ')' { Just $2 }
|
||||
|
||||
mas :: { Maybe QualifiedName }
|
||||
: { Nothing }
|
||||
| 'as' TYPE_IDENT { Just (makeQualified $2) }
|
||||
|
||||
import_list :: { [ImportName] }
|
||||
: import_name { [$1] }
|
||||
| import_list ',' import_name { $1 ++ [$3] }
|
||||
|
||||
import_name :: { ImportName }
|
||||
: either_ident { ImportNamed $1 }
|
||||
| either_ident 'as' either_ident { ImportRenamed $1 $3 }
|
||||
|
||||
either_ident :: { QualifiedName }
|
||||
: TYPE_IDENT { makeQualified $1 }
|
||||
| VAL_IDENT { makeQualified $1 }
|
||||
|
||||
-- Actual Declarations ------------------------------------------------------
|
||||
|
||||
-- A declaration starts with an optional export flag and an optional type
|
||||
-- restriction flag, and then has the declaration. We apply the restrictions /
|
||||
-- exports post-hoc because we're lazy.
|
||||
decl :: { Decl Position }
|
||||
: optional_decl_flags decl2 { $1 $2 }
|
||||
|
||||
optional_decl_flags :: { Decl Position -> Decl Position }
|
||||
: { id }
|
||||
| opt_export { $1 }
|
||||
| opt_restrict { $1 }
|
||||
| opt_export opt_restrict { $1 . $2 }
|
||||
| opt_restrict opt_export { $1 . $2 }
|
||||
|
||||
opt_export :: { Decl Position -> Decl Position }
|
||||
: 'export' { DeclExport $1 }
|
||||
|
||||
opt_restrict :: { Decl Position -> Decl Position }
|
||||
: 'restrict' '(' type_restrictions ')' { addTypeRestrictions $3 }
|
||||
|
||||
type_restrictions :: { [Type] }
|
||||
: type_restriction { [$1] }
|
||||
| type_restrictions ',' type_restriction { $1 ++ [$3] }
|
||||
|
||||
type_restriction :: { Type }
|
||||
: TYPE_IDENT VAL_IDENT
|
||||
{ TAp (TVar (makeQualified $1) Star) (TVar (makeQualified $2) Star) }
|
||||
| type_restriction VAL_IDENT
|
||||
{ TAp $1 (TVar (makeQualified $2) Star) }
|
||||
|
||||
decl2 :: { Decl Position }
|
||||
: data_decl { $1 }
|
||||
| type_decl { $1 }
|
||||
| newtype_decl { $1 }
|
||||
| class_decl { $1 }
|
||||
| instance_decl { $1 }
|
||||
| value_decl { $1 }
|
||||
|
||||
-- Data Declarations --------------------------------------------------------
|
||||
|
||||
data_decl :: { Decl Position }
|
||||
: 'datatype' TYPE_IDENT type_args '=' data_clauses
|
||||
{ DeclData $1 [] (makeQualified $2) $3 $5 }
|
||||
|
||||
type_args :: { [QualifiedName] }
|
||||
: { [] }
|
||||
| type_args VAL_IDENT { $1 ++ [makeQualified $2] }
|
||||
|
||||
data_clauses :: { [DataClause Position] }
|
||||
: data_clause { [] }
|
||||
| data_clauses '|' data_clause { $1 ++ [$3] }
|
||||
|
||||
data_clause :: { DataClause Position }
|
||||
: constructor_name '(' ')'
|
||||
{ DataClause $2 $1 [] [] }
|
||||
| constructor_name '(' constructor_args ')'
|
||||
{ DataClause $2 $1 (map fst $3) (map snd $3) }
|
||||
|
||||
constructor_name :: { QualifiedName }
|
||||
: TYPE_IDENT { makeQualified $1 }
|
||||
| '(' OP_IDENT ')' { makeQualified $2 }
|
||||
|
||||
constructor_args :: { [(Maybe QualifiedName,Type)] }
|
||||
: constructor_arg { [$1] }
|
||||
| constructor_args ',' constructor_arg { $1 ++ [$3] }
|
||||
|
||||
constructor_arg :: { (Maybe QualifiedName,Type) }
|
||||
: bang_type { (Nothing, $1) }
|
||||
| VAL_IDENT '::' bang_type { (Just (makeQualified $1), $3) }
|
||||
|
||||
-- Type Declarations --------------------------------------------------------
|
||||
|
||||
type_decl :: { Decl Position }
|
||||
: 'type' { undefined }
|
||||
|
||||
-- Newtype Declarations -----------------------------------------------------
|
||||
|
||||
newtype_decl :: { Decl Position }
|
||||
: 'newtype' { undefined }
|
||||
|
||||
-- Class Declarations -------------------------------------------------------
|
||||
|
||||
class_decl :: { Decl Position }
|
||||
: 'class' type_ident class_args '{' class_items '}'
|
||||
{ DeclClass $1 [] $2 $3 $5 }
|
||||
|
||||
class_args :: { [QualifiedName] }
|
||||
: VAL_IDENT { [makeQualified $1] }
|
||||
| class_args VAL_IDENT { $1 ++ [makeQualified $2] }
|
||||
|
||||
class_items :: { [ClassClause Position] }
|
||||
: class_item { [$1] }
|
||||
| class_items class_item { $1 ++ [$2] }
|
||||
|
||||
class_item :: { ClassClause Position }
|
||||
: value_ident maybe_clargs cl_retarg maybe_body ';'
|
||||
{% case ($2, $4) of
|
||||
(Nothing, Nothing) -> return (ClassClause $5 $1 $3 Nothing)
|
||||
(Just as, Nothing) ->
|
||||
let types = map snd as
|
||||
in return (ClassClause $5 $1 (buildFunType types $3) Nothing)
|
||||
(Nothing, Just bd) -> return (ClassClause $5 $1 $3 (Just bd))
|
||||
(Just as, Just bd) ->
|
||||
let types = map snd as
|
||||
names = sequence (map fst as)
|
||||
in case names of
|
||||
Nothing ->
|
||||
raiseP "Can't have class implementation without argument names."
|
||||
Just nms -> return (ClassClause $5 $1 (buildFunType types $3)
|
||||
(Just $ Lambda $5 nms bd))
|
||||
}
|
||||
|
||||
maybe_clargs :: { Maybe [(Maybe QualifiedName, Type)] }
|
||||
: { Nothing }
|
||||
| '(' clargs ')' { Just $2 }
|
||||
|
||||
clargs :: { [(Maybe QualifiedName, Type)] }
|
||||
: class_arg { [$1] }
|
||||
| clargs ',' class_arg { $1 ++ [$3] }
|
||||
|
||||
class_arg :: { (Maybe QualifiedName, Type) }
|
||||
: value_ident '::' bang_type { (Just $1, $3) }
|
||||
| bang_type { (Nothing, $1) }
|
||||
|
||||
cl_retarg :: { Type }
|
||||
: '::' bang_type { $2 }
|
||||
|
||||
maybe_body :: { Maybe (Expr Position) }
|
||||
: { Nothing }
|
||||
| '=' expression { Just $2 }
|
||||
| '{' statements '}' { Just (Block $1 $2) }
|
||||
|
||||
type_ident :: { QualifiedName }
|
||||
: TYPE_IDENT { makeQualified $1 }
|
||||
| '(' OP_IDENT ')' { makeQualified $2 }
|
||||
|
||||
-- Instance Declarations ----------------------------------------------------
|
||||
|
||||
instance_decl :: { Decl Position }
|
||||
: 'instance' { undefined }
|
||||
|
||||
-- Value Declaration --------------------------------------------------------
|
||||
|
||||
value_decl :: { Decl Position }
|
||||
: value_ident optional_args optional_type value_body
|
||||
{% postProcessDeclVal DeclValue $1 $2 $3 $4 }
|
||||
|
||||
|
||||
optional_args :: { Maybe [(QualifiedName, Maybe Type)] }
|
||||
: '(' optional_args2 ')' { Just $2 }
|
||||
| { Nothing }
|
||||
|
||||
optional_args2 :: { [(QualifiedName, Maybe Type)] }
|
||||
: optional_arg { [$1] }
|
||||
| optional_args2 ',' optional_arg { $1 ++ [$3] }
|
||||
|
||||
optional_arg :: { (QualifiedName, Maybe Type) }
|
||||
: value_ident optional_type { ($1, $2) }
|
||||
|
||||
optional_type :: { Maybe Type }
|
||||
: { Nothing }
|
||||
| '::' bang_type { Just $2 }
|
||||
|
||||
value_ident :: { QualifiedName }
|
||||
: VAL_IDENT { makeQualified $1 }
|
||||
| '(' OP_IDENT ')' { makeQualified $2 }
|
||||
| '(' '|' ')' { makeQualified (Lexeme $2 (TokOpIdent "|")) }
|
||||
|
||||
value_body :: { (Position, Expr Position) }
|
||||
: '=' expression { ($1, $2) }
|
||||
| '{' statements '}' { ($1, Block $1 $2) }
|
||||
|
||||
-- Types in Bang ------------------------------------------------------------
|
||||
|
||||
primary_type :: { Type }
|
||||
: TYPE_IDENT { TVar (makeQualified $1) Star }
|
||||
| VAL_IDENT { TVar (makeQualified $1) Star }
|
||||
| '(' bang_type ')' { $2 }
|
||||
|
||||
type_application_type :: { Type }
|
||||
: type_application_type primary_type
|
||||
{ TAp $1 $2 }
|
||||
| primary_type
|
||||
{ $1 }
|
||||
|
||||
function_type :: { Type }
|
||||
: function_type '->' type_application_type
|
||||
{ TAp (TVar (QualifiedName ["--INTERNAL--"] "->") Star) $3 }
|
||||
| type_application_type
|
||||
{ $1 }
|
||||
|
||||
list_type :: { Type }
|
||||
: '[' list_type ']'
|
||||
{ TAp (TVar (QualifiedName ["Data","List"] "List") Star) $2 }
|
||||
| function_type
|
||||
{ $1 }
|
||||
|
||||
bang_type :: { Type }
|
||||
: list_type { $1 }
|
||||
|
||||
-- Statements in bang
|
||||
|
||||
statements :: { [Stmt Position] }
|
||||
: { [] }
|
||||
| statements statement { $1 ++ [$2] }
|
||||
|
||||
statement :: { Stmt Position }
|
||||
: assignment_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 '{' case_items '}'
|
||||
{ SCase $1 $2 $4 }
|
||||
|
||||
case_items :: { [(Pattern,Maybe (Expr Position),(Stmt Position))] }
|
||||
: case_item { [$1] }
|
||||
| case_items case_item { $1 ++ [$2] }
|
||||
|
||||
case_item :: { (Pattern, Maybe (Expr Position), (Stmt Position)) }
|
||||
: pattern mguard '->' statement { ($1, $2, $4) }
|
||||
|
||||
mguard :: { Maybe (Expr Position) }
|
||||
: { Nothing }
|
||||
| '|' expression { Just $2 }
|
||||
|
||||
-- Patterns for pattern matching
|
||||
|
||||
infix_operator :: { QualifiedName }
|
||||
: OP_IDENT { makeQualified $1 }
|
||||
| '`' VAL_IDENT '`' { makeQualified $2 }
|
||||
|
||||
pattern_primary :: { Pattern }
|
||||
: 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) }
|
||||
| FLOATVAL { let (Lexeme _ (TokFloat val)) = $1
|
||||
in PConst (ConstFloat val) }
|
||||
| CHARVAL { let (Lexeme _ (TokChar val)) = $1
|
||||
in PConst (ConstChar val) }
|
||||
| STRVAL { let (Lexeme _ (TokString val)) = $1
|
||||
in PConst (ConstString val) }
|
||||
| '(' pattern ')' { $2 }
|
||||
|
||||
pattern_infix :: { Pattern }
|
||||
: pattern_infix infix_operator pattern_primary { PAp (PAp $1 (PVar $2)) $3 }
|
||||
| pattern_primary { $1 }
|
||||
|
||||
pattern_ap :: { Pattern }
|
||||
: pattern_ap pattern_infix { PAp $1 $2 }
|
||||
| pattern_infix { $1 }
|
||||
|
||||
pattern_name :: { Pattern }
|
||||
: value_ident '@' pattern_name { PNamed $1 $3 }
|
||||
| pattern_ap { $1 }
|
||||
|
||||
pattern :: { Pattern }
|
||||
: pattern_name { $1 }
|
||||
|
||||
-- Expressions in bang
|
||||
|
||||
primary_expression :: { Expr Position }
|
||||
: '(' expression ')' { $2 }
|
||||
| '[' ']' { VarRef $1 (QualifiedName ["Data","List"] "NULL") }
|
||||
| INTVAL { let (Lexeme src (TokInt (base, val))) = $1
|
||||
in Const src (ConstInteger base val) }
|
||||
| FLOATVAL { let (Lexeme src (TokFloat val)) = $1
|
||||
in Const src (ConstFloat val) }
|
||||
| CHARVAL { let (Lexeme src (TokChar val)) = $1
|
||||
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 }
|
||||
: let_expression { $1 }
|
||||
|
||||
infix_expression :: { Expr Position }
|
||||
: infix_expression infix_operator conditional_expression
|
||||
{ App (getSpecial $1) (VarRef (getSpecial $1) $2) [$1, $3] }
|
||||
| conditional_expression
|
||||
{ $1 }
|
||||
|
||||
lambda_expression :: { Expr Position }
|
||||
: '\\' arguments '->' infix_expression
|
||||
{ Lambda $1 $2 $4 }
|
||||
| infix_expression
|
||||
{ $1 }
|
||||
|
||||
arguments :: { [QualifiedName] }
|
||||
: value_ident { [$1] }
|
||||
| arguments ',' value_ident { $1 ++ [$3] }
|
||||
|
||||
application_expression :: { Expr Position }
|
||||
: application_expression '(' app_args ')'
|
||||
{ App $2 $1 $3 }
|
||||
| application_expression '(' ')'
|
||||
{ App $2 $1 [] }
|
||||
| lambda_expression
|
||||
{ $1 }
|
||||
|
||||
app_args :: { [Expr Position] }
|
||||
: expression { [$1] }
|
||||
| app_args ',' expression { $1 ++ [$3] }
|
||||
|
||||
block_expression :: { Expr Position }
|
||||
: '{' statements '}' { Block $1 $2 }
|
||||
| application_expression { $1 }
|
||||
|
||||
expression :: { Expr Position }
|
||||
: block_expression { $1 }
|
||||
|
||||
{
|
||||
lexer :: (Lexeme -> Parser a) -> Parser a
|
||||
lexer k = scan >>= k
|
||||
|
||||
happyError :: Parser a
|
||||
happyError = raiseP "Parse Error"
|
||||
|
||||
pappend :: ([a],[b]) -> ([a],[b]) -> ([a],[b])
|
||||
pappend (a,b) (c,d) = (a++c,b++d)
|
||||
|
||||
makeQualified :: Lexeme -> QualifiedName
|
||||
makeQualified (Lexeme _ (TokTypeIdent str)) = makeQualified' str
|
||||
makeQualified (Lexeme _ (TokValIdent str)) = makeQualified' str
|
||||
makeQualified (Lexeme _ (TokOpIdent str)) = makeQualified' str
|
||||
makeQualified _ = error "makeQualified bad arg"
|
||||
|
||||
makeQualified' :: String -> QualifiedName
|
||||
makeQualified' str = QualifiedName prefixes name
|
||||
where
|
||||
(prefixes,name) = loop str
|
||||
loop val =
|
||||
let (pre,rest) = span (/= '.') val
|
||||
in if rest == ""
|
||||
then ([], pre)
|
||||
else let (pres, name) = loop (tail rest)
|
||||
in (pre:pres, name)
|
||||
|
||||
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
|
||||
return (TVar name Star)
|
||||
Just x ->
|
||||
return x
|
||||
case margs of
|
||||
Nothing ->
|
||||
return (builder src [] final_type name body)
|
||||
Just [] ->
|
||||
fail "Need to figure out 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 = buildFunType atypes final_type
|
||||
return (builder src [] ftype name (Lambda src anames body))
|
||||
|
||||
buildFunType :: [Type] -> Type -> Type
|
||||
buildFunType [] finaltype = finaltype
|
||||
buildFunType (first:rest) finaltype =
|
||||
TAp (TAp arrow first) (buildFunType rest finaltype)
|
||||
where arrow = (TVar (makeQualified' "Data.Function") Star)
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user