{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Main where

import Config.Schema (SectionsSpec, ValueSpec)
import Control.Concurrent
import Control.Concurrent.Chan
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.Bits
import Data.ByteString (ByteString)
import Data.Char
import Data.Coerce
import Data.Colour.CIE
import Data.Colour.CIE.Illuminant
import Data.Colour.SRGB
import Data.Containers.ListUtils
import Data.Default
import Data.Foldable
import Data.Functor.Alt ((<!>))
import Data.String
import Data.Tree
import Data.Int
import Data.IORef
import Data.List
import Data.Map (Map)
import Data.Maybe
import Data.Monoid
import Data.Multiset (Multiset)
import Data.Ord
import Data.Set (Set)
import Data.Set.Ordered (OSet)
import Data.Text (Text)
import Data.Time
import Data.Time.Calendar.OrdinalDate
import Data.Traversable
import Data.Vector (Vector)
import Data.Void
import Database.PostgreSQL.Simple (Connection)
import GHC.Read
import Graphics.Rendering.Cairo (Render)
import Graphics.UI.Gtk
import Options.Applicative
import System.Clock (Clock(..), TimeSpec(..), getTime)
import System.Directory
import System.Environment
import System.Environment.XDG.BaseDir
import System.FilePath
import System.Glib.Properties
import System.Glib.UTFString
import System.IO
import System.Posix.Process (getProcessID)
import System.Random
import Text.Printf (printf)
import Text.Read
import Text.Read.Lex
import Vertumnion.Shared
import qualified Config as C
import qualified Config.Schema as C
import qualified Data.ByteString as BS
import qualified Data.Map as M
import qualified Data.Map.Strict as M.S
import qualified Data.Multiset as MS
import qualified Data.Set as S
import qualified Data.Set.Ordered as O
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Text.Read as T
import qualified Data.Vector as V
import qualified Database.PostgreSQL.Simple as DB
import qualified Database.PostgreSQL.Simple.FromField as DB
import qualified Database.PostgreSQL.Simple.ToField as DB
import qualified Database.PostgreSQL.Simple.FromRow as DB
import qualified Database.PostgreSQL.Simple.ToRow as DB
import qualified Database.PostgreSQL.Simple.Types as DB
import qualified Graphics.Rendering.Cairo as Cairo
import qualified Graphics.Rendering.Cairo.Matrix as CM
import qualified Numeric.LinearAlgebra as Matrix
import qualified Text.PrettyPrint.ANSI.Leijen as Doc

main :: IO ()
main = do
	ctx <- initializeContext
	traverse_ (\thread -> forkIO (thread ctx)) [loggingThread, stdinThread, parserThread, heartbeatThread, moduleThread, preferencesThread]
	guiThread ctx -- NB not forked
	-- TODO: maybe stay open and start ignoring stdin, so that pipes don't fill up and block producers?

data Context = Context
	{ ctxConfig :: Config
	, ctxProfile :: Profile
	, ctxArguments :: Arguments
	, ctxErrors :: Chan String
	, ctxInput :: Chan (TimeSpec, Text)
	-- TODO: since this is only written from parserThread (right?) it can probably be an IORef
	, ctxUITimerLabelStatus :: MVar TimerLabelStatus
	, ctxUITimerLabel :: Label
	, ctxUIGraph :: DrawingArea
	, ctxModuleInput :: Chan Command
	, ctxModuleOutputs :: TVar [(String, TVar [ModulePoint])]
	, ctxTimeMagnitude :: IORef TimeMagnitude
	, ctxEventStore :: TreeStore Event
	, ctxStateRange :: TVar StateRange
	-- the Word is an epoch, used as an equality-check fast path
	, ctxRandomRuns :: TVar (Word, Runs)
	, ctxPreferences :: TChan Preferences
	}

initializeContext :: IO Context
initializeContext = do
	argumentParser <- mkArgumentParser
	arguments <- execParser argumentParser
	profile <- loadProfile (argProfile arguments) (argTargetOverride arguments)
	config <- loadConfig
	errors <- newChan
	input <- newChan
	initGUI
	uiTimerLabelStatus <- newMVar (Stopped 0)
	uiTimerLabel <- labelNew (string <$> Nothing)
	uiGraph <- drawingAreaNew
	moduleInput <- newChan
	moduleOutputs <- newTVarIO []
	timeMagnitude <- newIORef (pDurationHint profile)
	eventStore <- treeStoreNew []
	stateRange <- newTVarIO StateRange
		{ srStateCache = Uninitialized
		, srMin = humanOrder (pTarget profile)
		, srMax = humanOrder (pTarget profile)
		}
	randomRuns <- newTVarIO (0, M.empty)
	preferences <- newTChanIO
	pure Context
		{ ctxConfig = config
		, ctxProfile = profile
		, ctxArguments = arguments
		, ctxErrors = errors
		, ctxInput = input
		, ctxUITimerLabelStatus = uiTimerLabelStatus
		, ctxUITimerLabel = uiTimerLabel
		, ctxUIGraph = uiGraph
		, ctxModuleInput = moduleInput
		, ctxModuleOutputs = moduleOutputs
		, ctxTimeMagnitude = timeMagnitude
		, ctxEventStore = eventStore
		, ctxStateRange = stateRange
		, ctxRandomRuns = randomRuns
		, ctxPreferences = preferences
		}

data Config = Config
	{ db :: ByteString
	} deriving (Eq, Ord, Read, Show)

instance Default Config where
	def = Config
		{ db = "dbname=vertumnion"
		}

configSpec :: ValueSpec Config
configSpec = C.sectionsSpec
	"configuration"
	(config <$> C.optSection "db" help)
	where
	config Nothing = def
	config (Just t) = Config
		{ db = T.encodeUtf8 t -- I know, I know. I don't care, it will never come up
		}
	help = "A postgres connection string for storing splits (default: dbname=vertumnion)"

type ID = Int32

soSort :: SortOrder -> [Text] -> [Text]
soSort = \case
	Ascending -> sortOn humanOrder
	Descending -> sortOn (Down . humanOrder)
	AscendingOn ts -> sortOn (\t -> (O.findIndex t ts, humanOrder t))

soCompare :: SortOrder -> HumanOrder -> HumanOrder -> Ordering
soCompare Ascending t t' = compare t t'
soCompare Descending t t' = compare t' t
soCompare (AscendingOn ts) t t' = case (O.findIndex (toText t) ts, O.findIndex (toText t') ts) of
	(Just i, Just i') -> compare i i'
	_ -> compare t t'

soLt :: SortOrder -> HumanOrder -> HumanOrder -> Bool
soLt so t t' = soCompare so t t' == LT

soMin :: SortOrder -> HumanOrder -> HumanOrder -> HumanOrder
soMin so t t' = if soLt so t t' then t else t'

soMax :: SortOrder -> HumanOrder -> HumanOrder -> HumanOrder
soMax so t t' = if soLt so t t' then t' else t

ctxAllStates :: Context -> Maybe (OSet Text)
ctxAllStates = soAllStates . pSortOrder . ctxProfile

preferencesSpec :: ValueSpec Preferences
preferencesSpec = C.sectionsSpec "preferences" $ pure Preferences
	<*> C.reqSection' "window" rectangleSpec "request that the window manager initially place the window with this geometry"
	<*> C.reqSection' "splits" splitsSpec "set the initial size of the splits pane"
	<*> C.reqSection' "graph" graphSpec "set the initial size of the graph pane"
	where
	rectangleSpec = C.sectionsSpec "window" $ pure Rectangle
		<*> C.reqSection "x" ""
		<*> C.reqSection "y" ""
		<*> C.reqSection "width" ""
		<*> C.reqSection "height" ""
	splitsSpec = C.sectionsSpec "splits" $ C.reqSection "height" ""
	graphSpec = C.sectionsSpec "graph" $ C.reqSection "width" ""

logDir :: IO FilePath
logDir = getUserStateDir "vertumnion"

preferencesDir :: IO FilePath
preferencesDir = configPath "preferences"

loadConfig :: IO Config
loadConfig = do
	fp <- configName
	mh <- try (openFile fp ReadMode)
	case mh of
		Left (e :: IOError) -> def
		Right h -> loadSchema fp h configSpec

loadPreferences :: String -> IO (Maybe Preferences)
loadPreferences profile = do
	fp <- (</> profile) <$> preferencesDir
	mh <- try (openFile fp ReadMode)
	case mh of
		Left (e :: IOError) -> def
		Right h -> Just <$> loadSchema fp h preferencesSpec

data Arguments = Arguments
	{ argProfile :: FilePath
	, argTargetOverride :: Maybe Text
	} deriving (Eq, Ord, Read, Show)

mkArgumentParser :: IO (ParserInfo Arguments)
mkArgumentParser = do
	desc <- usage
	pure $ info (opts <**> helper)
		(  fullDesc
		<> progDesc "Run a splits timer. Events are accepted on stdin."
		<> (footerDoc . Just . Doc.string) desc
		)
	where
	opts = pure Arguments
		<*> strArgument
			(  metavar "PROFILE"
			<> help "A description of the game being played"
			)
		<*> ( optional $ T.pack <$> strOption
				(  long "target"
				<> short 't'
				<> metavar "EVENT"
				<> help "Override the target given in the profile just for this run"
				)
			)

usage :: IO String
usage = do
	prog <- getProgName
	profDir <- profileDir
	prefDir <- preferencesDir
	fp <- configName
	pure . unlines . tail $ [undefined
		, "All files processed by " ++ prog ++ " should be in config-value format and use the"
		, "UTF-8 encoding. See here for details:"
		, "http://hackage.haskell.org/package/config-value/docs/Config.html"
		, ""
		, "PROFILE refers to a file in " ++ profDir ++ "."
		, "The profile should conform to the following format."
		, show (C.generateDocs profileSpec)
		, ""
		, "Preferences will be loaded if they are available. They may be placed in a file"
		, "with the same profile name in " ++ prefDir ++ "."
		, "This file will automatically be created or overwritten during program execution."
		, "The preferences should conform to the following format."
		, show (C.generateDocs preferencesSpec)
		, ""
		, "A configuration file is also read from " ++ fp ++ "."
		, "It is similarly a UTF-8 encoded config-value file, with the following format."
		, show (C.generateDocs configSpec)
		]

data Preferences = Preferences
	{ windowRectangle :: Rectangle
	, splitHeight :: Int
	, graphWidth :: Int
	} deriving (Eq, Show)

scheduleSavePreferences ::
	(WindowClass window, PanedClass graphPane, PanedClass dataPane) =>
	Context -> window -> graphPane -> dataPane -> IO ()
scheduleSavePreferences ctx window graphPane dataPane = liftIO $ do
	(x, y) <- windowGetPosition window
	(w, h) <- windowGetSize window
	sh <- panedGetPosition dataPane
	gw <- panedGetPosition graphPane
	atomically $ writeTChan (ctxPreferences ctx) Preferences
		{ windowRectangle = Rectangle x y w h
		, splitHeight = sh
		, graphWidth = gw
		}

loggingThread :: Context -> IO loop
loggingThread (ctxErrors -> chan) = do
	-- by reading from the channel first, we guarantee not to write a log unless there's something to put in it
	err <- readChan chan
	now <- getCurrentTime
	me <- getProcessID
	dir <- logDir
	let fp = dir </> show me <.> "log"
	mh <- try (createDirectoryIfMissing True dir >> openFile fp AppendMode)
	h <- case mh of
		Right h -> h <$ hSetBuffering h LineBuffering
		Left (_ :: SomeException) -> do
			hPutStrLn stderr $ "WARNING: Could not open log file " ++ fp ++ " for appending. Logging to stderr"
			pure stderr
	hPutStrLn h (show now ++ ": " ++ err)
	forever $ do
		err <- readChan chan
		now <- getCurrentTime
		hPutStrLn h (show now ++ ": " ++ err)

data TimerLabelStatus
	= RunningSince TimeSpec
	| Stopped DiffTimeSpec
	deriving (Eq, Ord, Read, Show)

{-# INLINE string #-}
string :: String -> String
string = id

arbitraryTimeSpec :: TimeSpec
arbitraryTimeSpec = TimeSpec 0 0

guiThread :: Context -> IO ()
guiThread ctx = do
	window <- windowNew
	on window objectDestroy mainQuit
	vbox <- vBoxNew False 0
	set window [windowTitle := string "vertumnion", containerChild := vbox]

	gameLabel <- labelNew . Just . pGame . ctxProfile $ ctx
	-- TODO: Maybe it would be nice for the target to be editable
	targetLabel <- labelNew . Just . ("Target: " <>) . pTarget . ctxProfile $ ctx

	updateTimerLabel ctx

	eventLog <- treeViewNewWithModel (ctxEventStore ctx)
	set eventLog [treeViewHeadersVisible := False]
	let newColumn :: GlibString string => (Event -> IO string) -> IO Int
	    newColumn = addColumnPlainText eventLog (ctxEventStore ctx)
	newColumn (pure . eState)
	newColumn $ \e -> do
		mag <- readIORef (ctxTimeMagnitude ctx)
		pure . snd . showDiffTimeSpec (eMicrosecond e) $ mag
	for_ (pFPS (ctxProfile ctx)) $ \fps -> newColumn $ \e -> do
		mag <- readIORef (ctxTimeMagnitude ctx)
		case eFrame e of
			Nothing -> pure ""
			Just n -> do
				let (mag', content) = showDiffTimeSpec (fromInteger n / realToFrac fps) mag
				when (mag /= mag') $ do
					writeIORef (ctxTimeMagnitude ctx) mag'
					redrawAllIntervals ctx
				pure content

	eventLogScroll <- scrolledWindowNew Nothing Nothing
	set eventLogScroll [containerChild := eventLog, scrolledWindowHscrollbarPolicy := PolicyNever]
	eventLogAdjustment <- scrolledWindowGetVAdjustment eventLogScroll
	-- TODO: disable jumping when position has been manually changed
	onAdjChanged eventLogAdjustment $
		adjustmentGetUpper eventLogAdjustment >>= adjustmentSetValue eventLogAdjustment

	widgetSetSizeRequest (ctxUIGraph ctx) 200 200
	on (ctxUIGraph ctx) draw (renderGraph ctx)

	legend <- mkLegend
	graphPane <- hPanedNew
	panedPack1 graphPane (ctxUIGraph ctx) True True
	panedPack2 graphPane legend False True

	dataPane <- vPanedNew
	panedPack1 dataPane eventLogScroll True True
	panedPack2 dataPane graphPane False True

	boxPackStart vbox gameLabel PackNatural 0
	boxPackStart vbox targetLabel PackNatural 0
	boxPackStart vbox (ctxUITimerLabel ctx) PackNatural 0
	boxPackStart vbox dataPane PackGrow 0

	mprefs <- loadPreferences (argProfile (ctxArguments ctx))
	for_ mprefs $ \prefs -> do
		let Rectangle x y w h = windowRectangle prefs
		windowSetDefaultSize window w h
		windowMove window x y
		panedSetPosition dataPane (splitHeight prefs)
		panedSetPosition graphPane (graphWidth prefs)

	let ssp = scheduleSavePreferences ctx window graphPane dataPane
	on window configureEvent (False <$ liftIO ssp)
	on graphPane (notifyProperty panedPosition') ssp
	on dataPane  (notifyProperty panedPosition') ssp

	widgetShowAll window
	mainGUI

addColumnPlainText ::
	( TreeViewClass treeView
	, TreeModelClass (model row)
	, TypedTreeModelClass model
	, GlibString string
	) =>
	treeView -> model row -> (row -> IO string) -> IO Int
addColumnPlainText treeView model showRow = do
	col <- treeViewColumnNew
	renderer <- cellRendererTextNew
	treeViewColumnPackEnd col renderer False
	cellLayoutSetAttributes col renderer model $ \row -> [cellText :=> showRow row]
	treeViewAppendColumn treeView col

mkLegend :: IO TreeView
mkLegend = do
	store <- listStoreNew $ []
		++ map Left (zip [0..] allModules)
		++ map Right [("time", [1, 1], 1/2), ("state", [1,3,1,1], -1/2), ("number", [1,5], -5/2)]
	treeView <- treeViewNewWithModel store
	col <- treeViewColumnNew
	graphicRenderer <- cellRendererPixbufNew
	labelRenderer <- cellRendererTextNew
	treeViewColumnPackStart col graphicRenderer False
	treeViewColumnPackStart col labelRenderer True
	cellLayoutSetAttributes col graphicRenderer store $ \row -> [cellPixbuf :=> legendPixbuf row]
	cellLayoutSetAttributes col labelRenderer store $ \row -> [cellText := legendText row]
	treeViewAppendColumn treeView col
	set treeView [treeViewHeadersVisible := False]
	pure treeView

legendText :: Either (Double, Module) (String, [Double], Double) -> String
legendText (Left (_, m)) = mLabel m
legendText (Right (s, _, _)) = s

legendPixbuf :: Either (Double, Module) (String, [Double], Double) -> IO Pixbuf
legendPixbuf row = do
	surface <- Cairo.createImageSurface Cairo.FormatARGB32 30 30
	Cairo.renderWith surface $ case row of
		Left (i, _) -> do
			let dAngle = min (pi / numModules) (pi / 12)
			    angle = 2 * pi * i / numModules
			    RGB r g b = toSRGB (cieLAB d65 50 (100 * cos angle) (100 * sin angle))
			Cairo.setSourceRGB r g b
			Cairo.moveTo 15 15
			Cairo.arc 15 15 14 (angle-dAngle) (angle+dAngle)
			Cairo.fill
		Right (_, intervals, start) -> do
			Cairo.scale 5 5
			Cairo.setLineWidth 0.4
			Cairo.setDash intervals start
			Cairo.moveTo 0 3
			Cairo.lineTo 6 3
			Cairo.stroke
	pixbufNewFromSurface surface 0 0 30 30
	where numModules = fromIntegral (length allModules)

renderGraph :: Context -> Render ()
renderGraph ctx = do
	(_, _, w, h) <- Cairo.clipExtents
	let wScale = w/1.75
	    hScale = h/1.3
	if wScale < hScale
		then Cairo.scale wScale wScale >> Cairo.translate 0.45 (h/(2*wScale)-0.55)
		else Cairo.scale hScale hScale >> Cairo.translate (w/(2*hScale)-0.425) 0.1
	states_ <- liftIO (ctxStates ctx)
	ptss_ <- liftIO $ readTVarIO (ctxModuleOutputs ctx)
	ptss <- liftIO $ for ptss_ $ \(label, ptVar) -> (,) label <$> readTVarIO ptVar

	let
		states :: Map Text Double
		states = M.fromList (zip states_ [0..])

		maxStateIx :: Double
		maxStateIx = fromIntegral (M.size states - 1)

		yStates = [s | (_, pts) <- ptss, ModulePoint { y = State s } <- pts]
		yTimes = [t | (_, pts) <- ptss, ModulePoint { y = Time t } <- pts]
		yLogScales = [n | (_, pts) <- ptss, ModulePoint { y = LogScale n } <- pts]

		dtbX = chooseDiffTimeBounds [x pt | (_, pts) <- ptss, pt <- pts]
		dtbY = chooseDiffTimeBounds yTimes
		lsb = chooseLogScaleBounds yLogScales

		isMajor = case pMajorStates (ctxProfile ctx) of
			Nothing -> const True
			Just ss -> (`S.member` ss)

		xPos :: DiffTimeSpec -> Double
		xPos = dtbPos dtbX

		yPos :: Dependent -> Double
		yPos (State s) = 1 - (states M.! s) / maxStateIx
		yPos (Time t) = 1 - dtbPos dtbY t
		yPos (LogScale n) = 1 - logScalePos lsb n

		numModules :: Double
		numModules = fromIntegral (length ptss)

		hasPoints = not . null . concatMap snd $ ptss
		hasState = not . null $ yStates
		hasDiffTime = not . null $ yTimes
		hasLogScale = not . null $ yLogScales

	Cairo.setLineWidth 0.001
	when hasPoints $ do
		let ds = dtbGridLines dtbX

		-- draw grid lines
		for_ ds $ \d -> do
			let coord = xPos d
			Cairo.moveTo coord 0
			Cairo.lineTo coord 1
		Cairo.stroke

		-- label grid lines
		spaceExtent <- Cairo.textExtents [' ']
		fe <- Cairo.fontExtents
		labels <- traverse sequence [(d, sizedText (dtbLabel dtbX d)) | d <- ds]

		let maxWidth = maximum $ map (Cairo.textExtentsXadvance . stExtents . snd) labels
		    xScale = 0.1/(Cairo.textExtentsXadvance spaceExtent + maxWidth)
		    yScale = 0.1/(Cairo.fontExtentsAscent fe + Cairo.fontExtentsDescent fe)
		    scale = min xScale yScale
		    halfScale = scale/2
		    y = 1.1 + (Cairo.fontExtentsAscent fe - Cairo.fontExtentsDescent fe) * halfScale

		scaleFontMatrix scale
		forM_ labels $ \(d, st) -> do
			let dx = Cairo.textExtentsXadvance (stExtents st) * halfScale
			Cairo.moveTo (xPos d - dx) y
			Cairo.showText (dtbLabel dtbX d)

	when hasState $ do
		-- draw grid lines
		Cairo.setDash [1/60, 3/60, 1/60, 1/60] (-1/120)
		flip M.traverseWithKey states $ \state ix -> when (isMajor state) $ do
			let y = 1 - ix / maxStateIx
			Cairo.moveTo 0 y
			Cairo.lineTo 1 y
		Cairo.stroke

		-- label grid lines
		valignText 1.05 0.2 . M.fromList $
			[ (yPos (State state), ("", "", state))
			| state <- M.keys states
			, isMajor state
			]

	when hasDiffTime $ do
		let ds = dtbGridLines dtbY
		-- draw grid lines
		Cairo.setDash [1/60, 1/60] (1/120)
		for_ ds $ \d -> do
			let coord = yPos (Time d)
			Cairo.moveTo 0 coord
			Cairo.lineTo 1 coord
		Cairo.stroke

		-- label grid lines
		valignText (-0.25) 0.2 . M.fromList $
			[(yPos (Time d), (dtbLabel dtbY d, "", "")) | d <- ds]

	when hasLogScale $ do
		-- draw grid lines
		Cairo.setDash [1/60, 5/60] (-5/120)
		for_ (lsbGridLines lsb) $ \n -> do
			let coord = yPos (LogScale n)
			Cairo.moveTo 0 coord
			Cairo.lineTo 1 coord
		Cairo.stroke

		-- label grid lines
		valignText (-0.4) 0.1 . M.fromList $
			[ (yPos (LogScale gridLine), logScaleShow gridLine)
			| gridLine <- lsbGridLines lsb
			]

	for_ (zip [0..] ptss) $ \(i, (lbl, pts)) -> do
		let dAngle = min (pi / numModules) (pi / 12)
		    angle = 2 * pi * i / numModules
		    RGB r g b = toSRGB (cieLAB d65 50 (100 * cos angle) (100 * sin angle))
		Cairo.setSourceRGB r g b
		for_ pts $ \pt -> do
			let xCoord = xPos (x pt)
			    yCoord = yPos (y pt)
			Cairo.moveTo xCoord yCoord
			Cairo.arc xCoord yCoord 0.03 (angle-dAngle) (angle+dAngle)
		Cairo.fill

valignText :: (Cairo.CairoString string, IsString string, Monoid string) =>
	Double -> Double -> Map Double (string, string, string) -> Render ()
valignText x w entries_ = do
	entries <- traverse valignInfo $
		if M.null entries_
		then M.singleton 0 ("", "", "")
		else entries_
	fe <- Cairo.fontExtents

	let maxPreWidth = maximum (vaiPrefixWidth <$> entries)
	    maxSufWidth = maximum (vaiSuffixWidth <$> entries)
	    maxWidth = maxPreWidth + maxSufWidth
	    xScale = w / maxWidth
	    yScale = chooseYScale xScale fe entries
	    scale = min xScale yScale
	    sepX = x + (w + (maxPreWidth - maxSufWidth)*scale)/2
	    dy = (Cairo.fontExtentsAscent fe - Cairo.fontExtentsDescent fe)*scale/2

	scaleFontMatrix scale

	void . flip M.traverseWithKey entries $ \y_ vai -> do
		let y = y_ + dy
		    sepWidth = scale * (Cairo.textExtentsXadvance . stExtents . vaiSeparator) vai
		Cairo.moveTo (sepX - vaiPrefixWidth vai*scale) y
		Cairo.showText (stString (vaiPrefix vai) <> stString (vaiSeparator vai))
		Cairo.moveTo (sepX + sepWidth/2) y
		Cairo.showText (stString (vaiSuffix vai))

scaleFontMatrix :: Double -> Render ()
scaleFontMatrix s = Cairo.setFontMatrix . CM.scalarMultiply s =<< Cairo.getFontMatrix

data SizedText string = SizedText
	{ stString :: string
	, stExtents :: Cairo.TextExtents
	}

sizedText :: Cairo.CairoString string => string -> Render (SizedText string)
sizedText s = SizedText s <$> Cairo.textExtents s

data VAlignInfo string = VAlignInfo
	{ vaiPrefix, vaiSeparator, vaiSuffix :: SizedText string
	, vaiPrefixWidth :: Double
	, vaiSuffixWidth :: Double
	}

valignInfo :: Cairo.CairoString string => (string, string, string) -> Render (VAlignInfo string)
valignInfo (pre_, sep_, suf_) = do
	pre <- sizedText pre_
	sep <- sizedText sep_
	suf <- sizedText suf_
	pure VAlignInfo
		{ vaiPrefix = pre
		, vaiSeparator = sep
		, vaiSuffix = suf
		, vaiPrefixWidth = dx pre + dx sep / 2
		, vaiSuffixWidth = dx suf + dx sep / 2
		}
	where dx = Cairo.textExtentsXadvance . stExtents

chooseYScale :: Double -> Cairo.FontExtents -> Map Double (VAlignInfo string) -> Double
chooseYScale def fe vai
	| M.size vai < 2 = def
	| otherwise = minDY / reqDY
	where
	minDY = minimum . ap (zipWith subtract) tail . M.keys $ vai
	reqDY = Cairo.fontExtentsHeight fe

-- TODO: the smallest (and largest?) state should always be major

data DiffTimeBounds = DiffTimeBounds
	{ dtbZero :: DiffTimeSpec
	, dtbGridLine :: DiffTimeSpec
	, dtbOne :: DiffTimeSpec
	, dtbLabel :: DiffTimeSpec -> String
	}

chooseDiffTimeBounds :: [DiffTimeSpec] -> DiffTimeBounds
chooseDiffTimeBounds [] = DiffTimeBounds
	{ dtbZero = 0
	, dtbGridLine = 1
	, dtbOne = 10
	, dtbLabel = \t -> show (floor t) ++ "s"
	}
chooseDiffTimeBounds ts = DiffTimeBounds
	{ dtbZero = smallAndRound
	, dtbGridLine = grid
	, dtbOne = bigAndRound
	, dtbLabel = label
	} where
	small = minimum ts
	big = maximum ts
	width = big - small
	gridTarget = width / 10
	(grid, label) = case M.lookupGE gridTarget roundIntervals of
		Just v -> v
		Nothing -> ( gridDays (60*60*24) (gridTarget / (60*60*24))
		           , \t -> let (pre, sep, suf) = logScaleShow . fromInteger . floor $ t/(60*60*24)
		                   in concat [pre, sep, suf, "d"]
		           )
	gridDays cur tgt
		| tgt > 5 = gridDays (cur*10) (tgt/10)
		| tgt > 2 = cur*5
		| tgt > 1 = cur*2
		| otherwise = cur
	smallAndRound = fromInteger (floor (small / grid)) * grid
	bigAndRound = fromInteger (ceiling (big / grid)) * grid

roundIntervals :: Map DiffTimeSpec (DiffTimeSpec -> String)
roundIntervals = M.fromList $ zip
	[      1,       2,       5,       10,       30 -- seconds
	,   60*1,    60*2,    60*5,    60*10,    60*30 -- minutes
	,60*60*1, 60*60*2, 60*60*6, 60*60*12           -- hours
	]
	([]
	++ replicate 5 (fmt "%m:%02S")
	++ replicate 5 (\t -> fmt (if t < 60*60 then "%-mm" else "%-hh%02Mm") t)
	++ replicate 4 (\t -> fmt (if t < 60*60*24 then "%-hh" else "%-dd%02Hh") t)
	)
	where
	fmt format = formatTime defaultTimeLocale format . ndt

	ndt :: DiffTimeSpec -> NominalDiffTime
	ndt = realToFrac

dtbGridLines :: DiffTimeBounds -> [DiffTimeSpec]
dtbGridLines dtb = [dtbZero dtb, dtbZero dtb + dtbGridLine dtb .. dtbOne dtb]

dtbPos :: DiffTimeBounds -> DiffTimeSpec -> Double
dtbPos dtb d = if o == z then 0.5 else realToFrac ((d - z) / (o - z)) where
	o = dtbOne dtb
	z = dtbZero dtb

data LogScaleBounds = LogScaleBounds
	{ lsbZero :: Double
	, lsbScale :: Double
	, lsbOffset :: Double
	, lsbGridLines :: [Double]
	} deriving (Eq, Ord, Read, Show)

chooseLogScaleBounds :: [Double] -> LogScaleBounds
chooseLogScaleBounds ns
	| null ns = LogScaleBounds
		{ lsbZero = 1
		, lsbScale = recip (log 10)
		, lsbOffset = 0
		, lsbGridLines = [1, 2, 5, 10]
		}
	| all (< 0) ns = let lsb = chooseLogScaleBounds (negate <$> ns) in LogScaleBounds
		{ lsbZero = -lsbZero lsb
		, lsbScale = -lsbScale lsb
		, lsbGridLines = negate <$> lsbGridLines lsb
		, lsbOffset = 1
		}
	| any (<= 0) ns = chooseLogScaleBounds (filter (>0) ns)
	| otherwise = LogScaleBounds
		{ lsbZero = zero
		, lsbScale = recip (log (one/zero))
		, lsbOffset = 0
		, lsbGridLines = gridLines
		} where
		small = minimum ns
		big = maximum ns

		oom x = floor (logBase 10 x)
		logMags@[smallLogMag, bigLogMag] = map oom [small, big]
		mags@[smallMag, bigMag] = map (10^^) logMags
		[smallRatio, bigRatio] = zipWith (/) [small, big] mags

		smallRoundRatio = fromMaybe 1 (S.lookupLE smallRatio roundDigits)
		bigRoundRatio = fromMaybe 10 (S.lookupGE bigRatio roundDigits)

		zero = smallRoundRatio * smallMag
		one = bigRoundRatio * bigMag

		allGrids = S.toAscList . S.fromList $
			[ gridLine
			-- bigLogMag is sometimes too small by 1 due to rounding, so
			-- include 10 as a choice of coefficient
			| ratio <- 10 : S.toList roundDigits
			, mag <- [smallLogMag..bigLogMag]
			, let gridLine = ratio*10^^mag
			, zero <= gridLine && gridLine <= one
			]
		gridLines = chooseAFewEvenly allGrids

chooseAFewEvenly :: [a] -> [a]
chooseAFewEvenly as
	| lines <= 6 = as
	| otherwise = head $ []
		++ [ every (gaps `quot` n) as
		   | n <- [5, 4, 3]
		   , gaps `rem` n == 0
		   ]
		++ [ indices [ (numerator * (lines-1) + 2) `quot` 4
		             | numerator <- [0 .. 4]
		             ]
		   ]
	where
	lines = length as
	gaps = lines-1

	every n [] = []
	every n (x:xs) = x : every n (drop (n-1) xs)

	indices = go 0 as where
		go _ [] _ = []
		go _ _ [] = []
		go i (x:xs) is@(i':is') = case compare i i' of
			LT -> go (i+1) xs is
			EQ -> x : go (i+1) xs is'
			-- should be impossible, but...
			GT -> if i' < 0 then go i (x:xs) is' else go 0 as is

roundDigits :: Set Double
roundDigits = S.fromList [1, 2, 5]

logScalePos :: LogScaleBounds -> Double -> Double
logScalePos lsb n = lsbOffset lsb + log (n/lsbZero lsb) * lsbScale lsb

logScaleShow :: Double -> (String, String, String)
logScaleShow = id
	. snd
	. head
	. sortOn (\(penalty, (pre, mid, suf)) -> (penalty + length (pre++mid++suf), mid))
	-- penalty: non-scientific notation is a bit nicer when it's possible, even
	-- to the point that we might want to choose it even when it's longer
	. (\v -> [(0, showDigitsFlat v), (1, showDigitsScientific v)])
	. dropZeros
	. sigFigs

sigFigs :: Double -> (Int, Int)
sigFigs 0 = (0, 0)
sigFigs n = (round (n/scale), magnitude) where
	-- 0.01 is a fudge factor for slightly-too-low log calculations
	magnitude = floor (logBase 10 (abs n) + 0.01) - 2
	scale = 10^^magnitude

dropZeros :: (Int, Int) -> (Int, Int)
dropZeros v@(mantissa, exponent) = case mantissa `quotRem` 10 of
	(0, 0) -> v
	(mantissa', 0) -> dropZeros (mantissa', exponent+1)
	_ -> v

showDigitsFlat :: (Int, Int) -> (String, String, String)
showDigitsFlat (mantissa, exponent)
	| exponent >= 0 = (show mantissa ++ replicate exponent '0', "", "")
	| otherwise = go mantissa exponent ""
	where
	go 0 e suf = (['-' | mantissa < 0] ++ "0", ".", replicate (-e) '0' ++ suf) -- fast path
	go m 0 suf = (show m, ".", suf)
	go m e suf = let (q, r) = m `quotRem` 10 in go q (e+1) (intToDigit (abs r) : suf)

showDigitsScientific :: (Int, Int) -> (String, String, String)
showDigitsScientific (mantissa, exponent) = go mantissa exponent "" where
	go m e suf
		| abs m < 10 = (show m ++ ['.' | not (null suf)] ++ suf, "e", show e)
		| otherwise = let (q, r) = m `quotRem` 10 in go q (e+1) (intToDigit (abs r) : suf)

-- The panedPosition offered by the library seems to be implemented in some
-- roundabout way that doesn't let notifyProperty work right.
panedPosition' :: PanedClass self => Attr self Int
panedPosition' = newAttrFromIntProperty "position"

updateTimerLabel :: Context -> IO ()
updateTimerLabel ctx = postGUIAsync $ do
	status <- readMVar (ctxUITimerLabelStatus ctx)
	case status of
		RunningSince from -> go runningAttrs . (`diffTimeSpec` from) =<< getCurrentTimeSpec
		Stopped dur -> go (if dur == 0 then commonAttrs else stoppedAttrs) dur
	where
	commonAttrs = tail [undefined
		, AttrWeight { paWeight = WeightHeavy, paStart = setLater, paEnd = setLater }
		, AttrSize { paSize = 32, paStart = setLater, paEnd = setLater }
		, AttrFamily { paFamily = "FreeMono,Latin Modern Mono,Noto Sans Mono CJK JP,DejaVu Sans Mono", paStart = setLater, paEnd = setLater }
		]
	runningAttrs = commonAttrs ++ tail [undefined
		, AttrForeground { paColor = Color 0x1000 0x8000 0x0000, paStart = setLater, paEnd = setLater }
		]
	stoppedAttrs = commonAttrs ++ tail [undefined
		, AttrForeground { paColor = Color 0xb000 0x2800 0x3800, paStart = setLater, paEnd = setLater }
		]
	setLater = error "updateTimerLabel attempted to use an attribute without setting its range first. This is a bug."

	go attrs dur = do
		mag <- readIORef (ctxTimeMagnitude ctx)
		let (mag', text) = showDiffTimeSpec dur mag
		labelSetText (ctxUITimerLabel ctx) text
		labelSetAttributes (ctxUITimerLabel ctx) [attr { paStart = 0, paEnd = length text } | attr <- attrs]
		when (mag /= mag') $ do
			writeIORef (ctxTimeMagnitude ctx) mag'
			redrawAllIntervals ctx

updateGraph :: Context -> IO ()
updateGraph = postGUIAsync . widgetQueueDraw . ctxUIGraph

-- 2^63 microseconds is about 300k years, so even though this technically can't
-- represent all the possible TimeSpec differences, it's gonna be good enough
-- for this application.

-- TODO: Read and Show instances that put the decimal point in the right place
newtype DiffTimeSpec = DiffTimeSpec { getMicros :: Int64 }
	deriving (Bounded, Eq, Ord, DB.FromField, DB.ToField, NFData)

-- | @fromInteger 1@ is one second
instance Num DiffTimeSpec where
	DiffTimeSpec a + DiffTimeSpec b = DiffTimeSpec (a+b)
	DiffTimeSpec a - DiffTimeSpec b = DiffTimeSpec (a-b)
	DiffTimeSpec a * DiffTimeSpec b = DiffTimeSpec (fromInteger ((toInteger a * toInteger b + 500000) `div` 1000000))
	negate (DiffTimeSpec a) = DiffTimeSpec (negate a)
	abs (DiffTimeSpec a) = DiffTimeSpec (abs a)
	signum (DiffTimeSpec a) = DiffTimeSpec (1000000 * signum a)
	fromInteger n = DiffTimeSpec (fromInteger (1000000 * n))

instance Real DiffTimeSpec where
	toRational (DiffTimeSpec a) = toRational a / 1000000

instance Fractional DiffTimeSpec where
	DiffTimeSpec a / DiffTimeSpec b = DiffTimeSpec (fromInteger ((a'*1000000 + b' `div` 2) `div` b')) where
		a' = toInteger a
		b' = toInteger b
	recip (DiffTimeSpec a) = DiffTimeSpec (fromInteger ((1000000000000 + a' `div` 2) `div` a')) where
		a' = toInteger a
	fromRational n = DiffTimeSpec (round (n*1000000))

instance RealFrac DiffTimeSpec where
	properFraction (DiffTimeSpec a) = (fromIntegral q, DiffTimeSpec r) where
		(q, r) = a `quotRem` 1000000

instance Enum DiffTimeSpec where
	succ (DiffTimeSpec a) = if a > maxBound - 1000000
		then error $ "DiffTimeSpec.succ: bad argument " ++ show a
		else DiffTimeSpec (a+1000000)
	pred (DiffTimeSpec a) = if a < minBound + 1000000
		then error $ "DiffTimeSpec.pred: bad argument " ++ show a
		else DiffTimeSpec (a-1000000)

	toEnum = coerce (toEnum :: Int -> Int64)
	fromEnum = coerce (int64 fromEnum)

	enumFrom (DiffTimeSpec a) = coerce [a, a+1000000 ..]
	enumFromThen = coerce (int64 enumFromThen)
	enumFromTo (DiffTimeSpec a) (DiffTimeSpec b) = coerce [a, a+1000000 .. b]
	enumFromThenTo = coerce (int64 enumFromThenTo)

instance Show DiffTimeSpec where
	show (DiffTimeSpec a) = concat . tail $ [undefined
		, if a < 0 then "-" else ""
		, show (abs q)
		, "."
		, pad (show (abs r))
		] where
		(q, r) = a `quotRem` 1000000
		pad s = replicate (6-length s) '0' ++ s

instance Read DiffTimeSpec where
	readPrec = readNumber $ \case
		Number n -> maybe (fail "not a number") convertDTS $ numberToFixed 6 n
		_ -> fail "not a number"
		where
		convertDTS (secs, micros) = pure . DiffTimeSpec . fromInteger $
			secs*1000000 + signum secs*micros

{-# INLINE int64 #-}
int64 :: (Int64 -> a) -> Int64 -> a
int64 f = f

diffTimeSpec :: TimeSpec -> TimeSpec -> DiffTimeSpec
diffTimeSpec (TimeSpec s ns) (TimeSpec s' ns') = DiffTimeSpec $
	1000000*(s-s') + (ns-ns'+500)`div`1000

addTimeSpec :: TimeSpec -> DiffTimeSpec -> TimeSpec
addTimeSpec ts (DiffTimeSpec micros) = ts + fromIntegral (1000*micros)

showDiffTimeSpec :: DiffTimeSpec -> TimeMagnitude -> (TimeMagnitude, String)
showDiffTimeSpec = showNominalDiffTime . realToFrac

showNominalDiffTime :: NominalDiffTime -> TimeMagnitude -> (TimeMagnitude, String)
showNominalDiffTime dur mag_ = (mag, formatTime defaultTimeLocale (formatString mag) dur) where
	mag = max mag_ (timeMagnitude dur)

timeMagnitude :: NominalDiffTime -> TimeMagnitude
timeMagnitude t
	| t < 60 = Seconds
	| t < 60*60 = Minutes
	| t < 24*60*60 = Hours
	| otherwise = Days (go (10*24*60*60) 1)
	where
	go t' d
		| t < t' = d
		-- technically could overflow, but like... 10^255 days is a really lot of days
		| otherwise = go (10*t') (1+d)

formatString :: TimeMagnitude -> String
formatString Seconds = "%03ES"
formatString Minutes = "%02M:" ++ formatString Seconds
formatString Hours = "%02H:" ++ formatString Minutes
formatString (Days n) = "%0" ++ show n ++ "dd " ++ formatString Hours

-- TODO
redrawAllIntervals :: Context -> IO ()
redrawAllIntervals _ = pure ()

getCurrentTimeSpec :: IO TimeSpec
getCurrentTimeSpec = getTime MonotonicRaw

stdinThread :: Context -> IO loop
stdinThread (ctxInput -> chan) = forever $ do
	line <- T.getLine
	now <- getCurrentTimeSpec
	writeChan chan (now, line)

data Event = Event
	{ eFrame :: Maybe Integer
	, eMicrosecond :: DiffTimeSpec
	, eState :: Text
	} deriving (Eq, Ord, Read, Show)

data Command = StateChange Event | Stop DiffTimeSpec deriving (Eq, Ord, Read, Show)

stop :: Text
stop = "STOP"

-- TODO: catch EOF and do something sensible (probably just quit?)
-- TODO: catch DB connection errors
parserThread :: Context -> IO loop
parserThread ctx = DB.connectPostgreSQL (db (ctxConfig ctx)) >>= go where
	go conn = case pFPS (ctxProfile ctx) of
		Just{} -> idling
		Nothing -> noFramesRunning Nothing Nothing
		where
		getEvent = do
			(now, t) <- readChan (ctxInput ctx)
			let (frame_, preState) = T.break (' '==) t
			    state = T.drop 1 preState
			case (T.signed T.decimal frame_, T.null preState) of
				(Right (frame, T.null -> True), False)
					| state == stop -> pure $ Left (Just now)
					| ctxValidState ctx state -> pure $ Right (frame, now, state)
					| otherwise -> Left Nothing <$ writeChan (ctxErrors ctx)
						(printf "Ignoring unknown state %s at frame %d, time %s" (show state) frame (show now))
				_ -> Left Nothing <$ writeChan (ctxErrors ctx) ("Ignoring malformed state change " ++ show t)

		idling = getEvent >>= \case
			Right (frame, now, state) -> do
				broadcast now Event { eFrame = Just 0, eMicrosecond = 0, eState = state }
					Nothing
					(running (negate frame) frame)
					stopping
			Left (Just now) -> warnIgnoreStop >> idling
			Left Nothing -> idling

		running dFrame frame runStart splitKey = getEvent >>= \case
			Right (frame', now, state)
				| frame' >= frame -> do
					broadcast runStart
						Event
							{ eFrame = Just (dFrame+frame')
							, eMicrosecond = diffTimeSpec now runStart
							, eState = state
							}
						(Just splitKey)
						(running dFrame frame')
						stopping
				| otherwise -> do
					let ddFrame = roundUpToPowerOf2 (max frame (if signed then -1-frame' else frame))
					    signed = frame' < 0
					    dFrame' = dFrame + if signed then shiftL ddFrame 1 else ddFrame
					writeChan (ctxErrors ctx) $ printf
						"New frame %d is smaller than old frame %d. Assuming this is due to %s overflow at %d."
						frame'
						frame
						(if signed then string "signed" else string "unsigned")
						ddFrame
					broadcast runStart
						Event
							{ eFrame = Just (dFrame'+frame')
							, eMicrosecond = diffTimeSpec now runStart
							, eState = state
							}
						(Just splitKey)
						(running dFrame' frame')
						stopping
			Left (Just now) -> stopTimer (diffTimeSpec now runStart) >> idling
			Left Nothing -> running dFrame frame runStart splitKey

		stopping = getEvent >>= \case
			Left (Just now) -> idling
			_ -> stopping

		-- invariant: arguments are both Just or both Nothing
		noFramesRunning runStartM splitKey = do
			(now, state) <- readChan (ctxInput ctx)
			let runStart = fromMaybe now runStartM
			case (state == stop, ctxValidState ctx state) of
				(True, _) -> do
					maybe warnIgnoreStop (stopTimer . diffTimeSpec now) runStartM
					noFramesRunning Nothing Nothing
				(_, True) -> broadcast runStart
					Event
						{ eFrame = Nothing
						, eMicrosecond = diffTimeSpec now runStart
						, eState = state
						}
					splitKey
					(\rs sk -> noFramesRunning (Just rs) (Just sk))
					noFramesStopping
				_ -> do
					writeChan (ctxErrors ctx)
						(printf "Ignoring unknown state %s at time %s" (show state) (show now))
					noFramesRunning runStartM splitKey

		noFramesStopping = do
			(now, state) <- readChan (ctxInput ctx)
			if state == stop
			then noFramesRunning Nothing Nothing
			else noFramesStopping

		broadcast runStart event splitKey continue won = do
			-- tell the database
			(runID, seqNo) <- case splitKey of
				Just (runID, seqNo) -> pure (runID, seqNo+1)
				Nothing -> do
					[DB.Only runID] <- DB.query conn
						"insert into run (game, fps, started) values (?, ?, now()) returning id"
						(pGame (ctxProfile ctx), pFPS (ctxProfile ctx))
					pure (runID :: ID, 0 :: ID)
			DB.execute conn
				"insert into split (run, seq_no, state, microsecond, frame) values (?, ?, ?, ?, ?)"
				(runID, seqNo, eState event, eMicrosecond event, eFrame event)

			-- tell the UI
			atomically $ do
				sr <- readTVar (ctxStateRange ctx)
				case srInsert (pSortOrder (ctxProfile ctx)) (eState event) sr of
					(Any True, sr') -> writeTVar (ctxStateRange ctx) sr'
					_ -> pure ()
			status <- takeMVar (ctxUITimerLabelStatus ctx)
			putMVar (ctxUITimerLabelStatus ctx) $ case status of
				RunningSince{} -> status
				_ -> RunningSince runStart
			postGUIAsync $ do
				case status of
					RunningSince{} -> pure ()
					_ -> treeStoreClear (ctxEventStore ctx)
				logEvent ctx event

			-- tell the modules
			writeChan (ctxModuleInput ctx) (StateChange event)

			-- tell the parser thread
			if eState event == pTarget (ctxProfile ctx)
			then stopTimer (eMicrosecond event) >> won
			else continue runStart (runID, seqNo)

		stopTimer dur = do
			-- nothing interesting to tell the database
			-- tell the UI
			status <- takeMVar (ctxUITimerLabelStatus ctx)
			putMVar (ctxUITimerLabelStatus ctx) $ case status of
				RunningSince{} -> Stopped dur
				_ -> status
			-- tell the modules
			writeChan (ctxModuleInput ctx) (Stop dur)
			-- the parser thread already knows

		warnIgnoreStop = writeChan (ctxErrors ctx) "Ignoring redundant STOP"

ctxValidState :: Context -> Text -> Bool
ctxValidState ctx s = maybe True (O.member s) (ctxAllStates ctx)

roundUpToPowerOf2 :: Integer -> Integer
roundUpToPowerOf2 n
	| n <= 1 = 1
	| otherwise = go 1 2
	where
	go exp pow
		| n <= pow = head [bit (e+1) | e <- [exp, exp-1 .. exp `rem` 2], testBit n e]
		| otherwise = go (2*exp) (pow*pow)

logEvent :: Context -> Event -> IO ()
logEvent ctx e = do
	n <- treeModelIterNChildren store Nothing
	case pMajorStates (ctxProfile ctx) of
		Just major | eState e `S.member` major -> do
			es <- removeMinorEvents major [] (n-1)
			n' <- treeModelIterNChildren store Nothing
			treeStoreInsertTree store [] n' $ Node e [Node e' [] | e' <- es]
		_ -> treeStoreInsert store [] n e
	where
	store = ctxEventStore ctx
	removeMinorEvents major minor n
		| n < 0 = pure minor
		| otherwise = do
			e' <- treeStoreGetValue store [n]
			if eState e' `S.member` major
			then pure minor
			else do
				treeStoreRemove store [n]
				removeMinorEvents major (e':minor) (n-1)

class Ord a => IsText a where
	fromText :: Text -> a
	toText :: a -> Text

instance IsText Text where
	fromText = id
	toText = id

instance IsText HumanOrder where
	fromText = humanOrder
	toText = unHumanOrder

instance IsText a => IsText (Down a) where
	fromText = Down . fromText
	toText (Down a) = toText a

data StateCache where
	Ordered :: OSet Text -> StateCache
	Sorted :: IsText a => Set a -> StateCache
	Uninitialized :: StateCache

stateCache :: Context -> [Text] -> StateCache
stateCache ctx ss = case pSortOrder (ctxProfile ctx) of
	Ascending -> Sorted . S.fromList . map humanOrder $ ss
	Descending -> Sorted . S.fromList . map (Down . humanOrder) $ ss
	AscendingOn o -> Ordered o

data StateRange = StateRange
	{ srStateCache :: StateCache
	, srMin :: HumanOrder
	, srMax :: HumanOrder
	}

srMinT, srMaxT :: StateRange -> Text
srMinT = toText . srMin
srMaxT = toText . srMax

srInsert :: SortOrder -> Text -> StateRange -> (Any, StateRange)
srInsert so t_ sr = pure StateRange
	<*> case srStateCache sr of
		Sorted ts -> (Any (S.notMember t' ts), Sorted (S.insert t' ts)) where t' = fromText t_
		_ -> (Any False, srStateCache sr) -- slightly optimistic... if it's Ordered, assumes t appears in the OSet
	<*> (Any (soLt so t (srMin sr)), soMin so t (srMin sr))
	<*> (Any (soLt so (srMax sr) t), soMax so t (srMax sr))
	where t = humanOrder t_

ctxStates :: Context -> IO [Text]
ctxStates ctx = do
	sr <- readTVarIO (ctxStateRange ctx)
	case srStateCache sr of
		Ordered ss -> case (O.findIndex (srMinT sr) ss, O.findIndex (srMaxT sr) ss) of
			(Just iMin, Just iMax) -> pure [fromJust (ss `O.elemAt` i) | i <- [iMin .. iMax]]
			_ -> failedRange sr $ printf "StateRange bounds %s-%s not found in StateCache %s"
				(show (srMinT sr))
				(show (srMaxT sr))
				(show ss)
		Sorted ss -> case (S.lookupIndex eMin ss, S.lookupIndex eMax ss) of
			(Just iMin, Just iMax) -> pure
				. map toText
				. S.toAscList
				. S.take (iMax-iMin+1)
				. S.drop iMin
				$ ss
			_ -> failedRange sr $ printf "StateRange bounds %s-%s not found in StateCache %s"
				(show (srMinT sr))
				(show (srMaxT sr))
				(show (S.map toText ss))
			where
			eMin = fromText (srMinT sr)
			eMax = fromText (srMaxT sr)
		Uninitialized -> do
			mCache <- initializeStateCache ctx
			cache <- case mCache of
				Nothing -> stateCache ctx <$>
					failedRange sr "Could not contact database to initialize state cache"
				Just cache -> pure cache
			atomically $ do
				sr' <- readTVar (ctxStateRange ctx)
				writeTVar (ctxStateRange ctx) (sr' { srStateCache = cache })
			ctxStates ctx
	where
	failedRange sr err = do
		writeChan (ctxErrors ctx) err
		pure $ [srMinT sr | srMin sr /= srMax sr] ++ [srMaxT sr]

initializeStateCache :: Context -> IO (Maybe StateCache)
initializeStateCache ctx = case pSortOrder (ctxProfile ctx) of
	AscendingOn ss -> pure (Just (Ordered ss))
	Ascending -> fetchFromDB
	Descending -> fetchFromDB
	where
	fetchFromDB = do
		mConn <- try (DB.connectPostgreSQL (db (ctxConfig ctx)))
		case mConn of
			Left err -> pure (const Nothing (DB.sqlState err {- type-checking hint -}))
			Right conn -> do
				ss <- DB.query conn
					"select distinct state from run join split on run.id = split.run where run.game = ?"
					(DB.Only (pGame (ctxProfile ctx)))
				DB.close conn
				pure . Just . stateCache ctx . fromOnlys $ ss

fromOnlys :: [DB.Only a] -> [a]
fromOnlys = coerce

heartbeatThread :: Context -> IO loop
heartbeatThread ctx = forever $ do
	updateTimerLabel ctx
	threadDelay (1000000`div`30) -- update at 30fps...ish

data Dependent
	= State Text
	| Time DiffTimeSpec
	| LogScale Double
	deriving (Eq, Ord, Read, Show)

instance NFData TimeSpec where
	rnf (TimeSpec secs nsecs) = rnf secs `seq` rnf nsecs

instance NFData Dependent where
	rnf (State s) = rnf s
	rnf (Time t) = rnf t
	rnf (LogScale n) = rnf n

data ModulePoint = ModulePoint
	{ x :: DiffTimeSpec
	, y :: Dependent
	} deriving (Eq, Ord, Read, Show)

instance NFData ModulePoint where
	rnf (ModulePoint xVal yVal) = rnf xVal `seq` rnf yVal

-- | Common case: we've just computed an offset to add to an event's time.
dtDependent :: Event -> DiffTimeSpec -> Dependent
dtDependent e dt = Time (eMicrosecond e + dt)

-- | Common case: we've just computed an offset to add to an event's time.
dtPoint :: Event -> DiffTimeSpec -> ModulePoint
dtPoint Event { eMicrosecond = micro } dt = ModulePoint micro (Time (micro + dt))

data Module = Module
	{ mLabel :: String
	, mLaunch :: Context -> Chan Command -> TVar [ModulePoint] -> IO Void
	}

-- | If your module only ever adds points, and only needs to see the latest
-- event to know which points it wants to add, you can use this wrapper to do
-- some of the bookkeeping for you.
appendOnlyModule :: String -> (Context -> IO a) -> (a -> Command -> IO [ModulePoint]) -> Module
appendOnlyModule label initialize newPoints = Module label $ \ctx i o -> do
	a <- initialize ctx
	let go pts = do
	    	me <- readChan i
	    	dpts <- newPoints a me
	    	let pts' = dpts ++ pts
	    	when (not (null dpts)) $ do
	    		atomically (writeTVar o pts')
	    		updateGraph ctx
	    	go $ case me of
	    		Stop{} -> []
	    		StateChange{} -> pts'
	go []

-- | If you meet the requirements of 'appendOnlyModule', and additionally your
-- new points always occur at the same time as the most recent event, you can
-- use this to add the x-coordinate for you.
synchronousOnlyModule :: String -> (Context -> IO a) -> (a -> Command -> IO [Dependent]) -> Module
synchronousOnlyModule label initialize newDependents
	= appendOnlyModule label initialize $ \a me ->
		map (ModulePoint (meMicrosecond me)) <$> newDependents a me
	where
	meMicrosecond (StateChange e) = eMicrosecond e
	meMicrosecond (Stop t) = t

stateProgressModule :: Module
stateProgressModule = synchronousOnlyModule "state progress" def
	$ \ ~() me -> pure [State (eState e) | StateChange e <- [me]]

pbModule :: Module
pbModule = synchronousOnlyModule "PB" initialize addPBRun
	where
	initialize ctx = do
		pbRef <- newIORef Nothing
		eConn <- try (DB.connectPostgreSQL (db (ctxConfig ctx)))
		case eConn of
			Left err -> writeChan (ctxErrors ctx) $ printf
				"Error connecting to database in pbModule: %s"
				(displayException @DB.SqlError err)
			Right conn -> pure ()
		pure (pbRef, eConn, pGame (ctxProfile ctx), pTarget (ctxProfile ctx))

	addPBRun (_, Left err, _, _) _ = pure []
	addPBRun (pbRef, _, _, _) Stop{} = [] <$ writeIORef pbRef Nothing
	addPBRun a@(pbRef, Right conn, game, tgt) me@(StateChange e) = do
		mPB <- readIORef pbRef
		case mPB of
			Just pb -> pure $ case M.lookup (eState e) pb of
				Nothing -> []
				Just t -> [dtDependent e ((pb M.! tgt) - t)]
			Nothing -> do
				runs <- DB.query @_ @(ID, DiffTimeSpec) conn findPBRunQuery (eState e, tgt, game)
				pb <- case runs of
					[] -> pure M.empty
					(runID, _):_ -> M.fromList <$> DB.query conn
						"select state, min(microsecond) from split where run = '?' group by state"
						(DB.Only runID)
				writeIORef pbRef (Just pb)
				addPBRun a me

	findPBRunQuery = "\
		\select b_run, e_microsecond - b_microsecond as duration \
		\from \
			\(\
				\(\
					\select run as b_run, microsecond as b_microsecond, seq_no as b_seq_no \
					\from split \
					\where state = ? \
				\) as beginning \
				\join \
				\( \
					\select run as e_run, microsecond as e_microsecond, seq_no as e_seq_no \
					\from split \
					\where state = ? \
				\) as ending \
				\on b_run = e_run and b_seq_no < e_seq_no \
			\) as interval \
			\join \
			\run \
			\on interval.b_run = run.id \
		\where run.game = ? \
		\order by duration, b_run \
		\limit 1"

data Split = Split
	{ run :: ID
	, seqNo :: Int32
	, state :: Text
	, microsecond :: DiffTimeSpec
	, frame :: Maybe Int32
	} deriving (Eq, Ord, Read, Show)
	-- BEWARE: some functions assume that the Ord instance compares on run
	-- first, then seqNo, then other stuff

instance DB.FromRow Split where
	fromRow = pure Split
		<*> DB.field
		<*> DB.field
		<*> DB.field
		<*> DB.field
		<*> DB.field

allSplits :: Context -> Connection -> IO [Split]
allSplits (ctxProfile -> p) conn = do
	ids <- DB.query conn "select id from run where game = ?" (DB.Only (pGame p))
	DB.query conn "select run, seq_no, state, microsecond, frame from split where run in ?"
		. DB.Only
		. DB.In
		. fromOnlys @ID
		$ ids

data Segment = Segment
	{ endState :: Text
	, duration :: DiffTimeSpec
	, frames :: Maybe Int32
	} deriving (Eq, Ord, Read, Show)

finishableSegments :: Context -> [Split] -> Map Text [Segment]
finishableSegments ctx splits = id
	. M.fromListWith (++)
	. concat
	. ap (zipWith mkSegment) tail
	$ sorted
	where
	sorted = sort splits
	finishable = unsafeFinishableStates ctx sorted
	mkSegment split split' =
		[(state split, [Segment
			{ endState = state split'
			, duration = microsecond split' - microsecond split
			, frames = liftA2 (-) (frame split') (frame split)
			}])
		| run split == run split'
		, seqNo split + 1 == seqNo split'
		, state split `S.member` finishable
		, state split' `S.member` finishable
		]

-- unsafe because it assumes the provided split list is already sorted
unsafeFinishableStates :: Context -> [Split] -> Set Text
unsafeFinishableStates (ctxProfile -> p) = id
	. restrict
	. dfs (pTarget p)
	. M.fromListWith (++)
	. concat
	. ap (zipWith predecessor) tail
	where
	-- paranoia: what if there are two profiles with the same game name? (but
	-- not quite paranoid enough to deal with two profiles with the same game
	-- name and shared states. at some point you finally have to give in to
	-- GIGO)
	restrict ss = case soAllStates (pSortOrder p) of
		Just ss' -> S.intersection (O.toSet ss') ss
		Nothing -> ss

	predecessor s s' =
		[(state s', [state s]) | run s == run s' && seqNo s + 1 == seqNo s']

dfs :: Ord a => a -> Map a [a] -> Set a
dfs root neighbors = go root (S.singleton root) where
	go s seen = case M.lookup s neighbors of
		Nothing -> seen
		Just (S.fromList -> ss) -> foldr go (ss `S.union` seen) (ss S.\\ seen)

-- This produces the expected (in the statistics sense of the term) run time
-- from all source states that can reach the target to the target. The model
-- used here is that if you are currently in state S0, then the next state you
-- arrive at S1 and the time it takes to get there t are sampled IID from some
-- (unknown) distribution.
--
-- Suppose for a moment that we *did* know that distribution for each state. Then
--
-- E[T → T] = 0
--
-- E⎡S  → T⎤ = ∑ p  * ⎛t   + E[S  → T]⎞  	whenever S  ≠ T
--  ⎣ i    ⎦   j  ij  ⎝ ij      j     ⎠  	          i
--
-- where T is the target state, S  ranges over states that can reach T (as does
--                               i
--
-- S ⎞, p   is the probability of transitioning to state S  given that you are
--  j⎠   ij                                               j
--
-- in state S  right now, and t   is the expected duration of a transition from
--           i                 ij
--
-- S  to S .
--  i     j
--
-- Now in the case where we do *not* know the distribution for each state, we
-- can approximate it by the uniform distribution over transition/duration
-- pairs from previous runs. This gives us estimates of p   and t   and a
--                                                       ij      ij
-- collection of linear equations with E⎡S  → T⎤ as the variables. We can
--                                      ⎣ i    ⎦
-- estimate these expectations by solving the system of linear equations.
expectedRunTimes :: Context -> Connection -> IO (Map Text DiffTimeSpec)
expectedRunTimes ctx conn = do
	splits <- allSplits ctx conn
	let target = pTarget (ctxProfile ctx)
	    stats = summarize <$> finishableSegments ctx splits
	    ss = S.insert target (M.keysSet stats)
	    nonTargets = S.delete target ss -- N.B. (S.delete k . S.insert k) is not necessarily id
	    -- this does all the addition in the world of exact integers, then at
	    -- the last second converts to Double; this avoids rounding issues to
	    -- the extent possible (at the unlikely cost of overflow issues)
	    summarize segs = (\(n, dur) -> (n, realToFrac dur)) <$> M.fromListWith pointwiseAddition
	    	[(endState seg, (1, duration seg)) | seg <- segs]
	    pointwiseAddition (n, dur) (n', dur') = (n+n', dur+dur')
	    outEdgeCounts = sum . fmap fst <$> stats
	    nonTargetsList = S.toList nonTargets
	    transitionMatrix = Matrix.matrix (S.size nonTargets)
	    	[ M.findWithDefault 0 to outEdges / outEdgeCount
	    	| from <- nonTargetsList
	    	, let outEdges = fst <$> M.findWithDefault M.empty from stats
	    	      outEdgeCount = max 1 (M.findWithDefault 1 from outEdgeCounts)
	    	, to <- nonTargetsList
	    	]
	    edgeTimes = Matrix.vector
	    	[ sum
	    		[ M.findWithDefault 0 to outEdges / outEdgeCount
	    		| to <- S.toList ss
	    		]
	    	| from <- nonTargetsList
	    	, let outEdges = snd <$> M.findWithDefault M.empty from stats
	    	      outEdgeCount = max 1 (M.findWithDefault 1 from outEdgeCounts)
	    	]
	when (M.keysSet stats /= nonTargets) . writeChan (ctxErrors ctx) $ printf
		"Some finishable states didn't have any edges to other finishable states or something? Weird. (nonTargets, stats) = %s"
		(show (nonTargets, stats))
	let expectedTimes = (Matrix.ident (S.size nonTargets) - transitionMatrix) Matrix.<\> edgeTimes
	pure
		. M.insert target 0
		. M.fromList
		. zipWith (\s t -> (s, realToFrac t)) nonTargetsList
		$ Matrix.toList expectedTimes

expectedModule :: Module
expectedModule = synchronousOnlyModule "expected" initialize handleEvent where
	initialize ctx = do
		conn <- DB.connectPostgreSQL (db (ctxConfig ctx))
		expectedsRef <- newIORef Nothing
		pure (ctx, conn, expectedsRef)

	handleEvent (ctx, conn, expectedsRef) e = case e of
		Stop{} -> [] <$ writeIORef expectedsRef Nothing
		StateChange e -> do
			expectedsMaybe <- readIORef expectedsRef
			expecteds <- case expectedsMaybe of
				Just expecteds -> pure expecteds
				Nothing -> do
					expecteds <- expectedRunTimes ctx conn
					writeIORef expectedsRef (Just expecteds)
					pure expecteds
			pure . map (dtDependent e) . toList
				$ M.lookup (eState e) expecteds

type Runs = Map Text (Multiset DiffTimeSpec)

runGenerationThread :: Context -> Chan Command -> IO loop
runGenerationThread ctx cmds = do
	conn <- DB.connectPostgreSQL (db (ctxConfig ctx))
	waiting conn
	where
	runTVar = ctxRandomRuns ctx
	target = pTarget (ctxProfile ctx)
	maxRunCount = 5000 -- TODO: configurable

	waiting conn = do
		cmd <- readChan cmds
		case cmd of
			Stop{} -> waiting conn
			StateChange e -> do
				atomically $ modifyTVar runTVar (\(epoch, _) -> (epoch+1, M.empty))
				segs <- finishableSegments ctx <$> allSplits ctx conn
				generating conn segs (eState e)

	generating conn segs state = do
		(_, runs) <- readTVarIO runTVar
		let remainingRunCount = maxRunCount - if state `M.member` segs
		    	then fromIntegral (MS.size (M.findWithDefault MS.empty state runs))
		    	else maxRunCount
		replicateM_ remainingRunCount $ do
			events <- randomRun segs target state
			case events of
				(s,_):_ | s == target -> atomically . modifyTVar' runTVar $
					\(epoch, runs) -> (,) (epoch+1) $! addRun events runs
				_ -> pure ()
		cmd <- readChan cmds
		case cmd of
			Stop{} -> waiting conn
			StateChange e -> generating conn segs (eState e)

randomRun :: Map Text [Segment] -> Text -> Text -> IO [(Text, DiffTimeSpec)]
randomRun segMap_ tgt = go 0 [] where
	segMap = V.fromList <$> segMap_
	go t prev s
		| s == tgt = pure prev'
		| otherwise = case M.lookup s segMap of
			Just segs -> do
				seg <- (segs V.!) <$> randomRIO (0, V.length segs - 1)
				go (t+duration seg) prev' (endState seg)
			Nothing -> pure prev'
		where prev' = (s,t):prev

addRun :: [(Text, DiffTimeSpec)] -> Runs -> Runs
addRun [] runs = runs
addRun es@((_, t):_) runs = M.S.unionWith MS.union newRuns runs where
	-- const keeps the last (earliest) one in the list if we hit a given state
	-- multiple times. If we were paranoid, we could use max instead. We don't
	-- want to keep them both because they are correlated -- and so not IID
	-- samples.
	newRuns = M.fromListWith const
		[(state, MS.singleton (t-t')) | (state, t') <- es]

-- | Simple modules that want access to random runs generated by the
-- 'runGenerationThread' can use this to do the bulk of the bookkeeping for
-- them. They will automatically get incremental updating if generation takes a
-- long time.
withRandomRuns :: String ->
	-- | Initialize some custom data on module launch
	(Context -> IO a) ->
	-- | Initialize some custom data on the first event from a run
	(Context -> a -> Event -> IO b) ->
	-- | Generate some points, given the most up-to-date random runs
	(Context -> a -> b -> Runs -> Event -> IO [ModulePoint]) ->
	Module
withRandomRuns s initializeLaunch initializeRun generate = Module s $ \ctx i_ o -> do
	(epoch, _) <- readTVarIO (ctxRandomRuns ctx)

	i <- newChan
	forkIO . forever $ readChan i_ >>= writeChan i . Right
	forkIO $ awaitEpochChanges (ctxRandomRuns ctx) i epoch

	a <- initializeLaunch ctx
	waiting ctx i o a
	where
	awaitEpochChanges i_ i epoch = do
		(epoch', runs) <- atomically $ do
			v@(epoch', runs) <- readTVar i_
			when (epoch == epoch') retry
			pure v
		writeChan i (Left runs)
		awaitEpochChanges i_ i epoch'

	waiting ctx i o a = do
		modification <- readChan i
		case modification of
			Left{} -> waiting ctx i o a
			Right Stop{} -> waiting ctx i o a
			Right (StateChange e) -> do
				b <- initializeRun ctx a e
				running ctx i o a b M.empty [e]

	running ctx i o a b runs events = do
		modification <- readChan i
		case modification of
			Left runs' -> redraw ctx i o a b runs' events
			Right (StateChange event) -> redraw ctx i o a b runs (event:events)
			Right Stop{} -> waiting ctx i o a

	redraw ctx i o a b runs events = do
		pts <- concat <$> traverse (generate ctx a b runs) events
		pts `deepseq` atomically (writeTVar o pts)
		updateGraph ctx
		running ctx i o a b runs events

percentileModule :: Double -> Module
percentileModule p_ = withRandomRuns (pString ++ " percentile")
	(\_ -> pure ())
	(\_ _ _ -> pure ())
	$ \_ _ _ runs event -> pure . toList $ do
		dts <- M.lookup (eState event) runs
		dt <- dts MS.!? round ((1-p) * fromIntegral (MS.size dts - 1))
		pure $ dtPoint event dt
	where
	p = min 1 (max 0 p_)

	pString = if fromIntegral pBigInt == pBig
		then show pBigInt ++ ordinalSuffix pBigInt
		else show pBig ++ "th"
		where
		pBig = 100*p
		pBigInt = round pBig
	ordinalSuffix 1 = "st"
	ordinalSuffix 2 = "nd"
	ordinalSuffix 3 = "rd"
	ordinalSuffix _ = "th"

pbChanceModule :: Module
pbChanceModule = withRandomRuns "attempts to PB"
	(DB.connectPostgreSQL . db . ctxConfig)
	getPBInfo
	(\_ _ -> computeAttempts)
	where
	getPBInfo (ctxProfile -> p) conn e = do
		pbLengths <- DB.query conn
			"select ending.microsecond - beginning.microsecond as duration \
			\from (select id from run where game = ?) as this_game \
			\join (select run, seq_no, microsecond from split where state = ?) as beginning \
			\on this_game.id = beginning.run \
			\join (select run, seq_no, microsecond from split where state = ?) as ending \
			\on this_game.id = ending.run and beginning.seq_no <= ending.seq_no \
			\order by duration \
			\limit 1"
			(pGame p, eState e, pTarget p)
		pure (fromOnlys pbLengths)

	computeAttempts pbLengths runs event = pure $ do
		pbLength <- pbLengths
		Just dts <- [M.lookup (eState event) runs]
		let nLT = MS.countLT (pbLength - eMicrosecond event) dts
		guard (eMicrosecond event < pbLength)
		guard (nLT > 0)
		pure ModulePoint
			{ x = eMicrosecond event
			, y = LogScale $ fromIntegral (MS.size dts) / fromIntegral nLT
			}

-- TODO: make this configurable
allModules :: [Module]
allModules = [stateProgressModule, percentileModule 0.1, percentileModule 0.9, expectedModule, pbModule, pbChanceModule]

moduleThread :: Context -> IO loop
moduleThread ctx = do
	(chans, outs) <- fmap unzip . for allModules $ \m -> do
		chan <- newChan
		tvar <- newTVarIO []
		forkIO (() <$ mLaunch m ctx chan tvar)
		pure (chan, (mLabel m, tvar))
	atomically $ writeTVar (ctxModuleOutputs ctx) outs
	-- TODO: when modules are configurable, only launch this thread when it's
	-- needed
	chan <- newChan
	forkIO (runGenerationThread ctx chan)
	forever $ do
		mEvent <- readChan (ctxModuleInput ctx)
		for_ (chan:chans) $ \chan -> writeChan chan mEvent

-- TODO: should we have an MVar or something so the main thread can wait till
-- this finishes?
preferencesThread :: Context -> IO loop
preferencesThread ctx = do
	initialPreferences <- loadPreferences (argProfile (ctxArguments ctx))
	go $ fromMaybe impossiblePrefs initialPreferences
	where
	go prefs = do
		prefs' <- debounceReadTChanIO (ctxPreferences ctx)
		when (prefs /= prefs') (savePreferences ctx prefs')
		go prefs'

	impossiblePrefs = Preferences
		{ windowRectangle = Rectangle (-1) (-1) (-1) (-1)
		, splitHeight = -1
		, graphWidth = -1
		}

debounceReadTChanIO :: TChan a -> IO a
debounceReadTChanIO chan = atomically (readTChan chan) >>= go where
	go a = do
		threadDelay 5000000 -- 5-10 seconds after the last mouse movement ought to be soon enough
		(continue, a') <- atomically (emptyTChan chan a)
		(if continue then go else pure) a'

emptyTChan :: TChan a -> a -> STM (Bool, a)
emptyTChan chan = go False where
	go haveRead res = tryReadTChan chan >>= \case
		Nothing -> pure (haveRead, res)
		Just res' -> go True res'

savePreferences :: Context -> Preferences -> IO ()
savePreferences ctx prefs = do
	dir <- preferencesDir
	let fp = dir </> argProfile (ctxArguments ctx)
	    write = do
	    	createDirectoryIfMissing True dir
	    	writeFile fp (preferencesToString prefs)

	    complain :: IOException -> IO ()
	    complain err = do
	    	writeChan (ctxErrors ctx) $ printf
	    		"Error while attempting to write preferences to %s (will retry at next change): %s"
	    		fp (displayException err)
	catch write complain

preferencesToString :: Preferences -> String
preferencesToString = flip shows "\n" . C.pretty . preferencesToValue where
	preferencesToValue (Preferences (Rectangle x y w h) sh gw) = C.Sections ()
		[ C.Section () "window" $ C.Sections ()
			[ intSection "x" x
			, intSection "y" y
			, intSection "width" w
			, intSection "height" h
			]
		, C.Section () "splits" $ C.Sections () [intSection "height" sh]
		, C.Section () "graph" $ C.Sections () [intSection "width" gw]
		]
	intSection nm = C.Section () nm . C.Number () . C.integerToNumber . toInteger


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

-- Created September 18 2015

-- TODO | -
--        -

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC Pragmas
--------------------------------------------------------------------------------------------------------------------------------------------

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module BattleHack.Window where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Control.Monad      (forM_, when)
import Control.Concurrent (threadDelay, forkIO)
import Text.Printf
import Data.IORef
import Data.Complex
import Data.StateVar
import qualified Data.Map  as M

import qualified Graphics.Rendering.Cairo as Cairo
import           Graphics.UI.Gtk          as Gtk
import           Graphics.UI.Gtk          (AttrOp(..), on)

-- Internal module imports
import           BattleHack.Types
import qualified BattleHack.Render  as Render
import qualified BattleHack.Events  as Events
import qualified BattleHack.Audio   as Audio

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------
-- |
-- TODO: Return canvas and frame too (?)
-- TODO: Allow for configurations
create :: Vector -> IO (Window, DrawingArea)
create (winx:+winy) = do
  initGUI
  window <- windowNew
  frame  <- frameNew

  set window [windowTitle := "Chordially"]

  canvas <- drawingAreaNew
  containerAdd frame canvas
  set window [ containerChild := frame ]
  windowSetDefaultSize window (round winx) (round winy)
  windowSetIconFromFile window "assets/images/gclef.png"

  widgetAddEvents canvas [PointerMotionMask] -- MouseButton1Mask
  widgetShowAll window

  return (window, canvas)

-- | Register event listeners
-- TODO: Rename (?)
bindevents :: Window -> DrawingArea -> IORef AppState -> IO ()
bindevents window canvas stateref = do
  window `on` deleteEvent        $ Events.ondelete      stateref
  window `on` motionNotifyEvent  $ Events.onmousemotion stateref

  window `on` buttonPressEvent   $ Events.onmousedown stateref
  window `on` buttonReleaseEvent $ Events.onmouseup   stateref

  window `on` keyPressEvent      $ Events.onkeydown stateref
  window `on` keyReleaseEvent    $ Events.onkeyup   stateref

  canvas `on` scrollEvent        $ Events.onwheelscrool stateref
  canvas `on` draw               $ Events.ondraw        stateref

  return ()


-- |
-- Module      : Occlusion.Events
-- 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.Events where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.IORef
import Data.Complex
import Data.Functor
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Set  as S
import Control.Lens
import Control.Monad (when, unless, forM, mapM)

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

import Occlusion.Types
import Occlusion.Lenses
import Occlusion.Vector
import qualified Occlusion.Behaviours as Behaviours
import qualified Occlusion.Render     as Render

--------------------------------------------------------------------------------------------------------------------------------------------
-- Event listeners
--------------------------------------------------------------------------------------------------------------------------------------------
-- |
onrender :: AppState -> Cairo.Render ()
onrender appstate = do
  Render.background appstate
  Render.scene (appstate^.scene)

-- |
-- TODO: Simulation speed
-- TODO: Factour out 'tick'
-- TODO: Use state monad
onanimate :: IORef AppState -> IO Bool
onanimate stateref = do
  --
  appstate <- readIORef stateref

  --
  widgetQueueDraw (appstate^.gui.canvas)
  modifyIORef stateref (animation.frame %~ (+1)) -- Increment frame count

  -- TODO: Refactor (cf. State, traverse, each)
  -- modifyIORef stateref $ \appstate -> forM [scene.player, scene.npcs.ix 0] $ \char -> Behaviours.run char
  modifyIORef stateref $ Behaviours.run (scene.player)
  modifyIORef stateref $ Behaviours.run (scene.npcs.nth 0)
  return True

-- |
onmousemoves :: IORef AppState -> EventM EMotion Bool
onmousemoves stateref = do
  p <- uncurry (:+) <$> eventCoordinates
  Cairo.liftIO $ do
    modifyIORef stateref (input.mouse .~ p)
  return False

-- |
onmousepressed :: IORef AppState -> EventM EButton Bool
onmousepressed stateref = do
  p <- uncurry (:+) <$> eventCoordinates
  Cairo.liftIO $ do
    modifyIORef stateref (input.click .~ Just p)
  return False

-- |
onmousereleased :: IORef AppState -> EventM EButton Bool
onmousereleased stateref = do
  p <- uncurry (:+) <$> eventCoordinates
  Cairo.liftIO $ do
    modifyIORef stateref (input.click .~ Nothing)
  return False

-- |
onkeypressed :: IORef AppState -> EventM EKey Bool
onkeypressed stateref = do
  key <- T.unpack <$> eventKeyName
  Cairo.liftIO $ do
    appstate <- readIORef stateref
    unless (S.member key $ appstate^.input.keyboard) $ do
      modifyIORef stateref (input.keyboard %~ S.insert key)
  return False

-- |
onkeyreleased :: IORef AppState -> EventM EKey Bool
onkeyreleased stateref = do
  key <- T.unpack <$> eventKeyName
  Cairo.liftIO $ do
    appstate <- readIORef stateref
    modifyIORef stateref (input.keyboard %~ S.delete key)
  return False

-- |
-- onwindowresized
-- onwindowminimised

--------------------------------------------------------------------------------------------------------------------------------------------
-- Utilities
--------------------------------------------------------------------------------------------------------------------------------------------
-- |
attach :: Window -> DrawingArea -> IORef AppState -> IO ()
attach window canvas stateref = do
  appstate <- readIORef stateref

  canvas `on` draw $ Cairo.liftIO (readIORef stateref) >>= onrender

  canvas `on` motionNotifyEvent  $ onmousemoves    stateref
  canvas `on` buttonPressEvent   $ onmousepressed  stateref
  canvas `on` buttonReleaseEvent $ onmousereleased stateref
  window `on` keyPressEvent      $ onkeypressed    stateref
  window `on` keyReleaseEvent    $ onkeyreleased   stateref

  window `on` deleteEvent $ Cairo.liftIO mainQuit >> return False

  timeoutAdd (onanimate stateref) (round $ 1000.0 / appstate^.animation.fps)

  pass

--------------------------------------------------------------------------------------------------------------------------------------------
-- |
velocityFromKey :: Double -> String -> Complex Double
velocityFromKey speed key = case key of
      "Left"  -> (-speed):+0
      "Right" -> ( speed):+0
      "Up"    ->       0 :+(-speed)
      "Down"  ->       0 :+( speed)
      _       ->       0:+0


-- |
-- Module      : Application
-- Description : Utilties for creating GUI applications
-- Copyright   : (c) Jonatan H Sundqvist, year
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental|stable
-- Portability : POSIX (not sure)
--

-- Created date year

-- TODO | - Refactor (move types to separate module, add lenses)
--        - Input queries, composite events (InputState type?)
--        - Redesign API (less fragile and add-hoc) (divide into app types, eg. full screen canvas, etc.)
--        - Optional event wrappers
--        - Printf-style event coupling (with a Listener class (?))

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC directives
--------------------------------------------------------------------------------------------------------------------------------------------
{-# LANGUAGE RankNTypes #-}

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module Southpaw.Interactive.Application where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.Complex --
import Data.Functor --
import Data.IORef   --
import Data.Maybe   --

import Control.Lens hiding (set)
import Control.Monad       (liftM, when, void, forM) --
import Control.Applicative (pure, (<*>))

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

import Southpaw.Interactive.Types
import Southpaw.Interactive.Lenses

--------------------------------------------------------------------------------------------------------------------------------------------
-- Data
--------------------------------------------------------------------------------------------------------------------------------------------

-- |
-- TODO: Rename (eg. no-listeners), create a separate default value (?)
nolisteners :: EventMap self s
nolisteners = EventMap Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing

-- |
-- TODO: Rename (eg. no-listeners), create a separate default value (?)
-- defaultListeners :: EventMap s
-- defaultListeners = nolisteners { }

--------------------------------------------------------------------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------------------------------------------------------------------

-- Master listeners ------------------------------------------------------------------------------------------------------------------------

-- TODO: Hoogle section

-- |
masterdraw :: (s -> Cairo.Render ()) -> IORef s -> Cairo.Render ()
masterdraw draw stateref = do
	state <- Cairo.liftIO $ readIORef stateref
	draw state

-- General utilities -----------------------------------------------------------------------------------------------------------------------

-- |
-- TODO: Make polymorphic
widgetSize :: WidgetClass self => self -> IO (Complex Int)
widgetSize widget = (:+) <$> widgetGetAllocatedWidth widget <*> widgetGetAllocatedHeight widget

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

-- |
-- TODO: Rename (duh)
-- TODO: Refactor
-- TODO: Factor out default event handlers
-- TODO: Use state value from the App (?)
wholecanvas :: WidgetSettings Window state -> WidgetSettings DrawingArea state -> state -> IO (App FullCanvasLayout state)
wholecanvas windowSettings canvasSettings appstate = do
	initGUI

	stateref <- newIORef appstate

	window'  <- makeWidget windowNew stateref $ windowSettings
	frame'   <- frameNew
	canvas'  <- makeWidget drawingAreaNew stateref $ canvasSettings

	containerAdd frame' canvas'
	set window' [ containerChild := frame' ]

	widgetShowAll window'
	return $ App { _window=window', _layout=FullCanvasLayout { _canvas=canvas' }, _appsize=_settingsize windowSettings, _state=stateref }

-- |
-- TODO: Use readstate for everything, or remove it (?)
-- TODO: Find out how to deal with 'onanimate'
-- TODO: Event wrappers (eg. draw)
attachListeners :: WidgetClass self => self -> IORef state -> EventMap self state -> IO ()
attachListeners self stateref eventmap = do
	simpleBind buttonPressEvent   onmousedown
	simpleBind buttonReleaseEvent onmouseup
	simpleBind motionNotifyEvent  onmousemotion
	simpleBind keyPressEvent      onkeydown
	simpleBind keyReleaseEvent    onkeyup
	simpleBind deleteEvent        ondelete
	-- simpleBind draw           (\emap -> maybe Nothing (void . Just . masterdraw dr) (ondraw emap))
	maybe pass (\ondr       -> void $ (self `on` draw $ masterdraw ondr stateref)) (ondraw eventmap)
	maybe pass (\(fps, ona) -> void $ timeoutAdd (ona self stateref) fps)          (onanimate eventmap)

	pass
	-- perhapsBind self key onanimate
	-- onresize, -- configureEvent
	-- ondrawIO
	-- perhapsBind self  onquit
	-- forM [(self `on` motionNotifyEvent,  onmousemotion),
	--       (self `on` buttonPressEvent,   onmousedown),
	-- 			(self `on` buttonReleaseEvent, onmouseup)] $ \(signal, prop) -> perhaps (prop eventmap) (\listener -> signal $ listener stateref)
	where
		simpleBind = maybeBind self eventmap stateref

-- |
pass :: Monad m => m ()
pass = return ()

-- |
-- bind :: WidgetClass self => self -> Signal ->
bind :: WidgetClass self => self -> Signal self callback -> IORef s -> (IORef s -> callback) -> IO (ConnectId self)
bind self event stateref action = self `on` event $ action stateref

-- |
maybeBind :: WidgetClass self => self -> EventMap self s -> IORef s -> Signal self callback -> (EventMap self s -> Maybe (IORef s -> callback)) -> IO ()
maybeBind self eventmap state event find = maybe pass (void . bind self event state) (find eventmap)

-- |
makeWidget :: WidgetClass self => IO self -> IORef s -> WidgetSettings self s -> IO self
makeWidget make stateref settings = do
	widget <- make
	applySettings widget stateref settings

-- |
applySettings :: WidgetClass self => self -> IORef s -> WidgetSettings self s -> IO self
applySettings self stateref settings = do
	widgetSetSizeRequest self dx dy -- TODO: Use windowSetDefaultSize instead (?)
	widgetAddEvents self eventmasks
	attachListeners self stateref (_settinglisteners settings)
	return self
	where
		(dx:+dy)   = _settingsize settings
		eventmasks = _settingeventmasks settings

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

-- |
-- TODO: Add setup argument (?)
-- TODO: Use 'IO (App s)' or 'App s' directly (?)
run :: IO (App layout state) -> IO ()
run makeApp = makeApp >> mainGUI


{-# LANGUAGE CPP, NoImplicitPrelude #-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif
module SafeHaskellSpec (main, spec) where

import TestHspecTrustworthy

-- The following modules should not be Unsafe (#56):
import Control.Concurrent.Compat ()
import Control.Concurrent.MVar.Compat ()
import Control.Exception.Compat ()
import Control.Monad.Compat ()
import Control.Monad.Fail.Compat ()
import Control.Monad.IO.Class.Compat ()
import Data.Bifoldable.Compat ()
import Data.Bifunctor.Compat ()
import Data.Bitraversable.Compat ()
import Data.Bits.Compat ()
import Data.Bool.Compat ()
import Data.Complex.Compat ()
import Data.Either.Compat ()
import Data.Foldable.Compat ()
import Data.Function.Compat ()
import Data.Functor.Compat ()
import Data.Functor.Compose.Compat ()
import Data.Functor.Const.Compat ()
import Data.Functor.Contravariant.Compat ()
import Data.Functor.Identity.Compat ()
import Data.Functor.Product.Compat ()
import Data.Functor.Sum.Compat ()
import Data.IORef.Compat ()
import Data.List.Compat ()
import Data.List.NonEmpty.Compat ()
import Data.Monoid.Compat ()
import Data.Proxy.Compat ()
import Data.Ratio.Compat ()
import Data.Semigroup.Compat ()
import Data.STRef.Compat ()
import Data.String.Compat ()
import Data.Type.Coercion.Compat ()
import Data.Type.Equality.Compat ()
import Data.Version.Compat ()
import Data.Void.Compat ()
import Data.Word.Compat ()
import Foreign.Compat ()
import Foreign.ForeignPtr.Compat ()
import Foreign.ForeignPtr.Safe.Compat ()
import Foreign.Marshal.Alloc.Compat ()
import Foreign.Marshal.Array.Compat ()
import Foreign.Marshal.Compat ()
import Foreign.Marshal.Safe.Compat ()
import Foreign.Marshal.Utils.Compat ()
import Numeric.Compat ()
import Numeric.Natural.Compat ()
import Prelude.Compat
import System.Environment.Compat ()
import System.Exit.Compat ()
import System.IO.Error ()
import Text.Read.Compat ()
import Type.Reflection.Compat ()

main :: IO ()
main = hspec spec

spec :: Spec
spec = pure ()


{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict              #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeOperators       #-}

module Grenade.Layers.Internal.CUDA
  ( setCudaTriggerSize
  , useCuda
  , cudaDescendUnsafeAdamGPU
  , cudaSumVectorsGPU
  ) where

import           Control.Concurrent
import           Control.Concurrent.Lock      (Lock)
import qualified Control.Concurrent.Lock      as Lock
import           Control.Concurrent.MVar
import           Control.Exception            (IOException, handle)
import           Control.Monad
import qualified Data.Map.Strict              as M
import           Data.Maybe                   (fromMaybe)
import           Data.Proxy
import           Data.String
import qualified Data.Vector.Storable         as V
import qualified Data.Vector.Storable         as U (unsafeFromForeignPtr0,
                                                    unsafeToForeignPtr0)
import           Foreign                      (withForeignPtr)
import           Foreign.C.Types
-- import qualified Foreign.CUDA.BLAS            as BLAS
import           Control.Monad.Primitive      (PrimBase)
import qualified Data.ByteString
import           Data.FileEmbed               (embedFile)
import qualified Foreign.CUDA.Driver          as CUDA
import           Foreign.Ptr
import           Foreign.Storable             (sizeOf)
import           GHC.IO.Handle.Text           (memcpy)
import           GHC.TypeLits
-- import qualified Numeric.LinearAlgebra        as LA
import qualified Numeric.LinearAlgebra.Static as LAS
import           System.IO.Unsafe             (unsafePerformIO)

import           Grenade.Types
import           Grenade.Utils.Vector

import           Debug.Trace

-- | Cuda context
cudaTriggerSize :: MVar (Maybe Int)
cudaTriggerSize = unsafePerformIO $ newMVar Nothing

-- | Set the minimum vector/matrix size (nr of elements) of when CUDA is used.
setCudaTriggerSize :: (PrimBase m) => Maybe Int -> m ()
setCudaTriggerSize sz = unsafePerformIO (tryPutMVar cudaTriggerSize sz) `seq` return ()

useCuda :: Int -> Bool
useCuda sz = unsafePerformIO $ do
  minSz <- tryReadMVar cudaTriggerSize
  return $ maybe False (sz >=) (join minSz)

-- Load the ptx file into the binary at compile-time!
bsGPUGradientDescent :: Data.ByteString.ByteString
bsGPUGradientDescent = $(embedFile "cbits/gpu_gradient_descent.ptx")

-- Load the ptx file into the binary at compile-time!
bsGPUSumVectors :: Data.ByteString.ByteString
bsGPUSumVectors = $(embedFile "cbits/gpu_sum_vectors.ptx")

-- | Cuda function for Adam
cudaDescendAdamGPUFun :: MVar (Maybe CUDA.Fun)
cudaDescendAdamGPUFun = unsafePerformIO $ newMVar Nothing
{-# NOINLINE cudaDescendAdamGPUFun #-}

-- | Cuda function for sumVectors
cudaSumVectorsGPUFun :: MVar (Maybe CUDA.Fun)
cudaSumVectorsGPUFun = unsafePerformIO $ newMVar Nothing
{-# NOINLINE cudaSumVectorsGPUFun #-}

-- | Cuda function for sumVectors
lock :: Lock
lock = unsafePerformIO Lock.new
{-# NOINLINE lock #-}

writeMVar :: MVar a -> a -> IO ()
writeMVar var x = modifyMVar var (\_ -> return (x, ()))

-- cudaInitialise :: IO ()
-- cudaInitialise = do
--   CUDA.initialise []
--   count <- CUDA.count
--   devs <- mapM CUDA.device [0 .. count - 1]
--   putStrLn $ "Initialising CUDA. Found " ++ show count ++ " devices: "
--   mapM_ (CUDA.props >=> print) devs
--   putStrLn ""
--   unless (null devs) $ do
--     props <- CUDA.props (head devs)
--     let threadsPerBlock = CUDA.maxThreadsPerBlock props
--     putStrLn $ "Using CUDA with device: " ++ show (CUDA.deviceName props) ++ "; threads per Block: " ++ show threadsPerBlock ++ "\n"
--     writeIORef cudaThreadsPerBlock threadsPerBlock
--     device <- CUDA.device 0
--     writeIORef cudaDevice (Just device)
--     ctx <- CUDA.create device []
--     writeIORef cudaCtx (Just ctx)
--     -- Compile to ptx?
--     mdl <- CUDA.loadData bsGPUGradientDescent
--     descendAdamGpuFun <- CUDA.getFun mdl (fromString "descend_adam_gpu")
--     writeIORef cudaDescendAdamGPUFun (Just descendAdamGpuFun)

cudaInitialise :: IO ()
cudaInitialise = do
  threadId <- myThreadId
  Lock.acquire lock
  -- m <- readIORef cudaCtx
  -- case M.lookup threadId m of
  --   Just{} -> return ()
  --   Nothing -> do
  do
      CUDA.initialise []
      count <- CUDA.count
      devs <- mapM CUDA.device [0 .. count - 1]
      if null devs
        then return ()
        else do
          putStrLn $ "Initialising CUDA. Found " ++ show count ++ " devices: "
          mapM_ (CUDA.props >=> print) devs
          putStrLn ""
          props <- CUDA.props (head devs)
          let threadsPerBlock = CUDA.maxThreadsPerBlock props
          putStrLn $ "Using CUDA with device: " ++ show (CUDA.deviceName props) ++ "; threads per Block: " ++ show threadsPerBlock ++ "\n"
          writeMVar cudaThreadsPerBlock threadsPerBlock
          device <- CUDA.device 0
          writeMVar cudaDevice (Just device)
          -- ctx <- CUDA.create device []
          -- -- atomicModifyIORef cudaCtx (\m' -> (M.insert threadId ctx m', ()))
          -- -- writeIORef cudaCtx (M.Just ctx)
          --      -- Inline compile to ptx?
          -- flip mapM_ functions $ \(file, functionName, ioRef) -> do
          --   mdl <- CUDA.loadData file
          --   fun <- CUDA.getFun mdl (fromString functionName)
          --   modifyMVar ioRef (\_ -> return (Just fun, ()))
  Lock.release lock
  where
    functions =
      [ (bsGPUGradientDescent, "descend_adam_gpu", cudaDescendAdamGPUFun) -- ^ Adam
      , (bsGPUSumVectors, "sum_vectors_gpu", cudaSumVectorsGPUFun) -- ^ Sum a list of vectors
      ]

-- | Cuda context
cudaThreadsPerBlock :: MVar Int
cudaThreadsPerBlock = unsafePerformIO $ newMVar 128

-- | Cuda device
cudaDevice :: MVar (Maybe CUDA.Device)
cudaDevice = unsafePerformIO $ newMVar Nothing

withCudaCtx :: CUDA.Device -> (CUDA.Fun -> IO b) -> IO b
withCudaCtx device f = do
  -- device <- fromMaybe (error "empty device") . join <$> tryReadMVar cudaDevice -- device 0
  -- myThreadId >>= print
  !ctx <- CUDA.create device []
  mdl <- CUDA.loadData bsGPUSumVectors
  fun <- CUDA.getFun mdl (fromString "sum_vectors_gpu")
  !b <- f fun
  CUDA.destroy ctx
  return b

-- | To inform the user when it works again
cudaErrored :: MVar Bool
cudaErrored = unsafePerformIO $ newMVar False
{-# NOINLINE cudaErrored #-}

cudaDescendUnsafeAdamGPU ::
     Int -- Len
  -> Int -- Step
  -> RealNum -- Alpha
  -> RealNum -- Beta1
  -> RealNum -- Beta2
  -> RealNum -- Epsilon
  -> RealNum -- Lambda
  -> V.Vector RealNum -- Weights
  -> V.Vector RealNum -- Gradient
  -> V.Vector RealNum -- M
  -> V.Vector RealNum -- V
  -> Maybe (V.Vector RealNum, V.Vector RealNum, V.Vector RealNum)
cudaDescendUnsafeAdamGPU len step alpha beta1 beta2 epsilon lambda weights gradient m v =
  unsafePerformIO $ do
    mFun <- join <$> tryReadMVar cudaDescendAdamGPUFun
    case mFun of
      Nothing -> cudaInitialise >> tryReadMVar cudaDescendAdamGPUFun >>= maybe (return Nothing) cudaDescendAdamGPU' -- Ensure it was initialised
      x -> handle handler (cudaDescendAdamGPU' x)
  where
    handler (e :: CUDA.CUDAException) = writeMVar cudaErrored True >> print e >> return Nothing
    cudaDescendAdamGPU' mFun =
      case mFun of
        Nothing -> return Nothing
        Just fun -> do
          threadsPerBlock <- fromMaybe 128 <$> tryReadMVar cudaThreadsPerBlock
          V.unsafeWith weights $ \wPtr' ->
            V.unsafeWith gradient $ \gPtr' ->
              V.unsafeWith m $ \mPtr' ->
                V.unsafeWith v $ \vPtr' -> do
                  wPtrDev <- CUDA.mallocArray len :: IO (CUDA.DevicePtr RealNum)
                  gPtrDev <- CUDA.mallocArray len :: IO (CUDA.DevicePtr RealNum)
                  mPtrDev <- CUDA.mallocArray len :: IO (CUDA.DevicePtr RealNum)
                  vPtrDev <- CUDA.mallocArray len :: IO (CUDA.DevicePtr RealNum)
                  CUDA.pokeArray len wPtr' wPtrDev
                  CUDA.pokeArray len gPtr' gPtrDev
                  CUDA.pokeArray len mPtr' mPtrDev
                  CUDA.pokeArray len vPtr' vPtrDev
                  let tx = ceiling (fromIntegral len / (fromIntegral threadsPerBlock :: Float)) :: Int
                  -- print (len, step+1)
                  -- print (alpha, beta1, beta2, epsilon, lambda)
                  CUDA.launchKernel
                    fun
                    (tx, 1, 1 :: Int)
                    (threadsPerBlock, 1, 1)
                    0
                    Nothing
                    [ CUDA.IArg (fromIntegral len)
                    , CUDA.IArg (fromIntegral $ step + 1)
                    , CUDA.VArg (alpha :: RealNum)
                    , CUDA.VArg (beta1 :: RealNum)
                    , CUDA.VArg (beta2 :: RealNum)
                    , CUDA.VArg (epsilon :: RealNum)
                    , CUDA.VArg (lambda :: RealNum)
                    , CUDA.VArg wPtrDev
                    , CUDA.VArg gPtrDev
                    , CUDA.VArg mPtrDev
                    , CUDA.VArg vPtrDev
                    ]
                  CUDA.sync
                  CUDA.peekArray len wPtrDev wPtr'
                  CUDA.peekArray len mPtrDev mPtr'
                  CUDA.peekArray len vPtrDev vPtr'
                  mapM_ CUDA.free [wPtrDev,gPtrDev,mPtrDev,vPtrDev] -- put pointers back for reuse
                  err <- fromMaybe False <$> tryReadMVar cudaErrored
                  when err $ writeMVar cudaErrored False >> putStrLn "Cuda works again"
                  return $ Just (weights, m, v)
{-# NOINLINE cudaDescendUnsafeAdamGPU #-}

cudaSumVectorsGPU :: [V.Vector RealNum] -> Maybe (V.Vector RealNum) -- vectors to sum, all of same length
cudaSumVectorsGPU [] = Nothing
cudaSumVectorsGPU vs
  | useCuda (length vs * V.length (head vs)) =
    unsafePerformIO $! do
      mDev <- join <$> tryReadMVar cudaDevice
      case mDev of
        Nothing -> cudaInitialise >> tryReadMVar cudaDevice >>= maybe (return Nothing) cudaSumVectorsGPU' -- Ensure it was initialised
        dev -> handle handler (cudaSumVectorsGPU' dev)
  | otherwise = Nothing
  where
    handler (e :: CUDA.CUDAException) = writeMVar cudaErrored True >> print e >> return Nothing
    cudaSumVectorsGPU' (mDev :: Maybe CUDA.Device) =
      case mDev of
        Nothing -> return Nothing
        Just dev ->
          withCudaCtx dev $ \fun -> do
            let outVec = createVectorUnsafe (V.length $ head vs)
            let outLen = V.length (head vs)
                inLen = outLen * length vs
            let inVec = V.generate inLen genFun
                genFun idx =
                  let vIdx = idx `div` outLen
                      vec = vs !! vIdx
                   in vec V.! (idx - vIdx * outLen)
            threadsPerBlock <- fromMaybe 128 <$> tryReadMVar cudaThreadsPerBlock
            V.unsafeWith inVec $ \inVecPtr' -> do
              V.unsafeWith outVec $ \outVecPtr' -> do
                inVecPtrDev <- CUDA.mallocArray inLen :: IO (CUDA.DevicePtr RealNum)
                outVecPtrDev <- CUDA.mallocArray outLen :: IO (CUDA.DevicePtr RealNum)
                CUDA.pokeArray inLen inVecPtr' inVecPtrDev
                let tx = ceiling (fromIntegral outLen / (fromIntegral threadsPerBlock :: Float)) :: Int
                CUDA.launchKernel
                  fun
                  (tx, 1, 1 :: Int)
                  (threadsPerBlock, 1, 1)
                  0
                  Nothing
                  [ CUDA.IArg (fromIntegral inLen)
                  , CUDA.IArg (fromIntegral outLen)
                  , CUDA.VArg (inVecPtrDev :: CUDA.DevicePtr RealNum)
                  , CUDA.VArg (outVecPtrDev :: CUDA.DevicePtr RealNum)
                  ]
                CUDA.sync
                CUDA.peekArray outLen outVecPtrDev outVecPtr'
                mapM_ CUDA.free [inVecPtrDev, outVecPtrDev] -- put pointers back for reuse
                err <- fromMaybe False <$> tryReadMVar cudaErrored
                when err $ writeMVar cudaErrored False >> putStrLn "Cuda works again"
                return $ Just outVec
{-# NOINLINE cudaSumVectorsGPU #-}

-- test =
--   cudaSumVectorsGPU (map V.fromList (replicate 32 [1..10]))


module Edges.Prelude
(
  module Exports,
  UnboxedVector,
  modifyTVar',
  forMInAscendingRange_,
  forMInDescendingRange_,
  showText,
  -- * Optics
  Lens,
  Lens',
  Prism,
  Prism',
  lens,
  prism,
  _Left,
  _Just,
)
where

-- base
-------------------------
import Control.Applicative as Exports
import Control.Arrow as Exports
import Control.Category as Exports
import Control.Concurrent as Exports
import Control.Exception as Exports
import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)
import Control.Monad.IO.Class as Exports
import Control.Monad.Fix as Exports hiding (fix)
import Control.Monad.ST as Exports
import Data.Bits as Exports
import Data.Bool as Exports
import Data.Char as Exports
import Data.Coerce as Exports
import Data.Complex as Exports
import Data.Data as Exports
import Data.Dynamic as Exports
import Data.Either as Exports
import Data.Fixed as Exports
import Data.Foldable as Exports
import Data.Function as Exports hiding (id, (.))
import Data.Functor as Exports
import Data.Functor.Identity as Exports
import Data.Int as Exports
import Data.IORef as Exports
import Data.Ix as Exports
import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')
import Data.Maybe as Exports
import Data.Monoid as Exports hiding (Last(..), First(..))
import Data.Ord as Exports
import Data.Proxy as Exports
import Data.Ratio as Exports
import Data.STRef as Exports
import Data.String as Exports
import Data.Traversable as Exports
import Data.Tuple as Exports
import Data.Unique as Exports
import Data.Version as Exports
import Data.Word as Exports
import Debug.Trace as Exports
import Foreign.ForeignPtr as Exports
import Foreign.Ptr as Exports
import Foreign.StablePtr as Exports
import Foreign.Storable as Exports hiding (sizeOf, alignment)
import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)
import GHC.Exts as Exports (lazy, inline, sortWith, groupWith)
import GHC.Generics as Exports (Generic)
import GHC.IO.Exception as Exports
import Numeric as Exports
import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))
import System.Environment as Exports
import System.Exit as Exports
import System.IO as Exports
import System.IO.Error as Exports
import System.IO.Unsafe as Exports
import System.Mem as Exports
import System.Mem.StableName as Exports
import System.Timeout as Exports
import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)
import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)
import Text.Printf as Exports (printf, hPrintf)
import Text.Read as Exports (Read(..), readMaybe, readEither)
import Unsafe.Coerce as Exports

-- contravariant
-------------------------
import Data.Functor.Contravariant as Exports
import Data.Functor.Contravariant.Divisible as Exports

-- pointed
-------------------------
import Data.Pointed as Exports
import Data.Copointed as Exports

-- profunctors
-------------------------
import Data.Profunctor.Unsafe as Exports
import Data.Profunctor.Choice as Exports
import Data.Profunctor.Strong as Exports

-- semigroupoids
-------------------------
import Data.Semigroupoid as Exports

-- cereal
-------------------------
import Data.Serialize as Exports (Serialize)

-- deferred-folds
-------------------------
import DeferredFolds.Unfoldl as Exports (Unfoldl(..))
import DeferredFolds.UnfoldlM as Exports (UnfoldlM(..))

-- foldl
-------------------------
import Control.Foldl as Exports (Fold(..), FoldM(..))

-- hashable
-------------------------
import Data.Hashable as Exports (Hashable)

-- primitive
-------------------------
import Data.Primitive as Exports
import Control.Monad.Primitive as Exports

-- primitive-extras
-------------------------
import PrimitiveExtras.PrimMultiArray as Exports (PrimMultiArray)
import PrimitiveExtras.TVarArray as Exports (TVarArray)

-- unordered-containers
-------------------------
import Data.HashMap.Strict as Exports (HashMap)

-- vector
-------------------------
import Data.Vector as Exports (Vector)

-- text
-------------------------
import Data.Text as Exports (Text)

-- deepseq
-------------------------
import Control.DeepSeq as Exports

-- data-dword
-------------------------
import Data.DoubleWord as Exports

-- cereal-vector
-------------------------
import Data.Vector.Serialize ()

-- cereal-data-dword
-------------------------
import Cereal.DataDWord.Serialize ()

import qualified Data.Vector.Unboxed as UnboxedVector
import qualified Data.Vector.Unboxed.Deriving as UnboxedVectorDeriving

type UnboxedVector = UnboxedVector.Vector

{-# INLINE modifyTVar' #-}
modifyTVar' :: TVar a -> (a -> a) -> STM ()
modifyTVar' var f = do
    x <- readTVar var
    writeTVar var $! f x

{-# INLINE forMInAscendingRange_ #-}
forMInAscendingRange_ :: Applicative m => Int -> Int -> (Int -> m a) -> m ()
forMInAscendingRange_ !startN !endN f =
  ($ startN) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure ()

{-# INLINE forMInDescendingRange_ #-}
forMInDescendingRange_ :: Applicative m => Int -> Int -> (Int -> m a) -> m ()
forMInDescendingRange_ !startN !endN f =
  ($ pred startN) $ fix $ \loop !n -> if n >= endN then f n *> loop (pred n) else pure ()

showText = fromString . show

-- * Optics
-------------------------

type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

type Lens' s a = Lens s s a a

type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)

type Prism' s a = Prism s s a a

{-# INLINE lens #-}
lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens sa sbt afb s = sbt s <$> afb (sa s)

{-# INLINE prism #-}
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism bt seta = dimap seta (either pure (fmap bt)) . right'

{-# INLINE _Left #-}
_Left :: Prism' (Either a b) a
_Left = prism Left (either Right (Left . Right))

{-# INLINE _Just #-}
_Just :: Prism' (Maybe a) a
_Just = prism Just (maybe (Left Nothing) Right)

-- * Instances for unboxed vectors
-------------------------

UnboxedVectorDeriving.derivingUnbox "Word96"
  [t| Word96 -> (Word32, Word64) |]
  [| \ (Word96 a b) -> (a, b) |]
  [| \ (a, b) -> Word96 a b |]

UnboxedVectorDeriving.derivingUnbox "Word128"
  [t| Word128 -> (Word64, Word64) |]
  [| \ (Word128 a b) -> (a, b) |]
  [| \ (a, b) -> Word128 a b |]

UnboxedVectorDeriving.derivingUnbox "Word256"
  [t| Word256 -> (Word128, Word128) |]
  [| \ (Word256 a b) -> (a, b) |]
  [| \ (a, b) -> Word256 a b |]