{
module ParserCore ( parseCore ) where

import HsCore
import RdrHsSyn
import HsSyn
import TyCon
import TcType
import RdrName
import OccName
import Module
import ParserCoreUtils
import LexCore
import Literal
import BasicTypes
import Type
import SrcLoc
import FastString

#include "../HsVersions.h"

}

%name parseCore
%tokentype { Token }

%token
 '%module'	{ TKmodule }
 '%data'	{ TKdata }
 '%newtype'	{ TKnewtype }
 '%forall'	{ TKforall }
 '%rec'		{ TKrec }
 '%let'		{ TKlet }
 '%in'		{ TKin }
 '%case'	{ TKcase }
 '%of'		{ TKof }
 '%coerce'	{ TKcoerce }
 '%note'	{ TKnote }
 '%external'	{ TKexternal }
 '%_'		{ TKwild }
 '('		{ TKoparen }
 ')'		{ TKcparen }
 '{'		{ TKobrace }
 '}'		{ TKcbrace }
 '#' 		{ TKhash}
 '='		{ TKeq }
 '::'		{ TKcoloncolon }
 '*'		{ 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	:: { RdrNameHsModule }
	: '%module' modid tdefs vdefgs
		{ HsModule $2 Nothing Nothing [] ($3 ++ concat $4) Nothing noSrcLoc}

tdefs	:: { [RdrNameHsDecl] }
	: {- empty -}	{[]}
	| tdef ';' tdefs	{$1:$3}

tdef	:: { RdrNameHsDecl }
	: '%data' q_tc_name tbinds '=' '{' cons1 '}'
                { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) }
	| '%newtype' q_tc_name tbinds trep 
		{ TyClD (mkTyData NewType ([], $2, $3) ($4 $2 $3) Nothing noSrcLoc) }

trep    :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
        : {- empty -}   { (\ x ts -> Unknown) }
        | '=' ty        { (\ x ts -> DataCons [ConDecl x x ts [] (VanillaCon [unbangedType $2]) noSrcLoc]) }

tbind	:: { HsTyVarBndr RdrName }
	:  name                    { IfaceTyVar $1 liftedTypeKind }
	|  '(' name '::' akind ')' { IfaceTyVar $2 $4 }

tbinds 	:: { [HsTyVarBndr RdrName] }
	: {- empty -}	{ [] }
	| tbind tbinds	{ $1:$2 }

vdefgs	:: { [[RdrNameHsDecl]] }
	: {- empty -}	        { [] }
	| vdefg ';' vdefgs	{ ($1:$3) }

vdefg	:: { [RdrNameHsDecl] }
	: '%rec' '{' vdefs1 '}' { $3   }
	|  vdef                 { [$1] }

let_bind :: { UfBinding RdrName }
	: '%rec' '{' vdefs1 '}' { UfRec (map convBind $3)   }
	|  vdef                 { let (b,r) = convBind $1
				  in UfNonRec b r }

vdefs1	:: { [RdrNameHsDecl] }
	: vdef		        { [$1] }
	| vdef ';' vdefs1       { $1:$3 }

vdef	:: { RdrNameHsDecl }
	: qname '::' ty '=' exp { TyClD (CoreDecl  $1 $3 $5 noSrcLoc) }


vbind	:: { (RdrName, RdrNameHsType) }
	: '(' name '::' ty ')'	{ ($2,$4) }

vbinds	:: { [(RdrName, RdrNameHsType)] }
	: {-empty -} 	{ [] }
	| vbind vbinds	{ $1:$2 }

bind	:: { UfBinder RdrName }
        : '@' tbind 	{ let (IfaceTyVar v k) = $2  in UfTyBinder  v k  }
	| vbind		{ let (v,ty) = $1 in UfValBinder v ty }

binds1 	:: { [UfBinder RdrName] }
	: bind		{ [$1] }
	| bind binds1	{ $1:$2 }

attbinds :: { [RdrNameHsTyVar] }
	: {- empty -} 	     { [] }
	| '@' tbind attbinds { $2:$3 }

