{-# OPTIONS_GHC -w -XNoOverloadedStrings #-} {- -*- Haskell -*- -}
-- -----------------------------------------------------------------------------
-- $Id: HsParser.ly,v 1.4 2001/11/25 08:52:13 bjpop Exp $

-- (c) Simon Marlow, Sven Panne 1997-2000
-- Modified by John Meacham

-- Haskell grammar.
-- -----------------------------------------------------------------------------

-- ToDo: Is (,) valid as exports? We don't allow it.
-- ToDo: Check exactly which names must be qualified with Prelude (commas and friends)
-- ToDo: Inst (MPCs?)
-- ToDo: Polish constr a bit
-- ToDo: Ugly: infixexp is used for lhs, pat, exp0, ...
-- ToDo: Differentiate between record updates and labeled construction.

{
module FrontEnd.HsParser (parse, parseHsStmt) where

import FrontEnd.HsSyn
import FrontEnd.ParseMonad
import FrontEnd.Lexer
import FrontEnd.ParseUtils hiding(readInteger,readRational)
import FrontEnd.SrcLoc

import Name.Names
import Name.Name

import Control.Monad (liftM, liftM2)
import Debug.Trace (trace)

}

-- -----------------------------------------------------------------------------
-- Conflicts: 10 shift/reduce

-- 7 for abiguity in 'if x then y else z + 1'
--      (shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
-- 1 for ambiguity in 'if x then y else z :: T'
--      (shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
-- 2 for ambiguity in 'case x of y :: a -> b'
--      (don't know whether to reduce 'a' as a btype or shift the '->'.
--       conclusion:  bogus expression anyway, doesn't matter)

-- -----------------------------------------------------------------------------

%token
      VARID    { VarId $$ }
      QVARID   { QVarId $$ }
      CONID    { ConId $$ }
      QCONID   { QConId $$ }
      VARSYM   { VarSym $$ }
      CONSYM   { ConSym $$ }
      QVARSYM  { QVarSym $$ }
      QCONSYM  { QConSym $$ }
      INT      { IntTok $$ }
      UINT     { UIntTok $$ }
      RATIONAL { FloatTok $$ }
      CHAR     { Character $$ }
      UCHAR    { UCharacter $$ }
      STRING   { StringTok $$ }
      USTRING  { UStringTok $$ }
      PRAGMAOPTIONS { PragmaOptions $$ }
      PRAGMASTART { PragmaStart $$ }
      PRAGMACTYPE { PragmaExp "CTYPE" }
      PRAGMAINLINE { PragmaInline $$ }
      PRAGMARULES { PragmaRules $$ }
      PRAGMASPECIALIZE { PragmaSpecialize $$ }
      PRAGMAEND { PragmaEnd }

-- Symbols

      '('     { LeftParen }
      ')'     { RightParen }
      '(#'    { LeftUParen }
      '#)'    { RightUParen }
      ';'     { SemiColon }
      '{'     { LeftCurly }
      '}'     { RightCurly }
      vccurly { VRightCurly }                 -- a virtual close brace
      '['     { LeftSquare }
      ']'     { RightSquare }
      ','     { Comma }
      '_'     { Underscore }
      '`'     { BackQuote }

-- Reserved operators

      '..'    { DotDot }
      '::'    { DoubleColon }
      '='     { Equals }
      '\\'    { Backslash }
      '|'     { Bar }
      '<-'    { LeftArrow }
      '->'    { RightArrow }
      '@'     { At }
      '~'     { Tilde }
      '=>'    { DoubleArrow }
      '-'     { Minus }
      '!'     { Exclamation }
      'bang!' { BangExclamation }
      '?'     { Quest }
      '??'    { QuestQuest }
      '*!'    { StarBang }
      '*'     { Star }
      '#'     { Hash }
      '.'     { Dot }

-- Reserved Ids

      'as'            { KW_As }
      'case'          { KW_Case }
      'class'         { KW_Class }
      'alias'         { KW_Alias }
      'data'          { KW_Data }
      'default'       { KW_Default }
      'deriving'      { KW_Deriving }
      'do'            { KW_Do }
      'else'          { KW_Else }
      'hiding'        { KW_Hiding }
      'if'            { KW_If }
      'import'        { KW_Import }
      'in'            { KW_In }
      'infix'         { KW_Infix }
      'infixl'        { KW_InfixL }
      'infixr'        { KW_InfixR }
      'instance'      { KW_Instance }
      'let'           { KW_Let }
      'module'        { KW_Module }
      'newtype'       { KW_NewType }
      'of'            { KW_Of }
      'then'          { KW_Then }
      'type'          { KW_Type }
      'where'         { KW_Where }
      'qualified'     { KW_Qualified }
      'foreign'       { KW_Foreign }
      'forall'        { KW_Forall }
      'exists'        { KW_Exists }
      'kind'          { KW_Kind }
      'family'        { KW_Family }
      'closed'        { KW_Closed }

%monad { P } { thenP } { returnP }
%lexer { lexer } { EOF }
%name parse module
%name parseHsStmt qual
%tokentype { Token }
%%

-- -----------------------------------------------------------------------------
-- Module Header
module :: { HsModule }
      : srcloc modulep                  { $2 { hsModuleSrcLoc = $1, hsModuleOptions = [] } }
      | srcloc PRAGMAOPTIONS module     { $3 { hsModuleSrcLoc = $1, hsModuleOptions = hsModuleOptions $3 ++ $2 } }

modulep  :: { HsModule }
      : 'module' modid maybeexports 'where' body      { HsModule { hsModuleName = $2, hsModuleExports = $3, hsModuleImports = (fst $5), hsModuleDecls = (snd $5)
                                                                 , hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" } }
      | body                                          { HsModule { hsModuleName = main_mod, hsModuleExports = Just [HsEVar (toName Val "main")], hsModuleImports = (fst $1), hsModuleDecls = (snd $1)
                                                                 , hsModuleSrcLoc = error "hsModuleSrcLoc not set", hsModuleOptions = error "hsModuleOptions not set" } }

body :: { ([HsImportDecl],[HsDecl]) }
      :  '{' bodyaux '}'                              { $2 }
      |      layout_on  bodyaux close                 { $2 }

bodyaux :: { ([HsImportDecl],[HsDecl]) }
      : optsemis impdecls semis topdecls              { (reverse $2, fixupHsDecls $4) }
      | optsemis                topdecls              { ([], fixupHsDecls $2) }
      | optsemis impdecls optsemis                    { (reverse $2, []) }
      | optsemis                                      { ([], []) }

optsemi :: { () }
      : ';'                                           { () }
      | {- empty -}                                   { () }

semis :: { () }
       : optsemis ';'				{ () }
optsemis :: { () }
       : semis					{ () }
       | {- empty -}				{ () }
-- -----------------------------------------------------------------------------
-- The Export List

maybeexports :: { Maybe [HsExportSpec] }
      :  exports                              { Just $1 }
      |  {- empty -}                          { Nothing }

exports :: { [HsExportSpec] }
      : '(' exportlist maybecomma ')'         { reverse $2 }
      | '(' ')'                               { [] }

maybecomma :: { () }
      : ','                                   { () }
      | {- empty -}                           { () }

exportlist :: { [HsExportSpec] }
      :  exportlist ',' export                { $3 : $1 }
      |  export                               { [$1]  }

export :: { HsExportSpec }
      :  qvar                                 { HsEVar $1 }
      |  qtyconorcls                          { HsEAbs $1 }
      |  qtyconorcls '(' '..' ')'             { HsEThingAll $1 }
      |  qtyconorcls '(' ')'                  { HsEThingWith $1 [] }
      |  qtyconorcls '(' qcnames ')'          { HsEThingWith $1 (reverse $3) }
      |  'module' modid                       { HsEModuleContents $2 }

qcnames :: { [HsName] }
      :  qcnames ',' qcname                   { $3 : $1 }
      |  qcname                               { [$1]  }

qcname :: { HsName }
      :  qvar                                 { $1 }
      |  qcon                                 { $1 }

-- -----------------------------------------------------------------------------
-- Import Declarations

impdecls :: { [HsImportDecl] }
      : impdecls semis impdecl                  { $3 : $1 }
      | impdecl                               { [$1] }

impdecl :: { HsImportDecl }
      : 'import' srcloc optqualified modid maybeas maybeimpspec
                              { HsImportDecl $2 $4 $3 $5 $6 }

optqualified :: { Bool }
      : 'qualified'                           { True  }
      | {- empty -}                           { False }

maybeas :: { Maybe Module }
      : 'as' modid                            { Just $2 }
      | {- empty -}                           { Nothing }

maybeimpspec :: { Maybe (Bool, [HsExportSpec]) }
      : impspec                               { Just $1 }
      | {- empty -}                           { Nothing }

impspec :: { (Bool, [HsExportSpec]) }
      :  '(' importlist maybecomma ')'          { (False, reverse $2) }
      |  '(' ')'                                { (False, []) }
      |  'hiding' '(' importlist maybecomma ')' { (True,  reverse $3) }
      |  'hiding' '(' ')'                       { (True, []) }

importlist :: { [HsExportSpec] }
      :  importlist ',' import                { $3 : $1 }
      |  import                               { [$1]  }

import :: { HsExportSpec }
      :  var                                  { HsEVar $1 }
      |  tyconorcls                           { HsEAbs $1 }
      |  tyconorcls '(' '..' ')'              { HsEThingAll $1 }
      |  tyconorcls '(' ')'                   { HsEThingWith $1 [] }
      |  tyconorcls '(' cnames ')'            { HsEThingWith $1 (reverse $3) }
      |  'class' import                       { HsEQualified ClassName $2 }
      |  'type'  import                       { HsEQualified TypeConstructor $2 }
      |  'kind'  import                       { HsEQualified SortName $2 }

cnames :: { [HsName] }
      :  cnames ',' cname                     { $3 : $1 }
      |  cname                                { [$1]  }

cname :: { HsName }
      :  var                                  { $1 }
      |  con                                  { $1 }

-- -----------------------------------------------------------------------------
-- Fixity Declarations

fixdecl :: { HsDecl }
      : srcloc infix prec ops                 { HsInfixDecl $1 $2 $3 (reverse $4) }

prec :: { Int }
      : {- empty -}                           { 9 }
      | INT                                   {%  checkPrec $1 `thenP` \p ->
                                                  returnP (fromInteger (readInteger p)) }

infix :: { HsAssoc }
      : 'infix'                               { HsAssocNone  }
      | 'infixl'                              { HsAssocLeft  }
      | 'infixr'                              { HsAssocRight }

ops   :: { [HsName] }
      : ops ',' op                            { $3 : $1 }
      | op                                    { [$1] }

-- -----------------------------------------------------------------------------
-- Top-Level Declarations

-- Note: The report allows topdecls to be empty. This would result in another
-- shift/reduce-conflict, so we don't handle this case here, but in bodyaux.

topdecls :: { [HsDecl] }
      : topdecls1 optsemis          { reverse $1 } -- TODO checkRevDecls

topdecls1 :: { [HsDecl] }
      : topdecls1 semis topdecl       { $3 : $1  }
      | topdecl                       { [$1] }

mkind :: { Maybe HsKind }
    : '::' kind                       { Just $2 }
    |                                 { Nothing }

mCTYPE :: { Maybe String }
    :  PRAGMACTYPE STRING PRAGMAEND  { Just $2 }
    |                                { Nothing }

topdecl :: { HsDecl }
      : 'data' mCTYPE ctype srcloc deriving
          {% checkDataHeader $3 `thenP` \(cs,c,t) ->
             returnP hsDataDecl { hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $5, hsDeclCTYPE = $2 } }
      | 'data' mCTYPE ctype '::' kind srcloc deriving
          {% checkDataHeader $3 `thenP` \(cs,c,t) ->
             returnP hsDataDecl { hsDeclSrcLoc = $6, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $7, hsDeclHasKind = Just $5, hsDeclCTYPE = $2 } }
      | 'data' 'family' simpletype srcloc mkind
                      { HsTypeFamilyDecl $4 True (fst $3) (snd $3) $5 }
      | 'type' 'family' simpletype srcloc mkind
                      { HsTypeFamilyDecl $4 False (fst $3) (snd $3) $5 }
      | 'data' 'kind' ctype srcloc '=' constrs deriving
                      {% checkDataHeader $3 `thenP` \(cs,c,t) ->
                         returnP hsDataDecl { hsDeclDeclType = DeclTypeKind, hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $7, hsDeclCons = reverse $6 } }
      | 'data' mCTYPE ctype srcloc '=' constrs deriving
                      {% checkDataHeader $3 `thenP` \(cs,c,t) ->
                         returnP hsDataDecl { hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclDerives = $7, hsDeclCons = reverse $6, hsDeclCTYPE = $2 } }
      | 'newtype' mCTYPE ctype srcloc '=' constr deriving
                      {% checkDataHeader $3 `thenP` \(cs,c,t) ->
                         returnP hsNewTypeDecl { hsDeclSrcLoc = $4, hsDeclContext = cs, hsDeclName = c, hsDeclArgs = t, hsDeclCons = [$6], hsDeclDerives = $7, hsDeclCTYPE = $2} }
      | 'class' srcloc classhead optfundep optcbody
                      { HsClassDecl $2 $3 $5 }
      | 'class' 'alias' srcloc conid varids '=' carhs optcbody
                      {% let
                         { (cxt, clss) = $7;
                           ret = HsClassAliasDecl { hsDeclSrcLoc = $3, hsDeclName = $4, hsDeclTypeArgs = map HsTyVar $5, hsDeclContext = cxt, hsDeclClasses = clss, hsDeclDecls =$8 }
                         } in trace ("\n"++show ret++"\n") (return ret)
                      }
      | 'instance' srcloc classhead optvaldefs
                      { HsInstDecl $2 $3 $4 }
      | 'deriving' 'instance' srcloc classhead
                      { HsDeclDeriving $3 $4 }
      | 'default' srcloc type
                      { HsDefaultDecl $2 $3 }
      | pinfixexp srcloc '<-' exp      {% checkPattern $1 `thenP` \p ->
                                         returnP (HsActionDecl $2 p $4) }
      | 'foreign' srcloc 'import' varids mstring '::' ctype
                      {% doForeign $2 (toName Val "import":reverse $4) $5 $7  }
      | 'foreign' srcloc varids mstring '::' ctype
                      {% doForeign $2 (reverse $3) $4 $6  }
      | 'foreign' srcloc varids mstring '::' ctype '=' exp
                      {% doForeignEq $2 (reverse $3) $4 $6 $8 }
      | PRAGMARULES rules PRAGMAEND
              { HsPragmaRules $ map (\x -> x { hsRuleIsMeta = $1 }) (reverse $2) }
      | srcloc PRAGMASPECIALIZE var '::' type PRAGMAEND
                      { HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = $3, hsDeclType = $5
                                           , hsDeclUniq = error "hsDeclUniq not set"  } }
      | srcloc PRAGMASPECIALIZE conid var '::' type PRAGMAEND
                      { HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = $4, hsDeclType = $6
                                           , hsDeclUniq = error "hsDeclUniq not set"  } }
      | decl          { $1 }

rule :: { HsRule }
      : srcloc STRING mfreevars exp '=' exp
         { HsRule { hsRuleSrcLoc = $1, hsRuleString = $2, hsRuleFreeVars = $3, hsRuleLeftExpr = $4, hsRuleRightExpr = $6
                  , hsRuleUniq = error "hsRuleUniq not set", hsRuleIsMeta = error "hsRuleIsMeta not set" } }

rules :: { [HsRule] }
      : rules ';'rule         { $3 : $1 }
      | rules ';'             { $1 }
      | rule                  { [$1] }
      | {- empty -}           { [] }

mfreevars :: { [(HsName,Maybe HsType)] }
      : 'forall' vbinds '.' { $2 }
      | { [] }

vbinds :: { [(HsName,Maybe HsType)] }
      : vbinds '(' var '::' type ')' { ($3,Just $5) : $1 }
      | vbinds var                   { ($2,Nothing) : $1 }
      |                              { [] }

decls :: { [HsDecl] }
      : optsemis decls1 optsemis      { fixupHsDecls ( reverse $2 ) }
      | optsemis                      { [] }

decls1 :: { [HsDecl] }
      : decls1 semis decl             { $3 : $1 }
      | decl                          { [$1] }

decl :: { HsDecl }
      : signdecl                      { $1 }
      | fixdecl                       { $1 }
      | valdef                        { $1 }
      | pragmaprops                   { $1 }

decllist :: { [HsDecl] }
      : '{' decls '}'                 { $2 }
      |     layout_on  decls close    { $2 }

signdecl :: { HsDecl }
      : vars srcloc '::' ctype        { HsTypeSig $2 (reverse $1) $4 }

pragmainline  :: { HsDecl }
      : PRAGMAINLINE srcloc optphasesn vars PRAGMAEND { HsPragmaProps $2 $1 $4 }

optphasesn :: { (Bool, Maybe Int) }
      : '~' optphases                 { (True, $2) }
      | optphases                     { (False, $1) }

optphases :: { Maybe Int }
      : '[' INT ']'                   { (Just (readInteger $2)) }
      |                               { Nothing }

pragmaprops  :: { HsDecl }
      : PRAGMASTART srcloc  vars PRAGMAEND  { HsPragmaProps $2 $1 $3 }

--pragmaexp  :: { Located HsPragmaExp }
--      : PRAGMAEXP srcloc texps srcloc PRAGMAEND
--        { located ($2,$4) $ HsPragmaExp $1 $3 }

-- ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var
-- instead of qvar, we get another shift/reduce-conflict. Consider the
-- following programs:

--    { (+) :: ... }          only var
--    { (+) x y  = ... }      could (incorrectly) be qvar

-- We re-use expressions for patterns, so a qvar would be allowed in patterns
-- instead of a var only (which would be correct). But deciding what the + is,
-- would require more lookahead. So let's check for ourselves...

vars  :: { [HsName] }
      : vars ',' var                  { $3 : $1 }
      | qvar                          {% checkUnQual $1 `thenP` \n ->
                                         returnP [n] }

-- FFI parts
mstring :: { Maybe (String,HsName) }
mstring : STRING var        { Just ($1,$2) }
        | {- empty -}    { Nothing }

-- -----------------------------------------------------------------------------
-- Types

type :: { HsType }
      : btype '->' type               { HsTyFun $1 $3 }
      | btype                         { $1 }
      | 'forall' tbinds '.' ctype     { HsTyForall { hsTypeVars = reverse $2, hsTypeType = $4 } }
      | 'exists' tbinds '.' ctype     { HsTyExists { hsTypeVars = reverse $2, hsTypeType = $4 } }

tbinds :: { [HsTyVarBind] }
      : tbinds tbind                  { $2 : $1 }
      | tbind                         { [$1] }

tbind :: { HsTyVarBind }
       : srcloc varid                   { hsTyVarBind { hsTyVarBindSrcLoc = $1, hsTyVarBindName = $2 } }
       | srcloc '(' varid '::' kind ')' { hsTyVarBind { hsTyVarBindSrcLoc = $1, hsTyVarBindName = $3, hsTyVarBindKind = Just $5 } }

kind :: { HsKind }
      : bkind                          { $1 }
      | bkind '->' kind                { HsKindFn $1 $3 }

bkind :: { HsKind }
       : '(' kind ')'           { $2 }
       |  '*'                   { hsKindStar }
       |  '#'                   { hsKindHash }
       |  '!'                   { hsKindBang }
       |  'bang!'               { hsKindBang }
       |  '*!'                  { hsKindStarBang }
       |  '?'                   { hsKindQuest }
       |  '??'                  { hsKindQuestQuest }
       |  qconid                { HsKind $1 }

btype :: { HsType }
      : btype atype                   { HsTyApp $1 $2 }
      | atype                         { $1 }

atype :: { HsType }
      : gtycon                        { HsTyCon $1 }
      | tyvar                         { HsTyVar $1 }
      | '(' types ')'                 { HsTyTuple (reverse $2) }
      | '(#' '#)'                     { HsTyUnboxedTuple [] }
      | '(#' type '#)'                { HsTyUnboxedTuple [$2] }
      | '(#' types '#)'               { HsTyUnboxedTuple (reverse $2) }
      | '[' type ']'                  { HsTyApp list_tycon $2 }
      | '(' ktype ')'                 { $2 }
      | '(' type '=' type ')'         { HsTyEq $2 $4 }

ktype :: { HsType }
    : srcloc atype '::' kind srcloc { HsTyExpKind { hsTyLType = located ($1,$5) $2, hsTyKind = $4 } }
    | type                          { $1 }

gtycon :: { HsName }
      : qcon                          { $1 }
      | '(' ')'                       { unit_tycon_name }
      | '(' '->' ')'                  { fun_tycon_name }
      | '[' ']'                       { list_tycon_name }
      | '(' commas ')'                { tuple_tycon_name $2 }

-- (Slightly edited) Comment from GHC's hsparser.y:
-- "context => type" vs  "type" is a problem, because you can't distinguish between

--      foo :: (Baz a, Baz a)
--      bar :: (Baz a, Baz a) => [a] -> [a] -> [a]

-- with one token of lookahead.  The HACK is to parse the context as a btype
-- (more specifically as a tuple type), then check that it has the right form
-- C a, or (C1 a, C2 b, ... Cn z) and convert it into a context.  Blaach!

ctype :: { HsQualType }
      : context '=>' type             { HsQualType $1 $3 }
      | type                          { HsQualType [] $1 }

context :: { HsContext }
        : btype				{% checkContext $1 }

carhs :: { (HsContext, HsContext) }
       : btype '=>' btype {% liftM2 (,)     (checkContext $1) (checkContext $3) }
       | btype            {% liftM ((,) []) (checkContext $1) }

classhead :: { HsClassHead }
    : ctype {% qualTypeToClassHead $1 }

types :: { [HsType] }
      : types ',' type                { $3 : $1 }
      | type  ',' type                { [$3, $1] }

simpletype :: { (HsName, [HsType]) }
      : tycon atypes                  { ($1,reverse $2) }

atypes :: { [HsType] }
      : atypes atype                  { $2 : $1 }
      | {- empty -}                   { [] }

-- -----------------------------------------------------------------------------
-- Datatype declarations

constrs :: { [HsConDecl] }
      : constrs '|' constr            { $3 : $1 }
      | constr                        { [$1] }

constr :: { HsConDecl }
      : srcloc mexists scontype               { HsConDecl { hsConDeclSrcLoc = $1, hsConDeclName = (fst $3), hsConDeclConArg = (snd $3), hsConDeclExists = $2 } }
      | srcloc mexists sbtype conop sbtype    { HsConDecl { hsConDeclSrcLoc = $1, hsConDeclName = $4, hsConDeclConArg = [$3,$5], hsConDeclExists = $2 } }
      | srcloc mexists con '{' fielddecls '}'
                                      { HsRecDecl { hsConDeclSrcLoc = $1, hsConDeclName = $3, hsConDeclRecArg = (reverse $5), hsConDeclExists = $2 } }
      | srcloc mexists con '{' '}'
                                      { HsRecDecl { hsConDeclSrcLoc = $1, hsConDeclName = $3, hsConDeclRecArg = [], hsConDeclExists = $2 } }

mexists :: { [HsTyVarBind] }
        : 'exists' tbinds '.'         { $2 }
        | 'forall' tbinds '.'         { $2 }  -- Allowed for GHC compatability
        |                             { [] }

scontype :: { (HsName, [HsBangType]) }
      : btype                         {% splitTyConApp $1 `thenP` \(c,ts) ->
                                         returnP (c,map HsUnBangedTy ts) }
      | scontype1                     { $1 }

scontype1 :: { (HsName, [HsBangType]) }
      : btype '!' atype               {% splitTyConApp $1 `thenP` \(c,ts) ->
                                         returnP (c,map HsUnBangedTy ts++
                                                      [HsBangedTy $3]) }
      | btype 'bang!' atype               {% splitTyConApp $1 `thenP` \(c,ts) ->
                                         returnP (c,map HsUnBangedTy ts++
                                                      [HsBangedTy $3]) }
      | scontype1 satype              { (fst $1, snd $1 ++ [$2] ) }

satype :: { HsBangType }
      : atype                         { HsUnBangedTy $1 }
      | '!' atype                     { HsBangedTy   $2 }
      | 'bang!' atype                 { HsBangedTy   $2 }

sbtype :: { HsBangType }
      : btype                         { HsUnBangedTy $1 }
      | '!' atype                     { HsBangedTy   $2 }
      | 'bang!' atype                 { HsBangedTy   $2 }

fielddecls :: { [([HsName],HsBangType)] }
      : fielddecls ',' fielddecl      { $3 : $1 }
      | fielddecl                     { [$1] }

fielddecl :: { ([HsName],HsBangType) }
      : vars '::' stype               { (reverse $1, $3) }

stype :: { HsBangType }
      : type                          { HsUnBangedTy $1 }
      | '!' atype                     { HsBangedTy   $2 }
      | 'bang!' atype                 { HsBangedTy   $2 }

deriving :: { [HsName] }
      : {- empty -}                   { [] }
      | 'deriving' qtycls             { [$2] }
      | 'deriving' '('          ')'   { [] }
      | 'deriving' '(' dclasses ')'   { reverse $3 }

dclasses :: { [HsName] }
      : dclasses ',' qtycls           { $3 : $1 }
      | qtycls                        { [$1] }

-- -----------------------------------------------------------------------------
-- Class declarations

optcbody :: { [HsDecl] }
      : 'where' decllist                      { fixupHsDecls $2 }
      | {- empty -}                           { [] }

cdefaults :: { [HsDecl] }
     : cdefaults ';' valdef                  { $3 : $1 }
     | valdef                                { [$1] }

-- -----------------------------------------------------------------------------
-- Functional dependencies

optfundep :: { [([HsName],[HsName])] }
      : {- empty -}                           { [] }
      | '|' fundeps                           { reverse $2 }

fundeps   :: { [([HsName],[HsName])] }
      : fundeps ',' fundep                    { ($3:$1) }
      | fundep                                { [$1]    }

fundep    :: { ([HsName],[HsName]) }
      : varids '->' varids                    { ($1,$3) }

varids    :: { [HsName] }
      : {- empty -}                           { [] }
      | varids varid                          { ($2:$1) }

-- -----------------------------------------------------------------------------
-- Instance declarations

optvaldefs :: { [HsDecl] }
      : 'where' '{' valdefs '}'               { $3 }
      | 'where' layout_on valdefs close       { $3 }
      | {- empty -}                           { [] }

-- Recycling...

valdefs :: { [HsDecl] }
      : cdefaults optsemi                     { fixupHsDecls (reverse $1) }
      | optsemi                               { [] }

-- -----------------------------------------------------------------------------
-- Value definitions

valdef :: { HsDecl }
      : 'type' simpletype srcloc '=' type
                      { HsTypeDecl $3 (fst $2) (snd $2) $5 }
--      | 'data' simpletype srcloc
--                      { HsTypeFamilyDecl $3 True (fst $2) (snd $2) Nothing }
--      | 'data' simpletype srcloc '::' kind
--                      { HsTypeFamilyDecl $3 True (fst $2) (snd $2) (Just $5) }
      | 'type' simpletype srcloc
                      { HsTypeFamilyDecl $3 False (fst $2) (snd $2) Nothing }
      | 'type' simpletype srcloc '::' kind
                      { HsTypeFamilyDecl $3 False (fst $2) (snd $2) (Just $5) }
      | pinfixexp srcloc rhs optwhere          {% checkValDef $2 $1 $3 $4}
      | srcloc PRAGMASPECIALIZE 'instance'  type PRAGMAEND
                      { HsPragmaSpecialize { hsDeclSrcLoc = $1, hsDeclBool = $2, hsDeclName = nameName u_instance , hsDeclType = $4
                                           , hsDeclUniq = error "hsDeclUniq not set"  } }
      | pragmainline { $1 }

optwhere :: { [HsDecl] }
       : 'where' decllist		{ $2 }
       | {- empty -}			{ [] }

rhs   :: { HsRhs }
      : '=' exp                       {% checkExpr $2 `thenP` \e ->
                                         returnP (HsUnGuardedRhs e) }
      | gdrhs                         { HsGuardedRhss  (reverse $1) }

gdrhs :: { [HsGuardedRhs] }
      : gdrhs gdrh                    { $2 : $1 }
      | gdrh                          { [$1] }

gdrh :: { HsGuardedRhs }
      : '|' exp srcloc '=' exp        {% checkExpr $2 `thenP` \g ->
                                         checkExpr $5 `thenP` \e ->
                                         returnP (HsGuardedRhs $3 g e) }

-- -----------------------------------------------------------------------------
-- Expressions

exp   :: { HsExp }
      : infixexp '::' srcloc ctype    { HsExpTypeSig $3 $1 $4 }
      | infixexp                      { $1 }

infixexp :: { HsExp }
      : exp10                         { $1 }
      | infixexp qop exp10            { HsInfixApp $1 $2 $3 }

exp10 :: { HsExp }
      : '\\' aexps srcloc '->' exp    {% checkPatterns (reverse $2) `thenP` \ps ->
                                         returnP (HsLambda $3 ps $5) }
      | 'let' decllist 'in' exp       { HsLet $2 $4 }
-- -- > | 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 }
      | 'if' exp optsemi 'then' exp optsemi 'else' exp { HsIf $2 $5 $8 }
      | 'case' exp 'of' altslist      { HsCase $2 $4 }
      | '-' fexp                      { HsNegApp $2 }
      | 'do' stmtlist                 { HsDo $2 }
      | fexp                          { $1 }

fexp :: { HsExp }
      : fexp aexp                     { HsApp $1 $2 }
      | aexp                          { $1 }

aexps :: { [HsExp] }
      : aexps aexp                    { $2 : $1 }
      | aexp                          { [$1] }

-- UGLY: Because patterns and expressions are mixed, aexp has to be split into
-- two rules: One left-recursive and one right-recursive. Otherwise we get two
-- reduce/reduce-errors (for as-patterns and irrefutable patters).

-- Note: The first alternative of aexp is not neccessarily a record update, it
-- could be a labeled construction, too.

aexp  :: { HsExp }
      : aexp '{' fbinds '}'           {% mkRecConstrOrUpdate $1 (reverse $3) }
      | aexp1                         { $1 }

-- Even though the variable in an as-pattern cannot be qualified, we use
-- qvar here to avoid a shift/reduce conflict, and then check it ourselves
-- (as for vars above).

aexp1 :: { HsExp }
      : qvar                          { HsVar $1 }
      | gcon                          { $1 }
      | literal                       { $1 }
      | '(' exp ')'                   { HsParen $2 }
      | '(' texps ')'                 { HsTuple (reverse $2) }
      | '(#' '#)'                     { HsUnboxedTuple [] }
      | '(#' exp '#)'                 { HsUnboxedTuple [$2] }
      | '(#' texps '#)'               { HsUnboxedTuple (reverse $2) }
      | '[' list ']'                  { $2 }
      | '(' infixexp qop ')'          { HsLeftSection $3 $2  }
      | '(' qopm infixexp ')'         { HsRightSection $3 $2 }
      | qvar '@' aexp                 {% checkUnQual $1 `thenP` \n ->
                                         returnP (HsAsPat n $3) }
      | srcloc '_'                    { HsWildCard $1 }
      | '~' srcloc aexp1 srcloc       { HsIrrPat $ located ($2,$4) $3 }
      | 'bang!' srcloc aexp1 srcloc   { HsBangPat $ located ($2,$4) $3 }

commas :: { Int }
      : commas ','                    { $1 + 1 }
      | ','                           { 1 }

texps :: { [HsExp] }
      : texps ',' exp                 { $3 : $1 }
      | exp ',' exp                   { [$3,$1] }

-- -----------------------------------------------------------------------------
-- List expressions

-- The rules below are little bit contorted to keep lexps left-recursive while
-- avoiding another shift/reduce-conflict.

list :: { HsExp }
      : exp                           { HsList [$1] }
      | lexps                         { HsList (reverse $1) }
      | exp '..'                      { HsEnumFrom $1 }
      | exp ',' exp '..'              { HsEnumFromThen $1 $3 }
      | exp '..' exp                  { HsEnumFromTo $1 $3 }
      | exp ',' exp '..' exp          { HsEnumFromThenTo $1 $3 $5 }
      | exp '|' quals                 { HsListComp $1 (reverse $3) }

lexps :: { [HsExp] }
      : lexps ',' exp                 { $3 : $1 }
      | exp ',' exp                   { [$3,$1] }

-- -----------------------------------------------------------------------------
-- Expressions

pexp   :: { HsExp }
      : pinfixexp '::' srcloc ctype    { HsExpTypeSig $3 $1 $4 }
      | pinfixexp                      { $1 }

pinfixexp :: { HsExp }
      : pexp10                         { $1 }
      | pinfixexp qop pexp10            { HsInfixApp $1 $2 $3 }

pexp10 :: { HsExp }
      : '-' pfexp                      { HsNegApp $2 }
      | pfexp                          { $1 }

pfexp :: { HsExp }
      : pfexp paexp                     { HsApp $1 $2 }
      | paexp                          { $1 }

-- UGLY: Because patterns and expressions are mixed, aexp has to be split into
-- two rules: One left-recursive and one right-recursive. Otherwise we get two
-- reduce/reduce-errors (for as-patterns and irrefutable patters).

-- Note: The first alternative of aexp is not neccessarily a record update, it
-- could be a labeled construction, too.

paexp  :: { HsExp }
      : paexp '{' pfbinds '}'           {% mkRecConstrOrUpdate $1 (reverse $3) }
      | paexp '{'  '}'                  {% mkRecConstrOrUpdate $1 [] }
      | paexp1                         { $1 }

-- Even though the variable in an as-pattern cannot be qualified, we use
-- qvar here to avoid a shift/reduce conflict, and then check it ourselves
-- (as for vars above).

paexp1 :: { HsExp }
      : qvar                          { HsVar $1 }
      | gcon                          { $1 }
      | literal                       { $1 }
      | '(' pexp ')'                  { HsParen $2 }
      | '(' ptexps ')'                { HsTuple (reverse $2) }
      | '(#' '#)'                     { HsUnboxedTuple [] }
      | '(#' pexp '#)'                { HsUnboxedTuple [$2] }
      | '(#' ptexps '#)'              { HsUnboxedTuple (reverse $2) }
      | '[' plist ']'                 { $2 }
      | '(' pinfixexp qop ')'          { HsLeftSection $3 $2  }
      | '(' qopm pinfixexp ')'         { HsRightSection $3 $2 }
      | qvar '@' paexp                {% checkUnQual $1 `thenP` \n ->
                                         returnP (HsAsPat n $3) }
      | srcloc '_'                    { HsWildCard $1 }
      | '~' srcloc paexp1 srcloc      { HsIrrPat $ located ($2,$4) $3 }
      | 'bang!' srcloc paexp1 srcloc  { HsBangPat $ located ($2,$4) $3 }

ptexps :: { [HsExp] }
      : ptexps ',' pexp                 { $3 : $1 }
      | pexp ',' pexp                   { [$3,$1] }

-- -----------------------------------------------------------------------------
-- List expressions

-- The rules below are little bit contorted to keep lexps left-recursive while
-- avoiding another shift/reduce-conflict.

plist :: { HsExp }
      : pexp                           { HsList [$1] }
      | plexps                         { HsList (reverse $1) }

plexps :: { [HsExp] }
      : plexps ',' pexp                 { $3 : $1 }
      | pexp ',' pexp                   { [$3,$1] }
-- -----------------------------------------------------------------------------
-- List comprehensions

quals :: { [HsStmt] }
      : quals ',' qual                        { $3 : $1 }
      | qual                                  { [$1] }

qual  :: { HsStmt }
      : exp srcloc '<-' exp      {% checkPattern $1 `thenP` \p ->
                                         returnP (HsGenerator $2 p $4) }
      | exp                           { HsQualifier $1 }
      | 'let' decllist                { HsLetStmt $2 }

-- -----------------------------------------------------------------------------
-- Case alternatives

altslist :: { [HsAlt] }
      : '{' alts optsemi '}'                  { reverse $2 }
      |     layout_on  alts optsemi close     { reverse $2 }

alts :: { [HsAlt] }
      : alts ';' alt                          { $3 : $1 }
      | alt                                   { [$1] }

alt :: { HsAlt }
      : pinfixexp srcloc ralt optwhere {% checkPattern $1 `thenP` \p ->
                                 returnP (HsAlt $2 p $3 $4) }

ralt :: { HsRhs }
      : '->' exp                              { HsUnGuardedRhs $2 }
      | gdpats                                { HsGuardedRhss (reverse $1) }

gdpats :: { [HsGuardedRhs] }
      : gdpats gdpat                          { $2 : $1 }
      | gdpat                                 { [$1] }

gdpat :: { HsGuardedRhs }
      : '|' exp srcloc '->' exp               { HsGuardedRhs $3 $2 $5 }

-- -----------------------------------------------------------------------------
-- Statement sequences

stmtlist :: { [HsStmt] }
        : '{' stmts '}'               { $2 }
        |     layout_on  stmts close  { $2 }

stmts :: { [HsStmt] }
      : stmt stmts1                   { $1:$2 }
      | ';' stmts                     { $2 }
      | {- empty -}                   { [] }

stmts1 :: { [HsStmt] }
      : ';' stmts                     { $2 }
      |                               { [] }

stmt :: { HsStmt }
    : qual            { $1 }

-- -----------------------------------------------------------------------------
-- Record Field Update/Construction

fbinds :: { [HsFieldUpdate] }
      : fbinds ',' fbind              { $3 : $1 }
      | fbind                         { [$1] }

fbind :: { HsFieldUpdate }
      : qvar '=' exp                  { HsFieldUpdate $1 $3 }

pfbinds :: { [HsFieldUpdate] }
      : pfbinds ',' pfbind              { $3 : $1 }
      | pfbind                         { [$1] }

pfbind :: { HsFieldUpdate }
      : qvar '=' pexp                  { HsFieldUpdate $1 $3 }

-- -----------------------------------------------------------------------------
-- Variables, Constructors and Operators.

gcon :: { HsExp }
      : '(' ')'               { unit_con }
      | '[' ']'               { HsList [] }
      | '(' commas ')'        { tuple_con $2 }
      | qcon                  { HsCon $1 }

var   :: { HsName }
      : varid                 { $1 }
      | '(' varsym ')'        { $2 }

qvar  :: { HsName }
      : qvarid                { $1 }
      | '(' qvarsym ')'       { $2 }

con   :: { HsName }
      : conid                 { $1 }
      | '(' consym ')'        { $2 }

qcon  :: { HsName }
      : qconid                { $1 }
      | '(' qconsym ')'       { $2 }

varop :: { HsName }
      : varsym                { $1 }
      | '`' varid '`'         { $2 }

qvarop :: { HsName }
      : qvarsym               { $1 }
      | '`' qvarid '`'        { $2 }

qvaropm :: { HsName }
      : qvarsymm              { $1 }
      | '`' qvarid '`'        { $2 }

conop :: { HsName }
      : consym                { $1 }
      | '`' conid '`'         { $2 }

qconop :: { HsName }
      : qconsym               { $1 }
      | '`' qconid '`'        { $2 }

op    :: { HsName }
      : varop                 { $1 }
      | conop                 { $1 }

qop   :: { HsExp }
      : qvarop                { HsVar $1 }
      | qconop                { HsCon $1 }

qopm  :: { HsExp }
      : qvaropm               { HsVar $1 }
      | qconop                { HsCon $1 }

qvarid :: { HsName }
      : varid                 { $1 }
      | QVARID                { $1 }

varid :: { HsName }
      : VARID                 { $1 }
      | 'as'                  { as_name }
      | 'alias'               { toName UnknownType "alias" }
      | 'kind'                { toName UnknownType "kind" }
      | 'closed'              { toName UnknownType "closed" }
      | 'family'              { toName UnknownType "family" }
      | 'qualified'           { qualified_name }
      | 'hiding'              { hiding_name }
      | 'forall'              { toName UnknownType "forall" }
      | 'exists'              { toName UnknownType "exists" }

qconid :: { HsName }
      : conid                 { $1 }
      | QCONID                { $1 }

conid :: { HsName }
      : CONID                 { $1 }

qconsym :: { HsName }
      : consym                { $1 }
      | QCONSYM               { $1 }

consym :: { HsName }
      : CONSYM                { $1 }

qvarsym :: { HsName }
      : varsym                { $1 }
      | qvarsym1              { $1 }

qvarsymm :: { HsName }
      : varsymm               { $1 }
      | qvarsym1              { $1 }

varsym :: { HsName }
      : VARSYM                { $1 }
      | '-'                   { minus_name }
      | '!'                   { pling_name }
      | 'bang!'               { pling_name }
      | '?'                   { toName UnknownType "?" }
      | '??'                  { toName UnknownType "??" }
      | '*!'                  { toName UnknownType "*!" }
      | '*'                   { star_name }
      | '#'                   { hash_name }
      | '.'                   { dot_name }

varsymm :: { HsName } -- varsym not including '-'
      : VARSYM                { $1 }
      | '!'                   { pling_name }
      | 'bang!'               { pling_name }
      | '*'                   { star_name }
      | '#'                   { hash_name }
      | '.'                   { dot_name }

qvarsym1 :: { HsName }
      : QVARSYM               { $1 }

literal :: { HsExp }
      : INT                   { HsLit (HsInt (readInteger $1)) }
      | UINT                  { HsLit (HsIntPrim (readInteger $1)) }
      | CHAR                  { HsLit (HsChar $1) }
      | UCHAR                 { HsLit (HsCharPrim $1) }
      | RATIONAL              { HsLit (HsFrac (readRational $1)) }
      | STRING                { HsLit (HsString $1) }
      | USTRING               { HsLit (HsStringPrim $1) }

 srcloc :: { SrcLoc } :       {% getSrcLoc }

-- -----------------------------------------------------------------------------
-- Layout

close :: { () }
      : vccurly               { () } -- context popped in lexer.
      | error                 {% popContext }

layout_on  :: { () }  :   {% getSrcLoc `thenP` \sl ->
                                 pushCurrentContext  }

--                                 pushCurrentContext (Layout (srcLocColumn sl)) }

-- -----------------------------------------------------------------------------
-- Miscellaneous (mostly renamings)

modid :: { Module }
      : CONID                 { toModule $ show $1 }
      | QCONID                { toModule $ show $1 } -- (fst $1 ++ "." ++ snd $1) }

tyconorcls :: { HsName }
      : conid                 { $1 }

tycon :: { HsName }
      : conid                 { $1 }

qtyconorcls :: { HsName }
      : qconid                { $1 }

qtycls :: { HsName }
      : qconid                { $1 }

tyvar :: { HsName }
      : varid                 { $1 }

-- -----------------------------------------------------------------------------

{

{-# NOINLINE parse #-}
{-# NOINLINE parseHsStmt #-}
parse       :: P HsModule
parseHsStmt :: P HsStmt

happyError = parseError "Parse error"
--hsSymbol x = HsIdent x
readInteger x = fromIntegral x
readRational x = x

as_name	              = toName UnknownType  "as"
derive_name	      = toName UnknownType  "derive"
qualified_name        = toName UnknownType  "qualified"
hiding_name	      = toName UnknownType  "hiding"
minus_name	      = toName UnknownType  "-"
pling_name	      = toName UnknownType  "!"
star_name	      = toName UnknownType  "*"
hash_name	      = toName UnknownType  "#"
dot_name	      = toName UnknownType  "."
prelude_mod	      = toModule "Prelude"
main_mod	      = toModule "Main"

tuple_con_name i      = toName DataConstructor (toModule "Jhc.Prim.Prim","("++replicate i ','++")")

unit_con	      = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = dc_Unit }
tuple_con i	      = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = (tuple_con_name i) }

unit_tycon_name       = tc_Unit
fun_tycon_name        = tc_Arrow
list_tycon_name       = toName UnknownType "[]"
tuple_tycon_name i    = tuple_con_name i

list_tycon	      = HsTyCon list_tycon_name

toUnqualName n = toName UnknownType (Nothing :: Maybe Module,n)
}
