{- |
    Module      :  $Header$
    Description :  A Parser for Curry
    Copyright   :  (c) 1999 - 2004 Wolfgang Lux
                       2005        Martin Engelke
                       2011 - 2015 Björn Peemöller
                       2016 - 2017 Finn Teegen
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    The Curry parser is implemented using the (mostly) LL(1) parsing
    combinators implemented in 'Curry.Base.LLParseComb'.
-}
module Curry.Syntax.Parser
  ( parseSource, parseHeader, parsePragmas, parseInterface, parseGoal
  ) where

import Curry.Base.Ident
import Curry.Base.Monad       (CYM)
import Curry.Base.Position    (Position(..), getPosition, setPosition, incr)
import Curry.Base.LLParseComb
import Curry.Base.Span        hiding (file) -- clash with Position.file
import Curry.Base.SpanInfo

import Curry.Syntax.Extension
import Curry.Syntax.Lexer (Token (..), Category (..), Attributes (..), lexer)
import Curry.Syntax.Type

-- |Parse a 'Module'
parseSource :: FilePath -> String -> CYM (Module ())
parseSource = fullParser (uncurry <$> moduleHeader <*> layout moduleDecls) lexer

-- TODO position on prefix parsers?
-- |Parse only pragmas of a 'Module'
parsePragmas :: FilePath -> String -> CYM (Module ())
parsePragmas
  = prefixParser ((\ps sp -> setEndPosition NoPos
                              (Module (SpanInfo sp []) ps mainMIdent
                                 Nothing [] []))
                    <$> modulePragmas <*> spanPosition)
      lexer

-- |Parse a 'Module' header
parseHeader :: FilePath -> String -> CYM (Module ())
parseHeader
  = prefixParser (moduleHeader <*> startLayout importDecls <*> succeed []) lexer
  where importDecls = many (importDecl <*-> many semicolon)

-- |Parse an 'Interface'
parseInterface :: FilePath -> String -> CYM Interface
parseInterface = fullParser interface lexer

-- |Parse a 'Goal'
parseGoal :: String -> CYM (Goal ())
parseGoal = fullParser goal lexer ""

-- ---------------------------------------------------------------------------
-- Module header
-- ---------------------------------------------------------------------------

-- |Parser for a module header
moduleHeader :: Parser a Token ([ImportDecl] -> [Decl b] -> Module b)
moduleHeader =
  (\sp ps (m, es, inf) is ds -> updateEndPos
      (Module (SpanInfo sp inf) ps m es is ds))
    <$> spanPosition
    <*> modulePragmas
    <*> header
  where header = (\sp1 m es sp2 -> (m, es, [sp1,sp2]))
                    <$>  tokenSpan KW_module
                    <*>  modIdent
                    <*>  option exportSpec
                    <*>  spanPosition
                    <*-> expectWhere
                `opt` (mainMIdent, Nothing, [])

modulePragmas :: Parser a Token [ModulePragma]
modulePragmas = many (languagePragma <|> optionsPragma)

languagePragma :: Parser a Token ModulePragma
languagePragma =   languagePragma'
              <$>  tokenSpan PragmaLanguage
              <*>  (languageExtension `sepBy1Sp` comma)
              <*>  tokenSpan PragmaEnd
  where languageExtension = classifyExtension <$> ident
        languagePragma' sp1 (ex, ss) sp2 = updateEndPos $
          LanguagePragma (SpanInfo sp1 (sp1 : ss ++ [sp2])) ex

-- TODO The span info is not 100% complete due to the lexer
-- combining OPTIONS, toolVal and toolArgs
optionsPragma :: Parser a Token ModulePragma
optionsPragma = optionsPragma'
           <$>  spanPosition
           <*>  token PragmaOptions
           <*>  tokenSpan PragmaEnd
  where optionsPragma' sp1 a sp2 = updateEndPos $
          OptionsPragma (SpanInfo sp1 [sp1, sp2])
                        (classifyTool <$> toolVal a)
                        (toolArgs a)

-- |Parser for an export specification
exportSpec :: Parser a Token ExportSpec
exportSpec = exportSpec' <$> spanPosition <*> parensSp (export `sepBySp` comma)
  where exportSpec' sp1 ((ex, ss),sp2,sp3) = updateEndPos $
          Exporting (SpanInfo sp1 (sp2:(ss ++ [sp3]))) ex

