-- Copyright (c) Facebook, Inc. and its affiliates.

{

module Thrift.Compiler.Parser
  ( parseThrift, runParser
  , parse, parseString
  , ThriftFile(..), Header(..), Decl(..), getModuleName
  ) where

import Prelude hiding (Enum)
import Data.Bifunctor
import Data.Maybe
import Data.Some
import Data.Text (Text)
import qualified Data.Text as Text
import System.FilePath

import Thrift.Compiler.Lexer
import Thrift.Compiler.Options
import Thrift.Compiler.Types

}

%name parseStatements
%tokentype { Token }
%lexer { lexWrap } { EOF }
%monad { Parser } { bind } { return }

%error { parseError }

%token struct      { Tok STRUCT _ }
       typedef     { Tok TYPEDEF _ }
       enum        { Tok ENUM _ }
       const       { Tok CONST _ }
       required    { Tok REQUIRED _ }
       optional    { Tok OPTIONAL _ }
       map         { Tok MAP _ }
       list        { Tok LIST _ }
       set         { Tok SET _ }
       byte        { Tok INT8 _ }
       i16         { Tok INT16 _ }
       i32         { Tok INT32 _ }
       i64         { Tok INT64 _ }
       double      { Tok DOUBLE _ }
       float       { Tok FLOAT _ }
       bool        { Tok BOOL _ }
       true        { Tok TRUE _ }
       false       { Tok FALSE _ }
       string      { Tok STRING _ }
       namespace   { Tok NAMESPACE _ }
       include     { Tok INCLUDE _ }
       hs_include  { Tok HS_INCLUDE _ }
       cpp_include { Tok CPP_INCLUDE _ }
       hash_map    { Tok HASH_MAP _ }
       hash_set    { Tok HASH_SET _ }
       intTok      { Tok INTEGRAL{} _ }
       doubleTok   { Tok FLOATING{} _ }
       stringTok   { Tok STRING_LIT{} _ }
       symTok      { Tok SYMBOL{} _ }
       '{'         { Tok L_CURLY_BRACE _ }
       '}'         { Tok R_CURLY_BRACE _ }
       '['         { Tok L_SQUARE_BRACE _ }
       ']'         { Tok R_SQUARE_BRACE _ }
       '<'         { Tok L_ANGLE_BRACE _ }
       '>'         { Tok R_ANGLE_BRACE _ }
       '('         { Tok L_PAREN _ }
       ')'         { Tok R_PAREN _ }
       ','         { Tok COMMA _ }
       ';'         { Tok SEMICOLON _ }
       ':'         { Tok COLON _ }
       '='         { Tok EQUALS _ }
       '@'         { Tok AT _ }
       -- Tokens for unused syntax
       package     { Tok PACKAGE _ }
       binary      { Tok BINARY _ }
       senum       { Tok SENUM _ }
       stream      { Tok STREAM _ }
       interaction { Tok INTERACTION _ }
       void        { Tok VOID _ }
       union       { Tok UNION _ }
       view        { Tok VIEW _ }
       exception   { Tok EXCEPTION _ }
       service     { Tok SERVICE _ }
       oneway      { Tok ONEWAY _ }
       extends     { Tok EXTENDS _ }
       performs    { Tok PERFORMS _ }
       throws      { Tok THROWS _ }
       safe        { Tok SAFE _ }
       transient   { Tok TRANSIENT _ }
       stateful    { Tok STATEFUL _ }
       permanent   { Tok PERMANENT _ }
       server      { Tok SERVER _ }
       client      { Tok CLIENT _ }
       readonly    { Tok READONLY _ }
       idempotent { Tok IDEMPOTENT _ }

-- Shift/reduce conflicts
-- - UntypedConst needs to parse both an identifier and a struct which begins with an identifier
%expect 1
-- - "oneway" can be both a function qualifier and an identifier, so "oneway fn_return_type"
--   is ambiguous - we want to always treat it as a qualifier if possible though. Ditto the
--   idempotency keywords.
%right SKIP_ONEWAY oneway
%right SKIP_IDEMPOTENCY readonly idempotent

%%
Thrift :: { [ParsedStatement] }
Thrift : list(Statement) { catMaybes $1 }

Statement :: { Maybe ParsedStatement }
  : Header { fmap StatementHeader $1 }
  | Decl { fmap StatementDecl $1 }

