{
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}

module Earthling.Parser where

import Earthling.Types
import Earthling.Lexer

import           AlexTools
import           Data.Sequence (Seq)
import qualified Data.Sequence as S
import           Data.Text (Text)
}

%tokentype { Lexeme Tok }

%token
  IDENT    { (matchIdent -> Just $$) }
  CONSTR   { (matchConstr -> Just $$) }
  INT      { (matchInt -> Just $$) }
  DOUBLE   { (matchDouble -> Just $$) }
  STACKVAR { (matchStackVar -> Just $$) }

  "@def" { Lexeme { lexemeToken = TokKeyword "@def" } }
  "("    { Lexeme { lexemeToken = TokStructure SLParen } }
  ")"    { Lexeme { lexemeToken = TokStructure SRParen } }
  "["    { Lexeme { lexemeToken = TokStructure SLBrac } }
  "]"    { Lexeme { lexemeToken = TokStructure SRBrac } }
  "{"    { Lexeme { lexemeToken = TokStructure SLCurl } }
  "}"    { Lexeme { lexemeToken = TokStructure SRCurl } }
  "."    { Lexeme { lexemeToken = TokStructure SDot } }
  "->"   { Lexeme { lexemeToken = TokStructure SArrow } }


%monad { Parse }
%error { parseError }

%name decls decls

%%

decls :: { Seq (Decl Raw) }
  : list(decl) { $1 }

decl :: { Decl Raw }
  : "@def" IDENT wordType instrSeq { Decl (fst $2) $3 $4 }

instrSeq :: { Seq (Item Raw) }
instrSeq
  : "." { S.empty }
  | atom instrSeq { $1 S.<| $2 }

wordType :: { WordType }
wordType
  : "(" stackType "->" stackType ")"
    { WordType $2 $4 }

stackType :: { StackType }
stackType : stackBase list(itemType) { StackType $1 $2 }

stackBase :: { StackBase }
stackBase
  : "[" "]"  { EmptyStack }
  | STACKVAR { StackVar (fst $1) }

itemType :: { ItemType }
itemType
  : IDENT     { VarType (fst $1) }
  | CONSTR    { ConstrType (fst $1) }
  | wordType  { AtomType $1 }

atom :: { Item Raw }
atom
  : IDENT  { Item (AtomIdent (fst $1)) () }
  | CONSTR { Item (AtomConstr (fst $1)) () }
  | INT    { Item (AtomLiteral (IntLiteral (fst $1))) () }
  | DOUBLE { Item (AtomLiteral (DoubleLiteral (fst $1))) () }

-- utils

list(p) :: { Seq p }
  : {- empty -}   { S.empty }
  | list1(p)      { $1 }

list1(p) :: { Seq p }
  : p           { S.singleton $1 }
  | list1(p) p  { $1 S.|> $2 }

{

parseDecls :: Text -> Parse (Seq (Decl Raw))
parseDecls str = decls (lexer str)

type Parse = Either ParseError

data ParseError
  = ParseError (Maybe SourcePos) String
    deriving (Show)

parseError :: [Lexeme Tok] -> Parse a
parseError [] =  Left (ParseError Nothing "")
parseError (t:_) =
  Left (ParseError (Just (sourceFrom (lexemeRange t))) (show (lexemeToken t)))

matchIdent :: Lexeme Tok -> Maybe (Text, SourceRange)
matchIdent Lexeme
  { lexemeToken = TokIdent t
  , lexemeRange = r
  } = Just (t, r)
matchIdent _ = Nothing

matchConstr :: Lexeme Tok -> Maybe (Text, SourceRange)
matchConstr Lexeme
  { lexemeToken = TokConstr c
  , lexemeRange = r
  } = Just (c, r)
matchConstr _ = Nothing

matchInt :: Lexeme Tok -> Maybe (Integer, SourceRange)
matchInt Lexeme
  { lexemeToken = TokInt i
  , lexemeRange = r
  } = Just (i, r)
matchInt _ = Nothing

matchDouble :: Lexeme Tok -> Maybe (Double, SourceRange)
matchDouble Lexeme
  { lexemeToken = TokDouble d
  , lexemeRange = r
  } = Just (d, r)
matchDouble _ = Nothing

matchStackVar :: Lexeme Tok -> Maybe (Text, SourceRange)
matchStackVar Lexeme
  { lexemeToken = TokStackVar d
  , lexemeRange = r
  } = Just (d, r)
matchStackVar _ = Nothing

}
