{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
module Parse.Pattern
  ( term
  , expression
  )
  where


import qualified Data.List as List
import qualified Data.Name as Name
import qualified Data.Utf8 as Utf8
import Foreign.Ptr (plusPtr)

import qualified AST.Source as Src
import qualified Parse.Keyword as Keyword
import qualified Parse.Number as Number
import qualified Parse.Space as Space
import qualified Parse.String as String
import qualified Parse.Variable as Var
import qualified Parse.Primitives as P
import Parse.Primitives (Parser, addLocation, addEnd, getPosition, inContext, oneOf, oneOfWithFallback, word1, word2)
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Syntax as E



-- TERM


term :: Parser E.Pattern Src.Pattern
term =
  do  start <- getPosition
      oneOf E.PStart
        [ record start
        , tuple start
        , list start
        , termHelp start
        ]


termHelp :: A.Position -> Parser E.Pattern Src.Pattern
termHelp start =
  oneOf E.PStart
    [
      do  wildcard
          addEnd start Src.PAnything
    ,
      do  name <- Var.lower E.PStart
          addEnd start (Src.PVar name)
    ,
      do  upper <- Var.foreignUpper E.PStart
          end <- getPosition
          let region = A.Region start end
          return $ A.at start end $
            case upper of
              Var.Unqualified name ->
                Src.PCtor region name []

              Var.Qualified home name ->
                Src.PCtorQual region home name []
    ,
      do  number <- Number.number E.PStart E.PNumber
          end <- getPosition
          case number of
            Number.Int int ->
              return (A.at start end (Src.PInt int))

            Number.Float float ->
              P.Parser $ \(P.State _ _ _ _ row col) _ _ cerr _ ->
                let
                  width = fromIntegral (Utf8.size float)
                in
                cerr row (col - width) (E.PFloat width)
    ,
      do  str <- String.string E.PStart E.PString
          addEnd start (Src.PStr str)
    ,
      do  chr <- String.character E.PStart E.PChar
          addEnd start (Src.PChr chr)
    ]



-- WILDCARD


wildcard :: Parser E.Pattern ()
wildcard =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then
      eerr row col E.PStart
    else
      let
        !newPos = plusPtr pos 1
        !newCol = col + 1
      in
      if Var.getInnerWidth newPos end > 0 then
        let (# badPos, badCol #) = Var.chompInnerChars newPos end newCol in
        cerr row col (E.PWildcardNotVar (Name.fromPtr pos badPos) (fromIntegral (badCol - col)))
      else
        let !newState = P.State src newPos end indent row newCol in
        cok () newState



-- RECORDS


record :: A.Position -> Parser E.Pattern Src.Pattern
record start =
  inContext E.PRecord (word1 0x7B {- { -} E.PStart) $
    do  Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentOpen
        oneOf E.PRecordOpen
          [ do  var <- addLocation (Var.lower E.PRecordField)
                Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
                recordHelp start [var]
          , do  word1 0x7D {-}-} E.PRecordEnd
                addEnd start (Src.PRecord [])
          ]


recordHelp :: A.Position -> [A.Located Name.Name] -> Parser E.PRecord Src.Pattern
recordHelp start vars =
  oneOf E.PRecordEnd
    [ do  word1 0x2C {-,-} E.PRecordEnd
          Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentField
          var <- addLocation (Var.lower E.PRecordField)
          Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd
          recordHelp start (var:vars)
    , do  word1 0x7D {-}-} E.PRecordEnd
          addEnd start (Src.PRecord vars)
    ]



-- TUPLES


tuple :: A.Position -> Parser E.Pattern Src.Pattern
tuple start =
  inContext E.PTuple (word1 0x28 {-(-} E.PStart) $
    do  Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1
        oneOf E.PTupleOpen
          [ do  (pattern, end) <- P.specialize E.PTupleExpr expression
                Space.checkIndent end E.PTupleIndentEnd
                tupleHelp start pattern []
          , do  word1 0x29 {-)-} E.PTupleEnd
                addEnd start Src.PUnit
          ]


tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser E.PTuple Src.Pattern
tupleHelp start firstPattern revPatterns =
  oneOf E.PTupleEnd
    [ do  word1 0x2C {-,-} E.PTupleEnd
          Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN
          (pattern, end) <- P.specialize E.PTupleExpr expression
          Space.checkIndent end E.PTupleIndentEnd
          tupleHelp start firstPattern (pattern : revPatterns)
    , do  word1 0x29 {-)-} E.PTupleEnd
          case reverse revPatterns of
            [] ->
              return firstPattern

            secondPattern : otherPatterns ->
              addEnd start (Src.PTuple firstPattern secondPattern otherPatterns)
    ]



