{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}

-- |
-- Module      : Criterion.Report
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Reporting functions.

module Criterion.Report
    (
      formatReport
    , report
    , tidyTails
    -- * Rendering helper functions
    , TemplateException(..)
    , loadTemplate
    , includeFile
    , getTemplateDir
    , vector
    , vector2
    ) where

import Control.Exception (Exception, IOException, throwIO)
import Control.Monad (mplus)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Reader (ask)
import Criterion.Monad (Criterion)
import Criterion.Types
import Data.Aeson (ToJSON (..), Value(..), object, (.=), Value)
import Data.Aeson.Text (encodeToLazyText)
import Data.Data (Data, Typeable)
import Data.Foldable (forM_)
import GHC.Generics (Generic)
import Paths_criterion (getDataFileName)
import Statistics.Function (minMax)
import System.Directory (doesFileExist)
import System.FilePath ((</>), (<.>), isPathSeparator)
import System.IO (hPutStrLn, stderr)
import Text.Microstache (Key (..), Node (..), Template (..),
                compileMustacheText, displayMustacheWarning, renderMustacheW)
import Prelude ()
import Prelude.Compat
import qualified Control.Exception as E
import qualified Data.Text as T
#if defined(EMBED)
import qualified Data.Text.Lazy.Encoding as TLE
#endif
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U

#if defined(EMBED)
import Criterion.EmbeddedData (dataFiles, chartContents)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Encoding as TE
#else
import qualified Language.Javascript.Chart as Chart
#endif

-- | Trim long flat tails from a KDE plot.
tidyTails :: KDE -> KDE
tidyTails KDE{..} = KDE { kdeType   = kdeType
                        , kdeValues = G.slice front winSize kdeValues
                        , kdePDF    = G.slice front winSize kdePDF
                        }
  where tiny     = uncurry subtract (minMax kdePDF) * 0.005
        omitTiny = G.length . G.takeWhile ((<= tiny) . abs)
        front    = omitTiny kdePDF
        back     = omitTiny . G.reverse $ kdePDF
        winSize  = G.length kdePDF - front - back

-- | Return the path to the template and other files used for
-- generating reports.
--
-- When the @-fembed-data-files@ @Cabal@ flag is enabled, this simply
-- returns the empty path.
getTemplateDir :: IO FilePath
#if defined(EMBED)
getTemplateDir = pure ""
#else
getTemplateDir = getDataFileName "templates"
#endif

-- | Write out a series of 'Report' values to a single file, if
-- configured to do so.
report :: [Report] -> Criterion ()
report reports = do
  Config{..} <- ask
  forM_ reportFile $ \name -> liftIO $ do
    td <- getTemplateDir
    tpl <- loadTemplate [td,"."] template
    TL.writeFile name =<< formatReport reports tpl

-- | Escape JSON string aimed to be embedded in an HTML <script> tag.  Notably
-- < and > are replaced with their unicode escape sequences such that closing
-- the <script> tag from within the JSON data is disallowed, i.e, the character
-- sequence "</" is made impossible.
--
-- Moreover, single quotes are escaped such that embedding JSON into HTML
-- attributes quoted with single quotes is safe, & is escaped to avoid HTML
-- character references (&<code>;) and + is escaped to avoid UTF-7 attacks
-- (should only affect old versions of IE).
--
-- The following characters are replaced with their unicode escape sequnces
-- (\uXXXX) <, >, &, +, \0, \n, \r, ' (single quote), /, \, \x2028 (line
-- separator) and \x2029 (paragraph separator)
escapeJSON :: Char -> TL.Text
escapeJSON '<'      = "\\u003c" -- ban closing of the script tag by making </ impossible
escapeJSON '>'      = "\\u003e" -- encode tags with unicode escape sequences
escapeJSON '\x2028' = "\\u2028" -- line separator
escapeJSON '\x2029' = "\\u2029" -- paragraph separator
escapeJSON '&'      = "\\u0026" -- avoid HTML entities
escapeJSON '+'      = "\\u002b" -- + can be used in UTF-7 escape sequences
escapeJSON '\0'     = "\\u0000" -- make null characters explicit
escapeJSON '\n'     = "\\u000a" -- for good measure also escape newlines
escapeJSON '\r'     = "\\u000d" -- , carriage returns
escapeJSON '\''     = "\\u0027" -- , single quotes
escapeJSON '/'      = "\\u002f" -- , slashes
escapeJSON '\\'     = "\\u005c" -- , and backslashes
escapeJSON c        = TL.singleton c

-- | Format a series of 'Report' values using the given Mustache template.
formatReport :: [Report]
             -> TL.Text    -- ^ Mustache template.
             -> IO TL.Text
formatReport reports templateName = do
    template0 <- case compileMustacheText "tpl" templateName of
        Left err -> fail (show err) -- TODO: throw a template exception?
        Right x -> return x

    criterionJS <- readDataFile "criterion.js"
    criterionCSS <- readDataFile "criterion.css"
    chartJS <- chartFileContents

    -- includes, only top level
    templates <- getTemplateDir
    template <- includeTemplate (includeFile [templates]) template0

    let context = object
            [ "json"                .= reportsJSON reports
            , "js-criterion"        .= criterionJS
            , "js-chart"            .= chartJS
            , "criterion-css"       .= criterionCSS
            ]

    let (warnings, formatted) = renderMustacheW template context
    -- If there were any issues during mustache template rendering, make sure
    -- to inform the user. See #127.
    forM_ warnings $ \warning -> do
        criterionWarning $ displayMustacheWarning warning
    return formatted
  where
    reportsJSON :: [Report] -> T.Text
    reportsJSON = TL.toStrict . TL.concatMap escapeJSON . encodeToLazyText

    chartFileContents :: IO T.Text
#if defined(EMBED)
    chartFileContents        = pure $ TE.decodeUtf8 chartContents
#else
    chartFileContents        = T.readFile =<< Chart.file Chart.Chart
#endif

    readDataFile :: FilePath -> IO T.Text
    readDataFile fp =
      (T.readFile =<< getDataFileName ("templates" </> fp))
#if defined(EMBED)
      `E.catch` \(e :: IOException) ->
        maybe (throwIO e)
              (pure . TE.decodeUtf8)
              (lookup fp dataFiles)
#endif

    includeTemplate :: (FilePath -> IO T.Text) -> Template -> IO Template
    includeTemplate f Template {..} = fmap
        (Template templateActual)
        (traverse (traverse (includeNode f)) templateCache)

    includeNode :: (FilePath -> IO T.Text) -> Node -> IO Node
    includeNode f (Section (Key ["include"]) [TextBlock fp]) =
        fmap TextBlock (f (T.unpack fp))
    includeNode _ n = return n

criterionWarning :: String -> IO ()
criterionWarning msg =
  hPutStrLn stderr $ unlines
    [ "criterion: warning:"
    , "  " ++ msg
    ]

