-- -- Copyright (C) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons -- Gabriele Keller (keller@cse.unsw.edu.au) -- Stefan Wehr - http://www.stefanwehr.de -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as -- published by the Free Software Foundation; either version 2 of -- the License, or (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -- -- -- This parser specifies the majority of the concrete syntax of -- MiniHaskell -- -- The parser also does some desugaring, converting infix to prefix -- form, for one. -- -- Extensions: -- Parses the syntax described in 'Associated Type Synonym' Paper -- -- TODO: new version of paper handles superclasses, this is not -- yet implemented { {-# OPTIONS -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-incomplete-patterns #-} -- ^ grr. happy needs them all on one line module Phrac.Parser ( parse ) where import Phrac.ParserHelper import Phrac.ParseSyntax import Phrac.Lexer import Phrac.Error ( phasefail_ ) import Phrac.Builtins } -- Conflicts -- %expect 0 -- we'll just let any specials/reservedXs die as happyErrors, at the moment %name parse %tokentype { Token } %token '(' { T _ (SpecialT '(') } ')' { T _ (SpecialT ')') } '{' { T _ (SpecialT '{') } '}' { T _ (SpecialT '}') } '`' { T _ (SpecialT '`') } ';' { T _ (SpecialT ';') } ',' { T _ (SpecialT ',') } 'if' { T _ (ReservedIdT "if") } 'then' { T _ (ReservedIdT "then") } 'else' { T _ (ReservedIdT "else") } 'case' { T _ (ReservedIdT "case") } 'class' { T _ (ReservedIdT "class") } 'data' { T _ (ReservedIdT "data") } 'of' { T _ (ReservedIdT "of") } 'let' { T _ (ReservedIdT "let") } 'type' { T _ (ReservedIdT "type") } 'abstype' { T _ (ReservedIdT "abstype") } 'in' { T _ (ReservedIdT "in") } -- 'forall' { T _ (ReservedIdT "forall") } 'instance' { T _ (ReservedIdT "instance") } 'where' { T _ (ReservedIdT "where") } '_' { T _ (ReservedOpT "_") } '@' { T _ (ReservedOpT "@") } '::' { T _ (ReservedOpT "::") } '=' { T _ (ReservedOpT "=") } ':=' { T _ (ReservedOpT ":=") } '|' { T _ (ReservedOpT "|") } '\\' { T _ (ReservedOpT "\\") } -- unused atm '->' { T _ (ReservedOpT "->") } '=>' { T _ (ReservedOpT "=>") } '-' { T _ (ReservedOpT "-") } '*' { T _ (VarSymT "*") } -- product types ! '+' { T _ (VarSymT "+") } -- sum types ! -- '.' { T _ (VarSymT ".") } INT { T _ (IntegerT $$) } -- FLOAT { T _ (FloatT $$) } CHAR { T _ (CharT $$) } STRING { T _ (StringT $$) } VARID { T _ (VarIdT $$) } -- variables CONID { T _ (ConIdT $$) } -- constructors | tycon VARSYM { T _ (VarSymT $$) } CONSYM { T _ (ConSymT $$) } %% p :: { Program } : prgElems { mkProgram (reverse $1) } prgElems :: { [PrgElem] } : prgElems typeDef {PrgTypeDef $2 : $1} | prgElems classDec {PrgClassDec $2 : $1} | prgElems classInst {PrgClassInst $2 : $1} | prgElems valBind ';' {PrgBind $2 : $1} | {-epsilon-} { [] } typeDef :: {TypeDef} : 'data' tycon etyvars '=' talt talts ';' { TypeDef $2 (reverse $3) ($5 : reverse $6) emptyInfo { info_toplevel = True } } talts:: { [DataConstructor] } : talts '|' talt {$3 : $1} | {-epsilon-} {[]} talt :: { DataConstructor } : tycon atypes { DataConstructor $1 $2 } classDec:: { ClassDec } : 'class' head 'where' '{' tsigs vsigs '}' { mkClassDec $2 (reverse $5) (reverse $6) } tsigs:: { [AssocTypeSig] } : tsigs tsig ';'{ $2 : $1} |{- epsilon -} {[]} tsig:: { AssocTypeSig } : 'type' tycon tyvars { (AssocTypeSig $2 (reverse $3) Nothing) } | 'type' tycon tyvars ':=' type { (AssocTypeSig $2 (reverse $3) (Just $5)) } vsigs:: { [VSig] } : vsigs vsig ';' { $2 : $1} | {- epsilon -} {[]} vsig:: { VSig } : var '::' qualifiedType { ($1, TypeScheme [{- fill later -}] $3) } classInst:: { ClassInst } : 'instance' head 'where' '{' assocTypeBinds methodBinds '}' { mkClassInst $2 (reverse $5) (reverse $6)} assocTypeBinds :: { [AssocTypeBind] } : assocTypeBinds assocTypeBind ';' { $2 : $1 } | {-epsilon-} { [] } assocTypeBind :: { AssocTypeBind } : 'type' tycon atypes '=' type { (AssocTypeBind $2 $3 [] $5 AssocTypeNotAbstract) } | 'abstype' tycon atypes '=' type { (AssocTypeBind $2 $3 [] $5 AssocTypeAbstract) } head :: { ([Constraint], Type) } : context '=>' type { ($1, $3) } | type { ([], $1) } context :: { [Constraint] } : constraints { reverse $1 } constraints :: { [Constraint] } : constraints ',' constraint { $3 : $1 } | constraint { [$1] } constraint :: { Constraint } : type '=' type { EC (mkEqConstraint $1 $3) } | type { CC (mkClassConstraint $1) } -- non-empty list of tyvars tyvars:: { [TypeVarId] } : tyvar { [$1] } | tyvars tyvar { $2 : $1 } -- poss. empty list of tyvars etyvars:: { [TypeVarId] } : {-epsilon-} { [] } | etyvars tyvar { $2 : $1 } methodBinds :: { [ValBind] } : methodBinds methodBind ';' { $2 : $1 } | {-epsilon-} { [] } methodBind :: { ValBind } : var epats '=' exp { ValBind $1 Nothing (reverse $2) $4 (emptyInfo { info_toplevel = True }) } valBinds :: { [ValBind] } : valBinds valBind ';' { $2 : $1 } | {-epsilon-} { [] } -- types are optional valBind :: { ValBind } : var '::' qualifiedType ';' var epats '=' exp { if $1 == $5 then ValBind $1 (Just (TypeScheme [{-fill later-}] $3)) (reverse $6) $8 emptyInfo else phasefail "parse error: different variables in explicitly typed binding" } | var epats '=' exp { ValBind $1 Nothing (reverse $2) $4 emptyInfo } -- expressions (based on Haskell) exp :: { Exp } : exp0a { $1 } | exp0b { $1 } -- n.b. have to then flatten to primops exp0a :: { Exp } : exp0b op exp10a { App (App (Var $2) $1) $3 } -- un-infix | exp10a { $1 } exp0b :: { Exp } : exp0b op exp10b { App (App (Var $2) $1) $3 } -- un-infix | exp10b { $1 } exp10a :: { Exp } : '\\' pats '->' exp { Lam (reverse $2) $4 } | 'let' valBinds 'in' exp { Letrec (reverse $2) $4 } | 'if' exp 'then' exp 'else' exp { If $2 $4 $6 } exp10b :: { Exp } : 'case' exp 'of' alts { Case $2 $4 } | '-' fexp { Prim IntNegOp [$2] } -- NB | fexp { $1 } fexp :: { Exp } : fexp aexp { App $1 $2 } | aexp { $1 } aexp :: { Exp } : var { Var $1 } | num { Const (Number $1) } | char { Const (Character $1) } | string { mkStringList $1 } | '(' exp ')' { $2 } | '(' ')' { Con (fst unitDataConstructor) [] } | '(' exp ',' exp ')' { Con (fst pairDataConstructor) [$2,$4] } | con { Con $1 [ {-filled later-} ] } {- explist :: { [Exp] } : {-epsilon-} { [] } | explist ',' exp { $3 : $1 } -} -- ----------------------------------------------------------- alts :: { [ Alt ] } alts : alts alt { $2 : $1 } -- would prefer: alts ';' alt | alt { [$1] } alt :: { Alt } : pat_ '->' exp ';' { Alt $1 $3 } epats :: { [Pat] } epats : pats { $1 } | {-epsilon-} { [] } pats :: { [Pat] } pats : pats pat { $2 : $1 } | pat { [$1] } pat :: { Pat } : var { PVar $1 } | '_' { PWildcard } | '(' con pats ')' { PCon $2 (reverse $3) } | con { PCon $1 [] } | '(' pat ')' { $2 } | var '@' pat { PAs $1 $3 } | '(' pat ',' pat ')' { PCon (fst pairDataConstructor) [$2, $4] } pat_ :: { Pat } : var { PVar $1 } | '_' { PWildcard } | con epats { PCon $1 (reverse $2) } | '(' pat ')' { $2 } | var '@' pat { PAs $1 $3 } | '(' pat ',' pat ')' { PCon (fst pairDataConstructor) [$2, $4] } -- ----------------------------------------------------------- -- types type:: {Type} : btype '->' type { TyApp (TyApp (TyConstruct funTypeConstructor) $1) $3 } | '(' type ',' type ')' { TyApp (TyApp (TyConstruct pairTypeConstructor) $2) $4 } | btype { $1 } btype :: {Type} : btype atype {TyApp $1 $2 } | atype { $1 } atype :: {Type} : tycon { TyConstruct $1 } | tyvar { TyVar $1 } | '(' type ')' { $2 } qualifiedType :: { QualifiedType } : context '=>' type { QualifiedType $1 $3 } | type { QualifiedType [] $1 } atypes :: {[Type]} : atypes atype {$1 ++ [$2]} | {- epsilon -} {[]} -- ----------------------------------------------------------- -- Variables, Constructors and Operators. var :: { Id } : varid { $1 } | '(' varsym ')' { $2 } con :: { Id } : conid { $1 } | '(' consym ')' { $2 } varop :: { Id } : varsym { $1 } | '-' { "-" } -- dyadic "subtract" | '+' { "+" } -- not the type constructor | '*' { "*" } -- not the type constructor | '`' varid '`' { $2 } conop :: { Id } : consym { $1 } | '`' conid '`' { $2 } op :: { Id } : varop { $1 } | conop { $1 } tycon :: { Id } : conid { $1 } tyvar :: { Id } : varid { $1 } num :: { Integer } : INT { $1 } char :: { Char } : CHAR { $1 } string :: { String } : STRING { $1 } -- ----------------------------------------------------------- -- Identifiers and Symbols varid :: { Id } : VARID { $1 } conid :: { Id } : CONID { $1 } consym :: { Id } : CONSYM { $1 } varsym :: { Id } : VARSYM { $1 } ------------------------------------------------------------------------ { happyError :: [Token] -> a happyError x = let next3 = concatMap showPosToken (take 3 x) in phasefail ("Parser error, next tokens: " ++ next3) where showPosToken (T p tk) = "\n " ++ showPos p ++ ", " ++ show tk }