-- |
-- Module      : Hieroglyphs
-- Description : Cairo experiments (graphics library)
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental
-- Portability : POSIX (not sure)
--
-- Jonatan H Sundqvist
-- May 31 2015
--

-- TODO | - Lenses
--        - Performance profiling (feels chuggish sometimes, consumes a lot of CPU power)
--        - Figure out how to deal with polymorphic numerical types
--        - Polymorphic wrappers around core rendering functions
--        - This module should only deal with graphics
--        - Work out how to deal with state (logical/interaction/graphical)
--        - Wrap up graphical/animation state in single object (eg. Renderable ball with trail/colour/arrows/etc.)
--          -- Toggle visibility (eg. with checkbuttons)
--          -- Drawing bounding boxes, vector arrows
--          -- Create Drawable type
--
--        - Effects
--          -- Fading
--
--        - Worry about clean-up or rely on GC (eg. freeing surfaces) (?)
--
--        - Shape API
--          -- Should render functions simply set a path or fill them in/draw them too
--          -- Utility functions for colour/fill/stroke/line width/etc. (?)

-- SPEC | -
--        -

-- module Hieroglyphs where

---------------------------------------------------------------------------------------------------
-- We'll need these
---------------------------------------------------------------------------------------------------
import Graphics.UI.Gtk -- hiding (fill)
import qualified Graphics.Rendering.Cairo as C

import Data.Complex
import Control.Monad (when, forM_)
import Data.IORef

import qualified Copernicus as Cop
import qualified Palette

---------------------------------------------------------------------------------------------------
-- Types
---------------------------------------------------------------------------------------------------
-- TODO: One trail per body ([[Complex Double]]) (?)
data World = World { frame :: Int, size :: (Int, Int), bodies :: [Cop.Body Double], trails :: [[Complex Double]] } deriving Show

---------------------------------------------------------------------------------------------------
-- Data
---------------------------------------------------------------------------------------------------
animate = True --
π       = pi   -- :: Double -- TODO: Polymorphic (?)
τ       = 2*π  -- :: Double -- TODO: Polymorphic (?)
fps     = 30   :: Int

v = 2.0:+0.5 --40.0 :+ 20.0
g = 0.0:+(-9.82) --0.0 :+ (-9.82)

bodies' = map (\ (p', v', g') -> Cop.Body p' v' g') [(0.0:+1.0, v, g), (1.0:+0.0, (2.0):+1.50, g), (3.0:+(2.80), v, g), (2.5:+1.92, v, g)]

---------------------------------------------------------------------------------------------------
-- Functions
---------------------------------------------------------------------------------------------------
-- |
mainGTK :: IO ()
mainGTK = do
    initGUI
    window <- windowNew

    frame  <- frameNew
    canvas <- drawingAreaNew
    containerAdd frame canvas

    set window [ containerChild := frame]
    windowSetDefaultSize window 650 650

    widgetAddEvents canvas [PointerMotionMask]

    widgetShowAll window

    -- Assets
    -- planets <- C.withImageSurfaceFromPNG "assets/planets.png" $ \surface -> surface
    planets <- C.liftIO $ C.imageSurfaceCreateFromPNG "assets/planets.png"

    -- Animation
    (w,h)    <- widgetSize window
    worldVar <- newIORef $ World { frame=0, size=(w,h), bodies=bodies', trails=map (const []) bodies' } --
    when animate $ timeoutAdd (onanimate worldVar canvas) (1000 `div` fps) >> return ()

    -- Events
    canvas `on` draw $ (C.liftIO $ readIORef worldVar) >>= flip render planets -- readIORef worldVar >>= \ w -> render (fromIntegral w) (fromIntegral h) w
    canvas `on` motionNotifyEvent $ onmousemove

    window `on` configureEvent $ onresize window worldVar
    window `on` deleteEvent $ C.liftIO mainQuit >> return False -- TODO: Uhmmm... what?
    window `on` keyPressEvent $ onkeypress

    mainGUI

-- |
-- TODO: Make polymorphic
widgetSize :: WidgetClass self => self -> IO (Int, Int)
widgetSize widget = do
    w <- widgetGetAllocatedWidth widget
    h <- widgetGetAllocatedHeight widget
    return (w, h)

-- |
-- onresize :: WidgetClass self => self -> IORef World -> IO Bool
onresize window worldVar = do
    sz <- eventSize
    C.liftIO $ modifyIORef worldVar $ \ wd -> wd { size=sz }
    return True

-- |
-- onkeypress ::
onkeypress = do
    key <- eventKeyName
    C.liftIO $ print key
    return True

-- |
-- onmousemove ::
onmousemove = do
    when False $ do
        (mx,my) <- eventCoordinates
        C.liftIO $ print (mx,my)
    return False

-- Animation --------------------------------------------------------------------------------------
-- |
onanimate :: IORef World -> DrawingArea -> IO Bool
onanimate world canvas = do
    -- withMVar var print
    modifyIORef world update
    widgetQueueDraw canvas
    return True

-- |
-- TODO: Refactor, make readable (State monad, lenses)
update :: World -> World
update w@(World { frame=f, bodies=bodies'' } ) = w { frame=f+1,
                                                                       bodies=map (Cop.animate (1.0/fromIntegral fps)) bodies'',
                                                                       trails=map (\ (trail, (Cop.Body p _ _)) -> take 50 $ p:trail) $ zip (trails w) bodies'' }

-- | The time elapsed (in seconds)
-- TODO: Polymorphic (?)
elapsed :: World -> Double
elapsed world = (fromIntegral $ frame world) * 1.0/fromIntegral fps

-- Rendering --------------------------------------------------------------------------------------
-- |
-- TODO: Make polymorphic
-- TODO: Apply coordinate transformations (to World perhaps; make world a monad?)
renderBody :: Cop.Body Double -> C.Render ()
renderBody (Cop.Body (x:+y) (vx:+vy) (ax:+ay)) = do
    -- C.arc (x/3 + 200) (y/3 + 200) 12 0 τ
    -- Body
    C.arc x y 12 0 τ
    C.setSourceRGBA 0.5 0.2 0.3 1.0
    C.fill

    -- Vector arrows
    C.setSourceRGBA 0.12 0.05 1 0.8
    renderArrow (x:+y) (x:+(y+vy*10)) (abs vy*10*0.8) 5 12

    C.setSourceRGBA 1 0.05 0.12 0.8
    renderArrow (x:+y) ((x+vx*10):+y) (abs vx*10*0.8) 5 12

-- |
renderWorld :: World -> C.Render ()
renderWorld world = do

    -- X-axis
    vectorise C.moveTo $ toScreenCoords world ((-5):+0)
    vectorise C.lineTo $ toScreenCoords world (  5:+0)
    C.setSourceRGBA 1 0 0 0.8
    C.stroke

    -- Y-axis
    vectorise C.moveTo $ toScreenCoords world (0:+(-5))
    vectorise C.lineTo $ toScreenCoords world (0:+  5)
    C.setSourceRGBA 0 1 0 0.8
    C.stroke

    -- Trail(s)
    -- TODO: Better way of doing 2D 'loops'
    forM_ (zip [Palette.green, Palette.red, Palette.blue] $ trails world) $ \(fill, trail) -> do
        forM_ trail $ \ dot -> do
            -- C.setSourceRGBA (cos $ 1.3*c) (sin $ 5*c) 0.2 1.0
            Palette.choose fill
            renderCircle (toScreenCoords world dot) 3

    -- Render bodies
    forM_ (bodies world) $ renderBody . bodyToScreenCoords world

