{
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Futhark parser written with Happy.
module Language.Futhark.Parser.Parser
  ( prog
  , expression
  , futharkType
  , anyValue
  , anyValues

  , ParserMonad
  , parse
  , ParseError(..)
  , parseDecOrExpIncrM
  )
  where

import Control.Monad
import Control.Monad.Trans
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.State
import Control.Arrow
import Data.Array
import qualified Data.Text as T
import Data.Char (ord)
import Data.Maybe (fromMaybe, fromJust)
import Data.Loc hiding (L) -- Lexer has replacements.
import qualified Data.Map.Strict as M
import Data.Monoid

import Language.Futhark.Syntax hiding (ID)
import Language.Futhark.Attributes
import Language.Futhark.Pretty
import Language.Futhark.Parser.Lexer

}

%name prog Prog
%name futharkType TypeExp
%name expression Exp
%name declaration Dec
%name anyValue Value
%name anyValues CatValues

%tokentype { L Token }
%error { parseError }
%monad { ParserMonad }
%lexer { lexer } { L _ EOF }

%token
      if              { L $$ IF }
      then            { L $$ THEN }
      else            { L $$ ELSE }
      let             { L $$ LET }
      loop            { L $$ LOOP }
      in              { L $$ IN }
      match           { L $$ MATCH }
      case            { L $$ CASE }

      id              { L _ (ID _) }
      'id['           { L _ (INDEXING _) }

      'qid['          { L _ (QUALINDEXING _ _) }

      'qid.('         { L _ (QUALPAREN _ _) }

      unop            { L _ (UNOP _) }
      qunop           { L _ (QUALUNOP _ _) }

      constructor     { L _ (CONSTRUCTOR _) }

      '.field'        { L _ (PROJ_FIELD _) }
      '.['            { L _ PROJ_INDEX }

      intlit          { L _ (INTLIT _) }
      i8lit           { L _ (I8LIT _) }
      i16lit          { L _ (I16LIT _) }
      i32lit          { L _ (I32LIT _) }
      i64lit          { L _ (I64LIT _) }
      u8lit           { L _ (U8LIT _) }
      u16lit          { L _ (U16LIT _) }
      u32lit          { L _ (U32LIT _) }
      u64lit          { L _ (U64LIT _) }
      floatlit        { L _ (FLOATLIT _) }
      f32lit          { L _ (F32LIT _) }
      f64lit          { L _ (F64LIT _) }
      stringlit       { L _ (STRINGLIT _) }
      charlit         { L _ (CHARLIT _) }

      '..'            { L $$ TWO_DOTS }
      '...'           { L $$ THREE_DOTS }
      '..<'           { L $$ TWO_DOTS_LT }
      '..>'           { L $$ TWO_DOTS_GT }
      '='             { L $$ EQU }

      '*'             { L $$ ASTERISK }
      '-'             { L $$ NEGATE }
      '<'             { L $$ LTH }
      '^'             { L $$ HAT }
      '|'             { L $$ PIPE  }

      '+...'          { L _ (SYMBOL Plus _ _) }
      '-...'          { L _ (SYMBOL Minus _ _) }
      '*...'          { L _ (SYMBOL Times _ _) }
      '/...'          { L _ (SYMBOL Divide _ _) }
      '%...'          { L _ (SYMBOL Mod _ _) }
      '//...'         { L _ (SYMBOL Quot _ _) }
      '%%...'         { L _ (SYMBOL Rem _ _) }
      '==...'         { L _ (SYMBOL Equal _ _) }
      '!=...'         { L _ (SYMBOL NotEqual _ _) }
      '<...'          { L _ (SYMBOL Less _ _) }
      '>...'          { L _ (SYMBOL Greater _ _) }
      '<=...'         { L _ (SYMBOL Leq _ _) }
      '>=...'         { L _ (SYMBOL Geq _ _) }
      '**...'         { L _ (SYMBOL Pow _ _) }
      '<<...'         { L _ (SYMBOL ShiftL _ _) }
      '>>...'         { L _ (SYMBOL ShiftR _ _) }
      '|>...'         { L _ (SYMBOL PipeRight _ _) }
      '<|...'         { L _ (SYMBOL PipeLeft _ _) }
      '|...'          { L _ (SYMBOL Bor _ _) }
      '&...'          { L _ (SYMBOL Band _ _) }
      '^...'          { L _ (SYMBOL Xor _ _) }
      '||...'         { L _ (SYMBOL LogOr _ _) }
      '&&...'         { L _ (SYMBOL LogAnd _ _) }

      '('             { L $$ LPAR }
      ')'             { L $$ RPAR }
      ')['            { L $$ RPAR_THEN_LBRACKET }
      '{'             { L $$ LCURLY }
      '}'             { L $$ RCURLY }
      '['             { L $$ LBRACKET }
      ']'             { L $$ RBRACKET }
      ','             { L $$ COMMA }
      '_'             { L $$ UNDERSCORE }
      '\\'            { L $$ BACKSLASH }
      '\''            { L $$ APOSTROPHE }
      '\'^'           { L $$ APOSTROPHE_THEN_HAT }
      '`'             { L $$ BACKTICK }
      entry           { L $$ ENTRY }
      '->'            { L $$ RIGHT_ARROW }
      ':'             { L $$ COLON }
      for             { L $$ FOR }
      do              { L $$ DO }
      with            { L $$ WITH }
      unsafe          { L $$ UNSAFE }
      assert          { L $$ ASSERT }
      true            { L $$ TRUE }
      false           { L $$ FALSE }
      while           { L $$ WHILE }
      include         { L $$ INCLUDE }
      import          { L $$ IMPORT }
      type            { L $$ TYPE }
      module          { L $$ MODULE }
      val             { L $$ VAL }
      open            { L $$ OPEN }
      local           { L $$ LOCAL }
      doc             { L _  (DOC _) }

%left bottom
%left ifprec letprec unsafe caseprec typeprec enumprec
%left ',' case
%left ':'
%right '...' '..<' '..>' '..'
%left '`'
%right '->'
%left with
%left '='
%left '|>...'
%right '<|...'
%left '||...'
%left '&&...'
%left '<=...' '>=...' '>...' '<' '<...' '==...' '!=...'
%left '&...' '^...' '^' '|...' '|'
%left '<<...' '>>...'
%left '+...' '-...' '-'
%left '*...' '*' '/...' '%...' '//...' '%%...'
%left '**...'
%left juxtprec
%left indexprec
%%

-- The main parser.

Doc :: { DocComment }
     : doc { let L loc (DOC s) = $1 in DocComment s loc }

-- Four cases to avoid ambiguities.
Prog :: { UncheckedProg }
      -- File begins with a file comment, followed by a Dec with a comment.
      : Doc Doc Dec_ Decs { Prog (Just $1) (addDoc $2 $3 : $4) }
      -- File begins with a file comment, followed by a Dec with no comment.
      | Doc Dec_ Decs     { Prog (Just $1) ($2 : $3) }
      -- File begins with a dec with no comment.
      | Dec_ Decs         { Prog Nothing ($1 : $2) }
      -- File is empty.
      |                   { Prog Nothing [] }