-- LIST


list :: A.Position -> Parser E.Pattern Src.Pattern
list start =
  inContext E.PList (word1 0x5B {-[-} E.PStart) $
    do  Space.chompAndCheckIndent E.PListSpace E.PListIndentOpen
        oneOf E.PListOpen
          [ do  (pattern, end) <- P.specialize E.PListExpr expression
                Space.checkIndent end E.PListIndentEnd
                listHelp start [pattern]
          , do  word1 0x5D {-]-} E.PListEnd
                addEnd start (Src.PList [])
          ]


listHelp :: A.Position -> [Src.Pattern] -> Parser E.PList Src.Pattern
listHelp start patterns =
  oneOf E.PListEnd
    [ do  word1 0x2C {-,-} E.PListEnd
          Space.chompAndCheckIndent E.PListSpace E.PListIndentExpr
          (pattern, end) <- P.specialize E.PListExpr expression
          Space.checkIndent end E.PListIndentEnd
          listHelp start (pattern:patterns)
    , do  word1 0x5D {-]-} E.PListEnd
          addEnd start (Src.PList (reverse patterns))
    ]



-- EXPRESSION


expression :: Space.Parser E.Pattern Src.Pattern
expression =
  do  start <- getPosition
      ePart <- exprPart
      exprHelp start [] ePart


exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern
exprHelp start revPatterns (pattern, end) =
  oneOfWithFallback
    [ do  Space.checkIndent end E.PIndentStart
          word2 0x3A 0x3A {-::-} E.PStart
          Space.chompAndCheckIndent E.PSpace E.PIndentStart
          ePart <- exprPart
          exprHelp start (pattern:revPatterns) ePart
    , do  Space.checkIndent end E.PIndentStart
          Keyword.as_ E.PStart
          Space.chompAndCheckIndent E.PSpace E.PIndentAlias
          nameStart <- getPosition
          name <- Var.lower E.PAlias
          newEnd <- getPosition
          Space.chomp E.PSpace
          let alias = A.at nameStart newEnd name
          return
            ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern revPatterns) alias)
            , newEnd
            )
    ]
    ( List.foldl' cons pattern revPatterns
    , end
    )


cons :: Src.Pattern -> Src.Pattern -> Src.Pattern
cons tl hd =
  A.merge hd tl (Src.PCons hd tl)



-- EXPRESSION PART


exprPart :: Space.Parser E.Pattern Src.Pattern
exprPart =
  oneOf E.PStart
    [
      do  start <- getPosition
          upper <- Var.foreignUpper E.PStart
          end <- getPosition
          exprTermHelp (A.Region start end) upper start []
    ,
      do  eterm@(A.At (A.Region _ end) _) <- term
          Space.chomp E.PSpace
          return (eterm, end)
    ]


exprTermHelp :: A.Region -> Var.Upper -> A.Position -> [Src.Pattern] -> Space.Parser E.Pattern Src.Pattern
exprTermHelp region upper start revArgs =
  do  end <- getPosition
      Space.chomp E.PSpace
      oneOfWithFallback
        [ do  Space.checkIndent end E.PIndentStart
              arg <- term
              exprTermHelp region upper start (arg:revArgs)
        ]
        ( A.at start end $
            case upper of
              Var.Unqualified name ->
                Src.PCtor region name (reverse revArgs)

              Var.Qualified home name ->
                Src.PCtorQual region home name (reverse revArgs)
        , end
        )
