{
{-# LANGUAGE FlexibleContexts, FlexibleInstances, ViewPatterns #-}
module Frontend.Autogen.Parser where

import qualified Data.Text as T
import Data.Maybe

import Frontend.Lexer.Wrapper
import Frontend.Lexer.Tokens
import Frontend.Parser.Posn
import Frontend.Syntax
import Frontend.Autogen.Lexer

import qualified Prelude
import Prelude hiding (span)

import Debug.Trace

import Control.Monad
}

%name parseExp Exp
%name parseMod Module
%name parseType Type

%tokentype { Token }

%monad { Alex }
%lexer { lexer } { Token TokEof _ _ }

%errorhandlertype explist
%error { parseError }

%token
  VAR         { Token (TokUnqual VarId _) _ _ }
  CON         { Token (TokUnqual ConId _) _ _ }

  QVAR        { Token (TokQual VarId _ _) _ _ }
  QCON        { Token (TokQual ConId _ _) _ _ }
  STRING      { Token (TokString _) _ _ }
  'eof'       { Token TokEof _ _ }

  '('         { Token TokOParen _ _ }
  ')'         { Token TokCParen _ _ }

  '{'         { Token TokOBrace _ _ }
  '}'         { Token TokCBrace _ _ }

  START       { Token TokLStart _ _ }
  END         { Token TokLEnd   _ _ }

  '['         { Token TokOSquare _ _ }
  ']'         { Token TokCSquare _ _ }

  '{-#'       { Token TokOPragma _ _ }
  '#-}'       { Token TokCPragma _ _ }

  '\\'        { Token TokLambda _ _ }
  
  '->'        { Token TokArrow _ _ }
  '_'         { Token TokUnder _ _ }
  '::'        { Token TokDoubleColon _ _ }
  ';'         { Token TokSemi  _ _ }
  '='         { Token TokEqual _ _ }
  ','         { Token TokComma _ _ }

  'let'       { Token TokLet _ _ }
  'in'        { Token TokIn _ _ }
  'data'      { Token TokData _ _ }
  'case'      { Token TokCase _ _ }
  'module'    { Token TokModule _ _ }
  'where'     { Token TokWhere _ _ }

  'import'    { Token TokImport _ _ }
  'as'        { Token TokAs _ _     }
  'qualified' { Token TokQualified _ _  }

%%

Exp :: { Exp }
  : InfixExp '::' Type { span $1 $3 $ Annot $1 $3 }
  | InfixExp           { $1 }

InfixExp :: { Exp }
  : LeftExp {- ... -} { $1 }
--  | LeftExp qop InfixExp { Infix $1 (getVar $2) $3 }

LeftExp :: { Exp }
  : '\\' Apat List(Apat) '->' Exp    { span $1 $5 (makeLams ($2:$3) $5) }
  | 'let' LaidOutList(Decl) 'in' Exp { span $1 $4 $ Let (thd $2) $4 }
  | FuncExp                          { $1 }

FuncExp :: { Exp }
  : FuncExp Aexp { span $1 $2 $ App $1 $2 }
  | Aexp         { $1 }

Aexp :: { Exp }
  : qvar                   { span $1 $1 $ Ref $1 }
  | qcon                   { span $1 $1 $ Con $1 }
  | '(' CommaList(Exp) ')' { span $1 $3 $ makeTuple $2 }
  | STRING                 { span $1 $1 $ Literal (LitString (getString $1)) }

Type :: { Type }
  : Btype '->' Type { span $1 $3 $ Tyarr $1 $3 }
  | Btype           { $1 }
  
Btype :: { Type }
  : Btype Atype { span $1 $2 $ Tyapp $1 $2 }
  | Atype       { $1 }
      
Atype :: { Type }
  : qvar                    { span $1 $1 $ Tyvar $1 }
  | qcon                    { span $1 $1 $ Tycon $1 }
  | '(' CommaList(Type) ')' { span $1 $3 $ makeTupleType $2 }

Pat :: { Pat }
  : Lpat { $1 }

Lpat :: { Pat }
  : Apat { $1 }

Apat :: { Pat }
  : VAR         { span $1 $1 $ Var (getVar $1) }
  | '_'         { span $1 $1 $ Wildcard }
  | '(' CommaList(Pat) ')' { span $1 $3 $ makeTuplePattern $2 }

Decl :: { Decl }
  : CommaList1(VAR) '::' Type  { TySig   (getVar `fmap` $1) $3 (startPosn (head $1)) (endPosn $3) }
  | VAR Apat List(Apat) Rhs    { FunDecl (getVar $1) ($2:$3) $4 (startPosn $1) (endPosn $4) }
  | Pat Rhs                    { PatDecl $1 $2 (startPosn $1) (endPosn $2) }

Rhs :: { Rhs }
  : '=' Exp                           { BareRhs $2 [] (startPosn $1) (endPosn $2) }
  | '=' Exp 'where' LaidOutList(Decl) { BareRhs $2 (thd $4) (startPosn $1) (endPosn $4) }

LaidOutList(p)
  : START Opt(Semis) LOLContents(p, END) { (startPosn $1, lolEnd $3, lolList $3) }
  | '{' Opt(Semis) LOLContents(p, '}')   { (startPosn $1, lolEnd $3, lolList $3) }

LOLContents(p, End)
  : p Semis LOLContents(p,End) { lolCons $1 $3            }
  | p Opt(Semis) End           { lolCons $1 (emptyLol $3) }
  | Opt(Semis)   End           { emptyLol $2              }

Module :: { Module }
  : 'module' CON ImportExportList 'where' LaidOutList(ModItem)
    {% do { (imports,items) <- spanModuleItems (thd $5)
          ; pure $ Module { moduleName    = toModId (getVar $2)
                          , moduleExports = fst $3
                          , moduleImports = imports
                          , moduleItems   = items }
          }
    }

ImportExportList :: { (Maybe [NamespacedItem ParsedVar], Maybe Posn) }
  : {-empty-}                 { (Nothing, Nothing) }
  | '(' CommaList(NSItem) ')' { (Just $2, Just (endPosn $3)) }

NSItem :: { NamespacedItem ParsedVar }
  : VAR          { IEVar (getVar $1) }
  | CON          { IECon (getVar $1) }
  | 'module' CON { IEModule (getVar $2) }

ModItem :: { Item }
  : Decl            { ModDecl $1 (startPosn $1) (endPosn $1) }
  | Import          { ModImport $1 (startPosn $1) (endPosn $1) } 

Import :: { ModuleImport ParsedVar }
  : 'import' modid ImportExportList
    { Import $2 (fst $3) False Nothing (startPosn $1) (fromMaybe (endPosn $2) (snd $3)) }

  | 'import' modid ImportExportList 'as' CON
    { Import $2 (fst $3) False (Just (getVar $5)) (startPosn $1) (endPosn $5) }
    
  | 'import' 'qualified' modid ImportExportList
    { Import $3 (fst $4) True Nothing (startPosn $1) (fromMaybe (endPosn $3) (snd $4)) }
    
  | 'import' 'qualified' modid ImportExportList 'as' CON
    { Import $3 (fst $4) True (Just (getVar $6)) (startPosn $1) (endPosn $6) }

Opt(p)
  :           { () }
  | p         { () }

Semis
  : ';' Semis { () }
  | ';'       { () }

-- TODO: qualified names
qvar :: { ParsedVar }
qvar : VAR  { getVar $1 }
     | QVAR { getVar $1 }

qcon : CON  { getVar $1 }
     | QCON { getVar $1 }

modid : qcon { toModId $1 }

List(p)
  : {-empty-} { [] }
  | p List(p) { $1:$2 }

CommaList(p)
  : {-empty-}          { [] }
  | p                  { [$1] }
  | p ',' CommaList(p) { $1:$3 }

CommaList1(p)
  : p                  { [$1] }
  | p ',' CommaList(p) { $1:$3 }

Block(p)
  : START p END { (startPosn $1, endPosn $3, $2) }
  | '{' p '}'   { (startPosn $1, endPosn $3, $2) }

{

type Exp    = FeExpr     ParsedVar
type Pat    = FePat      ParsedVar
type Decl   = FeDecl     ParsedVar
type Type   = FeType     ParsedVar
type Rhs    = FeRhs      ParsedVar
type Module = FeModule   ParsedVar
type Item   = ModuleItem ParsedVar

lexer cont = alexMonadScan >>= cont

parseError x = alexError (show x)

makeLams xs b = foldr Lam b xs

getVar :: Token -> ParsedVar
getVar tok@(Token (TokQual _ p s) _ _) = QualVar { varId = s, varPrefix = p, varBegin = startPosn tok, varEnd = endPosn tok }
getVar tok@(Token (TokUnqual _ s) _ _) = UnqualVar { varId = s, varBegin = startPosn tok, varEnd = endPosn tok }
getVar _ = error "getVar non-var"

getString (Token (TokString s) _ _) = s
getString _ = error "getString non-string"

data LOL a = LOL { lolEnd :: Posn, lolList :: [a] }

emptyLol :: HasPosn x => x -> LOL a
emptyLol t = LOL (endPosn t) []

lolCons :: a -> LOL a -> LOL a
lolCons x (LOL p xs) = LOL p (x:xs)

makeTupleType [x] = ParenType x
makeTupleType xs = Tytup xs

makeTuplePattern [x] = ParenPat x
makeTuplePattern xs = TupPat xs

makeTuple [x] = ParenExp x
makeTuple xs  = Tuple xs

spanModuleItems xs = do
  let
    isImport (ModImport _ _ _) = True
    isImport _ = False

    (imports, items) = Prelude.span isImport xs
  
  forM_ items $ \x -> case x of
    ModImport _ start end ->
      alexThrow $ \fname ->
        ParseError { parseErrorMessage    = "all import statements should be at the top of the file."
                   , parseErrorInlineDesc = Just "unexpected import statement"
                   , parseErrorFilename   = fname
                   , parseErrorBegin      = start
                   , parseErrorEnd        = end
                   }
    _ -> pure ()

  pure (map itemImport imports, items)
}