-- | Render the elements of a vector.
--
-- It will substitute each value in the vector for @x@ in the
-- following Mustache template:
--
-- > {{#foo}}
-- >  {{x}}
-- > {{/foo}}
vector :: (G.Vector v a, ToJSON a) =>
          T.Text                -- ^ Name to use when substituting.
       -> v a
       -> Value
{-# SPECIALIZE vector :: T.Text -> U.Vector Double -> Value #-}
vector name v = toJSON . map val . G.toList $ v where
    val i = object [ name .= i ]

-- | Render the elements of two vectors.
vector2 :: (G.Vector v a, G.Vector v b, ToJSON a, ToJSON b) =>
           T.Text               -- ^ Name for elements from the first vector.
        -> T.Text               -- ^ Name for elements from the second vector.
        -> v a                  -- ^ First vector.
        -> v b                  -- ^ Second vector.
        -> Value
{-# SPECIALIZE vector2 :: T.Text -> T.Text -> U.Vector Double -> U.Vector Double
                       -> Value #-}
vector2 name1 name2 v1 v2 = toJSON $ zipWith val (G.toList v1) (G.toList v2) where
    val i j = object
        [ name1 .= i
        , name2 .= j
        ]

-- | Attempt to include the contents of a file based on a search path.
-- Returns 'B.empty' if the search fails or the file could not be read.
--
-- Intended for preprocessing Mustache files, e.g. replacing sections
--
-- @
-- {{#include}}file.txt{{/include}
-- @
--
-- with file contents.
includeFile :: (MonadIO m) =>
               [FilePath]       -- ^ Directories to search.
            -> FilePath         -- ^ Name of the file to search for.
            -> m T.Text
{-# SPECIALIZE includeFile :: [FilePath] -> FilePath -> IO T.Text #-}
includeFile searchPath name = liftIO $ foldr go (return T.empty) searchPath
    where go dir next = do
            let path = dir </> name
            T.readFile path `E.catch` \(_::IOException) -> next

-- | A problem arose with a template.
data TemplateException =
    TemplateNotFound FilePath   -- ^ The template could not be found.
    deriving (Eq, Read, Show, Typeable, Data, Generic)

instance Exception TemplateException

-- | Load a Mustache template file.
--
-- If the name is an absolute or relative path, the search path is
-- /not/ used, and the name is treated as a literal path.
--
-- If the @-fembed-data-files@ @Cabal@ flag is enabled, this also checks
-- the embedded @data-files@ from @criterion.cabal@.
--
-- This function throws a 'TemplateException' if the template could
-- not be found, or an 'IOException' if no template could be loaded.
loadTemplate :: [FilePath]      -- ^ Search path.
             -> FilePath        -- ^ Name of template file.
             -> IO TL.Text
loadTemplate paths name
    | any isPathSeparator name = readFileCheckEmbedded name
    | otherwise                = go Nothing paths
  where go me (p:ps) = do
          let cur = p </> name <.> "tpl"
          x <- doesFileExist' cur
          if x
            then readFileCheckEmbedded cur `E.catch` \e -> go (me `mplus` Just e) ps
            else go me ps
        go (Just e) _ = throwIO (e::IOException)
        go _        _ = throwIO . TemplateNotFound $ name

        doesFileExist' :: FilePath -> IO Bool
        doesFileExist' fp = do
          e <- doesFileExist fp
          pure $ e
#if defined(EMBED)
                 || (fp `elem` map fst dataFiles)
#endif

-- A version of 'readFile' that falls back on the embedded 'dataFiles'
-- from @criterion.cabal@.
readFileCheckEmbedded :: FilePath -> IO TL.Text
readFileCheckEmbedded fp =
  TL.readFile fp
#if defined(EMBED)
  `E.catch` \(e :: IOException) ->
    maybe (throwIO e)
          (pure . TLE.decodeUtf8 . fromStrict)
          (lookup fp dataFiles)
  where
# if MIN_VERSION_bytestring(0,10,0)
    fromStrict = BL.fromStrict
# else
    fromStrict x = BL.fromChunks [x]
# endif
#endif


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

import Control.Monad
import Criterion
import Criterion.IO
import Criterion.Types
import Data.Aeson
import qualified Data.ByteString.Lazy as B
import qualified Data.HashMap as HM
import Data.List
import qualified Data.Vector as V
import Statistics.Types (confIntLDX, confIntUDX, estError, estPoint)
import System.Environment
import System.Exit
import System.IO
import System.Process as P

toScriptFormat :: [(Word, [Report])] -> Value
toScriptFormat = toJSON . concatMap mapRun
  where
    mapRun (cores, reps) =
        map
            (\rep ->
                 object
                     [ "config" .=
                       object ["experiment" .= reportName rep, "cores" .= cores]
                     , "mean" .=
                       let meanEstimate = anMean $ reportAnalysis rep
                        in object
                               [ "value" .= estPoint meanEstimate
                               , "upper" .= confIntLDX (estError meanEstimate)
                               , "lower" .= confIntUDX (estError meanEstimate)
                               ]
                     ])
            reps

reportFileName = "results/reports.json"

runExperiment lo hi benchmark variants = do
    let fname = benchmark ++ "-" ++ show lo ++ ":" ++ show hi ++ "-results"
        runFor c name = do
            callProcess
                "./bin/benchmarks"
                [ "--json"
                , reportFileName
                , "--match"
                , "prefix"
                , benchmark ++ "/" ++ name
                , "+RTS"
                , "-N" ++ show (c :: Word)
                ]
            (_, _, recs) <- either error pure =<< readJSONReports reportFileName
            pure recs
    let multiVars = filter (/= "sequential") variants
    sequential <- runFor 1 "sequential"
    multiRecs <-
        forM [lo .. hi] $ \c -> do
            recs <- concat <$> mapM (runFor c) multiVars
            pure (c, recs)
    let recs = (1, sequential) : multiRecs
    B.writeFile ("results/" ++ fname ++ ".json") $ encode $ toScriptFormat recs

setUpExperiment = do
    callProcess "stack" ["build"]
    callProcess
        "stack"
        [ "ghc"
        , "--"
        , "src/benchmarks.hs"
        , "-o"
        , "./bin/benchmarks"
        , "-outputdir"
        , "./bin/"
        , "-rtsopts"
        , "-threaded"
        ]

experiments =
    [ ("ohua-bench", ["sequential", "pure", "reading", "writing"])
    , ("comp-bench", ["sequential", "ohua", "par1", "par2"])
    , ("app-bench", ["sequential", "ohua", "par", "ohua-noinline", "par-noinline"])
    , ("cond-bench", ["sequential", "ohua", "par"])
    , ("matmult-bench", ["sequential", "ohua", "par"])
    , ("bs-bench", ["sequential", "ohua", "par"])
    , ("mandel-bench", ["sequential", "ohua", "par"])
    , ("sumeuler-bench", ["sequential", "ohua", "sum_ohua", "par"])
    ]

runAllExperiments lo hi = do
    forM experiments $ \(name, variants) -> runExperiment lo hi name variants

main = do
    [name, cs] <- getArgs
    let (lo, hi) = read cs
    setUpExperiment
    if name == "all"
        then runAllExperiments lo hi
        else (\x -> return [x]) =<<
             (runExperiment lo hi name $ getVariants name)
  where
    getVariants benchmark =
        let variants = HM.lookup benchmark (HM.fromList experiments)
         in case variants of
                (Just v) -> v
                (Nothing) -> error $ "No such benchmark: " ++ benchmark


{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

module NicePrelude (
  module X,
  module Base,
  identity,
  map,
  (&),
  uncons,
  applyN,
  print,
  show,

  LText,
  LByteString,
) where

import List as X
import Show as X
import Bool as X
import Debug as X
import Monad as X
import Functor as X
import Either as X
import Applicative as X
import Conv as X

import Base as Base hiding (
    putStr
  , putStrLn
  , print
  , show
  , error
  , undefined
  )
import qualified Base as PBase

-- Used for 'show'
import Data.String (String)

-- Maybe'ized version of partial functions
import Safe as X (
    headMay
  , headDef
  , initMay
  , initDef
  , initSafe
  , tailMay
  , tailDef
  , tailSafe
  , lastDef
  , lastMay
  , foldr1May
  , foldl1May
  , atMay
  , atDef
  )

-- Applicatives
import Control.Applicative as X (
    Applicative(..)
  , Alternative(..)
  , Const(..)
  , ZipList(..)
  , (<**>)
  , liftA
  , liftA2
  , liftA3
  , optional
  )

-- Base typeclasses
import Data.Eq as X
import Data.Ord as X
import Data.Traversable as X
import Data.Foldable as X hiding (
    foldr1
  , foldl1
  )
import Semiring as X
import Data.Functor.Identity as X

#if ( __GLASGOW_HASKELL__ >= 800 )
import Data.Monoid as X hiding ((<>))
import Data.Semigroup as X ( Semigroup(..) )
#else
import Data.Monoid as X
#endif

#if (__GLASGOW_HASKELL__ >= 710)
import Data.Bifunctor as X (Bifunctor(..))
#else
import Bifunctor as X (Bifunctor(..))
#endif

-- Deepseq
import Control.DeepSeq as X (
    NFData(..)
  , ($!!)
  , deepseq
  , force
  )

-- Data structures
import Data.Tuple as X
import Data.List as X (
    splitAt
  , break
  , intercalate
  , isPrefixOf
  , drop
  , filter
  , reverse
  , replicate
  , take
  , sortBy
  , sort
  , intersperse
  , transpose
  , subsequences
  , permutations
  , scanl
  , scanr
  , iterate
  , repeat
  , cycle
  , unfoldr
  , takeWhile
  , dropWhile
  , group
  , inits
  , tails
  , zipWith
  , zip
  )

import Data.Map as X (Map)
import Data.Set as X (Set)
import Data.Sequence as X (Seq)
import Data.IntMap as X (IntMap)
import Data.IntSet as X (IntSet)

#if ( __GLASGOW_HASKELL__ >= 710 )
import Data.Proxy as X (
    Proxy(..)
  )

import Data.Typeable as X (
    TypeRep
  , Typeable
  , typeRep
  , cast
  , eqT
  )

import Data.Type.Coercion as X (
    Coercion(..)
  , coerceWith
  )

import Data.Type.Equality as X (
    (:~:)(..)
  , type (==)
  , sym
  , trans
  , castWith
  , gcastWith
  )

import Data.Void as X (
    Void
  , absurd
  , vacuous
  )
#endif

-- Monad transformers
import Control.Monad.State as X (
    MonadState
  , State
  , StateT
  , put
  , get
  , gets
  , modify
  , withState

  , runState
  , execState
  , evalState

  , runStateT
  , execStateT
  , evalStateT
  )

import Control.Monad.Reader as X (
    MonadReader
  , Reader
  , ReaderT
  , ask
  , asks
  , local
  , runReader
  , runReaderT
  )

import Control.Monad.Except as X (
    MonadError
  , Except
  , ExceptT
  , throwError
  , catchError
  , runExcept
  , runExceptT
  )

import Control.Monad.Trans as X (
    MonadIO
  , lift
  , liftIO
  )

-- Base types
import Data.Int as X
import Data.Bits as X
import Data.Word as X
import Data.Either as X
import Data.Complex as X
import Data.Char as X (chr)
import Data.Bool as X hiding (bool)
import Data.Maybe as X hiding (fromJust)

import Data.Function as X (
    const
  , (.)
  , ($)
  , flip
  , fix
  , on
  )

-- Genericss
import GHC.Generics as X (
    Generic(..)
  , Rep
  , K1(..)
  , M1(..)
  , U1(..)
  , V1
  , D1
  , C1
  , S1
  , (:+:)
  , (:*:)
  , Rec0
  , Constructor(..)
  , Selector(..)
  , Fixity(..)
#if ( __GLASGOW_HASKELL__ >= 800 )
  , Meta(..)
#endif
  )

-- ByteString
import qualified Data.ByteString.Lazy
import Data.ByteString as X (ByteString)

-- Text
import Data.Text as X (Text)
import qualified Data.Text.Lazy
import qualified Data.Text.IO

import Data.Text.Lazy (
    toStrict
  , fromStrict
  )

import Data.String as X (IsString)

-- Printf
import Text.Printf as X (
    PrintfArg
  , printf
  , hPrintf
  )

-- IO
import System.Exit as X
--import System.Info as X
import System.Environment as X (getArgs)
import System.IO as X (Handle)

-- ST
import Control.Monad.ST as X

-- Concurrency and Parallelism
import Control.Exception as X
import Control.Monad.STM as X
import Control.Concurrent as X
import Control.Concurrent.Async as X

import Foreign.Storable as X (Storable)

-- Read instances hiding unsafe builtins (read)
import Text.Read as X (
    Read
  , reads
  , readMaybe
  , readEither
  )

-- Type synonymss for lazy texts
type LText = Data.Text.Lazy.Text
type LByteString = Data.ByteString.Lazy.ByteString

infixl 1 &

(&) :: a -> (a -> b) -> b
x & f = f x

identity :: a -> a
identity x = x

map :: Functor f => (a -> b) -> f a -> f b
map = fmap

uncons :: [a] -> Maybe (a, [a])
uncons []     = Nothing
uncons (x:xs) = Just (x, xs)

applyN :: Int -> (a -> a) -> a -> a
applyN n f = X.foldr (.) identity (X.replicate n f)

print :: (X.MonadIO m, PBase.Show a) => a -> m ()
print = liftIO . PBase.print

show :: (Show a, StringConv String b) => a -> b
show x = toS (PBase.show x)
{-# SPECIALIZE show :: Show  a => a -> String  #-}
{-# SPECIALIZE show :: Show  a => a -> Text  #-}
{-# SPECIALIZE show :: Show  a => a -> LText  #-}


-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Parallel.Strategies
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Parallel strategy combinators
--
-----------------------------------------------------------------------------
module Control.Parallel.Strategies where

-- based on hslibs/concurrent/Strategies.lhs; see it for more detailed
-- code comments. Original authors:
--
--	Phil Trinder, Hans-Wolfgang Loidl, Kevin Hammond et al.
--

#ifdef __HADDOCK__
import Prelude
#endif

import Control.Parallel as Parallel
import Data.Ix
import Data.Array
import Data.Complex
import Data.Ratio

-- not a terribly portable way of getting at Ratio rep.
#ifdef __GLASGOW_HASKELL__
import GHC.Real	(Ratio(..))	-- The basic defns for Ratio
#endif

#ifdef __HUGS__
import Hugs.Prelude(Ratio(..) )
#endif

#ifdef __NHC__
import Ratio (Ratio(..) )
#endif

infixl 0 `using`,`demanding`,`sparking`              -- weakest precedence!

infixr 2 >||                -- another name for par
infixr 3 >|                 -- another name for seq
infixl 6 $||, $|            -- strategic function application (seq and par)
infixl 9 .|, .||, -|, -||   -- strategic (inverse) function composition

------------------------------------------------------------------------------
--			Strategy Type, Application and Semantics
------------------------------------------------------------------------------
type Done = ()
type Strategy a = a -> Done

{-
A strategy takes a value and returns a dummy `done' value to indicate that
the specifed evaluation has been performed.

The basic combinators for strategies are @par@ and @seq@ but with types that
indicate that they only combine the results of a strategy application.

NB: This version can be used with Haskell 1.4 (GHC 2.05 and beyond), *but*
    you won't get strategy checking on seq (only on par)!

The infix fcts >| and >|| are alternative names for `seq` and `par`.
With the introduction of a Prelude function `seq` separating the Prelude
function from the Strategy function becomes a pain. The notation also matches
the notation for strategic function application.
-}

{-
par and seq have the same types as before; >| and >|| are more specific
and can only be used when composing strategies.
-}

(>|), (>||) :: Done -> Done -> Done
{-# INLINE (>|) #-}
{-# INLINE (>||) #-}
(>|) = Prelude.seq
(>||) = Parallel.par

using :: a -> Strategy a -> a
using x s = s x `seq` x

{-
using takes a strategy and a value, and applies the strategy to the
value before returning the value. Used to express data-oriented parallelism

x `using` s is a projection on x, i.e. both

  a retraction: x `using` s [ x
			    -
  and idempotent: (x `using` s) `using` s = x `using` s

demanding and sparking are used to express control-oriented
parallelism. Their second argument is usually a sequence of strategy
applications combined `par` and `seq`. Sparking should only be used
with a singleton sequence as it is not necessarily excuted
-}

demanding, sparking :: a -> Done -> a
demanding = flip Parallel.seq
sparking  = flip Parallel.par

{-
sPar and sSeq have been superceded by sparking and demanding: replace
  e `using` sPar x	with  	e `sparking`  x
  e `using` sSeq x	with 	e `demanding` x

sPar is a strategy corresponding to par. i.e. x `par` e <=> e `using` sPar x
-}

sPar :: a -> Strategy b
sPar x y = x `par` ()

{-
sSeq is a strategy corresponding to seq. i.e. x `seq` e <=> e `using` sSeq x
-}
sSeq :: a -> Strategy b
sSeq x y = x `seq` ()

-----------------------------------------------------------------------------
--			Basic Strategies
-----------------------------------------------------------------------------

-- r0 performs *no* evaluation on its argument.
r0 :: Strategy a
r0 x = ()

--rwhnf reduces its argument to weak head normal form.
rwhnf :: Strategy a
rwhnf x = x `seq` ()

class NFData a where
  -- rnf reduces its argument to (head) normal form
  rnf :: Strategy a
  -- Default method. Useful for base types. A specific method is necessay for
  -- constructed types
  rnf = rwhnf

class (NFData a, Integral a) => NFDataIntegral a
class (NFData a, Ord a) => NFDataOrd a

------------------------------------------------------------------------------
--                      Strategic Function Application
------------------------------------------------------------------------------

{-
The two  infix functions @$|@   and @$||@  perform sequential and  parallel
function application, respectively. They  are parameterised with a strategy
that is applied to the argument of the  function application.  This is very
handy when  writing  pipeline parallelism  as  a sequence of  @$@, @$|@ and
@$||@'s. There is no  need of naming intermediate values  in this case. The
separation  of algorithm from strategy  is  achieved by allowing strategies
only as second arguments to @$|@ and @$||@.
-}

($|), ($||) :: (a -> b) -> Strategy a -> a -> b

f $| s  = \ x -> f x `demanding` s x
f $|| s = \ x -> f x `sparking`  s x

{-
The same thing for function composition (.| and .||) and inverse function
composition (-| and -||) for those who read their programs from left to
right.
-}

(.|), (.||) :: (b -> c) -> Strategy b -> (a -> b) -> (a -> c)
(-|), (-||) :: (a -> b) -> Strategy b -> (b -> c) -> (a -> c)

(.|) f s g = \ x -> let  gx = g x
                    in   f gx `demanding` s gx
(.||) f s g = \ x -> let  gx = g x
                     in   f gx `sparking` s gx

(-|) f s g = \ x -> let  fx = f x
                    in   g fx `demanding` s fx
(-||) f s g = \ x -> let  fx = f x
                     in   g fx `sparking` s fx

------------------------------------------------------------------------------
--			Marking a Strategy
------------------------------------------------------------------------------

{-
Marking a strategy.

Actually, @markStrat@  sticks a label @n@  into the sparkname  field of the
thread executing strategy @s@. Together with a runtime-system that supports
propagation of sparknames to the children this means that this strategy and
all its children have  the sparkname @n@ (if the  static sparkname field in
the @parGlobal@ annotation contains the value 1). Note, that the @SN@ field
of starting the marked strategy itself contains the sparkname of the parent
thread. The END event contains @n@ as sparkname.
-}

#if 0
markStrat :: Int -> Strategy a -> Strategy a
markStrat n s x = unsafePerformPrimIO (
     _casm_ ``%r = set_sparkname(CurrentTSO, %0);'' n `thenPrimIO` \ z ->
     returnPrimIO (s x))
#endif

-----------------------------------------------------------------------------
--			Strategy Instances and Functions
-----------------------------------------------------------------------------

-----------------------------------------------------------------------------
--	                Tuples
-----------------------------------------------------------------------------

{-
We currently support up to 9-tuples. If you need longer tuples you have to
add the instance explicitly to your program.
-}

instance (NFData a, NFData b) => NFData (a,b) where
  rnf (x,y) = rnf x `seq` rnf y

instance (NFData a, NFData b, NFData c) => NFData (a,b,c) where
  rnf (x,y,z) = rnf x `seq` rnf y `seq` rnf z

instance (NFData a, NFData b, NFData c, NFData d) => NFData (a,b,c,d) where
  rnf (x1,x2,x3,x4) = rnf x1 `seq`
		        rnf x2 `seq`
		        rnf x3 `seq`
		        rnf x4

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) =>
         NFData (a1, a2, a3, a4, a5) where
  rnf (x1, x2, x3, x4, x5) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) =>
         NFData (a1, a2, a3, a4, a5, a6) where
  rnf (x1, x2, x3, x4, x5, x6) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) =>
         NFData (a1, a2, a3, a4, a5, a6, a7) where
  rnf (x1, x2, x3, x4, x5, x6, x7) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8, x9) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8 `seq`
                  rnf x9

seqPair :: Strategy a -> Strategy b -> Strategy (a,b)
seqPair strata stratb (x,y) = strata x `seq` stratb y

parPair :: Strategy a -> Strategy b -> Strategy (a,b)
parPair strata stratb (x,y) = strata x `par` stratb y `par` ()

{-
The reason for the  second `par` is so that the strategy terminates
quickly. This is important if the strategy is used as the 1st argument of a seq
-}

seqTriple :: Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c)
seqTriple strata stratb stratc p@(x,y,z) =
  strata x `seq`
  stratb y `seq`
  stratc z

parTriple :: Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c)
parTriple strata stratb stratc (x,y,z) =
  strata x `par`
  stratb y `par`
  stratc z `par`
  ()

{-
Weak head normal form and normal form are identical for integers, so the
default rnf is sufficient.
-}
instance NFData Int
instance NFData Integer
instance NFData Float
instance NFData Double

instance NFDataIntegral Int
instance NFDataOrd Int

--Rational and complex numbers.

instance (Integral a, NFData a) => NFData (Ratio a) where
  rnf (x:%y) = rnf x `seq`
               rnf y `seq`
               ()

instance (RealFloat a, NFData a) => NFData (Complex a) where
  rnf (x:+y) = rnf x `seq`
	         rnf y `seq`
               ()

instance NFData Char
instance NFData Bool
instance NFData ()

-----------------------------------------------------------------------------
--			Lists
----------------------------------------------------------------------------

instance NFData a => NFData [a] where
  rnf [] = ()
  rnf (x:xs) = rnf x `seq` rnf xs

----------------------------------------------------------------------------
--                        Lists: Parallel Strategies
----------------------------------------------------------------------------

-- | Applies a strategy to every element of a list in parallel
parList :: Strategy a -> Strategy [a]
parList strat []     = ()
parList strat (x:xs) = strat x `par` (parList strat xs)

-- | Applies a strategy to the first  n elements of a list  in parallel
parListN :: (Integral b) => b -> Strategy a -> Strategy [a]
parListN n strat []     = ()
parListN 0 strat xs     = ()
parListN n strat (x:xs) = strat x `par` (parListN (n-1) strat xs)

-- | Evaluates N elements of the spine of the argument list and applies
-- the given strategy to the Nth element (if there is one) in parallel with
-- the result. e.g. parListNth 2 [e1, e2, e3] evaluates e2
parListNth :: Int -> Strategy a -> Strategy [a]
parListNth n strat xs
  | null rest = ()
  | otherwise = strat (head rest) `par` ()
  where
    rest = drop n xs

-- | 'parListChunk' sequentially applies a strategy to chunks
-- (sub-sequences) of a list in parallel. Useful to increase grain size
parListChunk :: Int -> Strategy a -> Strategy [a]
parListChunk n strat [] = ()
parListChunk n strat xs = seqListN n strat xs `par`
			    parListChunk n strat (drop n xs)

-- | 'parMap' applies a function to each element of the argument list in
-- parallel.  The result of the function is evaluated using the given
-- strategy.
parMap :: Strategy b -> (a -> b) -> [a] -> [b]
parMap strat f xs 	= map f xs `using` parList strat

-- | 'parFlatMap' uses 'parMap' to apply a list-valued function to each
-- element of the argument list in parallel.  The result of the function
-- is evaluated using the given strategy.
parFlatMap :: Strategy [b] -> (a -> [b]) -> [a] -> [b]
parFlatMap strat f xs = concat (parMap strat f xs)

-- | 'parZipWith' zips together two lists with a function z in parallel
parZipWith :: Strategy c -> (a -> b -> c) -> [a] -> [b] -> [c]
parZipWith strat z as bs =
  zipWith z as bs `using` parList strat

----------------------------------------------------------------------------
--                        Lists: Sequential Strategies
----------------------------------------------------------------------------

-- | Sequentially applies a strategy to each element of a list
seqList :: Strategy a -> Strategy [a]
seqList strat []     = ()
seqList strat (x:xs) = strat x `seq` (seqList strat xs)

-- | Sequentially applies a strategy to the first  n elements of a list
seqListN :: (Integral a) => a -> Strategy b -> Strategy [b]
seqListN n strat []     = ()
seqListN 0 strat xs     = ()
seqListN n strat (x:xs) = strat x `seq` (seqListN (n-1) strat xs)

-- | 'seqListNth' applies a strategy to the Nth element of it's argument
-- (if there is one) before returning the result. e.g. seqListNth 2 [e1,
-- e2, e3] evaluates e2
seqListNth :: Int -> Strategy b -> Strategy [b]
seqListNth n strat xs
  | null rest = ()
  | otherwise = strat (head rest)
  where
    rest = drop n xs

-- | Parallel n-buffer function added for the revised version of the strategies
-- paper. 'parBuffer' supersedes the older @fringeList@. It has the same
-- semantics.
parBuffer :: Int -> Strategy a -> [a] -> [a]
parBuffer n s xs =
  return xs (start n xs)
  where
    return (x:xs) (y:ys) = (x:return xs ys) `sparking` s y
    return xs     []     = xs

    start n []     = []
    start 0 ys     = ys
    start n (y:ys) = start (n-1) ys `sparking` s y

{-
 'fringeList' implements a `rolling buffer' of length n, i.e.applies a
 strategy to the nth element of list when the head is demanded. More
 precisely:

   semantics:         fringeList n s = id :: [b] -> [b]
   dynamic behaviour: evalutates the nth element of the list when the
		      head is demanded.

 The idea is to provide a `rolling buffer' of length n.
fringeList :: (Integral a) => a -> Strategy b -> [b] -> [b]
fringeList n strat [] = []
fringeList n strat (r:rs) =
  seqListNth n strat rs `par`
  r:fringeList n strat rs
-}

------------------------------------------------------------------------------
--			Arrays
------------------------------------------------------------------------------
instance (Ix a, NFData a, NFData b) => NFData (Array a b) where
  rnf x = rnf (bounds x) `seq` seqList rnf (elems x) `seq` ()

-- | Apply a strategy to all elements of an array in parallel. This can be done
-- either in sequentially or in parallel (same as with lists, really).
seqArr :: (Ix b) => Strategy a -> Strategy (Array b a)
seqArr s arr = seqList s (elems arr)

parArr :: (Ix b) => Strategy a -> Strategy (Array b a)
parArr s arr = parList s (elems arr)

-- Associations maybe useful even without mentioning Arrays.

data  Assoc a b =  a := b  deriving ()

instance (NFData a, NFData b) => NFData (Assoc a b) where
  rnf (x := y) = rnf x `seq` rnf y `seq` ()

------------------------------------------------------------------------------
--	                Some strategies specific for Lolita
------------------------------------------------------------------------------

fstPairFstList :: (NFData a) => Strategy [(a,b)]
fstPairFstList = seqListN 1 (seqPair rwhnf r0)

-- Some HACKs for Lolita. AFAIK force is just another name for our rnf and
-- sforce is a shortcut (definition here is identical to the one in Force.lhs)

force :: (NFData a) => a -> a
sforce :: (NFData a) => a -> b -> b

force = id $| rnf
sforce x y = force x `seq` y


{-#LANGUAGE OverloadedStrings#-}

{-
Project name: Pipeline for analyze DropSeq data
Min Zhang
Date: Feb 5, 2016
Version: v0.1.0
README: Process raw fastq file, QC and mapping
-}

module DropSeq
where

import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as TextIO
import qualified Data.Char as C
import Control.Applicative
import qualified Data.List as L
import qualified Data.Set as Set
import Control.Monad (fmap)
import Data.Ord (comparing)
import Data.Function (on)
import qualified Safe as S
import qualified Data.HashMap.Lazy as M
import qualified Data.Maybe as Maybe
import qualified Data.Foldable as F (all)
import Data.Traversable (sequenceA)

import qualified Data.Vector as V
import qualified Statistics.Sample.Histogram as Stats

import MyText
import MyTable
import Util
import IO
import DataTypes

{- Part I
1. Check length of reads
2. Check number of unique cell barcode
3. Check number of unique UMI
-}

testR1Path = "/Users/minzhang/Documents/data/P56_dropseq/MH-L1-32920888/Data/Intensities/BaseCalls/MH-L1_S1_L001_R1_001.fastq"
testR2Path = "/Users/minzhang/Documents/data/P56_dropseq/MH-L1-32920888/Data/Intensities/BaseCalls/MH-L1_S1_L001_R2_001.fastq"

dropSeqQc = do
  inputFastq1 <- take 10000 <$> importFastq testR1Path
  let readLen = (V.fromList $ map (fromIntegral . T.length . fqseq) inputFastq1)
  let results = (Stats.histogram 5 readLen) :: (V.Vector Double, V.Vector Int)
  print results

-- high demand on memory
ifFastqNameMatch fq1 fq2 = and $ zipWith (==) (L.sort $ map fqname fq1) (L.sort $ map fqname fq2)

-- import fq1 only seq, to check the diversity of the barcodes.
testR1SeqPath = "/Users/minzhang/Documents/data/P56_dropseq/MH-L1-32920888/Data/Intensities/BaseCalls/MH-L1_S1_L001_R1_001.test.seq.fastq"
r1SeqPath = "/Users/minzhang/Documents/data/P56_dropseq/MH-L1-32920888/Data/Intensities/BaseCalls/MH-L1_S1_L001_R1_001.seq.fastq"

barcodeQc inputPath = do
  allBarcodes <- map (\x->(T.take 7 $ T.drop 5 x, T.take 8 $ T.drop 12 x)) . T.lines <$> TextIO.readFile inputPath
  let results = (Set.size $ Set.fromList $ map fst allBarcodes, Set.size $ Set.fromList $ map snd allBarcodes)
  print results

sortUMI inputPath = do
  results <- map (T.splitAt 12 . T.init) . T.lines <$> TextIO.readFile inputPath
  let output = T.unlines $ map (T.pack . show . length) $ L.reverse $ L.sortBy (comparing length) $ L.groupBy ((==) `on` snd) $ L.sortBy (comparing snd) results
  TextIO.writeFile "outputUMIsize.txt" output


{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- |
-- Module      : Test.ShowType
-- Copyright   : [2017..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Test.ShowType
  where

import Data.Complex

data ArgType (a :: *) = AT

showType :: forall proxy a. Show (ArgType a) => proxy a -> String
showType _ = show (AT :: ArgType a)

instance Show (ArgType a) => Show (ArgType (Complex a)) where
  show _ = "Complex " ++ show (AT :: ArgType a)

instance Show (ArgType Float)  where show _ = "Float"
instance Show (ArgType Double) where show _ = "Double"


{-# LANGUAGE RecordWildCards, FlexibleContexts, GADTs, ExistentialQuantification #-}

{-| FIR filtering, decimation and resampling.

    FIR filters (and decimators, resamplers) work by taking successive dot products between the filter coefficients and the input data at increasing offsets. Sometimes the dot product fits entirely within one input buffer and other times it spans two input buffers (but never more because we assume that the filter length is less than the buffer size).

    We divide the filtering code by these two cases. Each filter (or decimator, resampler) is described by a data structure such as `Filter` with two functions, one for filtering within a single buffer and one that crosses buffers.

    The user must first create one of these data structures using the helper functions and pass this data structure to one of `firFilter`, `firDecimator`, or `firResampler` to create the `Pipe` that does the filtering. For example:

    > decimatorStruct   <- fastDecimatorC cpuInfo decimation coeffs
    > let decimatorPipe :: Pipe (Vector (Complex Float)) (Vector (Complex Float)) IO ()
    >     decimatorPipe =  firDecimator decimatorStruct outputSize

    There are polymorphic Haskell only implementations of filtering, decimation and resampling, for example, `haskellFilter`. In addition, there are optimised C implementations that use SIMD instructions on x86 machines, such as `fastFilterR`. These are always specialized to either real or complex numbers. There are also even faster implementations specialized for the case where the filter coefficients are symmetric as in a linear phase filter such as `fastFilterSymR`.

    The Haskell implementations are reasonably fast due to the Vector library and GHC's LLVM backend, however, if speed is important you are much better off with the C implementations.

    In the future we may avoid the cross buffer filtering function by mapping the buffers consecutively in memory as (I believe) GNU Radio does.

    An extensive benchmark suite exists in the /benchmarks subdirectory of this package.
-}
module SDR.Filter (
    -- * Types
    Filter(..),
    Decimator(..),
    Resampler(..),

    -- * Helper Functions
    -- ** Filters
    haskellFilter,

    -- *** Real Data
    fastFilterCR,
    fastFilterSSER,
    fastFilterAVXR,
    fastFilterR,

    -- *** Complex Data
    fastFilterCC,
    fastFilterSSEC,
    fastFilterAVXC,
    fastFilterC,

    -- *** Linear Phase Real Data
    fastFilterSymSSER,
    fastFilterSymAVXR,
    fastFilterSymR,

    -- ** Decimators
    haskellDecimator,

    -- *** Real Data
    fastDecimatorCR,
    fastDecimatorSSER,
    fastDecimatorAVXR,
    fastDecimatorR,

    -- *** Complex Data
    fastDecimatorCC,
    fastDecimatorSSEC,
    fastDecimatorAVXC,
    fastDecimatorC,

    -- *** Linear Phase Real Data
    fastDecimatorSymSSER,
    fastDecimatorSymAVXR,
    fastDecimatorSymR,

    -- ** Resamplers
    haskellResampler,

    -- *** Real Data
    fastResamplerCR,
    fastResamplerSSER,
    fastResamplerAVXR,
    fastResamplerR,

    -- *** Complex Data
    fastResamplerCC,
    fastResamplerSSEC,
    fastResamplerAVXC,
    fastResamplerC,

    -- * Filter
    firFilter,

    -- * Decimate
    firDecimator,

    -- * Resample
    firResampler,

    -- * DC Blocking Filter
    dcBlockingFilter
    ) where

import           Control.Applicative
import           Data.Complex
import           Control.Exception           hiding (assert)
import qualified Data.Vector.Generic         as VG
import qualified Data.Vector.Generic.Mutable as VGM
import qualified Data.Vector.Storable        as VS
import           Control.Monad.Primitive

import           Pipes

import           SDR.Util
import           SDR.FilterInternal          hiding (mkResampler, mkResamplerC)
import           SDR.CPUID

{- | A `Filter` contains all of the information needed by the `filterr`
     function to perform filtering. i.e. it contains the filter coefficients
     and pointers to the functions to do the actual filtering.
-}
data Filter m v vm a = Filter {
    numCoeffsF    :: Int,
    filterOne     :: Int -> v a -> vm (PrimState m) a -> m (),
    filterCross   :: Int -> v a -> v a -> vm (PrimState m) a -> m ()
}

{- | A `Decimator` contains all of the information needed by the `decimate`
     function to perform decimation i.e. it contains the filter coefficients
     and pointers to the functions to do the actual decimation.
-}
data Decimator m v vm a = Decimator {
    numCoeffsD    :: Int,
    decimationD   :: Int,
    decimateOne   :: Int -> v a -> vm (PrimState m) a -> m (),
    decimateCross :: Int -> v a -> v a -> vm (PrimState m) a -> m ()
}

{- | A `Resampler` contains all of the information needed by the `resample`
     function to perform resampling i.e. it contains the filter coefficients
     and pointers to the functions to do the actual resampling.
-}
data Resampler m v vm a = forall dat. Resampler {
    numCoeffsR     :: Int,
    decimationR    :: Int,
    interpolationR :: Int,
    startDat       :: dat,
    resampleOne    :: dat -> Int -> v a -> vm (PrimState m) a -> m (dat, Int),
    resampleCross  :: dat -> Int -> v a -> v a -> vm (PrimState m) a -> m (dat, Int)
}

duplicate :: [a] -> [a]
duplicate = concatMap func
    where func x = [x, x]

{-# INLINE haskellFilter #-}
-- | Returns a slow Filter data structure entirely implemented in Haskell
haskellFilter :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a)
              => [b]                  -- ^ The filter coefficients
              -> IO (Filter m v vm a) -- ^ The `Filter` data structure
haskellFilter coeffs = do
    let vCoeffs     = VG.fromList coeffs
    evaluate vCoeffs
    let filterOne   = filterHighLevel      vCoeffs
        filterCross = filterCrossHighLevel vCoeffs
        numCoeffsF  = length coeffs
    return Filter {..}

mkFilter :: Int
         -> FilterRR
         -> [Float]
         -> IO (Filter IO VS.Vector VS.MVector Float)
mkFilter sizeMultiple filterFunc coeffs = do
    let l          = length coeffs
        numCoeffsF = roundUp l sizeMultiple
        diff       = numCoeffsF - l
        vCoeffs    = VG.fromList $ coeffs ++ replicate diff 0
    evaluate vCoeffs
    let filterOne   = filterFunc           vCoeffs
        filterCross = filterCrossHighLevel vCoeffs
    return Filter {..}

-- | Returns a fast Filter data structure implemented in C. For filtering real data with real coefficients.
fastFilterCR :: [Float]                                   -- ^ The filter coefficients
             -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure
fastFilterCR = mkFilter 1 filterCRR

-- | Returns a fast Filter data structure implemented in C using SSE instructions. For filtering real data with real coefficients.
fastFilterSSER :: [Float]                                -- ^ The filter coefficients
            -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure
fastFilterSSER = mkFilter 4 filterCSSERR

-- | Returns a fast Filter data structure implemented in C using AVX instructions. For filtering real data with real coefficients.
fastFilterAVXR :: [Float]                                -- ^ The filter coefficients
            -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure
fastFilterAVXR = mkFilter 8 filterCAVXRR

-- | Returns a fast Filter data structure implemented in C using the fastest SIMD instruction set your processor supports. For filtering real data with real coefficients.
fastFilterR :: CPUInfo                                   -- ^ The CPU's capabilities
            -> [Float]                                   -- ^ The filter coefficients
            -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure
fastFilterR info = featureSelect info fastFilterCR [(hasAVX, fastFilterAVXR), (hasSSE42, fastFilterSSER)]

mkFilterC :: Int
          -> FilterRC
          -> [Float]
          -> IO (Filter IO VS.Vector VS.MVector (Complex Float))
mkFilterC sizeMultiple filterFunc coeffs = do
    let l           = length coeffs
        numCoeffsF  = roundUp sizeMultiple l
        diff        = numCoeffsF - l
        vCoeffs     = VG.fromList $ duplicate $ coeffs ++ replicate diff 0
        vCoeffs2    = VG.fromList $ coeffs ++ replicate diff 0
    evaluate vCoeffs
    let filterOne   = filterFunc           vCoeffs
        filterCross = filterCrossHighLevel vCoeffs2
    return Filter {..}

-- | Returns a fast Filter data structure implemented in C For filtering complex data with real coefficients.
fastFilterCC :: [Float]                                             -- ^ The filter coefficients
             -> IO (Filter IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Filter` data structure
fastFilterCC = mkFilterC 1 filterCRC

-- | Returns a fast Filter data structure implemented in C using SSE instructions. For filtering complex data with real coefficients.
fastFilterSSEC :: [Float]                                          -- ^ The filter coefficients
               -> IO (Filter IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Filter` data structure
fastFilterSSEC = mkFilterC 2 filterCSSERC

-- | Returns a fast Filter data structure implemented in C using AVX instructions. For filtering complex data with real coefficients.
fastFilterAVXC :: [Float]                                          -- ^ The filter coefficients
               -> IO (Filter IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Filter` data structure
fastFilterAVXC = mkFilterC 4 filterCAVXRC

-- | Returns a fast Filter data structure implemented in C using the fastest SIMD instruction set your processor supports. For filtering complex data with real coefficients.
fastFilterC :: CPUInfo                                             -- ^ The CPU's capabilities
            -> [Float]                                             -- ^ The filter coefficients
            -> IO (Filter IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Filter` data structure
fastFilterC info = featureSelect info fastFilterCC [(hasAVX, fastFilterAVXC), (hasSSE42, fastFilterSSEC)]

mkFilterSymR :: FilterRR
             -> [Float]
             -> IO (Filter IO VS.Vector VS.MVector Float)
mkFilterSymR filterFunc coeffs = do
    let vCoeffs     = VG.fromList coeffs
    let vCoeffs2    = VG.fromList $ coeffs ++ reverse coeffs
    evaluate vCoeffs
    evaluate vCoeffs2
    let filterOne   = filterFunc          vCoeffs
        filterCross = filterCrossHighLevel vCoeffs2
        numCoeffsF  = length coeffs * 2
    return Filter {..}

-- | Returns a fast Filter data structure implemented in C using SSE instructions. For filtering real data with real coefficients. For filters with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4.
fastFilterSymSSER :: [Float]                                   -- ^ The first half of the filter coefficients
                  -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure
fastFilterSymSSER = mkFilterSymR filterCSSESymmetricRR

-- | Returns a fast Filter data structure implemented in C using AVX instructions. For filtering real data with real coefficients. For filters with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4.
fastFilterSymAVXR :: [Float]                                   -- ^ The first half of the filter coefficients
                  -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure
fastFilterSymAVXR = mkFilterSymR filterCAVXSymmetricRR

-- | Returns a fast Filter data structure implemented in C using the fastest SIMD instruction set your processor supports. For filtering complex data with real coefficients. For filters with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4.
fastFilterSymR :: CPUInfo                                   -- ^ The CPU's capabilities
               -> [Float]                                   -- ^ The filter coefficients
               -> IO (Filter IO VS.Vector VS.MVector Float) -- ^ The `Filter` data structure
fastFilterSymR info = featureSelect info (error "At least SSE4.2 required") [(hasAVX, fastFilterSymAVXR), (hasSSE42, fastFilterSymSSER)]

{-# INLINE haskellDecimator #-}
-- | Returns a slow Decimator data structure entirely implemented in Haskell
haskellDecimator :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a)
                 => Int                     -- ^ The decimation factor
                 -> [b]                     -- ^ The filter coefficients
                 -> IO (Decimator m v vm a) -- ^ The `Decimator` data structure
haskellDecimator decimationD coeffs = do
    let vCoeffs     = VG.fromList coeffs
    evaluate vCoeffs
    let decimateOne   = decimateHighLevel      decimationD vCoeffs
        decimateCross = decimateCrossHighLevel decimationD vCoeffs
        numCoeffsD    = length coeffs
    return $ Decimator {..}

mkDecimator :: Int
            -> DecimateRR
            -> Int
            -> [Float]
            -> IO (Decimator IO VS.Vector VS.MVector Float)
mkDecimator sizeMultiple filterFunc decimationD coeffs = do
    let l          = length coeffs
        numCoeffsD = roundUp l sizeMultiple
        diff       = numCoeffsD - l
        vCoeffs    = VG.fromList $ coeffs ++ replicate diff 0
    evaluate vCoeffs
    let decimateOne   = filterFunc             decimationD vCoeffs
        decimateCross = decimateCrossHighLevel decimationD vCoeffs
    return Decimator {..}

-- | Returns a fast Decimator data structure implemented in C. For decimating real data with real coefficients.
fastDecimatorCR :: Int                                          -- ^ The decimation factor
                -> [Float]                                      -- ^ The filter coefficients
                -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure
fastDecimatorCR = mkDecimator 1 decimateCRR

-- | Returns a fast Decimator data structure implemented in C using SSE instructions. For decimating real data with real coefficients.
fastDecimatorSSER :: Int                                          -- ^ The decimation factor
                  -> [Float]                                      -- ^ The filter coefficients
                  -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure
fastDecimatorSSER = mkDecimator 4 decimateCSSERR

-- | Returns a fast Decimator data structure implemented in C using AVX instructions. For decimating real data with real coefficients.
fastDecimatorAVXR :: Int                                          -- ^ The decimation factor
                  -> [Float]                                      -- ^ The filter coefficients
                  -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure
fastDecimatorAVXR = mkDecimator 8 decimateCAVXRR

-- | Returns a fast Decimator data structure implemented in C using the fastest SIMD instruction set your processor supports. For decimating real data with real coefficients.
fastDecimatorR :: CPUInfo                                      -- ^ The CPU's capabilities
               -> Int                                          -- ^ The decimation factor
               -> [Float]                                      -- ^ The filter coefficients
               -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure
fastDecimatorR info = featureSelect info fastDecimatorCR [(hasAVX, fastDecimatorAVXR), (hasSSE42, fastDecimatorSSER)]

mkDecimatorC :: Int
             -> DecimateRC
             -> Int
             -> [Float]
             -> IO (Decimator IO VS.Vector VS.MVector (Complex Float))
mkDecimatorC sizeMultiple filterFunc decimationD coeffs = do
    let l          = length coeffs
        numCoeffsD = roundUp l sizeMultiple
        diff       = numCoeffsD - l
        vCoeffs    = VG.fromList $ duplicate $ coeffs ++ replicate diff 0
        vCoeffs2   = VG.fromList $ coeffs ++ replicate diff 0
    evaluate vCoeffs
    let decimateOne   = filterFunc             decimationD vCoeffs
        decimateCross = decimateCrossHighLevel decimationD vCoeffs2
    return Decimator {..}

-- | Returns a fast Decimator data structure implemented in C. For decimating complex data with real coefficients.
fastDecimatorCC :: Int                                                    -- ^ The decimation factor
                -> [Float]                                                -- ^ The filter coefficients
                -> IO (Decimator IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Decimator` data structure
fastDecimatorCC = mkDecimatorC 1 decimateCRC

-- | Returns a fast Decimator data structure implemented in C using SSE instructions. For decimating complex data with real coefficients.
fastDecimatorSSEC :: Int                                                    -- ^ The decimation factor
                  -> [Float]                                                -- ^ The filter coefficients
                  -> IO (Decimator IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Decimator` data structure
fastDecimatorSSEC = mkDecimatorC 2 decimateCSSERC

-- | Returns a fast Decimator data structure implemented in C using AVX instructions. For decimating complex data with real coefficients.
fastDecimatorAVXC :: Int                                                 -- ^ The decimation factor
               -> [Float]                                                -- ^ The filter coefficients
               -> IO (Decimator IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Decimator` data structure
fastDecimatorAVXC = mkDecimatorC 4 decimateCAVXRC

-- | Returns a fast Decimator data structure implemented in C using the fastest SIMD instruction set your processor supports. For decimating complex data with real coefficients.
fastDecimatorC :: CPUInfo                                                -- ^ The CPU's capabilities
               -> Int                                                    -- ^ The decimation factor
               -> [Float]                                                -- ^ The filter coefficients
               -> IO (Decimator IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Decimator` data structure
fastDecimatorC info = featureSelect info fastDecimatorCC [(hasAVX, fastDecimatorAVXC), (hasSSE42, fastDecimatorSSEC)]

mkDecimatorSymR :: DecimateRR
                -> Int
                -> [Float]
                -> IO (Decimator IO VS.Vector VS.MVector Float)
mkDecimatorSymR filterFunc decimationD coeffs = do
    let vCoeffs    = VG.fromList coeffs
    let vCoeffs2   = VG.fromList $ coeffs ++ reverse coeffs
    evaluate vCoeffs
    evaluate vCoeffs2
    let decimateOne   = filterFunc             decimationD vCoeffs
        decimateCross = decimateCrossHighLevel decimationD vCoeffs2
        numCoeffsD    = length coeffs * 2

    return Decimator {..}
-- | Returns a fast Decimator data structure implemented in C using SSE instructions. For decimating real data with real coefficients. For decimators with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4.
fastDecimatorSymSSER :: Int                                          -- ^ The decimation factor
                     -> [Float]                                      -- ^ The first half of the filter coefficients
                     -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure
fastDecimatorSymSSER = mkDecimatorSymR decimateCSSESymmetricRR

-- | Returns a fast Decimator data structure implemented in C using AVX instructions. For decimating real data with real coefficients. For decimators with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4.
fastDecimatorSymAVXR :: Int                                          -- ^ The decimation factor
                     -> [Float]                                      -- ^ The first half of the filter coefficients
                     -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure
fastDecimatorSymAVXR = mkDecimatorSymR decimateCAVXSymmetricRR

-- | Returns a fast Decimator data structure implemented in C using the fastest SIMD instruction set your processor supports. For decimating real data with real coefficients. For decimators with symmetric coefficients, i.e. 'linear phase'. Coefficient length must be a multiple of 4.
fastDecimatorSymR :: CPUInfo                                      -- ^ The CPU's capabilities
                  -> Int                                          -- ^ The decimation factor
                  -> [Float]                                      -- ^ The filter coefficients
                  -> IO (Decimator IO VS.Vector VS.MVector Float) -- ^ The `Decimator` data structure
fastDecimatorSymR info = featureSelect info (error "at least AVX required") [(hasAVX, fastDecimatorSymAVXR), (hasSSE42, fastDecimatorSymSSER)]

{-# INLINE haskellResampler #-}
-- | Returns a slow Resampler data structure entirely implemented in Haskell
haskellResampler :: (PrimMonad m, Functor m, Num a, Mult a b, VG.Vector v a, VG.Vector v b, VGM.MVector vm a)
                  => Int                     -- ^ The interpolation factor
                  -> Int                     -- ^ The decimation factor
                  -> [b]                     -- ^ The filter coefficients
                  -> IO (Resampler m v vm a) -- ^ The `Resampler` data structure
haskellResampler interpolationR decimationR coeffs = do
    let vCoeffs     = VG.fromList coeffs
    evaluate vCoeffs
    let resampleOne   v w x y   = func <$> resampleHighLevel      interpolationR decimationR vCoeffs v w x y
        resampleCross v w x y z = func <$> resampleCrossHighLevel interpolationR decimationR vCoeffs v w x y z
        numCoeffsR            = length coeffs
        func          x       = (x, x)
        startDat              = 0
    return Resampler {..}

mkResampler :: Int
            -> ResampleRR
            -> Int
            -> Int
            -> [Float]
            -> IO (Resampler IO VS.Vector VS.MVector Float)
mkResampler sizeMultiple filterFunc interpolationR decimationR coeffs = do
    let vCoeffs     = VG.fromList coeffs
    evaluate vCoeffs
    resamp <- filterFunc interpolationR decimationR coeffs
    let resampleOne   v w x y   = func1 <$> resamp (fst v) w x y
        resampleCross (group, offset) count x y z = do
            offset' <- resampleCrossHighLevel interpolationR decimationR vCoeffs offset count x y z
            return (((group + count) `mod` interpolationR, offset'), offset')
        numCoeffsR              = roundUp (length coeffs) (interpolationR * sizeMultiple)
        func1 group             = let offset = interpolationR - 1 - ((interpolationR + group * decimationR - 1) `mod` interpolationR) in ((group, offset), offset)
        startDat                = (0, 0)
    return Resampler {..}

mkResamplerC :: Int
             -> ResampleRC
             -> Int
             -> Int
             -> [Float]
             -> IO (Resampler IO VS.Vector VS.MVector (Complex Float))
mkResamplerC sizeMultiple filterFunc interpolationR decimationR coeffs = do
    let vCoeffs     = VG.fromList coeffs
    evaluate vCoeffs
    resamp <- filterFunc interpolationR decimationR coeffs
    let resampleOne   v w x y   = func1 <$> resamp (fst v) w x y
        resampleCross (group, offset) count x y z = do
            offset' <- resampleCrossHighLevel interpolationR decimationR vCoeffs offset count x y z
            return (((group + count) `mod` interpolationR, offset'), offset')
        numCoeffsR              = roundUp (length coeffs) (interpolationR * sizeMultiple)
        func1 group             = let offset = interpolationR - 1 - ((interpolationR + group * decimationR - 1) `mod` interpolationR) in ((group, offset), offset)
        startDat                = (0, 0)
    return Resampler {..}

-- | Returns a fast Resampler data structure implemented in C. For filtering real data with real coefficients.
fastResamplerCR :: Int                                          -- ^ The interpolation factor
                -> Int                                          -- ^ The decimation factor
                -> [Float]                                      -- ^ The filter coefficients
                -> IO (Resampler IO VS.Vector VS.MVector Float) -- ^ The `Resampler` data structure
fastResamplerCR = mkResampler 1 resampleCRR2

-- | Returns a fast Resampler data structure implemented in C using SSE instructions. For filtering real data with real coefficients.
fastResamplerSSER :: Int                                          -- ^ The interpolation factor
                  -> Int                                          -- ^ The decimation factor
                  -> [Float]                                      -- ^ The filter coefficients
                  -> IO (Resampler IO VS.Vector VS.MVector Float) -- ^ The `Resampler` data structure
fastResamplerSSER = mkResampler 4 resampleCSSERR

-- | Returns a fast Resampler data structure implemented in C using AVX instructions. For filtering real data with real coefficients.
fastResamplerAVXR :: Int                                          -- ^ The interpolation factor
                  -> Int                                          -- ^ The decimation factor
                  -> [Float]                                      -- ^ The filter coefficients
                  -> IO (Resampler IO VS.Vector VS.MVector Float) -- ^ The `Resampler` data structure
fastResamplerAVXR = mkResampler 8 resampleCAVXRR

-- | Returns a fast Resampler data structure implemented in C using the fastest SIMD instruction set your processor supports. For resampling real data with real coefficients.
fastResamplerR :: CPUInfo                                      -- ^ The CPU's capabilities
               -> Int                                          -- ^ The interpolation factor
               -> Int                                          -- ^ The decimation factor
               -> [Float]                                      -- ^ The filter coefficients
               -> IO (Resampler IO VS.Vector VS.MVector Float) -- ^ The `Resampler` data structure
fastResamplerR info = featureSelect info fastResamplerCR [(hasAVX, fastResamplerAVXR), (hasSSE42, fastResamplerSSER)]

-- | Returns a fast Resampler data structure implemented in C. For filtering complex data with real coefficients.
fastResamplerCC :: Int                                          -- ^ The interpolation factor
                -> Int                                          -- ^ The decimation factor
                -> [Float]                                      -- ^ The filter coefficients
                -> IO (Resampler IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Resampler` data structure
fastResamplerCC = mkResamplerC 1 resampleCRC

-- | Returns a fast Resampler data structure implemented in C using SSE instructions. For filtering complex data with real coefficients.
fastResamplerSSEC :: Int                                          -- ^ The interpolation factor
                  -> Int                                          -- ^ The decimation factor
                  -> [Float]                                      -- ^ The filter coefficients
                  -> IO (Resampler IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Resampler` data structure
fastResamplerSSEC = mkResamplerC 4 resampleCSSERC

-- | Returns a fast Resampler data structure implemented in C using AVX instructions. For filtering complex data with real coefficients.
fastResamplerAVXC :: Int                                          -- ^ The interpolation factor
                  -> Int                                          -- ^ The decimation factor
                  -> [Float]                                      -- ^ The filter coefficients
                  -> IO (Resampler IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Resampler` data structure
fastResamplerAVXC = mkResamplerC 8 resampleCAVXRC

-- | Returns a fast Resampler data structure implemented in C using the fastest SIMD instruction set your processor supports. For resampling complex data with real coefficients.
fastResamplerC :: CPUInfo                                      -- ^ The CPU's capabilities
               -> Int                                          -- ^ The interpolation factor
               -> Int                                          -- ^ The decimation factor
               -> [Float]                                      -- ^ The filter coefficients
               -> IO (Resampler IO VS.Vector VS.MVector (Complex Float)) -- ^ The `Resampler` data structure
fastResamplerC info = featureSelect info fastResamplerCC [(hasAVX, fastResamplerAVXC), (hasSSE42, fastResamplerSSEC)]

data Buffer v a = Buffer {
    buffer :: v a,
    offset :: Int
}

space Buffer{..} = VGM.length buffer - offset

newBuffer :: (PrimMonad m, VGM.MVector vm a) => Int -> m (Buffer (vm (PrimState m)) a)
newBuffer size = do
    buf <- VGM.new size
    return $ Buffer buf 0

advanceOutBuf :: (PrimMonad m, VG.Vector v a) => Int -> Buffer (VG.Mutable v (PrimState m)) a -> Int -> Pipe b (v a) m (Buffer (VG.Mutable v (PrimState m)) a)
advanceOutBuf blockSizeOut buf@(Buffer bufOut offsetOut) count =
    if count == space buf then do
        bufOutF <- lift $ VG.unsafeFreeze bufOut
        yield bufOutF
        lift $ newBuffer blockSizeOut
    else
        return $ Buffer bufOut (offsetOut + count)

-- | My own assert implementation since the GHC one doesnt seem to work even with optimisations disabled and using -fno-ignore-asserts
assert loc False = error loc
assert loc True  = return ()

--Filtering
{-# INLINE firFilter #-}
{-| Create a pipe that performs filtering -}
firFilter :: (PrimMonad m, Functor m, VG.Vector v a, Num a)
        => Filter m v (VG.Mutable v) a -- ^ The `Filter` data structure
        -> Int                         -- ^ The output block size
        -> Pipe (v a) (v a) m ()       -- ^ The `Pipe` that does the filtering
firFilter Filter{..} blockSizeOut = do
    inBuf  <- await
    outBuf <- lift $ newBuffer blockSizeOut
    simple inBuf outBuf

    where

    simple bufIn bufferOut@(Buffer bufOut offsetOut) = do
        assert "filter 1" (VG.length bufIn >= numCoeffsF)

        let count = min (VG.length bufIn - numCoeffsF + 1) (space bufferOut)
        lift $ filterOne count bufIn (VGM.unsafeDrop offsetOut bufOut)

        bufferOut' <- advanceOutBuf blockSizeOut bufferOut count
        let bufIn' =  VG.drop count bufIn

        case VG.length bufIn' < numCoeffsF of
            False -> simple bufIn' bufferOut'
            True  -> do
                next <- await
                crossover bufIn' next bufferOut'

    crossover bufLast bufNext bufferOut@(Buffer bufOut offsetOut) = do
        assert "filter 2" (VG.length bufLast < numCoeffsF)
        assert "filter 3" (VG.length bufLast > 0)

        let count = min (VG.length bufLast) (space bufferOut)
        lift $ filterCross count bufLast bufNext (VGM.unsafeDrop offsetOut bufOut)

        bufferOut' <- advanceOutBuf blockSizeOut bufferOut count

        case VG.length bufLast == count of
            True  -> simple bufNext bufferOut'
            False -> crossover (VG.drop count bufLast) bufNext bufferOut'

--Decimation
{-# INLINE firDecimator #-}
{-| Create a pipe that performs decimation -}
firDecimator :: (PrimMonad m, Functor m, VG.Vector v a, Num a)
         => Decimator m v (VG.Mutable v) a -- ^ The `Decimator` data structure
         -> Int                            -- ^ The output block size
         -> Pipe (v a) (v a) m ()          -- ^ The `Pipe` that does the decimation
firDecimator Decimator{..} blockSizeOut = do
    inBuf  <- await
    outBuf <- lift $ newBuffer blockSizeOut
    simple inBuf outBuf

    where

    simple bufIn bufferOut@(Buffer bufOut offsetOut) = do
        assert "decimate 1" (VG.length bufIn >= numCoeffsD)

        let count = min (((VG.length bufIn - numCoeffsD) `quot` decimationD) + 1) (space bufferOut)
        lift $ decimateOne count bufIn (VGM.unsafeDrop offsetOut bufOut)

        bufferOut' <- advanceOutBuf blockSizeOut bufferOut count
        let bufIn' = VG.drop (count * decimationD) bufIn

        case VG.length bufIn' < numCoeffsD of
            False -> simple bufIn' bufferOut'
            True  -> do
                next <- await
                crossover bufIn' next bufferOut'

    crossover bufLast bufNext bufferOut@(Buffer bufOut offsetOut) = do
        assert "decimate 2" (VG.length bufLast < numCoeffsD)
        assert "decimate 3" (VG.length bufLast > 0)

        let count = min (VG.length bufLast `quotUp` decimationD) (space bufferOut)
        lift $ decimateCross count bufLast bufNext (VGM.unsafeDrop offsetOut bufOut)

        bufferOut' <- advanceOutBuf blockSizeOut bufferOut count

        case VG.length bufLast <= count * decimationD of
            True  -> simple (VG.drop (count * decimationD - VG.length bufLast) bufNext) bufferOut'
            False -> crossover (VG.drop (count * decimationD) bufLast) bufNext bufferOut'

{-
Rational Downsampling:

Input upsampled by 3:    |**|**|**|**|**|**|**|**|**|**|**|
Output downsampled by 7: |******|******|******|******|*****

                  Consider here ^
                  Next output is here  ^

Filter offset is 2

k is number of used inputs

filterOffset + k*interpolation = decimation + filterOffset'
where
    k > 0
    0 <= filterOffset, filterOffset' < interpolation

k*interpolation - filterOffset' = decimation - filterOffset
k*interpolation - filterOffset' - 1 = decimation - filterOffset - 1

(k-1) * interpolation + (interpolation - filterOffset' - 1) = decimation - filterOffset - 1

k             = (decimation - filterOffset - 1) / interpolation + 1
filterOffset' = interpolation - 1 - (decimation - filterOffset - 1) % interpolation

Only works if decimation > interpolation

-}

{-
Rational Upsampling:

Input upsampled by 7:    |******|******|******|******|*****
Output downsampled by 3: |**|**|**|**|**|**|**|**|**|**|**|

              Consider Here ^
              Next sample is   ^

Filter offset is 4

filterOffset + k * interpolation = decimation + filterOffset'
where
    k = {0, 1}
    0 <= filterOffset, filterOffset' < interpolation

k * interpolation + (interpolation - filterOffset' - 1) = decimation - filterOffset + interpolation - 1

k = (decimation - filterOffset + interpolation - 1) / interpolation

============================

Or, equivalently,

k = 0 | filterOffset >= decimation
    1 | otherwise

o = o - decimation + k * interpolation

-}

--Rational resampling
quotUp q d = (q + (d - 1)) `quot` d

{-# INLINE firResampler #-}
{-| Create a pipe that performs resampling -}
firResampler :: (PrimMonad m, VG.Vector v a, Num a)
         => Resampler m v (VG.Mutable v) a -- ^ The `Resampler` data structure
         -> Int                            -- ^ The output block size
         -> Pipe (v a) (v a) m ()          -- ^ The `Pipe` that does the resampling
firResampler Resampler{..} blockSizeOut = do
    inBuf  <- await
    outBuf <- lift $ newBuffer blockSizeOut
    simple inBuf outBuf startDat 0

    where

    simple bufIn bufferOut@(Buffer bufOut offsetOut) dat filterOffset = do
        assert "resample 1" (VG.length bufIn * interpolationR >= numCoeffsR - filterOffset)
        --available number of samples == interpolation * num_input
        --required number of samples  == decimation * (num_output - 1) + filter_length - filter_offset
        let count = min (((VG.length bufIn * interpolationR - numCoeffsR + filterOffset) `quot` decimationR) + 1) (space bufferOut)
        (dat, endOffset) <- lift $ resampleOne dat count bufIn (VGM.unsafeDrop offsetOut bufOut)
        assert "resample 2" ((count * decimationR + endOffset - filterOffset) `rem` interpolationR == 0)
        bufferOut' <- advanceOutBuf blockSizeOut bufferOut count
        --samples no longer needed starting from filterOffset == count * decimation - filterOffset
        --inputs lying in this region                         == (count * decimation - filterOffset) / interpolation (rounding up)
        let usedInput = (count * decimationR - filterOffset) `quotUp` interpolationR
            bufIn'    = VG.drop usedInput bufIn

        case VG.length bufIn' * interpolationR < numCoeffsR - endOffset of
            False -> simple bufIn' bufferOut' dat endOffset
            True  -> do
                next <- await
                --TODO: why is this not needed in filter and decimator
                case VG.length bufIn' == 0 of
                    True ->  simple    next bufferOut' dat endOffset
                    False -> crossover bufIn' next bufferOut' dat endOffset

    crossover bufLast bufNext bufferOut@(Buffer bufOut offsetOut) dat filterOffset = do
        assert "resample 3" (VG.length bufLast * interpolationR < numCoeffsR - filterOffset)
        --outputsComputable is the number of outputs that need to be computed for the last buffer to no longer be needed
        --outputsComputable * decimation == numInput * interpolation + filterOffset + k
        let outputsComputable = (VG.length bufLast * interpolationR + filterOffset) `quotUp` decimationR
            count = min outputsComputable (space bufferOut)
        assert "resample 4" (count /= 0)
        (dat, endOffset) <- lift $ resampleCross dat count bufLast bufNext (VGM.unsafeDrop offsetOut bufOut)
        assert "resample 5" ((count * decimationR + endOffset - filterOffset) `rem` interpolationR == 0)
        bufferOut' <- advanceOutBuf blockSizeOut bufferOut count

        let inputUsed = (count * decimationR - filterOffset) `quotUp` interpolationR

        case inputUsed >= VG.length bufLast of
            True  -> simple (VG.drop (inputUsed - VG.length bufLast) bufNext) bufferOut' dat endOffset
            False -> crossover (VG.drop inputUsed bufLast) bufNext bufferOut' dat endOffset

-- | A DC blocking filter
dcBlockingFilter :: Pipe (VS.Vector Float) (VS.Vector Float) IO ()
dcBlockingFilter = func 0 0
    where
    func lastSample lastOutput = do
        dat <- await
        out <- lift $ VGM.new (VG.length dat)
        (lastSample, lastOutput) <- lift $ dcBlocker (VG.length dat) lastSample lastOutput dat out
        outF <- lift $ VG.unsafeFreeze out
        yield outF
        func lastSample lastOutput


{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif

#include "lens-common.h"

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Each
-- Copyright   :  (C) 2012-16 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module Control.Lens.Each
  (
  -- * Each
    Each(..)
  ) where

import Prelude ()

import Control.Lens.Traversal
import Control.Lens.Internal.ByteString
import Control.Lens.Internal.Prelude
import Data.Array.Unboxed as Unboxed
import Data.Array.IArray as IArray
import Data.ByteString as StrictB
import Data.ByteString.Lazy as LazyB
import Data.Complex
import Data.HashMap.Lazy as HashMap
import Data.IntMap as IntMap
import Data.Map as Map
import Data.Sequence as Seq
import Data.Text.Lens (text)
import Data.Text as StrictT
import Data.Text.Lazy as LazyT
import Data.Tree as Tree
import Data.Vector.Generic.Lens (vectorTraverse)
import qualified Data.Vector as Vector
import qualified Data.Vector.Primitive as Prim
import Data.Vector.Primitive (Prim)
import qualified Data.Vector.Storable as Storable
import Data.Vector.Storable (Storable)
import qualified Data.Vector.Unboxed as Unboxed
import Data.Vector.Unboxed (Unbox)
import Data.Word

-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens
-- >>> import Data.Text.Strict.Lens as Text
-- >>> import Data.Char as Char

-- | Extract 'each' element of a (potentially monomorphic) container.
--
-- Notably, when applied to a tuple, this generalizes 'Control.Lens.Traversal.both' to arbitrary homogeneous tuples.
--
-- >>> (1,2,3) & each *~ 10
-- (10,20,30)
--
-- It can also be used on monomorphic containers like 'StrictT.Text' or 'StrictB.ByteString'.
--
-- >>> over each Char.toUpper ("hello"^.Text.packed)
-- "HELLO"
--
-- >>> ("hello","world") & each.each %~ Char.toUpper
-- ("HELLO","WORLD")
class Each s t a b | s -> a, t -> b, s b -> t, t a -> s where
  each :: Traversal s t a b
  default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b
  each = traverse
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' (a,a) (b,b) a b@
instance (a~a', b~b') => Each (a,a') (b,b') a b where
  each f ~(a,b) = (,) <$> f a <*> f b
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' (a,a,a) (b,b,b) a b@
instance (a~a2, a~a3, b~b2, b~b3) => Each (a,a2,a3) (b,b2,b3) a b where
  each f ~(a,b,c) = (,,) <$> f a <*> f b <*> f c
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' (a,a,a,a) (b,b,b,b) a b@
instance (a~a2, a~a3, a~a4, b~b2, b~b3, b~b4) => Each (a,a2,a3,a4) (b,b2,b3,b4) a b where
  each f ~(a,b,c,d) = (,,,) <$> f a <*> f b <*> f c <*> f d
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' (a,a,a,a,a) (b,b,b,b,b) a b@
instance (a~a2, a~a3, a~a4, a~a5, b~b2, b~b3, b~b4, b~b5) => Each (a,a2,a3,a4,a5) (b,b2,b3,b4,b5) a b where
  each f ~(a,b,c,d,e) = (,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' (a,a,a,a,a,a) (b,b,b,b,b,b) a b@
instance (a~a2, a~a3, a~a4, a~a5, a~a6, b~b2, b~b3, b~b4, b~b5, b~b6) => Each (a,a2,a3,a4,a5,a6) (b,b2,b3,b4,b5,b6) a b where
  each f ~(a,b,c,d,e,g) = (,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' (a,a,a,a,a,a,a) (b,b,b,b,b,b,b) a b@
instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7) => Each (a,a2,a3,a4,a5,a6,a7) (b,b2,b3,b4,b5,b6,b7) a b where
  each f ~(a,b,c,d,e,g,h) = (,,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g <*> f h
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' (a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b) a b@
instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8) => Each (a,a2,a3,a4,a5,a6,a7,a8) (b,b2,b3,b4,b5,b6,b7,b8) a b where
  each f ~(a,b,c,d,e,g,h,i) = (,,,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g <*> f h <*> f i
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' (a,a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b,b) a b@
instance (a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, a~a9, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8, b~b9) => Each (a,a2,a3,a4,a5,a6,a7,a8,a9) (b,b2,b3,b4,b5,b6,b7,b8,b9) a b where
  each f ~(a,b,c,d,e,g,h,i,j) = (,,,,,,,,) <$> f a <*> f b <*> f c <*> f d <*> f e <*> f g <*> f h <*> f i <*> f j
  {-# INLINE each #-}

-- | @'each' :: ('RealFloat' a, 'RealFloat' b) => 'Traversal' ('Complex' a) ('Complex' b) a b@
instance Each (Complex a) (Complex b) a b where
  each f (a :+ b) = (:+) <$> f a <*> f b
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' ('Map' c a) ('Map' c b) a b@
instance (c ~ d) => Each (Map c a) (Map d b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' ('Map' c a) ('Map' c b) a b@
instance Each (IntMap a) (IntMap b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' ('HashMap' c a) ('HashMap' c b) a b@
instance (c ~ d) => Each (HashMap c a) (HashMap d b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' [a] [b] a b@
instance Each [a] [b] a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' (NonEmpty a) (NonEmpty b) a b@
instance Each (NonEmpty a) (NonEmpty b) a b

-- | @'each' :: 'Traversal' ('Identity' a) ('Identity' b) a b@
instance Each (Identity a) (Identity b) a b

-- | @'each' :: 'Traversal' ('Maybe' a) ('Maybe' b) a b@
instance Each (Maybe a) (Maybe b) a b

-- | @'each' :: 'Traversal' ('Either' a a) ('Either' b b) a b@
--
-- @since 4.18
instance (a~a', b~b') => Each (Either a a') (Either b b') a b where
  each f (Left a)   = Left <$> f a
  each f (Right a ) = Right <$> f a
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' ('Seq' a) ('Seq' b) a b@
instance Each (Seq a) (Seq b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' ('Tree' a) ('Tree' b) a b@
instance Each (Tree a) (Tree b) a b

-- | @'each' :: 'Traversal' ('Vector.Vector' a) ('Vector.Vector' b) a b@
instance Each (Vector.Vector a) (Vector.Vector b) a b where
  each = vectorTraverse
  {-# INLINE each #-}

-- | @'each' :: ('Prim' a, 'Prim' b) => 'Traversal' ('Prim.Vector' a) ('Prim.Vector' b) a b@
instance (Prim a, Prim b) => Each (Prim.Vector a) (Prim.Vector b) a b where
  each = vectorTraverse
  {-# INLINE each #-}

-- | @'each' :: ('Storable' a, 'Storable' b) => 'Traversal' ('Storable.Vector' a) ('Storable.Vector' b) a b@
instance (Storable a, Storable b) => Each (Storable.Vector a) (Storable.Vector b) a b where
  each = vectorTraverse
  {-# INLINE each #-}

-- | @'each' :: ('Unbox' a, 'Unbox' b) => 'Traversal' ('Unboxed.Vector' a) ('Unboxed.Vector' b) a b@
instance (Unbox a, Unbox b) => Each (Unboxed.Vector a) (Unboxed.Vector b) a b where
  each = vectorTraverse
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' 'StrictT.Text' 'StrictT.Text' 'Char' 'Char'@
instance (a ~ Char, b ~ Char) => Each StrictT.Text StrictT.Text a b where
  each = text
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' 'LazyT.Text' 'LazyT.Text' 'Char' 'Char'@
instance (a ~ Char, b ~ Char) => Each LazyT.Text LazyT.Text a b where
  each = text
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' 'StrictB.ByteString' 'StrictB.ByteString' 'Word8' 'Word8'@
instance (a ~ Word8, b ~ Word8) => Each StrictB.ByteString StrictB.ByteString a b where
  each = traversedStrictTree
  {-# INLINE each #-}

-- | @'each' :: 'Traversal' 'LazyB.ByteString' 'LazyB.ByteString' 'Word8' 'Word8'@
instance (a ~ Word8, b ~ Word8) => Each LazyB.ByteString LazyB.ByteString a b where
  each = traversedLazy
  {-# INLINE each #-}

-- | @'each' :: 'Ix' i => 'Traversal' ('Array' i a) ('Array' i b) a b@
instance (Ix i, i ~ j) => Each (Array i a) (Array j b) a b where
  each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f a) (IArray.assocs arr)
  {-# INLINE each #-}

-- | @'each' :: ('Ix' i, 'IArray' 'UArray' a, 'IArray' 'UArray' b) => 'Traversal' ('Array' i a) ('Array' i b) a b@
instance (Ix i, IArray UArray a, IArray UArray b, i ~ j) => Each (UArray i a) (UArray j b) a b where
  each f arr = array (bounds arr) <$> traverse (\(i,a) -> (,) i <$> f a) (IArray.assocs arr)
  {-# INLINE each #-}


module Utilities.Types where
import           Data.Complex
import qualified System.IO                     as IO
import           Data.Ratio
import           Data.Array
import           Data.IORef
import           Control.Monad.Except
import           Text.ParserCombinators.Parsec
                                         hiding ( spaces )

type Env = IORef [(String, IORef LispVal)]
type ThrowsError = Either LispError
type IOThrowsError = ExceptT LispError IO

data LispError = NumArgs Integer [LispVal]
    | TypeMismatch String LispVal
    | Parser ParseError
    | BadSpecialForm String LispVal
    | NotFunction String String
    | UnboundVar String String
    | Default String

data LispVal = Atom String
    | List [LispVal]
    | DottedList [LispVal] LispVal
    | Number Integer
    | String String
    | Bool Bool
    | Character Char
    | Float Double
    | Ratio Rational
    | Complex (Complex Double)
    | Vector (Array Int LispVal)
    | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
    | Func {params :: [String], vararg :: Maybe String,
        body :: [LispVal], closure :: Env}
    | IOFunc ([LispVal] -> IOThrowsError LispVal)
    | Port IO.Handle
    | None

showVal :: LispVal -> String
showVal val = case val of
    String contents -> "\"" ++ contents ++ "\""
    Atom   name     -> name
    Number contents -> show contents
    Bool   True     -> "#t"
    Bool   False    -> "#f"
    List   contents -> "(" ++ unwordsList contents ++ ")"
    DottedList head tail ->
        "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
    PrimitiveFunc _ -> "<primitive"
    Func { params = args, vararg = varargs, body = body, closure = env } ->
        "(lambda ("
            ++ unwords (map show args)
            ++ (case varargs of
                   Nothing  -> ""
                   Just arg -> " . " ++ arg
               )
            ++ ") ...)"
    Port   _ -> "<IO port>"
    IOFunc _ -> "<IO primitive>"

instance Show LispVal where
    show = showVal
instance Eq LispVal where
    (==) = (==)

unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal