content: {-# LANGUAGE OverloadedStrings #-}
  module Parser where
  
  import Syntax
  import qualified Data.Text.IO as Text
  import Data.List(uncons)
  import Data.Foldable(foldl')
  import Data.Functor(($>))
  import Control.Applicative((<|>), optional, empty, liftA2)
  import Control.Monad(guard, (<$!>))
  import Control.Monad.Trans.State.Strict(StateT(..), runStateT)
  import Lexer(Lexeme(..),
      lexlex, prettyLocated, alternating1,
      extractLexeme, extractLocation)
  import Data.Attoparsec.Combinator(sepBy', sepBy1', many', many1', option)
  
  
  {-
  This module turns a list of lexemes into a syntax tree
  -}
  parse path s = do
      lexemes <- lexlex path s
      case runStateT modDecl lexemes of
          Nothing -> Left "Parse error at the beginning"
          Just (result, []) -> return result
          Just (_, rest) ->
              Left ("Could not parse until end. Next lexemes are: "
                  <> renderError (fmap prettyLocated (take 10 rest)))
  {-# INLINE parse #-}
  
  parseFile path = do
      str <- Text.readFile path
      either fail return (parse path str)
  {-# INLINE parseFile #-}
  
  parseString s = parse "" s
  {-# INLINE parseString #-}
  
  -- get the next lexeme
  next = StateT uncons
  {-# INLINE next #-}
  
  nextLexeme = extractLexeme <$!> next
  {-# INLINE nextLexeme #-}
  
  token t = do
      Reserved r <- nextLexeme
      guard (t == r)
  {-# INLINE token #-}
  
  -- parens combinators for readability
  parenthesized p = token "(" *> p <* token ")"
  {-# INLINE parenthesized #-}
  
  curlyBraces p = token "{" *> p <* token "}"
  {-# INLINE curlyBraces #-}
  
  bracketed p = token "[" *> p <* token "]"
  {-# INLINE bracketed #-}
  
  sepByTrailing p sep = option [] (sepBy1' p sep <* optional sep)
  {-# INLINE sepByTrailing #-}
  
  
  {- Module -}
  modDecl = do
      name <- option (fromText "Scratch") (token "module" *> modid <* token ";")
      imports <- many' (impdecl <* token ";")
      topDecls <- many' (topdecl <* token ";")
      return (ModuleDeclaration name imports topDecls)
  {-# INLINE modDecl #-}
  
  impdecl = do
      token "import"
      name <- modid
      imps <- optional impspec
      asAlias <- optional (token "as" *> modid)
      return (ImportDeclaration name imps asAlias)
  {-# INLINE impdecl #-}
  
  impspec = parenthesized (sepByTrailing spec (token ","))
  {-# INLINE impspec #-}
  
  {- Declarations -}
  topdecl = typeDeclaration <|> aliasDeclaration <|> decl
  {-# INLINE topdecl #-}
  
  typeDeclaration = do
      token "type"
      name <- con
      variables <- many' var
      constructors <- optional (token "=" *> constrs)
      return (TypeDeclaration (fromId name) variables (concat constructors))
  {-# INLINE typeDeclaration #-}
  
  aliasDeclaration = do
      token "alias"
      alias <- conid
      token "="
      val <- otype
      return (AliasDeclaration (fromId alias) val)
  {-# INLINE aliasDeclaration #-}
  
  decls = curlyBraces (sepBy' decl (token ";"))
  {-# INLINE decls #-}
  
  decl = typeSignature <|> fixityDeclaration
      <|> operatorDeclaration <|> functionDeclaration
      <|> expressionDeclaration
  {-# INLINE decl #-}
  
  typeSignature = do
      v <- var
      token ":"
      t <- qtype
      return (TypeSignature (fromId v) t)
  {-# INLINE typeSignature #-}
  
  fixityDeclaration = do
      f <- fixity
      i <- float
      o <- varsym
      a <- varid <|> conid
      return (FixityDeclaration f i (fromId o) (fromId a))
  {-# INLINE fixityDeclaration #-}
  
  functionDeclaration = do
      v <- var
      ps <- many1' apat
      r <- rhs
      return (FunctionDeclaration (fromId v) [(ps, r)])
  {-# INLINE functionDeclaration #-}
  
  operatorDeclaration = do
      p1 <- lpat
      o <- varsym
      p2 <- lpat
      r <- rhs
      return (FunctionDeclaration (fromId o) [([p1, p2], r)])
  {-# INLINE operatorDeclaration #-}
  
  expressionDeclaration = do
      p <- lpat
      token "="
      e <- (token "await" *> fmap AwaitExpression expr) <|> exprWithWhere
      return (ExpressionDeclaration p e)
  {-# INLINE expressionDeclaration #-}
  
  rhs = token "=" *> exprWithWhere
  {-# INLINE rhs #-}
  
  exprWithWhere =
      maybeWith expr (fmap LetExpression (token "where" *> decls))
  {-# INLINE exprWithWhere #-}
  
  fixity = token "infixl" $> LeftAssociative
      <|> token "infixr" $> RightAssociative
      <|> token "infix" $> None
  {-# INLINE fixity #-}
  
  {- Types -}
  qtype = forAll <|> otype
  {-# INLINE qtype #-}
  
  forAll = do
      token "forall"
      ids <- many1' varid
      token "."
      t <- otype
      return (ForAll ids t)
  {-# INLINE forAll #-}
  
  otype = maybeWith typeOperator (fmap (flip TypeArrow) (token "->" *> otype))
  {-# INLINE otype #-}
  
  typeOperator = maybeWith btype (liftA2 (\o r l -> TypeOperator l o r) qvarsym typeOperator)
  {-# INLINE typeOperator #-}
  
  btype = liftA2 (foldl' TypeApplication) atype (many' atype)
  {-# INLINE btype #-}
  
  atype = typeConstructor <|> typeVariable <|> parenthesizedType
  {-# INLINE atype #-}
  
  typeConstructor = TypeConstructor <$!> qcon
  {-# INLINE typeConstructor #-}
  
  typeVariable = TypeVariable <$!> var
  {-# INLINE typeVariable #-}
  
  parenthesizedType = ParenthesizedType <$!> parenthesized qtype
  {-# INLINE parenthesizedType #-}
  
  constrs = sepBy1' constr (token "|")
  {-# INLINE constrs #-}
  
  constr = do
      c <- con
      ts <- many' atype
      return (fromId c, ts)
  {-# INLINE constr #-}
  
  expr = maybeWith lexpr (liftA2 (\o r l -> OperatorExpression l o r) qvarsym expr)
  {-# INLINE expr #-}
  
  {-
  Performance helper for cases like
  `operatorExpr <|> lexpr`
  where operator expression is starting with an lexpr.
  When we just want to parse an lexpr, we would still enter operatorExpr
  and then fail, because it is not an operator application.
  Essentially, lexpr would be parsed twice.
  -}
  maybeWith lp rp = do
      l <- lp
      o <- optional rp
      return (case o of
          Just f -> f l
          Nothing -> l)
  {-# INLINE maybeWith #-}
  
  -- NOTE negation expression was moved out of expr
  -- and down to lexpr
  negationExpression = do
      Varsym [] "-" <- nextLexeme
      e <- fexpr
      return (NegationExpression e)
  {-# INLINE negationExpression #-}
  
  lexpr = negationExpression <|> lambdaExpression <|> letExpression
      <|> ifExpression <|> caseExpression <|> fexpr
  {-# INLINE lexpr #-}
  
  lambdaExpression = do
      token "fun" <|> token "\\"
      ps <- many1' apat
      token "->"
      e <- expr
      return (LambdaExpression ps e)
  {-# INLINE lambdaExpression #-}
  
  letExpression = do
      token "let"
      ds <- decls
      token "in"
      e <- expr
      return (LetExpression ds e)
  {-# INLINE letExpression #-}
  
  -- NOTE optional semicolons were removed
  -- because they were part of parsing if- in do-expressions
  ifExpression = do
      token "if"
      c <- expr
      token "then"
      t <- expr
      token "else"
      e <- expr
      return (IfExpression c t e)
  {-# INLINE ifExpression #-}
  
  caseExpression = do
      token "case"
      e <- expr
      token "of"
      als <- alts
      return (CaseExpression e als)
  {-# INLINE caseExpression #-}
  
  fexpr = liftA2 (foldl' FunctionApplication) aexpr (many' aexpr)
  {-# INLINE fexpr #-}
  
  aexpr = variable <|> constructorExpression <|> literalExpression
      <|> parenthesizedExpression <|> arrayExpression
      <|> interpolatedStringExpression
  {-# INLINE aexpr #-}
  
  variable = Variable <$!> qvar
  {-# INLINE variable #-}
  
  constructorExpression = ConstructorExpression <$!> qcon
  {-# INLINE constructorExpression #-}
  
  literalExpression = LiteralExpression <$!> literal
  {-# INLINE literalExpression #-}
  
  parenthesizedExpression =
      ParenthesizedExpression <$!> parenthesized expr
  {-# INLINE parenthesizedExpression #-}
  
  arrayExpression =
      ArrayExpression <$!> bracketed (sepByTrailing expr (token ","))
  {-# INLINE arrayExpression #-}
  
  interpolatedStringExpression = do
      InterpolatedStringStart <- nextLexeme
      expressions <- alternating1 positionedStringExpr expr
      InterpolatedStringEnd <- nextLexeme
      return (makeInterpolatedString expressions)
  {-# INLINE interpolatedStringExpression #-}
  
  positionedStringExpr = do
      InterpolatedStringMid s <- nextLexeme
      return (LiteralExpression (Text s))
  {-# INLINE positionedStringExpr #-}
  
  alts = curlyBraces (sepBy' alt (token ";"))
  {-# INLINE alts #-}
  
  alt = do
      p <- pat
      token "->"
      e <- exprWithWhere
      return (p, e)
  {-# INLINE alt #-}
  
  {- Patterns -}
  pat = operatorPattern <|> lpat
  {-# INLINE pat #-}
  
  operatorPattern = do
      l <- lpat
      o <- qvarsym
      r <- pat
      return (OperatorPattern l o r)
  {-# INLINE operatorPattern #-}
  
  -- NOTE negative patterns were removed from lpat
  -- because the minus is part of the literal
  lpat = appliedConstructorPattern <|> apat
  {-# INLINE lpat #-}
  
  appliedConstructorPattern = do
      c <- qcon
      ps <- many1' apat
      return (ConstructorPattern TaggedRepresentation c ps)
  {-# INLINE appliedConstructorPattern #-}
  
  apat = aliasPattern <|> wildcard <|> variablePattern
      <|> constructorPattern <|> literalPattern
      <|> parenthesizedPattern <|> arrayPattern
  {-# INLINE apat #-}
  
  {- NOTE
  aliasPattern uses a keyword instead of @, allows pat instead of apat
  and requires enclosing parentheses e.g. (s alias Sphere p v c r)
  
  Here are some alternative ideas
  (Sphere p v c r as s)       hard to read because as looks like a variable
  (s as Sphere p v c r)       would be clearer, but switched compared to imports
                              e.g. import Viewer.Obj as Obj
  
  TODO warn or eliminate patterns of the form
  (aVar alias anotherVar) and (aVar alias (anotherVar))
  -}
  aliasPattern = parenthesized (do
      v <- var
      token "alias"
      p <- pat
      return (AliasPattern (fromId v) p))
  {-# INLINE aliasPattern #-}
  
  variablePattern = (VariablePattern . fromId) <$!> var
  {-# INLINE variablePattern #-}
  
  constructorPattern = do
      c <- qcon
      return (ConstructorPattern TaggedRepresentation c [])
  {-# INLINE constructorPattern #-}
  
  literalPattern = LiteralPattern <$!> literal
  {-# INLINE literalPattern #-}
  
  parenthesizedPattern = ParenthesizedPattern <$!> parenthesized pat
  {-# INLINE parenthesizedPattern #-}
  
  arrayPattern = ArrayPattern <$!> bracketed (sepByTrailing pat (token ","))
  {-# INLINE arrayPattern #-}
  
  {-
  Read the following like this example:
  A variable can be a varid like x
  or a varsym like (+)
  -}
  spec = varid <|> conid <|> parenthesized varsym
  {-# INLINE spec #-}
  
  var = varid <|> parenthesized varsym
  {-# INLINE var #-}
  
  qvar = qvarid <|> parenthesized qvarsym
  {-# INLINE qvar #-}
  
  con = conid <|> parenthesized varsym
  {-# INLINE con #-}
  
  qcon = qconid <|> parenthesized qvarsym
  {-# INLINE qcon #-}
  
  {-
  Read the following like this example:
  A qvarid can be a qualified variable like List.map
  or a normal variable identifier like map
  -}
  
  fromVarsym (Varsym [] v) l = return (Id v l)
  fromVarsym _ _ = Nothing
  {-# INLINE fromVarsym #-}
  
  fromVarid (Varid [] v) l = return (Id v l)
  fromVarid _ _ = Nothing
  {-# INLINE fromVarid #-}
  
  fromConid (Conid [] v) l = return (Id v l)
  fromConid _ _ = Nothing
  {-# INLINE fromConid #-}
  
  fromQVarsym (Varsym qs v) l = return (Name qs (Id v l))
  fromQVarsym _ _ = Nothing
  {-# INLINE fromQVarsym #-}
  
  fromQVarid (Varid qs v) l = return (Name qs (Id v l))
  fromQVarid _ _ = Nothing
  {-# INLINE fromQVarid #-}
  
  fromQConid (Conid qs v) l = return (Name qs (Id v l))
  fromQConid _ _ = Nothing
  {-# INLINE fromQConid #-}
  
  fromWildcard (Reserved "_") l = return (Wildcard (Id "_" l))
  fromWildcard _ _ = Nothing
  {-# INLINE fromWildcard #-}
  
  parseLocated f = do
      n <- next
      maybe empty return (f (extractLexeme n) (extractLocation n))
  {-# INLINE parseLocated #-}
  
  varsym = parseLocated fromVarsym
  {-# INLINE varsym #-}
  
  qvarsym = parseLocated fromQVarsym
  {-# INLINE qvarsym #-}
  
  varid = parseLocated fromVarid
  {-# INLINE varid #-}
  
  qvarid = parseLocated fromQVarid
  {-# INLINE qvarid #-}
  
  conid = parseLocated fromConid
  {-# INLINE conid #-}
  
  qconid = parseLocated fromQConid
  {-# INLINE qconid #-}
  
  wildcard = parseLocated fromWildcard
  {-# INLINE wildcard #-}
  
  modid = qconid
  {-# INLINE modid #-}
  
  float = do
      Double d <- nextLexeme
      return d
  {-# INLINE float #-}
  
  integer = do
      Integer i <- nextLexeme
      return i
  {-# INLINE integer #-}
  
  string = do
      String s <- nextLexeme
      return s
  {-# INLINE string #-}
  
  literal =
      Number . intToDouble <$!> integer
      <|> Number <$!> float
      <|> Text <$!> string
  {-# INLINE literal #-}
  