{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
module ParsersTest (parsersTests) where

import Prelude hiding (getChar)

import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck

import Data.Complex (Complex(..))
import Data.Maybe
import Data.Either
import qualified Data.Vector as V

import Control.Arrow (first)

import Parsers
import Val
import LispValTest ()
import EvaluationTest ((?=))

pattern IList xs <- (unrollList -> Just xs)
  where IList xs = makeImmutableList xs

pattern IDottedList xs x <- (unrollDList -> Just (xs, x))
  where IDottedList xs x = makeImproperImmutableList xs x

parsersTests :: TestTree
parsersTests = testGroup "Parser tests" [unitTests, propTests]

unitTests :: TestTree
unitTests = testGroup "Unit tests"
    [ stringParserTests
    , atomParserTests
    , numberParserTests
    , charParserTests
    , listParserTests
    , dotListParserTests
    , vectorParserTests
    , endToEndTests
    ]

propTests :: TestTree
propTests = testGroup "Property tests" [qcTests]

qcTests :: TestTree
qcTests = testGroup "(QuickCheck)"
    [ prop_QuoteParser
    , prop_QuasiquoteParser
    , prop_UnquoteParser
    , prop_UnquoteSplicingParser
    ]

-- END TO END TESTS
endToEndTests = testGroup "End to End" $ map testParseExpr
    [ mkE2Etest
        { testName = "#d Number"
        , input = "12"
        , expectedContents = Just $ Number 12
        }
    , mkE2Etest
        { testName = "#x, negative number"
        , input = "#x-ef"
        , expectedContents = Just $ Number (-239)
        }
    , mkE2Etest
        { testName = "#o, number with +"
        , input = "#o+55"
        , expectedContents = Just $ Number 45
        }
    , mkE2Etest
        { testName = "Char"
        , input = "#\\f"
        , expectedContents = Just $ Char 'f'
        }
    , mkE2Etest
        { testName = "Regular Symbol"
        , input = "symbol"
        , expectedContents = Just $ Symbol "symbol"
        }
    , mkE2Etest
        { testName = "#t"
        , input = "#t"
        , expectedContents = Just $ Bool True
        }
    , mkE2Etest
        { testName = "#f"
        , input = "#f"
        , expectedContents = Just $ Bool False
        }
    , mkE2Etest
        { testName = "Simple string"
        , input = "\"string\""
        , expectedContents = Just $ IString "string"
        }
    , mkE2Etest
        { testName = "Quoted atom"
        , input = "'$name"
        , expectedContents = Just $ IList [Symbol "quote", Symbol "$name"]
        }
    , mkE2Etest
        { testName = "Quoted char"
        , input = "'#\\*"
        , expectedContents = Just $ IList [Symbol "quote", Char '*']
        }
    , mkE2Etest
        { testName = "Immediately nested quote forms"
        , input = "`,4"
        , expectedContents = Just $ IList [Symbol "quasiquote", IList
                                          [Symbol "unquote", Number 4]]
        }
    , mkE2Etest
        { testName = "Quasiquoted mess"
        , input = "`(,(foo) ,@(bar) x 1)"
        , expectedContents = Just $
            IList [Symbol "quasiquote", IList
                  [ IList [Symbol "unquote", IList [Symbol "foo"]]
                  , IList [Symbol "unquote-splicing", IList [Symbol "bar"]]
                  , Symbol "x"
                  , Number 1
                  ]]
        }
    , mkE2Etest
        { testName = "Nested List"
        , input = "(f \"x\" #\\5 (+ 3))"
        , expectedContents = Just $
            IList [Symbol "f", IString "x", Char '5', IList
                  [Symbol "+", Number 3]
            ]
        }
    , mkE2Etest
        { testName = "List with []"
        , input = "[+ 1 2]"
        , expectedContents = Just $
            IList [Symbol "+", Number 1, Number 2]
        }
    , mkE2Etest
        { testName = "List with {}"
        , input = "{test-func #\\a 0}"
        , expectedContents = Just $
            IList [Symbol "test-func", Char 'a', Number 0]
        }
    , mkE2Etest
        { testName = "Regular dotted List"
        , input = "(f 5 #\\$ . (1 2 \"test\"))"
        , expectedContents = Just $
            IList [Symbol "f", Number 5, Char '$'
                  , Number 1, Number 2, IString "test"]
        }
    , mkE2Etest
        { testName = "Dotted with nil"
        , input = "(+ 0 . ())"
        , expectedContents = Just $ IList [Symbol "+", Number 0]
        }
    , mkE2Etest
        { testName = "Irregular dotted List"
        , input = "(f 0 . m)"
        , expectedContents = Just $ IDottedList [Symbol "f", Number 0] (Symbol "m")
        }
    , mkE2Etest
        { testName = "Degenerate dotted List"
        , input = "(. xs)"
        , expectedContents = Just $ Symbol "xs"
        }
    , mkE2Etest
        { testName = "Empty vector"
        , input = "#()"
        , expectedContents = Just $ IVector V.empty
        }
    , mkE2Etest
        { testName = "regular vector"
        , input = "#(\"test\" 0 atom)"
        , expectedContents = Just $ IVector $ V.fromList
            [IString "test", Number 0, Symbol "atom"]
        }
    , mkE2Etest
        { testName = "Irregular spacing"
        , input = "(f 5 #\\$(1 2 #x45) #b10(test))"
        , expectedContents = Just $
            IList
                [Symbol "f", Number 5, Char '$', IList
                    [Number 1, Number 2, Number 69]
                , Number 2, IList
                    [Symbol "test"]
                ]
        }
    , mkE2Etest
        { testName = "Invalid #d number and invalid atom"
        , input = "(+ 1 5b)"
        }
    , mkE2Etest
        { testName = "Invalid symbol"
        , input = "symb`ol"
        }
    , mkE2Etest
        { testName = "Too few parens"
        , input = "(test-func 1 (cons (car xs) (cdr xs))"
        }
    , mkE2Etest
        { testName = "Too many parens"
        , input = "(test-func \"t\" car xs))"
        }
    , mkE2Etest
        { testName = "Extra input after list expr"
        , input = "(test-func + 0) randomwords"
        }
    , mkE2Etest
        { testName = "Extra input after normal expr"
        , input = "#\\c (test-func 0 1)"
        }
    ]

mkE2Etest :: TestBuilder Val
mkE2Etest = TB End2End "" "" Nothing

testParseExpr :: TestBuilder Val -> TestTree
testParseExpr testBuilder =
    testCaseSteps (testName testBuilder) $ \step -> do
        step "Parsing"
        let pInput = input testBuilder
        parse <- run pInput

        if isJust $ expectedContents testBuilder
        then do
            step "Verifying success"
            isRight parse @? "Parse failed on: " ++ pInput

            let val = fromRight undefined parse

            step "Verifying parse"
            -- TODO: we should also verify that the result is
            -- appropriately mutable/immutable.
            Right val ?= Right (fromJust $ expectedContents testBuilder)
        else do
            step "Verifying failure"
            isLeft parse @? "Parse succeeded on: " ++ pInput

-- UNIT TESTS
stringParserTests = testGroup "Parsing Strings" $ map testStringParser
    [ mkStringTest
        { testName = "Simple string"
        , input = "\"simple test string\""
        , expectedContents = Just "simple test string"
        }
    , mkStringTest
        { testName = "Missing start quote"
        , input = "simple test string\""
        }
    , mkStringTest
        { testName = "Missing end quote"
        , input = "\"simple test string"
        }
    , mkStringTest
        { testName = "Unquoted"
        , input = "simple test string"
        }
    , mkStringTest
        { testName = "String with \\"
        , input = "\"test\\\\string\""
        , expectedContents = Just "test\\string"
        }
    , mkStringTest
        { testName = "String with \""
        , input =  "\"test \\\"string in a string\\\" string\""
        , expectedContents = Just "test \"string in a string\" string"
        }
    , mkStringTest
        { testName = "String with newline"
        , input = "\"test string\\nwith two lines\""
        , expectedContents = Just "test string\nwith two lines"
        }
    , mkStringTest
        { testName = "String with carriage return"
        , input = "\"test string \\r with carriage ret\""
        , expectedContents = Just "test string \r with carriage ret"
        }
    , mkStringTest
        { testName = "String with tab"
        , input = "\"test string\\t with tab\""
        , expectedContents = Just "test string\t with tab"
        }
    ]

atomParserTests :: TestTree
atomParserTests = testGroup "Parsing Symbols" $ map testSymbolParser
    [ let symbol = "atom" in mkSymbolTest
        { testName = "Simple atom"
        , input = symbol
        , expectedContents = Just $ pack symbol
        }
    , let symbol = "#name" in mkSymbolTest
        { testName = "Symbol with #"
        , input = symbol
        }
    , let symbol = "!@#$%&*-_=+|:\\/?<>~" in mkSymbolTest
        { testName = "Symbol with all symbols"
        , input = symbol
        , expectedContents = Just $ pack symbol
        }
    , let symbol = "t1" in mkSymbolTest
        { testName = "Symbol with digit"
        , input = symbol
        , expectedContents = Just $ pack symbol
        }
    , mkSymbolTest
        { testName = "Symbol starts with digit"
        , input = "5a"
        }
    , mkSymbolTest
        { testName = "Symbol with brackets"
        , input = "na[]me"
        }
    , mkSymbolTest
        { testName = "Symbol with braces"
        , input = "na{}me"
        }
    , mkSymbolTest
        { testName = "Symbol with invalid symbols"
        , input = "AlmostValidSymbol`name"
        }
    , let symbol = "Complex#Valid15Symbol\\Name8?" in mkSymbolTest
        { testName = "Complex valid atom"
        , input = symbol
        , expectedContents = Just $ pack symbol
        }
    , mkSymbolTest
        { testName = "vertical bar symbol"
        , input = "|H\\x65;llo|"
        , expectedContents = Just "Hello"
        }
    ]

numberParserTests :: TestTree
numberParserTests = testGroup "Parsing Numbers" $ map testNumberParser
    [ mkNumTest
        { testName = "25"
        , input = "25"
        , expectedContents = Just 25
        }
   , mkNumTest
        { testName = "-2"
        , input = "-2"
        , expectedContents = Just (-2)
        }
    , mkNumTest
        { testName = "+15"
        , input = "+15"
        , expectedContents = Just 15
        }
    , mkNumTest
        { testName = "#d80915"
        , input = "#d80915"
        , expectedContents = Just 80915
        }
    , mkNumTest
        { testName = "#d-100"
        , input = "#d-100"
        , expectedContents = Just (-100)
        }
    , mkNumTest
        { testName = "#d+06"
        , input = "#d+06"
        , expectedContents = Just 6
        }
    , mkNumTest
        { testName = "#b1010"
        , input = "#b1010"
        , expectedContents = Just 10
        }
    , mkNumTest
        { testName = "#b-11101"
        , input = "#b-11101"
        , expectedContents = Just (-29)
        }
    , mkNumTest
        { testName = "#b+1011"
        , input = "#b+1011"
        , expectedContents = Just 11
        }
    , mkNumTest
        { testName = "#o517"
        , input = "#o517"
        , expectedContents = Just 335
        }
    , mkNumTest
        { testName = "#o-24"
        , input = "#o-24"
        , expectedContents = Just (-20)
        }
    , mkNumTest
        { testName = "#o+36"
        , input = "#o+36"
        , expectedContents = Just 30
        }
    , mkNumTest
        { testName = "#xf4"
        , input = "#xf4"
        , expectedContents = Just 244
        }
    , mkNumTest
        { testName = "#x-cb8"
        , input = "#x-cb8"
        , expectedContents = Just (-3256)
        }
    , mkNumTest
        { testName = "#x+aa1"
        , input = "#x+aa1"
        , expectedContents = Just 2721
        }
    , mkNumTest
        { testName = "0.5"
        , input = "0.5"
        , expectedContents = Just (Real (Flonum 0.5))
        }
    , mkNumTest
        { testName = "#e0.5"
        , input = "#e0.5"
        , expectedContents = Just (Real (Ratnum 0.5))
        }
    , mkNumTest
        { testName = "infinity"
        , input = "+inf.0"
        , expectedContents = Just (Real (Flonum (1/0)))
        }
    , mkNumTest
        { testName = "rational"
        , input = "3/5"
        , expectedContents = Just (Real (Ratnum (3/5)))
        }
    , mkNumTest
        { testName = "rectangular complex"
        , input = "1+1i"
        , expectedContents = Just (Complex (1 :+ 1))
        }
    , mkNumTest
        { testName = "rectangular with scientific notation"
        , input = "2e+5+3i"
        , expectedContents = Just (Complex (2e+5 :+ 3))
        }
    , mkNumTest
        -- this is _almost_ a peculiar identifier, but the dot subsequent
        -- cannot be a number.
        { testName = "werid rectangular 0"
        , input = "-.0i"
        , expectedContents = Just (Complex (0 :+ (-0.0)))
        }
    , mkNumTest
        { testName = "15a3"
        , input = "15a3"
        }
    , mkNumTest
        { testName = "#b1201"
        , input = "#b1201"
        }
    , mkNumTest
        { testName = "#bnx"
        , input = "#bnx"
        }
    , mkNumTest
        { testName = "#o358"
        , input = "#o358"
        }
    , mkNumTest
        { testName = "#oa"
        , input = "#oa"
        }
    , mkNumTest
        { testName = "#x54mk"
        , input = "#x54mk"
        }
    , mkNumTest
        { testName = "Empty string"
        , input = ""
        }
    ]

charParserTests :: TestTree
charParserTests = testGroup "Parsing Chars" $ map testCharParser
    [ mkCharTest
        { testName = "Basic single character"
        , input = "#\\k"
        , expectedContents = Just 'k'
        }
    , mkCharTest
        { testName = "Basic single character"
        , input = "#\\$"
        , expectedContents = Just '$'
        }
    , mkCharTest
        { testName = "Basic single character"
        , input = "#\\`"
        , expectedContents = Just '`'
        }
    , mkCharTest
        { testName = "Too many characters"
        , input = "#\\ab"
        }
    , mkCharTest
        { testName = "No \\"
        , input = "#8"
        }
    , mkCharTest
        { testName = "Space"
        , input = "#\\space"
        , expectedContents = Just ' '
        }
    , mkCharTest
        { testName = "Newline"
        , input = "#\\newline"
        , expectedContents = Just '\n'
        }
    , mkCharTest
        { testName = "Carriage return"
        , input = "#\\return"
        , expectedContents = Just '\r'
        }
    , mkCharTest
        { testName = "Tab"
        , input = "#\\tab"
        , expectedContents = Just '\t'
        }
    , mkCharTest
        { testName = "escaped unicode"
        , input = "#\\x3bb"
        , expectedContents = Just 'λ'
        }
    ]

listParserTests :: TestTree
listParserTests = testGroup "Parsing Lists"
    [ testCase "\"(5 a #\\a)\"" $ do
        p <- run "(5 a #\\a)"
        isRight p @? "Parse failed."
        let val = unrollList $ fromRight undefined p
        isJust val @? "Parse did not return a list."
        let correct = case fromJust val of
                [Number 5, Symbol "a", Char 'a'] -> True
                _ -> False
        correct @? "Contents of the list are wrong: " ++ show (fromJust val)
    ]

dotListParserTests :: TestTree
dotListParserTests = testGroup "Parsing Dotted Lists"
    [ testCase "\"(5 a . #\\a)\"" $ do
        p <- run "(5 a . #\\a)"
        isRight p @? "Parse failed."
        let Right val = p
            mpair = unrollDList val
        isJust mpair @? "Parse did not return a dotted list."
        let correct = case fromJust mpair of
              ([Number 5, Symbol "a"], Char 'a') -> True
              _ -> False
        correct @? "Contents of the dotted list are wrong: " ++ show val
    ]

vectorParserTests :: TestTree
vectorParserTests = testGroup "Parsing vectors"
    [ testCase "\"#(1 #\\x ())\"" $ do
        p <- run "#(1 #\\x ())"
        val <- verify p
        fromJust val @?= V.fromList [Number 1, Char 'x', Nil]
    , testCase "\"#()\"" $ do
        p <- run "#()"
        val <- verify p
        fromJust val @?= V.empty
    ]
  where verify p = do
            isRight p @? "Parse failed."
            let val = case fromRight undefined p of
                    IVector v -> Just v
                    _ -> Nothing
            isJust val @? "Parse did not return an IVector."
            return val

-- PROPERTY TESTS
prop_QuoteParser :: TestTree
prop_QuoteParser = testProperty "tick always results in quote" $
    withMaxSuccess 50 $ \input -> ioProperty $ do
        result <- run ('\'' : show (input :: Val))
        return $ isRight result ==> case result of
            Right (IPair (Symbol "quote") _) -> True
            _ -> False

prop_QuasiquoteParser :: TestTree
prop_QuasiquoteParser = testProperty "backtick always results in quasiquote" $
    withMaxSuccess 50 $ \input -> ioProperty $ do
        result <- run ('`' : show (input :: Val))
        return $ isRight result ==> case result of
            Right (IPair (Symbol "quasiquote") _)  -> True
            _ -> False

prop_UnquoteParser :: TestTree
prop_UnquoteParser = testProperty "comma always results in unquote" $
    withMaxSuccess 50 $ \input -> ioProperty $ do
        result <- run (',' : clean (show (input :: Val)))
        return $ isRight result ==> case result of
            Right (IPair (Symbol "unquote") _)  -> True
            _ -> False
  -- if we don't do this, a LispString/Symbol that starts with '@' will turn it into
  -- an unquote splicing, which happened in a test at least once.
  where clean = dropWhile (== '@')

prop_UnquoteSplicingParser :: TestTree
prop_UnquoteSplicingParser = testProperty "comma@ always results in unquote-splicing" $
    withMaxSuccess 50 $ \input -> ioProperty $ do
        result <- run (",@" ++ show (input :: Val))
        return $ isRight result ==> case result of
            Right (IPair (Symbol "unquote-splicing") _)  -> True
            _ -> False

run :: String -> IO (Either LispErr Val)
run = labeledReadExpr ""

parseSucceeds :: String -> IO Bool
parseSucceeds s = isRight <$> run s

testStringParser :: TestBuilder Text -> TestTree
testStringParser tb = testParser tb getString

testSymbolParser :: TestBuilder Symbol -> TestTree
testSymbolParser tb = testParser tb getSymbol

testNumberParser :: TestBuilder Number -> TestTree
testNumberParser tb = testParser tb getNumber

testCharParser :: TestBuilder Char -> TestTree
testCharParser tb = testParser tb getChar

data TestType = TString | TSymbol | TNumber | TChar | End2End
instance Show TestType where
    show TString = "String"
    show TSymbol = "Symbol"
    show TNumber = "Number"
    show TChar   = "Char"
    show End2End = "End to End"

data TestBuilder a = TB { testType :: TestType
                        , testName :: String
                        , input :: String
                        , expectedContents :: Maybe a
                        }

mkStringTest, mkSymbolTest, mkNumTest, mkCharTest :: TestBuilder a
mkStringTest = TB TString "String Parser Test" "" Nothing
mkSymbolTest = TB TSymbol "Symbol Parser Test" "" Nothing
mkNumTest = TB TNumber "Number Parser Test" "" Nothing
mkCharTest = TB TChar "Char Parser Test" "" Nothing

testParser :: (Eq a, Show a)
           => TestBuilder a
           -> (Val -> Maybe a)
           -> TestTree
testParser testBuilder decons =
    testCaseSteps (testName testBuilder) $ \step -> do
        step "Parsing"
        parse <- run $ input testBuilder

        if isJust $ expectedContents testBuilder
        then do
            step "Verifying success"
            isRight parse @? "Parse failed on: " ++ input testBuilder

            step "Verifying type"
            let val = (decons . fromRight undefined) parse

            isJust val @? "Parse did not produce a "
                          ++ show (testType testBuilder) ++ "."

            step "Verifying contents"
            fromJust val @?= fromJust (expectedContents testBuilder)
        else do
            step "Verifying failure"
            isLeft parse @? "Parse succeeded on: " ++ input testBuilder

getString :: Val -> Maybe Text
getString (IString s) = Just s
getString _          = Nothing

getSymbol :: Val -> Maybe Symbol
getSymbol (Symbol s) = Just s
getSymbol _        = Nothing

getNumber :: Val -> Maybe Number
getNumber (Number n) = Just n
getNumber _ = Nothing

getChar :: Val -> Maybe Char
getChar (Char c) = Just c
getChar _        = Nothing

unrollList :: Val -> Maybe [Val]
unrollList (IPair c d) =
    (c:) <$> unrollList d
unrollList Nil = Just []
unrollList _ = Nothing

unrollDList :: Val -> Maybe ([Val], Val)
unrollDList (IPair c d) =
    first (c:) <$> unrollDList d
unrollDList Nil = Nothing -- not dotted
unrollDList obj = Just ([], obj)


-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Plot.Render.Plot
-- Copyright   :  (c) A. V. H. McPhail 2010
-- License     :  BSD3
--
-- Maintainer  :  haskell.vivian.mcphail <at> gmail <dot> com
-- Stability   :  provisional
-- Portability :  portable
--
-- Rendering 'Figure's
--
-----------------------------------------------------------------------------

module Graphics.Rendering.Plot.Render.Plot (
                                       -- * Rendering
                                       renderPlots
                                       ) where

-----------------------------------------------------------------------------

--import Data.Either

--import Data.Packed.Vector
--import Numeric.LinearAlgebra.Linear

--import Data.Word

--import Data.Maybe

--import Data.Colour.SRGB
--import Data.Colour.Names

import qualified Data.Array.IArray as A

import Data.Colour.Names

import qualified Graphics.Rendering.Cairo as C
--import qualified Graphics.Rendering.Pango as P

--import Control.Monad.Reader
import Control.Monad.State
--import Control.Monad.Trans

import Graphics.Rendering.Plot.Types
--import Graphics.Rendering.Plot.Defaults

--import Graphics.Rendering.Plot.Figure.Text

import Graphics.Rendering.Plot.Render.Types

import Graphics.Rendering.Plot.Render.Text
import Graphics.Rendering.Plot.Render.Plot.Axis
import Graphics.Rendering.Plot.Render.Plot.Data
import Graphics.Rendering.Plot.Render.Plot.Legend
import Graphics.Rendering.Plot.Render.Plot.Annotation

--import qualified Text.Printf as Printf

--import Prelude hiding(min,max)
--import qualified Prelude(max)

-----------------------------------------------------------------------------

bbPlot :: Int -> Int -> (Int,Int) -> Render ()
bbPlot r c (px,py) = modify (\(BoundingBox x y w h) ->
  let w' = w/(fromIntegral c)
      h' = h/(fromIntegral r)
  in (BoundingBox
      (x+w'*((fromIntegral py)-1))
      (y+h'*((fromIntegral px)-1))
      w' h'))

renderPlots :: Plots -> Render ()
renderPlots d = do
  let ((x,y),(x',y')) = A.bounds d
      rows = x'-x+1
      cols = y'-y+1
  bb <- get
  mapM_ (\(i,e) -> do
    case e of
      Nothing -> return ()
      Just e' -> do
        bbPlot rows cols i
        renderPlot e'
        put bb) (A.assocs d)

renderPlot :: PlotData -> Render ()
renderPlot (Plot b c p hd r a bc sd d l an) = do
  tx <- bbCentreWidth
  ty <- bbTopHeight
  (_,th) <- renderText hd Centre TTop tx ty
  when (th /= 0) $ bbLowerTop (th+textPad)
  legend <- renderLegend l d
  (axes,padding) <- renderAxes p r a
  renderBorder b
  cairo C.save
  clipBoundary
  when (c /= white) (do
    cairo $ do
      setColour c
      C.paint)
  renderData r bc sd d
  renderAnnotations r an
  cairo C.restore
  cairo C.save
  legend padding
  cairo C.restore
  cairo C.save
  axes
  cairo C.restore

renderBorder :: Border -> Render ()
renderBorder False = return ()
renderBorder True  = do
  (BoundingBox x y w h) <- get
  cairo $ do
    C.setLineWidth 0.5
    C.rectangle (x+0.5) (y+0.5) w h
    C.stroke

-----------------------------------------------------------------------------


{-# LANGUAGE OverloadedStrings #-}
module ML.Gym.DType where

import qualified Control.Exception        as E
import           Control.Monad            (join, liftM, void)
import qualified CPython                  as Py
import qualified CPython.Constants        as Py
import qualified CPython.Protocols.Object as Py
import qualified CPython.Types            as Py
import qualified CPython.Types.Exception  as Py
import qualified CPython.Types.Module     as Py
import qualified CPython.Types.Module     as Py
import qualified Data.ByteString          as BS
import           Data.Complex             (Complex)
import           Data.Maybe               (fromMaybe)
import qualified Data.Text                as T
import           System.Environment       (getArgs, getProgName)
import           System.Exit
import           System.IO
import           System.Random            (randomRIO)

data GymDType = GymBool | GymInteger | GymFloat | GymObject | GymByteString | GymText | GymVoid
  deriving (Show, Eq)

-------------------- Converting --------------------

pyToInteger :: Py.SomeObject -> IO (Maybe Integer)
pyToInteger = pyToA Py.fromInteger

pyToText :: Py.SomeObject -> IO (Maybe T.Text)
pyToText = pyToA Py.fromUnicode

pyToFloat :: Py.SomeObject -> IO (Maybe Double)
pyToFloat = pyToA Py.fromFloat

pyToDouble :: Py.SomeObject -> IO (Maybe Double)
pyToDouble = pyToFloat

pyToBool :: Py.SomeObject -> IO (Maybe Bool)
pyToBool obj = do
  true <- Py.isTrue obj
  if true
    then return $ Just True
    else do
    false <- Py.isFalse obj
    if false
      then return $ Just False
      else return $ Nothing

pyToVoid :: Py.SomeObject -> IO (Maybe ())
pyToVoid _ = return $ Just ()

pyToComplex :: Py.SomeObject -> IO (Maybe (Complex Double))
pyToComplex = pyToA Py.fromComplex

pyToByteString :: Py.SomeObject -> IO (Maybe BS.ByteString)
pyToByteString = pyToA Py.fromBytes

pyToTupleList :: Py.SomeObject -> IO (Maybe [Py.SomeObject])
pyToTupleList = pyToA Py.fromTuple

pyToList :: Py.SomeObject -> IO (Maybe [Py.SomeObject])
pyToList = pyToA Py.fromList

pyToListOf :: (Py.SomeObject -> IO (Maybe a)) -> Py.SomeObject -> IO (Maybe [a])
pyToListOf convert = fmap join . join . fmap (traverse (fmap sequence . mapM convert)) . pyToList

pyToListOfListOf :: (Py.SomeObject -> IO (Maybe a)) -> Py.SomeObject -> IO (Maybe [[a]])
pyToListOfListOf convert obj = do
  mList <- pyToList obj
  join . fmap sequence <$> sequence (mapM (pyToListOf convert) <$> mList)

pyToListOfListOfListOf :: (Py.SomeObject -> IO (Maybe a)) -> Py.SomeObject -> IO (Maybe [[[a]]])
pyToListOfListOfListOf convert obj = do
  mList <- pyToList obj
  join . fmap sequence <$> sequence (mapM (pyToListOfListOf convert) <$> mList)

pyToA :: (Py.Concrete b) => (b -> IO a) -> Py.SomeObject -> IO (Maybe a)
pyToA convert obj = do
  isNone <- Py.isNone obj
  if isNone
    then return Nothing
    else Py.cast obj >>= traverse convert

getGymDType :: Py.Object self => self -> IO GymDType
getGymDType dType = do
  kind <- T.unpack . fromMaybe (error "gym type 'kind' not recognized!") <$> (Py.toUnicode "kind" >>= Py.getAttribute dType >>= pyToText)
  return $
    case kind of
      "b" -> GymBool       -- boolean
      "i" -> GymInteger    -- signed integer
      "u" -> GymInteger    -- unsigned integer
      "f" -> GymFloat      -- floating-point
      "c" -> GymFloat      -- complex floating-point
      "m" -> GymInteger    -- timedelta
      "M" -> GymInteger    -- datetime
      "O" -> GymObject     -- object
      "S" -> GymByteString -- (byte-)string
      "U" -> GymText       -- Unicode
      "V" -> GymVoid       -- void
      _ -> error $ "ERROR: unknown gym (numpy) data type/kind named '" ++ show kind ++ "'!"


{-# LANGUAGE OverloadedLists, TemplateHaskell #-}

module Data.SkyBox where

import qualified Graphics.Rendering.OpenGL.GL as GL
import           Graphics.Rendering.OpenGL.GL (($=))
import           Numeric.LinearAlgebra (flatten,ident)
import           Control.Monad
import           Control.Lens
import qualified Data.Vector.Storable as VS
import           Foreign (sizeOf)
import           Foreign.Ptr (intPtrToPtr)

import Data.Mesh
import Data.GameObject
import Data.Shaders

data SkyBox = SkyBox { _skyTex :: GL.TextureObject,
                       _skyVao :: GL.VertexArrayObject,
                       _skyVbo :: GL.BufferObject,
                       _shad   :: Shaders }

makeLenses ''SkyBox

drawSkyBox cam proj b = do
  GL.depthMask $= GL.Disabled
  GL.currentProgram $= Just (b^.shad.program)
  GL.bindVertexArrayObject $= Just (b^.skyVao)

  passMatrix "camera" $ flatten cam
  passMatrix "proj" proj

  passTexture "skytex" 3 $ Just $ b^.skyTex
  GL.drawArrays GL.Triangles 0 36
  GL.depthMask $= GL.Enabled
  where
    passMatrix = passMatrixToProg $ b^.shad
    passTexture = passTextureToProg GL.TextureCubeMap $ b^.shad

loadSkyBox = do
  let uni = ["camera", "proj", "skytex"] :: [String]
  shad <- loadShaders "shaders/cubevert.glsl" "shaders/cubefrag.glsl" uni
  tex <- loadTextures fnames
  createSkyBox shad tex

createSkyBox shad tex = do
  vao <- GL.genObjectName
  GL.bindVertexArrayObject $= Just vao
  vbo <- createAndBindArrayBuffer GL.ArrayBuffer skyboxVertices
  let glFloatSize = sizeOf (undefined :: GL.GLfloat)
  loc <- GL.get $ GL.attribLocation (shad^.program) "aPos"
  GL.vertexAttribPointer loc $=
    (GL.ToFloat,
     GL.VertexArrayDescriptor 3 GL.Float 0 $ intPtrToPtr $ fromIntegral 0)
  GL.vertexAttribArray loc $= GL.Enabled
  GL.bindVertexArrayObject $= Nothing
  return $ SkyBox tex vao vbo shad

texTargets =
  [ GL.TextureCubeMapPositiveX
  , GL.TextureCubeMapNegativeX
  , GL.TextureCubeMapPositiveY
  , GL.TextureCubeMapNegativeY
  , GL.TextureCubeMapPositiveZ
  , GL.TextureCubeMapNegativeZ ]

fnames :: [String]
fnames = -- map (("media/SkyBox/"++).(++".jpg")) . replicate 6 $ "Starscape"
  map ("media/sbox2/cgp_1/textures/"++) [ "xpos.png", "xneg.png", "ypos.png", "yneg.png", "zpos.png", "zneg.png"]

  -- [ "right"
  -- , "left"
  -- , "up"
  -- , "bottom"
  -- , "front"
  -- , "back" ]

loadTextures fns = do
  texName <- GL.genObjectName
  GL.textureBinding GL.TextureCubeMap $= Just texName
  zipWithM_ loadAndBindImage texTargets fns
  GL.textureFilter GL.TextureCubeMap $=
    ((GL.Linear', Nothing),GL.Linear')
  mapM_ setWrapping dirs
  return texName
  where setWrapping dir =
          GL.textureWrapMode GL.TextureCubeMap dir $=
            (GL.Repeated, GL.ClampToBorder)
        dirs = [GL.S, GL.T, GL.R] :: [GL.TextureCoordName]

skyboxVertices :: VS.Vector Float
skyboxVertices = [
    -1.0,  1.0, -1.0,
    -1.0, -1.0, -1.0,
     1.0, -1.0, -1.0,
     1.0, -1.0, -1.0,
     1.0,  1.0, -1.0,
    -1.0,  1.0, -1.0,

    -1.0, -1.0,  1.0,
    -1.0, -1.0, -1.0,
    -1.0,  1.0, -1.0,
    -1.0,  1.0, -1.0,
    -1.0,  1.0,  1.0,
    -1.0, -1.0,  1.0,

     1.0, -1.0, -1.0,
     1.0, -1.0,  1.0,
     1.0,  1.0,  1.0,
     1.0,  1.0,  1.0,
     1.0,  1.0, -1.0,
     1.0, -1.0, -1.0,

    -1.0, -1.0,  1.0,
    -1.0,  1.0,  1.0,
     1.0,  1.0,  1.0,
     1.0,  1.0,  1.0,
     1.0, -1.0,  1.0,
    -1.0, -1.0,  1.0,

    -1.0,  1.0, -1.0,
     1.0,  1.0, -1.0,
     1.0,  1.0,  1.0,
     1.0,  1.0,  1.0,
    -1.0,  1.0,  1.0,
    -1.0,  1.0, -1.0,

    -1.0, -1.0, -1.0,
    -1.0, -1.0,  1.0,
     1.0, -1.0, -1.0,
     1.0, -1.0, -1.0,
    -1.0, -1.0,  1.0,
     1.0, -1.0,  1.0 ]


-- |
-- Module      : Occlusion.Lenses
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental|stable
-- Portability : POSIX (not sure)
--

-- Created September 20 2015

-- TODO | -
--        -

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC Pragmas
--------------------------------------------------------------------------------------------------------------------------------------------
{-# LANGUAGE Rank2Types #-}

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module Occlusion.Lenses where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Control.Lens
import Data.Complex
import Data.Functor
import qualified Data.Set as S
import qualified Data.Map as M

import Graphics.UI.Gtk
import qualified Graphics.Rendering.Cairo as Cairo

import qualified Southpaw.Picasso.Palette as Palette

import Occlusion.Types

--------------------------------------------------------------------------------------------------------------------------------------------
-- Lenses
--------------------------------------------------------------------------------------------------------------------------------------------
-- AppState --------------------------------------------------------------------------------------------------------------------------------

gui :: Lens AppState AppState GUI GUI
gui f s = (\new -> s { _gui=new }) <$> f (_gui s)

animation :: Lens AppState AppState AnimationData AnimationData
animation f s = (\new -> s { _animation=new }) <$> f (_animation s)

input :: Lens AppState AppState InputData InputData
input f s = (\new -> s { _input=new }) <$> f (_input s)

scene :: Lens AppState AppState Scene Scene
scene f s = (\new -> s { _scene=new }) <$> f (_scene s)

assets :: Lens AppState AppState Assets Assets
assets f s = (\new -> s { _assets=new }) <$> f (_assets s)

-- GUI -------------------------------------------------------------------------------------------------------------------------------------

window :: Lens GUI GUI Window Window
window f s = (\new -> s { _window=new }) <$> f (_window s)

canvas :: Lens GUI GUI DrawingArea DrawingArea
canvas f s = (\new -> s { _canvas=new }) <$> f (_canvas s)

-- InputData -------------------------------------------------------------------------------------------------------------------------------

mouse :: Lens InputData InputData (Complex Double) (Complex Double)
mouse f s = (\new -> s { _mouse=new }) <$> f (_mouse s)

click :: Lens InputData InputData (Maybe (Complex Double)) (Maybe (Complex Double))
click f s = (\new -> s { _click=new }) <$> f (_click s)

keyboard :: Lens InputData InputData (S.Set String) (S.Set String)
keyboard f s = (\new -> s { _keyboard=new }) <$> f (_keyboard s)

-- AnimationData ---------------------------------------------------------------------------------------------------------------------------

fps :: Lens AnimationData AnimationData Double Double
fps f s = (\new -> s { _fps=new }) <$> f (_fps s)

frame :: Lens AnimationData AnimationData Int Int
frame f s = (\new -> s { _frame=new }) <$> f (_frame s)

-- Scene -----------------------------------------------------------------------------------------------------------------------------------

player :: Lens Scene Scene Character Character
player f s = (\new -> s { _player=new }) <$> f (_player s)

npcs :: Lens Scene Scene [Character] [Character]
npcs f s = (\new -> s { _npcs=new }) <$> f (_npcs s)

obstacles :: Lens Scene Scene [Polygon Double] [Polygon Double]
obstacles f s = (\new -> s { _obstacles=new }) <$> f (_obstacles s)

-- Complex ---------------------------------------------------------------------------------------------------------------------------------

images :: Lens Assets Assets (M.Map String Cairo.Surface) (M.Map String Cairo.Surface)
images f s = (\new -> s { _images=new }) <$> f (_images s)

-- Character -------------------------------------------------------------------------------------------------------------------------------

position :: Lens Character Character (Complex Double) (Complex Double)
position f s = (\new -> s { _position=new }) <$> f (_position s)

velocity :: Lens Character Character (Complex Double) (Complex Double)
velocity f s = (\new -> s { _velocity=new }) <$> f (_velocity s)

name :: Lens Character Character String String
name f s = (\new -> s { _name=new }) <$> f (_name s)

colour :: Lens Character Character (Palette.Colour Double) (Palette.Colour Double)
colour f s = (\new -> s { _colour=new }) <$> f (_colour s)

behaviour :: Lens Character Character (Behaviour Character AppState Character) (Behaviour Character AppState Character)
behaviour f s = (\new -> s { _behaviour=new }) <$> f (_behaviour s)

-- Complex ---------------------------------------------------------------------------------------------------------------------------------

real :: Lens (Complex n) (Complex n) n n
real f (re:+im) = (:+im) <$> f re

imag :: Lens (Complex n) (Complex n) n n
imag f (re:+im) = (re:+) <$> f im

-- List ------------------------------------------------------------------------------------------------------------------------------------

-- nth :: Functor f => Int -> (Character -> f Character) -> [Character] -> f [Character]
nth :: Int -> Lens [a] [a] a a
nth i f s = assemble <$> f (s !! i)
  where
    assemble new = let (before, _:fter) = splitAt i s in before ++ [new] ++ fter

-- Lines -----------------------------------------------------------------------------------------------------------------------------------

linebegin :: Lens (Line a) (Line a) (Complex a) (Complex a)
linebegin f (Line fr to) = (`Line` to) <$> f fr

linestop :: Lens (Line a) (Line a) (Complex a) (Complex a)
linestop f (Line fr to) = (fr `Line`) <$> f to


{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MonoLocalBinds #-}
module Data.StoreSpec where

import           Control.Applicative
import           Control.Exception (evaluate)
import           Control.Monad (unless)
import           Control.Monad.Fail (MonadFail)
import qualified Data.Array.Unboxed as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Short as SBS
import           Data.Complex (Complex(..))
import           Data.Containers (mapFromList, setFromList)
import           Data.Fixed (Pico)
import           Data.Generics (listify)
import           Data.HashMap.Strict (HashMap)
import           Data.HashSet (HashSet)
import           Data.Hashable (Hashable)
import           Data.Int
import           Data.IntMap (IntMap)
import           Data.IntSet (IntSet)
import qualified Data.List.NonEmpty as NE
import           Data.Map (Map)
import           Data.Monoid
import           Data.Proxy (Proxy(..))
import           Data.Sequence (Seq)
import           Data.Sequences (fromList)
import           Data.Set (Set)
import           Data.Store
import           Data.Store.Internal
import           Data.Store.TH
import           Data.Store.TH.Internal
import           Data.Store.TypeHash
import           Data.StoreSpec.TH
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Time as Time
import qualified Data.Time.Clock.TAI as Time
import           Data.Typeable (Typeable)
import qualified Data.Vector as V
import qualified Data.Vector.Primitive as PV
import qualified Data.Vector.Storable as SV
import qualified Data.Vector.Unboxed as UV
import           Data.Word
import           Foreign.C.Types
import           Foreign.Ptr
import           Foreign.Storable (Storable, sizeOf)
import           GHC.Fingerprint.Type (Fingerprint(..))
import           GHC.Generics
import           GHC.Real (Ratio(..))
#if MIN_VERSION_base(4,15,0)
import           GHC.RTS.Flags (IoSubSystem(..))
#endif
import           Language.Haskell.TH
import           Language.Haskell.TH.Syntax
import           Network.Socket
import           Numeric.Natural (Natural)
import           Prelude
import           System.Clock (TimeSpec(..))
import           System.Posix.Types
import           Test.Hspec hiding (runIO)
import           Test.SmallCheck.Series
import           TH.Utilities (unAppsT)

#if !MIN_VERSION_primitive(0,7,0)
import           Data.Primitive.Types (Addr)
#endif

#if MIN_VERSION_time(1,8,0)
import qualified Data.Time.Clock.System as Time
#endif
#if MIN_VERSION_time(1,9,0)
import qualified Data.Time.Format.ISO8601 as Time
#endif
#if MIN_VERSION_time(1,11,0)
import qualified Data.Time.Calendar.Quarter as Time
#endif

#if !MIN_VERSION_smallcheck(1,2,0)
import           Data.Void (Void)
#endif

------------------------------------------------------------------------
-- Instances for base types

addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a]
addMinAndMaxBounds xs =
    (if (minBound :: a) `notElem` xs then [minBound] else []) ++
    (if (maxBound :: a) `notElem` xs && (maxBound :: a) /= minBound then maxBound : xs else xs)

$(mkManyHasTypeHash [ [t| Int32 |] ])

-- Serial instances for (Num a, Bounded a) types. Only really
-- appropriate for the use here.

#if !MIN_VERSION_network(3,1,2)
instance Bounded PortNumber where
  minBound = 0
  maxBound = 65535
#endif

$(do let ns = [ ''PortNumber

#if !MIN_VERSION_smallcheck(1,2,0)
              , ''CWchar, ''CUShort, ''CULong, ''CULLong, ''CIntMax
              , ''CUIntMax, ''CPtrdiff, ''CSChar, ''CShort, ''CUInt, ''CLLong
              , ''CLong, ''CInt, ''CChar
#endif
              , ''CSsize, ''CPid
              , ''COff, ''CMode, ''CIno, ''CDev
#if !MIN_VERSION_smallcheck(1,1,4)
              , ''Word8, ''Word16, ''Word32, ''Word64
              , ''Int8, ''Int16, ''Int32, ''Int64
#endif
#if !MIN_VERSION_smallcheck(1,1,3)
              , ''Word
#endif
#if MIN_VERSION_base(4,10,0)
#if !MIN_VERSION_smallcheck(1,2,0)
              , ''CBool
#endif
              , ''CClockId, ''CKey, ''CId
              , ''CBlkSize, ''CFsBlkCnt, ''CFsFilCnt, ''CBlkCnt
#endif
#if MIN_VERSION_base(4,14,0)
              , ''CSocklen, ''CNfds
#endif
#ifndef mingw32_HOST_OS
              , ''CUid, ''CTcflag, ''CRLim, ''CNlink, ''CGid
#endif
              ]
         f n = [d| instance Monad m => Serial m $(conT n) where
                      series = generate (\_ -> addMinAndMaxBounds [0, 1]) |]
     concat <$> mapM f ns)

-- Serial instances for (Num a) types. Only really appropriate for the
-- use here.

$(do let ns =
#if !MIN_VERSION_smallcheck(1,2,0)
              [ ''CUSeconds, ''CClock, ''CTime, ''CUChar, ''CSize, ''CSigAtomic
              ,  ''CSUSeconds, ''CFloat, ''CDouble
              ] ++
#endif
#if !MIN_VERSION_smallcheck(1,1,3)
              [ ''Natural ] ++
#endif
#ifndef mingw32_HOST_OS
              [ ''CSpeed, ''CCc ] ++
#endif
              []
         f n = [d| instance Monad m => Serial m $(conT n) where
                      series = generate (\_ -> [0, 1]) |]
     concat <$> mapM f ns)

-- Serial instances for Primitive vectors

$(do tys <- getAllInstanceTypes1 ''PV.Prim
     let f ty = [d| instance (Serial m $(return ty), Monad m) => Serial m (PV.Vector $(return ty)) where
                      series = fmap PV.fromList series |]
     concat <$> mapM f (filter (\ty -> length (unAppsT ty) == 1) tys))

$(do let ns = [ ''Dual, ''Sum, ''Product, ''First, ''Last ]
         f n = [d| instance (Monad m, Serial m a) => Serial m ($(conT n) a) |]
     concat <$> mapM f ns)

instance Monad m => Serial m Any where
    series = fmap Any series

instance Monad m => Serial m All where
    series = fmap All series

instance Monad m => Serial m Fingerprint where
    series = generate (\_ -> [Fingerprint 0 0, Fingerprint maxBound maxBound])

instance Monad m => Serial m BS.ByteString where
    series = fmap BS.pack series

instance Monad m => Serial m LBS.ByteString where
    series = fmap LBS.pack series

instance Monad m => Serial m SBS.ShortByteString where
    series = fmap SBS.pack series

instance (Monad m, Serial m a, Storable a) => Serial m (SV.Vector a) where
    series = fmap SV.fromList series

instance (Monad m, Serial m a) => Serial m (V.Vector a) where
    series = fmap V.fromList series

instance (Monad m, Serial m k, Serial m a, Ord k) => Serial m (Map k a) where
    series = fmap mapFromList series

instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where
    series = fmap setFromList series

instance (Monad m, Serial m a) => Serial m (IntMap a) where
    series = fmap mapFromList series

instance Monad m => Serial m IntSet where
    series = fmap setFromList series

instance Monad m => Serial m Text where
    series = fmap fromList series

instance (Monad m, Serial m a) => Serial m (Seq a) where
    series = fmap fromList series

instance (Monad m, Serial m a, UV.Unbox a) => Serial m (UV.Vector a) where
    series = fmap fromList series

instance (Monad m, Serial m k, Serial m a, Hashable k, Eq k) => Serial m (HashMap k a) where
    series = fmap mapFromList series

instance (Monad m, Serial m a, Hashable a, Eq a) => Serial m (HashSet a) where
    series = fmap setFromList series

instance (Monad m, A.Ix i, Serial m i, Serial m e) => Serial m (A.Array i e) where
    series = seriesArray

instance (Monad m, A.IArray A.UArray e, A.Ix i, Serial m i, Serial m e) => Serial m (A.UArray i e) where
    series = seriesArray

seriesArray :: (Monad m, A.Ix i, A.IArray a e, Serial m i, Serial m e) => Series m (a i e)
seriesArray = cons2 $ \bounds (NonEmpty xs) ->
    A.listArray bounds (take (A.rangeSize bounds) (cycle xs))

instance Monad m => Serial m Time.Day where
    series = Time.ModifiedJulianDay <$> series

instance Monad m => Serial m Time.DiffTime where
    series = Time.picosecondsToDiffTime <$> series

instance Monad m => Serial m Time.NominalDiffTime where
    series = (realToFrac :: Integer -> Time.NominalDiffTime) <$> series

instance Monad m => Serial m Time.UTCTime where
    series = uncurry Time.UTCTime <$> (series >< series)

instance (Monad m, Serial m a) => Serial m (Tagged a)

#if MIN_VERSION_base(4,15,0)
instance Monad m => Serial m IoSubSystem where
  series = cons0 IoPOSIX \/ cons0 IoNative
#endif

#if !MIN_VERSION_smallcheck(1,2,0)
instance (Monad m, Serial m a) => Serial m (Complex a) where
    series = uncurry (:+) <$> (series >< series)

instance (Monad m, Serial m a) => Serial m (NE.NonEmpty a)

instance Monad m => Serial m Void where
    series = generate (\_ -> [])
#endif

instance Monad m => Serial m TimeSpec where
    series = uncurry TimeSpec <$> (series >< series)

-- We define our own Serial instance for 'Ratio' because of <https://github.com/feuerbach/smallcheck/pull/34>

newtype SerialRatio a = SerialRatio (Ratio a)
  deriving (Store, Eq, Show)

instance (Integral i, Serial m i) => Serial m (SerialRatio i) where
   series = pairToRatio <$> series
     where
      pairToRatio (n, Positive d) = SerialRatio (n :% d)

------------------------------------------------------------------------
-- Test datatypes for generics support

data Test
    = TestA Int64 Word32
    | TestB Bool
    | TestC
    | TestD BS.ByteString
    deriving (Eq, Show, Generic)
-- $(return . (:[]) =<< deriveStore [] (ConT ''Test) . dtCons =<< reifyDataType ''Test)
instance Store Test
instance Monad m => Serial m Test

data X = X
    deriving (Eq, Show, Generic)
instance Monad m => Serial m X
instance Store X

-- Datatypes with faulty instances
newtype BadIdea = BadIdea Int64
instance Store BadIdea where
    poke (BadIdea x) = poke x
    peek = BadIdea <$> peek
    size = ConstSize 1 -- too small

newtype BadIdea2 = BadIdea2 Int64
instance Store BadIdea2 where
    poke (BadIdea2 x) = poke x
    peek = BadIdea2 <$> peek
    size = ConstSize 12 -- too large

spec :: Spec
spec = do
    describe "Store on all monomorphic instances"
        $(do insts <- getAllInstanceTypes1 ''Store
             omitTys0 <- sequence $
#if !MIN_VERSION_primitive(0,7,0)
                 [t| Addr |] :
#endif
                 [ [t| CUIntPtr |]
                 , [t| CIntPtr |]
                 , [t| IntPtr |]
                 , [t| WordPtr |]
                 , [t| TypeHash |]
                 , [t| Fd |]
                 , [t| NameFlavour |]
#if MIN_VERSION_base(4,10,0)
                 , [t| CTimer |]
#endif

-- Assume the TH generated instances for Time work, to avoid defining
-- Serial instances. Also some lack Show / Eq.

                 , [t| Time.AbsoluteTime |]
                 , [t| Time.Day |]
                 , [t| Time.LocalTime |]
                 , [t| Time.TimeOfDay |]
                 , [t| Time.TimeZone |]
                 , [t| Time.UTCTime |]
                 , [t| Time.UniversalTime |]
                 , [t| Time.ZonedTime |]
                 , [t| Time.TimeLocale |]
#if MIN_VERSION_time(1,8,0)
                 , [t| Time.SystemTime |]
#endif
#if MIN_VERSION_time(1,9,0)
                 , [t| Time.FormatExtension |]
                 , [t| Time.CalendarDiffDays |]
                 , [t| Time.CalendarDiffTime |]
#endif
#if MIN_VERSION_time(1,11,0)
                 , [t| Time.DayOfWeek |]
                 , [t| Time.FirstWeekType |]
                 , [t| Time.Quarter |]
                 , [t| Time.QuarterOfYear |]
#endif

                 ]
             omitTys <- (omitTys0 ++) <$> mapM (\ty -> [t| PV.Vector $(pure ty) |]) omitTys0
             let f ty = isMonoType ty && ty `notElem` omitTys && null (listify isThName ty)
                 filtered = filter f insts
                 -- Roundtrip testing of TH instances is disabled - see issue #150
                 isThName n = nameModule n == Just "Language.Haskell.TH.Syntax"
             smallcheckManyStore verbose 2 $ map return filtered)
    it "Store on non-numeric Float/Double values" $ do
        let testNonNumeric :: forall a m. (RealFloat a, Eq a, Show a, Typeable a, Store a, Monad m, MonadFail m) => Proxy a -> m ()
            testNonNumeric _proxy = do
                assertRoundtrip verbose ((1/0) :: a)
                assertRoundtrip verbose ((-1/0) :: a)
                -- -0 == 0, so we check if the infinity sign is the same
                case decode (encode ((-0) :: a)) of
                    Right (x :: a) -> unless (-1/0 == 1/x) (fail "Could not roundtrip negative 0")
                    _ -> fail "Could not roundtrip negative 0"
                assertRoundtrip verbose ((-0) :: a)
                -- 0/0 /= 0/0, so we check for NaN explicitly
                case decode (encode ((0/0) :: a)) of
                    Right (x :: a) -> unless (isNaN x) (fail "Could not roundtrip NaN")
                    _ -> fail "Could not roundtrip NaN"
        testNonNumeric (Proxy :: Proxy Double)
        testNonNumeric (Proxy :: Proxy Float)
        testNonNumeric (Proxy :: Proxy CDouble)
        testNonNumeric (Proxy :: Proxy CFloat)
        (return () :: IO ())
    describe "Store on all custom generic instances"
        $(smallcheckManyStore verbose 2
            [ [t| Test |]
            , [t| X |]
            ])
    describe "Manually listed polymorphic store instances"
        $(smallcheckManyStore verbose 4
            [ [t| SV.Vector Int8 |]
            , [t| V.Vector  Int8 |]
            , [t| SerialRatio     Int8 |]
            , [t| Complex   Int8 |]
            , [t| Dual      Int8 |]
            , [t| Sum       Int8 |]
            , [t| Product   Int8 |]
            , [t| First     Int8 |]
            , [t| Last      Int8 |]
            , [t| Maybe     Int8 |]
            , [t| Either    Int8 Int8 |]
            , [t| SV.Vector Int64 |]
            , [t| V.Vector  Int64 |]
            , [t| SerialRatio     Int64 |]
            , [t| Complex   Int64 |]
            , [t| Dual      Int64 |]
            , [t| Sum       Int64 |]
            , [t| Product   Int64 |]
            , [t| First     Int64 |]
            , [t| Last      Int64 |]
            , [t| Maybe     Int64 |]
            , [t| Either    Int64 Int64 |]
            , [t| (Int8, Int16) |]
            , [t| (Int8, Int16, Bool) |]
            , [t| (Bool, (), (), ()) |]
            , [t| (Bool, (), Int8, ()) |]
            -- Container-ey types
            , [t| [Int8] |]
            , [t| [Int64] |]
            , [t| Seq Int8 |]
            , [t| Seq Int64 |]
            , [t| Set Int8 |]
            , [t| Set Int64 |]
            , [t| IntMap Int8 |]
            , [t| IntMap Int64 |]
            , [t| Map Int8 Int8 |]
            , [t| Map Int64 Int64 |]
            , [t| HashMap Int8 Int8 |]
            , [t| HashMap Int64 Int64 |]
            , [t| HashSet Int8 |]
            , [t| HashSet Int64 |]
            , [t| NE.NonEmpty Int8 |]
            , [t| NE.NonEmpty Int64 |]
            , [t| Tagged Int32 |]
            , [t| A.Array (Int, Integer) Integer |]
            , [t| A.UArray Char Bool |]
            ])
    it "Slices roundtrip" $ do
        assertRoundtrip False $ T.drop 3 $ T.take 3 "Hello world!"
        assertRoundtrip False $ BS.drop 3 $ BS.take 3 "Hello world!"
        assertRoundtrip False $ SV.drop 3 $ SV.take 3 (SV.fromList [1..10] :: SV.Vector Int32)
        assertRoundtrip False $ UV.drop 3 $ UV.take 3 (UV.fromList [1..10] :: UV.Vector Word8)
        (return () :: IO ())
    it "StaticSize roundtrips" $ do
        let x :: StaticSize 17 BS.ByteString
            x = toStaticSizeEx (BS.replicate 17 255)
        unless (checkRoundtrip False x) $
            (fail "Failed to roundtrip StaticSize ByteString" :: IO ())
    it "Size of generic instance for single fieldless constructor is 0" $ do
        case size :: Size X of
            ConstSize 0 -> (return () :: IO ())
            _ -> fail "Empty datatype takes up space"
    it "Printing out polymorphic store instances" $ do
        putStrLn ""
        putStrLn "Not really a test - printing out known polymorphic store instances (which should all be tested above)"
        putStrLn ""
        mapM_ putStrLn
              $(do insts <- getAllInstanceTypes1 ''Store
                   lift $ map pprint $ filter (not . isMonoType) insts)
    it "Faulty implementations of size lead to PokeExceptions" $ do
        evaluate (encode (BadIdea 0)) `shouldThrow` isPokeException
        evaluate (encode (BadIdea2 0)) `shouldThrow` isPokeException
    it "Avoids reading data with a negative size" $ do
        let bs = encode (SV.fromList [1..10::Int])
            bs' = BS.concat [encode (-1 :: Int)
                            , BS.drop (sizeOf (10 :: Int)) bs
                            ]
        evaluate (decodeEx bs' :: SV.Vector Int) `shouldThrow` isNegativeBytesException
    it "Avoids overflow in bounds checks" $ do
        let bs = encode ("some random bytestring" :: BS.ByteString)
            bs' = BS.concat [encode (maxBound :: Int)
                            , BS.drop (sizeOf (10 :: Int)) bs
                            ]
        evaluate (decodeEx bs' :: BS.ByteString) `shouldThrow` isTooManyBytesException
    it "Handles unaligned access" $ do
        assertRoundtrip verbose (250 :: Word8, 40918 :: Word16, 120471416 :: Word32)
        assertRoundtrip verbose (250 :: Word8, 10.1 :: Float, 8697.65 :: Double)
        (return () :: IO ())
    it "Expects the right marker when deserializing ordered maps (#97)" $ do
        let m = mapFromList [(1, ()), (2, ()), (3, ())] :: HashMap Int ()
            bs = encode m
        (decodeEx bs :: HashMap Int ()) `shouldBe` m
        evaluate (decodeEx bs :: Map Int ()) `shouldThrow` isUnexpectedMarkerException
        evaluate (decodeEx bs :: IntMap ()) `shouldThrow` isUnexpectedMarkerException
    it "Expects decode of negative integer as a natural to throw PeekException" $ do
        evaluate (decodeEx (encode ((-5) :: Integer)) :: Natural)
            `shouldThrow` isNegativeNaturalException

isPokeException :: Test.Hspec.Selector PokeException
isPokeException = const True

isNegativeBytesException :: Test.Hspec.Selector PeekException
isNegativeBytesException (PeekException _ t) = "Attempted to read negative number of bytes" `T.isPrefixOf` t

isTooManyBytesException :: Test.Hspec.Selector PeekException
isTooManyBytesException (PeekException _ t) = "Attempted to read too many bytes" `T.isPrefixOf` t

isUnexpectedMarkerException :: Test.Hspec.Selector PeekException
isUnexpectedMarkerException (PeekException _ t) =
    "Expected marker for ascending Map / IntMap: " `T.isPrefixOf` t

isNegativeNaturalException :: Test.Hspec.Selector PeekException
isNegativeNaturalException (PeekException _ t) =
    "Encountered negative integer when expecting a Natural" `T.isPrefixOf` t


{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
--------------------------------------------------------------------
-- |
-- Copyright :  (c) 2014 Edward Kmett
-- License   :  BSD2
-- Maintainer:  Edward Kmett <ekmett@gmail.com>
-- Stability :  experimental
-- Portability: non-portable
--
-- OpenGL STD140 and STD430 support
--
-- Note STD430 can only be used for shader storage blocks, NOT
-- uniform blocks!
--------------------------------------------------------------------
module Quine.GL.Block
  ( Offset(..)
  , Block(..)
  , GBlock(..)
  , STD140(..)
  , STD430(..)
  ) where

import Control.Applicative
import Control.Category
import Control.Lens hiding (to, from)
import Control.Monad.IO.Class
import Data.Complex
import Data.Data
import Data.Foldable
import Data.Functor.Rep hiding (Rep)
import Data.Int
import Data.Traversable
import Data.Word
import Foreign.Storable
import Foreign.Ptr
import GHC.Generics
import Linear
import Linear.V
import Prelude hiding (id,(.),sequence)
import Quine.GL.Types

newtype Offset (a :: *) (b :: *) = Offset Int
  deriving (Data,Typeable,Generic,Eq,Ord,Show,Read)

instance Category Offset where
  id = Offset 0
  Offset a . Offset b = Offset (a + b)

newtype STD140 a = STD140 { getSTD140 :: a }
  deriving (Data,Typeable,Generic,Functor,Foldable,Traversable,Eq,Ord,Show,Read)

instance Block a => Storable (STD140 a) where
  alignment _ = alignment140 (Proxy :: Proxy a)
  sizeOf _ = sizeOf140 (Proxy :: Proxy a)
  peekByteOff p o = STD140 <$> read140 p (Offset o)
  pokeByteOff p o = write140 p (Offset o) . getSTD140

newtype STD430 a = STD430 { getSTD430 :: a }
  deriving (Data,Typeable,Generic,Functor,Foldable,Traversable,Eq,Ord,Show,Read)

instance Block a => Storable (STD430 a) where
  alignment _ = alignment430 (Proxy :: Proxy a)
  sizeOf _ = sizeOf430 (Proxy :: Proxy a)
  peekByteOff p o = STD430 <$> read430 p (Offset o)
  pokeByteOff p o = write430 p (Offset o) . getSTD430

-- | This describes how to load and store primitives
-- through a uniform/shader storage blocks according to
-- OpenGL STD140 and STD430.
--
-- There are lots of fiddly little constants around, beware.
class Block b where
  -- | As per 'Storable' 'alignment', but matching OpenGL STD140.
  alignment140 :: p b -> Int
  default alignment140 :: (Generic b, GBlock (Rep b)) => p b -> Int
  alignment140 _ = galignment140 (Proxy :: Proxy (Rep b))

  -- | As per 'Storable' 'sizeOf', but matching OpenGL STD140.
  sizeOf140 :: p b -> Int
  default sizeOf140 :: (Generic b, GBlock (Rep b)) => p b -> Int
  sizeOf140 _ = gsizeOf140 (Proxy :: Proxy (Rep b))

  -- | Structures get smashed up to a minimum of a vec4 alignment in 140 mode
  isStruct :: p b -> Bool
  isStruct _ = True

  read140 :: MonadIO m => Ptr a -> Offset a b -> m b
  default read140 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Offset a b -> m b
  read140 p (Offset o) = liftIO $ to <$> gread140 p o

  write140 :: MonadIO m => Ptr a -> Offset a b -> b -> m ()
  default write140 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Offset a b -> b -> m ()
  write140 p (Offset o) b = liftIO $ gwrite140 p o (from b)

  -- | As per 'Storable' 'alignment', but matching OpenGL STD430.
  alignment430 :: p b -> Int
  default alignment430 :: (Generic b, GBlock (Rep b)) => p b -> Int
  alignment430 _ = galignment430 (Proxy :: Proxy (Rep b))

  -- | As per 'Storable' 'sizeOf', but matching OpenGL STD430.
  sizeOf430 :: p b -> Int
  default sizeOf430 :: (Generic b, GBlock (Rep b)) => p b -> Int
  sizeOf430 _ = gsizeOf430 (Proxy :: Proxy (Rep b))

  read430 :: MonadIO m => Ptr a -> Offset a b -> m b
  default read430 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Offset a b -> m b
  read430 p (Offset o) = liftIO $ to <$> gread430 p o

  write430 :: MonadIO m => Ptr a -> Offset a b -> b -> m ()
  default write430 :: (MonadIO m, Generic b, GBlock (Rep b)) => Ptr a -> Offset a b -> b -> m ()
  write430 p (Offset o) b = liftIO $ gwrite430 p o (from b)

-- | Automatically derive STD140 and STD430 alignment using GHC Generics
class GBlock f where
  galignment140 :: p f -> Int
  galignment430 :: p f -> Int
  gsizeOf140    :: p f -> Int
  gsizeOf430    :: p f -> Int
  gread140  :: Ptr a -> Int -> IO (f b)
  gread430  :: Ptr a -> Int -> IO (f b)
  gwrite140 :: Ptr a -> Int -> f b -> IO ()
  gwrite430 :: Ptr a -> Int -> f b -> IO ()

instance GBlock U1 where
  galignment140 _ = 1
  gsizeOf140    _ = 0
  galignment430 _ = 1
  gsizeOf430    _ = 0
  gread140 _ _ = return U1
  gread430 _ _ = return U1
  gwrite140 _ _ U1 = return ()
  gwrite430 _ _ U1 = return ()

instance (GBlock f, GBlock g) => GBlock (f :*: g) where
  galignment140 _ = galignment140 (Proxy :: Proxy f)
              `max` galignment140 (Proxy :: Proxy g)
  galignment430 _ = galignment430 (Proxy :: Proxy f)
              `max` galignment430 (Proxy :: Proxy g)
  gsizeOf140 _ = roundUp (gsizeOf140 (Proxy :: Proxy f)) (galignment140 (Proxy :: Proxy g)) + gsizeOf140 (Proxy :: Proxy g)
  gsizeOf430 _ = roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy g)) + gsizeOf430 (Proxy :: Proxy g)
  gread140 p o = (:*:) <$> gread140 p o <*> gread140 p (o + roundUp (gsizeOf140 (Proxy :: Proxy f)) (galignment140 (Proxy :: Proxy g)))
  gread430 p o = (:*:) <$> gread430 p o <*> gread430 p (o + roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy g)))
  gwrite140 p o (a :*: b) = do
    gwrite140 p o a
    gwrite140 p (o + roundUp (gsizeOf140 (Proxy :: Proxy f)) (galignment140 (Proxy :: Proxy g))) b
  gwrite430 p o (a :*: b) = do
    gwrite430 p o a
    gwrite430 p (o + roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy g))) b

instance GBlock f => GBlock (M1 S c f) where
  galignment140 _ = galignment140 (Proxy :: Proxy f)
  galignment430 _ = galignment430 (Proxy :: Proxy f)
  gsizeOf140    _ = gsizeOf140 (Proxy :: Proxy f)
  gsizeOf430    _ = gsizeOf430 (Proxy :: Proxy f)
  gread140 p o = M1 <$> gread140 p o
  gread430 p o = M1 <$> gread430 p o
  gwrite140 p o (M1 a) = gwrite140 p o a
  gwrite430 p o (M1 a) = gwrite430 p o a

instance GBlock f => GBlock (M1 C c f) where
  galignment140 _ = lcm 16 $ galignment140 (Proxy :: Proxy f) -- std140 rule 9
  galignment430 _ = galignment430 (Proxy :: Proxy f) -- std140 rule 9, relaxed by std430
  gsizeOf140    _ = roundUp (gsizeOf140 (Proxy :: Proxy f)) (galignment140 (Proxy :: Proxy f)) -- std140 rule 9
  gsizeOf430    _ = roundUp (gsizeOf430 (Proxy :: Proxy f)) (galignment430 (Proxy :: Proxy f)) -- std140 rule 9, relaxed by std430
  gread140 p o = M1 <$> gread140 p o
  gread430 p o = M1 <$> gread430 p o
  gwrite140 p o (M1 a) = gwrite140 p o a
  gwrite430 p o (M1 a) = gwrite430 p o a

instance GBlock f => GBlock (M1 D c f) where
  galignment140 _ = galignment140 (Proxy :: Proxy f)
  galignment430 _ = galignment430 (Proxy :: Proxy f)
  gsizeOf140    _ = gsizeOf140 (Proxy :: Proxy f)
  gsizeOf430    _ = gsizeOf430 (Proxy :: Proxy f)
  gread140 p o = M1 <$> gread140 p o
  gread430 p o = M1 <$> gread430 p o
  gwrite140 p o (M1 a) = gwrite140 p o a
  gwrite430 p o (M1 a) = gwrite430 p o a

instance Block c => GBlock (K1 i c) where
  galignment140 _ = alignment140 (Proxy :: Proxy c)
  galignment430 _ = alignment430 (Proxy :: Proxy c)
  gsizeOf140    _ = sizeOf140 (Proxy :: Proxy c)
  gsizeOf430    _ = sizeOf430 (Proxy :: Proxy c)
  gread140 p o = K1 <$> read140 p (Offset o)
  gread430 p o = K1 <$> read430 p (Offset o)
  gwrite140 p o (K1 a) = write140 p (Offset o) a
  gwrite430 p o (K1 a) = write430 p (Offset o) a

toBool :: Int32 -> Bool
toBool 0 = False
toBool _ = True

fromBool :: Bool -> Int32
fromBool False = 0
fromBool True = 1

instance Block Bool where
  alignment140 _ = 4
  sizeOf140 _    = 4
  alignment430 _ = 4
  sizeOf430 _    = 4
  isStruct _ = False
  read140  p (Offset o)   = liftIO $ toBool <$> peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o (fromBool b)
  read430 = read140
  write430 = write140

instance Block Float where
  alignment140 _ = 4
  sizeOf140 _    = 4
  alignment430 _ = 4
  sizeOf430 _    = 4
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Double where
  alignment140 _ = 8
  sizeOf140 _    = 8
  alignment430 _ = 8
  sizeOf430 _    = 8
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Int32 where
  alignment140 _ = 4
  sizeOf140 _    = 4
  alignment430 _ = 4
  sizeOf430 _    = 4
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Word32 where
  alignment140 _ = 4
  sizeOf140 _    = 4
  alignment430 _ = 4
  sizeOf430 _    = 4
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block BVec2 where
  alignment140 _ = 8
  sizeOf140 _    = 8
  alignment430 _ = 8
  sizeOf430 _    = 8
  isStruct _ = False
  read140  p (Offset o)   = liftIO $ fmap toBool <$> peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o (fmap fromBool b)
  read430 = read140
  write430 = write140

instance Block BVec3 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140  p (Offset o)   = liftIO $ fmap toBool <$> peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o (fmap fromBool b)
  read430 = read140
  write430 = write140

instance Block BVec4 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140  p (Offset o)   = liftIO $ fmap toBool <$> peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o (fmap fromBool b)
  read430 = read140
  write430 = write140

instance Block Vec2 where
  alignment140 _ = 8
  sizeOf140 _    = 8
  alignment430 _ = 8
  sizeOf430 _    = 8
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Vec3 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Vec4 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block DVec2 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block DVec3 where
  alignment140 _ = 32
  sizeOf140 _    = 24
  alignment430 _ = 32
  sizeOf430 _    = 24
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block DVec4 where
  alignment140 _ = 32
  sizeOf140 _    = 32
  alignment430 _ = 32
  sizeOf430 _    = 32
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block IVec2 where
  alignment140 _ = 8
  sizeOf140 _    = 8
  alignment430 _ = 8
  sizeOf430 _    = 8
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block IVec3 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block IVec4 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block UVec2 where
  alignment140 _ = 8
  sizeOf140 _    = 8
  alignment430 _ = 8
  sizeOf430 _    = 8
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block UVec3 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block UVec4 where
  alignment140 _ = 16
  sizeOf140 _    = 16
  alignment430 _ = 16
  sizeOf430 _    = 16
  isStruct _ = False
  read140 p (Offset o) = liftIO $ peekByteOff p o
  write140 p (Offset o) b = liftIO $ pokeByteOff p o b
  read430 = read140
  write430 = write140

instance Block Mat2 where
  alignment140 _ = 16 -- per vec4, despite being vec2
  sizeOf140    _ = 32 -- 2 columns, each rounded up to vec4 size
  alignment430 _ = 8  -- vec2
  sizeOf430    _ = 16 -- 2 columns, each vec2 in size
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a c <- peekByteOff p o
    V2 b d <- peekByteOff p (o + 16)
    return $ V2 (V2 a b) (V2 c d)
  write140 p (Offset o)
    (V2 (V2 a b)
        (V2 c d)) = liftIO $ do
    pokeByteOff p o        (V2 a b)
    pokeByteOff p (o + 16) (V2 c d)
  read430 p (Offset o) = liftIO $ do
    V2 a c <- peekByteOff p o
    V2 b d <- peekByteOff p (o + 8)
    return $ V2 (V2 a b) (V2 c d)
  write430 p (Offset o)
    (V2 (V2 a b)
        (V2 c d)) = liftIO $ do
    pokeByteOff p o       (V2 a b)
    pokeByteOff p (o + 8) (V2 c d)

instance Block DMat2 where
  alignment140 _ = 16 -- dvec2 = vec4 in size
  sizeOf140    _ = 32 -- 2 columns, perfect fit!
  alignment430 _ = 16 -- dvec2 = vec4 in size
  sizeOf430    _ = 32 -- 2 columns, perfect fit!
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a c <- peekByteOff p o
    V2 b d <- peekByteOff p (o + 16)
    return $ V2 (V2 a b) (V2 c d)
  write140 p (Offset o)
    (V2 (V2 a b)
        (V2 c d)) = liftIO $ do
    pokeByteOff p o        (V2 a b)
    pokeByteOff p (o + 16) (V2 c d)
  read430 = read140
  write430 = write140

instance Block Mat3x2 where
  alignment140 _ = 16 -- per vec4, despite being vec3s
  sizeOf140    _ = 32 -- 2 columns, each rounded up to vec4 size
  alignment430 _ = 16 -- per vec4, despite being vec3s
  sizeOf430    _ = 32 -- 2 columns, each rounded up to vec4 size
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a c e <- peekByteOff p o
    V3 b d f <- peekByteOff p (o + 16)
    return $ V3 (V2 a b) (V2 c d) (V2 e f)
  write140 p (Offset o)
    (V3 (V2 a b)
        (V2 c d)
        (V2 e f)) = liftIO $ do
    pokeByteOff p o        (V3 a b e)
    pokeByteOff p (o + 16) (V3 c d f)
  read430 = read140
  write430 = write140

instance Block DMat3x2 where
  alignment140 _ = 32 -- dvec3s = 24, rounded up to 2*vec4 in size
  sizeOf140    _ = 64 -- 2 columns, each rounded up to 2*vec4 size
  alignment430 _ = 32 -- dvec3s = 24, rounded up to 2*vec4 in size
  sizeOf430    _ = 64 -- 2 columns, each rounded up to 2*vec4 size
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a c e <- peekByteOff p o
    V3 b d f <- peekByteOff p (o + 32)
    return $ V3 (V2 a b) (V2 c d) (V2 e f)
  write140 p (Offset o)
    (V3 (V2 a b)
        (V2 c d)
        (V2 e f)) = liftIO $ do
    pokeByteOff p o        (V3 a b e)
    pokeByteOff p (o + 32) (V3 c d f)
  read430 = read140
  write430 = write140

instance Block Mat4x2 where
  alignment140 _ = 16 -- per vec4
  sizeOf140    _ = 32 -- 2 columns
  alignment430 _ = 16 -- per vec4
  sizeOf430    _ = 32 -- 2 columns
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a c e g <- peekByteOff p o
    V4 b d f h <- peekByteOff p (o + 16)
    return $ V4 (V2 a b) (V2 c d) (V2 e f) (V2 g h)
  write140 p (Offset o)
    (V4 (V2 a b)
        (V2 c d)
        (V2 e f)
        (V2 g h)) = liftIO $ do
    pokeByteOff p o        (V4 a b e g)
    pokeByteOff p (o + 16) (V4 c d f h)
  read430 = read140
  write430 = write140

instance Block DMat4x2 where
  alignment140 _ = 32 -- per dvec4 = 2*vec4
  sizeOf140    _ = 64 -- 2 columns
  alignment430 _ = 32 -- per dvec4 = 2*vec4
  sizeOf430    _ = 64 -- 2 columns
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a c e g <- peekByteOff p o
    V4 b d f h <- peekByteOff p (o + 32)
    return $ V4 (V2 a b) (V2 c d) (V2 e f) (V2 g h)
  write140 p (Offset o)
    (V4 (V2 a b)
        (V2 c d)
        (V2 e f)
        (V2 g h)) = liftIO $ do
    pokeByteOff p o        (V4 a b e g)
    pokeByteOff p (o + 32) (V4 c d f h)
  read430 = read140
  write430 = write140

instance Block Mat2x3 where
  alignment140 _ = 16 -- per vec4, despite being vec2 by array rules
  sizeOf140    _ = 48 -- 3 columns, each a vec4 in size, despite being vec2s
  alignment430 _ = 8  -- per vec2
  sizeOf430    _ = 24 -- 3 columns, each a vec2 in size
  isStruct  _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a d <- peekByteOff p o
    V2 b e <- peekByteOff p (o + 16)
    V2 c f <- peekByteOff p (o + 32)
    return $ V2 (V3 a b c)
                (V3 d e f)
  write140 p (Offset o)
    (V2 (V3 a b c)
        (V3 d e f)) = liftIO $ do
    pokeByteOff p o        (V2 a d)
    pokeByteOff p (o + 16) (V2 b e)
    pokeByteOff p (o + 32) (V2 c f)
  read430 p (Offset o) = liftIO $ do
    V2 a d <- peekByteOff p o
    V2 b e <- peekByteOff p (o + 8)
    V2 c f <- peekByteOff p (o + 16)
    return $ V2 (V3 a b c)
                (V3 d e f)
  write430 p (Offset o)
    (V2 (V3 a b c)
        (V3 d e f)) = liftIO $ do
    pokeByteOff p o        (V2 a d)
    pokeByteOff p (o + 8)  (V2 b e)
    pokeByteOff p (o + 16) (V2 c f)

instance Block DMat2x3 where
  alignment140 _ = 16 -- a dvec2 is one vec4 in size
  sizeOf140    _ = 48 -- 3 columns, each a vec4 in size
  alignment430 _ = 16 -- a dvec2 is one vec4 in size
  sizeOf430    _ = 48 -- 3 columns, each a vec4 in size
  isStruct     _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a d <- peekByteOff p o
    V2 b e <- peekByteOff p (o + 16)
    V2 c f <- peekByteOff p (o + 32)
    return $ V2 (V3 a b c)
                (V3 d e f)
  write140 p (Offset o)
    (V2 (V3 a b c)
        (V3 d e f)) = liftIO $ do
    pokeByteOff p o        (V2 a d)
    pokeByteOff p (o + 16) (V2 b e)
    pokeByteOff p (o + 32) (V2 c f)
  read430 = read140
  write430 = write140

instance Block Mat3 where
  alignment140 _ = 16 -- per vec4, despite being vec3
  sizeOf140    _ = 48 -- 3 columns, each rounded up to vec4 size
  alignment430 _ = 16 -- a dvec2 is one vec4 in size
  sizeOf430    _ = 48 -- 3 columns, each a vec4 in size
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a d g <- peekByteOff p o
    V3 b e h <- peekByteOff p (o + 16)
    V3 c f i <- peekByteOff p (o + 24)
    return $ V3 (V3 a b c)
                (V3 d e f)
                (V3 g h i)
  write140 p (Offset o)
    (V3 (V3 a b c)
        (V3 d e f)
        (V3 g h i)) = liftIO $ do
    pokeByteOff p o        (V3 a d g)
    pokeByteOff p (o + 16) (V3 b e h)
    pokeByteOff p (o + 32) (V3 c f i)
  read430 = read140
  write430 = write140

instance Block DMat3 where
  alignment140 _ = 32 -- dvec3 = 1.5vec4, round up to 2*vec2
  sizeOf140    _ = 96 -- 3 columns, each rounded up to 2*vec4 size
  alignment430 _ = 32 -- a dvec2 is one vec4 in size
  sizeOf430    _ = 96 -- 3 columns, each a vec4 in size
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a d g <- peekByteOff p o
    V3 b e h <- peekByteOff p (o + 32)
    V3 c f i <- peekByteOff p (o + 64)
    return $ V3 (V3 a b c)
                (V3 d e f)
                (V3 g h i)
  write140 p (Offset o)
    (V3 (V3 a b c)
        (V3 d e f)
        (V3 g h i)) = liftIO $ do
    pokeByteOff p o        (V3 a d g)
    pokeByteOff p (o + 32) (V3 b e h)
    pokeByteOff p (o + 64) (V3 c f i)
  read430 = read140
  write430 = write140

instance Block Mat4x3 where
  alignment140 _ = 16 -- per vec4
  sizeOf140    _ = 48 -- 3 columns
  alignment430 _ = 16 -- per vec4
  sizeOf430    _ = 48 -- 3 columns
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a d g j <- peekByteOff p o
    V4 b e h k <- peekByteOff p (o + 16)
    V4 c f i l <- peekByteOff p (o + 32)
    return $ V4 (V3 a b c)
                (V3 d e f)
                (V3 g h i)
                (V3 j k l)
  write140 p (Offset o)
    (V4 (V3 a b c)
        (V3 d e f)
        (V3 g h i)
        (V3 j k l)) = liftIO $ do
    pokeByteOff p o        (V4 a d g j)
    pokeByteOff p (o + 16) (V4 b e h k)
    pokeByteOff p (o + 32) (V4 c f i l)
  read430 = read140
  write430 = write140

instance Block DMat4x3 where
  alignment140 _ = 32 -- dvec4 is 2*vec4 in size
  sizeOf140    _ = 48 -- 3 columns
  alignment430 _ = 32 -- dvec4 is 2*vec4 in size
  sizeOf430    _ = 48 -- 3 columns
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a d g j <- peekByteOff p o
    V4 b e h k <- peekByteOff p (o + 32)
    V4 c f i l <- peekByteOff p (o + 64)
    return $ V4 (V3 a b c)
                (V3 d e f)
                (V3 g h i)
                (V3 j k l)
  write140 p (Offset o)
    (V4 (V3 a b c)
        (V3 d e f)
        (V3 g h i)
        (V3 j k l)) = liftIO $ do
    pokeByteOff p o        (V4 a d g j)
    pokeByteOff p (o + 32) (V4 b e h k)
    pokeByteOff p (o + 64) (V4 c f i l)
  read430 = read140
  write430 = write140

instance Block Mat2x4 where
  alignment140 _ = 16 -- 2 rows, but vec2 rounds up to vec4 as per array
  sizeOf140    _ = 64 -- 4 columns, each rounded up to 16 bytes each
  alignment430 _ = 8  -- 2 rows, each a vec2 in size
  sizeOf430    _ = 32 -- 4 columns
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a e <- peekByteOff p o
    V2 b f <- peekByteOff p (o + 16)
    V2 c g <- peekByteOff p (o + 32)
    V2 d h <- peekByteOff p (o + 48)
    return $ V2 (V4 a b c d)
                (V4 e f g h)
  write140 p (Offset o)
    (V2 (V4 a b c d)
        (V4 e f g h)) = liftIO $ do
    pokeByteOff p o        (V2 a e)
    pokeByteOff p (o + 16) (V2 b f)
    pokeByteOff p (o + 32) (V2 c g)
    pokeByteOff p (o + 48) (V2 d h)
  read430 p (Offset o) = liftIO $ do
    V2 a e <- peekByteOff p o
    V2 b f <- peekByteOff p (o + 8)
    V2 c g <- peekByteOff p (o + 16)
    V2 d h <- peekByteOff p (o + 24)
    return $ V2 (V4 a b c d)
                (V4 e f g h)
  write430 p (Offset o)
    (V2 (V4 a b c d)
        (V4 e f g h)) = liftIO $ do
    pokeByteOff p o        (V2 a e)
    pokeByteOff p (o + 8) (V2 b f)
    pokeByteOff p (o + 16) (V2 c g)
    pokeByteOff p (o + 24) (V2 d h)

instance Block DMat2x4 where
  alignment140 _ = 16 -- 2 rows, and dvec2 = vec4 in size
  sizeOf140    _ = 64 -- 4 columns, perfect fit
  alignment430 _ = 16 -- 2 rows, and dvec2 = vec4 in size
  sizeOf430    _ = 64 -- 4 columns, perfect fit
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V2 a e <- peekByteOff p o
    V2 b f <- peekByteOff p (o + 16)
    V2 c g <- peekByteOff p (o + 32)
    V2 d h <- peekByteOff p (o + 48)
    return $ V2 (V4 a b c d)
                (V4 e f g h)
  write140 p (Offset o)
    (V2 (V4 a b c d)
        (V4 e f g h)) = liftIO $ do
    pokeByteOff p o        (V2 a e)
    pokeByteOff p (o + 16) (V2 b f)
    pokeByteOff p (o + 32) (V2 c g)
    pokeByteOff p (o + 48) (V2 d h)
  read430 = read140
  write430 = write140

instance Block Mat3x4 where
  alignment140 _ = 16 -- 3 rows, but vec3 rounds up to vec4
  sizeOf140    _ = 64 -- 4 columns, each rounded up to 16 bytes each
  alignment430 _ = 16 -- 3 rows, but vec3 rounds up to vec4
  sizeOf430    _ = 64 -- 4 columns, each rounded up to 16 bytes each
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a e i <- peekByteOff p o
    V3 b f j <- peekByteOff p (o + 16)
    V3 c g k <- peekByteOff p (o + 32)
    V3 d h l <- peekByteOff p (o + 48)
    return $ V3 (V4 a b c d)
                (V4 e f g h)
                (V4 i j k l)
  write140 p (Offset o)
    (V3 (V4 a b c d)
        (V4 e f g h)
        (V4 i j k l)) = liftIO $ do
    pokeByteOff p o        (V3 a e i)
    pokeByteOff p (o + 16) (V3 b f j)
    pokeByteOff p (o + 32) (V3 c g k)
    pokeByteOff p (o + 48) (V3 d h l)
  read430 = read140
  write430 = write140

instance Block DMat3x4 where
  alignment140 _ = 32  -- 3 rows, but dvec3 rounds up to 2*vec4
  sizeOf140    _ = 128 -- 4 columns, each rounded up to 32 bytes each
  alignment430 _ = 32  -- 3 rows, but dvec3 rounds up to 2*vec4
  sizeOf430    _ = 128 -- 4 columns, each rounded up to 32 bytes each
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V3 a e i <- peekByteOff p o
    V3 b f j <- peekByteOff p (o + 32)
    V3 c g k <- peekByteOff p (o + 64)
    V3 d h l <- peekByteOff p (o + 96)
    return $ V3 (V4 a b c d)
                (V4 e f g h)
                (V4 i j k l)
  write140 p (Offset o)
    (V3 (V4 a b c d)
        (V4 e f g h)
        (V4 i j k l)) = liftIO $ do
    pokeByteOff p o        (V3 a e i)
    pokeByteOff p (o + 32) (V3 b f j)
    pokeByteOff p (o + 64) (V3 c g k)
    pokeByteOff p (o + 96) (V3 d h l)
  read430 = read140
  write430 = write140

instance Block Mat4 where
  alignment140 _ = 16
  sizeOf140    _ = 64
  alignment430 _ = 16
  sizeOf430    _ = 64
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a e i m <- peekByteOff p o
    V4 b f j n <- peekByteOff p (o + 16)
    V4 c g k q <- peekByteOff p (o + 32)
    V4 d h l r <- peekByteOff p (o + 48)
    return $ V4 (V4 a b c d)
                (V4 e f g h)
                (V4 i j k l)
                (V4 m n q r)
  write140 p (Offset o)
    (V4 (V4 a b c d)
        (V4 e f g h)
        (V4 i j k l)
        (V4 m n q r)) = liftIO $ do
    pokeByteOff p o        (V4 a e i m)
    pokeByteOff p (o + 16) (V4 b f j n)
    pokeByteOff p (o + 32) (V4 c g k q)
    pokeByteOff p (o + 48) (V4 d h l r)
  read430 = read140
  write430 = write140

instance Block DMat4 where
  alignment140 _ = 32
  sizeOf140    _ = 128
  alignment430 _ = 32
  sizeOf430    _ = 128
  isStruct _ = False
  read140 p (Offset o) = liftIO $ do
    V4 a e i m <- peekByteOff p o
    V4 b f j n <- peekByteOff p (o + 32)
    V4 c g k q <- peekByteOff p (o + 64)
    V4 d h l r <- peekByteOff p (o + 96)
    return $ V4 (V4 a b c d)
                (V4 e f g h)
                (V4 i j k l)
                (V4 m n q r)
  write140 p (Offset o)
    (V4 (V4 a b c d)
        (V4 e f g h)
        (V4 i j k l)
        (V4 m n q r)) = liftIO $ do
    pokeByteOff p o        (V4 a e i m)
    pokeByteOff p (o + 32) (V4 b f j n)
    pokeByteOff p (o + 64) (V4 c g k q)
    pokeByteOff p (o + 96) (V4 d h l r)
  read430 = read140
  write430 = write140

instance Block (Complex Float) where
  alignment140 _ = 16
  sizeOf140    _ = 16
  alignment430 _ = 8
  sizeOf430    _ = 8
  isStruct     _ = True
  read140 p (Offset o) = liftIO $ do
    V2 a b <- peekByteOff p o
    return $ a :+ b
  write140 p (Offset o) (a :+ b) = liftIO $ pokeByteOff p o (V2 a b)
  read430  = read140
  write430 = write140

instance Block (Complex Double) where
  alignment140 _ = 16
  sizeOf140    _ = 16
  alignment430   = alignment140
  sizeOf430      = sizeOf140
  isStruct     _ = True
  read140 p (Offset o) = liftIO $ do
    V2 a b <- peekByteOff p o
    return $ a :+ b
  write140 p (Offset o) (a :+ b) = liftIO $ pokeByteOff p o (V2 a b)
  read430  = read140
  write430 = write140

-- | encoded to match @shaders/math/quaternion.h@
instance Block (Quaternion Float) where
  alignment140 _ = 16
  sizeOf140    _ = 16
  alignment430   = alignment140
  sizeOf430      = sizeOf140
  isStruct     _ = True
  read140 p (Offset o) = liftIO $ do
    V4 a b c d <- peekByteOff p o
    return $ Quaternion d (V3 a b c)
  write140 p (Offset o) (Quaternion d (V3 a b c)) = liftIO $ pokeByteOff p o (V4 a b c d)
  read430  = read140
  write430 = write140

instance Block (Quaternion Double) where
  alignment140 _ = 32
  sizeOf140    _ = 32
  alignment430   = alignment140
  sizeOf430      = sizeOf140
  isStruct     _ = True
  read140 p (Offset o) = liftIO $ do
    V4 a b c d <- peekByteOff p o
    return $ Quaternion d (V3 a b c)
  write140 p (Offset o) (Quaternion d (V3 a b c)) = liftIO $ pokeByteOff p o (V4 a b c d)
  read430  = read140
  write430 = write140

-- | Can be used for fixed-sized arrays
instance (Dim n, Block a) => Block (V n a) where
  isStruct _ = isStruct (Proxy :: Proxy a)
  alignment140 _
    | isStruct (Proxy :: Proxy a) = lcm 16 n -- std140 rule 9
    | otherwise = n
    where n = alignment140 (Proxy :: Proxy a)
  alignment430 _ = alignment430 (Proxy :: Proxy a)
  sizeOf140 _ = roundUp (sizeOf140 (Proxy :: Proxy a)) (alignment140 (Proxy :: Proxy a)) * fromIntegral (reflectDim (Proxy :: Proxy n))
  sizeOf430 _ = roundUp (sizeOf430 (Proxy :: Proxy a)) (alignment430 (Proxy :: Proxy a)) * fromIntegral (reflectDim (Proxy :: Proxy n))
  read140 p (Offset o) = liftIO $ sequence $ tabulate $ \i -> read140 p $ Offset (o + i*d) where
    d = roundUp (sizeOf140 (Proxy :: Proxy a)) (alignment140 (Proxy :: Proxy a))
  write140 p (Offset o) v = liftIO $ iforM_ v $ \i -> write140 p (Offset (o + i*d)) where
    d = roundUp (sizeOf140 (Proxy :: Proxy a)) (alignment140 (Proxy :: Proxy a))
  read430 p (Offset o) = liftIO $ sequence $ tabulate $ \i -> read430 p $ Offset (o + i*d) where
    d = roundUp (sizeOf430 (Proxy :: Proxy a)) (alignment430 (Proxy :: Proxy a))
  write430 p (Offset o) v = liftIO $ iforM_ v $ \i -> write430 p (Offset (o + i*d)) where
    d = roundUp (sizeOf430 (Proxy :: Proxy a)) (alignment430 (Proxy :: Proxy a))

-- | @roundUp k n@ rounds up k up to an integral multiple of n
roundUp :: Int -> Int -> Int
roundUp k n = k + mod (n - k) n

instance (Block a, Block b) => Block (a,b)
instance (Block a, Block b, Block c) => Block (a,b,c)


{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-|
Module      : Text.Loquacious
Description : Overridable Pretty Printed Values with Generic Annotations
Stability   : experimental

Loquacious enables pretty printing of values with the ability to override
individual typeclass instances in particular context, for example to provide
locali[sz]ation.
-}

module Text.Loquacious
  ( -- * Loquacious class and existential type.
    Loquacious(..)
  , Loq(..)
    -- * Handle Loqs, in particular to override them.
  , defLoq
  , LoqHandler(..)
  , loqHandle
  , loqHandles
  , overLoq
    -- * Helpers for polymorphic Loquacious instances
  , toLoqFunctor
  , fromLoqTraversable
  , toLoqBifunctor
  , fromLoqBitraversable
  , toLoqFirst
  , fromLoqFirst
  ) where

-- For core functionality.
import           Data.Maybe (fromMaybe)
import           Data.Text.Prettyprint.Doc (Doc, Pretty)
import           Data.Typeable (Typeable, cast)
import           Text.Loquacious.Annotations (Ann)

-- For helpers.
import           Data.Bifunctor (Bifunctor, bimap, first)
import           Data.Bitraversable (Bitraversable, bitraverse)
import           Data.Foldable (toList)
import           Data.Text.Prettyprint.Doc (align, colon, list, parens, pretty, tupled, viaShow,
                     vsep, (<+>))

-- For instances.
import qualified Control.Exception as E
import qualified Control.Exception.Base as EB
import           Data.Array.Unboxed (Array, IArray, Ix, UArray, elems)
import           Data.Complex (Complex((:+)))
import           Data.Functor.Const (Const, getConst)
import           Data.Functor.Identity (Identity, runIdentity)
import           Data.Int (Int16, Int32, Int64, Int8)
import           Data.List.NonEmpty (NonEmpty)
import           Data.Ratio (Ratio, denominator, numerator)
import           Data.String (fromString)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LazyText
import           Data.Typeable (Proxy(Proxy), TypeRep, typeOf, typeRep, (:~:), (:~~:))
import           Data.Version (Version, showVersion)
import           Data.Void (Void)
import           Data.Word (Word16, Word32, Word64, Word8)
import           GHC.Stack
import           Numeric.Natural (Natural)

-- | The root of the Loquacious Type Heirarchy, compare 'E.SomeException'.
data Loq = forall t. Loquacious t => Loq t

-- | Construct a 'Doc' with the default loq handlers (those specified in
-- the typeclass bodies).
defLoq :: Loquacious s => s -> Doc Ann
defLoq = loq defLoq

instance Show Loq where
  show = show . defLoq

instance Loquacious Loq where
  loq m (Loq x) = m x
  toLoq = id
  fromLoq = pure

-- | Types than can be turned into Loquaciouss.
class Typeable t => Loquacious t where
  -- | Produce a 'Doc'ument ready for pretty-printing that may or may not
  -- include annotations.
  --
  -- For base types this can simply be 'pretty', but higher kinded types should
  -- implement this manually.
  loq :: (forall s. Loquacious s => s -> Doc Ann) -> t -> Doc Ann
  default loq :: Pretty t => (forall s. Loquacious s => s -> Doc Ann) -> t -> Doc Ann
  loq _ = pretty

  -- | Embed a 'Loquacious' as a 'Loq'.
  --
  -- Higher Kinded Types should recursively encode their arguments! This allows
  -- polymorphic deconstruction of 'Loq'.
  --
  -- For 'Functor's and 'Bifunctor's use 'toLoqFunctor' and 'toLoqBifunctor',
  -- respectively.
  toLoq :: t -> Loq
  toLoq = Loq

  -- | Attempt to extract some 'Loquacious' from a 'Loq'.
  --
  -- For 'Data.Traversable.Traverable's and 'Data.Bitraversable.Bitraverable's
  -- use 'fromLoqTraversable' and 'fromLoqBitraversable', respectively.
  fromLoq :: Loq -> Maybe t
  fromLoq (Loq sm) = cast sm

-- | Wrap a function from some 'Loquacious' type.
data LoqHandler t = forall m. Loquacious m => LoqHandler (m -> t)

-- | Given some loq and a handler for some loq, apply the handler if
-- possible, otherwise return a default value.
loqHandle :: Loq -> LoqHandler t -> t -> t
loqHandle m (LoqHandler handle) def = fromMaybe def (handle <$> fromLoq m)

-- | Given some loq and a bunch of handlers for some loq, apply each
-- handler in turn if possible, otherwise return a default value.
loqHandles :: Foldable f => Loq -> t -> f (LoqHandler t) -> t
loqHandles m def hs = foldr (loqHandle m) def hs

-- | Override a Loquacious Handler!
overLoq :: (Foldable f, Loquacious s) => f (LoqHandler (Doc Ann)) -> s -> Doc Ann
overLoq hs x = loqHandles (Loq x) (loq (overLoq hs) x) hs

-- | Recursively encode a 'Functor' instance to 'Loq'.
--
-- Useful for types of kind '* -> *'.
toLoqFunctor :: (Loquacious (f Loq), Functor f, Loquacious a) => f a -> Loq
toLoqFunctor = Loq . fmap toLoq

-- | Decode a recursively encoded 'Loq' via a 'Traversable' instance.
--
-- Useful for types of kind '* -> *'.
fromLoqTraversable :: (Traversable t, Loquacious a, Typeable t) => Loq -> Maybe (t a)
fromLoqTraversable (Loq sm) = cast sm >>= traverse fromLoq

-- | Recursively encode a 'Bifunctor' instance to 'Loq'.
--
-- Useful for types of kind '* -> * -> *'.
toLoqBifunctor :: (Loquacious (f Loq Loq), Bifunctor f, Loquacious a, Loquacious b) => f a b -> Loq
toLoqBifunctor = Loq . bimap toLoq toLoq

-- | Decode a recursively encoded 'Loq' via a 'Traversable' instance.
--
-- Useful for types of kind '* -> *'.
fromLoqBitraversable :: (Bitraversable t, Loquacious a, Loquacious b, Typeable t) => Loq -> Maybe (t a b)
fromLoqBitraversable (Loq sm) = cast sm >>= bitraverse fromLoq fromLoq

-- | Recursively encode a 'Bifunctor' instance to 'Loq', but only on the first type argument.
--
-- Useful for types of kind '* -> k -> *', for example 'Const'.
toLoqFirst :: (Loquacious (f Loq b), Bifunctor f, Loquacious a) => f a b -> Loq
toLoqFirst = Loq . first toLoq

-- | Decode a recursively encoded 'Loq' via a 'Traversable' instance.
--
-- Useful for types of kind '* -> *'.
fromLoqFirst :: (Bitraversable t, Loquacious a, Typeable t, Typeable b) => Loq -> Maybe (t a b)
fromLoqFirst (Loq sm) = cast sm >>= bitraverse fromLoq pure

-- basic base types
instance Loquacious ()
instance Loquacious Bool
instance Loquacious Version where loq _ = pretty . showVersion
instance Loquacious Void

-- basic number types
instance Loquacious Integer
instance Loquacious Natural

instance Loquacious Int
instance Loquacious Int8
instance Loquacious Int16
instance Loquacious Int32
instance Loquacious Int64

instance Loquacious Word
instance Loquacious Word8
instance Loquacious Word16
instance Loquacious Word32
instance Loquacious Word64

instance Loquacious Double
instance Loquacious Float

-- polymorphic types
instance Loquacious a => Loquacious (Identity a) where
  loq m = m . runIdentity
  toLoq = toLoqFunctor
  fromLoq = fromLoqTraversable

instance (Loquacious a, Typeable b) => Loquacious (Const a b) where
  loq m = m . getConst
  toLoq = toLoqFirst
  fromLoq = fromLoqFirst

instance Loquacious a => Loquacious (Maybe a) where
  loq _ Nothing  = mempty
  loq m (Just x) = m x
  toLoq = toLoqFunctor
  fromLoq = fromLoqTraversable

instance Loquacious a => Loquacious (NonEmpty a) where
  loq m = align . list . fmap m . toList
  toLoq = toLoqFunctor
  fromLoq = fromLoqTraversable

instance Loquacious a => Loquacious [a] where
  loq m = align . list . fmap m
  toLoq = toLoqFunctor
  fromLoq = fromLoqTraversable

-- | The first paramater of 'Array' cannot be matched generically.
instance (Ix i, Typeable i, Loquacious a) => Loquacious (Array i a) where
  loq m = align . list . fmap m . toList
  toLoq = toLoqFunctor
  fromLoq = fromLoqTraversable

-- | 'UArray' cannot be matched generically due to boxing requirements.
instance (Ix i, Typeable i, IArray UArray a, Loquacious a) => Loquacious (UArray i a) where
  loq m = align . list . fmap m . elems

instance (Loquacious a, Loquacious b) => Loquacious (Either a b) where
  loq m (Left x)  = m x
  loq m (Right x) = m x
  toLoq = toLoqBifunctor
  fromLoq = fromLoqBitraversable

instance (Loquacious a, Loquacious b) => Loquacious (a, b) where
  loq m (a,b) = align $ tupled [m a, m b]
  toLoq = toLoqBifunctor
  fromLoq = fromLoqBitraversable

-- | FIXME The first paramater of cannot be matched generically, no @Tritraversable@.
instance (Loquacious a, Loquacious b, Loquacious c) => Loquacious (a, b, c) where
  loq m (a,b,c) = align $ tupled [m a, m b, m c]
  toLoq = toLoqBifunctor
  fromLoq = fromLoqBitraversable

instance Loquacious t => Loquacious (Complex t) where
  loq m (a :+ b) = m a <+> "+" <+> m b <> "i"
  toLoq = toLoqFunctor
  fromLoq = fromLoqTraversable

-- | FIXME Cannot match generic 'Ratio's due to lack of 'Functor' instance.
instance Loquacious t => Loquacious (Ratio t) where
  loq m x = m (numerator x) <> "/" <> m (denominator x)
  -- toLoq = toLoqFunctor
  -- fromLoq = fromLoqTraversable

-- basic string types
instance Loquacious Char
instance {-# OVERLAPS #-} Loquacious String
instance Loquacious Text.Text
instance Loquacious LazyText.Text
-- TODO instance Loquacious ByteString.ByteString
-- TODO instance Loquacious LazyByteString.ByteString

-- Call Stack Support
instance Loquacious CallStack where
  loq m = withFrozenCallStack ( align . vsep . fmap messageStack . getCallStack )
    where messageStack (func, srcLoc) = fromString func <+> "←" <+> m srcLoc

instance Loquacious SrcLoc where
  loq m SrcLoc{..} = msgFile <+> parens msgPackage
    where
      msgFile = fromString srcLocFile <> colon <> m srcLocStartLine <> colon <> m srcLocStartCol
      msgPackage = fromString srcLocPackage <> colon <> fromString srcLocModule

-- Proxy and other Type Representations
instance Loquacious TypeRep where loq _ = viaShow

instance (Typeable a) => Loquacious (Proxy a) where
  loq m _ = m $ typeRep (Proxy @a)

instance (Typeable a, Typeable b) => Loquacious (a -> b) where
  loq m = m . typeOf

instance (Typeable a, Typeable b) => Loquacious (a :~: b) where
  loq m _ = m (typeRep (Proxy @a)) <+> ":~:" <+> m (typeRep (Proxy @b))

instance (Typeable a, Typeable b) => Loquacious (a :~~: b) where
  loq m _ = m (typeRep (Proxy @a)) <+> ":~~:" <+> m (typeRep (Proxy @b))

-- Exception Types
instance Loquacious E.AllocationLimitExceeded where loq _ = viaShow
instance Loquacious E.ArithException where loq _ = viaShow
instance Loquacious E.ArrayException where loq _ = viaShow
instance Loquacious E.AssertionFailed where loq _ = viaShow
instance Loquacious E.AsyncException where loq _ = viaShow
instance Loquacious E.BlockedIndefinitelyOnMVar where loq _ = viaShow
instance Loquacious E.BlockedIndefinitelyOnSTM where loq _ = viaShow
instance Loquacious E.CompactionFailed where loq _ = viaShow
instance Loquacious E.Deadlock where loq _ = viaShow
instance Loquacious E.IOException where loq _ = viaShow
instance Loquacious E.NestedAtomically where loq _ = viaShow
instance Loquacious E.NoMethodError where loq _ = viaShow
instance Loquacious E.NonTermination where loq _ = viaShow
instance Loquacious E.PatternMatchFail where loq _ = viaShow
instance Loquacious E.RecConError where loq _ = viaShow
instance Loquacious E.RecSelError where loq _ = viaShow
instance Loquacious E.RecUpdError where loq _ = viaShow
instance Loquacious E.SomeAsyncException where loq _ = viaShow
instance Loquacious E.SomeException where loq _ = viaShow
instance Loquacious E.TypeError where loq _ = viaShow
instance Loquacious EB.FixIOException where loq _ = viaShow