-- |
render :: World -> C.Surface -> C.Render ()
render world planets = do

    --
    when False $ do
        C.moveTo 16 44
        C.liftIO $ C.fontOptionsCreate >>= flip C.fontOptionsSetAntialias C.AntialiasSubpixel
        C.selectFontFace "Helvetica" C.FontSlantNormal C.FontWeightNormal
        C.setFontSize 30
        C.setSourceRGBA 0.62 0.62 0.62 0.7
        C.showText "Copernicus"

        extents <- C.textExtents "Copernicus"

        C.setFontSize 14
        C.setSourceRGBA 0.3 0.3 0.3 1.0
        C.moveTo 16 $ 44 + C.textExtentsHeight extents + 5
        C.showText "Jonatan H Sundqvist 2015"

    --
    renderGrid 10 10 $ fromIntegral (fst $ size world) / 10

    -- Image
    when False $ do
        {-action <- C.liftIO . C.withImageSurfaceFromPNG "assets/planets.png" $ (\surface -> return $
            do C.setSourceSurface surface 20 20 >> C.paint)-}
        -- planets <- C.liftIO $ C.imageSurfaceCreateFromPNG "assets/planets.png"
        C.setSourceSurface planets 50 50
        C.rectangle 320 310 250 250
        C.clip
        C.paint
        C.resetClip

    -- Arrow
    -- renderArrow (40:+40) (200:+120) 80 20 40
    -- TODO: Don't hard-code arrow values
    when False $ do
        forM_ (bodies world) $ \ body -> do
            let (from, to, len, width, headWidth) = (40:+50, let (Cop.Body p _ _) = body in toScreenCoords world p, 0.78 * magnitude (to-from), 40, 88)
            let thearrow = arrow from to len width headWidth
            renderArrow from to len width headWidth

            -- Arrow vertices
            C.setSourceRGBA 0 0 0 1.0
            forM_ thearrow (flip renderCircle 5)

            C.setSourceRGBA 0 0 0 1.0
            forM_ (zip [1..] thearrow) $ \(n, p) -> vectorise C.moveTo (p+(6:+6)) >> C.showText (show n)

            -- Arrow symmetry line
            vectorise C.moveTo from
            vectorise C.lineTo to
            C.setSourceRGBA 0 0 0 1.0
            C.stroke

    -- Shifting polygons
    when False $ do
        let sides       = 3 + (flip mod 10 . flip div fps $ frame world)
            radius mini = (+mini) . (*35.0) . (+1.0) . sin  $ elapsed world
            origin      = (w/2):+(h/2)
            fill        = False in forM_ [(10, (0.0, 0.5, 0, 1.0)),
                                          (30, (0.3, 0.0, 0.8, 1.0)),
                                          (50, (0.0, 0.7, 0.2, 1.0)),
                                          (70, (0.8, 0.8, 0.1, 1.0))] $ \(mini, colour) -> renderPolygon sides (radius mini) origin colour fill

    --  Bouncing balls
    renderWorld world

    -- Circle carousel
    when False $ do
        renderCircleArc 10 origin spread radius begin τ
    where count  = 10
          origin = (w/2):+(h/2)
          spread = 50 + 50 * (1 + sin (τ * rpm * elapsed world)) -- 134      -- Radius of the big circle (pixels?)
          radius = 20       -- Radius of a small circle (pixels?)
          (w,h)  = let (w', h') = size world in (fromIntegral w', fromIntegral h')
          rpm    = 0.3      --
          begin  = τ * rpm * elapsed world

-- |
renderGrid :: Int -> Int -> Double -> C.Render ()
renderGrid cols rows size = do
    sequence_ [ tilePath cl rw >> C.fill   | cl <- [0..(cols-1)], rw <- [0..(rows-1)] ] -- Tiles
    sequence_ [ tilePath cl rw >> C.stroke | cl <- [0..(cols-1)], rw <- [0..(rows-1)] ] -- Borders
    -- TODO: Figure out how to use fill AND stroke
    where chooseColour cl rw = if (cl `mod` 2) == (rw `mod` 2) then 0.3 else 0.75 -- TODO: This should be a utility function
          tilePath cl rw     = C.rectangle (fromIntegral cl*size) (fromIntegral rw*size) size size >> C.setSourceRGBA 0.22 0.81 (chooseColour cl rw) 0.32

-- |
renderArrow :: Complex Double -> Complex Double -> Double -> Double -> Double -> C.Render ()
renderArrow from to sl sw hw = do
    let (first:rest) = closePath $ arrow from to sl sw hw
    vectorise C.moveTo first
    forM_ rest $ vectorise C.lineTo

    -- C.setSourceRGBA 1 0.8 0.15 1.0
    C.setLineWidth 3
    C.stroke

-- |
-- TODO: Add arguments for colour, stroke, etc.
-- TODO: Make polymorphic
renderPolygon :: Int -> Double -> Complex Double -> (Double, Double, Double, Double) -> Bool -> C.Render ()
renderPolygon sides radius origin (r,g,b,a) filled = do
    -- TODO: Refine 'wrap-around logic'
    C.moveTo fx fy
    forM_ rest $ \(x:+y) -> C.lineTo x y

    C.setSourceRGBA r g b a
    C.setLineWidth 12
    if filled
        then C.fill
        else C.stroke
    where ((fx:+fy):rest) = polygon sides radius origin ++ [fx:+fy]

-- |
-- TODO: Options for fill/stroke, colour, width, etc.
renderCircle :: Complex Double -> Double -> C.Render ()
renderCircle (cx:+cy) radius = do
    C.arc cx cy radius 0 τ
    C.fill

-- |
-- TODO: Options for colour, width, closed/open, etc.
renderPath :: [Complex Double] -> C.Render ()
renderPath (p:ath) = do
    vectorise C.moveTo p
    forM_ ath $ vectorise C.lineTo
    C.stroke

-- |
-- Ugh, I hate underscores so much
-- TODO: Make polymorphic
renderCircleArc :: Int -> Complex Double -> Double -> Double -> Double -> Double -> C.Render ()
renderCircleArc
    count    -- Number of small circles
    (ox:+oy) -- Centre of the 'arc' (pixels?)
    spread   -- Radius of the 'arc'
    radius   -- Radius of the small circles
    begin    -- Start angle of the arc
    extent = forM_ [1..count] $ \ n -> do
        let n' = fromIntegral n
        let θ  = begin + n'*extent/fromIntegral count
        C.arc (ox - spread*cos θ) (oy - spread*sin θ) radius 0 τ
        C.setSourceRGBA (0.5 * (1 + sin θ)) (0.1*n') (1/n') 0.95
        C.fill

-- Geometry ---------------------------------------------------------------------------------------
-- |
-- TODO: Start angle
-- TODO: Invalid arguments (eg. sides < 3) (use Maybe?)
-- TODO: Make polymorphic
-- TODO: Move to geometry section
-- polygon :: (Floating f, RealFloat f) => Int -> f -> Complex f -> [Complex f]
polygon :: Int -> Double -> Complex Double -> [Complex Double]
polygon sides radius origin = [ let θ = arg n in origin + ((radius * cos θ):+(radius * sin θ)) | n <- [1..sides]]
    where arg n = fromIntegral n * (2*π)/fromIntegral sides

-- |
-- TODO: Simplify and expound comments
arrow :: Complex Double -> Complex Double -> Double -> Double -> Double -> [Complex Double]
arrow from to sl sw hw = [from     + straight (sw/2), --
                          shaftEnd + straight (sw/2), --
                          shaftEnd + straight (hw/2), --
                          to,                         --
                          shaftEnd - straight (hw/2), --
                          shaftEnd - straight (sw/2), --
                          from     - straight (sw/2)]  --
    where along a b distance = a + (mkPolar distance . snd . polar $ b-a) -- Walk distance along the from a to b
          normal a b = let (mag, arg) = polar (b-a) in mkPolar mag (arg+π/2)
          shaftEnd = along from to sl --
          straight = along (0:+0) (normal from to) -- Vector perpendicular to the centre line
          -- shaftWidth = along (0:+0) (normal a b) (sw/2) -- Half of shaft width (vector relative to symmetry line)
          -- headWidth  = along (0:+0) (normal a b) (hw/2)

-- Utilities --------------------------------------------------------------------------------------
-- |
vectorise :: (Double -> Double -> a) -> Complex Double -> a
vectorise f (re:+im) = f re im

-- |
-- TODO: Unsafe, use Maybe (?)
closePath :: [Complex Double] -> [Complex Double]
closePath path = path ++ [head path]

