{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Data.Semigroup.Free where

import GHC.Generics
import GHC.Read
import Control.Applicative
import Data.Functor.Classes
import Data.Functor.Identity
import Data.Semigroup
import Data.List.NonEmpty (NonEmpty(..))
import Data.Coerce
import Data.List (sortOn)
import Control.Monad
import Control.Monad.Free (Free(..), MonadFree(..), iterA)
import Control.Monad.Free.Church (F(..))
import qualified Control.Monad.Free.Church as F
import Data.Pair

import Criterion
import Criterion.Main
import Criterion.Types
import Data.Proxy (Proxy(..), asProxyTypeOf)
import Statistics.Types

import Weigh (Weigh, func, mainWith, wgroup)

-- | Size notes:
--
-- @
--  So a single element weighs ~400 bytes.
--    Supposing a MArray has a 1-byte overhead per element,
--    could we get a ~2 byte overhead per element if we stored every 400 elements in a MArray?
--    Ehh.. I don't know if the price of copying arrays will offset the cost..
--
--  What if we only access one cycle element at a time?
--    In that case, it's probably better to simply carry around a list and cons onto it.
--
--  What if we have a predictable cycle-size?
--    In that case, it's probably best to use pre-allocated memory
--    Possibly a pool of smaller pre-allocated chunks
-- @
--
sizeNotes :: ()
sizeNotes = ()

-- | Note:
--
-- @
--  On one hand, it seems nice to preserve the commutativity of the GappedIxCycle's
--  On the other hand, it takes O(min n m) time to zip two GappedIxCycle's together.
--  On the other hand, I'm not sure it needs to be anything other than a []/Seq/Set of period-1 cycles whose LCM is the given period. (that would give O(1) (<>))
-- @
--
notes :: ()
notes = ()

---- A strict finite collection of single-element cycles with:
---- O(1) `return`, `cons`, `snoc`, and `mappend`.
----
---- Pretty much everything else is much slower than lists.
---- (This data type's main features are its strictness and ability to `mappend`
---- two structures in constant time.)
----
---- Isomorphic to a strict version of:
----
---- @
----  GappedCycle a == Free Pair (Int, a)
----  wrap :: Pair (Free Pair (Int, a)) -> Free Pair (Int, a)
---- @
----
---- Which is effectively "pairing for free", exactly what we want.
----
---- Take a look at this:
----
---- @
----  F f a = F { runF :: forall r. (a -> r) -> (f r -> r) -> r }
----  F Pair a = F { runF :: forall r. (a -> r) -> (Pair r -> r) -> r }
----  F Pair a = F { runF :: forall r. (a -> r) -> (r -> r -> r) -> r }
----  F Pair a = F { runF :: forall r. (a -> r) -> (r -> r -> r) -> r }
----  F Pair a = F { runF :: forall r. Semigroup r => (a -> r) -> r }
----  F Pair a = FreeSemigroup a
---- @
----
----
--data GappedCycle a where
--  GCPure :: !Int -> !a -> GappedCycle a -- Period, Value
--  GCMappend :: !(GappedCycle a) -> !(GappedCycle a) -> GappedCycle a
--
--
-- |
--
-- @
--  GappedCycle a == Free Pair (Int, a)
-- @
--
-- data IntGappedCycle where
--   IGCPure :: !Int -> !Int -> IntGappedCycle -- Period, Value
--   IGCMappend :: !IntGappedCycle -> !IntGappedCycle -> IntGappedCycle
--

-- fun idea to test collection of bijections:
-- - make graph of bijections
-- - randomly traverse the graph until loop
-- - test equality with looped

-- If there are no edges, fails with an error.
-- Otherwise:
-- - randomly select a vertex with positive degree
-- - randomly select an adjacent vertex
-- - if the randomly selected vertex has been visited already, return all previous values
-- - otherwise add to collection of visited
-- randomCycleFrom :: Graph a -> m [a]

-- Interesting:
--   Store an array as a Set and a multi-permutation (index table) -- for fast updates, order, and no-repeated values
--   Or an ordered array and a (muti)-permutation -- read/write is fast, bsearch is fast, most combinations/alterations are very slow.

-- | `Alternative` without `empty`
class Applicative f => Semialternative f where
  (<!>) :: f a -> f a -> f a

  saconcat :: NonEmpty (f a) -> f a
  saconcat ~(x :| xs) =
    case xs of
      [] -> x
      ~(y:ys) -> x <!> saconcat (y :| ys)

  saconcatMap :: (a -> f b) -> NonEmpty a -> f b
  saconcatMap f = saconcat . fmap f

instance Semialternative NonEmpty where
  (<!>) = (<>)

-- | Wrap a `Semialternative` to provide a `Semigroup` instance
newtype WrapSemialternative f a = WrapSemialternative { runWrapSemialternative :: f a }

instance Semialternative f => Semigroup (WrapSemialternative f a) where
  {-# INLINE (<>) #-}
  (<>) :: WrapSemialternative f a -> WrapSemialternative f a -> WrapSemialternative f a
  (<>) x y = coerce $ coerce x <!> (coerce `asTypeOf` runWrapSemialternative) y

-- | A free `Semigroup` is a `Semialternative` that we can `foldMap1` over
-- (`foldMap` specialized to non-empty inputs) and convert to any other
-- `SemigroupFree` (they're all isomorphic to each other).
class Semialternative f => SemigroupFree f where
  foldMap1 :: Semigroup s => (a -> s) -> f a -> s
  foldMap1 f xs = runFSemigroup (semigroupFree xs) f

  semigroupFree :: SemigroupFree g => f a -> g a
  semigroupFree = runWrapSemialternative . foldMap1 (WrapSemialternative . pure)

  {-# MINIMAL foldMap1 | semigroupFree #-}

instance SemigroupFree NonEmpty where
  foldMap1 f ~(x :| xs) = loop x xs
    where
      loop x [] = f x
      loop x ~(y:ys) = f x <> loop x ys

-- | From the triangle benchmakrs, this is the fastest.
-- How fast? @~100x@ faster than `NonEmpty`, taking
-- @~180 ms@ to construct and destruct a triangle with
-- around a million elements.
--
-- For a little comparison, the average human blink of an eye
-- is around @100-400 ms@ (according to WolframAlpha). I can
-- process a trangular collection of a million elements in less
-- then half the average time that it takes to blink an eye!
--
-- That's @~180 ns@ per element..
--
-- My computer has a @3.1 GHz@ processor. Assuming total utilization
-- of a single core, we get a cycle-duration of @~0.323 ns@. That
-- gives us an estimate of @557@ cycles per element.
--
-- That's not the greatest. I'll have to check CPU utilization for that benchmark to see if it's skewing my quick math.
-- (267.2%?, not sure what to make of that. need to run without criterion to remove overhead)
-- Though it's still not bad for a pure, polymorphic data type.
--
-- All in all, this data type is plenty fast for its primary purpose:
-- quickly accumulating cycle-pieces when calculating the final cycle.
data FreeSemigroup a where
  PureFreeSemigroup :: a -> FreeSemigroup a
  AppendFreeSemigroup :: FreeSemigroup a -> FreeSemigroup a -> FreeSemigroup a
  deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)

instance Semigroup (FreeSemigroup a) where
  {-# INLINE (<>) #-}
  (<>) = AppendFreeSemigroup

instance Applicative FreeSemigroup where
  {-# INLINE pure #-}
  pure = PureFreeSemigroup

  PureFreeSemigroup f <*> xs = f <$> xs
  f <*> PureFreeSemigroup x = ($ x) <$> f
  ~(AppendFreeSemigroup fs gs) <*> ~(AppendFreeSemigroup xs ys) = AppendFreeSemigroup (fs <*> xs) (gs <*> ys)

instance Semialternative FreeSemigroup where
  {-# INLINE (<!>) #-}
  (<!>) = AppendFreeSemigroup

instance SemigroupFree FreeSemigroup where
  semigroupFree (PureFreeSemigroup x) = pure x
  semigroupFree (AppendFreeSemigroup xs ys) = semigroupFree xs <!> semigroupFree ys

-- | `semigroupFree` specialized to `FreeSemigroup`
{-# INLINE toFreeSemigroup #-}
toFreeSemigroup :: SemigroupFree f => f a -> FreeSemigroup a
toFreeSemigroup = semigroupFree

-- | It looks like this sucks around the [2^12..2^16] elements range
data FreeSemigroup' a where
  PureFreeSemigroup' :: !a -> FreeSemigroup' a
  AppendFreeSemigroup' :: !(FreeSemigroup' a) -> !(FreeSemigroup' a) -> FreeSemigroup' a
  deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)

instance Semigroup (FreeSemigroup' a) where
  {-# INLINE (<>) #-}
  (<>) = AppendFreeSemigroup'

instance Applicative FreeSemigroup' where
  {-# INLINE pure #-}
  pure !x = PureFreeSemigroup' x

  PureFreeSemigroup' f <*> xs = f <$> xs
  f <*> PureFreeSemigroup' x = ($ x) <$> f
  ~(AppendFreeSemigroup' fs gs) <*> ~(AppendFreeSemigroup' xs ys) = AppendFreeSemigroup' (fs <*> xs) (gs <*> ys)

instance Semialternative FreeSemigroup' where
  {-# INLINE (<!>) #-}
  (<!>) = AppendFreeSemigroup'

instance SemigroupFree FreeSemigroup' where
  semigroupFree (PureFreeSemigroup' x) = pure x
  semigroupFree (AppendFreeSemigroup' xs ys) = semigroupFree xs <!> semigroupFree ys

-- | `Free`-based `FreeSemigroup`
newtype FreePS a = FreePS { runFreePS :: Free Pair a } deriving (Eq, Ord, Show, Read, Functor, Applicative, Monad)

deriving instance MonadFree Pair FreePS

instance Semialternative FreePS where
  (<!>) = fmap (wrap . Pair) . (,)

instance SemigroupFree FreePS where
  semigroupFree = iterA (uncurry (<!>) . getPair) . runFreePS

-- | `F`-based `FreeSemigroup`
newtype FPS a = FPS { runFPS :: F Pair a } deriving (Functor, Applicative, Monad)

deriving instance MonadFree Pair FPS

instance Semialternative FPS where
  (<!>) = fmap (wrap . Pair) . (,)

instance SemigroupFree FPS where
  semigroupFree = F.iter (uncurry (<!>) . getPair) . fmap pure . runFPS

-- | Partially applied `foldMap1` wrapped in a @newtype@.
newtype FSemigroup a = FSemigroup { runFSemigroup :: forall s. Semigroup s => (a -> s) -> s } deriving (Functor)

instance Eq a => Eq (FSemigroup a) where
  {-# INLINE (==) #-}
  x == y = toFreeSemigroup x == toFreeSemigroup y

instance Ord a => Ord (FSemigroup a) where
  {-# INLINE compare #-}
  compare x y = toFreeSemigroup x `compare` toFreeSemigroup y

instance Show a => Show (FSemigroup a) where
  {-# INLINE show #-}
  show = show . toFreeSemigroup

instance Semigroup (FSemigroup a) where
  {-# INLINE (<>) #-}
  FSemigroup x <> FSemigroup y = FSemigroup $ \cnv -> y cnv <> y cnv

instance Applicative FSemigroup where
  {-# INLINE pure #-}
  pure x = FSemigroup $ \cnv -> cnv x

  {-# INLINE liftA2 #-}
  liftA2 f (FSemigroup xs) (FSemigroup ys) = FSemigroup $ \cnv -> ys . xs $ fmap cnv . f

instance Semialternative FSemigroup where
  {-# INLINE (<!>) #-}
  FSemigroup x <!> FSemigroup y = FSemigroup $ \cnv -> x cnv <> y cnv

instance SemigroupFree FSemigroup where
  {-# INLINE foldMap1 #-}
  foldMap1 cnv (FSemigroup xs) = xs cnv

-- | `FSemigroup` with explicitly provided @(`<>`)@.
--
-- Slightly faster in triangle benchmarks.
newtype FS a = FS
  { runFS :: forall s. (s -> s -> s) -> (a -> s) -> s
  } deriving (Functor)

instance Eq a => Eq (FS a) where
  {-# INLINE (==) #-}
  x == y = toFreeSemigroup x == toFreeSemigroup y

instance Ord a => Ord (FS a) where
  {-# INLINE compare #-}
  compare x y = toFreeSemigroup x `compare` toFreeSemigroup y

instance Show a => Show (FS a) where
  {-# INLINE show #-}
  show = show . toFreeSemigroup

instance Semigroup (FS a) where
  {-# INLINE (<>) #-}
  FS x <> FS y = FS $ \append cnv -> x append cnv `append` y append cnv

instance Applicative FS where
  {-# INLINE pure #-}
  pure x = FS $ \append cnv -> cnv x

  {-# INLINE liftA2 #-}
  liftA2 f (FS xs) (FS ys) =
    FS $ \append cnv -> ys append . xs (liftA2 append) $ fmap cnv . f

instance Semialternative FS where
  {-# INLINE (<!>) #-}
  FS x <!> FS y = FS $ \append cnv -> x append cnv `append` y append cnv

instance SemigroupFree FS where
  {-# INLINE foldMap1 #-}
  foldMap1 cnv (FS xs) = xs (<>) cnv

-- | Lift function application to strict function application
{-# INLINE liftS2 #-}
liftS2 :: (a -> b -> c) -> a -> b -> c
liftS2 f x y = f x' y'
  where
    !x' = x
    !y' = y

-- | Strict `FSemigroup` with explicitly provided @(`<>`)@.
newtype FS' a = FS'
  { runFS' :: forall s. (s -> s -> s) -> (a -> s) -> s
  } deriving (Functor)

instance Eq a => Eq (FS' a) where
  {-# INLINE (==) #-}
  x == y = toFreeSemigroup x == toFreeSemigroup y

instance Ord a => Ord (FS' a) where
  {-# INLINE compare #-}
  compare x y = toFreeSemigroup x `compare` toFreeSemigroup y

instance Show a => Show (FS' a) where
  {-# INLINE show #-}
  show = show . toFreeSemigroup

instance Semigroup (FS' a) where
  {-# INLINE (<>) #-}
  FS' x <> FS' y = FS' $ \append cnv -> x append cnv `append` y append cnv

instance Applicative FS' where
  {-# INLINE pure #-}
  pure x = let !x' = x in FS' $ \_ cnv -> cnv x'

  {-# INLINE liftA2 #-}
  liftA2 f (FS' xs) (FS' ys) =
    FS' $ \append cnv -> ys append . xs (liftA2 append) $ fmap cnv . f

instance Semialternative FS' where
  {-# INLINE (<!>) #-}
  FS' x <!> FS' y = FS' $ \append cnv -> x append cnv `append` y append cnv

instance SemigroupFree FS' where
  {-# INLINE foldMap1 #-}
  foldMap1 cnv (FS' xs) = xs (liftS2 (<>)) (cnv $!)

-- | A concatenated "triangle" of values:
--
-- @
--  saconcat [1] <> saconcat [1, 2] <> saconcat [1, 2, 3] <> .. <> saconcat [1..n]
-- @
--
makeTriangle :: Semialternative f => Int -> f Int
makeTriangle n | n < 1 = error "makeTriangle: non-positive input"
makeTriangle 1 = pure 1
makeTriangle n = makeTriangle (n - 1) <!> makeLine n

-- | Conveniently construct and `Sum` a triangle of `SemigroupFree` values
-- for benchmarking.
destructTriangle :: SemigroupFree f => Proxy f -> Int -> Int
destructTriangle prxy = getSum . foldMap1 Sum . (`asProxyTypeOf` proxyApInt prxy) . makeTriangle

-- | A concatenated line of values
--
-- @
--  saconcat [1..n]
-- @
makeLine :: Semialternative f => Int -> f Int
makeLine n = saconcatMap pure [1..n]

-- | Conveniently construct and `Sum` a line of `SemigroupFree` values
-- for benchmarking.
destructLine :: SemigroupFree f => Proxy f -> Int -> Int
destructLine prxy = getSum . foldMap1 Sum . (`asProxyTypeOf` proxyApInt prxy) . makeLine

-- | Apply `Int` to a type inside a @proxy@
proxyApInt :: proxy g -> Proxy (g Int)
proxyApInt _ = Proxy

-- | Benchmark `destructTriangle`
benchTriangle :: SemigroupFree f => Proxy f -> Int -> Benchmarkable
benchTriangle prxy !x = nf (destructTriangle prxy) x

-- | Benchmark `destructLine`
benchLine :: SemigroupFree f => Proxy f -> Int -> Benchmarkable
benchLine prxy !x = nf (destructLine prxy) x

-- | Weigh `destructTriangle`
weighTriangle :: SemigroupFree f => String -> Proxy f -> Int -> Weigh ()
weighTriangle name prxy !sz = func desc' (destructTriangle prxy) sz
  where
    desc' = unwords [name, "destructTriangle, size:", show sz]

-- | Weigh `destructLine`
weighLine :: SemigroupFree f => String -> Proxy f -> Int -> Weigh ()
weighLine name prxy !sz = func desc' (destructLine prxy) sz
  where
    desc' = unwords [name, "destructLine    , size:", show sz]

-- | `weighTriangle` and `weighLine` for powers of @2@
-- in experimentally derived ranges.
weighPow2s :: SemigroupFree f => String -> Proxy f -> Weigh ()
weighPow2s name prxy = wgroup name $ do
  forM_ ([5..15] :: [Int]) $ weighLine name prxy . (2 ^)
  forM_ ([1..10] :: [Int]) $ weighTriangle name prxy . (2 ^)

type Est = Estimate ConfInt Double

reportEstimate :: Report -> Est
reportEstimate = anMean . reportAnalysis

estimate :: Benchmarkable -> IO Est
estimate = fmap reportEstimate . benchmark'

quickEstimate :: Benchmarkable -> IO Est
quickEstimate = fmap reportEstimate . benchmarkWith' quickConfig

quickConfig :: Config
quickConfig =
  defaultConfig {confInterval = cl90, timeLimit = 1, resamples = 100}

-- | `benchTriangle` and `benchLine` for powers of @2@
-- in experimentally derived ranges.
benchPow2s :: SemigroupFree f => String -> Proxy f -> Benchmark
benchPow2s name prxy =
  bgroup name $
  ((\n -> (name ++ " Triangle: " ++ show n) `bench` benchTriangle prxy n) .
   (2 ^) <$>
   [1 .. 10]) ++
  ((\n -> (name ++ " Line: " ++ show n) `bench` benchLine prxy n) . (2 ^) <$>
   [5 .. 15])

-- | `sequenceA` a benchmark over all of the `SemigroupFree` implementations
benchable :: Applicative f => (forall g. SemigroupFree g => String -> Proxy g -> f a) -> f [a]
benchable f = sequenceA
  [ f "NonEmpty      " (Proxy @NonEmpty)
  , f "FreeSemigroup " (Proxy @FreeSemigroup)
  , f "FreeSemigroup'" (Proxy @FreeSemigroup')
  , f "FreePS        " (Proxy @FreePS)
  , f "FPS           " (Proxy @FPS)
  , f "FSemigroup    " (Proxy @FSemigroup)
  , f "FS            " (Proxy @FS)
  , f "FS'           " (Proxy @FS')
  ]

weighFS :: Weigh ()
weighFS = void $ benchable weighPow2s

runWeighFS :: IO ()
-- runWeighFS = mainWith $ weighPow2s "FS" (Proxy @FS)
runWeighFS = mainWith weighFS

benchCompare :: Int -> (forall g. SemigroupFree g => Proxy g -> Benchmarkable) -> IO ()
benchCompare n f = do
  results <- sortOn (estPoint . snd) <$> benchable (\n prxy -> (n, ) <$> estimate (f prxy))
  let resultNames = fst <$> results
  appendFile "orderings.txt" . unlines $ show n : resultNames ++ [""]
  mapM_ (\(n, e) -> putStrLn n >> putStrLn ("  " ++ show e)) results

benchFS :: [Benchmark]
benchFS = runIdentity $ benchable (fmap Identity . benchPow2s)

runBenchFS :: IO ()
runBenchFS =
  forM_ ([8,8+40..1414] :: [Int]) $ \i -> do
    putStrLn ""
    putStrLn $
      unwords
        [ "Benchmarking Triangle with input:"
        , show i
        , "(size"
        , show (sum [n | n <- [1 .. i]])
        , ")"
        ]
    benchCompare i (`benchTriangle` i)


{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE OverloadedStrings     #-}
module Taiji.Pipeline.ATACSeq.Functions.QC
    ( plotFragDistr
    , plotAlignQC
    , plotDupRate
    , plotTE
    , plotPeakCor

    , computeTE
    , fragDistr
    , alignStat
    , peakSignal
    ) where

import Language.Javascript.JMacro
import           Bio.Pipeline.Report
import Bio.Data.Bed.Utils
import Bio.Data.Bed.Types
import Bio.RealWorld.GENCODE
import Bio.Data.Bed
import Bio.Utils.Functions (slideAverage)
import qualified Data.ByteString.Char8 as B
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as UM
import Data.Binary
import           Bio.Pipeline.Utils
import qualified Data.Map.Strict               as M
import qualified Data.Text as T
import Bio.HTS
import Statistics.Correlation (pearsonMatByRow)
import Statistics.Matrix (fromRows, toRowLists)

import           Taiji.Pipeline.ATACSeq.Types
import Taiji.Utils.Plot.ECharts
import Taiji.Utils (readGenesValidated)
import           Taiji.Prelude
import qualified Taiji.Utils.DataFrame as DF

plotAlignQC :: [(String, Double, Double)]
            -> Maybe EChart
plotAlignQC xs
    | null xs = Nothing
    | otherwise = Just $ yAxisLabel "Percent" >+> options >+> toolbox >+> plt
  where
    plt = (bar df){_height=480,_width=w}
    w = max 480 $ fromIntegral (length xs) * 30 + 40
    options = [jmacroE| { grid: {top: 60} } |]
    df = DF.mkDataFrame ["mappable", "chrM"] names $
        [p, chrM]
    (names, p, chrM) = unzip3 $
        map (\(a,b,c) -> (T.pack a, 100*b, 100*c)) xs

-- | Return name, percent_mapped_reads and percent_chrM_reads.
alignStat :: ATACSeq S (Either (File tags1 'Bam) (File tags2 'Bam))
          -> IO (String, Double, Double)
alignStat e = do
    stats <- either bamStat bamStat $ e^.replicates._2.files
    let p = fromIntegral (_mapped_tags stats) / fromIntegral (_total_tags stats)
        chrM = case lookup "chrM" (_mapped_tags_by_chrom stats) of
            Nothing -> case lookup "M" (_mapped_tags_by_chrom stats) of
                Nothing -> 0
                Just x -> fromIntegral x / fromIntegral (_mapped_tags stats)
            Just x -> fromIntegral x / fromIntegral (_mapped_tags stats)
    return (nm, p, chrM)
  where
    nm = printf "%s_rep%d" (T.unpack $ e^.eid) (e^.replicates._1)

plotDupRate :: [ATACSeq S (Either (File tags1 'Bam) (File tags2 'Bam))]
            -> [EChart]
plotDupRate [] = []
plotDupRate input =
    [ yAxisLabel "Usable reads (Million)" >+> options >+> toolbox >+> (bar totalReads){_height=480,_width=w}
    , yAxisLabel "Percent duplicated" >+> options >+> toolbox >+> (bar dupRate){_height=480,_width=w}
    ]
  where
    w = max 480 $ fromIntegral (length input) * 20 + 40
    options = [jmacroE| { grid: {top: 60} }|]
    (dupRate, totalReads) = DF.unzip $ DF.mkDataFrame [""] names [dat]
    (names, dat) = unzip $ mapMaybe getDupRate input
    getDupRate e = case either getResult getResult (e^.replicates._2.files) of
        Nothing -> Nothing
        Just r ->  Just
            (T.pack $ printf "%s_rep%d" (T.unpack $ e^.eid) (e^.replicates._1), r)
    getResult fl = do
        total <- fmap (read . T.unpack) $ M.lookup "READ" $ fl^.info
        dup <- fmap (read . T.unpack) $ M.lookup "DUPLICATE TOTAL" $ fl^.info
        return (100 * dup / total, total / 1000000)

peakSignal :: ATACSeqConfig config
           => ( ATACSeq S (Either (File '[Gzip] 'Bed) (File '[PairedEnd, Gzip] 'Bed))
              , File '[Gzip] 'Bed )   -- ^ Reference peak list
           -> ReaderT config IO (ATACSeq S (File '[] 'Other))
peakSignal (atac, peakFl) = do
    dir <- asks _atacseq_output_dir >>= getPath . (<> (asDir "/Peaks"))
    let output = printf "%s/%s_rep%d.signal.bin" dir (T.unpack $ atac^.eid)
            (atac^.replicates._1)
    atac & replicates.traverse.files %%~ liftIO . ( \fl -> do
        regions <- runResourceT $ runConduit $ streamBedGzip (peakFl^.location) .|
            concatMapC (splitBedBySizeLeft 500) .| sinkList :: IO [BED3]
        let readInput = either (streamBedGzip . (^.location))
                (\x -> streamBedGzip (x^.location) .| concatMapC f)
        res <- runResourceT $ runConduit $ readInput fl .|
            rpkmBed regions :: IO (U.Vector Double)
        encodeFile output res
        return $ location .~ output $ emptyFile )
  where
    f :: BED -> [BED]
    f x = [ BED (x^.chrom) (x^.chromStart) (x^.chromStart + 1) (x^.name) Nothing (Just True)
          , BED (x^.chrom) (x^.chromEnd - 1) (x^.chromEnd) (x^.name) Nothing (Just False) ]

-- | Compute correlation between experiments.
plotPeakCor :: [ATACSeq S (File '[] 'Other)] -> IO (Maybe EChart)
plotPeakCor inputs
    | length inputs == 0 || length inputs > 100 = return Nothing
    | otherwise = do
        let names = flip map inputs $ \x ->
                (x^.eid) <> "_rep" <> T.pack (show $ x^.replicates._1)
        cor <- fmap (pearsonMatByRow . fromRows) $ forM inputs $ \input ->
            decodeFile $ input^.replicates._2.files.location
        let plt = heatmap $ DF.orderDataFrame id $
                DF.mkDataFrame names names $ toRowLists cor
        return $ Just $ addAttr (title "Pearson correlation") $ addAttr toolbox plt

plotTE :: [(T.Text, U.Vector Double)] -> [EChart]
plotTE [] = []
plotTE xs = [p1{_width=w,_height=480}, p2{_width=480,_height=480}]
  where
    p1 = addAttr toolbox $ addAttr (yAxisLabel "TSS Enrichment") $ stackBar $
        DF.mkDataFrame [""] names [map U.maximum vals]
    w = max 480 $ fromIntegral (length xs) * 30 + 40
    p2 = addAttr toolbox $ addAttr (yAxisLabel "TSS Enrichment") $
        line $ DF.mkDataFrame names (map (T.pack . show) [-2000..2000::Int]) $
        map U.toList vals
    (names, vals) = unzip xs

computeTE :: ATACSeqConfig config
          => ATACSeq S (Either (File '[Gzip] 'Bed) (File '[PairedEnd, Gzip] 'Bed))
          -> ReaderT config IO (T.Text, U.Vector Double)
computeTE input = do
    genes <- getAnnotation >>= liftIO . readGenesValidated
    let tss = flip map genes $ \g ->
            let chr = geneChrom g
                str = geneStrand g
                x = if str then geneLeft g else geneRight g
            in (chr, x, str)
        readInput = either (streamBedGzip . (^.location))
            (\x -> streamBedGzip (x^.location) .| concatMapC f)
    res <- liftIO $ runResourceT $ runConduit $
        readInput (input^.replicates._2.files) .| tssEnrichment tss
    return (input^.eid <> "_rep" <> T.pack (show $ input^.replicates._1), res)
  where
    f :: BED -> [BED]
    f x = [ BED (x^.chrom) (x^.chromStart) (x^.chromStart + 1) (x^.name) Nothing (Just True)
          , BED (x^.chrom) (x^.chromEnd - 1) (x^.chromEnd) (x^.name) Nothing (Just False) ]

-- | Transcription Start Site (TSS) Enrichment Score
-- The TSS enrichment calculation is a signal to noise calculation.
-- The reads around a reference set of TSSs are collected to
-- form an aggregate distribution of reads centered on the TSSs
-- and extending to 1000 bp in either direction (for a total of 2000bp).
-- This distribution is then normalized by taking the average
-- read depth in the 100 bps at each of the end flanks of
-- the distribution (for a total of 200bp of averaged data) and
-- calculating a fold change at each position over that average
-- read depth. This means that the flanks should start at 1,
-- and if there is high read signal at transcription start
-- sites (highly open regions of the genome) there should be an
-- increase in signal up to a peak in the middle. We take the signal
-- value at the center of the distribution after this normalization
-- as our TSS enrichment metric. Used to evaluate ATAC-seq.
--
-- 1. For each TSS, get per base coverage for the 1000 bp flanking region.
--    We will get a matrix of #TSS x 2000 bp dimension.
-- 2. Do a column sum of the matrix.
-- 3. Sum of the coverage of the endFlank (100bp) at both ends and divide
--    by 200 bp to get a normalization factor.
-- 4. divide the the normalization factor for -1900 to + 1900 bp to get per base normalized coverage.
-- 5. do a smoothing with a defined window (50bp by default) using zoo::rollmean.
-- 6. select the highest value within a window (highest_tss_flank, 50 bp by default)
--    around the TSS because the highest peak is not necessary at exactly the TSS
--    site (position 0)
tssEnrichment :: [(B.ByteString, Int, Bool)]   -- ^ A list of TSSs
              -> ConduitT BED o (ResourceT IO) (U.Vector Double)
tssEnrichment tss = mapC getCutSite .| intersectBedWith f regions .| sink
  where
    sink = do
        vec <- liftIO $ UM.replicate 4000 0
        mapM_C $ mapM_ $ UM.unsafeModify vec (+1)
        liftIO $ normalize <$> U.unsafeFreeze vec
    normalize vec = slideAverage 5 $ U.map (/bk) vec
      where
        bk = (U.sum (U.take 100 vec) + U.sum (U.drop 3900 vec)) / 200 + 0.1
    getCutSite x = BED3 (x^.chrom) i $ i + 1
      where
        i = case x^.strand of
            Just False -> x^.chromEnd - 76
            _ -> x^.chromStart + 75
    f x ys = flip map ys $ \y -> case y^.strand of
        Just False -> 3999 - (x^.chromStart - y^.chromStart)
        _ -> x^.chromStart - y^.chromStart
    regions = map ( \(chr, x, str) ->
        BED chr (x - 2000) (x + 2000) Nothing Nothing $ Just str ) tss

-- | Plot QC for fragment size distribution.
plotFragDistr :: [Maybe (T.Text, U.Vector Double)] -> [EChart]
plotFragDistr xs = flip map (catMaybes xs) $ \(nm, dat) ->
    let df = DF.mkDataFrame ["fraction"] labels [U.toList dat]
    in addAttr (yAxisLabel "Fraction") $
        addAttr (title (T.unpack nm)) (stackLine df){_width=400, _height=480}
  where
    labels = map (T.pack . show) [0..1000 :: Int]

-- | Compute fragment size distribution.
fragDistr :: ATACSeq S (Either (File tags1 'Bam) (File tags2 'Bam))
          -> IO (Maybe (T.Text, U.Vector Double))
fragDistr input = case input^.replicates._2.files of
    Left _ -> return Nothing
    Right fl -> do
        r <- runResourceT $ runConduit $
            streamBam (fl^.location) .| fragmentSizeDistr 1001
        return $ Just (nm, r)
  where
    nm = (input^.eid) <> "_rep" <> (T.pack $ show $ input^.replicates._1)


module GDAL.Complex (
    Complex(..)
  , module C
) where

import Data.Complex as C hiding (Complex(..))
import qualified Data.Complex as C

newtype Complex a =
  Complex { unComplex :: C.Complex a }
  deriving (Eq)

instance Show a => Show (Complex a) where
  show (Complex c) = show c


{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeOperators              #-}

#if __GLASGOW_HASKELL__ >=706
{-# LANGUAGE PolyKinds #-}
#endif

#if __GLASGOW_HASKELL__ >=702
{-# LANGUAGE Trustworthy                #-}
#endif

-- | A class of non-empty data structures that can be folded to a summary value.
module Data.Foldable1 (
    Foldable1(..),
    foldr1, foldr1',
    foldl1, foldl1',
    intercalate1,
    foldrM1,
    foldlM1,
    foldrMapM1,
    foldlMapM1,
    maximumBy,
    minimumBy,
    ) where

import Data.Foldable      (Foldable, foldlM, foldr)
import Data.List          (foldl, foldl')
import Data.List.NonEmpty (NonEmpty (..))
import Data.Semigroup
       (Dual (..), First (..), Last (..), Max (..), Min (..), Product (..),
       Semigroup (..), Sum (..))
import Prelude
       (Maybe (..), Monad (..), Ord, Ordering (..), id, seq, ($!), ($), (.),
       (=<<), flip, const)

import qualified Data.List.NonEmpty as NE

#if MIN_VERSION_base(4,4,0)
import Data.Complex (Complex (..))
import GHC.Generics
       (M1 (..), Par1 (..), Rec1 (..), V1, (:*:) (..), (:+:) (..), (:.:) (..))
import Prelude      (error)
#endif

#if MIN_VERSION_base(4,6,0)
import Data.Ord (Down (..))
#endif

#if MIN_VERSION_base(4,8,0)
import qualified Data.Monoid as Mon
#endif

#if !MIN_VERSION_base(4,12,0)
import Data.Orphans ()
#endif

#ifdef MIN_VERSION_tagged
import Data.Tagged (Tagged (..))
#endif

-- Instances
import Control.Applicative.Backwards (Backwards (..))
import Control.Applicative.Lift      (Lift (..))
import Control.Monad.Trans.Identity  (IdentityT (..))
import Data.Functor.Compose          (Compose (..))
import Data.Functor.Identity         (Identity (..))
import Data.Functor.Reverse          (Reverse (..))
import Data.Tree                     (Tree (..))

import qualified Data.Functor.Product as Functor
import qualified Data.Functor.Sum     as Functor

-- coerce
#if __GLASGOW_HASKELL__ <708
import Unsafe.Coerce (unsafeCoerce)
#else
import Data.Coerce (Coercible, coerce)
#endif

-- $setup
-- >>> import Prelude hiding (foldr1, foldl1, head, last, minimum, maximum)

-------------------------------------------------------------------------------
-- Foldable1 type class
-------------------------------------------------------------------------------

-- | Non-empty data structures that can be folded.
class Foldable t => Foldable1 t where
#if __GLASGOW_HASKELL__ >= 708
    {-# MINIMAL foldMap1 | foldrMap1 #-}
#endif

    -- At some point during design it was possible to define this class using
    -- only 'toNonEmpty'. But it seems a bad idea in general.
    --
    -- So currently we require either foldMap1 or foldrMap1
    --
    -- * foldMap1 defined using foldrMap1
    -- * foldrMap1 defined using foldMap1
    --
    -- One can alsays define instance using following pattern:
    --
    --     toNonEmpty = ...
    --     foldMap f     = foldMap f     . toNonEmpty
    --     foldrMap1 f g = foldrMap1 f g . toNonEmpty

    -- | Combine the elements of a structure using a semigroup.
    fold1 :: Semigroup m => t m -> m
    fold1 = foldMap1 id

    -- | Map each element of the structure to a semigroup,
    -- and combine the results.
    --
    -- >>> foldMap1 Sum (1 :| [2, 3, 4])
    -- Sum {getSum = 10}
    --
    foldMap1 :: Semigroup m => (a -> m) -> t a -> m
    foldMap1 f = foldrMap1 f (\a m -> f a <> m)

    -- | A variant of 'foldMap1' that is strict in the accumulator.
    --
    -- >>> foldMap1' Sum (1 :| [2, 3, 4])
    -- Sum {getSum = 10}
    --
    foldMap1' :: Semigroup m => (a -> m) -> t a -> m
    foldMap1' f = foldlMap1' f (\m a -> m <> f a)

    -- | List of elements of a structure, from left to right.
    --
    -- >>> toNonEmpty (Identity 2)
    -- 2 :| []
    --
    toNonEmpty :: t a -> NonEmpty a
    toNonEmpty = runNonEmptyDList . foldMap1 singleton

    -- | The largest element of a non-empty structure.
    --
    -- >>> maximum (32 :| [64, 8, 128, 16])
    -- 128
    --
    maximum :: Ord a => t a -> a
    maximum = getMax #. foldMap1' Max

    -- | The least element of a non-empty structure.
    --
    -- >>> minimum (32 :| [64, 8, 128, 16])
    -- 8
    --
    minimum :: Ord a => t a -> a
    minimum = getMin #. foldMap1' Min

    -- | The first element of a non-empty structure.
    --
    -- >>> head (1 :| [2, 3, 4])
    -- 1
    --
    head :: t a -> a
    head = getFirst #. foldMap1 First

    -- | The last element of a non-empty structure.
    --
    -- >>> last (1 :| [2, 3, 4])
    -- 4
    --
    last :: t a -> a
    last = getLast #. foldMap1 Last

    -- | Generalized 'foldr1'.
    foldrMap1 :: (a -> b) -> (a -> b -> b) -> t a -> b
    foldrMap1 f g xs =
        appFromMaybe (foldMap1 (FromMaybe #. h) xs) Nothing
      where
        h a Nothing  = f a
        h a (Just b) = g a b

    -- | Generalized 'foldl1''.
    foldlMap1' :: (a -> b) -> (b -> a -> b) -> t a -> b
    foldlMap1' f g xs =
        foldrMap1 f' g' xs SNothing
      where
        -- f' :: a -> SMaybe b -> b
        f' a SNothing  = f a
        f' a (SJust b) = g b a

        -- g' :: a -> (SMaybe b -> b) -> SMaybe b -> b
        g' a x SNothing  = x $! SJust (f a)
        g' a x (SJust b) = x $! SJust (g b a)

    -- | Generalized 'foldl1'.
    foldlMap1 :: (a -> b) -> (b -> a -> b) -> t a -> b
    foldlMap1 f g xs =
        appFromMaybe (getDual (foldMap1 ((Dual . FromMaybe) #. h) xs)) Nothing
      where
        h a Nothing  = f a
        h a (Just b) = g b a

    -- | Generalized 'foldr1''.
    foldrMap1' :: (a -> b) -> (a -> b -> b) -> t a -> b
    foldrMap1' f g xs =
        foldlMap1 f' g' xs SNothing
      where
        f' a SNothing  = f a
        f' a (SJust b) = g a b

        g' bb a SNothing  = bb $! SJust (f a)
        g' bb a (SJust b) = bb $! SJust (g a b)

-------------------------------------------------------------------------------
-- Combinators
-------------------------------------------------------------------------------

-- | Right-associative fold of a structure.
--
-- In the case of lists, 'foldr1', when applied to a binary operator,
-- and a list, reduces the list using the binary operator,
-- from right to left:
--
-- > foldr1 f [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn1 `f` xn )...)
--
-- Note that, since the head of the resulting expression is produced by
-- an application of the operator to the first element of the list,
-- 'foldr1' can produce a terminating expression from an infinite list.
--
-- For a general 'Foldable1' structure this should be semantically identical
-- to,
--
-- @foldr1 f = foldr1 f . 'toNonEmpty'@
--
foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a
foldr1 = foldrMap1 id
{-# INLINE foldr1 #-}

-- | Right-associative fold of a structure, but with strict application of
-- the operator.
--
foldr1' :: Foldable1 t => (a -> a -> a) -> t a -> a
foldr1' = foldrMap1' id
{-# INLINE foldr1' #-}

-- | Left-associative fold of a structure.
--
-- In the case of lists, 'foldl1', when applied to a binary
-- operator, and a list, reduces the list using the binary operator,
-- from left to right:
--
-- > foldl1 f [x1, x2, ..., xn] == (...((x1 `f` x2) `f`...) `f` xn
--
-- Note that to produce the outermost application of the operator the
-- entire input list must be traversed. This means that 'foldl1' will
-- diverge if given an infinite list.
--
-- Also note that if you want an efficient left-fold, you probably want to
-- use 'foldl1'' instead of 'foldl1'. The reason for this is that latter does
-- not force the "inner" results (e.g. @x1 \`f\` x2@ in the above example)
-- before applying them to the operator (e.g. to @(\`f\` x3)@). This results
-- in a thunk chain \(\mathcal{O}(n)\) elements long, which then must be
-- evaluated from the outside-in.
--
-- For a general 'Foldable1' structure this should be semantically identical
-- to,
--
-- @foldl1 f z = foldl1 f . 'toNonEmpty'@
--
foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a
foldl1 = foldlMap1 id
{-# INLINE foldl1 #-}

-- | Left-associative fold of a structure but with strict application of
-- the operator.
--
-- This ensures that each step of the fold is forced to weak head normal
-- form before being applied, avoiding the collection of thunks that would
-- otherwise occur. This is often what you want to strictly reduce a finite
-- list to a single, monolithic result (e.g. 'length').
--
-- For a general 'Foldable1' structure this should be semantically identical
-- to,
--
-- @foldl1' f z = foldl1 f . 'toNonEmpty'@
--
foldl1' :: Foldable1 t => (a -> a -> a) -> t a -> a
foldl1' = foldlMap1' id
{-# INLINE foldl1' #-}

-- | Insert an @m@ between each pair of @t m@.
--
-- >>> intercalate1 ", " $ "hello" :| ["how", "are", "you"]
-- "hello, how, are, you"
--
-- >>> intercalate1 ", " $ "hello" :| []
-- "hello"
--
-- >>> intercalate1 mempty $ "I" :| ["Am", "Fine", "You?"]
-- "IAmFineYou?"
--
intercalate1 :: (Foldable1 t, Semigroup m) => m -> t m -> m
intercalate1 = flip intercalateMap1 id

intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m
intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f)

-- | Monadic fold over the elements of a non-empty structure,
-- associating to the right, i.e. from right to left.
foldrM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a
foldrM1 = foldrMapM1 return

-- | Map variant of 'foldrM1'.
foldrMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (a -> b -> m b) -> t a -> m b
foldrMapM1 g f = go . toNonEmpty
  where
    go (e:|es) =
      case es of
        []   -> g e
        x:xs -> f e =<< go (x:|xs)

-- | Monadic fold over the elements of a non-empty structure,
-- associating to the left, i.e. from left to right.
foldlM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a
foldlM1 = foldlMapM1 return

-- | Map variant of 'foldlM1'.
foldlMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (b -> a -> m b) -> t a -> m b
foldlMapM1 g f t = g x >>= \y -> foldlM f y xs
  where x:|xs = toNonEmpty t

-- | The largest element of a non-empty structure with respect to the
-- given comparison function.

-- See Note [maximumBy/minimumBy space usage]
maximumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a
maximumBy cmp = foldl1' max'
  where max' x y = case cmp x y of
                        GT -> x
                        _  -> y

-- | The least element of a non-empty structure with respect to the
-- given comparison function.

-- See Note [maximumBy/minimumBy space usage]
minimumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a
minimumBy cmp = foldl1' min'
  where min' x y = case cmp x y of
                        GT -> y
                        _  -> x

-------------------------------------------------------------------------------
-- Auxiliary types
-------------------------------------------------------------------------------

-- | Used for default toNonEmpty implementation.
newtype NonEmptyDList a = NEDL { unNEDL :: [a] -> NonEmpty a }

instance Semigroup (NonEmptyDList a) where
  xs <> ys = NEDL (unNEDL xs . NE.toList . unNEDL ys)
  {-# INLINE (<>) #-}

-- | Create dlist with a single element
singleton :: a -> NonEmptyDList a
singleton = NEDL #. (:|)

-- | Convert a dlist to a non-empty list
runNonEmptyDList :: NonEmptyDList a -> NonEmpty a
runNonEmptyDList = ($[]) . unNEDL
{-# INLINE runNonEmptyDList #-}

-- | Used for foldrMap1 and foldlMap1 definitions
newtype FromMaybe b = FromMaybe { appFromMaybe :: Maybe b -> b }

instance Semigroup (FromMaybe b) where
    FromMaybe f <> FromMaybe g = FromMaybe (f . Just . g)

-- | Strict maybe, used to implement default foldlMap1' etc.
data SMaybe a = SNothing | SJust !a

-- | Used to implement intercalate1/Map
newtype JoinWith a = JoinWith {joinee :: (a -> a)}

instance Semigroup a => Semigroup (JoinWith a) where
  JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j

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

instance Foldable1 NonEmpty where
    foldMap1 f (x :| xs) = go (f x) xs where
        go y [] = y
        go y (z : zs) = y <> go (f z) zs

    foldMap1' f (x :| xs) = foldl' (\m y -> m <> f y) (f x) xs

    toNonEmpty = id

    foldrMap1 g f (x :| xs) = go x xs where
        go y [] = g y
        go y (z : zs) = f y (go z zs)

    foldlMap1  g f (x :| xs) = foldl f (g x) xs
    foldlMap1' g f (x :| xs) = let gx = g x in gx `seq` foldl' f gx xs

    head = NE.head
    last = NE.last

#if MIN_VERSION_base(4,6,0)
instance Foldable1 Down where
    foldMap1 = coerce
#endif

#if MIN_VERSION_base(4,4,0)
instance Foldable1 Complex where
    foldMap1 f (x :+ y) = f x <> f y

    toNonEmpty (x :+ y) = x :| y : []
#endif

-------------------------------------------------------------------------------
-- Instances for tuples
-------------------------------------------------------------------------------

-- 3+ tuples are not Foldable/Traversable

instance Foldable1 ((,) a) where
    foldMap1 f (_, y) = f y
    toNonEmpty (_, x) = x :| []
    minimum (_, x) = x
    maximum (_, x) = x
    head (_, x) = x
    last (_, x) = x

-------------------------------------------------------------------------------
-- Monoid / Semigroup instances
-------------------------------------------------------------------------------

instance Foldable1 Dual where
    foldMap1 = coerce

instance Foldable1 Sum where
    foldMap1 = coerce

instance Foldable1 Product where
    foldMap1 = coerce

instance Foldable1 Min where
    foldMap1 = coerce

instance Foldable1 Max where
    foldMap1 = coerce

instance Foldable1 First where
    foldMap1 = coerce

instance Foldable1 Last where
    foldMap1 = coerce

#if MIN_VERSION_base(4,8,0)
deriving instance (Foldable1 f) => Foldable1 (Mon.Alt f)
#endif

#if MIN_VERSION_base(4,12,0)
deriving instance (Foldable1 f) => Foldable1 (Mon.Ap f)
#endif

-------------------------------------------------------------------------------
-- GHC.Generics instances
-------------------------------------------------------------------------------

#if MIN_VERSION_base(4,4,0)
instance Foldable1 V1 where
    foldMap1 _ x = x `seq` error "foldMap1 @V1"

instance Foldable1 Par1 where
    foldMap1 = coerce

deriving instance Foldable1 f => Foldable1 (Rec1 f)

deriving instance Foldable1 f => Foldable1 (M1 i c f)

instance (Foldable1 f, Foldable1 g) => Foldable1 (f :+: g) where
    foldMap1 f (L1 x) = foldMap1 f x
    foldMap1 f (R1 y) = foldMap1 f y

instance (Foldable1 f, Foldable1 g) => Foldable1 (f :*: g) where
    foldMap1 f (x :*: y) = foldMap1 f x <> foldMap1 f y

instance (Foldable1 f, Foldable1 g) => Foldable1 (f :.: g) where
    foldMap1 f = foldMap1 (foldMap1 f) . unComp1
#endif

-------------------------------------------------------------------------------
-- Extra instances
-------------------------------------------------------------------------------

instance Foldable1 Identity where
    foldMap1      = coerce

    foldrMap1  g _ = coerce g
    foldrMap1' g _ = coerce g
    foldlMap1  g _ = coerce g
    foldlMap1' g _ = coerce g

    toNonEmpty (Identity x) = x :| []

    last    = coerce
    head    = coerce
    minimum = coerce
    maximum = coerce

-- | It would be enough for either half of a product to be 'Foldable1'.
-- Other could be 'Foldable'.
instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Product f g) where
    foldMap1 f (Functor.Pair x y)    = foldMap1 f x <> foldMap1 f y
    foldrMap1 g f (Functor.Pair x y) = foldr f (foldrMap1 g f y) x

    head (Functor.Pair x _) = head x
    last (Functor.Pair _ y) = last y

instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Sum f g) where
    foldMap1 f (Functor.InL x) = foldMap1 f x
    foldMap1 f (Functor.InR y) = foldMap1 f y

    foldrMap1 g f (Functor.InL x) = foldrMap1 g f x
    foldrMap1 g f (Functor.InR y) = foldrMap1 g f y

    toNonEmpty (Functor.InL x) = toNonEmpty x
    toNonEmpty (Functor.InR y) = toNonEmpty y

    head (Functor.InL x) = head x
    head (Functor.InR y) = head y
    last (Functor.InL x) = last x
    last (Functor.InR y) = last y

    minimum (Functor.InL x) = minimum x
    minimum (Functor.InR y) = minimum y
    maximum (Functor.InL x) = maximum x
    maximum (Functor.InR y) = maximum y

instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where
    foldMap1 f = foldMap1 (foldMap1 f) . getCompose

    foldrMap1 f g = foldrMap1 (foldrMap1 f g) (\xs x -> foldr g x xs) . getCompose

    head = head . head . getCompose
    last = last . last . getCompose

-------------------------------------------------------------------------------
-- containers
-------------------------------------------------------------------------------

instance Foldable1 Tree where
    foldMap1 f (Node x [])       = f x
    foldMap1 f (Node x (y : ys)) = f x <> foldMap1 (foldMap1 f) (y :| ys)

    foldMap1' f = go where
        go (Node x ys) =
            foldl' (\m zs -> let gozs = go zs in gozs `seq` m <> gozs) (f x) ys

    foldlMap1 f g (Node x xs) = goForest (f x) xs where
        goForest = foldl' go
        go y (Node z zs) = goForest (g y z) zs

    foldlMap1' f g (Node x xs) = goForest (f x) xs where
        goForest !y = foldl' go y
        go !y (Node z zs) = goForest (g y z) zs

    head (Node x _) = x

-------------------------------------------------------------------------------
-- transformers
-------------------------------------------------------------------------------

instance Foldable1 f => Foldable1 (Reverse f) where
    foldMap1 f = getDual . foldMap1 (Dual . f) . getReverse

    foldrMap1  f g (Reverse xs) = foldlMap1  f (flip g) xs
    foldlMap1  f g (Reverse xs) = foldrMap1  f (flip g) xs
    foldrMap1' f g (Reverse xs) = foldlMap1' f (flip g) xs
    foldlMap1' f g (Reverse xs) = foldrMap1' f (flip g) xs

    head = last . getReverse
    last = head . getReverse

deriving instance Foldable1 f => Foldable1 (IdentityT f)

instance Foldable1 f => Foldable1 (Backwards f) where
    foldMap1 f = foldMap1 f . forwards

instance Foldable1 f => Foldable1 (Lift f) where
    foldMap1 f (Pure x)  = f x
    foldMap1 f (Other y) = foldMap1 f y

-------------------------------------------------------------------------------
-- tagged
-------------------------------------------------------------------------------

#ifdef MIN_VERSION_tagged
instance Foldable1 (Tagged b) where
    foldMap1      = coerce

    foldrMap1  g _ = coerce g
    foldrMap1' g _ = coerce g
    foldlMap1  g _ = coerce g
    foldlMap1' g _ = coerce g

    toNonEmpty x = coerce x :| []

    last    = coerce
    head    = coerce
    minimum = coerce
    maximum = coerce
#endif

-------------------------------------------------------------------------------
-- coerce shim
-------------------------------------------------------------------------------

#if __GLASGOW_HASKELL__ <708
coerce :: a -> b
coerce = unsafeCoerce

(#.) :: (b -> c) -> (a -> b) -> a -> c
(#.) _f = coerce
#else
(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c
(#.) _f = coerce
#endif