-- |Parser for an export item
export :: Parser a Token Export
export =  qtycon <**> (tcExportWith <$> parensSp spec `opt` tcExport)
      <|> tcExport <$> qfun <\> qtycon
      <|> exportModule' <$> tokenSpan KW_module <*> modIdent
  where spec =  (\sp      -> (ExportTypeAll    , [sp])) <$> tokenSpan DotDot
            <|> (\(c, ss) -> (exportTypeWith' c,  ss )) <$> con `sepBySp` comma
        tcExport qtc = updateEndPos $ Export (fromSrcSpan (getSrcSpan qtc)) qtc
        tcExportWith ((spc, ss), sp1, sp2) qtc =
          updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $
          spc (fromSrcSpan (getSrcSpan qtc)) qtc
        exportTypeWith' c spi qtc = ExportTypeWith spi qtc c
        exportModule' sp = updateEndPos . ExportModule (SpanInfo sp [])

moduleDecls :: Parser a Token ([ImportDecl], [Decl ()])
moduleDecls = impDecl <$> importDecl
                      <*> (semicolon <-*> moduleDecls `opt` ([], []))
          <|> (,) []  <$> topDecls
  where impDecl i (is, ds) = (i:is ,ds)

-- |Parser for a single import declaration
importDecl :: Parser a Token ImportDecl
importDecl =  importDecl'
          <$> tokenSpan KW_import
          <*> option (tokenSpan Id_qualified)
          <*> modIdent
          <*> option ((,) <$> tokenSpan Id_as <*> modIdent)
          <*> option importSpec
  where
    importDecl' sp1 (Just sp2) mid (Just (sp3, alias)) = updateEndPos .
      ImportDecl (SpanInfo sp1 [sp1, sp2, sp3]) mid True  (Just alias)
    importDecl' sp1 Nothing    mid (Just (sp3, alias)) = updateEndPos .
      ImportDecl (SpanInfo sp1      [sp1, sp3]) mid False (Just alias)
    importDecl' sp1 (Just sp2) mid Nothing             = updateEndPos .
      ImportDecl (SpanInfo sp1      [sp1, sp2]) mid True  Nothing
    importDecl' sp1 Nothing    mid Nothing             = updateEndPos .
      ImportDecl (SpanInfo sp1           [sp1]) mid False Nothing

-- |Parser for an import specification
importSpec :: Parser a Token ImportSpec
importSpec =   spanPosition
          <**> (hiding' <$-> token Id_hiding `opt` importing')
          <*>  parensSp (importSp `sepBySp` comma)
  where
    hiding' sp1 ((specs, ss), sp2, sp3) = updateEndPos $
      Hiding    (SpanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) specs
    importing' sp1 ((specs, ss), sp2, sp3) = updateEndPos $
      Importing (SpanInfo sp1 (      sp2 : (ss ++ [sp3]))) specs

importSp :: Parser a Token Import
importSp = tycon <**> (tcImportWith <$> parensSp spec `opt` tcImport)
      <|> tcImport <$> fun <\> tycon
  where spec =  (\sp      -> (ImportTypeAll    , [sp])) <$> tokenSpan DotDot
            <|> (\(c, ss) -> (importTypeWith' c,  ss )) <$> con `sepBySp` comma
        tcImport tc = updateEndPos $ Import (fromSrcSpan (getSrcSpan tc)) tc
        tcImportWith ((spc, ss), sp1, sp2) tc =
          updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $
          spc (fromSrcSpan (getSrcSpan tc)) tc
        importTypeWith' c spi tc = ImportTypeWith spi tc c
-- ---------------------------------------------------------------------------
-- Interfaces
-- ---------------------------------------------------------------------------

-- |Parser for an interface
interface :: Parser a Token Interface
interface = uncurry <$> intfHeader <*> braces intfDecls

intfHeader :: Parser a Token ([IImportDecl] -> [IDecl] -> Interface)
intfHeader = Interface <$-> token Id_interface <*> modIdent <*-> expectWhere

intfDecls :: Parser a Token ([IImportDecl], [IDecl])
intfDecls = impDecl <$> iImportDecl
                    <*> (semicolon <-*> intfDecls `opt` ([], []))
        <|> (,) [] <$> intfDecl `sepBy` semicolon
  where impDecl i (is, ds) = (i:is, ds)

-- |Parser for a single interface import declaration
iImportDecl :: Parser a Token IImportDecl
iImportDecl = IImportDecl <$> tokenPos KW_import <*> modIdent

-- |Parser for a single interface declaration
intfDecl :: Parser a Token IDecl
intfDecl = choice [ iInfixDecl, iHidingDecl, iDataDecl, iNewtypeDecl
                  , iTypeDecl , iFunctionDecl <\> token Id_hiding
                  , iClassDecl, iInstanceDecl ]

-- |Parser for an interface infix declaration
iInfixDecl :: Parser a Token IDecl
iInfixDecl = infixDeclLhs iInfixDecl' <*> integer <*> qfunop
  where iInfixDecl' sp = IInfixDecl (span2Pos sp)

-- |Parser for an interface hiding declaration
iHidingDecl :: Parser a Token IDecl
iHidingDecl = tokenPos Id_hiding <**> (hDataDecl <|> hClassDecl)
  where
  hDataDecl = hiddenData <$-> token KW_data <*> withKind qtycon <*> many tyvar
  hClassDecl = hiddenClass <$> classInstHead KW_class (withKind qtycls) clsvar
  hiddenData (tc, k) tvs p = HidingDataDecl p tc k tvs
  hiddenClass (_, _, cx, (qcls, k), tv) p = HidingClassDecl p cx qcls k tv

-- |Parser for an interface data declaration
iDataDecl :: Parser a Token IDecl
iDataDecl = iTypeDeclLhs IDataDecl KW_data <*> constrs <*> iHiddenPragma
  where constrs = equals <-*> constrDecl `sepBy1` bar `opt` []

-- |Parser for an interface newtype declaration
iNewtypeDecl :: Parser a Token IDecl
iNewtypeDecl = iTypeDeclLhs INewtypeDecl KW_newtype
               <*-> equals <*> newConstrDecl <*> iHiddenPragma

-- |Parser for an interface type synonym declaration
iTypeDecl :: Parser a Token IDecl
iTypeDecl = iTypeDeclLhs ITypeDecl KW_type
            <*-> equals <*> type0

-- |Parser for an interface hiding pragma
iHiddenPragma :: Parser a Token [Ident]
iHiddenPragma = token PragmaHiding
                <-*> (con `sepBy` comma)
                <*-> token PragmaEnd
                `opt` []


-- |Parser for an interface function declaration
iFunctionDecl :: Parser a Token IDecl
iFunctionDecl = IFunctionDecl <$> position <*> qfun <*> option iMethodPragma
                <*> arity <*-> token DoubleColon <*> qualType

-- |Parser for an interface method pragma
iMethodPragma :: Parser a Token Ident
iMethodPragma = token PragmaMethod <-*> clsvar <*-> token PragmaEnd

-- |Parser for function's arity
arity :: Parser a Token Int
arity = int `opt` 0

iTypeDeclLhs :: (Position -> QualIdent -> Maybe KindExpr -> [Ident] -> a)
             -> Category -> Parser b Token a
iTypeDeclLhs f kw = f' <$> tokenPos kw <*> withKind qtycon <*> many tyvar
  where f' p (tc, k) = f p tc k

-- |Parser for an interface class declaration
iClassDecl :: Parser a Token IDecl
iClassDecl = (\(sp, _, cx, (qcls, k), tv) ->
               IClassDecl (span2Pos sp) cx qcls k tv)
        <$> classInstHead KW_class (withKind qtycls) clsvar
        <*> braces (iMethod `sepBy` semicolon)
        <*> iClassHidden

-- |Parser for an interface method declaration
iMethod :: Parser a Token IMethodDecl
iMethod = IMethodDecl <$> position
                      <*> fun <*> option int <*-> token DoubleColon <*> qualType

-- |Parser for an interface hiding pragma
iClassHidden :: Parser a Token [Ident]
iClassHidden = token PragmaHiding
          <-*> (fun `sepBy` comma)
          <*-> token PragmaEnd
          `opt` []

-- |Parser for an interface instance declaration
iInstanceDecl :: Parser a Token IDecl
iInstanceDecl = (\(sp, _, cx, qcls, inst) ->
                   IInstanceDecl (span2Pos sp) cx qcls inst)
           <$> classInstHead KW_instance qtycls type2
           <*> braces (iImpl `sepBy` semicolon)
           <*> option iModulePragma

-- |Parser for an interface method implementation
iImpl :: Parser a Token IMethodImpl
iImpl = (,) <$> fun <*> arity

iModulePragma :: Parser a Token ModuleIdent
iModulePragma = token PragmaModule <-*> modIdent <*-> token PragmaEnd

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

topDecls :: Parser a Token [Decl ()]
topDecls = topDecl `sepBy` semicolon

topDecl :: Parser a Token (Decl ())
topDecl = choice [ dataDecl, externalDataDecl, newtypeDecl, typeDecl
                 , classDecl, instanceDecl, defaultDecl
                 , infixDecl, functionDecl ]

dataDecl :: Parser a Token (Decl ())
dataDecl = combineWithSpans
             <$> typeDeclLhs dataDecl' KW_data
             <*> ((addSpan <$> tokenSpan Equals <*> constrs) `opt` ([],[]))
             <*> deriv
  where constrs = constrDecl `sepBy1Sp` bar
        dataDecl' sp = DataDecl (SpanInfo sp [sp])

externalDataDecl :: Parser a Token (Decl ())
externalDataDecl = decl <$> tokenSpan KW_external <*> typeDeclLhs (,,) KW_data
  where decl sp1 (sp2, tc, tvs) = updateEndPos $
          ExternalDataDecl (SpanInfo sp1 [sp1, sp2]) tc tvs

newtypeDecl :: Parser a Token (Decl ())
newtypeDecl = combineWithSpans
             <$> typeDeclLhs newtypeDecl' KW_newtype
             <*> ((\sp c -> (c, [sp]))  <$> tokenSpan Equals <*> newConstrDecl)
             <*> deriv
  where newtypeDecl' sp = NewtypeDecl (SpanInfo sp [sp])

combineWithSpans :: HasSpanInfo a =>
                    (t1 -> t2 -> a) -> (t1, [Span]) -> (t2, [Span]) -> a
combineWithSpans df (cs, sps1) (cls, sps2)
  = updateEndPos $ setSrcInfoPoints (getSrcInfoPoints res ++ sps1 ++ sps2) res
  where res = df cs cls

typeDecl :: Parser a Token (Decl ())
typeDecl = typeDeclLhs typeDecl' KW_type <*> tokenSpan Equals <*> type0
  where typeDecl' sp1 tyc tyv sp2 txp = updateEndPos $
          TypeDecl (SpanInfo sp1 [sp1, sp2]) tyc tyv txp

typeDeclLhs :: (Span -> Ident -> [Ident] -> a) -> Category
            -> Parser b Token a
typeDeclLhs f kw = f <$> tokenSpan kw <*> tycon <*> many anonOrTyvar

constrDecl :: Parser a Token ConstrDecl
constrDecl = spanPosition <**> (existVars
                          <**> optContext (\cx sp f -> f sp cx) constr)
  where
  constr =  conId     <**> identDecl
        <|> tokenSpan LeftParen <**> parenDecl
        <|> type1 <\> conId <\> leftParen <**> opDecl
  identDecl =  many type2 <**> (conType <$> opDecl `opt` conDecl)
           <|> recDecl <$> recFields
  parenDecl =  conOpDeclPrefix
           <$> conSym    <*>   tokenSpan RightParen <*> type2 <*> type2
           <|> tupleType <**> (tokenSpan RightParen <**> opDeclParen)
  opDecl = conOpDecl <$> conop <*> type1
  opDeclParen = conOpDeclParen <$> conop <*> type1
  recFields = layoutOff <-*> bracesSp (fieldDecl `sepBySp` comma)
  conType f tys c = f $ foldl mkApply (mkConstructorType $ qualify c) tys
  mkApply t1 t2 = updateEndPos $ ApplyType (fromSrcSpan (getSrcSpan t1)) t1 t2
  mkConstructorType qid = ConstructorType (fromSrcSpan (getSrcSpan qid)) qid
  conDecl tys c ss1 cx (ss2, tvs) sp = updateEndPos $
    ConstrDecl (SpanInfo sp (ss2 ++ ss1)) tvs cx c tys
  conOpDecl op ty2 ty1 ss1 cx (ss2, tvs) sp = updateEndPos $
    ConOpDecl (SpanInfo sp (ss2 ++ ss1)) tvs cx ty1 op ty2
  conOpDeclParen op ty2 sp1 ty1 sp2 ss1 cx (ss2, tvs) sp5 = updateEndPos $
    ConOpDecl (SpanInfo sp5 (ss2 ++ ss1 ++ [sp2, sp1])) tvs cx ty1 op ty2
  conOpDeclPrefix op sp1 ty1 ty2 sp2 ss1 cx (ss2, tvs) sp3 = updateEndPos $
    ConOpDecl (SpanInfo sp3 (ss2 ++ ss1 ++ [sp2,sp1])) tvs cx ty1 op ty2
  recDecl ((fs, ss), sp1, sp2) c ss1 cx (ss2, tvs) sp3 = updateEndPos $
    RecordDecl (SpanInfo sp3 (ss2 ++ ss1 ++ (sp1: (ss ++ [sp2])))) tvs cx c fs

fieldDecl :: Parser a Token FieldDecl
fieldDecl = mkFieldDecl <$> spanPosition <*> labels
                        <*> tokenSpan DoubleColon <*> type0
  where labels = fun `sepBy1Sp` comma
        mkFieldDecl sp1 (idt,ss) sp2 ty = updateEndPos $
          FieldDecl (SpanInfo sp1 (ss ++ [sp2])) idt ty

newConstrDecl :: Parser a Token NewConstrDecl
newConstrDecl = spanPosition <**> (con <**> newConstr)
  where newConstr =  newConDecl <$> type2
                 <|> newRecDecl <$> newFieldDecl
        newConDecl ty  c sp = updateEndPos $ NewConstrDecl (SpanInfo sp []) c ty
        newRecDecl ((idt, sp2, ty), sp3, sp4) c sp1 = updateEndPos $
          NewRecordDecl (SpanInfo sp1 [sp3,sp2,sp4]) c (idt, ty)

newFieldDecl :: Parser a Token ((Ident, Span, TypeExpr), Span, Span)
newFieldDecl = layoutOff <-*> bracesSp labelDecl
  where labelDecl = (,,) <$> fun <*> tokenSpan DoubleColon <*> type0

deriv :: Parser a Token ([QualIdent], [Span])
deriv = (addSpan <$> tokenSpan KW_deriving <*> classes) `opt` ([], [])
  where classes = ((\q -> ([q], [])) <$> qtycls)
               <|> ((\sp1 (qs, ss) sp2 -> (qs, sp1 : (ss ++ [sp2])))
                      <$> tokenSpan LeftParen
                      <*> (qtycls `sepBySp` comma)
                      <*> tokenSpan RightParen)

-- Parsing of existential variables
existVars :: Parser a Token ([Span], [Ident])
existVars = mk <$> tokenSpan Id_forall <*> many1 tyvar <*>
                   tokenSpan SymDot
              `opt` ([],[])
  where mk sp1 a sp2 = ([sp1,sp2], a)

functionDecl :: Parser a Token (Decl ())
functionDecl = spanPosition <**> decl
  where decl = fun `sepBy1Sp` comma <**> funListDecl <|?> funRule

funRule :: Parser a Token (Span -> Decl ())
funRule = mkFunDecl <$> lhs <*> declRhs
  where lhs = (\f ->
                 (f, updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f []))
                 <$> fun <|?> funLhs

funListDecl :: Parser a Token (([Ident],[Span]) -> Span -> Decl ())
funListDecl = typeSig <|> mkExtFun <$> tokenSpan KW_external
  where mkExtFun sp1 (vs,ss) sp2 = updateEndPos $
          ExternalDecl (SpanInfo sp2 (ss++[sp1])) (map (Var ()) vs)


typeSig :: Parser a Token (([Ident],[Span]) -> Span -> Decl ())
typeSig = sig <$> tokenSpan DoubleColon <*> qualType
  where sig sp1 qty (vs,ss) sp2 = updateEndPos $
          TypeSig (SpanInfo sp2 (ss++[sp1])) vs qty

mkFunDecl :: (Ident, Lhs ()) -> Rhs () -> Span -> Decl ()
mkFunDecl (f, lhs) rhs' p = updateEndPos $
    FunctionDecl (SpanInfo p []) () f [updateEndPos $
                                         Equation (SpanInfo p []) lhs rhs']

funLhs :: Parser a Token (Ident, Lhs ())
funLhs = mkFunLhs    <$> fun      <*> many1 pattern2
    <|?> flip ($ updateEndPos) <$> pattern1 <*> opLhs
    <|?> curriedLhs
  where
  opLhs  =                opLHS funSym (gConSym <\> funSym)
       <|> tokenSpan Backquote <**>
             opLHSSp ((,) <$> funId            <*>  spanPosition
                                               <*-> expectBackquote)
                     ((,) <$> qConId <\> funId <*>  spanPosition
                                               <*-> expectBackquote)
  opLHS funP consP   = mkOpLhs       <$> funP  <*> pattern0
                    <|> mkInfixPat   <$> consP <*> pattern1 <*> opLhs
  opLHSSp funP consP = mkOpLhsSp     <$> funP  <*> pattern0
                    <|> mkInfixPatSp <$> consP <*> pattern1 <*> opLhs
  mkFunLhs f ts = (f , updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f ts)
  mkOpLhs op t2 f t1      =
    let t1' = f t1
    in (op, updateEndPos $ OpLhs (fromSrcSpan (getSrcSpan t1')) t1' op t2)
  mkInfixPat op t2 f g t1 =
    f (g . InfixPattern (fromSrcSpan (getSrcSpan t1)) () t1 op) t2
  mkOpLhsSp (op, sp1)    t2   sp2 f t1 =
    let t1' = f t1
    in (op, updateEndPos $
              OpLhs (SpanInfo (getSrcSpan t1') [sp2, sp1]) t1' op t2)

  mkInfixPatSp (op, sp1) t2 g sp2 f t1 =
    g (f . InfixPattern (SpanInfo (getSrcSpan t1) [sp2, sp1]) () t1 op) t2


curriedLhs :: Parser a Token (Ident, Lhs ())
curriedLhs = apLhs <$> parensSp funLhs <*> many1 pattern2
  where apLhs ((f, lhs), sp1, sp2) ts =
          let spi = fromSrcSpan sp1
          in (f, updateEndPos $ setSrcInfoPoints [sp1, sp2] $ ApLhs spi lhs ts)

declRhs :: Parser a Token (Rhs ())
declRhs = rhs equals

rhs :: Parser a Token b -> Parser a Token (Rhs ())
rhs eq = rhsExpr <*> spanPosition <*> localDecls
  where rhsExpr =  mkSimpleRhs  <$> spanPosition <*-> eq <*> expr
               <|> mkGuardedRhs <$> spanPosition <*>  many1 (condExpr eq)
        mkSimpleRhs  sp1 e  sp2 ds = updateEndPos $
          SimpleRhs  (SpanInfo sp1 [sp2]) e  ds
        mkGuardedRhs sp1 ce sp2 ds = updateEndPos $
          GuardedRhs (SpanInfo sp1 [sp2]) ce ds

whereClause :: Parser a Token [b] -> Parser a Token [b]
whereClause decls = token KW_where <-*> layout decls `opt` []

localDecls :: Parser a Token [Decl ()]
localDecls = whereClause valueDecls

valueDecls :: Parser a Token [Decl ()]
valueDecls  = choice [infixDecl, valueDecl] `sepBy` semicolon

infixDecl :: Parser a Token (Decl ())
infixDecl = infixDeclLhs infixDecl'
              <*> option ((,) <$> spanPosition <*> integer)
              <*> funop `sepBy1Sp` comma
  where infixDecl' sp1 inf (Just (sp2, pr)) (ids, ss) =
          updateEndPos $ InfixDecl (SpanInfo sp1 (sp1:sp2:ss)) inf (Just pr) ids
        infixDecl' sp1 inf Nothing          (ids, ss) =
          updateEndPos $ InfixDecl (SpanInfo sp1 (sp1    :ss)) inf Nothing   ids

infixDeclLhs :: (Span -> Infix -> a) -> Parser b Token a
infixDeclLhs f = f <$> spanPosition <*> tokenOps infixKW
  where infixKW = [(KW_infix, Infix), (KW_infixl, InfixL), (KW_infixr, InfixR)]

valueDecl :: Parser a Token (Decl ())
valueDecl = spanPosition <**> decl
  where
  decl =   var `sepBy1Sp` comma       <**> valListDecl
      <|?> patOrFunDecl <$> pattern0   <*> declRhs
      <|?> mkFunDecl    <$> curriedLhs <*> declRhs

  valListDecl =  funListDecl
             <|> mkFree <$> tokenSpan KW_free
    where mkFree sp1 (vs, ss) sp2 = updateEndPos $
            FreeDecl (SpanInfo sp2 (ss ++ [sp1])) (map (Var ()) vs)

  patOrFunDecl (ConstructorPattern spi _ c ts)
    | not (isConstrId c) = mkFunDecl (f, FunLhs spi f ts)
    where f = unqualify c
  patOrFunDecl t = patOrOpDecl updateEndPos t

  patOrOpDecl f (InfixPattern spi a t1 op t2)
    | isConstrId op = patOrOpDecl (f . InfixPattern spi a t1 op) t2
    | otherwise     = mkFunDecl (op', updateEndPos $ OpLhs spi (f t1) op' t2)
    where op' = unqualify op
  patOrOpDecl f t = mkPatDecl (f t)

  mkPatDecl t rhs' sp = updateEndPos $ PatternDecl (fromSrcSpan sp) t rhs'

  isConstrId c = c == qConsId || isQualified c || isQTupleId c

defaultDecl :: Parser a Token (Decl ())
defaultDecl = mkDefaultDecl <$> tokenSpan KW_default
                            <*> parensSp (type0 `sepBySp` comma)
  where mkDefaultDecl sp1 ((ty, ss), sp2, sp3) = updateEndPos $
          DefaultDecl (SpanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) ty

classInstHead :: Category -> Parser a Token b -> Parser a Token c
              -> Parser a Token (Span, [Span], Context, b, c)
classInstHead kw cls ty = f <$> tokenSpan kw
                            <*> optContext (,,) ((,) <$> cls <*> ty)
  where f sp (cx, ss, (cls', ty')) = (sp, ss, cx, cls', ty')

classDecl :: Parser a Token (Decl ())
classDecl = (\(sp1, ss, cx, cls, tv) sp2 -> updateEndPos .
                ClassDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) cx cls tv)
        <$> classInstHead KW_class tycls clsvar
        <*> spanPosition
        <*> whereClause innerDecls
  where
  innerDecls = innerDecl `sepBy` semicolon
  --TODO: Refactor by left-factorization
  --TODO: Support infixDecl
  innerDecl = foldr1 (<|?>)
    [ spanPosition <**> (fun `sepBy1Sp` comma <**> typeSig)
    , spanPosition <**> funRule
                            {-, infixDecl-} ]

instanceDecl :: Parser a Token (Decl ())
instanceDecl = (\(sp1, ss, cx, qcls, inst) sp2 ->  updateEndPos .
                   InstanceDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) cx qcls inst)
           <$> classInstHead KW_instance qtycls type2
           <*> spanPosition
           <*> whereClause innerDecls
  where
  innerDecls = (spanPosition <**> funRule) `sepBy` semicolon
-- ---------------------------------------------------------------------------
-- Type classes
-- ---------------------------------------------------------------------------

optContext :: (Context -> [Span] -> a -> b)
           -> Parser c Token a
           -> Parser c Token b
optContext f p = combine <$> context <*> tokenSpan DoubleArrow <*> p
            <|?> f [] [] <$> p
  where combine (ctx, ss) sp = f ctx (ss ++ [sp])

context :: Parser a Token (Context, [Span])
context = (\c -> ([c], [])) <$> constraint
      <|> combine <$> parensSp (constraint `sepBySp` comma)
  where combine ((ctx, ss), sp1, sp2) = (ctx, sp1 : (ss ++ [sp2]))

-- TODO: ???
constraint :: Parser a Token Constraint
constraint = mkConstraint <$> spanPosition <*> qtycls <*> conType
  where varType = mkVariableType <$> spanPosition <*> clsvar
        conType = fmap ((,) []) varType
               <|> mk <$> parensSp
                            (foldl mkApplyType <$> varType <*> many1 type2)
        mkConstraint sp qtc (ss, ty) = updateEndPos $
          Constraint (SpanInfo sp ss) qtc ty
        mkVariableType sp = VariableType (fromSrcSpan sp)
        mkApplyType t1 t2 =
          ApplyType (fromSrcSpan (combineSpans (getSrcSpan t1)
                                               (getSrcSpan t2)))
                    t1 t2
        mk (a, sp1, sp2) = ([sp1, sp2], a)

-- ---------------------------------------------------------------------------
-- Kinds
-- ---------------------------------------------------------------------------

withKind :: Parser a Token b -> Parser a Token (b, Maybe KindExpr)
withKind p = implicitKind <$> p
        <|?> parens (explicitKind <$> p <*-> token DoubleColon <*> kind0)
  where implicitKind x   = (x, Nothing)
        explicitKind x k = (x, Just k)

-- kind0 ::= kind1 ['->' kind0]
kind0 :: Parser a Token KindExpr
kind0 = kind1 `chainr1` (ArrowKind <$-> token RightArrow)

-- kind1 ::= * | '(' kind0 ')'
kind1 :: Parser a Token KindExpr
kind1 = Star <$-> token SymStar
    <|> parens kind0

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

-- qualType ::= [context '=>']  type0
qualType :: Parser a Token QualTypeExpr
qualType = mkQualTypeExpr <$> spanPosition <*> optContext (,,) type0
  where mkQualTypeExpr sp (cx, ss, ty) = updateEndPos $
          QualTypeExpr (SpanInfo sp ss) cx ty

-- type0 ::= type1 ['->' type0]
type0 :: Parser a Token TypeExpr
type0 = type1 `chainr1` (mkArrowType <$> tokenSpan RightArrow)
  where mkArrowType sp ty1 ty2 = updateEndPos $
          ArrowType (SpanInfo (getSrcSpan ty1) [sp]) ty1 ty2

-- type1 ::= [type1] type2
type1 :: Parser a Token TypeExpr
type1 = foldl1 mkApplyType <$> many1 type2
  where mkApplyType ty1 ty2 = updateEndPos $
          ApplyType (fromSrcSpan (getSrcSpan ty1)) ty1 ty2

-- type2 ::= anonType | identType | parenType | bracketType
type2 :: Parser a Token TypeExpr
type2 = anonType <|> identType <|> parenType <|> bracketType

-- anonType ::= '_'
anonType :: Parser a Token TypeExpr
anonType = mkVariableType <$> spanPosition <*> anonIdent
  where mkVariableType sp = VariableType (fromSrcSpan sp)

-- identType ::= <identifier>
identType :: Parser a Token TypeExpr
identType =  mkVariableType    <$> spanPosition <*> tyvar
         <|> mkConstructorType <$> spanPosition <*> qtycon <\> tyvar
  where mkVariableType    sp = VariableType    (fromSrcSpan sp)
        mkConstructorType sp = ConstructorType (fromSrcSpan sp)

-- parenType ::= '(' tupleType ')'
parenType :: Parser a Token TypeExpr
parenType = fmap updateSpanWithBrackets (parensSp tupleType)

-- tupleType ::= type0                         (parenthesized type)
--            |  type0 ',' type0 { ',' type0 } (tuple type)
--            |  '->'                          (function type constructor)
--            |  ',' { ',' }                   (tuple type constructor)
--            |                                (unit type)
tupleType :: Parser a Token TypeExpr
tupleType = type0 <**> (mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> type0)
                          `opt` ParenType NoSpanInfo)
        <|> tokenSpan RightArrow <**> succeed (mkConstructorType qArrowId)
        <|> mkConstructorTupleType <$> many1 (tokenSpan Comma)
        <|> succeed (ConstructorType NoSpanInfo qUnitId)
  where mkTuple stys ty = let (ss, tys) = unzip stys
                          in TupleType (fromSrcInfoPoints ss) (ty : tys)
        mkConstructorType qid sp = ConstructorType (fromSrcInfoPoints [sp]) qid
        mkConstructorTupleType ss = ConstructorType (fromSrcInfoPoints ss)
                                                    (qTupleId (length ss + 1))

-- bracketType ::= '[' listType ']'
bracketType :: Parser a Token TypeExpr
bracketType = fmap updateSpanWithBrackets (bracketsSp listType)

-- listType ::= type0 (list type)
--           |        (list type constructor)
listType :: Parser a Token TypeExpr
listType = ListType NoSpanInfo <$> type0
             `opt` ConstructorType NoSpanInfo qListId

-- ---------------------------------------------------------------------------
-- Literals
-- ---------------------------------------------------------------------------

-- literal ::= '\'' <escaped character> '\''
--          |  <integer>
--          |  <float>
--          |  '"' <escaped string> '"'
literal :: Parser a Token Literal
literal = Char   <$> char
      <|> Int    <$> integer
      <|> Float  <$> float
      <|> String <$> string

-- ---------------------------------------------------------------------------
-- Patterns
-- ---------------------------------------------------------------------------

-- pattern0 ::= pattern1 [ gconop pattern0 ]
pattern0 :: Parser a Token (Pattern ())
pattern0 = pattern1 `chainr1` (mkInfixPattern <$> gconop)
  where mkInfixPattern qid p1 p2 =
          InfixPattern (fromSrcSpan (combineSpans (getSrcSpan p1)
                                                  (getSrcSpan p2)))
            () p1 qid p2

-- pattern1 ::= varId
--           |  QConId { pattern2 }
--           |  '-'  Integer
--           |  '-.' Float
--           |  '(' parenPattern'
--           | pattern2
pattern1 :: Parser a Token (Pattern ())
pattern1 = varId <**> identPattern'            -- unqualified
        <|> qConId <\> varId <**> constrPattern -- qualified
        <|> mkNegNum <$> minus <*> negNum
        <|> tokenSpan LeftParen <**> parenPattern'
        <|> pattern2  <\> qConId <\> leftParen
  where
  identPattern' =  optAsRecPattern
               <|> mkConsPattern qualify <$> many1 pattern2

  constrPattern =  mkConsPattern id <$> many1 pattern2
               <|> optRecPattern


  parenPattern' =  minus <**> minusPattern
      <|> mkGconPattern <$> gconId <*> tokenSpan RightParen <*> many pattern2
      <|> mkFunIdentP <$> funSym <\> minus <*> tokenSpan RightParen
                                           <*> identPattern'
      <|> mkParenTuple <$> parenTuplePattern <\> minus <*> tokenSpan RightParen
  minusPattern = flip mkParenMinus <$> tokenSpan RightParen <*> identPattern'
         <|> mkParenMinus <$> parenMinusPattern <*> tokenSpan RightParen

  mkNegNum idt p = setEndPosition (end (getSrcSpan idt)) p
  mkParenTuple p sp1 sp2 =
    setSpanInfo (SpanInfo (combineSpans sp2 sp1) [sp2, sp1]) p
  mkFunIdentP idt sp1 f sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt)
  mkParenMinus f sp1 idt sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt)
  mkConsPattern f ts c = updateEndPos $
    ConstructorPattern (fromSrcSpan (getSrcSpan (f c))) () (f c) ts
  mkGconPattern qid sp1 ps sp2 = updateEndPos $
    ConstructorPattern (SpanInfo (getSrcSpan qid) [sp2,sp1]) () qid ps

pattern2 :: Parser a Token (Pattern ())
pattern2 =  literalPattern <|> anonPattern <|> identPattern
        <|> parenPattern   <|> listPattern <|> lazyPattern

-- literalPattern ::= <integer> | <char> | <float> | <string>
literalPattern :: Parser a Token (Pattern ())
literalPattern = flip LiteralPattern () <$> fmap fromSrcSpan spanPosition
                                        <*> literal

-- anonPattern ::= '_'
anonPattern :: Parser a Token (Pattern ())
anonPattern = flip VariablePattern () <$> fmap fromSrcSpan spanPosition
                                      <*> anonIdent

-- identPattern ::= Variable [ '@' pattern2 | '{' fields '}'
--               |  qConId   [ '{' fields '}' ]
identPattern :: Parser a Token (Pattern ())
identPattern =  varId <**> optAsRecPattern -- unqualified
            <|> qConId <\> varId <**> optRecPattern               -- qualified

-- TODO: document me!
parenPattern :: Parser a Token (Pattern ())
parenPattern = tokenSpan LeftParen <**> parenPattern'
  where
  parenPattern' = minus <**> minusPattern
      <|> mkConstructorPattern <$> gconId <*> tokenSpan RightParen
      <|> mkFunAsRec <$> funSym <\> minus <*> tokenSpan RightParen
                     <*> optAsRecPattern
      <|> mkParenTuple <$> parenTuplePattern <\> minus <*> tokenSpan RightParen
  minusPattern = mkOptAsRec <$> tokenSpan RightParen <*> optAsRecPattern
      <|> mkParen <$> parenMinusPattern <*> tokenSpan RightParen

  mkConstructorPattern qid sp1 sp2 =
    ConstructorPattern (fromSrcSpan (combineSpans sp2 sp1)) () qid []
  mkFunAsRec = flip (flip . mkOptAsRec)
  mkParenTuple p sp1 sp2 =
    let ss  = getSrcInfoPoints p
        spi = SpanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1]))
    in setSpanInfo spi p
  mkOptAsRec sp1 f idt sp2 =
    let p   = f idt
        ss  = getSrcInfoPoints p
        spi = SpanInfo (combineSpans sp2 sp1) ([sp2, sp1] ++ ss)
    in setSpanInfo spi p
  mkParen f sp1 idt sp2 =
    let p   = f idt
        ss  = getSrcInfoPoints p
        spi = SpanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1]))
    in setSpanInfo spi p