-- Transforms a vector from one coordinate space to another
-- by applying the given scaling and translation
-- Useful for converting between simulation and screen coordinates
-- TODO: Types for representing coordinate systems
-- TODO: Use matrix instead (scale and translate should be applied in reverse order when undoing the transformation)
-- TODO: Add undo parameter (?)
-- TODO: Pure function, move to Copernicus.hs or use Cairo matrix functions
transform :: Complex Double -> Complex Double -> Complex Double -> Complex Double
transform scaling translation = scale scaling . translate translation

-- |
scale :: Complex Double -> Complex Double -> Complex Double
scale (sx:+sy) (x:+y) = (sx*x):+(sy*y)

-- |
translate :: Complex Double -> Complex Double -> Complex Double
translate = (+)

-- |
toScreenCoords :: World -> Complex Double -> Complex Double
toScreenCoords world = transform (sx:+sy) translation
    where (w, h)   = let (w', h') = size world in (fromIntegral w', fromIntegral h')
          (sx:+sy)    = (w/10):+(-h/10)
          translation = w/(2*sx):+h/(2*sy)

-- | TODO: Implement :/
-- TODO: Dotwise application for Complex numbers
-- TODO: Don't hard-code the world-size of the canvas (currently 10-by-10)
toWorldCoords :: World -> Complex Double -> Complex Double
toWorldCoords world = translate (-translation) . scale (sx**(-1):+sy**(-1))
    where (w, h) = let (w', h') = size world in (fromIntegral w', fromIntegral h')
          (sx:+sy)    = (w/10):+(-h/10)
          translation = (w/(2*sx)):+(h/(2*sy))

-- |
bodyToScreenCoords :: World -> Cop.Body Double -> Cop.Body Double
bodyToScreenCoords world (Cop.Body p v' a') = Cop.Body (toScreenCoords world p) v' a' -- TODO: Make transformation less ad-hoc

---------------------------------------------------------------------------------------------------
-- Entry point
---------------------------------------------------------------------------------------------------
main :: IO ()
main = mainGTK


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase    #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -Wall #-}