;

Dec :: { UncheckedDec }
    : Dec_              { $1 }
    | Doc Dec_          { addDoc $1 $2 }

Decs :: { [UncheckedDec] }
      :          { [] }
      | Dec Decs { $1 : $2 }

Dec_ :: { UncheckedDec }
    : Val               { ValDec $1 }
    | TypeAbbr          { TypeDec $1 }
    | SigBind           { SigDec $1 }
    | ModBind           { ModDec $1 }
    | open ModExp       { OpenDec $2 $1 }
    | import stringlit
      { let L _ (STRINGLIT s) = $2 in ImportDec s NoInfo (srcspan $1 $>) }
    | local Dec         { LocalDec $2 (srcspan $1 $>) }
;

SigExp :: { UncheckedSigExp }
        : QualName            { let (v, loc) = $1 in SigVar v loc }
        | '{' Specs '}'  { SigSpecs $2 (srcspan $1 $>) }
        | SigExp with TypeRef { SigWith $1 $3 (srcspan $1 $>) }
        | '(' SigExp ')'      { SigParens $2 (srcspan $1 $>) }
        | '(' id ':' SigExp ')' '->' SigExp
                              { let L _ (ID name) = $2
                                in SigArrow (Just name) $4 $7 (srcspan $1 $>) }
        | SigExp '->' SigExp  { SigArrow Nothing $1 $3 (srcspan $1 $>) }

TypeRef :: { TypeRefBase NoInfo Name }
         : QualName TypeParams '=' TypeExpTerm
           { TypeRef (fst $1) $2 (TypeDecl $4 NoInfo) (srcspan (snd $1) $>) }

SigBind :: { SigBindBase NoInfo Name }
         : module type id '=' SigExp
          { let L _ (ID name) = $3
            in SigBind name $5 Nothing (srcspan $1 $>) }

ModExp :: { UncheckedModExp }
        : ModExp ':' SigExp
          { ModAscript $1 $3 NoInfo (srcspan $1 $>) }
        | '\\' ModParam maybeAscription(SimpleSigExp) '->' ModExp
          { ModLambda $2 (fmap (,NoInfo) $3) $5 (srcspan $1 $>) }
        | import stringlit
          { let L _ (STRINGLIT s) = $2 in ModImport s NoInfo (srcspan $1 $>) }
        | ModExpApply
          { $1 }
        | ModExpAtom
          { $1 }


ModExpApply :: { UncheckedModExp }
             : ModExpAtom ModExpAtom %prec juxtprec
               { ModApply $1 $2 NoInfo NoInfo (srcspan $1 $>) }
             | ModExpApply ModExpAtom %prec juxtprec
               { ModApply $1 $2 NoInfo NoInfo (srcspan $1 $>) }

ModExpAtom :: { UncheckedModExp }
            : '(' ModExp ')'
              { ModParens $2 (srcspan $1 $>) }
            | QualName
              { let (v, loc) = $1 in ModVar v loc }
            | '{' Decs '}' { ModDecs $2 (srcspan $1 $>) }

SimpleSigExp :: { UncheckedSigExp }
             : QualName            { let (v, loc) = $1 in SigVar v loc }
             | '(' SigExp ')'      { $2 }

ModBind :: { ModBindBase NoInfo Name }
         : module id ModParams maybeAscription(SigExp) '=' ModExp
           { let L floc (ID fname) = $2;
             in ModBind fname $3 (fmap (,NoInfo) $4) $6 Nothing (srcspan $1 $>)
           }

ModParam :: { ModParamBase NoInfo Name }
          : '(' id ':' SigExp ')' { let L _ (ID name) = $2 in ModParam name $4 NoInfo (srcspan $1 $>) }

ModParams :: { [ModParamBase NoInfo Name] }
           : ModParam ModParams { $1 : $2 }
           |                    { [] }

Spec :: { SpecBase NoInfo Name }
      : val id TypeParams ':' TypeExpDecl
        { let L loc (ID name) = $2
          in ValSpec name $3 $5 Nothing (srcspan $1 $>) }
      | val BindingBinOp TypeParams ':' TypeExpDecl
        { ValSpec $2 $3 $5 Nothing (srcspan $1 $>) }
      | val BindingUnOp TypeParams ':' TypeExpDecl
        { ValSpec $2 $3 $5 Nothing (srcspan $1 $>) }
      | TypeAbbr
        { TypeAbbrSpec $1 }
      | type id TypeParams
        { let L _ (ID name) = $2
          in TypeSpec Unlifted name $3 Nothing (srcspan $1 $>) }
      | type 'id[' id ']' TypeParams
        { let L _ (INDEXING name) = $2; L ploc (ID pname) = $3
          in TypeSpec Unlifted name (TypeParamDim pname ploc : $5) Nothing (srcspan $1 $>) }
      | type '^' id TypeParams
        { let L _ (ID name) = $3
          in TypeSpec Lifted name $4 Nothing (srcspan $1 $>) }
      | type '^' 'id[' id ']' TypeParams
        { let L _ (INDEXING name) = $3; L ploc (ID pname) = $4
          in TypeSpec Lifted name (TypeParamDim pname ploc : $6) Nothing (srcspan $1 $>) }
      | module id ':' SigExp
        { let L _ (ID name) = $2
          in ModSpec name $4 Nothing (srcspan $1 $>) }
      | include SigExp
        { IncludeSpec $2 (srcspan $1 $>) }
      | Doc Spec
        { addDocSpec $1 $2 }

Specs :: { [SpecBase NoInfo Name] }
       : Spec Specs { $1 : $2 }
       |            { [] }

TypeParam :: { TypeParamBase Name }
           : '[' id ']' { let L _ (ID name) = $2 in TypeParamDim name (srcspan $1 $>) }
           | '\'' id { let L _ (ID name) = $2 in TypeParamType Unlifted name (srcspan $1 $>) }
           | '\'^' id { let L _ (ID name) = $2 in TypeParamType Lifted name (srcspan $1 $>) }

TypeParams :: { [TypeParamBase Name] }
            : TypeParam TypeParams { $1 : $2 }
            |                      { [] }

TypeParams1 :: { (TypeParamBase Name, [TypeParamBase Name]) }
            : TypeParam TypeParams { ($1, $2) }

UnOp :: { (QualName Name, SrcLoc) }
      : qunop { let L loc (QUALUNOP qs v) = $1 in (QualName qs v, loc) }
      | unop  { let L loc (UNOP v) = $1 in (qualName v, loc) }

