From e1821977aba36201ebee194058fd7b297093d455 Mon Sep 17 00:00:00 2001 From: Adam Wick Date: Sun, 26 Jun 2016 21:21:11 -0700 Subject: [PATCH] Remove the old syntax stuff. --- src/Syntax/AST.hs | 109 --------- src/Syntax/Makefile | 14 -- src/Syntax/Parser.y | 509 --------------------------------------- src/Syntax/ParserCore.hs | 149 ------------ 4 files changed, 781 deletions(-) delete mode 100644 src/Syntax/AST.hs delete mode 100644 src/Syntax/Makefile delete mode 100644 src/Syntax/Parser.y delete mode 100644 src/Syntax/ParserCore.hs diff --git a/src/Syntax/AST.hs b/src/Syntax/AST.hs deleted file mode 100644 index 41be43b..0000000 --- a/src/Syntax/AST.hs +++ /dev/null @@ -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) diff --git a/src/Syntax/Makefile b/src/Syntax/Makefile deleted file mode 100644 index 88bca0d..0000000 --- a/src/Syntax/Makefile +++ /dev/null @@ -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 diff --git a/src/Syntax/Parser.y b/src/Syntax/Parser.y deleted file mode 100644 index 7a29210..0000000 --- a/src/Syntax/Parser.y +++ /dev/null @@ -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) -} - diff --git a/src/Syntax/ParserCore.hs b/src/Syntax/ParserCore.hs deleted file mode 100644 index 1d60323..0000000 --- a/src/Syntax/ParserCore.hs +++ /dev/null @@ -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) -