Remove the old syntax stuff.
This commit is contained in:
@@ -1,109 +0,0 @@
|
||||
module Syntax.AST where
|
||||
|
||||
import Syntax.ParserCore
|
||||
|
||||
data Show a => Module a = Module {
|
||||
modName :: QualifiedName
|
||||
, modImports :: [Import]
|
||||
, modDecls :: [Decl a]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data QualifiedName = QualifiedName {
|
||||
qnPrefixes :: [String]
|
||||
, qnName :: String
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
gensym :: Parser QualifiedName
|
||||
gensym = do
|
||||
name <- genstr
|
||||
return (QualifiedName [] name)
|
||||
|
||||
data Import = Import {
|
||||
imName :: QualifiedName
|
||||
, imQualified :: Bool
|
||||
, imList :: Maybe [ImportName]
|
||||
, imAs :: Maybe QualifiedName
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data ImportName = ImportNamed QualifiedName
|
||||
| ImportRenamed QualifiedName QualifiedName
|
||||
deriving (Show)
|
||||
|
||||
data Show a => Decl a =
|
||||
DeclData a [Type] QualifiedName [QualifiedName] [DataClause a]
|
||||
| DeclType a [Type]
|
||||
| DeclNewtype a [Type]
|
||||
| DeclClass a [Type] QualifiedName [QualifiedName] [ClassClause a]
|
||||
| DeclInstance a [Type]
|
||||
| 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 _ a b c) = DeclClass s rs a b c
|
||||
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]
|
||||
deriving (Show)
|
||||
|
||||
data ClassClause a = ClassClause a QualifiedName Type (Maybe (Expr a))
|
||||
deriving (Show)
|
||||
|
||||
data Show a => Expr a =
|
||||
Const a ConstVal
|
||||
| VarRef a QualifiedName
|
||||
| Cond a (Expr a) (Expr 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 (Let a _ _ _ _) = a
|
||||
|
||||
data Show a => Stmt a =
|
||||
SExpr a (Expr a)
|
||||
| SBind a QualifiedName (Stmt a)
|
||||
| SLet a Type QualifiedName (Expr a)
|
||||
| SCase a (Expr a) [(Pattern,Maybe (Expr a),Stmt a)]
|
||||
deriving (Show)
|
||||
|
||||
data Pattern =
|
||||
ListNull
|
||||
| PConst ConstVal
|
||||
| PVar QualifiedName
|
||||
| PNamed QualifiedName Pattern
|
||||
| PAp Pattern Pattern
|
||||
deriving (Show)
|
||||
|
||||
data Kind = Star | KFun Kind Kind
|
||||
deriving (Eq,Show)
|
||||
|
||||
data Type = TVar QualifiedName Kind
|
||||
| TCon QualifiedName Kind
|
||||
| TAp Type Type
|
||||
| TGen Int
|
||||
deriving (Show)
|
||||
|
||||
data ConstVal = ConstInteger Int String
|
||||
| ConstFloat String
|
||||
| ConstChar String
|
||||
| ConstString String
|
||||
| ConstEmpty
|
||||
deriving (Show)
|
||||
@@ -1,14 +0,0 @@
|
||||
CURDIR := $(TOPDIR)/hsrc/Syntax
|
||||
|
||||
SYNFILES := Lexer ParserCore AST Parser
|
||||
|
||||
SYNFILES_PREFIXED := $(addprefix $(CURDIR)/,$(SYNFILES))
|
||||
OBJECTS += $(addsuffix .o,$(SYNFILES_PREFIXED))
|
||||
HS_SOURCES += $(addsuffix .hs,$(SYNFILES_PREFIXED))
|
||||
|
||||
EXTRA_CLEAN += $(CURDIR)/Lexer.hs $(CURDIR)/Lexer.info \
|
||||
$(CURDIR)/Parser.hs $(CURDIR)/Parser.info
|
||||
|
||||
.SECONDARY: $(CURDIR)/Lexer.hs $(CURDIR)/Parser.hs
|
||||
|
||||
$(CURDIR)/Parser.d: $(CURDIR)/Lexer.d
|
||||
@@ -1,509 +0,0 @@
|
||||
{
|
||||
{-# 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)
|
||||
}
|
||||
|
||||
@@ -1,149 +0,0 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
module Syntax.ParserCore where
|
||||
|
||||
import Control.Applicative(Applicative)
|
||||
import qualified Data.ByteString as S
|
||||
import MonadLib
|
||||
import System.IO
|
||||
|
||||
-- --------------------------------------------------------------------------
|
||||
-- Positions
|
||||
--
|
||||
|
||||
data Position = Position {
|
||||
posOff :: !Int
|
||||
, posLine :: !Int
|
||||
, posCol :: !Int
|
||||
, posFile :: !FilePath
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
initPosition :: FilePath -> Position
|
||||
initPosition = Position 0 1 1
|
||||
|
||||
movePos :: Position -> Char -> Position
|
||||
movePos (Position o l c f) '\t' = Position (o+1) l (c+8) f
|
||||
movePos (Position o l _ f) '\n' = Position (o+1) (l+1) 0 f
|
||||
movePos (Position o l c f) _ = Position (o+1) l (c+1) f
|
||||
|
||||
pprtPosition :: Position -> String
|
||||
pprtPosition p = posFile p ++ ":" ++ show (posLine p) ++ ":" ++ show (posCol p)
|
||||
|
||||
-- --------------------------------------------------------------------------
|
||||
-- Tokens
|
||||
--
|
||||
|
||||
data Token = LParen | RParen
|
||||
| LSquare | RSquare
|
||||
| LBrace | RBrace
|
||||
| Bar | Semi | Comma | BTick | LLambda
|
||||
| TokTypeIdent String
|
||||
| TokValIdent String
|
||||
| TokOpIdent String
|
||||
| TokInt (Int,String)
|
||||
| TokFloat String
|
||||
| TokChar String
|
||||
| TokString String
|
||||
| TokEOF
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- --------------------------------------------------------------------------
|
||||
-- Lexemes
|
||||
--
|
||||
|
||||
data Lexeme = Lexeme {
|
||||
lexPos :: !Position
|
||||
, lexTok :: Token
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Eq Lexeme where
|
||||
a == b = lexTok a == lexTok b
|
||||
|
||||
-- --------------------------------------------------------------------------
|
||||
-- Errors
|
||||
--
|
||||
|
||||
data ErrorType =
|
||||
LexerError
|
||||
| ParserError
|
||||
deriving (Show)
|
||||
|
||||
data Error = Error ErrorType String Position
|
||||
deriving (Show)
|
||||
|
||||
printError :: Error -> IO ()
|
||||
printError (Error etype str pos) = hPutStrLn stderr errstr
|
||||
where
|
||||
errstr = pprtPosition pos ++ ":" ++ etypeStr ++ ": " ++ str
|
||||
etypeStr = case etype of
|
||||
LexerError -> "LEX"
|
||||
ParserError -> "PARSE"
|
||||
|
||||
-- --------------------------------------------------------------------------
|
||||
-- ParserState
|
||||
--
|
||||
|
||||
data ParserState = ParserState {
|
||||
psInput :: !S.ByteString
|
||||
, psChar :: !Char
|
||||
, psPos :: !Position
|
||||
, psLexCode :: !Int
|
||||
, psGenNum :: !Int
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
initParserState :: FilePath -> S.ByteString -> ParserState
|
||||
initParserState path bs = ParserState {
|
||||
psInput = bs
|
||||
, psChar = '\n'
|
||||
, psPos = initPosition path
|
||||
, psLexCode = 0
|
||||
, psGenNum = 0
|
||||
}
|
||||
|
||||
-- --------------------------------------------------------------------------
|
||||
-- Parser
|
||||
--
|
||||
|
||||
newtype Parser a = Parser {
|
||||
unParser :: StateT ParserState (ExceptionT Error Id) a
|
||||
} deriving (Functor, Applicative, Monad)
|
||||
|
||||
instance StateM Parser ParserState where
|
||||
get = Parser get
|
||||
set = Parser . set
|
||||
|
||||
instance ExceptionM Parser Error where
|
||||
raise = Parser . raise
|
||||
|
||||
instance RunExceptionM Parser Error where
|
||||
try m = Parser (try (unParser m))
|
||||
|
||||
-- |Raise a lexer error
|
||||
raiseL :: String -> Parser a
|
||||
raiseL msg = do
|
||||
st <- get
|
||||
raise (Error LexerError msg (psPos st))
|
||||
|
||||
-- |Raise a parser error
|
||||
raiseP :: String -> Parser a
|
||||
raiseP msg = do
|
||||
st <- get
|
||||
raise (Error ParserError msg (psPos st))
|
||||
|
||||
-- |Run the parser over the given file
|
||||
runParser :: FilePath -> S.ByteString -> Parser a -> Either Error a
|
||||
runParser path bs (Parser m) =
|
||||
case runM m (initParserState path bs) of
|
||||
Right (a,_) -> Right a
|
||||
Left err -> Left err
|
||||
|
||||
genstr :: Parser String
|
||||
genstr = do
|
||||
st <- get
|
||||
set st{ psGenNum = psGenNum st + 1 }
|
||||
return $ "--gen" ++ show (psGenNum st)
|
||||
|
||||
Reference in New Issue
Block a user