-- Note that this production does not include Minus, but does include
-- operator sections.
BinOp :: { QualName Name }
      : '+...'     { binOpName $1 }
      | '-...'     { binOpName $1 }
      | '*...'     { binOpName $1 }
      | '*'        { qualName (nameFromString "*") }
      | '/...'     { binOpName $1 }
      | '%...'     { binOpName $1 }
      | '//...'    { binOpName $1 }
      | '%%...'    { binOpName $1 }
      | '==...'    { binOpName $1 }
      | '!=...'    { binOpName $1 }
      | '<...'     { binOpName $1 }
      | '<=...'    { binOpName $1 }
      | '>...'     { binOpName $1 }
      | '>=...'    { binOpName $1 }
      | '&&...'    { binOpName $1 }
      | '||...'    { binOpName $1 }
      | '**...'    { binOpName $1 }
      | '^...'     { binOpName $1 }
      | '^'        { qualName (nameFromString "^") }
      | '&...'     { binOpName $1 }
      | '|...'     { binOpName $1 }
      | '|'        { qualName (nameFromString "|") }
      | '>>...'    { binOpName $1 }
      | '<<...'    { binOpName $1 }
      | '<|...'    { binOpName $1 }
      | '|>...'    { binOpName $1 }
      | '<'        { qualName (nameFromString "<") }
      | '`' QualName '`' { fst $2 }

BindingUnOp :: { Name }
      : UnOp {% let (QualName qs name, _) = $1 in do
                   unless (null qs) $ fail "Cannot use a qualified name in binding position."
                   return name }

BindingBinOp :: { Name }
      : BinOp {% let QualName qs name = $1 in do
                   unless (null qs) $ fail "Cannot use a qualified name in binding position."
                   return name }
      | '-'   { nameFromString "-" }

BindingId :: { (Name, SrcLoc) }
     : id                   { let L loc (ID name) = $1 in (name, loc) }
     | '(' BindingBinOp ')' { ($2, $1) }
     | '(' BindingUnOp ')'  { ($2, $1) }

Val    :: { ValBindBase NoInfo Name }
Val     : let BindingId TypeParams FunParams maybeAscription(TypeExpDecl) '=' Exp
          { let (name, _) = $2
            in ValBind (name==defaultEntryPoint) name (fmap declaredType $5) NoInfo
               $3 $4 $7 Nothing (srcspan $1 $>)
          }

        | entry BindingId TypeParams FunParams maybeAscription(TypeExpDecl) '=' Exp
          { let (name, loc) = $2
            in ValBind True name (fmap declaredType $5) NoInfo
               $3 $4 $7 Nothing (srcspan $1 $>) }

        | let FunParam BindingBinOp FunParam maybeAscription(TypeExpDecl) '=' Exp
          { ValBind False $3 (fmap declaredType $5) NoInfo [] [$2,$4] $7 Nothing (srcspan $1 $>)
          }

        | let BindingUnOp TypeParams FunParams maybeAscription(TypeExpDecl) '=' Exp
          { let name = $2
            in ValBind (name==defaultEntryPoint) name (fmap declaredType $5) NoInfo
               $3 $4 $7 Nothing (srcspan $1 $>)
          }

TypeExpDecl :: { TypeDeclBase NoInfo Name }
             : TypeExp %prec bottom { TypeDecl $1 NoInfo }

TypeAbbr :: { TypeBindBase NoInfo Name }
TypeAbbr : type id TypeParams '=' TypeExpDecl
           { let L _ (ID name) = $2
              in TypeBind name $3 $5 Nothing (srcspan $1 $>) }
         | type 'id[' id ']' TypeParams '=' TypeExpDecl
           { let L loc (INDEXING name) = $2; L ploc (ID pname) = $3
             in TypeBind name (TypeParamDim pname ploc:$5) $7 Nothing (srcspan $1 $>) }

TypeExp :: { UncheckedTypeExp }
         : '(' id ':' TypeExp ')' '->' TypeExp
           { let L _ (ID v) = $2 in TEArrow (Just v) $4 $7 (srcspan $1 $>) }
         | TypeExpTerm '->' TypeExp
           { TEArrow Nothing $1 $3 (srcspan $1 $>) }
         | TypeExpTerm %prec typeprec { $1 }

TypeExpTerm :: { UncheckedTypeExp }
         : '*' TypeExpTerm
           { TEUnique $2 (srcspan $1 $>) }
         | '[' DimDecl ']' TypeExpTerm %prec indexprec
           { TEArray $4 (fst $2) (srcspan $1 $>) }
         | '['  ']' TypeExpTerm %prec indexprec
           { TEArray $3 AnyDim (srcspan $1 $>) }
         | TypeExpApply { $1 }

         -- Errors
         | '[' DimDecl ']' %prec bottom
           {% parseErrorAt (srcspan $1 $>) $ Just $
                unlines ["missing array row type.",
                         "Did you mean []"  ++ pretty (fst $2) ++ "?"]
           }

TypeExpApply :: { UncheckedTypeExp }
              : TypeExpApply TypeArg
                { TEApply $1 $2 (srcspan $1 $>) }
              | 'id[' DimDecl ']'
                { let L loc (INDEXING v) = $1
                  in TEApply (TEVar (qualName v) loc) (TypeArgExpDim (fst $2) loc) (srcspan $1 $>) }
              | 'qid[' DimDecl ']'
                { let L loc (QUALINDEXING qs v) = $1
                  in TEApply (TEVar (QualName qs v) loc) (TypeArgExpDim (fst $2) loc) (srcspan $1 $>) }
              | TypeExpAtom
                { $1 }

TypeExpAtom :: { UncheckedTypeExp }
             : '(' TypeExp ')'                { $2 }
             | '(' ')'                        { TETuple [] (srcspan $1 $>) }
             | '(' TypeExp ',' TupleTypes ')' { TETuple ($2:$4) (srcspan $1 $>) }
             | '{' '}'                        { TERecord [] (srcspan $1 $>) }
             | '{' FieldTypes1 '}'            { TERecord $2 (srcspan $1 $>) }
             | QualName                       { TEVar (fst $1) (snd $1) }
             | Enum                           { TEEnum (fst $1)  (snd $1)}

Enum :: { ([Name], SrcLoc) }
      : VConstr0 %prec enumprec { ([fst $1], snd $1) }
      | VConstr0 '|' Enum
        { let names = fst $1 : fst $3; loc = srcspan (snd $1) (snd $3)
          in (names, loc) }

VConstr0 :: { (Name, SrcLoc) }
          : constructor { let L _ (CONSTRUCTOR c) = $1 in (c, srclocOf $1) }

TypeArg :: { TypeArgExp Name }
         : '[' DimDecl ']' { TypeArgExpDim (fst $2) (srcspan $1 $>) }
         | '[' ']'         { TypeArgExpDim AnyDim (srcspan $1 $>) }
         | TypeExpAtom     { TypeArgExpType $1 }

FieldType :: { (Name, UncheckedTypeExp) }
FieldType : FieldId ':' TypeExp { (fst $1, $3) }