Header :: { Maybe (Parsed Header) }
  : Include stringLit
    { Just HInclude
      { incPath = Text.unpack (lParsed $2)
      , incType = lVal $1
      , incKeywordLoc = lLoc $1
      , incPathLoc    = lLoc $2
      , incQuoteType  = lRep $2
      }
    }
  | namespace Symbol SymbolOrString
    { Just HNamespace
      { nmLang = lVal $2
      , nmName = lParsed $3
      , nmKeywordLoc = getLoc $1
      , nmLangLoc    = lLoc $2
      , nmNameLoc    = lLoc $3
      , nmQuoteType  = lRep $3
      }
    }
  | StructuredAnnotations package stringLit
    { Just HPackage
      { pkgUri = lParsed $3
      , pkgKeywordLoc = getLoc $2
      , pkgUriLoc     = lLoc $3
      , pkgQuoteType  = lRep $3
      , pkgSAnns      = $1
      }
    }

Include
  : include     { L (getLoc $1) Include }
  | hs_include  { L (getLoc $1) HsInclude }
  | cpp_include { L (getLoc $1) CppInclude }

SymbolOrString
  : stringLit { fmap (second Just) $1 }
  | Symbol    { fmap (,Nothing) $1 }

Decl :: { Maybe (Parsed Decl) }
  : Struct  { Just $ D_Struct $1 }
  | Union   { Just $ D_Union $1 }
  | Typedef { Just $ D_Typedef $1 }
  | Enum    { Just $ D_Enum $1 }
  | Const   { Just $ D_Const $1 }
  | Service { Just $ D_Service $1 }
  | Interaction { Just $ D_Interaction $1 }
  | UnusedDecl { Nothing }

-- Structs ---------------------------------------------------------------------

Struct :: { Parsed Struct }
Struct
  : StructuredAnnotations ErrorClassifications StructType Symbol '{' list(Field) '}' Annotations
    { Struct
      { structName         = lVal $4
      , structResolvedName = ()
      , structType         = lVal $3
      , structMembers      = filterHiddenFields $6
      , structLoc          = StructLoc
        { slKeyword    = lLoc $3
        , slName       = lLoc $4
        , slOpenBrace  = getLoc $5
        , slCloseBrace = getLoc $7
        }
      , structAnns           = $8
      , structSAnns          = $1
      , errorClassifications = $2
      }
    }

StructType
  : struct    { L (getLoc $1) StructTy }
  | exception { L (getLoc $1) ExceptionTy }