-- listPattern ::= '[' pattern0s ']'
-- pattern0s   ::= {- empty -}
--              |  pattern0 ',' pattern0s
listPattern :: Parser a Token (Pattern ())
listPattern = mkListPattern <$> bracketsSp (pattern0 `sepBySp` comma)
  where mkListPattern ((ps, ss), sp1, sp2) = updateEndPos $
          ListPattern (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) () ps

-- lazyPattern ::= '~' pattern2
lazyPattern :: Parser a Token (Pattern ())
lazyPattern = mkLazyPattern <$> tokenSpan Tilde <*> pattern2
  where mkLazyPattern sp p = updateEndPos $ LazyPattern (SpanInfo sp [sp]) p

-- optRecPattern ::= [ '{' fields '}' ]
optRecPattern :: Parser a Token (QualIdent -> Pattern ())
optRecPattern = mkRecordPattern <$> fieldsSp pattern0 `opt` mkConPattern
  where
  mkRecordPattern ((fs, ss), sp1, sp2) c = updateEndPos $
    RecordPattern (SpanInfo (getSrcSpan c) (sp1 : (ss ++ [sp2]))) () c fs
  mkConPattern c = ConstructorPattern (fromSrcSpan (getSrcSpan c)) () c []

-- ---------------------------------------------------------------------------
-- Partial patterns used in the combinators above, but also for parsing
-- the left-hand side of a declaration.
-- ---------------------------------------------------------------------------