FieldTypes1 :: { [(Name, UncheckedTypeExp)] }
FieldTypes1 : FieldType                 { [$1] }
            | FieldType ',' FieldTypes1 { $1 : $3 }

TupleTypes :: { [UncheckedTypeExp] }
            : TypeExp                { [$1] }
            | TypeExp ',' TupleTypes { $1 : $3 }

DimDecl :: { (DimDecl Name, SrcLoc) }
        : QualName
          { (NamedDim (fst $1), snd $1) }
        | intlit
          { let L loc (INTLIT n) = $1
            in (ConstDim (fromIntegral n), loc) }

FunParam :: { PatternBase NoInfo Name }
FunParam : InnerPattern { $1 }

FunParams1 :: { (PatternBase NoInfo Name, [PatternBase NoInfo Name]) }
FunParams1 : FunParam            { ($1, []) }
           | FunParam FunParams1 { ($1, fst $2 : snd $2) }

FunParams :: { [PatternBase NoInfo Name] }
FunParams :                     { [] }
           | FunParam FunParams { $1 : $2 }

QualName :: { (QualName Name, SrcLoc) }
          : id FieldAccesses
            { let L vloc (ID v) = $1 in
              foldl (\(QualName qs v', loc) (y, yloc) ->
                      (QualName (qs ++ [v']) y, srcspan loc yloc))
                    (qualName v, vloc) $2 }

-- Expressions are divided into several layers.  The first distinction
-- (between Exp and Exp2) is to factor out ascription, which we do not
-- permit inside array indices operations (there is an ambiguity with
-- array slices).
Exp :: { UncheckedExp }
     : Exp ':' TypeExpDecl { Ascript $1 $3 (srcspan $1 $>) }
     | Exp2 %prec ':'      { $1 }

Exp2 :: { UncheckedExp }
     : if Exp then Exp else Exp %prec ifprec
                      { If $2 $4 $6 NoInfo (srcspan $1 $>) }

     | loop TypeParams Pattern LoopForm do Exp %prec ifprec
         {% fmap (\t -> DoLoop $2 $3 t $4 $6 (srcspan $1 $>)) (patternExp $3) }

     | loop TypeParams Pattern '=' Exp LoopForm do Exp %prec ifprec
         { DoLoop $2 $3 $5 $6 $8 (srcspan $1 $>) }

     | LetExp %prec letprec { $1 }

     | MatchExp { $1 }

     | unsafe Exp2     { Unsafe $2 (srcspan $1 $>) }
     | assert Atom Atom    { Assert $2 $3 NoInfo (srcspan $1 $>) }

     | Exp2 '+...' Exp2    { binOp $1 $2 $3 }
     | Exp2 '-...' Exp2    { binOp $1 $2 $3 }
     | Exp2 '-' Exp2       { binOp $1 (L $2 (SYMBOL Minus [] (nameFromString "-"))) $3 }
     | Exp2 '*...' Exp2    { binOp $1 $2 $3 }
     | Exp2 '*' Exp2       { binOp $1 (L $2 (SYMBOL Times [] (nameFromString "*"))) $3 }
     | Exp2 '/...' Exp2    { binOp $1 $2 $3 }
     | Exp2 '%...' Exp2    { binOp $1 $2 $3 }
     | Exp2 '//...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '%%...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '**...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '>>...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '<<...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '&...' Exp2    { binOp $1 $2 $3 }
     | Exp2 '|...' Exp2    { binOp $1 $2 $3 }
     | Exp2 '|' Exp2       { binOp $1 (L $2 (SYMBOL Bor [] (nameFromString "|"))) $3 }
     | Exp2 '&&...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '||...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '^...' Exp2    { binOp $1 $2 $3 }
     | Exp2 '^' Exp2       { binOp $1 (L $2 (SYMBOL Xor [] (nameFromString "^"))) $3 }
     | Exp2 '==...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '!=...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '<...' Exp2    { binOp $1 $2 $3 }
     | Exp2 '<=...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '>...' Exp2    { binOp $1 $2 $3 }
     | Exp2 '>=...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '|>...' Exp2   { binOp $1 $2 $3 }
     | Exp2 '<|...' Exp2   { binOp $1 $2 $3 }

     | Exp2 '<' Exp2              { binOp $1 (L $2 (SYMBOL Less [] (nameFromString "<"))) $3 }
     | Exp2 '`' QualName '`' Exp2 { BinOp (fst $3) NoInfo ($1, NoInfo) ($5, NoInfo) NoInfo (srclocOf $1) }

     | Exp2 '...' Exp2           { Range $1 Nothing (ToInclusive $3) NoInfo (srcspan $1 $>) }
     | Exp2 '..<' Exp2           { Range $1 Nothing (UpToExclusive $3) NoInfo (srcspan $1 $>) }
     | Exp2 '..>' Exp2           { Range $1 Nothing (DownToExclusive $3) NoInfo (srcspan $1 $>) }
     | Exp2 '..' Exp2 '...' Exp2 { Range $1 (Just $3) (ToInclusive $5) NoInfo (srcspan $1 $>) }
     | Exp2 '..' Exp2 '..<' Exp2 { Range $1 (Just $3) (UpToExclusive $5) NoInfo (srcspan $1 $>) }
     | Exp2 '..' Exp2 '..>' Exp2 { Range $1 (Just $3) (DownToExclusive $5) NoInfo (srcspan $1 $>) }
     | Exp2 '..' Atom            {% twoDotsRange $2 }
     | Atom '..' Exp2            {% twoDotsRange $2 }
     | '-' Exp2
       { Negate $2 $1 }

     | Exp2 with '[' DimIndices ']' '=' Exp2
       { Update $1 $4 $7 (srcspan $1 $>) }

     | Exp2 with FieldAccesses_ '=' Exp2
       { RecordUpdate $1 (map fst $3) $5 NoInfo (srcspan $1 $>) }

     | '\\' TypeParams FunParams1 maybeAscription(TypeExpTerm) '->' Exp
       { Lambda $2 (fst $3 : snd $3) $6 (fmap (flip TypeDecl NoInfo) $4) NoInfo (srcspan $1 $>) }

     | Apply { $1 }

Apply :: { UncheckedExp }
      : Apply Atom %prec juxtprec
        { Apply $1 $2 NoInfo NoInfo (srcspan $1 $>) }
      | UnOp Atom %prec juxtprec
        { Apply (Var (fst $1) NoInfo (snd $1)) $2 NoInfo NoInfo (srcspan (snd $1) $>) }
      | Atom %prec juxtprec
        { $1 }

Atom :: { UncheckedExp }
Atom : PrimLit        { Literal (fst $1) (snd $1) }
     | VConstr0       { VConstr0 (fst $1) NoInfo (snd $1) }
     | intlit         { let L loc (INTLIT x) = $1 in IntLit x NoInfo loc }
     | floatlit       { let L loc (FLOATLIT x) = $1 in FloatLit x NoInfo loc }
     | stringlit      { let L loc (STRINGLIT s) = $1 in
                        ArrayLit (map (flip Literal loc . SignedValue . Int32Value . fromIntegral . ord) s) NoInfo loc }
     | '(' Exp ')' FieldAccesses
       { foldl (\x (y, _) -> Project y x NoInfo (srclocOf x))
               (Parens $2 (srcspan $1 $3))
               $4 }
     | '(' Exp ')[' DimIndices ']'    { Index (Parens $2 $1) $4 NoInfo (srcspan $1 $>) }
     | '(' Exp ',' Exps1 ')'          { TupLit ($2 : fst $4 : snd $4) (srcspan $1 $>) }
     | '('      ')'                   { TupLit [] (srcspan $1 $>) }
     | '[' Exps1 ']'                  { ArrayLit (fst $2:snd $2) NoInfo (srcspan $1 $>) }
     | '['       ']'                  { ArrayLit [] NoInfo (srcspan $1 $>) }

     | QualVarSlice FieldAccesses
       { let (v,slice,loc) = $1
         in foldl (\x (y, _) -> Project y x NoInfo (srclocOf x))
                  (Index (Var v NoInfo loc) slice NoInfo loc)
                  $2 }
     | QualName
       { Var (fst $1) NoInfo (snd $1) }
     | '{' Fields '}' { RecordLit $2 (srcspan $1 $>) }
     | 'qid.(' Exp ')'
       { let L loc (QUALPAREN qs name) = $1 in QualParens (QualName qs name) $2 loc }

     -- Operator sections.
     | '(' UnOp ')'
        { Var (fst $2) NoInfo (srcspan (snd $2) $>) }
     | '(' '-' ')'
        { OpSection (qualName (nameFromString "-")) NoInfo (srcspan $1 $>) }
     | '(' Exp2 '-' ')'
        { OpSectionLeft (qualName (nameFromString "-"))
           NoInfo $2 (NoInfo, NoInfo) NoInfo (srcspan $1 $>) }
     | '(' BinOp Exp2 ')'
       { OpSectionRight $2 NoInfo $3 (NoInfo, NoInfo) NoInfo (srcspan $1 $>) }
     | '(' Exp2 BinOp ')'
       { OpSectionLeft $3 NoInfo $2 (NoInfo, NoInfo) NoInfo (srcspan $1 $>) }
     | '(' BinOp ')'
       { OpSection $2 NoInfo (srcspan $1 $>) }

     | '(' FieldAccess FieldAccesses ')'
       { ProjectSection (map fst ($2:$3)) NoInfo (srcspan $1 $>) }

     | '(' '.[' DimIndices ']' ')'
       { IndexSection $3 NoInfo (srcspan $1 $>) }


PrimLit :: { (PrimValue, SrcLoc) }
        : true   { (BoolValue True, $1) }
        | false  { (BoolValue False, $1) }

        | i8lit   { let L loc (I8LIT num)  = $1 in (SignedValue $ Int8Value num, loc) }
        | i16lit  { let L loc (I16LIT num) = $1 in (SignedValue $ Int16Value num, loc) }
        | i32lit  { let L loc (I32LIT num) = $1 in (SignedValue $ Int32Value num, loc) }
        | i64lit  { let L loc (I64LIT num) = $1 in (SignedValue $ Int64Value num, loc) }

        | u8lit  { let L loc (U8LIT num)  = $1 in (UnsignedValue $ Int8Value $ fromIntegral num, loc) }
        | u16lit { let L loc (U16LIT num) = $1 in (UnsignedValue $ Int16Value $ fromIntegral num, loc) }
        | u32lit { let L loc (U32LIT num) = $1 in (UnsignedValue $ Int32Value $ fromIntegral num, loc) }
        | u64lit { let L loc (U64LIT num) = $1 in (UnsignedValue $ Int64Value $ fromIntegral num, loc) }

        | f32lit { let L loc (F32LIT num) = $1 in (FloatValue $ Float32Value num, loc) }
        | f64lit { let L loc (F64LIT num) = $1 in (FloatValue $ Float64Value num, loc) }

        | charlit { let L loc (CHARLIT char) = $1
                    in (SignedValue $ Int32Value $ fromIntegral $ ord char, loc) }

Exps1 :: { (UncheckedExp, [UncheckedExp]) }
       : Exps1_ { case reverse (snd $1 : fst $1) of
                    []   -> (snd $1, [])
                    y:ys -> (y, ys) }

Exps1_ :: { ([UncheckedExp], UncheckedExp) }
        : Exps1_ ',' Exp { (snd $1 : fst $1, $3) }
        | Exp            { ([], $1) }

FieldAccess :: { (Name, SrcLoc) }
             : '.field' { let L loc (PROJ_FIELD f) = $1 in (f, loc) }

FieldAccesses :: { [(Name, SrcLoc)] }
               : FieldAccess FieldAccesses { $1 : $2 }
               |                           { [] }

FieldAccesses_ :: { [(Name, SrcLoc)] }
               : FieldId FieldAccesses { (fst $1, snd $1) : $2 }

Field :: { FieldBase NoInfo Name }
       : FieldId '=' Exp { RecordFieldExplicit (fst $1) $3 (srcspan (snd $1) $>) }
       | id              { let L loc (ID s) = $1 in RecordFieldImplicit s NoInfo loc }

Fields :: { [FieldBase NoInfo Name] }
        : Fields1 { $1 }
        |         { [] }

Fields1 :: { [FieldBase NoInfo Name] }
        : Field ',' Fields1 { $1 : $3 }
        | Field             { [$1] }

LetExp :: { UncheckedExp }
     : let Pattern '=' Exp LetBody
                      { LetPat [] $2 $4 $5 (srcspan $1 $>) }
     | let TypeParams1 Pattern '=' Exp LetBody
                      { LetPat (fst $2 : snd $2) $3 $5 $6 (srcspan $1 $>) }

     | let id TypeParams FunParams1 maybeAscription(TypeExpDecl) '=' Exp LetBody
       { let L _ (ID name) = $2
         in LetFun name ($3, fst $4 : snd $4, (fmap declaredType $5), NoInfo, $7) $8 (srcspan $1 $>) }

     | let VarSlice '=' Exp LetBody
                      { let (v,slice,loc) = $2; ident = Ident v NoInfo loc
                        in LetWith ident ident slice $4 $5 (srcspan $1 $>) }

LetBody :: { UncheckedExp }
    : in Exp %prec letprec { $2 }
    | LetExp %prec letprec { $1 }

MatchExp :: { UncheckedExp }
          : match Exp Cases  { let loc = srcspan $1 $>
                               in Match $2 $> NoInfo loc  }

Cases :: { [CaseBase NoInfo Name] }
       : Case  %prec caseprec { [$1] }
       | Case Cases           { $1 : $2 }

Case :: { CaseBase NoInfo Name }
      : case CPattern '->' Exp       { let loc = srcspan $1 $>
                                       in CasePat $2 $> loc }

CPattern :: { PatternBase NoInfo Name }
          : CInnerPattern ':' TypeExpDecl { PatternAscription $1 $3 (srcspan $1 $>) }
          | CInnerPattern                 { $1 }

CPatterns1 :: { [PatternBase NoInfo Name] }
           : CPattern               { [$1] }
           | CPattern ',' CPatterns1 { $1 : $3 }

CInnerPattern :: { PatternBase NoInfo Name }
               : id                                 { let L loc (ID name) = $1 in Id name NoInfo loc }
               | '(' BindingBinOp ')'               { Id $2 NoInfo (srcspan $1 $>) }
               | '(' BindingUnOp ')'                { Id $2 NoInfo (srcspan $1 $>) }
               | '_'                                { Wildcard NoInfo $1 }
               | '(' ')'                            { TuplePattern [] (srcspan $1 $>) }
               | '(' CPattern ')'                   { PatternParens $2 (srcspan $1 $>) }
               | '(' CPattern ',' CPatterns1 ')'    { TuplePattern ($2:$4) (srcspan $1 $>) }
               | '{' CFieldPatterns '}'             { RecordPattern $2 (srcspan $1 $>) }
               | CaseLiteral                        { PatternLit (fst $1) NoInfo (snd $1) }

CFieldPattern :: { (Name, PatternBase NoInfo Name) }
               : FieldId '=' CPattern
               { (fst $1, $3) }
               | FieldId ':' TypeExpDecl
               { (fst $1, PatternAscription (Id (fst $1) NoInfo (snd $1)) $3 (srcspan (snd $1) $>)) }
               | FieldId
               { (fst $1, Id (fst $1) NoInfo (snd $1)) }

CFieldPatterns :: { [(Name, PatternBase NoInfo Name)] }
                : CFieldPatterns1 { $1 }
                |                { [] }

CFieldPatterns1 :: { [(Name, PatternBase NoInfo Name)] }
                 : CFieldPattern ',' CFieldPatterns1 { $1 : $3 }
                 | CFieldPattern                    { [$1] }

CaseLiteral :: { (UncheckedExp, SrcLoc) }
             : PrimLit        { (Literal (fst $1) (snd $1), snd $1) }
             | intlit         { let L loc (INTLIT x) = $1 in (IntLit x NoInfo loc, loc) }
             | floatlit       { let L loc (FLOATLIT x) = $1 in (FloatLit x NoInfo loc, loc) }
             | stringlit      { let L loc (STRINGLIT s) = $1 in
                              (ArrayLit (map (flip Literal loc . SignedValue . Int32Value . fromIntegral . ord) s) NoInfo loc, loc) }
             | VConstr0       { (VConstr0 (fst $1) NoInfo (snd $1), snd $1) }

LoopForm :: { LoopFormBase NoInfo Name }
LoopForm : for VarId '<' Exp
           { For $2 $4 }
         | for Pattern in Exp
           { ForIn $2 $4 }
         | while Exp
           { While $2 }

VarSlice :: { (Name, [UncheckedDimIndex], SrcLoc) }
          : 'id[' DimIndices ']'
              { let L _ (INDEXING v) = $1
                in (v, $2, srcspan $1 $>) }

QualVarSlice :: { (QualName Name, [UncheckedDimIndex], SrcLoc) }
              : VarSlice
                { let (x, y, z) = $1 in (qualName x, y, z) }
              | 'qid[' DimIndices ']'
                { let L _ (QUALINDEXING qs v) = $1 in (QualName qs v, $2, srcspan $1 $>) }

DimIndex :: { UncheckedDimIndex }
         : Exp2                   { DimFix $1 }
         | Exp2 ':' Exp2          { DimSlice (Just $1) (Just $3) Nothing }
         | Exp2 ':'               { DimSlice (Just $1) Nothing Nothing }
         |      ':' Exp2          { DimSlice Nothing (Just $2) Nothing }
         |      ':'               { DimSlice Nothing Nothing Nothing }
         | Exp2 ':' Exp2 ':' Exp2 { DimSlice (Just $1) (Just $3) (Just $5) }
         |      ':' Exp2 ':' Exp2 { DimSlice Nothing (Just $2) (Just $4) }
         | Exp2 ':'      ':' Exp2 { DimSlice (Just $1) Nothing (Just $4) }
         |      ':'      ':' Exp2 { DimSlice Nothing Nothing (Just $3) }

DimIndices :: { [UncheckedDimIndex] }
            :             { [] }
            | DimIndices1 { fst $1 : snd $1 }

DimIndices1 :: { (UncheckedDimIndex, [UncheckedDimIndex]) }
             : DimIndex                 { ($1, []) }
             | DimIndex ',' DimIndices1 { ($1, fst $3 : snd $3) }

VarId :: { IdentBase NoInfo Name }
VarId : id { let L loc (ID name) = $1 in Ident name NoInfo loc }

FieldId :: { (Name, SrcLoc) }
         : id     { let L loc (ID name) = $1 in (name, loc) }
         | intlit { let L loc (INTLIT n) = $1 in (nameFromString (show n), loc) }

Pattern :: { PatternBase NoInfo Name }
Pattern : InnerPattern ':' TypeExpDecl { PatternAscription $1 $3 (srcspan $1 $>) }
        | InnerPattern                 { $1 }

Patterns1 :: { [PatternBase NoInfo Name] }
           : Pattern               { [$1] }
           | Pattern ',' Patterns1 { $1 : $3 }

InnerPattern :: { PatternBase NoInfo Name }
InnerPattern : id                               { let L loc (ID name) = $1 in Id name NoInfo loc }
             | '(' BindingBinOp ')'             { Id $2 NoInfo (srcspan $1 $>) }
             | '(' BindingUnOp ')'              { Id $2 NoInfo (srcspan $1 $>) }
             | '_'                              { Wildcard NoInfo $1 }
             | '(' ')'                          { TuplePattern [] (srcspan $1 $>) }
             | '(' Pattern ')'                  { PatternParens $2 (srcspan $1 $>) }
             | '(' Pattern ',' Patterns1 ')'    { TuplePattern ($2:$4) (srcspan $1 $>) }
             | '{' FieldPatterns '}'            { RecordPattern $2 (srcspan $1 $>) }

FieldPattern :: { (Name, PatternBase NoInfo Name) }
              : FieldId '=' Pattern
                { (fst $1, $3) }
              | FieldId ':' TypeExpDecl
              { (fst $1, PatternAscription (Id (fst $1) NoInfo (snd $1)) $3 (srcspan (snd $1) $>)) }
              | FieldId
                { (fst $1, Id (fst $1) NoInfo (snd $1)) }

FieldPatterns :: { [(Name, PatternBase NoInfo Name)] }
               : FieldPatterns1 { $1 }
               |                { [] }

FieldPatterns1 :: { [(Name, PatternBase NoInfo Name)] }
               : FieldPattern ',' FieldPatterns1 { $1 : $3 }
               | FieldPattern                    { [$1] }


maybeAscription(p) : ':' p { Just $2 }
                   |       { Nothing }

Value :: { Value }
Value : IntValue { $1 }
      | FloatValue { $1 }
      | StringValue { $1 }
      | BoolValue { $1 }
      | ArrayValue { $1 }

CatValues :: { [Value] }
CatValues : Value CatValues { $1 : $2 }
          |                 { [] }

PrimType :: { PrimType }
         : id {% let L _ (ID s) = $1 in primTypeFromName s }

IntValue :: { Value }
         : SignedLit { PrimValue (SignedValue (fst $1)) }
         | '-' SignedLit { PrimValue (SignedValue (intNegate (fst $2))) }
         | UnsignedLit { PrimValue (UnsignedValue (fst $1)) }

FloatValue :: { Value }
         : FloatLit     { PrimValue (FloatValue (fst $1)) }
         | '-' FloatLit { PrimValue (FloatValue (floatNegate (fst $2))) }

StringValue :: { Value }
StringValue : stringlit  { let L pos (STRINGLIT s) = $1 in
                           ArrayValue (arrayFromList $ map (PrimValue . SignedValue . Int32Value . fromIntegral . ord) s) $ Prim $ Signed Int32 }

BoolValue :: { Value }
BoolValue : true           { PrimValue $ BoolValue True }
          | false          { PrimValue $ BoolValue False }

SignedLit :: { (IntValue, SrcLoc) }
          : i8lit   { let L loc (I8LIT num)  = $1 in (Int8Value num, loc) }
          | i16lit  { let L loc (I16LIT num) = $1 in (Int16Value num, loc) }
          | i32lit  { let L loc (I32LIT num) = $1 in (Int32Value num, loc) }
          | i64lit  { let L loc (I64LIT num) = $1 in (Int64Value num, loc) }
          | intlit  { let L loc (INTLIT num) = $1 in (Int32Value $ fromInteger num, loc) }
          | charlit { let L loc (CHARLIT char) = $1 in (Int32Value $ fromIntegral $ ord char, loc) }

UnsignedLit :: { (IntValue, SrcLoc) }
            : u8lit  { let L pos (U8LIT num)  = $1 in (Int8Value $ fromIntegral num, pos) }
            | u16lit { let L pos (U16LIT num) = $1 in (Int16Value $ fromIntegral num, pos) }
            | u32lit { let L pos (U32LIT num) = $1 in (Int32Value $ fromIntegral num, pos) }
            | u64lit { let L pos (U64LIT num) = $1 in (Int64Value $ fromIntegral num, pos) }

FloatLit :: { (FloatValue, SrcLoc) }
         : f32lit { let L loc (F32LIT num) = $1 in (Float32Value num, loc) }
         | f64lit { let L loc (F64LIT num) = $1 in (Float64Value num, loc) }
         | QualName {% let (qn, loc) = $1 in
                       if      qn == QualName [nameFromString "f32"] (nameFromString "inf")
                       then return (Float32Value (1/0), loc)
                       else if qn == QualName [nameFromString "f32"] (nameFromString "nan")
                       then return (Float32Value (0/0), loc)
                       else if qn == QualName [nameFromString "f64"] (nameFromString "inf")
                       then return (Float64Value (1/0), loc)
                       else if qn == QualName [nameFromString "f64"] (nameFromString "nan")
                       then return (Float64Value (0/0), loc)
                       else parseErrorAt (snd $1) Nothing }
         | floatlit { let L loc (FLOATLIT num) = $1 in (Float64Value num, loc) }

ArrayValue :: { Value }
ArrayValue :  '[' Value ']'
             {% return $ ArrayValue (arrayFromList [$2]) $ toStruct $ valueType $2
             }
           |  '[' Value ',' Values ']'
             {% case combArrayElements $2 $4 of
                  Left e -> throwError e
                  Right v -> return $ ArrayValue (arrayFromList $ $2:$4) $ valueType v
             }
           | id '(' PrimType ')'
             {% ($1 `mustBe` "empty") >> return (ArrayValue (listArray (0,-1) []) (Prim $3)) }
           | id '(' RowType ')'
             {% ($1 `mustBe` "empty") >> return (ArrayValue (listArray (0,-1) []) $3) }

           -- Errors
           | '[' ']'
             {% emptyArrayError $1 }

RowType :: { TypeBase () () }
RowType : '[' ']' RowType   { fromJust $ arrayOf $3 (rank 1) Nonunique }
        | '[' ']' PrimType  { fromJust $ arrayOf (Prim $3) (rank 1) Nonunique }

Values :: { [Value] }
Values : Value ',' Values { $1 : $3 }
       | Value            { [$1] }
       |                  { [] }

{

addDoc :: DocComment -> UncheckedDec -> UncheckedDec
addDoc doc (ValDec val) = ValDec (val { valBindDoc = Just doc })
addDoc doc (TypeDec tp) = TypeDec (tp { typeDoc = Just doc })
addDoc doc (SigDec sig) = SigDec (sig { sigDoc = Just doc })
addDoc doc (ModDec mod) = ModDec (mod { modDoc = Just doc })
addDoc _ dec = dec

addDocSpec :: DocComment -> SpecBase NoInfo Name -> SpecBase NoInfo Name
addDocSpec doc (TypeAbbrSpec tpsig) = TypeAbbrSpec (tpsig { typeDoc = Just doc })
addDocSpec doc val@(ValSpec {}) = val { specDoc = Just doc }
addDocSpec doc (TypeSpec l name ps _ loc) = TypeSpec l name ps (Just doc) loc
addDocSpec doc (ModSpec name se _ loc) = ModSpec name se (Just doc) loc
addDocSpec _ spec = spec

reverseNonempty :: (a, [a]) -> (a, [a])
reverseNonempty (x, l) =
  case reverse (x:l) of
    x':rest -> (x', rest)
    []      -> (x, [])

mustBe (L loc (ID got)) expected
  | nameToString got == expected = return ()
mustBe (L loc _) expected =
  parseErrorAt loc $ Just $
  "Only the keyword '" ++ expected ++ "' may appear here."

data ParserEnv = ParserEnv {
                 parserFile :: FilePath
               }

type ParserMonad a =
  ExceptT String (
    StateT ParserEnv (
       StateT ([L Token], Pos) ReadLineMonad)) a

data ReadLineMonad a = Value a
                     | GetLine (Maybe T.Text -> ReadLineMonad a)

readLineFromMonad :: ReadLineMonad (Maybe T.Text)
readLineFromMonad = GetLine Value

instance Monad ReadLineMonad where
  return = Value
  Value x >>= f = f x
  GetLine g >>= f = GetLine $ \s -> g s >>= f

instance Functor ReadLineMonad where
  f `fmap` m = do x <- m
                  return $ f x

instance Applicative ReadLineMonad where
  (<*>) = ap

getLinesFromM :: Monad m => m T.Text -> ReadLineMonad a -> m a
getLinesFromM _ (Value x) = return x
getLinesFromM fetch (GetLine f) = do
  s <- fetch
  getLinesFromM fetch $ f $ Just s

getLinesFromTexts :: [T.Text] -> ReadLineMonad a -> Either String a
getLinesFromTexts _ (Value x) = Right x
getLinesFromTexts (x : xs) (GetLine f) = getLinesFromTexts xs $ f $ Just x
getLinesFromTexts [] (GetLine f) = getLinesFromTexts [] $ f Nothing

getNoLines :: ReadLineMonad a -> Either String a
getNoLines (Value x) = Right x
getNoLines (GetLine f) = getNoLines $ f Nothing

combArrayElements :: Value
                  -> [Value]
                  -> Either String Value
combArrayElements t ts = foldM comb t ts
  where comb x y
          | valueType x == valueType y = Right x
          | otherwise                  = Left $ "Elements " ++ pretty x ++ " and " ++
                                         pretty y ++ " cannot exist in same array."

arrayFromList :: [a] -> Array Int a
arrayFromList l = listArray (0, length l-1) l

patternExp :: UncheckedPattern -> ParserMonad UncheckedExp
patternExp (Id v _ loc) = return $ Var (qualName v) NoInfo loc
patternExp (TuplePattern pats loc) = TupLit <$> (mapM patternExp pats) <*> return loc
patternExp (Wildcard _ loc) = parseErrorAt loc $ Just "cannot have wildcard here."
patternExp (PatternAscription pat _ _) = patternExp pat
patternExp (PatternParens pat _) = patternExp pat
patternExp (RecordPattern fs loc) = RecordLit <$> mapM field fs <*> pure loc
  where field (name, pat) = RecordFieldExplicit name <$> patternExp pat <*> pure loc

eof :: Pos -> L Token
eof pos = L (SrcLoc $ Loc pos pos) EOF

binOpName (L _ (SYMBOL _ qs op)) = QualName qs op

binOp x (L _ (SYMBOL _ qs op)) y =
  BinOp (QualName qs op) NoInfo (x, NoInfo) (y, NoInfo) NoInfo $
  srcspan x y

getTokens :: ParserMonad ([L Token], Pos)
getTokens = lift $ lift get

putTokens :: ([L Token], Pos) -> ParserMonad ()
putTokens = lift . lift . put

primTypeFromName :: Name -> ParserMonad PrimType
primTypeFromName s = maybe boom return $ M.lookup s namesToPrimTypes
  where boom = fail $ "No type named " ++ nameToString s

getFilename :: ParserMonad FilePath
getFilename = lift $ gets parserFile

intNegate :: IntValue -> IntValue
intNegate (Int8Value v) = Int8Value (-v)
intNegate (Int16Value v) = Int16Value (-v)
intNegate (Int32Value v) = Int32Value (-v)
intNegate (Int64Value v) = Int64Value (-v)

floatNegate :: FloatValue -> FloatValue
floatNegate (Float32Value v) = Float32Value (-v)
floatNegate (Float64Value v) = Float64Value (-v)

readLine :: ParserMonad (Maybe T.Text)
readLine = lift $ lift $ lift readLineFromMonad

lexer :: (L Token -> ParserMonad a) -> ParserMonad a
lexer cont = do
  (ts, pos) <- getTokens
  case ts of
    [] -> do
      ended <- lift $ runExceptT $ cont $ eof pos
      case ended of
        Right x -> return x
        Left parse_e -> do
          line <- readLine
          ts' <-
            case line of Nothing -> throwError parse_e
                         Just line' -> return $ scanTokensText (advancePos pos '\n') line'
          (ts'', pos') <-
            case ts' of Right x -> return x
                        Left lex_e  -> throwError lex_e
          case ts'' of
            [] -> cont $ eof pos
            xs -> do
              putTokens (xs, pos')
              lexer cont
    (x : xs) -> do
      putTokens (xs, pos)
      cont x

parseError :: L Token -> ParserMonad a
parseError (L loc EOF) =
  parseErrorAt (srclocOf loc) $ Just "unexpected end of file."
parseError (L loc DOC{}) =
  parseErrorAt (srclocOf loc) $
  Just "documentation comments ('-- |') are only permitted when preceding declarations."
parseError tok = parseErrorAt (srclocOf tok) Nothing

parseErrorAt :: SrcLoc -> Maybe String -> ParserMonad a
parseErrorAt loc Nothing = throwError $ "Error at " ++ locStr loc ++ ": Parse error."
parseErrorAt loc (Just s) = throwError $ "Error at " ++ locStr loc ++ ": " ++ s

emptyArrayError :: SrcLoc -> ParserMonad a
emptyArrayError loc =
  parseErrorAt loc $
  Just "write empty arrays as 'empty(t)', for element type 't'.\n"

twoDotsRange :: SrcLoc -> ParserMonad a
twoDotsRange loc = parseErrorAt loc $ Just "use '...' for ranges, not '..'.\n"

--- Now for the parser interface.

-- | A parse error.  Use 'show' to get a human-readable description.
data ParseError = ParseError String

instance Show ParseError where
  show (ParseError s) = s

parseInMonad :: ParserMonad a -> FilePath -> T.Text
             -> ReadLineMonad (Either ParseError a)
parseInMonad p file program =
  either (Left . ParseError) Right <$> either (return . Left)
  (evalStateT (evalStateT (runExceptT p) env))
  (scanTokensText (Pos file 1 1 0) program)
  where env = ParserEnv file

parseIncremental :: ParserMonad a -> FilePath -> T.Text
                 -> Either ParseError a
parseIncremental p file program =
  either (Left . ParseError) id
  $ getLinesFromTexts (T.lines program)
  $ parseInMonad p file mempty

parse :: ParserMonad a -> FilePath -> T.Text
      -> Either ParseError a
parse p file program =
  either (Left . ParseError) id
  $ getNoLines $ parseInMonad p file program

-- | Parse an Futhark expression incrementally from monadic actions, using the
-- 'FilePath' as the source name for error messages.
parseExpIncrM :: Monad m =>
                 m T.Text -> FilePath -> T.Text
              -> m (Either ParseError UncheckedExp)
parseExpIncrM fetch file program =
  getLinesFromM fetch $ parseInMonad expression file program

-- | Parse either an expression or a declaration incrementally;
-- favouring declarations in case of ambiguity.
parseDecOrExpIncrM :: Monad m =>
                      m T.Text -> FilePath -> T.Text
                   -> m (Either ParseError (Either UncheckedDec UncheckedExp))
parseDecOrExpIncrM fetch file input =
  case parseInMonad declaration file input of
    Value Left{} -> fmap Right <$> parseExpIncrM fetch file input
    Value (Right d) -> return $ Right $ Left d
    GetLine c -> do
      l <- fetch
      parseDecOrExpIncrM fetch file $ input <> "\n" <> l
}