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

import qualified Data.Text as T
import Data.Maybe

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

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 _ _) _ _ }

  VARSYM      { Token (TokUnqualOp VarId _) _ _ }
  CONSYM      { Token (TokUnqualOp ConId _) _ _ }

  QVARSYM     { Token (TokQualOp VarId _ _) _ _ }
  QCONSYM     { Token (TokQualOp 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 _ _ }
  '`'         { Token TokTick _ _ }

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

  'import'    { Token TokImport _ _ }
  'as'        { Token TokAs _ _     }
  'qualified' { Token TokQualified _ _  }
  
  'foreign'   { Token TokForeign _ _ }
  'export'    { Token TokExport _ _ }
  'safe'      { Token TokSafe _ _ }
  'unsafe'    { Token TokUnsafe _ _ }
  'ccall'     { Token TokCCall _ _ }

%%

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

InfixExp :: { Exp }
  : LeftExp {- ... -}   { $1 }
  | LeftExp qop InfixExp { span $1 $3 $ Infix $1 $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 }
  | gcon                    { span $1 $1 $ Con $1 }
  | '(' CommaList1(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 }
  | gtycon                   { span $1 $1 $ Tycon $1 }
  | '[' Type ']'             { span $1 $3 $ Tylist $2 }
  | '(' CommaList1(Type) ')' { span $1 $3 $ makeTupleType $2 }

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

Lpat :: { Pat }
  : Apat                 { $1 }
  | gcon Apat List(Apat) { span $1 (endOfListPos $2 $3) (ConPat $1 ($2 : $3)) }
  | Lpat qconop Pat      { span $1 $3 $ InfixPat $1 $2 $3 }

Apat :: { Pat }
  : VAR         { span $1 $1 $ Var (getVar $1) }
  | gcon        { span $1 $1 $ ConPat $1 [] }
  | '_'         { span $1 $1 $ Wildcard }
  | '(' CommaList1(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) } 
  | 'foreign' FfiItem { ModFfi $2 (startPosn $1) (endPosn $2) }

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) }

FfiItem :: { FfiItem ParsedVar }
  : 'import' CallConv Safety Entity VAR '::' Type
  -- 1       2        3      4      5   6    7
    {% do { ffiDesc <- traverse parseForeignItem $4
          ; pure $ FfiImport
            { fiVarName  = getVar $5
            , fiType     = $7
            , fiCallConv = $2
            , fiSafety   = $3
            , fiItem     = ffiDesc
            , fiBegin    = startPosn $1
            , fiEnd      = endPosn $7 }
          } }

Safety :: { Maybe FfiSafety }
  : {-empty-} { Nothing }
  | 'safe'    { Just Safe }
  | 'unsafe'  { Just Unsafe }

CallConv :: { FfiCallConv }
  : 'ccall' { CC_CCall }

Entity :: { Maybe Token }
  : {-empty-} { Nothing }
  | STRING    { Just $1 }

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

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

qvarid :: { ParsedVar }
qvarid
  : VAR  { getVar $1 }
  | QVAR { getVar $1 }

qvar :: { ParsedVar }
  : qvarid          { $1 }
  | '(' qvarsym ')' { span $1 $3 $2 }

qconid :: { ParsedVar }
qconid
  : CON  { getVar $1 }
  | QCON { getVar $1 }

qcon :: { ParsedVar }
qcon
  : qconid          { $1 }
  | '(' qconsym ')' { span $1 $3 $2 }

qvarsym :: { ParsedVar }
qvarsym : VARSYM  { getVar $1 }
        | QVARSYM { getVar $1 }

qconsym :: { ParsedVar }
qconsym : CONSYM  { getVar $1 }
        | QCONSYM { getVar $1 }

qvarop :: { ParsedVar }
  : qvarsym      { $1 }
  | '`' qvar '`' { span $1 $3 $2 }

qconop :: { ParsedVar }
  : qconsym      { $1 }
  | '`' qcon '`' { span $1 $3 $2 }

qop :: { ParsedVar }
  : qvarop { $1 }
  | qconop { $1 }

gcon :: { ParsedVar }
  : qcon           { $1 }
  | '(' Commas ')' { BuiltinId { varId       = tupleConSymName $2
                               , varBuiltin  = BuiltinTuple $2
                               , varBegin    = startPosn $1
                               , varEnd      = endPosn $3 }
                   }

  | '[' ']'        { BuiltinId { varId       = T.pack "[]"
                               , varBuiltin  = BuiltinNil
                               , varBegin    = startPosn $1
                               , varEnd      = endPosn $2 }
                   }

gtycon :: { ParsedVar }
  : gcon         { $1 }
  | '(' '->' ')' { BuiltinId { varId       = T.pack "[]"
                             , varBuiltin  = BuiltinArrow
                             , varBegin    = startPosn $1
                             , varEnd      = endPosn $2 }
                   }

Commas :: { Int }
  : {- empty -} { 0 }
  | ',' Commas  { (let x = $2 in x `seq` 1 + x) }

modid : qconid { 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 (token, expected) = do
  (here, _, _, _) <- alexGetInput
  alexThrow $ \fn -> ParseError { parseErrorMessage    = "expecting one of: " ++ unwords expected
                                , parseErrorInlineDesc = Just ("unexpected " ++ show (tokenClass token))
                                , parseErrorBegin      = startPosn token
                                , parseErrorEnd        = here
                                , parseErrorFilename   = fn }

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 tok@(Token (TokQualOp _ p s) _ _) = QualVar { varId = s, varPrefix = p, varBegin = startPosn tok, varEnd = endPosn tok }
getVar tok@(Token (TokUnqualOp _ 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] =
  case x of
    SPType ParenType{} _ _ -> x
    _ -> ParenType x
makeTupleType xs = Tytup xs

makeTuplePattern [x] =
  case x of
    SPPat ParenPat{} _ _ -> x
    _ -> ParenPat x
makeTuplePattern xs = TupPat xs

makeTuple [x] =
  case x of
    SPExpr ParenExp{} _ _ -> 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)

tupleConSymName :: Int -> T.Text
tupleConSymName n = T.singleton '(' <> T.replicate n (T.singleton ',') <> T.singleton ')'

endOfListPos :: HasPosn x => x -> [x] -> Posn
endOfListPos x [] = endPosn x
endOfListPos _ xs = endPosn (last xs)

}