gconId :: Parser a Token QualIdent
gconId = colon <|> tupleCommas

negNum :: Parser a Token (Pattern ())
negNum = mkNegativePattern <$> spanPosition <*>
                             (Int <$> integer <|> Float <$> float)
  where mkNegativePattern sp = NegativePattern (fromSrcSpan sp) ()

optAsRecPattern :: Parser a Token (Ident -> Pattern ())
optAsRecPattern =  mkAsPattern     <$> tokenSpan At <*> pattern2
               <|> mkRecordPattern <$> fieldsSp pattern0
               `opt` mkVariablePattern
  where mkRecordPattern ((fs,ss),sp1,sp2) v =
          let s = getPosition v
              e = end sp2
              f = file s
              spi = SpanInfo (Span f s e) (sp1 : (ss ++ [sp2]))
          in updateEndPos $ RecordPattern spi () (qualify v) fs
        mkAsPattern sp p idt =
          AsPattern (SpanInfo (getSrcSpan idt) [sp]) idt p
        mkVariablePattern idt =
          VariablePattern (fromSrcSpan (getSrcSpan idt)) () idt

optInfixPattern :: Parser a Token (Pattern () -> Pattern ())
optInfixPattern = mkInfixPat <$> gconop <*> pattern0
            `opt` id
  where mkInfixPat op t2 t1 =
          let s = getPosition t1
              e = getSrcSpanEnd t2
              f = file s
          in InfixPattern (fromSrcSpan (Span f s e)) () t1 op t2

