content: -- |
  -- Module      : Minigent.Syntax.Parser
  -- Copyright   : (c) Data61 2018-2019
  --                   Commonwealth Science and Research Organisation (CSIRO)
  --                   ABN 41 687 119 230
  -- License     : BSD3
  --
  -- This parser uses the @Earley@ library to make it based on a nice declarative grammar
  -- specification without too much noise.
  --
  -- The algorithm is cubic in the worst case but linear normally. We test for and avoid ambiguity,
  -- even though the Earley algorithm can handle ambiguous grammars, so that the parser can have
  -- good errors and fast performance.
  --
  -- It can be imported unqualified or qualified, as there are very few exports.
  {-# LANGUAGE RecursiveDo #-}
  module Minigent.Syntax.Parser where
  
  import Text.Earley
  import Control.Applicative
  import Data.Maybe (isJust)
  
  import qualified Minigent.Syntax.Lexer as L
  
  import Minigent.Syntax
  import Minigent.Syntax.Utils
  import qualified Minigent.Syntax.Utils.Row as Row
  
  -- | The grammar for multiple top-level declarations.
  toplevels :: Grammar r (Prod r String L.Token [RawTopLevel])
  toplevels = mdo
      tl <- toplevel
      tls <- rule $ many tl
      return tls
  
  -- | The grammar for a single top-level declarations.
  toplevel :: Grammar r (Prod r String L.Token RawTopLevel)
  toplevel = mdo
  
      let fromLowerIdent (L.LowerIdent n) = Just n
          fromLowerIdent _                = Nothing
          fromNumeric    (L.Numeric n)    = Just n
          fromNumeric    _                = Nothing
  
          reservedTypeNames = ["U8","U16","U32", "U64", "Bool","Unit"]
  
          reservedValueNames = ["Unit","True","False"]
  
          fromUpperType (L.UpperIdent n) | n `notElem` reservedTypeNames
                                         = Just n
          fromUpperType _                = Nothing
          fromUpperValue (L.UpperIdent n) | n `notElem` reservedValueNames
                                          = Just n 
          fromUpperValue _                = Nothing
  
      primTy <- rule $  U8   <$ token (L.UpperIdent "U8")
                    <|> U16  <$ token (L.UpperIdent "U16")   
                    <|> U32  <$ token (L.UpperIdent "U32")   
                    <|> U64  <$ token (L.UpperIdent "U64")   
                    <|> Bool <$ token (L.UpperIdent "Bool")   
                    <|> Unit <$ token (L.UpperIdent "Unit")   
                    <?> "primitive type"
                    
  
      typeVar      <- rule $ terminal fromLowerIdent <?> "type variable"
      var          <- rule $ terminal fromLowerIdent <?> "variable"
      fieldName    <- rule $ terminal fromLowerIdent <?> "field name"
      absTypeName  <- rule $ terminal fromUpperType  <?> "abstract type"
      conName      <- rule $ terminal fromUpperValue <?> "Constructor"
  
      takenTag     <- rule $  isJust <$> optional (token (L.Keyword L.Take)) 
                          <?> "optional taken tag"
  
      fieldEntry   <- rule $  Entry <$> fieldName <* token L.Colon <*> ty <*> takenTag  
                          <?> "field entry"
  
      fieldEntries <- rule $  (:)   <$> fieldEntry <* token L.Comma <*> fieldEntries
                          <|> (:[]) <$> fieldEntry
                          <?> "field entries"
  
      conEntry     <- rule $  Entry <$> conName <*> ty <*> takenTag
                          <?> "constructor entry"
      
      conEntries   <- rule $  (:)   <$> conEntry <* token L.Bar <*> conEntries
                          <|> (:[]) <$> conEntry
                          <?> "constructor entries"
    
  
      sigil <- rule $  Unboxed  <$ token L.Hash
                   <|> ReadOnly <$ token L.Bang
                   <|> pure Writable
                   <?> "sigil"
  
  
      atomicTy <- rule $  PrimType    <$> primTy
                      <|> TypeVar     <$> typeVar
                      <|> TypeVarBang <$> typeVar <* token (L.Bang)
                      <|> Record      <$> recTy
                                      <*  token (L.Open L.Brace)
                                      <*> (Row.fromList <$> fieldEntries)
                                      <*  token (L.Close L.Brace)
                                      <*> sigil 
                      <|> Variant     <$  token (L.Operator Less)
                                      <*> (Row.fromList <$> conEntries )
                                      <*  token (L.Operator Greater)
                      <|> AbsType     <$> absTypeName
                                      <*> sigil
                                      <*> pure []
                      <|> id          <$  token (L.Open L.Paren)
                                      <*> ty
                                      <*  token (L.Close L.Paren)
  
      ty' <- rule $ AbsType <$> absTypeName
                            <*> sigil
                            <*> some atomicTy
                 <|> atomicTy
  
      ty <- rule $  Function <$> ty' <* token (L.Arrow) <*> ty
                <|> ty'
  
    
      bool <- rule $  True  <$ token (L.UpperIdent "True")
                  <|> False <$ token (L.UpperIdent "False")
                  <?> "boolean"
  
      number <- rule $ terminal fromNumeric <?> "number"
      literal <- rule $  BoolV <$> bool
                     <|> IntV  <$> number 
                     <|> UnitV <$ token (L.UpperIdent "Unit")
                     <?> "literal"
  
      types <- rule $  (:)   <$> ty <* token (L.Comma) <*> types
                   <|> (:[]) <$> ty
                   <|> pure []
  
      fieldInitialiser <- rule $  (,) <$> fieldName <* token (L.Equals) <*> exp
                              <?> "field initialiser" 
  
      fieldInitialisers <- rule $ (:) <$> fieldInitialiser <* token (L.Comma) <*> fieldInitialisers
                                      <|> (:[]) <$> fieldInitialiser
  
      atomExp <- rule $  Literal <$> literal  
                     <|> Var     <$> var 
                     <|> TypeApp <$> var 
                                 <*  token (L.Open L.Square)
                                 <*> types
                                 <*  token (L.Close L.Square)
                     <|> If      <$  token (L.Keyword L.If)
                                 <*> exp 
                                 <*  token (L.Keyword L.Then)
                                 <*> exp 
                                 <*  token (L.Keyword L.Else)
                                 <*> exp  
                                 <*  token (L.Keyword L.End)
                     <|> Let     <$  token (L.Keyword L.Let)
                                 <*> var
                                 <*  token (L.Equals)
                                 <*> exp 
                                 <*  token (L.Keyword L.In)
                                 <*> exp  
                                 <*  token (L.Keyword L.End)
                     <|> LetBang <$  token (L.Keyword L.Let)
                                 <*  token (L.Bang)
                                 <*  token (L.Open L.Paren)
                                 <*> many var
                                 <*  token (L.Close L.Paren)
                                 <*> var
                                 <*  token (L.Equals)
                                 <*> exp 
                                 <*  token (L.Keyword L.In)
                                 <*> exp  
                                 <*  token (L.Keyword L.End)
                     <|> Struct  <$  token (L.Open L.Brace)
                                 <*> fieldInitialisers
                                 <*  token (L.Close L.Brace)
                     <|> Case    <$  token (L.Keyword L.Case)
                                 <*> exp
                                 <*  token (L.Keyword L.Of)
                                 <*> conName 
                                 <*> var
                                 <*  token (L.Arrow)
                                 <*> exp 
                                 <*  token (L.Bar)
                                 <*> var
                                 <*  token (L.Arrow)
                                 <*> exp
                                 <*  token (L.Keyword L.End)
                     <|> Esac    <$  token (L.Keyword L.Case)
                                 <*> exp
                                 <*  token (L.Keyword L.Of)
                                 <*> conName 
                                 <*> var
                                 <*  token (L.Arrow)
                                 <*> exp 
                                 <*  token (L.Keyword L.End)
                     <|> Take    <$  token (L.Keyword L.Take)
                                 <*> var 
                                 <*  token (L.Open L.Brace)
                                 <*> fieldName 
                                 <*  token (L.Equals) 
                                 <*> var
                                 <*  token (L.Close L.Brace)
                                 <*  token (L.Equals)
                                 <*> exp
                                 <*  token (L.Keyword L.In)
                                 <*> exp  
                                 <*  token (L.Keyword L.End)
                     <|> Put     <$  token (L.Keyword L.Put)
                                 <*> exp
                                 <*  token (L.Dot)
                                 <*> fieldName 
                                 <*  token (L.Colon)
                                 <*  token (L.Equals) 
                                 <*> exp
                                 <*  token (L.Keyword L.End)
                     <|> Member  <$> atomExp <* token (L.Dot) <*> fieldName
                     <|> id      <$  token (L.Open L.Paren)
                                 <*> exp 
                                 <*  token (L.Close L.Paren)
                     <?> "expression (atomic)"
  
      appExp <- rule $  Apply <$> appExp <*> atomExp
                    <|> Con   <$> conName <*> atomExp
                    <|> PrimOp Not . pure <$ token (L.Operator Not) <*> atomExp 
                    <|> atomExp
                    <?> "expression (appExp)"
  
  
      let binOp e1 o e2 = PrimOp o [e1, e2]
          fromOp set (L.Operator o) | o `elem` set = Just o
          fromOp _ _                               = Nothing 
                
  
      prodExp <- rule $ binOp <$> prodExp <*> terminal (fromOp prodOps) <*> appExp
                     <|> appExp
                     <?> "expression (prodExp)"
      sumExp <- rule $ binOp <$> sumExp <*> terminal (fromOp sumOps) <*> prodExp
                    <|> prodExp
                    <?> "expression (sumExp)"
      compExp <- rule $ binOp <$> sumExp <*> terminal (fromOp compOps) <*> sumExp
                     <|> sumExp
                     <?> "expression (compExp)"
      boolExp <- rule $ binOp <$> boolExp <*> terminal (fromOp boolOps) <*> compExp
                     <|> compExp
                     <?> "expression (boolExp)"
      exp <- rule $  Sig <$> exp <* token (L.Colon) <*> ty
                 <|> boolExp <?> "expression"
  
      typeVars <- rule $  (:)   <$> typeVar <* token (L.Comma) <*> typeVars
                      <|> (:[]) <$> typeVar
                      <|> pure []
      
                  -- rec t
      recTy <- rule $ Rec <$> (token (L.Keyword L.Rec) *> typeVar)
                  -- recursive parameter ommitted
                   <|> pure None 
                   <?> "recursive type"
  
      constraint <- rule $  Share  . TypeVar <$ token (L.UpperIdent "Share")  <*> typeVar
                        <|> Drop   . TypeVar <$ token (L.UpperIdent "Drop")   <*> typeVar
                        <|> Escape . TypeVar <$ token (L.UpperIdent "Escape") <*> typeVar
  
      constraints <- rule $  (:)   <$> constraint <* token (L.Comma) <*> constraints
                         <|> (:[]) <$> constraint
                         <|> pure []
  
      polyType <- rule $  Forall <$  token (L.Open L.Square) 
                                 <*> typeVars 
                                 <*  token (L.Close L.Square)
                                 <*> constraints
                                 <*  token (L.Dot)
                                 <*> ty
                      <|> Forall [] [] <$> ty
      topLevel <- rule $  TypeSig  <$> var
                                   <*  token (L.Colon) 
                                   <*> polyType
                                   <*  token (L.Semi)
                      <|> Equation <$> var
                                   <*> var
                                   <*  token (L.Equals) 
                                   <*> exp 
                                   <*  token (L.Semi) 
      return topLevel
  