{ {-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 {-# OPTIONS -Wwarn -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module ParserCore ( parseCore ) where import IfaceSyn import ForeignCall import RdrHsSyn import HsSyn import RdrName import OccName import Type ( Kind, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, mkTyConApp ) import Coercion( mkArrowKind ) import Name( Name, nameOccName, nameModule, mkExternalName ) import Module import ParserCoreUtils import LexCore import Literal import SrcLoc import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, floatPrimTyCon, doublePrimTyCon, addrPrimTyCon ) import TyCon ( TyCon, tyConName ) import FastString import Outputable import Data.Char import Unique #include "../HsVersions.h" } %name parseCore %expect 0 %tokentype { Token } %token '%module' { TKmodule } '%data' { TKdata } '%newtype' { TKnewtype } '%forall' { TKforall } '%rec' { TKrec } '%let' { TKlet } '%in' { TKin } '%case' { TKcase } '%of' { TKof } '%cast' { TKcast } '%note' { TKnote } '%external' { TKexternal } '%local' { TKlocal } '%_' { TKwild } '(' { TKoparen } ')' { TKcparen } '{' { TKobrace } '}' { TKcbrace } '#' { TKhash} '=' { TKeq } ':' { TKcolon } '::' { TKcoloncolon } ':=:' { TKcoloneqcolon } '*' { TKstar } '->' { TKrarrow } '\\' { TKlambda} '@' { TKat } '.' { TKdot } '?' { TKquestion} ';' { TKsemicolon } NAME { TKname $$ } CNAME { TKcname $$ } INTEGER { TKinteger $$ } RATIONAL { TKrational $$ } STRING { TKstring $$ } CHAR { TKchar $$ } %monad { P } { thenP } { returnP } %lexer { lexer } { TKEOF } %% module :: { HsExtCore RdrName } -- : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 } : '%module' modid tdefs vdefgs { HsExtCore $2 [] [] } ------------------------------------------------------------- -- Names: the trickiest bit in here -- A name of the form A.B.C could be: -- module A.B.C -- dcon C in module A.B -- tcon C in module A.B modid :: { Module } : NAME ':' mparts { undefined } q_dc_name :: { Name } : NAME ':' mparts { undefined } q_tc_name :: { Name } : NAME ':' mparts { undefined } q_var_occ :: { Name } : NAME ':' vparts { undefined } mparts :: { [String] } : CNAME { [$1] } | CNAME '.' mparts { $1:$3 } vparts :: { [String] } : var_occ { [$1] } | CNAME '.' vparts { $1:$3 } ------------------------------------------------------------- -- Type and newtype declarations are in HsSyn syntax tdefs :: { [TyClDecl RdrName] } : {- empty -} {[]} | tdef tdefs {$1:$2} tdef :: { TyClDecl RdrName } : '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';' { TyData { tcdND = DataType, tcdCtxt = noLoc [] , tcdLName = noLoc (ifaceExtRdrName $2) , tcdTyVars = map toHsTvBndr $3 , tcdTyPats = Nothing, tcdKindSig = Nothing , tcdCons = $6, tcdDerivs = Nothing } } | '%newtype' q_tc_name tv_bndrs trep ';' { let tc_rdr = ifaceExtRdrName $2 in TyData { tcdND = NewType, tcdCtxt = noLoc [] , tcdLName = noLoc tc_rdr , tcdTyVars = map toHsTvBndr $3 , tcdTyPats = Nothing, tcdKindSig = Nothing , tcdCons = $4 (rdrNameOcc tc_rdr), tcdDerivs = 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 -> [LConDecl RdrName] } : {- empty -} { (\ tc_occ -> []) } | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ; con_info = PrefixCon [toHsType $2] } in [noLoc $ mkSimpleConDecl (noLoc dc_name) [] (noLoc []) con_info]) } cons :: { [LConDecl RdrName] } : {- empty -} { [] } -- 20060420 Empty data types allowed. jds | con { [$1] } | con ';' cons { $1:$3 } con :: { LConDecl RdrName } : d_pat_occ attv_bndrs hs_atys { noLoc $ mkSimpleConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3) } -- ToDo: parse record-style declarations attv_bndrs :: { [LHsTyVarBndr RdrName] } : {- empty -} { [] } | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 } hs_atys :: { [LHsType RdrName] } : atys { map toHsType $1 } --------------------------------------- -- Types --------------------------------------- atys :: { [IfaceType] } : {- empty -} { [] } | aty atys { $1:$2 } aty :: { IfaceType } : fs_var_occ { IfaceTyVar $1 } | q_tc_name { IfaceTyConApp (IfaceTc $1) [] } | '(' ty ')' { $2 } bty :: { IfaceType } : fs_var_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 } | q_var_occ atys { undefined } | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 } | '(' ty ')' { $2 } ty :: { IfaceType } : bty { $1 } | bty '->' ty { IfaceFunTy $1 $3 } | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 } ---------------------------------------------- -- Bindings are in Iface syntax vdefgs :: { [IfaceBinding] } : {- empty -} { [] } | let_bind ';' vdefgs { $1 : $3 } let_bind :: { IfaceBinding } : '%rec' '{' vdefs1 '}' { IfaceRec $3 } -- Can be empty. Do we care? | vdef { let (b,r) = $1 in IfaceNonRec b r } vdefs1 :: { [(IfaceLetBndr, IfaceExpr)] } : vdef { [$1] } | vdef ';' vdefs1 { $1:$3 } vdef :: { (IfaceLetBndr, IfaceExpr) } : fs_var_occ '::' ty '=' exp { (IfLetBndr $1 $3 NoInfo, $5) } | '%local' vdef { $2 } -- NB: qd_occ includes data constructors, because -- we allow data-constructor wrappers at top level -- But we discard the module name, because it must be the -- same as the module being compiled, and Iface syntax only -- has OccNames in binding positions. Ah, but it has Names now! --------------------------------------- -- Binders bndr :: { IfaceBndr } : '@' tv_bndr { IfaceTvBndr $2 } | id_bndr { IfaceIdBndr $1 } bndrs :: { [IfaceBndr] } : bndr { [$1] } | bndr bndrs { $1:$2 } id_bndr :: { IfaceIdBndr } : '(' fs_var_occ '::' ty ')' { ($2,$4) } tv_bndr :: { IfaceTvBndr } : fs_var_occ { ($1, ifaceLiftedTypeKind) } | '(' fs_var_occ '::' akind ')' { ($2, $4) } tv_bndrs :: { [IfaceTvBndr] } : {- empty -} { [] } | tv_bndr tv_bndrs { $1:$2 } akind :: { IfaceKind } : '*' { ifaceLiftedTypeKind } | '#' { ifaceUnliftedTypeKind } | '?' { ifaceOpenTypeKind } | '(' kind ')' { $2 } kind :: { IfaceKind } : akind { $1 } | akind '->' kind { ifaceArrow $1 $3 } | ty ':=:' ty { ifaceEq $1 $3 } ----------------------------------------- -- Expressions aexp :: { IfaceExpr } : fs_var_occ { IfaceLcl $1 } | q_var_occ { IfaceExt $1 } | q_dc_name { IfaceExt $1 } | lit { IfaceLit $1 } | '(' exp ')' { $2 } fexp :: { IfaceExpr } : fexp aexp { IfaceApp $1 $2 } | fexp '@' aty { IfaceApp $1 (IfaceType $3) } | aexp { $1 } exp :: { IfaceExpr } : fexp { $1 } | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 } | '%let' let_bind '%in' exp { IfaceLet $2 $4 } -- gaw 2004 | '%case' '(' ty ')' aexp '%of' id_bndr '{' alts1 '}' { IfaceCase $5 (fst $7) $9 } | '%cast' aexp aty { IfaceCast $2 $3 } -- No InlineMe any more -- | '%note' STRING exp -- { case $2 of -- --"SCC" -> IfaceNote (IfaceSCC "scc") $3 -- "InlineMe" -> IfaceNote IfaceInlineMe $3 -- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall (CCallSpec (StaticTarget (mkFastString $2) Nothing) CCallConv (PlaySafe False))) $3 } alts1 :: { [IfaceAlt] } : alt { [$1] } | alt ';' alts1 { $1:$3 } alt :: { IfaceAlt } : q_dc_name bndrs '->' exp { (IfaceDataAlt $1, map ifaceBndrName $2, $4) } -- The external syntax currently includes the types of the -- the args, but they aren't needed internally -- Nor is the module qualifier | q_dc_name '->' exp { (IfaceDataAlt $1, [], $3) } | lit '->' exp { (IfaceLitAlt $1, [], $3) } | '%_' '->' exp { (IfaceDefault, [], $3) } lit :: { Literal } : '(' INTEGER '::' aty ')' { convIntLit $2 $4 } | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 } | '(' CHAR '::' aty ')' { MachChar $2 } | '(' STRING '::' aty ')' { MachStr (mkFastString $2) } fs_var_occ :: { FastString } : NAME { mkFastString $1 } var_occ :: { String } : NAME { $1 } -- Data constructor in a pattern or data type declaration; use the dataName, -- because that's what we expect in Core case patterns d_pat_occ :: { OccName } : CNAME { mkOccName dataName $1 } { ifaceKind kc = IfaceTyConApp kc [] ifaceBndrName (IfaceIdBndr (n,_)) = n ifaceBndrName (IfaceTvBndr (n,_)) = n convIntLit :: Integer -> IfaceType -> Literal convIntLit i (IfaceTyConApp tc []) | tc `eqTc` intPrimTyCon = MachInt i | tc `eqTc` wordPrimTyCon = MachWord i | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i)) | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr convIntLit i aty = pprPanic "Unknown integer literal type" (ppr aty) convRatLit :: Rational -> IfaceType -> Literal convRatLit r (IfaceTyConApp tc []) | tc `eqTc` floatPrimTyCon = MachFloat r | tc `eqTc` doublePrimTyCon = MachDouble r convRatLit i aty = pprPanic "Unknown rational literal type" (ppr aty) eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh! eqTc (IfaceTc name) tycon = name == tyConName tycon -- Tiresomely, we have to generate both HsTypes (in type/class decls) -- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes, -- 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 -> LHsType RdrName toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual (mkTyVarOccFS 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) -- We also need to convert IfaceKinds to Kinds (now that they are different). -- Only a limited form of kind will be encountered... hopefully toKind :: IfaceKind -> Kind toKind (IfaceFunTy ifK1 ifK2) = mkArrowKind (toKind ifK1) (toKind ifK2) toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) [] toKind other = pprPanic "toKind" (ppr other) toKindTc :: IfaceTyCon -> TyCon toKindTc IfaceLiftedTypeKindTc = liftedTypeKindTyCon toKindTc IfaceOpenTypeKindTc = openTypeKindTyCon toKindTc IfaceUnliftedTypeKindTc = unliftedTypeKindTyCon toKindTc IfaceUbxTupleKindTc = ubxTupleKindTyCon toKindTc IfaceArgTypeKindTc = argTypeKindTyCon toKindTc other = pprPanic "toKindTc" (ppr other) ifaceTcType ifTc = IfaceTyConApp ifTc [] ifaceLiftedTypeKind = ifaceTcType IfaceLiftedTypeKindTc ifaceOpenTypeKind = ifaceTcType IfaceOpenTypeKindTc ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 ifaceEq ifT1 ifT2 = IfacePredTy (IfaceEqPred ifT1 ifT2) toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) (toKind k) ifaceExtRdrName :: Name -> RdrName ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name) ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other) 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 }