optTuplePattern :: Parser a Token (Pattern () -> Pattern ())
optTuplePattern = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> pattern0)
            `opt` ParenPattern NoSpanInfo
  where mkTuple ts t = let (ss, ps) = unzip ts
                       in TuplePattern (fromSrcInfoPoints ss) (t:ps)

parenMinusPattern :: Parser a Token (Ident -> Pattern ())
parenMinusPattern = mkNeg <$> negNum <.> optInfixPattern <.> optTuplePattern
  where mkNeg neg idt = setEndPosition (end (getSrcSpan idt)) neg

parenTuplePattern :: Parser a Token (Pattern ())
parenTuplePattern = pattern0 <**> optTuplePattern
              `opt` ConstructorPattern NoSpanInfo () qUnitId []

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

-- condExpr ::= '|' expr0 eq expr
--
-- Note: The guard is an `expr0` instead of `expr` since conditional expressions
-- may also occur in case expressions, and an expression like
-- @
-- case a of { _ -> True :: Bool -> a }
-- @
-- can not be parsed with a limited parser lookahead.
condExpr :: Parser a Token b -> Parser a Token (CondExpr ())
condExpr eq = mkCondExpr <$> spanPosition <*-> bar <*> expr0
                         <*> spanPosition <*-> eq  <*> expr
  where mkCondExpr sp1 e1 sp2 e2 = updateEndPos $
          CondExpr (SpanInfo sp1 [sp1, sp2]) e1 e2