Field :: { Parsed (Field 'StructField) }
Field : StructuredAnnotations intLit ':' Req AnnotatedType Symbol MaybeConst Annotations Separator
        { case $5 of
            Some t -> Field
              { fieldId           = fromIntegral $ lParsed $2
              , fieldName         = lVal $6
              , fieldResolvedName = ()
              , fieldType         = t
              , fieldResolvedType = ()
              , fieldVal          = fmap lVal $7
              , fieldResolvedVal  = ()
              , fieldRequiredness = $4
              , fieldLaziness     = Lazy
              , fieldTag          = STRUCT_FIELD
              , fieldLoc          = FieldLoc
                { flId        = lLoc $2
                , flIdRep     = lRep $2
                , flColon     = getLoc $3
                , flName      = lLoc $6
                , flEqual     = fmap lLoc $7
                , flSeparator = $9
                }
              , fieldAnns         = $8
              , fieldSAnns        = $1
              }
        }

Req :: { Requiredness 'StructField Loc }
Req : {- empty -}    { Default }
    | optional       { Optional $ getLoc $1 }
    | required       { Required $ getLoc $1 }

MaybeConst : {- empty -}      { Nothing }
           | '=' UntypedConst { Just $ L (getLoc $1) $2 }

ErrorClassifications : list(ErrorClassification) { $1 }

ErrorClassification
  : ErrorClassificationKeyword
    { ErrorClassification
      { ecType = lVal $1
      , ecKeywordLoc = lLoc $1
      }
    }

ErrorClassificationKeyword
  : safe       { L (getLoc $1) EcSafe }
  | transient  { L (getLoc $1) EcTransient }
  | stateful   { L (getLoc $1) EcStateful }
  | permanent  { L (getLoc $1) EcPermanent }
  | server     { L (getLoc $1) EcServer }
  | client     { L (getLoc $1) EcClient }

-- Unions ----------------------------------------------------------------------

Union :: { Parsed Union }
Union
  : StructuredAnnotations union Symbol '{' list(UnionAlt) '}' Annotations
    { Union
      { unionName         = lVal $3
      , unionResolvedName = ()
      , unionAlts         = $5
      , unionEmptyName    = ()
      , unionHasEmpty     = HasEmpty
      , unionLoc          = StructLoc
        { slKeyword    = getLoc $2
        , slName       = lLoc $3
        , slOpenBrace  = getLoc $4
        , slCloseBrace = getLoc $6
        }
      , unionAnns         = $7
      , unionSAnns        = $1
      }
    }

UnionAlt :: { Parsed UnionAlt }
UnionAlt
  : StructuredAnnotations intLit ':' AnnotatedType Symbol MaybeConst Annotations Separator
    { case $4 of
        Some t -> UnionAlt
          { altId           = fromIntegral $ lParsed $2
          , altName         = lVal $5
          , altResolvedName = ()
          , altType         = t
          , altResolvedType = ()
          , altLoc          = FieldLoc
            { flId        = lLoc $2
            , flIdRep     = lRep $2
            , flColon     = getLoc $3
            , flName      = lLoc $5
            , flEqual     = fmap lLoc $6
            , flSeparator = $8
            }
          , altAnns         = $7
          , altSAnns        = $1
          }
    }

-- Typedefs --------------------------------------------------------------------

Typedef :: { Parsed Typedef }
Typedef : StructuredAnnotations typedef AnnotatedType Symbol Annotations
          { case $3 of
              Some t -> Typedef
                { tdName         = lVal $4
                , tdResolvedName = ()
                , tdTag          = IsTypedef
                , tdType         = t
                , tdResolvedType = ()
                , tdLoc          = TypedefLoc
                  { tdlKeyword = getLoc $2
                  , tdlName    = lLoc $4
                  }
                , tdAnns         = $5
                , tdSAnns        = $1
                }
          }

-- Annotations -----------------------------------------------------------------

Annotations :: { Maybe (Annotations Loc) }
Annotations
  : '(' list(Annotation) ')'
     { Just Annotations
       { annList = $2
       , annOpenParen  = getLoc $1
       , annCloseParen = getLoc $3
       }
     }
  | {- empty -} { Nothing }

Annotation :: { Annotation Loc }
Annotation
  : Symbol Separator
    { SimpleAnn
      { saTag = lVal $1
      , saLoc = lLoc $1
      , saSep = $2
      }
    }
  | Symbol '=' AnnValue Separator
    { ValueAnn
      { vaTag = lVal $1
      , vaVal = lVal $3
      , vaTagLoc = lLoc $1
      , vaEqual  = getLoc $2
      , vaValLoc = lLoc $3
      , vaSep    = $4
      }
    }

AnnValue
  : intLit    { fmap (uncurry IntAnn) $1 }
  | stringLit { fmap (uncurry TextAnn) $1 }

StructuredAnnotations : list(StructuredAnnotation) { $1 }

StructuredAnnotation
  : '@' Symbol
    { StructuredAnn
      { saAt = getLoc $1
      , saType = lVal $2
      , saTypeLoc = Arity0Loc $ lLoc $2
      , saMaybeElems = Nothing
      }
    }
  | '@' Symbol '{' list(StructElem) '}'
    { StructuredAnn
      { saAt = getLoc $1
      , saType = lVal $2
      , saTypeLoc = Arity0Loc $ lLoc $2
      , saMaybeElems = Just $ StructuredAnnElems
        { saOpenBrace = getLoc $3
        , saElems = $4
        , saCloseBrace = getLoc $5
        }
      }
    }

-- Constants -------------------------------------------------------------------

Const :: { Parsed Const }
Const : StructuredAnnotations const AnnotatedType Symbol '=' UntypedConst Separator
        { case $3 of
            Some ty -> Const
              { constName         = lVal $4
              , constResolvedName = ()
              , constType         = ty
              , constResolvedType = ()
              , constVal          = $6
              , constResolvedVal  = ()
              , constLoc          = ConstLoc
                { clKeyword   = getLoc $2
                , clName      = lLoc $4
                , clEqual     = getLoc $5
                , clSeparator = $7
                }
              , constSAnns = $1
              }
        }

UntypedConst :: { UntypedConst Loc }
UntypedConst
  : intLit     { UntypedConst (lLoc $1) (uncurry IntConst $ lVal $1) }
  | doubleLit  { UntypedConst (lLoc $1) (uncurry DoubleConst $ lVal $1) }
  | stringLit  { UntypedConst (lLoc $1) (uncurry StringConst $ lVal $1) }
  | true       { UntypedConst (getLoc $1) (BoolConst True) }
  | false      { UntypedConst (getLoc $1) (BoolConst False) }
  | Symbol     { UntypedConst (lLoc $1) (IdConst $ lVal $1) }
  | '[' list(ListElem) ']'
    { UntypedConst
      { ucLoc   = getLoc $1
      , ucConst = ListConst
        { lvElems = $2
        , lvCloseBrace = getLoc $3
        }
      }
    }
  | '{' list(MapElem) '}'
    { UntypedConst
      { ucLoc   = getLoc $1
      , ucConst = MapConst
        { mvElems = $2
        , mvCloseBrace = getLoc $3
        }
      }
    }
  | Symbol '{' list(StructElem) '}'
    { UntypedConst
      { ucLoc   = lLoc $1
      , ucConst = StructConst
        { svType = lVal $1
        , svOpenBrace = getLoc $2
        , svElems = $3
        , svCloseBrace = getLoc $4
        }
      }
    }
ListElem : UntypedConst Separator { ListElem $1 $2 }

MapElem : UntypedConst ':' UntypedConst Separator
          { ListElem (MapPair $1 (getLoc $2) $3) $4 }

StructElem : Symbol '=' UntypedConst Separator
             { ListElem (StructPair (lVal $1) (lLoc $1) (getLoc $2) $3) $4 }

-- Enum Values -----------------------------------------------------------------

Enum :: { Parsed Enum }
Enum : StructuredAnnotations enum Symbol '{' list(EnumVal) '}' Annotations
       { Enum
         { enumName         = lVal $3
         , enumResolvedName = ()
         , enumFlavour      = ()
         , enumConstants    = $5
         , enumLoc          = StructLoc
           { slKeyword    = getLoc $2
           , slName       = lLoc $3
           , slOpenBrace  = getLoc $4
           , slCloseBrace = getLoc $6
           }
         , enumAnns = $7
         , enumSAnns = $1
         }
       }

EnumVal :: { Parsed EnumValue }
EnumVal : StructuredAnnotations Symbol '=' intLit Annotations Separator
          { EnumValue
            { evName         = lVal $2
            , evResolvedName = ()
            , evValue        = fromIntegral $ lParsed $4
            , evLoc          = EnumValLoc
              { evlName      = lLoc $2
              , evlEqual     = getLoc $3
              , evlValue     = lLoc $4
              , evlRep       = lRep $4
              , evlSeparator = $6
              }
            , evAnns = $5
            , evSAnns = $1
            }
          }

-- Services --------------------------------------------------------------------

Service :: { Parsed Service }
Service
  : StructuredAnnotations service Symbol Extends '{' list(ServiceStmt) '}' Annotations
     { Service
       { serviceName         = lVal $3
       , serviceResolvedName = ()
       , serviceSuper        = $4
       , serviceStmts        = $6
       , serviceLoc          = StructLoc
         { slKeyword    = getLoc $2
         , slName       = lLoc $3
         , slOpenBrace  = getLoc $5
         , slCloseBrace = getLoc $7
         }
       , serviceAnns         = $8
       , serviceSAnns        = $1
       }
     }

ServiceStmt :: { Parsed ServiceStmt }
  : Function
    { FunctionStmt $1
    }
  | performs Symbol Separator
    { PerformsStmt
      ( Performs
        { performsName = lVal $2
        }
      )
    }

Function :: { Parsed Function }
  : StructuredAnnotations IsOneway RpcIdempotency FunType Symbol '(' list(Argument) ')' Throws Annotations Separator
    { Function
      { funName          = lVal $5
      , funResolvedName  = ()
      , funType          = $4
      , funResolvedType  = ()
      , funArgs          = $7
      , funExceptions    = maybe [] throwsFields $9
      , funIsOneWay      = isJust $2
      , funIdempotency   = fmap lVal $3
      , funPriority      = NormalPriority
      , funLoc           = FunLoc
        { fnlOneway      = $2
        , fnlIdempotency = fmap lLoc $3
        , fnlName        = lLoc $5
        , fnlOpenParen   = getLoc $6
        , fnlCloseParen  = getLoc $8
        , fnlThrows      = fmap throwsLoc $9
        , fnlSeparator   = $11
        }
      , funAnns         = $10
      , funSAnns        = $1
      }
    }

Argument :: { Parsed (Field 'Argument) }
Argument : StructuredAnnotations intLit ':' AnnotatedType Symbol MaybeConst Annotations Separator
  { case $4 of
     Some t -> Field
       { fieldId           = fromIntegral $ lParsed $2
       , fieldName         = lVal $5
       , fieldResolvedName = ()
       , fieldType         = t
       , fieldResolvedType = ()
       , fieldVal          = fmap lVal $6
       , fieldResolvedVal  = ()
       , fieldRequiredness = Default
       , fieldLaziness     = Lazy
       , fieldTag          = ARGUMENT
       , fieldLoc          = FieldLoc
         { flId        = lLoc $2
         , flIdRep     = lRep $2
         , flColon     = getLoc $3
         , flName      = lLoc $5
         , flEqual     = fmap lLoc $6
         , flSeparator = $8
         }
       , fieldAnns         = $7
       , fieldSAnns        = $1
       }
  }

Extends
  : extends Symbol
    { Just Super
        { supName         = lVal $2
        , supResolvedName = ()
        , supExtends      = getLoc $1
        , supLoc          = lLoc $2
        }
    }
  | {- nothing -}  { Nothing }

IsOneway
  : oneway      { Just $ getLoc $1  }
  | {- empty -} %prec SKIP_ONEWAY { Nothing }

RpcIdempotency
  : RpcIdempotencyKeyword { Just $ L (lLoc $1) (RpcIdempotency (lVal $1)) }
  | {- empty -} %prec SKIP_IDEMPOTENCY { Nothing }

RpcIdempotencyKeyword
  : readonly   { L (getLoc $1) RiReadonly }
  | idempotent { L (getLoc $1) RiIdempotent }

Throws :: { Maybe (Parsed Throws) }
Throws
  : throws '(' list(Throw) ')'
    { Just $ Throws
      { throwsLoc = ThrowsLoc
          { tlThrows     = getLoc $1
          , tlOpenParen  = getLoc $2
          , tlCloseParen = getLoc $4
          }
      , throwsFields = $3
      }
    }
  | {- empty -} { Nothing }

FunType
  : AnnotatedType { FunType $1 }
  | void { FunTypeVoid $ getLoc $1 }
  | ResponseAndStreamReturnType { FunTypeResponseAndStreamReturn $1 }

ResponseAndStreamReturnType
  : stream '<' AnnotatedType Throws '>'
    { case $3 of
        Some t -> ResponseAndStreamReturn
          { rsReturn = Nothing
          , rsComma = Nothing
          , rsStream = (Stream t $4 (annTy1 $1 $2 $5))
          }
    }
  | AnnotatedType ',' stream '<' AnnotatedType Throws '>'
    { case ($1, $5) of
        (Some tRet, Some tStream) -> ResponseAndStreamReturn
          { rsReturn = Just tRet
          , rsComma = Just $ getLoc $2
          , rsStream = (Stream tStream $6 (annTy1 $3 $4 $7))
          }
    }

Throw :: { Parsed (Field 'ThrowsField) }
Throw : StructuredAnnotations intLit ':' AnnotatedType Symbol MaybeConst Annotations Separator
        { case $4 of
            Some t -> Field
              { fieldId           = fromIntegral $ lParsed $2
              , fieldName         = lVal $5
              , fieldResolvedName = ()
              , fieldType         = t
              , fieldResolvedType = ()
              , fieldVal          = fmap lVal $6
              , fieldResolvedVal  = ()
              , fieldRequiredness = Default
              , fieldLaziness     = Lazy
              , fieldTag          = THROWS_UNRESOLVED
              , fieldLoc          = FieldLoc
                { flId        = lLoc $2
                , flIdRep     = lRep $2
                , flColon     = getLoc $3
                , flName      = lLoc $5
                , flEqual     = fmap lLoc $6
                , flSeparator = $8
                }
              , fieldAnns         = $7
              , fieldSAnns        = $1
              }
        }


-- Unused Stuff ----------------------------------------------------------------

-- We don't use any of this syntax at the moment, but we need to be aware of it
-- for compatibility

UnusedDecl
  : view Symbol ':' Symbol '{' list(ViewField) '}' Annotations  {}
  | senum Symbol '{' list(stringLit) '}'                        {}

ViewField
  : Symbol Annotations                              {}
  | intLit ':' Req AnnotatedType Symbol Annotations {}

-- Interactions --------------------------------------------------------------------

Interaction :: { Parsed Interaction }
Interaction
  : StructuredAnnotations interaction Symbol Extends '{' list(Function) '}' Annotations
     { Interaction
       { interactionName         = lVal $3
       , interactionResolvedName = ()
       , interactionSuper        = $4
       , interactionFunctions    = $6
       , interactionLoc          = StructLoc
         { slKeyword    = getLoc $2
         , slName       = lLoc $3
         , slOpenBrace  = getLoc $5
         , slCloseBrace = getLoc $7
         }
       , interactionAnns         = $8
       , interactionSAnns        = $1
       }
     }


-- Other------------------------------------------------------------------------

list(p) : revlist(p) { reverse $1 }

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

Symbol :: { L Text }
  : symTok
    {% case $1 of
        Tok (SYMBOL s) loc -> return $ L loc $ Text.pack s
        _ -> parseError $1
    }
  -- view isn't actually a keyword according to the fbthrift lexer
  -- even though it probably should be
  | view { L (getLoc $1) "view" }
  -- other "keywords" allowed in identifiers:
  | oneway      { L (getLoc $1) "oneway" }
  | safe        { L (getLoc $1) "safe" }
  | transient   { L (getLoc $1) "transient" }
  | stateful    { L (getLoc $1) "stateful" }
  | permanent   { L (getLoc $1) "permanent" }
  | server      { L (getLoc $1) "server" }
  | client      { L (getLoc $1) "client" }
  | readonly    { L (getLoc $1) "readonly" }
  | idempotent  { L (getLoc $1) "idempotent" }
  | package     { L (getLoc $1) "package" }

stringLit : stringTok
  {% case $1 of
       Tok (STRING_LIT s qt) loc -> return $ L loc (Text.pack s, qt)
       _ -> parseError $1
  }

intLit : intTok
  {% case $1 of
       Tok (INTEGRAL x s) loc -> return $ L loc (x, s)
       _ -> parseError $1
  }

doubleLit : doubleTok
  {% case $1 of
       Tok (FLOATING x s) loc -> return $ L loc (x, s)
       _ -> parseError $1
  }

Separator :: { Separator Loc }
  : ',' { Comma     $ getLoc $1 }
  | ';' { Semicolon $ getLoc $1 }
  |     { NoSep }

AnnotatedType :: { Some (AnnotatedType Loc) }
AnnotatedType : Type Annotations
                { case $1 of
                    ThisAnnTy ty loc -> Some $ AnnotatedType ty $2 loc
                }

Type :: { SomeAnnTy 'Unresolved () }
Type : byte   { ThisAnnTy I8 (annTy0 $1) }
     | i16    { ThisAnnTy I16 (annTy0 $1) }
     | i32    { ThisAnnTy I32 (annTy0 $1) }
     | i64    { ThisAnnTy I64 (annTy0 $1) }
     | double { ThisAnnTy TDouble (annTy0 $1) }
     | float  { ThisAnnTy TFloat (annTy0 $1) }
     | string { ThisAnnTy TText (annTy0 $1) }
     | binary { ThisAnnTy TBytes (annTy0 $1) }
     | bool   { ThisAnnTy TBool (annTy0 $1) }
     | Symbol { ThisAnnTy (TNamed (lVal $1)) (Arity0Loc (lLoc $1)) }
     | map '<' AnnotatedType ',' AnnotatedType '>'
       { case ($3, $5) of
           (Some k, Some v) -> ThisAnnTy (TMap k v) (annTy2 $1 $2 $4 $6)
       }
     | hash_map '<' AnnotatedType ',' AnnotatedType '>'
       { case ($3, $5) of
           (Some k, Some v) -> ThisAnnTy (THashMap k v) (annTy2 $1 $2 $4 $6)
       }
     | set '<' AnnotatedType '>'
       { case $3 of
           Some t -> ThisAnnTy (TSet t) (annTy1 $1 $2 $4)
       }
     | hash_set '<' AnnotatedType '>'
       { case $3 of
           Some t -> ThisAnnTy (THashSet t) (annTy1 $1 $2 $4)
       }
     | list '<' AnnotatedType '>'
       { case $3 of
           Some t -> ThisAnnTy (TList t) (annTy1 $1 $2 $4) }

{

-- Result Types ----------------------------------------------------------------

data ThriftFile a l = ThriftFile
  { thriftName    :: Text
  , thriftPath    :: FilePath
  , thriftHeaders :: [Header 'Unresolved () l]
  , thriftDecls   :: [Decl 'Unresolved () l]
  , thriftSplice  :: a
  , thriftComments :: [Comment l]
  }

-- Parser Monad ----------------------------------------------------------------

type Parser = Alex

data L a = L { lLoc :: Located Loc, lVal :: a }

instance Functor L where
  fmap f (L loc val) = L loc $ f val

lParsed :: L (a, b) -> a
lParsed = fst . lVal

lRep :: L (a, b) -> b
lRep = snd . lVal

getLoc :: Token -> Located Loc
getLoc (Tok _ loc) = loc

runParser :: Parser a -> FilePath -> String -> Either String a
runParser parser file input = fst <$> runFullParser parser file input

runFullParser
  :: Parser a -> FilePath -> String -> Either String (a, [Comment Loc])
runFullParser parser file input =
  runAlex input $ setFilename file >> (,) <$> parser <*> getComments

parseError :: Token -> Parser a
parseError (Tok _ Located{lLocation=Loc{..}}) =
  alexError $ concat
    [locFile, ":", show locStartLine, ":", show locStartCol, ": parse error"]

bind :: Parser a -> (a -> Parser b) -> Parser b
bind = (>>=)

lexWrap :: (Token -> Parser a) -> Parser a
lexWrap k = alexMonadScan >>= k

parseThrift :: Parser ([Parsed Header], [Parsed Decl])
parseThrift = do
  statements <- parseStatements
  splitStatements [] [] statements
  where
    splitStatements
      :: [Parsed Header]
      -> [Parsed Decl]
      -> [ParsedStatement]
      -> Parser ([Parsed Header], [Parsed Decl])
    splitStatements headers [] (StatementHeader header : statements) =
      splitStatements (header:headers) [] statements
    splitStatements _ decl (StatementHeader header : _) =
      alexError $ concat
        [locFile, ":", show locStartLine, ":", show locStartCol, ": unexpected header"]
      where
        Located{lLocation=Loc{..}} = case header of
          HInclude{incKeywordLoc=incKeywordLoc} -> incKeywordLoc
          HNamespace{nmKeywordLoc=nmKeywordLoc} -> nmKeywordLoc
          HPackage{pkgKeywordLoc=pkgKeywordLoc} -> pkgKeywordLoc
    splitStatements headers decls (StatementDecl decl : statements) =
      splitStatements headers (decl:decls) statements
    splitStatements headers decls [] =
      pure ((reverse headers), (reverse decls))


parseString :: FilePath -> String -> Either String (ThriftFile () Loc)
parseString file string = do
  ((headers, decls), comments) <- runFullParser parseThrift file string
  pure $ mkThriftFile (headers, decls, comments)

  where
    mkThriftFile (headers, decls, comments) =
      ThriftFile
      { thriftName    = getModuleName file
      , thriftPath    = file
      , thriftHeaders = headers
      , thriftDecls   = decls
      , thriftSplice  = ()
      , thriftComments = comments
      }

parse :: FilePath -> FilePath -> IO (Either String (ThriftFile () Loc))
parse baseDir file = parseString file <$> readFile (baseDir </> file)

getModuleName :: FilePath -> Text
getModuleName file =
  fst . Text.breakOn "." .
  snd . Text.breakOnEnd "/" .
  Text.pack $ file

annTy0 :: Token -> TypeLoc 0 Loc
annTy0 tok = Arity0Loc $ getLoc tok

annTy1 :: Token -> Token -> Token -> TypeLoc 1 Loc
annTy1 tok open close = Arity1Loc
  { a1Ty         = getLoc tok
  , a1OpenBrace  = getLoc open
  , a1CloseBrace = getLoc close
  }

annTy2 :: Token -> Token -> Token -> Token -> TypeLoc 2 Loc
annTy2 tok open comma close = Arity2Loc
  { a2Ty         = getLoc tok
  , a2OpenBrace  = getLoc open
  , a2Comma      = getLoc comma
  , a2CloseBrace = getLoc close
  }
}