{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE BangPatterns, UnboxedTuples #-}
module Parse.Shader
  ( shader
  )
  where


import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.UTF8 as BS_UTF8
import qualified Data.Map as Map
import qualified Data.Name as Name
import Data.Word (Word8)
import Foreign.Ptr (Ptr, plusPtr, minusPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import qualified Language.GLSL.Parser as GLP
import qualified Language.GLSL.Syntax as GLS
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.Error as Parsec

import qualified AST.Source as Src
import qualified AST.Utils.Shader as Shader
import Parse.Primitives (Parser, Row, Col)
import qualified Parse.Primitives as P
import qualified Reporting.Annotation as A
import qualified Reporting.Error.Syntax as E



-- SHADER


shader :: A.Position -> Parser E.Expr Src.Expr
shader start@(A.Position row col) =
  do  block <- parseBlock
      shdr <- parseGlsl row col block
      end <- P.getPosition
      return (A.at start end (Src.Shader (Shader.fromChars block) shdr))



-- BLOCK


parseBlock :: Parser E.Expr [Char]
parseBlock =
  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
    let
      !pos6 = plusPtr pos 6
    in
    if pos6 <= end
      && P.unsafeIndex (        pos  ) == 0x5B {- [ -}
      && P.unsafeIndex (plusPtr pos 1) == 0x67 {- g -}
      && P.unsafeIndex (plusPtr pos 2) == 0x6C {- l -}
      && P.unsafeIndex (plusPtr pos 3) == 0x73 {- s -}
      && P.unsafeIndex (plusPtr pos 4) == 0x6C {- l -}
      && P.unsafeIndex (plusPtr pos 5) == 0x7C {- | -}
    then
      let
        (# status, newPos, newRow, newCol #) =
          eatShader pos6 end row (col + 6)
      in
      case status of
        Good ->
          let
            !off = minusPtr pos6 (unsafeForeignPtrToPtr src)
            !len = minusPtr newPos pos6
            !block = BS_UTF8.toString (B.PS src off len)
            !newState = P.State src (plusPtr newPos 2) end indent newRow (newCol + 2)
          in
          cok block newState

        Unending ->
          cerr row col E.EndlessShader

    else
      eerr row col E.Start


data Status
  = Good
  | Unending


eatShader :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
eatShader pos end row col =
  if pos >= end then
    (# Unending, pos, row, col #)

  else
    let !word = P.unsafeIndex pos in
    if word == 0x007C {- | -} && P.isWord (plusPtr pos 1) end 0x5D {- ] -} then
      (# Good, pos, row, col #)

    else if word == 0x0A {- \n -} then
      eatShader (plusPtr pos 1) end (row + 1) 1

    else
      let !newPos = plusPtr pos (P.getCharWidth word) in
      eatShader newPos end row (col + 1)



-- GLSL


parseGlsl :: Row -> Col -> [Char] -> Parser E.Expr Shader.Types
parseGlsl startRow startCol src =
  case GLP.parse src of
    Right (GLS.TranslationUnit decls) ->
      return (foldr addInput emptyTypes (concatMap extractInputs decls))

    Left err ->
      let
        pos = Parsec.errorPos err
        row = fromIntegral (Parsec.sourceLine pos)
        col = fromIntegral (Parsec.sourceColumn pos)
        msg =
          Parsec.showErrorMessages
            "or"
            "unknown parse error"
            "expecting"
            "unexpected"
            "end of input"
            (Parsec.errorMessages err)
      in
      if row == 1
        then failure startRow (startCol + 6 + col) msg
        else failure (startRow + row - 1) col msg


failure :: Row -> Col -> [Char] -> Parser E.Expr a
failure row col msg =
  P.Parser $ \(P.State _ _ _ _ _ _) _ _ cerr _ ->
    cerr row col (E.ShaderProblem msg)



-- INPUTS


emptyTypes :: Shader.Types
emptyTypes =
  Shader.Types Map.empty Map.empty Map.empty


addInput :: (GLS.StorageQualifier, Shader.Type, [Char]) -> Shader.Types -> Shader.Types
addInput (qual, tipe, name) glDecls =
  case qual of
    GLS.Attribute -> glDecls { Shader._attribute = Map.insert (Name.fromChars name) tipe (Shader._attribute glDecls) }
    GLS.Uniform   -> glDecls { Shader._uniform = Map.insert (Name.fromChars name) tipe (Shader._uniform glDecls) }
    GLS.Varying   -> glDecls { Shader._varying = Map.insert (Name.fromChars name) tipe (Shader._varying glDecls) }
    _             -> error "Should never happen due to `extractInputs` function"


extractInputs :: GLS.ExternalDeclaration -> [(GLS.StorageQualifier, Shader.Type, [Char])]
extractInputs decl =
  case decl of
    GLS.Declaration
      (GLS.InitDeclaration
         (GLS.TypeDeclarator
            (GLS.FullType
               (Just (GLS.TypeQualSto qual))
               (GLS.TypeSpec _prec (GLS.TypeSpecNoPrecision tipe _mexpr1))))
         [GLS.InitDecl name _mexpr2 _mexpr3]
      ) ->
        case elem qual [GLS.Attribute, GLS.Varying, GLS.Uniform] of
          False -> []
          True ->
              case tipe of
                GLS.Vec2 -> [(qual, Shader.V2, name)]
                GLS.Vec3 -> [(qual, Shader.V3, name)]
                GLS.Vec4 -> [(qual, Shader.V4, name)]
                GLS.Mat4 -> [(qual, Shader.M4, name)]
                GLS.Int -> [(qual, Shader.Int, name)]
                GLS.Float -> [(qual, Shader.Float, name)]
                GLS.Sampler2D -> [(qual, Shader.Texture, name)]
                _ -> []
    _ -> []