-- expr ::= expr0 [ '::' type0 ]
expr :: Parser a Token (Expression ())
expr = expr0 <??> (mkTyped <$> tokenSpan DoubleColon <*> qualType)
  where mkTyped sp qty e = updateEndPos $ setSrcSpan (getSrcSpan e) $
          Typed (fromSrcInfoPoints [sp]) e qty

-- expr0 ::= expr1 { infixOp expr1 }
expr0 :: Parser a Token (Expression ())
expr0 = expr1 `chainr1` (mkInfixApply <$> infixOp)
  where mkInfixApply op e1 e2 = InfixApply
          (fromSrcSpan (combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2

-- expr1 ::= - expr2 | -. expr2 | expr2
expr1 :: Parser a Token (Expression ())
expr1 =  mkUnaryMinus <$> minus <*> expr2
     <|> expr2
  where mkUnaryMinus idt ex =
          let p = getPosition idt
              e = getSrcSpanEnd ex
              f = file p
          in UnaryMinus (SpanInfo (Span f p e) [Span f p (incr p 1)]) ex

-- expr2 ::= lambdaExpr | letExpr | doExpr | ifExpr | caseExpr | expr3
expr2 :: Parser a Token (Expression ())
expr2 = choice [ lambdaExpr, letExpr, doExpr, ifExpr, caseExpr
               , foldl1 mkApply <$> many1 expr3
               ]
  where mkApply e1 e2 = updateEndPos $ Apply (fromSrcSpan (getSrcSpan e1)) e1 e2

expr3 :: Parser a Token (Expression ())
expr3 = foldl mkRecordUpdate <$> expr4 <*> many recUpdate
  where recUpdate = layoutOff <-*> bracesSp (field expr0 `sepBy1Sp` comma)
        mkRecordUpdate e ((fs,ss), sp1, sp2) = updateEndPos $
          setSrcInfoPoints (sp1 : (ss ++ [sp2])) $
          RecordUpdate (fromSrcSpan (getSrcSpan e)) e fs

expr4 :: Parser a Token (Expression ())
expr4 = choice
  [constant, anonFreeVariable, variable, parenExpr, listExpr]

constant :: Parser a Token (Expression ())
constant = mkLiteral <$> spanPosition <*> literal
  where mkLiteral sp = Literal (fromSrcSpan sp) ()

anonFreeVariable :: Parser a Token (Expression ())
anonFreeVariable =  (\ p v -> mkVariable $ qualify $ addPositionIdent p v)
                <$> position <*> anonIdent
  where mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid

variable :: Parser a Token (Expression ())
variable = qFunId <**> optRecord
  where optRecord = mkRecord <$> fieldsSp expr0 `opt` mkVariable
        mkRecord ((fs,ss), sp1, sp2) qid =
          let spi = SpanInfo (getSrcSpan qid) (sp1 : (ss ++ [sp2]))
          in updateEndPos $ Record spi () qid fs
        mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid

parenExpr :: Parser a Token (Expression ())
parenExpr = fmap updateSpanWithBrackets (parensSp pExpr)
  where
  pExpr = minus <**> minusOrTuple
      <|> mkConstructor () <$> tupleCommas
      <|> leftSectionOrTuple <\> minus
      <|> opOrRightSection <\> minus
      `opt` Constructor (fromSrcInfoPoints []) () qUnitId
  minusOrTuple = mkUnaryMinus <$> expr1 <.> infixOrTuple
            `opt` mkVariable . qualify
  leftSectionOrTuple = expr1 <**> infixOrTuple
  infixOrTuple = ($ updateEndPos) <$> infixOrTuple'
  infixOrTuple' = infixOp <**> leftSectionOrExp
              <|> (.) <$> (optType <.> tupleExpr)
  leftSectionOrExp = expr1 <**> (infixApp <$> infixOrTuple')
                `opt` leftSection
  optType   = mkTyped <$> tokenSpan DoubleColon <*> qualType `opt` id
  tupleExpr = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> expr)
               `opt` Paren NoSpanInfo
  opOrRightSection =  qFunSym <**> optRightSection
                  <|> colon   <**> optCRightSection
                  <|> infixOp <\> colon <\> qFunSym <**> rightSection
  optRightSection  = (. InfixOp ()    ) <$> rightSection
                       `opt` Variable NoSpanInfo ()
  optCRightSection = (. InfixConstr ()) <$> rightSection
                       `opt` Constructor NoSpanInfo ()
  rightSection     = mkRightSection <$> expr0
  infixApp f e2 op g e1 = f (g . mkInfixApply e1 op) e2
  leftSection op f e = mkLeftSection (f e) op
  mkTuple ses e = let (ss,es) = unzip ses
                  in Tuple (fromSrcInfoPoints ss) (e:es)
  mkConstructor = Constructor NoSpanInfo
  mkTyped sp ty e = Typed (fromSrcInfoPoints [sp]) e ty
  mkRightSection = flip (RightSection NoSpanInfo)
  mkLeftSection  = LeftSection  NoSpanInfo
  mkInfixApply e1 op e2 = InfixApply (fromSrcSpan
    (combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2
  mkVariable = Variable NoSpanInfo ()
  mkUnaryMinus ex idt =
    let p = getPosition idt
        e = getSrcSpanEnd ex
        f = file p
    in UnaryMinus (SpanInfo (Span f p e) [Span f p (incr p 1)]) ex

infixOp :: Parser a Token (InfixOp ())
infixOp = InfixOp () <$> qfunop <|> InfixConstr () <$> colon

listExpr :: Parser a Token (Expression ())
listExpr = updateSpanWithBrackets <$>
             bracketsSp (elements `opt` List (fromSrcInfoPoints []) () [])
  where
  elements = expr <**> rest
  rest = comprehension
      <|> enumeration mkEnumFromTo mkEnumFrom
      <|> (tokenSpan Comma <**> (expr <**>(
           enumeration mkEnumFromThenTo mkEnumFromThen
          <|> list <$> many ((,) <$> tokenSpan Comma <*> expr)))
    `opt` (\ e -> List (fromSrcInfoPoints []) () [e]))
  comprehension = mkListCompr <$> tokenSpan Bar <*> quals
  enumeration enumTo enum =
    tokenSpan DotDot <**> (enumTo <$> expr `opt` enum)

  mkEnumFrom                 sp     =
    EnumFrom (fromSrcInfoPoints [sp])
  mkEnumFromTo            e1 sp  e2 =
    EnumFromTo (fromSrcInfoPoints [sp]) e2 e1
  mkEnumFromThen      sp1 e1 sp2 e2 =
    EnumFromThen (fromSrcInfoPoints [sp2,sp1]) e2 e1
  mkEnumFromThenTo e1 sp1 e2 sp2 e3 =
    EnumFromThenTo (fromSrcInfoPoints [sp2,sp1]) e3 e2 e1
  mkListCompr sp qu e = ListCompr (fromSrcInfoPoints [sp]) e qu

  list xs e2 sp e1 = let (ss, es) = unzip xs
                     in List (fromSrcInfoPoints (sp:ss)) () (e1:e2:es)

updateSpanWithBrackets :: HasSpanInfo a => (a, Span, Span) -> a
updateSpanWithBrackets (ex, sp1, sp2) =
  let ss = getSrcInfoPoints ex
      s  = getPosition sp1
      e  = end sp2
      f  = file s
      spi = SpanInfo (Span f s e) (sp1 : (ss ++ [sp2]))
  in setSpanInfo spi ex

lambdaExpr :: Parser a Token (Expression ())
lambdaExpr = mkLambda <$> tokenSpan Backslash <*> many1 pattern2
                      <*> spanPosition <*-> expectRightArrow
                      <*> expr
  where mkLambda sp1 ps sp2 e = updateEndPos $ Lambda (SpanInfo sp1 [sp1, sp2]) ps e

letExpr :: Parser a Token (Expression ())
letExpr = mkLet <$>  tokenSpan KW_let <*> layout valueDecls
                <*> (tokenSpan KW_in <?> "in expected") <*> expr
  where mkLet sp1 ds sp2 e = updateEndPos $ Let (SpanInfo sp1 [sp1, sp2]) ds e

doExpr :: Parser a Token (Expression ())
doExpr = mkDo <$> tokenSpan KW_do <*> layout stmts
  where mkDo sp (stms, ex) = updateEndPos $ Do (SpanInfo sp [sp]) stms ex

ifExpr :: Parser a Token (Expression ())
ifExpr = mkIfThenElse
    <$>  tokenSpan KW_if                        <*> expr
    <*> (tokenSpan KW_then <?> "then expected") <*> expr
    <*> (tokenSpan KW_else <?> "else expected") <*> expr
  where mkIfThenElse sp1 e1 sp2 e2 sp3 e3 = updateEndPos $
          IfThenElse (SpanInfo sp1 [sp1, sp2, sp3]) e1 e2 e3

caseExpr :: Parser a Token (Expression ())
caseExpr = (mkCase Flex  <$> tokenSpan KW_fcase
        <|> mkCase Rigid <$> tokenSpan KW_case)
          <*> expr
          <*> (tokenSpan KW_of <?> "of expected")
          <*> layout (alt `sepBy1` semicolon)
  where mkCase ct sp1 e sp2 = updateEndPos . Case (SpanInfo sp1 [sp1, sp2]) ct e

alt :: Parser a Token (Alt ())
alt = mkAlt <$> spanPosition <*> pattern0
            <*> spanPosition <*> rhs expectRightArrow
  where mkAlt sp1 p sp2 = updateEndPos . Alt (SpanInfo sp1 [sp2]) p

fieldsSp :: Parser a Token b -> Parser a Token (([Field b], [Span]), Span, Span)
fieldsSp p = layoutOff <-*> bracesSp (field p `sepBySp` comma)

field :: Parser a Token b -> Parser a Token (Field b)
field p = mkField <$> spanPosition <*> qfun
                  <*> spanPosition <*-> expectEquals
                  <*> p
  where mkField sp1 q sp2 = updateEndPos . Field (SpanInfo sp1 [sp2]) q

-- ---------------------------------------------------------------------------
-- \paragraph{Statements in list comprehensions and \texttt{do} expressions}
-- Parsing statements is a bit difficult because the syntax of patterns
-- and expressions largely overlaps. The parser will first try to
-- recognize the prefix \emph{Pattern}~\texttt{<-} of a binding statement
-- and if this fails fall back into parsing an expression statement. In
-- addition, we have to be prepared that the sequence
-- \texttt{let}~\emph{LocalDefs} can be either a let-statement or the
-- prefix of a let expression.
-- ---------------------------------------------------------------------------

stmts :: Parser a Token ([Statement ()], Expression ())
stmts = stmt reqStmts optStmts

reqStmts :: Parser a Token (Statement () -> ([Statement ()], Expression ()))
reqStmts = (\ (sts, e) st -> (st : sts, e)) <$-> semicolon <*> stmts

optStmts :: Parser a Token (Expression () -> ([Statement ()], Expression ()))
optStmts = succeed mkStmtExpr <.> reqStmts `opt` (,) []
  where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e

quals :: Parser a Token [Statement ()]
quals = stmt (succeed id) (succeed mkStmtExpr) `sepBy1` comma
  where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e

stmt :: Parser a Token (Statement () -> b)
     -> Parser a Token (Expression () -> b) -> Parser a Token b
stmt stmtCont exprCont =  letStmt stmtCont exprCont
                      <|> exprOrBindStmt stmtCont exprCont

letStmt :: Parser a Token (Statement () -> b)
        -> Parser a Token (Expression () -> b) -> Parser a Token b
letStmt stmtCont exprCont = ((,) <$> tokenSpan KW_let <*> layout valueDecls)
                              <**> optExpr
  where optExpr =  let' <$> tokenSpan KW_in <*> expr <.> exprCont
               <|> succeed stmtDecl' <.> stmtCont
          where
            let' sp1 e (sp2, ds) = updateEndPos $
              Let (SpanInfo sp2 [sp2, sp1]) ds e
            stmtDecl'  (sp2, ds) = updateEndPos $
              StmtDecl (SpanInfo sp2 [sp2]) ds

exprOrBindStmt :: Parser a Token (Statement () -> b)
               -> Parser a Token (Expression () -> b)
               -> Parser a Token b
exprOrBindStmt stmtCont exprCont =
       stmtBind' <$> spanPosition <*> pattern0 <*> tokenSpan LeftArrow <*> expr
         <**> stmtCont
  <|?> expr <\> token KW_let <**> exprCont
  where
    stmtBind' sp1 p sp2 e = updateEndPos $
      StmtBind (SpanInfo sp1 [sp2]) p e

-- ---------------------------------------------------------------------------
-- Goals
-- ---------------------------------------------------------------------------

goal :: Parser a Token (Goal ())
goal = mkGoal <$> spanPosition <*> expr <*> spanPosition <*> localDecls
  where mkGoal sp1 ex sp2 ds = updateEndPos $
          Goal (SpanInfo sp1 [sp2]) ex ds

-- ---------------------------------------------------------------------------
-- Literals, identifiers, and (infix) operators
-- ---------------------------------------------------------------------------

char :: Parser a Token Char
char = cval <$> token CharTok

float :: Parser a Token Double
float = fval <$> token FloatTok

int :: Parser a Token Int
int = fromInteger <$> integer

integer :: Parser a Token Integer
integer = ival <$> token IntTok

string :: Parser a Token String
string = sval <$> token StringTok

tycon :: Parser a Token Ident
tycon = conId

anonOrTyvar :: Parser a Token Ident
anonOrTyvar = anonIdent <|> tyvar

tyvar :: Parser a Token Ident
tyvar = varId

clsvar :: Parser a Token Ident
clsvar = tyvar

tycls :: Parser a Token Ident
tycls = conId

qtycls :: Parser a Token QualIdent
qtycls = qConId

qtycon :: Parser a Token QualIdent
qtycon = qConId

varId :: Parser a Token Ident
varId = ident

funId :: Parser a Token Ident
funId = ident

conId :: Parser a Token Ident
conId = ident

funSym :: Parser a Token Ident
funSym = sym

conSym :: Parser a Token Ident
conSym = sym

modIdent :: Parser a Token ModuleIdent
modIdent = mIdent <?> "module name expected"

var :: Parser a Token Ident
var = varId <|> updateSpanWithBrackets
                     <$> parensSp (funSym <?> "operator symbol expected")

fun :: Parser a Token Ident
fun = funId <|> updateSpanWithBrackets
                     <$> parensSp (funSym <?> "operator symbol expected")

con :: Parser a Token Ident
con = conId <|> updateSpanWithBrackets
                     <$> parensSp (conSym <?> "operator symbol expected")

funop :: Parser a Token Ident
funop = funSym <|> updateSpanWithBrackets
                     <$> backquotesSp (funId <?> "operator name expected")

conop :: Parser a Token Ident
conop = conSym <|> updateSpanWithBrackets
                     <$> backquotesSp (conId <?> "operator name expected")

qFunId :: Parser a Token QualIdent
qFunId = qIdent

qConId :: Parser a Token QualIdent
qConId = qIdent

qFunSym :: Parser a Token QualIdent
qFunSym = qSym

qConSym :: Parser a Token QualIdent
qConSym = qSym

gConSym :: Parser a Token QualIdent
gConSym = qConSym <|> colon

qfun :: Parser a Token QualIdent
qfun = qFunId <|> updateSpanWithBrackets
                     <$> parensSp (qFunSym <?> "operator symbol expected")

qfunop :: Parser a Token QualIdent
qfunop = qFunSym <|> updateSpanWithBrackets
                     <$> backquotesSp (qFunId <?> "operator name expected")

gconop :: Parser a Token QualIdent
gconop = gConSym <|> updateSpanWithBrackets
                     <$> backquotesSp (qConId <?> "operator name expected")

anonIdent :: Parser a Token Ident
anonIdent = ((`setSpanInfo` anonId) . fromSrcSpanBoth) <$> tokenSpan Underscore

mIdent :: Parser a Token ModuleIdent
mIdent = mIdent' <$> spanPosition <*>
     tokens [Id,QId,Id_as,Id_ccall,Id_forall,Id_hiding,
             Id_interface,Id_primitive,Id_qualified]
  where mIdent' sp a = ModuleIdent (fromSrcSpanBoth sp) (modulVal a ++ [sval a])

ident :: Parser a Token Ident
ident = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t)))
          <$> spanPosition <*> tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding,
                                       Id_interface,Id_primitive,Id_qualified]

