--------------------------------------------------------------------------------
-- |
-- Module      :  Material
-- Copyright   :  (c) Vladimir Lopatin 2022
-- License     :  BSD-3-Clause
--
-- Maintainer  :  Vladimir Lopatin <madjestic13@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- Utilities for handling Materials.
--
--------------------------------------------------------------------------------


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TemplateHaskell #-}

module Graphics.RedViz.Material
  ( Material (..)
  , name
  , defaultMat
  , Graphics.RedViz.Material.read
  , write
  , textures
  ) where  

import Control.Lens hiding ((.=))
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.Aeson.TH
import Data.Maybe                (fromMaybe)
import qualified Data.ByteString.Lazy as B
import Data.Text    hiding (drop)

import Graphics.RedViz.Texture as T hiding (name, _name)

data Material
  =  Material
     { -- | Material name.
       Material -> String
_name       :: String
       -- | Path to vertex shader program.
     , Material -> String
_vertShader :: FilePath
       -- | Path to fragment shader program.
     , Material -> String
_fragShader :: FilePath
       -- | Paths to texture bindings and other 'Texture' data.
     , Material -> [Texture]
_textures   :: [Texture]  
     } deriving Int -> Material -> ShowS
[Material] -> ShowS
Material -> String
(Int -> Material -> ShowS)
-> (Material -> String) -> ([Material] -> ShowS) -> Show Material
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Material] -> ShowS
$cshowList :: [Material] -> ShowS
show :: Material -> String
$cshow :: Material -> String
showsPrec :: Int -> Material -> ShowS
$cshowsPrec :: Int -> Material -> ShowS
Show
$(makeLenses ''Material)
deriveJSON defaultOptions {fieldLabelModifier = drop 1} ''Material

defaultMat :: Material
defaultMat :: Material
defaultMat
  = String -> String -> String -> [Texture] -> Material
Material
    String
"default"
    String
"shader.vert"
    String
"shader.frag"
    [Texture
defaultTexture]

-- | Read a Material json-formatted file from disk.
read :: FilePath -> IO Material
read :: String -> IO Material
read String
jsonFile =
  do
    -- print $ "jsonFile :" ++ jsonFile
    Either String Material
d <- (ByteString -> Either String Material
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String Material)
-> IO ByteString -> IO (Either String Material)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
jsonFile) :: IO (Either String Material)
    String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Loading Material :"
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ case Either String Material
d of
           Right Material
m -> Getting String Material String -> Material -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Material String
Lens' Material String
name Material
m
           Either String Material
_ -> String
"error"

    let name' :: String
name'       = (Material -> String
_name       (Material -> String)
-> (Either String Material -> Material)
-> Either String Material
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Material -> Material
forall a. Either a Material -> Material
fromEitherDecode) Either String Material
d
        vertShader' :: String
vertShader' = (Material -> String
_vertShader (Material -> String)
-> (Either String Material -> Material)
-> Either String Material
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Material -> Material
forall a. Either a Material -> Material
fromEitherDecode) Either String Material
d
        fragShader' :: String
fragShader' = (Material -> String
_fragShader (Material -> String)
-> (Either String Material -> Material)
-> Either String Material
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Material -> Material
forall a. Either a Material -> Material
fromEitherDecode) Either String Material
d
        textures' :: [Texture]
textures'   = (Material -> [Texture]
_textures   (Material -> [Texture])
-> (Either String Material -> Material)
-> Either String Material
-> [Texture]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String Material -> Material
forall a. Either a Material -> Material
fromEitherDecode) Either String Material
d
    Material -> IO Material
forall (m :: * -> *) a. Monad m => a -> m a
return (Material -> IO Material) -> Material -> IO Material
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> [Texture] -> Material
Material String
name' String
vertShader' String
fragShader' [Texture]
textures'
      where
        fromEitherDecode :: Either a Material -> Material
fromEitherDecode = Material -> Maybe Material -> Material
forall a. a -> Maybe a -> a
fromMaybe (String -> String -> String -> [Texture] -> Material
Material String
"" String
"" String
"" []) (Maybe Material -> Material)
-> (Either a Material -> Maybe Material)
-> Either a Material
-> Material
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a Material -> Maybe Material
forall a a. Either a a -> Maybe a
fromEither
        fromEither :: Either a a -> Maybe a
fromEither Either a a
d =
          case Either a a
d of
            Right a
pt -> a -> Maybe a
forall a. a -> Maybe a
Just a
pt
            Either a a
_ -> Maybe a
forall a. Maybe a
Nothing

-- | Write a Material json-formatted file to disk.
write :: Material -> FilePath -> IO ()
write :: Material -> String -> IO ()
write Material
mat String
fileOut =
  do
    String -> ByteString -> IO ()
B.writeFile String
fileOut (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> Material -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
config  Material
mat
    where
      config :: Config
config = Config
defConfig { confCompare :: Text -> Text -> Ordering
confCompare = Text -> Text -> Ordering
comp }

comp :: Text -> Text -> Ordering
comp :: Text -> Text -> Ordering
comp = [Text] -> Text -> Text -> Ordering
keyOrder ([Text] -> Text -> Text -> Ordering)
-> ([String] -> [Text]) -> [String] -> Text -> Text -> Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
pack ([String] -> Text -> Text -> Ordering)
-> [String] -> Text -> Text -> Ordering
forall a b. (a -> b) -> a -> b
$ [String
"name", String
"fragShader", String
"vertShader", String
"textures"]