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