qIdent :: Parser a Token QualIdent
qIdent = qualify <$> ident <|> qIdentWith QId

sym :: Parser a Token Ident
sym = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t)))
        <$> spanPosition <*> tokens [Sym, SymDot, SymMinus, SymStar]

qSym :: Parser a Token QualIdent
qSym = qualify <$> sym <|> qIdentWith QSym

qIdentWith :: Category -> Parser a Token QualIdent
qIdentWith c = mkQIdent <$> spanPosition <*> token c
  where mkQIdent :: Span -> Attributes -> QualIdent
        mkQIdent sp a =
          let mid  = ModuleIdent (fromSrcSpan sp) (modulVal a)
              p    = incr (getPosition sp) (mIdentLength mid - 1)
              mid' = setEndPosition p mid
              idt  = setSrcSpan sp $ mkIdent (sval a)
              idt' = setPosition (incr p 1) idt
          in QualIdent (fromSrcSpanBoth sp) (Just mid') idt'

colon :: Parser a Token QualIdent
colon = (qualify . (`setSpanInfo` consId) . fromSrcSpanBoth) <$> tokenSpan Colon

minus :: Parser a Token Ident
minus = ((`setSpanInfo` minusId) . fromSrcSpanBoth) <$> tokenSpan SymMinus

tupleCommas :: Parser a Token QualIdent
tupleCommas = (\ sp ss -> qualify $ updateEndPos $ setSpanInfo (SpanInfo sp ss)
                                  $ tupleId      $ succ $ length  ss)
              <$> spanPosition <*> many1 (tokenSpan Comma)

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

-- |This function starts a new layout block but does not wait for its end.
-- This is only used for parsing the module header.
startLayout :: Parser a Token b -> Parser a Token b
startLayout p = layoutOff <-*> leftBrace <-*> p
             <|> layoutOn <-*> p

layout :: Parser a Token b -> Parser a Token b
layout p =  layoutOff <-*> braces p
        <|> layoutOn  <-*> p <*-> (token VRightBrace <|> layoutEnd)

-- ---------------------------------------------------------------------------
-- Bracket combinators
-- ---------------------------------------------------------------------------

braces :: Parser a Token b -> Parser a Token b
braces p = between leftBrace p rightBrace

bracesSp :: Parser a Token b -> Parser a Token (b, Span, Span)
bracesSp p = (\sp1 b sp2 -> (b, sp1, sp2))
               <$> tokenSpan LeftBrace
               <*> p
               <*> tokenSpan RightBrace

bracketsSp :: Parser a Token b -> Parser a Token (b, Span, Span)
bracketsSp p = (\sp1 b sp2 -> (b, sp1, sp2))
                 <$> tokenSpan LeftBracket
                 <*> p
                 <*> tokenSpan RightBracket

parens :: Parser a Token b -> Parser a Token b
parens p = between leftParen p rightParen

parensSp :: Parser a Token b -> Parser a Token (b, Span, Span)
parensSp p = (\sp1 b sp2 -> (b, sp1, sp2))
               <$> tokenSpan LeftParen
               <*> p
               <*> tokenSpan RightParen

backquotes :: Parser a Token b -> Parser a Token b
backquotes p = between backquote p expectBackquote

backquotesSp :: Parser a Token b -> Parser a Token (b, Span, Span)
backquotesSp p = (\sp1 b sp2 -> (b, sp1, sp2))
                   <$> tokenSpan Backquote
                   <*> p
                   <*> spanPosition <*-> expectBackquote

-- ---------------------------------------------------------------------------
-- Simple token parsers
-- ---------------------------------------------------------------------------

token :: Category -> Parser a Token Attributes
token c = attr <$> symbol (Token c NoAttributes)
  where attr (Token _ a) = a

tokens :: [Category] -> Parser a Token Attributes
tokens = foldr1 (<|>) . map token

tokenPos :: Category -> Parser a Token Position
tokenPos c = position <*-> token c

tokenSpan :: Category -> Parser a Token Span
tokenSpan c = spanPosition <*-> token c

tokenOps :: [(Category, b)] -> Parser a Token b
tokenOps cs = ops [(Token c NoAttributes, x) | (c, x) <- cs]

comma :: Parser a Token Attributes
comma = token Comma

semicolon :: Parser a Token Attributes
semicolon = token Semicolon <|> token VSemicolon

bar :: Parser a Token Attributes
bar = token Bar

equals :: Parser a Token Attributes
equals = token Equals

expectEquals :: Parser a Token Attributes
expectEquals = equals <?> "= expected"

expectWhere :: Parser a Token Attributes
expectWhere = token KW_where <?> "where expected"

expectRightArrow :: Parser a Token Attributes
expectRightArrow  = token RightArrow <?> "-> expected"

backquote :: Parser a Token Attributes
backquote = token Backquote

expectBackquote :: Parser a Token Attributes
expectBackquote = backquote <?> "backquote (`) expected"

leftParen :: Parser a Token Attributes
leftParen = token LeftParen

rightParen :: Parser a Token Attributes
rightParen = token RightParen

leftBrace :: Parser a Token Attributes
leftBrace = token LeftBrace

rightBrace :: Parser a Token Attributes
rightBrace = token RightBrace