import IfaceSyn
import ForeignCall
import RdrHsSyn
-import TcIface ( tcIfaceKind )
import HsSyn
import RdrName
import OccName
+import Kind( Kind(..) )
import Name( nameOccName, nameModuleName )
import Module
import ParserCoreUtils
import LexCore
import Literal
-import BasicTypes
import SrcLoc
import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon,
floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
import TyCon ( TyCon, tyConName )
import FastString
import Outputable
+import Char
#include "../HsVersions.h"
tdef :: { TyClDecl RdrName }
: '%data' q_tc_name tv_bndrs '=' '{' cons1 '}'
- { mkTyData DataType ([], ifaceExtRdrName $2, map toHsTvBndr $3) $6 Nothing noSrcLoc }
+ { mkTyData DataType (noLoc (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3)) Nothing $6 Nothing }
| '%newtype' q_tc_name tv_bndrs trep
{ let tc_rdr = ifaceExtRdrName $2 in
- mkTyData NewType ([], tc_rdr, map toHsTvBndr $3) ($4 (rdrNameOcc tc_rdr)) Nothing noSrcLoc }
+ mkTyData NewType (noLoc (noLoc [], noLoc tc_rdr, map toHsTvBndr $3)) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
-- For a newtype we have to invent a fake data constructor name
-- It doesn't matter what it is, because it won't be used
-trep :: { OccName -> [ConDecl RdrName] }
+trep :: { OccName -> [LConDecl RdrName] }
: {- empty -} { (\ tc_occ -> []) }
| '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ;
- con_info = PrefixCon [unbangedType (toHsType $2)] }
- in [ConDecl dc_name [] [] con_info noSrcLoc]) }
+ con_info = PrefixCon [toHsType $2] }
+ in [noLoc $ ConDecl (noLoc dc_name) []
+ (noLoc []) con_info]) }
-cons1 :: { [ConDecl RdrName] }
+cons1 :: { [LConDecl RdrName] }
: con { [$1] }
| con ';' cons1 { $1:$3 }
-con :: { ConDecl RdrName }
+con :: { LConDecl RdrName }
: d_pat_occ attv_bndrs hs_atys
- { ConDecl (mkRdrUnqual $1) $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
+ { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3)}
+ | d_pat_occ '::' ty
+ { noLoc $ GadtDecl (noLoc (mkRdrUnqual $1)) (toHsType $3) }
-attv_bndrs :: { [HsTyVarBndr RdrName] }
+attv_bndrs :: { [LHsTyVarBndr RdrName] }
: {- empty -} { [] }
| '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 }
-hs_atys :: { [HsType RdrName] }
+hs_atys :: { [LHsType RdrName] }
: atys { map toHsType $1 }
| id_bndr id_bndrs { $1:$2 }
tv_bndr :: { IfaceTvBndr }
- : tv_occ { ($1, IfaceLiftedTypeKind) }
+ : tv_occ { ($1, LiftedTypeKind) }
| '(' tv_occ '::' akind ')' { ($2, $4) }
tv_bndrs :: { [IfaceTvBndr] }
| tv_bndr tv_bndrs { $1:$2 }
akind :: { IfaceKind }
- : '*' { IfaceLiftedTypeKind }
- | '#' { IfaceUnliftedTypeKind }
- | '?' { IfaceOpenTypeKind }
+ : '*' { LiftedTypeKind }
+ | '#' { UnliftedTypeKind }
+ | '?' { OpenTypeKind }
| '(' kind ')' { $2 }
kind :: { IfaceKind }
: akind { $1 }
- | akind '->' kind { IfaceFunKind $1 $3 }
+ | akind '->' kind { FunKind $1 $3 }
-----------------------------------------
-- Expressions
: fexp { $1 }
| '\\' bndrs '->' exp { foldr IfaceLam $4 $2 }
| '%let' let_bind '%in' exp { IfaceLet $2 $4 }
- | '%case' aexp '%of' id_bndr
- '{' alts1 '}' { IfaceCase $2 (fst $4) $6 }
+-- gaw 2004
+ | '%case' '(' ty ')' aexp '%of' id_bndr
+ '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 }
| '%coerce' aty exp { IfaceNote (IfaceCoerce $2) $3 }
| '%note' STRING exp
{ case $2 of
lit :: { Literal }
: '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
| '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
- | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) }
+ | '(' CHAR '::' aty ')' { MachChar $2 }
| '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
tv_occ :: { OccName }
convIntLit i (IfaceTyConApp tc [])
| tc `eqTc` intPrimTyCon = MachInt i
| tc `eqTc` wordPrimTyCon = MachWord i
- | tc `eqTc` charPrimTyCon = MachChar (fromInteger i)
+ | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i))
| tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr
convIntLit i aty
= pprPanic "Unknown integer literal type" (ppr aty)
-- and convert to HsTypes here. But the IfaceTypes we can see here
-- are very limited (see the productions for 'ty', so the translation
-- isn't hard
-toHsType :: IfaceType -> HsType RdrName
-toHsType (IfaceTyVar v) = HsTyVar (mkRdrUnqual v)
-toHsType (IfaceAppTy t1 t2) = HsAppTy (toHsType t1) (toHsType t2)
-toHsType (IfaceFunTy t1 t2) = HsFunTy (toHsType t1) (toHsType t2)
-toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl HsAppTy (HsTyVar (ifaceExtRdrName tc)) (map toHsType ts)
+toHsType :: IfaceType -> LHsType RdrName
+toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual v)
+toHsType (IfaceAppTy t1 t2) = noLoc $ HsAppTy (toHsType t1) (toHsType t2)
+toHsType (IfaceFunTy t1 t2) = noLoc $ HsFunTy (toHsType t1) (toHsType t2)
+toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts)
toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t)
-toHsTvBndr :: IfaceTvBndr -> HsTyVarBndr RdrName
-toHsTvBndr (tv,k) = KindedTyVar (mkRdrUnqual tv) (tcIfaceKind k)
+toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
+toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual tv) k
ifaceExtRdrName :: IfaceExtName -> RdrName
ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ
ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
-add_forall tv (HsForAllTy exp tvs cxt t) = HsForAllTy exp (tv:tvs) cxt t
-add_forall tv t = HsForAllTy Explicit [tv] [] t
+add_forall tv (L _ (HsForAllTy exp tvs cxt t))
+ = noLoc $ HsForAllTy exp (tv:tvs) cxt t
+add_forall tv t
+ = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
happyError :: P a
happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l