{-# OPTIONS_GHC -Wno-deprecations #-} -- for errorWithStackTrace

-- | Miscellany

module ConCat.Misc where

import GHC.Types (Constraint)

-- import Control.Arrow ((&&&))
-- import Data.Type.Equality

import Data.Typeable (Typeable,TypeRep,typeRep,Proxy(..))
import Data.Data (Data)
import Data.Monoid (Endo(..))
import Data.Semigroup (Semigroup(..))
import Data.Complex (Complex)
import GHC.Generics hiding (R)
-- import Unsafe.Coerce (unsafeCoerce)  -- for oops
import GHC.Stack (errorWithStackTrace)  -- for oops
import GHC.TypeLits

import Control.Newtype.Generics

{--------------------------------------------------------------------
    Type abbreviations
-------------------------------------------------------------------
-}

infixr 8 :^
infixl 7 :*
infixl 6 :+
infixr 1 :=>

type s :^ n = n -> s
type (:*)  = (,)
type (:+)  = Either
type (:=>) = (->)

{--------------------------------------------------------------------
    Helpers for GHC.Generics
--------------------------------------------------------------------}

-- | Operate inside a Generic1
inGeneric1 :: (Generic1 f, Generic1 g) => (Rep1 f a -> Rep1 g b) -> (f a -> g b)
inGeneric1 = to1 <~ from1
{-# INLINE inGeneric1 #-}

-- | Apply a unary function within the 'Comp1' constructor.
inComp :: (g (f a) -> g' (f' a')) -> ((g :.: f) a -> (g' :.: f') a')
inComp = Comp1 <~ unComp1
{-# INLINE inComp #-}

-- | Apply a binary function within the 'Comp1' constructor.
inComp2 :: (  g (f a)   -> g' (f' a')     -> g'' (f'' a''))
        -> ((g :.: f) a -> (g' :.: f') a' -> (g'' :.: f'') a'')
inComp2 = inComp <~ unComp1
{-# INLINE inComp2 #-}

-- TODO: phase out inComp and inComp2 in favor of inNew and inNew2.

absurdF :: V1 a -> b
absurdF = \ case
{-# INLINE absurdF #-}

-- infixr 1 +->
-- data (a +-> b) p = Fun1 { unFun1 :: a p -> b p }

-- -- TODO: resolve name conflict with tries. Using ":->:" for functors fits with
-- -- other type constructors in GHC.Generics.

-- instance Newtype ((a +-> b) t) where
--   type O ((a +-> b) t) = a t -> b t
--   pack = Fun1
--   unpack = unFun1

#if 0

{--------------------------------------------------------------------
    Evaluation
--------------------------------------------------------------------}

-- class Evalable e where
--   type ValT e
--   eval :: e -> ValT e

class PrimBasics p where
  unitP :: p ()
  pairP :: p (a :=> b :=> a :* b)

class Evalable p where eval :: p a -> a

-- TODO: Are we still using PrimBasics or Evalable?

#endif

{--------------------------------------------------------------------
    Other
--------------------------------------------------------------------}

type Unop   a = a -> a
type Binop  a = a -> Unop a
type Ternop a = a -> Binop a

infixl 1 <~
infixr 1 ~>

-- | Add pre- and post-processing
(~>) :: forall a b a' b'. (a' -> a) -> (b -> b') -> ((a -> b) -> (a' -> b'))
(f ~> h) g = h . g . f
-- (~>) = flip (<~)
{-# INLINE (~>) #-}

-- | Add post- and pre-processing
(<~) :: forall a b a' b'. (b -> b') -> (a' -> a) -> ((a -> b) -> (a' -> b'))
(h <~ f) g = h . g . f
{-# INLINE (<~) #-}

-- For SEC-style programming. I was using fmap instead, but my rules interfered.
result :: (b -> c) -> ((a -> b) -> (a -> c))
result = (.)
{-# INLINE result #-}

class    Yes0
instance Yes0

class    Yes1 a
instance Yes1 a

class    Yes2 a b
instance Yes2 a b

-- | Compose list of unary transformations
compose :: Foldable f => f (Unop a) -> Unop a
compose = appEndo . foldMap Endo
-- compose = foldr (.) id

infixr 3 `xor`

xor :: Binop Bool
xor = (/=)
{-# NOINLINE xor #-}

newtype Parity = Parity { getParity :: Bool }

instance Newtype Parity where
  type O Parity = Bool
  pack = Parity
  unpack (Parity x) = x

instance Semigroup Parity where
  Parity a <> Parity b = Parity (a `xor` b)

instance Monoid Parity where
  mempty = Parity False
  mappend = (<>)
  -- Parity a `mappend` Parity b = Parity (a `xor` b)

boolToInt :: Bool -> Int
boolToInt c = if c then 1 else 0
{-# INLINE boolToInt #-}

cond :: a -> a -> Bool -> a
cond t e i = if i then t else e
{-# INLINE cond #-}  -- later INLINE?

{--------------------------------------------------------------------
    Type level computations
--------------------------------------------------------------------}

infixr 3 &&

class    (a,b) => a && b
instance (a,b) => a && b

-- Saying (b,a) instead of (a,b) causes Oks k [a,b,c] to expand in order, oddly.
-- TODO: investigate.

infixr 3 &+&
class    (a t, b t) => (a &+& b) t
instance (a t, b t) => (a &+& b) t

class    f b a => Flip f a b
instance f b a => Flip f a b

-- • Potential superclass cycle for ‘&&’
--     one of whose superclass constraints is headed by a type variable: ‘a’
--   Use UndecidableSuperClasses to accept this

-- Same for Flip

type family FoldrC op b0 as where
  FoldrC op z '[]      = z
  FoldrC op z (a : as) = a `op` FoldrC op z as

type family MapC f us where
  MapC f '[]      = '[]
  MapC f (u : us) = f u : MapC f us

-- type Comp g f u = g (f u)
-- -- Operator applied to too few arguments: :
-- type MapC' f us = FoldrC (Comp (':) f) '[] us

type AndC   cs = FoldrC (&&) Yes0 cs
type AllC f us = AndC (MapC f us)

-- type family AndC' cs where
--   AndC' '[]      = Yes0
--   AndC' (c : cs) = c && AndC' cs

-- type family AllC f as where
--   AllC f '[]      = Yes0
--   AllC f (a : as) = f a && AllC f as

-- -- Operator applied to too few arguments: :
-- type as ++ bs = FoldrC (':) bs as

infixr 5 ++
type family as ++ bs where
  '[]      ++ bs = bs
  (a : as) ++ bs = a : as ++ bs

type family CrossWith f as bs where
  CrossWith f '[]      bs = '[]
  CrossWith f (a : as) bs = MapC (f a) bs ++ CrossWith f as bs

-- Illegal nested type family application ‘MapC (f a1) bs
--                                               ++ CrossWith f as bs’
--       (Use UndecidableInstances to permit this)

type AllC2 f as bs = AndC (CrossWith f as bs)

-- | Annotation for pseudo-function, i.e., defined by rules. During ccc
-- generation, don't split applications. TODO: maybe add an arity.
data PseudoFun = PseudoFun { pseudoArgs :: Int } deriving (Typeable,Data)

-- Alternatively, we could keep PseudoFun abstract:

-- pseudoFun :: Int -> PseudoFun
-- pseudoFun = PseudoFun

-- | Pseudo function to fool GHC's divergence checker.
oops :: String -> b
oops str = errorWithStackTrace ("Oops: "++str)
{-# NOINLINE oops #-}

--     In the use of ‘errorWithStackTrace’ (imported from GHC.Stack):
--     Deprecated: "'error' appends the call stack now"

-- When we use error, the divergence checker eliminates a lot of code early. An
-- alternative is unsafeCoerce, but it leads to terrible run-time errors. A safe
-- alternative seems to be errorWithStackTrace. Oddly, the doc for
-- errorWithStackTrace says "Deprecated: error appends the call stack now."

-- | Hack: delay inlining to thwart some of GHC's rewrites
delay :: a -> a
delay a = a
{-# INLINE [0] delay #-}

bottom :: a
-- bottom = error "bottom evaluated"
bottom = oops "bottom evaluated"
{-# NOINLINE bottom #-}

-- Convenient alternative to typeRep
typeR :: forall a. Typeable a => TypeRep
typeR = typeRep (Proxy :: Proxy a)

type R = Double -- Float

type C = Complex R

sqr :: Num a => a -> a
sqr a = a * a
{-# INLINE sqr #-}

magSqr :: Num a => a :* a -> a
magSqr (a,b) = sqr a + sqr b
{-# INLINE magSqr #-}

transpose :: (Traversable t, Applicative f) => t (f a) -> f (t a)
transpose = sequenceA

inTranspose :: (Applicative f, Traversable t, Applicative f', Traversable t')
            => (f (t a) -> t' (f' a)) -> (t (f a) -> f' (t' a))
inTranspose = transpose <~ transpose
{-# INLINE inTranspose #-}
-- inTranspose h = transpose . h . transpose

unzip :: Functor f => f (a :* b) -> f a :* f b
unzip ps = (fst <$> ps, snd <$> ps)
{-# INLINE unzip #-}

natValAt :: forall n. KnownNat n => Integer
natValAt = nat @n

-- Shorter name
nat :: forall n. KnownNat n => Integer
nat = natVal (Proxy @n)
{-# INLINE nat #-}

int :: forall n. KnownNat n => Int
int = fromIntegral (nat @n)
{-# INLINE int #-}

{--------------------------------------------------------------------
    Newtype
--------------------------------------------------------------------}

-- See <https://github.com/jcristovao/newtype-generics/pull/5>

-- Type generalization of underF from newtype-generics.
underF :: (Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f, Functor g)
       => (o -> n) -> (f n -> g n') -> (f o -> g o')
underF _ f = fmap unpack . f . fmap pack
{-# INLINE underF #-}

-- Type generalization of overF from newtype-generics.
overF :: (Newtype n, Newtype n', o' ~ O n', o ~ O n, Functor f, Functor g)
      => (o -> n) -> (f o -> g o') -> (f n -> g n')
overF _ f = fmap pack . f . fmap unpack
{-# INLINE overF #-}

inNew :: (Newtype p, Newtype q) =>
         (O p -> O q) -> (p -> q)
inNew = pack <~ unpack
{-# INLINE inNew #-}

inNew2 :: (Newtype p, Newtype q, Newtype r) =>
          (O p -> O q -> O r) -> (p -> q -> r)
inNew2 = inNew <~ unpack
{-# INLINE inNew2 #-}

-- TODO: use inNew and inNew2 in place of ad hoc versions throughout.

exNew :: (Newtype p, Newtype q) =>
         (p -> q) -> (O p -> O q)
exNew = unpack <~ pack
{-# INLINE exNew #-}

exNew2 :: (Newtype p, Newtype q, Newtype r) =>
          (p -> q -> r) -> (O p -> O q -> O r)
exNew2 = exNew <~ pack
{-# INLINE exNew2 #-}

{--------------------------------------------------------------------
    Constraint shorthands
--------------------------------------------------------------------}

#if 1
-- Experiment. Smaller Core?
type C1 (con :: u -> Constraint) a = con a
type C2 (con :: u -> Constraint) a b = (con a, con b)
type C3 (con :: u -> Constraint) a b c = (con a, con b, con c)
type C4 (con :: u -> Constraint) a b c d = (con a, con b, con c, con d)
type C5 (con :: u -> Constraint) a b c d e = (con a, con b, con c, con d, con e)
type C6 (con :: u -> Constraint) a b c d e f = (con a, con b, con c, con d, con e, con f)
#else
type C1 (con :: u -> Constraint) a = con a
type C2 con a b         = (C1 con a, con b)
type C3 con a b c       = (C2 con a b, con c)
type C4 con a b c d     = (C2 con a b, C2 con c d)
type C5 con a b c d e   = (C3 con a b c, C2 con d e)
type C6 con a b c d e f = (C3 con a b c, C3 con d e f)
#endif


{-# LANGUAGE OverloadedStrings
  , FlexibleInstances
  , GeneralizedNewtypeDeriving
  , MultiParamTypeClasses
  , InstanceSigs
  , QuasiQuotes #-}
module Main where

import Data.List

import Control.Monad.IO.Class
import Control.Monad.Trans
import Control.Monad.Reader

import Data.Maybe
import qualified Data.Vector as V
import Data.Time

import Types
import Persistence

import Colog
import Colog.Message
import Colog.Actions

import Graphics.Rendering.Chart.Easy hiding ((<.>))
import Graphics.Rendering.Chart.Backend.Diagrams (toFile)

import System.Environment
import System.FilePath.Posix
import Statistics.Quantile

import Text.InterpolatedString.Perl6 (qc)

data Env m = Env { _persistence :: Persistence
                 , _logAction :: !(LogAction m Message) }

newtype App e = App { unapp :: ReaderT (Env App) IO e }
    deriving (Monad, Functor, Applicative, MonadIO, MonadReader (Env App))

instance HasPersistence (Env m) where
    getPersistence = _persistence

instance HasLog (Env m) Message m where
    getLogAction = _logAction
    setLogAction newLogAction env = env { _logAction = newLogAction }

indexHtml diagram = [qc|

        <title>SMHI Forecast error</title>

|]

withApp :: Env App -> App () -> IO ()
withApp env f = runReaderT (unapp f) env

-- environment variable with default value in io monad
fromEnv :: String -> String -> IO String
fromEnv d = fmap (fromMaybe d) . lookupEnv

type BoxValues = (Double, Double, Double, Double, Double)

lineStyle :: Double -> Colour Double -> LineStyle
lineStyle n colour = line_width .~ n
                   $ line_color .~ opaque colour
                   $ def

box label color vals = liftEC $ do
    plot_candle_line_style  .= lineStyle 1 color
    plot_candle_fill .= False
    plot_candle_rise_fill_style .= solidFillStyle (opaque color)
    plot_candle_fall_fill_style .= solidFillStyle (opaque color)
    plot_candle_tick_length .= 2
    plot_candle_width .= 8
    plot_candle_centre .= 8
    plot_candle_values .= [ Candle ind mn first med third mx | (ind,(mn,first,med,third,mx)) <- vals]
    plot_candle_title .= label

grpBox :: [HourOffset] -> (Double, (Double, Double, Double, Double, Double))
grpBox os = (k, (mn, q1, q2, q3, mx))
    where k = fromIntegral $ hoursAgo (head os)
          mn = quantile s 1 10 temperatures
          mx = quantile s 9 10 temperatures
          q1 = quantile s 1 4 temperatures
          q2 = quantile s 2 4 temperatures
          q3 = quantile s 3 4 temperatures
          temperatures = V.fromList (map temperatureE os)

every n xs = case drop (n-1) xs of
              (y:ys) -> y : every n ys
              [] -> []

errorsByHour = groupBy (\a b -> hoursAgo a == hoursAgo b) . sortOn hoursAgo

main :: IO ()
main = do
    time <- show <$> getCurrentTime
    outdir <- fromEnv "./" "OUTDIR"
    database <- fromEnv "data.db" "DATABASE"
    image <- fromEnv (outdir </> time <.> "svg") "DIAGRAM"
    index <- fromEnv (outdir </> "index.html") "HTML"

    env <- Env <$> initPersistence database
               <*> pure richMessageAction

    withApp env $ do
        samples <- getHourOffsets
        let grps = errorsByHour samples
            positives = map (filter (\a -> temperatureE a > 0)) grps
            negatives = map (filter (\a -> temperatureE a < 0)) grps
            positivesBoxes = map grpBox $ filter (\grp -> length grp > 2) positives
            negativesBoxes = map grpBox $ filter (\grp -> length grp > 2) negatives

        mae <- getMAE
        liftIO $ toFile def image $ do
            layout_title .= "SMHI Forecast Accuracy (Generated " ++ show time ++")"
            layout_y_axis . laxis_title   .= "Temperature error (C)"
            layout_x_axis . laxis_title   .= "Forecast age (h)"
            layout_x_axis . laxis_reverse .= True

            plot (box "high forecast" blue $ every 10 negativesBoxes)
            plot (box "low forecast"  red  $ every 10 positivesBoxes)

        liftIO $ writeFile index (indexHtml image)


{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}

module Data.Discrimination.Grouping
  ( Group(..)
  , Grouping(..)
  , Grouping1(..)
  -- * Combinators
  , nub, nubWith
  , group, groupWith
  , groupingEq
  , runGroup
  -- * Internals
  , hashing
  , word8s
  ) where

import Control.Monad hiding (mapM_)
import Control.Monad.Primitive
import Control.Monad.ST
import Control.Monad.ST.Unsafe
import Data.Complex
import Data.Discrimination.Internal.WordMap as WordMap
import Data.Foldable hiding (concat)
import Data.Functor.Compose
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import Data.Functor.Contravariant.Generic
import Data.Hashable
import Data.Int
import Data.Semigroup hiding (Any)
import Data.Primitive.MutVar
import Data.Primitive.PrimArray
import Data.Promise
import Data.Proxy
import Data.Ratio
import Data.Typeable
import Data.Void
import Data.Word
import GHC.Integer.GMP.Internals
import GHC.Word
import Numeric.Natural
import Prelude hiding (read, concat, mapM_)

-- | Productive Stable Unordered Discriminator

newtype Group a = Group
  { getGroup :: forall m b. PrimMonad m
             => (b -> m (b -> m ())) -> m (a -> b -> m ())
  } deriving Typeable

instance Contravariant Group where
  contramap f m = Group $ \k -> do
    g <- getGroup m k
    return (g . f)

instance Divisible Group where
  conquer = Group $ \ (k :: b -> m (b -> m ())) -> do
    v <- newMutVar undefined
    writeMutVar v $ \b -> k b >>= writeMutVar v
    return $ \ _ b -> readMutVar v >>= ($ b)

  divide f m n = Group $ \k -> do
    kbcd <- getGroup m $ \ (c, d) -> do
      kcd <- getGroup n k
      kcd c d
      return $ uncurry kcd
    return $ \ a d -> case f a of
      (b, c) -> kbcd b (c, d)

instance Decidable Group where
  choose f m n = Group $ \k -> do
    kb <- getGroup m k
    kc <- getGroup n k
    return (either kb kc . f)

  lose k = Group $ \_ -> return (absurd . k)

instance Semigroup (Group a) where
  (<>) = divide (\a -> (a,a))

instance Monoid (Group a) where
  mempty = conquer
  mappend = (<>)

--------------------------------------------------------------------------------
-- Primitives
--------------------------------------------------------------------------------

groupingWord64 :: Group Word64
groupingWord64 = Group $ \k -> do
  mt <- newMutVar WordMap.empty
  return $ \a b -> readMutVar mt >>= \m -> case WordMap.lookup a m of
    Nothing -> k b >>= \p -> writeMutVar mt (insert a p m)
    Just n -> n b

-- | This may be useful for pragmatically accelerating a grouping structure by
-- preclassifying by a hash function
--
-- Semantically,
--
-- @
-- grouping = hashing <> grouping
-- @
hashing :: Hashable a => Group a
hashing = contramap hash grouping

--------------------------------------------------------------------------------
-- * Unordered Discrimination (for partitioning)
--------------------------------------------------------------------------------

-- | 'Eq' equipped with a compatible stable unordered discriminator.
class Grouping a where
  -- | For every surjection @f@,
  --
  -- @
  -- 'contramap' f 'grouping' ≡ 'grouping'
  -- @

  grouping :: Group a
#ifndef HLINT
  default grouping :: Deciding Grouping a => Group a
  grouping = deciding (Proxy :: Proxy Grouping) grouping
#endif

instance Grouping Void where grouping = lose id
instance Grouping () where grouping = conquer
instance Grouping Word8 where grouping = contramap fromIntegral groupingWord64
instance Grouping Word16 where grouping = contramap fromIntegral groupingWord64
instance Grouping Word32 where grouping = contramap fromIntegral groupingWord64
instance Grouping Word64 where grouping = groupingWord64
instance Grouping Word where grouping = contramap fromIntegral groupingWord64
instance Grouping Int8 where grouping = contramap fromIntegral groupingWord64
instance Grouping Int16 where grouping = contramap fromIntegral groupingWord64
instance Grouping Int32 where grouping = contramap fromIntegral groupingWord64
instance Grouping Int64 where grouping = contramap fromIntegral groupingWord64
instance Grouping Int where grouping = contramap fromIntegral groupingWord64
instance Grouping Char where grouping = contramap (fromIntegral . fromEnum) groupingWord64

instance Grouping Bool
instance (Grouping a, Grouping b) => Grouping (a, b)
instance (Grouping a, Grouping b, Grouping c) => Grouping (a, b, c)
instance (Grouping a, Grouping b, Grouping c, Grouping d) => Grouping (a, b, c, d)
instance Grouping a => Grouping [a]
instance Grouping a => Grouping (Maybe a)
instance (Grouping a, Grouping b) => Grouping (Either a b)
instance Grouping a => Grouping (Complex a) where
  grouping = divide (\(a :+ b) -> (a, b)) grouping grouping

instance Grouping Integer where
  grouping = contramap word8s grouping

word8s :: Integer -> [Word8]
word8s i = runST $ unsafeIOToST $ do
  p@(MutablePrimArray mba) :: MutablePrimArray RealWorld Word8 <- newPrimArray (fromIntegral $ W# (sizeInBaseInteger i 256#))
  _ <- exportIntegerToMutableByteArray i mba 0## 1#
  primArrayToList <$> unsafeFreezePrimArray p

instance Grouping Natural where grouping = contramap toInteger grouping

#if __GLASGOW_HASKELL__ >= 800
instance Grouping a => Grouping (Ratio a) where
#else
instance (Grouping a, Integral a) => Grouping (Ratio a) where
#endif
  grouping = divide (\r -> (numerator r, denominator r)) grouping grouping

instance (Grouping1 f, Grouping1 g, Grouping a) => Grouping (Compose f g a) where
  grouping = getCompose `contramap` grouping1 (grouping1 grouping)

class Grouping1 f where
  grouping1 :: Group a -> Group (f a)
#ifndef HLINT
  default grouping1 :: Deciding1 Grouping f => Group a -> Group (f a)
  grouping1 = deciding1 (Proxy :: Proxy Grouping) grouping
#endif

instance Grouping1 []
instance Grouping1 Maybe
instance Grouping a => Grouping1 (Either a)
instance Grouping a => Grouping1 ((,) a)
instance (Grouping a, Grouping b) => Grouping1 ((,,) a b)
instance (Grouping a, Grouping b, Grouping c) => Grouping1 ((,,,) a b c)
instance (Grouping1 f, Grouping1 g) => Grouping1 (Compose f g) where
  grouping1 f = getCompose `contramap` grouping1 (grouping1 f)
instance Grouping1 Complex where
  grouping1 f = divide (\(a :+ b) -> (a, b)) f f

-- | Valid definition for @('==')@ in terms of 'Grouping'.
groupingEq :: Grouping a => a -> a -> Bool
groupingEq a b = runST $ do
  rn <- newMutVar (0 :: Word8)
  k <- getGroup grouping $ \_ -> do
    modifyMutVar' rn (+1)
    return return
  k a ()
  k b ()
  n <- readMutVar rn
  return $ n == 1
{-# INLINE groupingEq #-}

runGroup :: Group a -> [(a,b)] -> [[b]]
runGroup (Group m) xs = runLazy (\p0 -> do
    rp <- newMutVar p0
    f <- m $ \ b -> do
      p <- readMutVar rp
      q <- promise []
      p' <- promise []
      p != (b : demand q) : demand p'
      writeMutVar rp p'
      rq <- newMutVar q
      return $ \b' -> do
        q' <- readMutVar rq
        q'' <- promise []
        q' != b' : demand q''
        writeMutVar rq q''
    mapM_ (uncurry f) xs
  ) []

--------------------------------------------------------------------------------
-- * Combinators
--------------------------------------------------------------------------------

-- | /O(n)/. Similar to 'Data.List.group', except we do not require groups to be clustered.
--
-- This combinator still operates in linear time, at the expense of storing history.
--
-- The result equivalence classes are __not__ sorted, but the grouping is stable.
--
-- @
-- 'group' = 'groupWith' 'id'
-- @
group :: Grouping a => [a] -> [[a]]
group as = runGroup grouping [(a, a) | a <- as]

-- | /O(n)/. This is a replacement for 'GHC.Exts.groupWith' using discrimination.
--
-- The result equivalence classes are __not__ sorted, but the grouping is stable.
groupWith :: Grouping b => (a -> b) -> [a] -> [[a]]
groupWith f as = runGroup grouping [(f a, a) | a <- as]

-- | /O(n)/. This upgrades 'Data.List.nub' from @Data.List@ from /O(n^2)/ to /O(n)/ by using
-- productive unordered discrimination.
--
-- @
-- 'nub' = 'nubWith' 'id'
-- 'nub' as = 'head' 'Control.Applicative.<$>' 'group' as
-- @
nub :: Grouping a => [a] -> [a]
nub = nubWith id

-- | /O(n)/. Online 'nub' with a Schwartzian transform.
--
-- @
-- 'nubWith' f as = 'head' 'Control.Applicative.<$>' 'groupWith' f as
-- @
nubWith :: Grouping b => (a -> b) -> [a] -> [a]
nubWith f xs = runLazy (\p0 -> do
    rp <- newMutVar p0
    k <- getGroup grouping $ \a -> do
      p' <- promise []
      p <- readMutVar rp
      p != a : demand p'
      writeMutVar rp p'
      return $ \ _ -> return ()
    mapM_ (\x -> k (f x) x) xs
  ) []


{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeApplications          #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE QuasiQuotes               #-}
{-# LANGUAGE AllowAmbiguousTypes       #-}
{-# LANGUAGE PolyKinds                 #-}
{-# LANGUAGE PartialTypeSignatures     #-}
module Main where

import           Control.Lens                    ((^.))
import qualified Control.Foldl                   as FL
import           Control.Monad.IO.Class          (MonadIO(liftIO))
import qualified Data.Map                        as M
import           Data.Maybe                      (catMaybes)
import qualified Data.Monoid                     as MO
import           Data.Proxy                      (Proxy(..))
import qualified Data.Text                       as T
import qualified Data.Text.IO                    as T
import qualified Data.Text.Lazy                  as TL
import qualified Data.Time.Calendar              as Time
import qualified Data.Vinyl                      as V
import qualified Data.Vinyl.TypeLevel            as V
import qualified Frames                          as F
import           Frames                          ((:->),(<+>),(&:))
import qualified Frames.CSV                      as F
import qualified Frames.InCore                   as F hiding (inCoreAoS)
import qualified Pipes                           as P
import qualified Pipes.Prelude                   as P
import qualified Statistics.Types               as S

import qualified Text.Blaze.Html.Renderer.Text  as BH

import qualified Frames.ParseableTypes as FP
import qualified Frames.VegaLite as FV
import qualified Frames.Transform as FT
import qualified Frames.Folds as FF
import qualified Frames.Regression as FR
import qualified Frames.MapReduce as MR
import qualified Frames.Table as Table

import qualified Frames.Visualization.VegaLite.Data        as FHV
import qualified Graphics.Vega.VegaLite.Configuration as VLC
import qualified Frames.Visualization.VegaLite.Histogram as FHV

import qualified Knit.Report                    as K
import qualified Knit.Report.Other.Blaze        as KB

import           Data.String.Here (here)

import           BlueRipple.Data.DataFrames

templateVars = M.fromList
  [
    ("lang", "English")
  , ("author", "Adam Conner-Sax")
  , ("pagetitle", "BlueRipple Adam Mission")
--  , ("tufte","True")
  ]

loadCSVToFrame :: forall rs effs. ( MonadIO (K.Sem effs)
                                  , K.LogWithPrefixesLE effs
                                  , F.ReadRec rs
                                  , F.RecVec rs
                                  , V.RMap rs)
               => F.ParserOptions -> FilePath -> (F.Record rs -> Bool) -> K.Sem effs (F.FrameRec rs)
loadCSVToFrame po fp filterF = do
  let --producer :: F.MonadSafe m => P.Producer rs m ()
      producer = F.readTableOpt po fp P.>-> P.filter filterF
  frame <- liftIO $ F.inCoreAoS producer
  let reportRows :: Foldable f => f x -> FilePath -> K.Sem effs ()
      reportRows f fn = K.logLE K.Diagnostic $ T.pack (show $ FL.fold FL.length f) <> " rows in " <> T.pack fn
  reportRows frame fp
  return frame

main :: IO ()
main = do
  let template = K.FromIncludedTemplateDir "mindoc-pandoc-KH.html"
  pandocWriterConfig <- K.mkPandocWriterConfig template
                                               templateVars
                                               K.mindocOptionsF
  let knitConfig = K.defaultKnitConfig
        { K.outerLogPrefix = Just "mission.Main"
        , K.logIf = K.logAll
        , K.pandocWriterConfig = pandocWriterConfig
        }
  eitherDocs <- K.knitHtmls knitConfig $ do
    -- load the data
    let parserOptions = F.defaultParser { F.quotingMode =  F.RFC4180Quoting ' ' }
    K.logLE K.Info "Loading data..."
    totalSpendingFrame :: F.Frame TotalSpending <- loadCSVToFrame parserOptions totalSpendingCSV (const True)
    totalSpendingBeforeFrame :: F.Frame TotalSpending <- loadCSVToFrame parserOptions totalSpendingBeforeCSV (const True)
    totalSpendingDuringFrame :: F.Frame TotalSpending <- loadCSVToFrame parserOptions totalSpendingDuringCSV (const True)
    forecastAndSpendingFrame :: F.Frame ForecastAndSpending <- loadCSVToFrame parserOptions forecastAndSpendingCSV (const True)
    electionResultsFrame :: F.Frame ElectionResults <- loadCSVToFrame parserOptions electionResultsCSV (const True)
    contextDemographicsFrame :: F.Frame ContextDemographics <- loadCSVToFrame parserOptions contextDemographicsCSV (const True)
    angryDemsFrame :: F.Frame AngryDems <- loadCSVToFrame parserOptions angryDemsCSV (const True)
--    reportRows angryDemsFrame "angryDems"
    K.logLE K.Info "Knitting..."
    K.newPandoc (K.PandocInfo "mission" M.empty) $ do
      totalSpendingHistograms totalSpendingFrame
      spendVsChangeInVoteShare totalSpendingDuringFrame totalSpendingFrame forecastAndSpendingFrame electionResultsFrame
      angryDemsAnalysis angryDemsFrame
  case eitherDocs of
    Right namedDocs ->   K.writeAllPandocResultsWithInfoAsHtml "mission/html" namedDocs --T.writeFile "mission/html/mission.html" $ TL.toStrict  $ htmlAsText
    Left err -> putStrLn $ "pandoc error: " ++ show err
--
{-
TODO
** Trends
** Registration (see Census)
* Repeat Runners
* local races?
* Ballot initiatives?
* GOTV
-}
--
angryDemsNotes :: T.Text
angryDemsNotes
  = [here|
## Angry Democrats Donations
* The [angry democrats post][AngryDemPost] generated a variety of donation size.
* As the histogram below shows, donations were mostly small with a few much larger ones.

[AngryDemPost]: <https://medium.com/@frank_s_david/angrydems-cc7e8caefe7b>
|]

angryDemsAnalysis :: K.KnitOne effs => F.Frame AngryDems -> K.Sem effs ()
angryDemsAnalysis angryDemsFrame = do
  -- aggregate by ReceiptID
  K.addMarkDown angryDemsNotes
  let byDonationFrame = FL.fold (MR.concatFold $ MR.mapReduceFold
                                 MR.noUnpack
                                 (MR.assignKeysAndData @'[ReceiptID] @'[Amount])
                                 (MR.foldAndAddKey (FF.foldAllMonoid @MO.Sum)))
                        angryDemsFrame
      vc = VLC.ViewConfig 800 400 50
  _ <- K.addHvega Nothing Nothing $
    FHV.singleHistogram @Amount "Angry Democrats Donations" (Just "# Donations") 10 VLC.Default False vc byDonationFrame
  _ <- K.addHvega Nothing Nothing $
    FHV.singleHistogram @Amount "Angry Democrats Donations (<$3000)" (Just "# Donations") 10 (VLC.GivenMinMax 0 3000) True vc byDonationFrame
  _ <- K.addHvega Nothing Nothing $
    FHV.singleHistogram @Amount "Angry Democrats Donations (<$200)" (Just "# Donations") 10 (VLC.GivenMinMax 0 200) True vc byDonationFrame
  return ()

--
spendFor r = (r ^. disbursement) + (r ^. indSupport) + realToFrac (r ^. partyExpenditures)
spendAgainst r = r ^. indOppose
proxyRace = Proxy :: Proxy '[StateAbbreviation, CongressionalDistrict]

type RaceTotalFor = "race_total_for" :-> Double
type RaceTotalAgainst = "race_total_against" :-> Double
type RaceTotalCands = "race_total_cands" :-> Int
type CandidateDiffSpend  = "candidate_diff_spend" :-> Double
type ResultVsForecast = "result_vs_forecast" :-> Double

differentialSpendNotes :: T.Text
differentialSpendNotes
  = [here|
## Differential Spending and changes in the race
* Below we look at the spending of each candidate from 8/1/2018 (the earliest date for which we have any polling/forecast data) through election day 2018.  Since we are interested in whether that spending affects the outcome of a race, we pair the spending data with an estimated change in vote share, calculated using the [538][538_house] forecast on 8/1 and the actual election result.
* Candidates, committees and parties spend money on behalf of candidates.  But Committees (Super-PACs) etc. can also spend money *against* candidates.  That makes it hard to determine how much was spent on behalf of each candidate.  We take the simplistic approach of assuming that money spent against a candidate is exactly like money spent for the opposing candidate(s).  If there is more than one opposing candidate, we divide it evenly among them.
* We divide each candidates total spending by the total spent on the entire race by all candidates, considering % of spending by each candidate rather than the actual dollars spent.  We do this so we can compare races with very different levels of spending.
* We visualize this data a couple of ways.  First, a histogram of the differential spending and then a scatter-plot of differential spending vs change in vote-share, along with a simple regression. If anything, this regression shows that extra spending has a slightly negative correlation with changes in vote-share; in line with [this][538_electionMoney] 538 story about how money affects elections.

[538_house]:<https://projects.fivethirtyeight.com/2018-midterm-election-forecast/house/>
[538_electionMoney]: <https://fivethirtyeight.com/features/money-and-elections-a-complicated-love-story/>
|]

setF :: V.KnownField t => V.Snd t -> V.ElField t
setF = V.Field

-- differential spend vs (result - 8/1 forecast)
spendVsChangeInVoteShare :: K.KnitOne effs
  => F.Frame TotalSpending -> F.Frame TotalSpending -> F.Frame ForecastAndSpending -> F.Frame ElectionResults -> K.Sem effs ()
spendVsChangeInVoteShare spendingDuringFrame totalSpendingFrame fcastAndSpendFrame eResultsFrame = K.wrapPrefix "spendVsChangeInVoteShare" $ do
  -- create a Frame with each candidate, candidate total, race total, candidate differential
  -- use aggregateFs by aggregating by [StateAbbreviation,CongressionalDistrict] and then use extract to turn those records into the ones we want
  K.logLE K.Info "Transforming spending before, forecasts and spending during, and election results..."
  let firstForecastFrame = fmap (F.rcast @[CandidateId, StateAbbreviation, CongressionalDistrict, CandidateParty, Voteshare]) $
        F.filterFrame (\r -> r ^. date == FP.FrameDay (Time.fromGregorian 2018 08 01)) fcastAndSpendFrame
  K.logLE K.Info "Filtered forecasts for first voteshare forecast on 8/1/2018 to get first forecast by candidateId"
  let proxyRace = Proxy :: Proxy '[StateAbbreviation, CongressionalDistrict]
      spendAgainst r = (r ^. indOppose)
      raceTotalsF = FF.sequenceRecFold (FF.recFieldF @RaceTotalCands FL.length id
                                        V.:& FF.recFieldF @RaceTotalFor FL.sum spendFor
                                        V.:& FF.recFieldF @RaceTotalAgainst FL.sum spendAgainst
                                        V.:& V.RNil)
      raceTotalFrameF = (MR.concatFold $ MR.mapReduceFold
                          MR.noUnpack
                          (MR.assignKeys @[StateAbbreviation, CongressionalDistrict])
                          (MR.ReduceFold $ \_ -> let f t c = fmap (V.rappend t) c in f <$> raceTotalsF <*> FL.list ))

      raceTotalFrame = F.toFrame $ fmap (F.rcast @[CandidateId,RaceTotalFor,RaceTotalAgainst,RaceTotalCands]) $ FL.fold raceTotalFrameF totalSpendingFrame

      retypeCols = FT.retypeColumn @RaceTotalFor @("race_during_for" :-> Double)
                   . FT.retypeColumn @RaceTotalAgainst @("race_during_against" :-> Double)
      raceDuringFrame = F.toFrame $ fmap (retypeCols . F.rcast @[CandidateId,RaceTotalFor,RaceTotalAgainst,Disbursement,IndSupport,IndOppose,PartyExpenditures])
                        $ FL.fold raceTotalFrameF spendingDuringFrame
  K.logLE K.Info "aggregated by race (state and district) to get total spending by race and then attached that to each candidateId"
  -- all ur joins r belong to us
  let selectResults = fmap (F.rcast @[CandidateId, FinalVoteshare])
      fRFrame = F.toFrame $ catMaybes $ fmap F.recMaybe $ F.leftJoin @'[CandidateId] firstForecastFrame (selectResults eResultsFrame)
      fRTFrame = F.toFrame $ catMaybes $ fmap F.recMaybe $ F.leftJoin @'[CandidateId] fRFrame raceTotalFrame
      fRTBFrame = F.toFrame $ catMaybes $ fmap F.recMaybe $ F.leftJoin @'[CandidateId] fRTFrame raceDuringFrame
  K.logLE K.Info $ "Did all the joins. Final frame has " <> T.pack (show $ FL.fold FL.length fRTBFrame) <> " rows."
  let addCandDiff r = FT.recordSingleton @CandidateDiffSpend $ 100*candSpend/totalSpend where
        allCandsFor = F.rgetField @RaceTotalFor r
        allCandsAgainst = F.rgetField @RaceTotalAgainst r
        allCandsAgainstDuring = F.rgetField @("race_during_against" :-> Double) r
        allCandsForDuring = F.rgetField @("race_during_for" :-> Double) r
        nCands = F.rgetField @RaceTotalCands r
        candForDuring = spendFor r
        candAgainstDuring = spendAgainst r
        candSpend = candForDuring + (allCandsAgainstDuring - realToFrac candAgainstDuring)/(realToFrac nCands - 1)
        totalSpend = allCandsForDuring + allCandsAgainstDuring
      addResultVsForecast r = FT.recordSingleton @ResultVsForecast $ (finalVS - forecastVS) where
        forecastVS = F.rgetField @Voteshare r
        finalVS = F.rgetField @FinalVoteshare r
      addAll r = addCandDiff r <+> addResultVsForecast r
      contestedRacesFrame = F.filterFrame ((==2) . F.rgetField @RaceTotalCands) $ fmap (FT.mutate addAll) fRTBFrame
  K.logLE K.Info $ "Added normalized differential spend and filtered to cheap and close races. " <> (T.pack $ show (FL.fold FL.length contestedRacesFrame)) <> " rows left."
  K.addMarkDown differentialSpendNotes
  K.addMarkDown "### All Races With 2 or more candidates"
  _ <- K.addHvega Nothing Nothing  $
    FHV.singleHistogram @CandidateDiffSpend "Distribution of Differential Spending (8/1/2018-11/6/2018)" (Just "# Candidates") 10 VLC.Default True (VLC.ViewConfig 800 400 50) contestedRacesFrame
  diffSpendVsdiffVs <- FR.ordinaryLeastSquares @_ @ResultVsForecast @True @'[CandidateDiffSpend] contestedRacesFrame
  _ <- K.addHvega Nothing Nothing $ FV.frameScatterWithFit "Differential Spending vs Change in Voteshare (8/1/208-11/6/2018)" (Just "regression") diffSpendVsdiffVs S.cl95 contestedRacesFrame
  K.addBlaze $ FR.prettyPrintRegressionResultBlaze (\y _ -> "Regression Details") diffSpendVsdiffVs S.cl95
  _ <- K.addHvega Nothing Nothing $ FV.regressionCoefficientPlot "Parameters" ["intercept","differential spend"] (FR.regressionResult diffSpendVsdiffVs) S.cl95
  let filterCloseAndCheap r =
        let vs = F.rgetField @Voteshare r
            rtf = F.rgetField @RaceTotalFor r
            rta = F.rgetField @RaceTotalAgainst r
            party = F.rgetField @CandidateParty r
        in (vs > 40) && (vs < 60) && ((rtf + rta) < 2000000) -- && (party == "Republican")
      cheapAndCloseFrame = F.filterFrame filterCloseAndCheap  contestedRacesFrame
  K.addMarkDown "### All Races With 2 or more candidates, total spending below $2,000,000, and first forecast closer than 60/40."
  _ <- K.addHvega Nothing Nothing  $
    FHV.singleHistogram @CandidateDiffSpend "Distribution of Differential Spending (8/1/2018-11/6/2018)" (Just "# Candidates") 10 VLC.Default True (VLC.ViewConfig 800 400 50) cheapAndCloseFrame
  diffSpendVsdiffVs <- FR.ordinaryLeastSquares @_ @ResultVsForecast @True @'[CandidateDiffSpend] cheapAndCloseFrame
  _ <- K.addHvega Nothing Nothing $ FV.frameScatterWithFit "Differential Spending vs Change in Voteshare (8/1/208-11/6/2018)" (Just "regression") diffSpendVsdiffVs S.cl95 cheapAndCloseFrame
  K.addBlaze $ FR.prettyPrintRegressionResultBlaze (\y _ -> "Regression Details") diffSpendVsdiffVs S.cl95
  _ <- K.addHvega Nothing Nothing $ FV.regressionCoefficientPlot "Parameters" ["intercept","differential spend"] (FR.regressionResult diffSpendVsdiffVs) S.cl95
  K.addMarkDown "### All Races With 2 or more candidates, total spending below $2,000,000, and first forecast closer than 60/40."

-- Spending histograms
spendingHistNotes :: T.Text
spendingHistNotes
  = [here|
## Spending By Party in 2018 House Races
* The bar charts below summarize the distribution of per-candidate spending in 2018 house races.  The top chart shows all the candidates, the one below zooms in on candidates who spent less than $1,000,000 and the one below that zooms in further to candidates who spent less than $100,000.
* These were produced with data from the [FEC][FECMain], using the open-data [API][FECAPI].
* This chart includes candidate expenditures, independent expenditures in support of the candidate and party expenditures on behalf of the candidate.  It ignores independent expenditures *against* the candidate, which can be considerable in some races. See the [FEC web-site for more information][FECDefs] about all of these categories.

[FECMain]: <https://www.fec.gov/>
[FECAPI]: <https://api.open.fec.gov/developers/>
[FECDefs]: <https://www.fec.gov/data/browse-data/?tab=spending>
|]

type AllSpending = "all_spending" F.:-> Double
sumSpending r =
  let db = realToFrac $ F.rgetField @Disbursement r
      is = realToFrac $ F.rgetField @IndSupport r
      pe = realToFrac $ F.rgetField @PartyExpenditures r
  in FT.recordSingleton @AllSpending (db + is + pe)

totalSpendingHistograms :: K.KnitOne effs
  => F.Frame TotalSpending -> K.Sem effs ()
totalSpendingHistograms tsFrame = do
  K.addMarkDown spendingHistNotes
  let frameWithSum = F.filterFrame ((>0). F.rgetField @AllSpending) $ fmap (FT.mutate sumSpending) tsFrame
      mergeOtherParties :: F.Record '[CandidateParty] -> F.Record '[CandidateParty]
      mergeOtherParties r =
        let p = F.rgetField @CandidateParty r
            np = case p of
              "Republican" -> "Republican"
              "Democrat" -> "Democrat"
              _ -> "_AllOthers"
        in FT.recordSingleton @CandidateParty np
      frameWithMergedOtherParties = fmap (FT.transform mergeOtherParties) frameWithSum
      vc = VLC.ViewConfig 800 400 50
--  K.log K.Diagnostic $ T.pack $ show $ fmap (show . F.rcast @[CandidateId, AllSpending]) $ FL.fold FL.list frameWithSum
  _ <- K.addHvega Nothing Nothing  $
    FHV.multiHistogram @AllSpending @CandidateParty "Distribution of Spending By Party" (Just "# Candidates") 10 (VLC.GivenMinMax 0 1e7) True FHV.AdjacentBar vc frameWithMergedOtherParties
  _ <- K.addHvega Nothing Nothing  $
    FHV.multiHistogram @AllSpending @CandidateParty "Distribution of Spending By Party (< $1,000,000)" (Just "# Candidates") 10 (VLC.GivenMinMax 0 1e6) False FHV.AdjacentBar vc frameWithMergedOtherParties
  _ <- K.addHvega Nothing Nothing  $
    FHV.multiHistogram @AllSpending @CandidateParty "Distribution of Spending By Party (< $100,000)" (Just "# Candidates") 10 (VLC.GivenMinMax 0 1e5) False FHV.AdjacentBar vc frameWithMergedOtherParties
  return ()