akind	:: { Kind }
	: '*' 		   { liftedTypeKind   }	
	| '#'		   { unliftedTypeKind }
	| '?'		   { openTypeKind     }
        | '(' kind ')'	   { $2 }

kind 	:: { Kind }
	: akind 	   { $1 }
	| akind '->' kind  { mkArrowKind $1 $3 }

cons1	:: { [ConDecl RdrName] }
	: con		{ [$1] }
	| con ';' cons1	{ $1:$3 }

con	:: { ConDecl RdrName }
	: q_d_name attbinds atys 
		{ mkConDecl $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc}

atys	:: { [ RdrNameHsType] }
	: {- empty -}   { [] }
	| aty atys      { $1:$2 }

aty	:: { RdrNameHsType }
	: name	     { HsTyVar $1 }
	| q_tc_name     { HsTyVar $1 }
	| '(' ty ')' { $2 }


bty	:: { RdrNameHsType }
	: aty	     { $1 }
        | bty aty    { HsAppTy $1 $2 }

ty	:: { RdrNameHsType }
	: bty	                   { $1 }
	| bty '->' ty              { HsFunTy $1 $3 }
	| '%forall' tbinds '.' ty  { HsForAllTy (Just $2) [] $4 }

aexp    :: { UfExpr RdrName }
	: qname 	{ UfVar $1 }
        | q_d_name 	{ UfVar $1 } 
	| lit		{ UfLit $1 }
	| '(' exp ')' 	{ $2 }

fexp	:: { UfExpr RdrName }
	: fexp aexp	{ UfApp $1 $2 }
	| fexp '@' aty	{ UfApp $1 (UfType $3) }
	| aexp		{ $1 }

exp	:: { UfExpr RdrName }
	: fexp		           { $1 }
	| '\\' binds1 '->' exp 	   { foldr UfLam $4 $2 }
	| '%let' let_bind '%in' exp   { UfLet $2 $4 }
	| '%case' aexp '%of' vbind
	  '{' alts1 '}'		   { UfCase $2 (fst $4) $6 }
	| '%coerce' aty exp   	   { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
	| '%note' STRING exp 	   
	    { case $2 of
	       --"SCC"        -> UfNote (UfSCC "scc") $3
	       "InlineCall" -> UfNote UfInlineCall $3
	       "InlineMe"   -> UfNote UfInlineMe $3
            }
--        | '%external' STRING aty   { External $2 $3 }

alts1	:: { [UfAlt RdrName] }
	: alt		{ [$1] }
	| alt ';' alts1	{ $1:$3 }

alt	:: { UfAlt RdrName }
	: q_d_name attbinds vbinds '->' exp 
		{ {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) } 
	| lit '->' exp
		{ (UfLitAlt $1, [], $3) }
	| '%_' '->' exp
		{ (UfDefault, [], $3) }

lit	:: { Literal }
	: '(' INTEGER '::' aty ')'	{ MachInt $2 }
	| '(' RATIONAL '::' aty ')'	{ MachDouble $2 }
	| '(' CHAR '::' aty ')'		{ MachChar (fromEnum $2) }
	| '(' STRING '::' aty ')'	{ MachStr (mkFastString $2) }

name	:: { RdrName }
	: NAME	{ mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) }

cname	:: { String }
	: CNAME	{ $1 }
         
mname	:: { String }
	: CNAME	{ $1 }

modid	:: { ModuleName }
	: CNAME	{ mkSysModuleNameFS (mkFastString $1) }

qname	:: { RdrName }
	: name	{ $1 }
	| mname '.' NAME
	  { mkIfaceOrig varName (mkFastString $1,mkFastString $3) }

-- Type constructor
q_tc_name	:: { RdrName }
        : mname '.' cname 
		{ mkIfaceOrig tcName (mkFastString $1,mkFastString $3) }

-- Data constructor
q_d_name	:: { RdrName }
        : mname '.' cname 
		{ mkIfaceOrig dataName (mkFastString $1,mkFastString $3) }


{
convBind :: RdrNameHsDecl -> (UfBinder RdrName, UfExpr RdrName)
convBind (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs)

happyError :: P a 
happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
}