text:
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances, DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables, BangPatterns, ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module:      Data.Configurator.FromValue.Implementation
-- Copyright:   (c) 2016 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>

module Data.Configurator.FromValue.Implementation where

import           Prelude
import           Control.Applicative
import           Control.Arrow (first, second)
import           Control.Monad (ap)
import qualified Control.Monad.Fail as Fail
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import           Data.Complex (Complex((:+)))
import           Data.Configurator.Types
                   ( Value(..)
                   , ConversionError(..)
                   , ConversionErrorWhy(..)
                   , defaultConversionError
                   )
import           Data.Configurator.Types.Internal
                   ( MultiErrors
                   , singleError
                   , toErrors
                   )
import           Data.Fixed (Fixed, HasResolution)
import           Data.Int(Int8, Int16, Int32, Int64)
-- import           Data.Monoid
import           Data.Ratio ( Ratio, (%) )
import           Data.Scientific
                   ( Scientific,  coefficient, base10Exponent, normalize
                   , floatingOrInteger, toRealFloat, toBoundedInteger )
import           Data.Text(Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import           Data.Text.Encoding(encodeUtf8)
import           Data.Typeable(Typeable, TypeRep, typeOf)
#if !(MIN_VERSION_base(4,8,0))
import           Data.Word(Word)
#endif
import           Data.Word(Word8, Word16, Word32, Word64)
import           Foreign.C.Types(CFloat, CDouble)

type ConversionErrors = MultiErrors ConversionError

-- | An action to turn a 'Maybe' 'Value' into zero or one values of type @a@,
--   and possibly report errors/warnings.
newtype MaybeParser a = MaybeParser {
      unMaybeParser :: Maybe Value -> (Maybe a, ConversionErrors)
    } deriving (Functor, Typeable)

-- | An action to turn a 'Value' into zero or one values of type @a@,
--   and possibly report errors/warnings.
newtype ValueParser a = ValueParser {
      unValueParser :: Value -> (Maybe a, ConversionErrors)
    } deriving (Functor, Typeable)

data ListParserResult a =
     NonListError
   | ListError
   | ListOk a [Value]
     deriving (Functor, Typeable)

-- | An action to turn a @['Value']@ into zero or one values of type @a@,
--   and possibly report errors/warnings.
newtype ListParser a = ListParser {
      unListParser :: [Value] -> (ListParserResult a, ConversionErrors)
    } deriving (Functor, Typeable)

instance Applicative MaybeParser where
    pure a = MaybeParser $ \_v -> (Just a, mempty)
    (<*>) ff fa =
        MaybeParser $ \v ->
            case unMaybeParser ff v of
              (Nothing, w) -> (Nothing, w)
              (Just f , w) ->
                  case unMaybeParser fa v of
                    (Nothing, w') -> (Nothing   , w <> w')
                    (Just a , w') -> (Just (f a), w <> w')

instance Applicative ValueParser where
    pure a = ValueParser $ \_v -> (Just a, mempty)
    (<*>) ff fa =
        ValueParser $ \v ->
            case unValueParser ff v of
              (Nothing, w) -> (Nothing, w)
              (Just f , w) ->
                  case unValueParser fa v of
                    (Nothing, w') -> (Nothing   , w <> w')
                    (Just a , w') -> (Just (f a), w <> w')

instance Alternative ValueParser where
    empty   = ValueParser $ \_v -> (Nothing, mempty)
    f <|> g = ValueParser $ \v ->
                 case unValueParser f v of
                   (Nothing, Nothing) -> unValueParser g v
                   (Nothing, w) ->
                       case unValueParser g v of
                         (Nothing, w') -> (Nothing, w <> w')
                         res -> res
                   res -> res

    some v = repeat <$> v
    many v = some v <|> pure []

instance Alternative MaybeParser where
    empty   = MaybeParser $ \_v -> (Nothing, mempty)
    f <|> g = MaybeParser $ \v ->
                 case unMaybeParser f v of
                   (Nothing, Nothing) -> unMaybeParser g v
                   (Nothing, w) ->
                       case unMaybeParser g v of
                         (Nothing, w') -> (Nothing, w <> w')
                         res -> res
                   res -> res

    some v = repeat <$> v
    many v = some v <|> pure []

instance Monad MaybeParser where
#if !(MIN_VERSION_base(4,8,0))
    return = pure
#endif
    m >>= k  = MaybeParser $ \v ->
                   case unMaybeParser m v of
                     (Just a, w) ->
                         case w of
                           Nothing -> unMaybeParser (k a) v
                           Just _  -> let (mb, w') = unMaybeParser (k a) v
                                       in (mb, w <> w')
                     (Nothing, w) -> (Nothing, w)

    fail = Fail.fail

instance Monad ValueParser where
#if !(MIN_VERSION_base(4,8,0))
    return = pure
#endif
    m >>= k  = ValueParser $ \v ->
                   case unValueParser m v of
                     (Just a, w) ->
                         case w of
                           Nothing -> unValueParser (k a) v
                           Just _  -> let (mb, w') = unValueParser (k a) v
                                       in (mb, w <> w')
                     (Nothing, w) -> (Nothing, w)

    fail = Fail.fail

instance Fail.MonadFail MaybeParser where
    fail msg = MaybeParser $ \_v -> (Nothing, singleError (failError msg))

instance Fail.MonadFail ValueParser where
    fail msg = ValueParser $ \_v -> (Nothing, singleError (failError msg))

failError :: String -> ConversionError
failError msg = defaultConversionError {
                  conversionErrorLoc = "fail",
                  conversionErrorWhy = MonadFail,
                  conversionErrorMsg = Just (T.pack msg)
                }

runMaybeParser :: MaybeParser a -> Maybe Value -> (Maybe a, [ConversionError])
runMaybeParser p = second toErrors . unMaybeParser p

runValueParser :: ValueParser a -> Value -> (Maybe a, [ConversionError])
runValueParser p = second toErrors . unValueParser p

instance Applicative ListParser where
    pure a = ListParser $ \vs -> (ListOk a vs, mempty)
    (<*>) = ap

instance Alternative ListParser where
    empty   = ListParser $ \_v -> (ListError, mempty)
    f <|> g = ListParser $ \v ->
                 case unListParser f v of
                   (ListError, Nothing)  -> unListParser g v
                   (ListError, w) ->
                       case unListParser g v of
                         (ListError, w') -> (ListError, w <> w')
                         res -> res
                   res -> res

instance Monad ListParser where
#if !(MIN_VERSION_base(4,8,0))
    return = pure
#endif
    m >>= k  = ListParser $ \v ->
                   case unListParser m v of
                     (ListOk a v', w) ->
                         case w of
                           Nothing -> unListParser (k a) v'
                           Just _  -> let (mb, w') = unListParser (k a) v'
                                       in (mb, w <> w')
                     (ListError, w) ->
                         (ListError, w)
                     (NonListError, w) ->
                         (NonListError, w)

    fail = Fail.fail

instance Fail.MonadFail ListParser where
    fail msg = ListParser $ \_v -> (NonListError, singleError (failError msg))

-- | Turns a 'ValueParser' into a 'MaybeParser'.  If the 'Maybe' 'Value' the
--   parser is passed is 'Nothing' (which normally means a key was not found),
--   then this returns the @Nothing@ value with no errors or warnings.
--   Otherwise, it passes the 'Value' to the subparser.  If the
--   subparser returns a result value, then this returns 'Just' the value.
--   Otherwise, if the subparser does not return a value,  then this does
--   not return a value.
--
--   Any errors/warnings returned by the subparser are returned exactly as-is.

optionalValue :: ValueParser a -> MaybeParser (Maybe a)
optionalValue p =
    MaybeParser $ \mv ->
       case mv of
         Nothing -> (Just Nothing, mempty)
         Just v  -> first (Just <$>) (unValueParser p v)

-- | Turns a 'ValueParser' into a 'MaybeParser'.  If the 'Maybe' 'Value' the
--   parser is passed is 'Nothing' (which normally means a key was not found),
--   then this does not return a value and also returns a 'missingValueError'.
--   Otherwise,  the 'Value' is passed to the subparser,  and the result
--   and any errors/warnings are returned as-is.

requiredValue :: forall a. Typeable a => ValueParser a -> MaybeParser a
requiredValue p =
    MaybeParser $ \mv ->
        case mv of
          Nothing -> (Nothing, err)
          Just v  -> unValueParser p v
  where
    funcName = "requiredValue"
    err = singleError $ missingValueError funcName (typeOf (undefined :: a))

missingValueError :: Text -> TypeRep -> ConversionError
missingValueError funcName typ = defaultConversionError {
      conversionErrorLoc  = funcName,
      conversionErrorWhy  = MissingValue,
      conversionErrorType = Just typ
   }

-- | Turns a 'ListParser' into a 'ValueParser'.  It first checks that the
--   'Value' the 'ValueParser' is passed is a 'List' Value.  If it's not,
--   this returns no result as well as a 'typeError'.  Otherwise, it passes
--   the list of results to the 'ListParser' subparser.
--
--   If the subparser consumes all of the list elements,  this returns the
--   value and errors as-is.   If there are leftover list elements,  this
--   returns the value, and adds a message warning of the extra elements
--   to the list of errors.
--
--   The difference from 'listValue\'' is that this returns values with
--   unconsumed list elements (discarding the list elements).

listValue :: forall a. Typeable a => ListParser a -> ValueParser a
listValue p =
    ValueParser $ \v ->
        case v of
          List vs ->
              case unListParser p vs of
                (ListOk a vs', errs) ->
                   case vs' of
                     []    -> (Just a, errs)
                     (_:_) -> (,) (Just a) $! errs <> extraErr vs
                (_, errs)  -> (Nothing, errs)
          _ -> (Nothing, typeErr v)
  where
    fn = "listValue"
    extraErr vs = singleError $ extraValuesError fn vs (typeOf (undefined :: a))
    typeErr  v  = singleError $ typeError        fn v  (typeOf (undefined :: a))

-- | Turns a 'ListParser' into a 'ValueParser'.  It first checks that the
--   'Value' the 'ValueParser' is passed is a 'List' Value.  If it's not,
--   this returns no result as well as a 'typeError'.  Otherwise, it passes
--   the list of results to the 'ListParser' subparser.
--
--   If the subparser consumes all of the list elements,  this returns the
--   value and errors as-is.   If there are leftover list elements,  this
--   returns no value, and adds a message warning of the extra elements
--   to the list of errors.
--
--   The difference from 'listValue' is that this never returns a value if
--   there are unconsumed list elements. (discarding both the value returned
--   and the list element.)

listValue' :: forall a. Typeable a => ListParser a -> ValueParser a
listValue' p =
    ValueParser $ \v ->
        case v of
          List vs ->
              case unListParser p vs of
                (ListOk a vs', errs) ->
                   case vs' of
                     []    -> (Just a, errs)
                     (_:_) -> (,) Nothing $! errs <> extraErr vs
                (_, errs)  -> (Nothing, errs)
          _ -> (Nothing, typeErr v)
  where
    fn = "listValue'"
    extraErr vs = singleError $ extraValuesError fn vs (typeOf (undefined :: a))
    typeErr  v  = singleError $ typeError        fn v  (typeOf (undefined :: a))

-- | Turns a 'ValueParser' into a 'ListParser' that consumes a single element.
--
--   If there are no list elements left, this returns list error value and an
--   'ExhaustedValues' error.
--
--   If there is an element left,  it is passed to the value parser.  If the
--   value parser returns a value,  it is returned along with the errors as-is.
--   If the value parser returns no value,  then this returns a non-list error
--   value and the list of errors returned by the value parser.
--
--   The difference between a "list error value" and a "non-list error value",
--   is that the 'Alternative' instance for 'ListParser' recovers from "list
--   error" values but does not recover from "non-list error" values.   This
--   behavior was chosen so that the 'optional', 'some', and 'many' combinators
--   work on 'ListParser's in a way that is hopefully least surprising.

listElem :: forall a. (Typeable a) => ValueParser a -> ListParser a
listElem p =
    ListParser $ \vs ->
        case vs of
          [] -> (ListError, exhaustedError)
          (v:vs') -> case unValueParser p v of
                       (Nothing, errs) -> (NonListError, errs)
                       (Just a,  errs) -> (ListOk a vs', errs)
  where
    exhaustedError = singleError defaultConversionError {
                       conversionErrorLoc  = "listElem",
                       conversionErrorWhy  = ExhaustedValues,
                       conversionErrorType = Just (typeOf (undefined :: a))
                     }

extraValuesError :: Text -> [Value] -> TypeRep -> ConversionError
extraValuesError funcName vals typ
    = defaultConversionError {
        conversionErrorLoc  = funcName,
        conversionErrorWhy  = ExtraValues,
        conversionErrorVal  = Just (List vals),
        conversionErrorType = Just typ
      }

typeError :: Text -> Value -> TypeRep -> ConversionError
typeError funcName val typ
    = defaultConversionError {
        conversionErrorLoc  = funcName,
        conversionErrorWhy  = TypeError,
        conversionErrorVal  = Just val,
        conversionErrorType = Just typ
      }

boundedIntegerValue :: forall a. (Typeable a, Integral a, Bounded a)
                    => ValueParser a
boundedIntegerValue =
    ValueParser $ \v ->
        case v of
          (Number r) ->
              case toBoundedInteger r of
                ja@(Just _) -> (ja     , mempty)
                Nothing     -> (Nothing, overflowErr r)
          _ -> (Nothing, typeErr v)
  where
    fn = "boundedIntegerValue"
    overflowErr v = singleError (overflowError fn v (typeOf (undefined :: a)))
    typeErr     v = singleError (typeError     fn v (typeOf (undefined :: a)))

overflowError :: Text -> Scientific -> TypeRep -> ConversionError
overflowError fn val typ = valueError fn (Number val) typ "overflow"

valueError :: Text -> Value -> TypeRep -> Text -> ConversionError
valueError funcName val typ msg
    = defaultConversionError {
        conversionErrorLoc  = funcName,
        conversionErrorWhy  = ValueError,
        conversionErrorVal  = Just val,
        conversionErrorType = Just typ,
        conversionErrorMsg  = Just msg
      }

integralValue :: forall a. (Typeable a, Integral a) => ValueParser a
integralValue =
    ValueParser $ \v ->
        case v of
          Number r ->
              if base10Exponent r >= 0
              then toIntegral r
              else let r' = normalize r
                   in if base10Exponent r' >= 0
                      then toIntegral r'
                      else (Nothing, intErr r)
          _  -> (Nothing, typeErr v)
  where
    fn = "integralValue"
    intErr  r = singleError (notAnIntegerError fn r (typeOf (undefined :: a)))
    typeErr v = singleError (typeError         fn v (typeOf (undefined :: a)))

    toIntegral r =
        case floatingOrInteger r of
          Right a -> (Just a, mempty)
          -- This case should be impossible:
          Left  (_::Float) -> (Nothing, intErr r)

notAnIntegerError :: Text -> Scientific -> TypeRep -> ConversionError
notAnIntegerError fn val typ = valueError fn (Number val) typ "not an integer"

fractionalValue :: forall a. (Typeable a, Fractional a) => ValueParser a
fractionalValue =
    ValueParser $ \v ->
        case v of
          Number r ->
              let !c   = coefficient    r
                  !e   = base10Exponent r
                  !r'  = fromRational $! if e >= 0
                                         then (c * 10^e) % 1
                                         else c % (10^(- e))
               in (Just r', mempty)
          _ -> (Nothing, typeErr v)
  where
    fn = "fractionalValue"
    typeErr v = singleError (typeError fn v (typeOf (undefined :: a)))

realFloatValue :: forall a. (Typeable a, RealFloat a) => ValueParser a
realFloatValue = realFloatValue_ (typeOf (undefined :: a))

realFloatValue_ :: (RealFloat a) => TypeRep -> ValueParser a
realFloatValue_ typ =
    ValueParser $ \v ->
        case v of
          Number (toRealFloat -> !r) -> (Just r, mempty)
          _ -> (Nothing, typeErr v)
  where
    fn = "realFloatValue"
    typeErr v = singleError (typeError fn v typ)

fixedValue :: forall a. (Typeable a, HasResolution a) => ValueParser (Fixed a)
fixedValue = fractionalValue
  -- FIXME: optimize fixedValue and/or Data.Fixed

class FromMaybeValue a where
    fromMaybeValue :: MaybeParser a
    default fromMaybeValue :: (Typeable a, FromValue a) => MaybeParser a
    fromMaybeValue = requiredValue fromValue

class FromValue a where
    fromValue :: ValueParser a

class FromListValue a where
    fromListValue :: ListParser a

instance FromValue a => FromMaybeValue (Maybe a) where
    fromMaybeValue = optionalValue fromValue

instance FromMaybeValue Bool
instance FromValue Bool where
   fromValue = boolValue

boolValue :: ValueParser Bool
boolValue =
    ValueParser $ \v ->
        case v of
          Bool b -> (Just b, mempty)
          _ -> (Nothing, typeErr v (typeOf True))
  where
    fn = "boolValue"
    typeErr v t = singleError (typeError fn v t)

instance FromMaybeValue Value where
    fromMaybeValue = MaybeParser $ \mv -> (mv, mempty)
instance FromValue Value where
    fromValue = ValueParser $ \v -> (Just v, mempty)

instance FromMaybeValue Int
instance FromValue Int where
    fromValue = boundedIntegerValue

instance FromMaybeValue Integer
instance FromValue Integer where
    fromValue = integralValue

instance FromMaybeValue Int8
instance FromValue Int8 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Int16
instance FromValue Int16 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Int32
instance FromValue Int32 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Int64
instance FromValue Int64 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Word
instance FromValue Word where
    fromValue = boundedIntegerValue

instance FromMaybeValue Word8
instance FromValue Word8 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Word16
instance FromValue Word16 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Word32
instance FromValue Word32 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Word64
instance FromValue Word64 where
    fromValue = boundedIntegerValue

instance FromMaybeValue Double
instance FromValue Double where
    fromValue = realFloatValue

instance FromMaybeValue Float
instance FromValue Float where
    fromValue = realFloatValue

instance FromMaybeValue CDouble
instance FromValue CDouble where
    fromValue = realFloatValue

instance FromMaybeValue CFloat
instance FromValue CFloat where
    fromValue = realFloatValue

instance (Typeable a, Integral a) => FromMaybeValue (Ratio a)
instance (Typeable a, Integral a) => FromValue (Ratio a) where
    fromValue = fractionalValue

instance FromMaybeValue Scientific
instance FromValue Scientific where
    fromValue = scientificValue

scientificValue :: ValueParser Scientific
scientificValue =
    ValueParser $ \v ->
        case v of
          Number r -> (Just r, mempty)
          _ -> (Nothing, typeErr v)
  where
    fn = "scientificValue"
    typeErr v = singleError (typeError fn v (typeOf (undefined :: Scientific)))

instance (Typeable a, RealFloat a) => FromMaybeValue (Complex a)
instance (Typeable a, RealFloat a) => FromValue (Complex a) where
    fromValue = (:+ 0) <$> realFloatValue_ (typeOf (undefined :: Complex a))

instance (Typeable a, HasResolution a) => FromMaybeValue (Fixed a)
instance (Typeable a, HasResolution a) => FromValue (Fixed a) where
    fromValue = fixedValue

instance FromMaybeValue Text
instance FromValue Text where
    fromValue = textValue

textValue :: ValueParser Text
textValue = textValue_ (typeOf (undefined :: Text))

textValue_ :: TypeRep -> ValueParser Text
textValue_ typ =
    ValueParser $ \v ->
        case v of
          String r -> (Just r, mempty)
          _ -> (Nothing, typeErr v typ)
  where
    fn = "textValue"
    typeErr v t = singleError (typeError fn v t)

instance FromMaybeValue Char
instance FromValue Char where
    fromValue = charValue

charValue :: ValueParser Char
charValue =
    ValueParser $ \v ->
        case v of
          String txt ->
              case T.uncons txt of
                Nothing           -> (Nothing, charErr txt)
                Just (c,txt')
                    | T.null txt' -> (Just  c, mempty)
                    | otherwise   -> (Nothing, charErr txt)
          _ -> (Nothing, typeErr v)
  where
    fn  = "charValue"
    typ = typeOf (undefined :: Char)
    msg = "expecting exactly one character"
    charErr v = singleError (valueError fn (String v) typ msg)
    typeErr v = singleError (typeError fn v typ)

instance FromMaybeValue L.Text
instance FromValue L.Text where
    fromValue = L.fromStrict <$> textValue_ (typeOf (undefined :: L.Text))

instance FromMaybeValue B.ByteString
instance FromValue B.ByteString where
    fromValue = encodeUtf8 <$> textValue_ (typeOf (undefined :: B.ByteString))

instance FromMaybeValue LB.ByteString
instance FromValue LB.ByteString where
    fromValue = convert <$> textValue_ (typeOf (undefined :: LB.ByteString))
      where convert = LB.fromStrict . encodeUtf8

-- AJ
-- instance FromMaybeValue String
-- instance FromValue String where
--     fromValue = T.unpack <$> textValue_ (typeOf (undefined :: String))

instance ( Typeable a, FromValue a
         , Typeable b, FromValue b ) => FromMaybeValue (a,b)
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b ) => FromValue (a,b) where
    fromValue = listValue fromListValue
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b ) => FromListValue (a,b) where
    fromListValue = (,) <$> listElem fromValue <*> listElem fromValue

instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c ) => FromMaybeValue (a,b,c)
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c ) => FromValue (a,b,c) where
    fromValue = listValue fromListValue
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c ) => FromListValue (a,b,c) where
    fromListValue = (,,) <$> listElem fromValue <*> listElem fromValue
                         <*> listElem fromValue

instance (Typeable a, FromValue a) => FromMaybeValue [a]
instance (Typeable a, FromValue a) => FromValue [a] where
    fromValue = listValue (many (listElem fromValue))

instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c
         , Typeable d, FromValue d ) => FromMaybeValue (a,b,c,d)
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c
         , Typeable d, FromValue d ) => FromValue (a,b,c,d) where
    fromValue = listValue fromListValue
instance ( Typeable a, FromValue a
         , Typeable b, FromValue b
         , Typeable c, FromValue c
         , Typeable d, FromValue d ) => FromListValue (a,b,c,d) where
    fromListValue = (,,,) <$> listElem fromValue <*> listElem fromValue
                          <*> listElem fromValue <*> listElem fromValue

{--
parserFail :: forall a. Typeable a => T.Text -> Maybe T.Text -> ValueParser a
parserFail loc msg = ValueParser $ \st -> (Nothing, failError, st)
       where
         failError = singleError defaultConversionError {
                       conversionErrorLoc  = loc
                       conversionErrorWhy  = MonadFail,
                       conversionErrorType = Just (typeRep (undefined :: a)),
                       conversionErrorMsg  = msg
                     }
--}

{--
defaultValue :: Typeable a => a -> ValueParser a -> ValueParser a
defaultValue def m =
    ValueParser $ \vs ->
        case vs of
          (Nothing:vs') -> (Just def, mempty, vs')
          _
--}

max_stars_repo_name: ajnsit/postgrest

max_issues_repo_name: ajnsit/postgrest

max_forks_repo_name: ajnsit/postgrest


text:
module Main where

import Lib
import Numeric.LinearAlgebra.HMatrix

import Graphics.Rendering.OpenGL as GL
import Graphics.UI.GLFW as GLFW
import Control.Monad (forever)
import System.Exit (exitSuccess)

keyPressed :: GLFW.KeyCallback
keyPressed win GLFW.Key'Escape _ GLFW.KeyState'Pressed _ = shutdown win
keyPressed _   _               _ _                     _ = return ()

shutdown :: GLFW.WindowCloseCallback
shutdown win =
  do
    GLFW.destroyWindow win
    GLFW.terminate
    _ <- exitSuccess
    return ()

resizeWindow :: GLFW.WindowSizeCallback
resizeWindow _ w h =
  do
    GL.viewport   $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
    GL.matrixMode $= GL.Projection
    GL.loadIdentity
    GL.ortho2D 0 (realToFrac w) (realToFrac h) 0

openWindow :: String -> (Int, Int) -> IO GLFW.Window
openWindow title (sizex,sizey) =
  do
    GLFW.init
    GLFW.defaultWindowHints
    GLFW.windowHint (GLFW.WindowHint'ContextVersionMajor 4)
    GLFW.windowHint (GLFW.WindowHint'ContextVersionMinor 5)
    GLFW.windowHint (GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core)
    GLFW.windowHint (GLFW.WindowHint'Resizable False)
    Just win <- GLFW.createWindow sizex sizey title Nothing Nothing
    GLFW.makeContextCurrent (Just win)
    GLFW.setWindowSizeCallback win (Just resizeWindow)
    GLFW.setKeyCallback win (Just keyPressed)
    GLFW.setWindowCloseCallback win (Just shutdown)
    return win

closeWindow :: GLFW.Window -> IO ()
closeWindow win =
  do
    GLFW.destroyWindow win
    GLFW.terminate

display :: IO ()
display =
  do
    inWindow <- openWindow "Hello Window!" (512,512)
    onDisplay inWindow
    closeWindow inWindow

onDisplay :: GLFW.Window -> IO ()
onDisplay win =
  do
    GL.clearColor $= Color4 1 0 0 1
    GL.clear [ColorBuffer]
    GLFW.swapBuffers win

    GLFW.pollEvents
    onDisplay win

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

main :: IO ()
main =
  do
    display

ext: hs


text:
module Main where

import Numeric.LinearAlgebra
import Common
import Forward
import BackProp
import AutoEncoder
import ActivFunc
import Other

main :: IO ()
main = do
  regression
  classification

regression :: IO ()
regression = do
  ws <- genWeights [2, 4, 8, 1]
  let x = matrix 4 [0, 0, 1, 1,
                    0, 1, 0, 1]
  let y = matrix 4 [0, 1, 1, 0]
  let i = matrix 4 [0, 0, 1, 1,
                    0, 1, 0, 1] -- example
  -- let nws = last . take 500 $ iterate (backPropRegression sigmoids (x, y)) ws
  nws <- last . take 500 $ iterateM (sgdMethod 2 (x, y) $ backPropRegression 0.1 sigmoids) ws
  let pws = preTrains 0.1 500 sigmoids x ws
  npws <- last . take 500 $ iterateM (sgdMethod 2 (x, y) $ backPropRegression 0.1 sigmoids) pws
  putStrLn "training inputs"
  print x
  putStrLn "training outputs"
  print y
  putStrLn "inputs"
  print i
  putStrLn "not trained outputs"
  print $ forwardRegression sigmoidC ws i
  putStrLn "trainined outputs"
  print $ forwardRegression sigmoidC nws i
  putStrLn "pretrainined outputs"
  print $ forwardRegression sigmoidC npws i

classification :: IO ()
classification = do
  ws <- genWeights [2, 4, 8, 3]
  let x = matrix 4 [0, 0, 1, 1,
                    0, 1, 0, 1]
  let y = matrix 4 [1, 0, 0, 0,
                    0, 1, 1, 0,
                    0, 0, 0, 1]
  let i = matrix 4 [0, 0, 1, 1,
                    0, 1, 0, 1] -- example
  -- let nws = last . take 500 $ iterate (backPropClassification sigmoids (x, y)) ws
  nws <- last . take 500 $ iterateM (sgdMethod 2 (x, y) $ backPropClassification 0.1 sigmoids) ws
  let pws = preTrains 0.1 500 sigmoids x ws
  npws <- last . take 500 $ iterateM (sgdMethod 2 (x, y) $ backPropClassification 0.1 sigmoids) pws
  putStrLn "training inputs"
  print x
  putStrLn "training outputs"
  print y
  putStrLn "inputs"
  print i
  putStrLn "not trained outputs"
  print $ forwardClassification sigmoidC ws i
  putStrLn "trainined outputs"
  print $ forwardClassification sigmoidC nws i
  putStrLn "pretrainined outputs"
  print $ forwardClassification sigmoidC npws i

max_stars_repo_name: pupuu/deep-neuralnet

max_issues_repo_name: pupuu/deep-neuralnet

max_forks_repo_name: pupuu/deep-neuralnet


text:
{-# LANGUAGE OverloadedStrings #-}
module Analysis.FFT (auralDistance, peakList) where

-- need to create frequency frames for peaks after the FFT has been applied
import Data.Complex
import Data.List
import Data.List.Split
import Data.Ord
import Data.Audio
import Numeric.Extra
import Data.Int
import Data.Array.IArray
import Numeric.Transform.Fourier.FFT

import Control.Parallel.Strategies

import Analysis.FFT_Py

import Types.Common
import qualified Settings as S
import Utils

import Shelly (shelly, silently, run)
import Data.String

auralDistance :: (FilePath, AudioFormat) -> (FilePath, AudioFormat) -> IO Double
auralDistance a1 a2 = do
  ps1 <- peakList a1
  ps2 <- peakList a2
  -- since I am not looking at time shifting filter for now, I can zipWith over time to remove the time domain
  -- NB this means the times need to line up 'exactly', ie this will not work well for real-world examples
  --    but only for contrsucted examples where I apply the filter to the sample myself (eg in audacity)
  --mapM_ plot $ take 5 $ zip (map sort ps1) (map sort ps2)
  let
    distances = zipWith (comparePeaks) (map sort ps1) (map sort ps2)
    average ls = sum ls / genericLength ls
  return $ average distances

plot :: ([Peak], [Peak]) -> IO()
plot (ps1, ps2) = do
  writeFile "tmp1.csv" (listToCSV ps1)
  writeFile "tmp2.csv" (listToCSV ps2)
  results <- shelly $ silently $ run (fromString "gnuplot")
               [ "-p"
               , "plotter.gnuplot" ]
  return ()

comparePeaks ps1 ps2 =
  sum $ zipWith comparePeak ps1 ps2

-- TODO rethink how i do distances...
-- | for a single time slice, do euclid distance treating (freq,amp) as (x,y)
--   should always have the same number of points, but they might not lineup exactly...
--   eg (3,0.1),(4,0.5),(5,0.5) vs (4,0.5),(5,0.5),(6,0.1) should be rated as fairly close
comparePeak :: Peak -> Peak -> Double
comparePeak peak1 peak2 = let
  freq1 = intToDouble $ getFreq peak1
  freq2 = intToDouble $ getFreq peak2
  amp1 = getAmp peak1
  amp2 = getAmp peak2
 in
    {-if amp2 == 0
    then 1000 --penalize zero files
    else -}
    --traceShow ((show freq1)++" "++(show amp1)++", "++(show freq2)++" "++(show amp2) )
    (euclidDistance (freq1,amp1) (freq2,amp2)) / 1000-- + 1/(amp2+0.00001)

-- | break an audio file into time slices and i
--   find the freq peaks that are most predominate for each time slice
peakList :: (FilePath, AudioFormat) -> IO (OverTime (OverFreq Peak))
peakList (fp,a) = do
  peaks <- peakListPython fp
  let normPeaks = normalize peaks
  return $ getMainPeaks normPeaks

-- | Scale so max over all time slices is 1
--   note that this means some time slices will not have a max of 1
--   another option is to normlize so that the integral of the fft is 1
normalize :: [[Peak]] -> [[Peak]]
normalize ps = let
  maxPeak = maximum $ concatMap (map getAmp) ps
  scaleFactor = 1 / maxPeak
 in
  map (map (\(frq,amp) -> (frq, amp* scaleFactor))) ps

{-
--takes wave file and turns it's values into list of Complex Doubles
wavList :: AudioFormat -> OverTime Double
wavList wav = let
    l1 = sampleData wav
  --takes at most a certain time frame
  in take (16384*10) $ elems $ amap (toSample) l1

-- mkFrames takes assocs of audio file and breaks it into 4096 sample (.09s) frames (overlapped by 50%)
mkFrames :: OverTime Double -> OverTime (OverTime Double)
mkFrames list1 =
  if (length list1) < S.frameRes --Settings.framerate
    then []
    else (take S.frameRes list1):(mkFrames (drop S.overlap list1))

-- | performs FFT on a list of samples, and conversts each sample to a list of peaks as the triple (freq,amp,phase)
--   returns a list (in the time domain) of peaks (freq domain)
constellateAll :: OverTime (OverTime Double) -> OverTime (OverFreq Peak)
constellateAll timeSlices = let
    -- what the heck does this do?
    sparsifying n= foldr (.) id (replicate n (remove_every_nth 2))
    ars1 = --sparsifying S.resolution $
               --why not length sample here?
               map (\samples -> listArray (0,(S.frameRes - 1)) samples) timeSlices
    in map ((take (S.frameRes `div` 2)).assocs.constellate.rfft) ars1

-- constellate takes results of FFT and turns it into (amp,phase) at each frequency point
constellate :: Array Int (Complex Double) -> Array Int (Double,Double)
constellate arr1 =
  let list1 = assocs arr1
      polar1 = map (polar.snd) list1 --TODO use amap for array
      in listArray (0,((length list1) - 1)) polar1
-}

-- | with the full set of peaks for a list of frames,
--   we want to essentially apply a filter to each time slice
--   so that we only have the main peaks for that time slice
getMainPeaks :: OverTime (OverFreq Peak) -> OverTime (OverFreq Peak)
getMainPeaks ts =
  map (findBiggestPeaks. freqBins) ts

-- | partition a sample slice's peaks by freq into bins
--   this allows for a bit of flexibilty in freq analysis
--   ie dont need the exact same freqs to be the same
--   sameness of frequency is determined by bin size
--   NB the OverFreq interprtation seems to break down here
freqBins :: OverFreq Peak -> [[Peak]]
freqBins = chunksOf S.binSize

-- | for a given sample slices' peaks in each freq bin,
--   get the biggest (by amp) in each bin
--   then take the biggest numPeaks of those
findBiggestPeaks :: [[Peak]] -> [Peak]
findBiggestPeaks ts = let
   -- first sort each bin, and only take the largest
   -- this eliminates the 'noisy' freqs nearby the peaks
   largestPeaksPerBin = map (last.(sortBy (comparing getAmp))) ts
   -- then we want to get the biggest peaks our of all the loudest bins (or 'freq areas')
   -- so we first sort by loudest 'freq areas'
   largestBinPerSampleSlice = reverse $ sortBy (comparing getAmp) largestPeaksPerBin
  in
   -- to find the S.numPeaks biggest peaks
   take S.numPeaks $ largestBinPerSampleSlice

-- listTriple turns tuple of int and tuple and makes it into a triple
listTriple :: [(a,(b,b))] -> [(a,b,b)]
listTriple xs =
   map (\(x,(y,z)) -> (x,y,z)) xs

max_stars_repo_name: Yale-OMI/DSP-PBE

max_issues_repo_name: Yale-OMI/DSP-PBE

max_forks_repo_name: Yale-OMI/DSP-PBE


text:
{-# LANGUAGE ApplicativeDo              #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuantifiedConstraints      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Main where
import           Control.Monad
import           Control.Monad.State
import           Data.Foldable
import           Data.List                   hiding (filter)
import           Data.RVar
import           Data.Random
import qualified Data.Text                   as T
import           Data.Time
import           Graphics.Vega.VegaLite      hiding (repeat, sample)
import qualified Numeric.LinearAlgebra       as V
import           Prelude                     hiding (filter)
import           Q.ContingentClaim.Options
import           Q.MonteCarlo
import           Q.Options.BlackScholes
import           Q.Stats.TimeSeries
import           Q.Stochastic.Discretize
import           Q.Stochastic.Process
import           Q.Time
import           Q.Time.DayCounter
import           Q.Types
import qualified Q.Util.File                 as QF
import           Statistics.Sample.Histogram

import qualified Data.Time                   as Time

dt :: Double
dt = 1/365
gbm = GeometricBrownian 0.0 0.15

plotPayouts :: IO ()
plotPayouts = do
  let strike      = 100.0
      lowStrike   = 95.0
      highStrike  = 105.0
      expiry      = fromGregorian 2015 3 31
      spots       = [90, 90.01..110]
      calls       = map (vanillaPayout Call strike) spots
      puts        = map (vanillaPayout Put strike) spots
      callSpreads = map (spreadPayout Call lowStrike highStrike) spots
      putSpreads  = map (spreadPayout Put lowStrike highStrike) spots
      straddles   = map (straddlePayout strike) spots

      payouts = dataFromColumns []
        . dataColumn "Spot" (Numbers spots)
        . dataColumn "Call" (Numbers calls)
        . dataColumn "Put"  (Numbers puts)
        . dataColumn "Call Spread"  (Numbers callSpreads)
        . dataColumn "Put Spread"  (Numbers putSpreads)
        . dataColumn "Straddle" (Numbers straddles)

      enc = encoding
        . position X [PName "Spot", PmType Quantitative]
      encVanillaCall = enc
        . position Y [PName "Call", PmType Quantitative]
      encVanillaPut  = enc
        . position Y [PName "Put", PmType Quantitative]
      encCallSpread = enc
        . position Y [PName "Call Spread", PmType Quantitative]
      encPutSpread = enc
        . position Y [PName "Put Spread", PmType Quantitative]
      encStraddle = enc
        . position Y [PName "Straddle", PmType Quantitative]

      vl = toVegaLite [payouts [], vlConcat [ asSpec [encVanillaCall [], mark Line []]
                                            , asSpec [encVanillaPut  [], mark Line []]
                                            , asSpec [encCallSpread  [], mark Line []]
                                            , asSpec [encPutSpread   [], mark Line []]
                                            , asSpec [encStraddle    [], mark Line []]
                                            ]
                      ]
  toHtmlFile "/tmp/payouts.html" vl

-- Option delta is the sensitivity of the option to the underlying:
-- \(dV/dS\).
--
-- for a fixed time and vol what is the delta per relative strike.
-- How does delta look as a function of time
-- How does delta look as a function of vol?

-- How does delta look like as a function of the spot?
-- Plot call delta against log relative strike.
-- Plot put  delta against log relative strike.
studyDelta :: IO ()
studyDelta = do
  let today           = fromGregorian 2015 3 31
      expiry          = YearFrac 1
      vol             = 0.6
      spot            =  100
      strikes         = map Strike [80, 81..120]
      vols            = [0.01,0.06..1]
      expiries        = map YearFrac [0.1,0.2..2]
      relativeStrikes = [log (k/(atmf bs expiry)) | k <- strikes]
      r               = 0.01
      bs              = BlackScholes spot r vol
      delta cp k      = vDelta (euOption bs expiry cp k)
      pv    cp k      = vPremium (euOption bs expiry cp k)
      row (vol,k,t)     = [show today,
                         show t,
                         show $log (k / atmf bs t),
                         show r,
                         show vol,
                         show $ pv Call k,
                         show $ pv Put k,
                         show $ delta Call k,
                         show $ delta Put k
                        ]
      header           = ["VD","Expiry","RelativeStrike", "IR", "Vol", "cPV", "pPV", "cDelta", "pDelta"]

  QF.write (map row [(vol, k, t) | vol <- vols, k <- strikes, t <- expiries]) header "/tmp/data/delta.csv"

  let mydata = dataFromUrl "delta.csv" [Parse [ ( "Expiry", FoDate "%Y-%m-%d" ), ( "VD", FoDate "%Y-%m-%d" ) ]]

  -- !This is \(dV/dS\) for different strikes, same expiry, interest rate,
  let l1 = toVegaLite [mydata , layers, width 800, height 600, res, trans] where
      calls = encoding
        . position X [PName "RelativeStrike"    , PmType Quantitative]
        . position Y [PName "cDelta" , PmType Quantitative, PTitle "Calls", PAxis [AxTitleColor "green"]]
      puts  = encoding
        . position X [PName "RelativeStrike"    , PmType Quantitative]
        . position Y [PName "pDelta"  , PmType Quantitative, PTitle "Puts", PAxis [AxTitleColor "red"]]
      layers = layer [ asSpec [calls [], mark Line [MColor "green"]]
                     , asSpec [puts  [], mark Line [MColor "red"]]
                     ]
      trans = transform . filter (FExpr "datum.Expiry == datetime(2015,3,15)") $ []
      res = resolve . resolution (RScale [(ChY, Independent)]) $ []

  toHtmlFile "/tmp/data/deltas.html" l1

-- | Plot call option premiums, deltas, payoffs across a differnt
-- range of strikes.
plotCallOptions :: IO ()
plotCallOptions = do
  let today   = fromGregorian 2015 3 31
      expiry  = YearFrac 1.0
      spot    = 100
      r       = 0
      vol     = 0.01
      bs      = BlackScholes spot r vol
      k       = atmf bs expiry
      cp      = Call
  let strikes = [95, 95.01..105]
      values  = [] -- map (vPremium . euOption cp bs expiry) strikes
      deltas  = [] --map (vDelta   . euOption cp bs expiry) strikes
      pvs = dataFromColumns []
        . dataColumn "Strikes" (Numbers strikes)
        . dataColumn "Premiums"     (Numbers values)
        . dataColumn "Deltas"  (Numbers deltas)
  let encPvs = encoding
        . position X [PName "Strikes", PmType Quantitative]
        . position Y [PName "Premiums"    , PmType Quantitative]
      encDeltas = encoding
        . position X [PName "Strikes", PmType Quantitative]
        . position Y [PName "Deltas", PmType Quantitative]
      layers = layer [ asSpec [ encPvs     [], mark Line [MColor "blue"]]
                     , asSpec [ encDeltas  [], mark Line [MColor "red"]]
                     ]
      res = resolve . resolution (RScale [(ChY, Independent)])
      vl     = toVegaLite [pvs [], layers, width 800, res [], height 400]
  toHtmlFile "/tmp/callOptions.html" vl

testPlot = do
  let dvals = dataSequenceAs 0 6.28 0.1 "x"
      trans = transform
              . calculateAs "sin(datum.x)" "sinX"
              . calculateAs "cos(datum.x)" "cosX"
      enc = encoding
            . position X [PName "x", PmType Quantitative]
      encCos = enc . position Y [PName "cosX", PmType Quantitative]
      encSin = enc . position Y [PName "sinX", PmType Quantitative]

      vl = toVegaLite [ dvals
                      , trans []
                      , vlConcat [ asSpec [encCos [], mark Line []]
                                 , asSpec [encSin [], mark Line []]
                                 ]
                      ]
  toHtmlFile "/tmp/test.html" vl

plotTrajectories :: IO ()
plotTrajectories = do
  let dt = 1/365
      today = fromGregorian 2015 3 31
      dates = [d | d <- fmap (flip addDays today) [0, 365]]
      dts = tail $ map (\d -> dcYearFraction ThirtyUSA today d) dates
      n = 64000
      ids = mconcat $ fmap (replicate $ length dates) [T.pack $ show id | id <- [1..n]]
  trajectories <- sample $ trajectories n (Euler dt) gbm  (100::Double) dts (repeat stdNormal)
  let trajectories' = dataFromColumns [ Parse [ ( "Date", FoDate "%Y%m%d" ) ] ]
                      . dataColumn "Date" (Strings  (mconcat (replicate n (map dayToString dates))))
                      . dataColumn "St" (Numbers $ mconcat trajectories)
                      . dataColumn "ID" (Strings ids)
      calls = mark Line
      enc = encoding
            . position X [ PName "Date", PmType Temporal]
            . position Y [ PName "St", PmType Quantitative, PScale [SDomain (DNumbers [50, 150])] ]
            . color [ MName "ID", MmType Nominal, MLegend []]
      vl = toVegaLite [trajectories' [], enc [], mark Line [], width 1000, height 600]
  toHtmlFile "/tmp/a.html" vl

main  = undefined

max_stars_repo_name: ghais/lowq

max_issues_repo_name: ghais/lowq

max_forks_repo_name: ghais/lowq


text:
{-# LANGUAGE DataKinds                     #-}
{-# LANGUAGE FlexibleContexts              #-}
{-# LANGUAGE RankNTypes                    #-}
{-# LANGUAGE ScopedTypeVariables           #-}
{-# LANGUAGE TypeApplications              #-}
{-# LANGUAGE TypeOperators                 #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Backprop.Learn.Loss (
  -- * Loss functions
    Loss
  , crossEntropy, crossEntropy1
  , squaredError, absError, totalSquaredError, squaredErrorV
  -- , totalCov
  -- ** Manipulate loss functions
  , scaleLoss
  , sumLoss
  , sumLossDecay
  , lastLoss
  , zipLoss
  , t2Loss
  -- * Regularization
  , Regularizer
  , l2Reg
  , l1Reg
  , noReg
  -- ** Manipulate regularizers
  , addReg
  , scaleReg
  ) where

import           Backprop.Learn.Regularize
import           Control.Applicative
import           Data.Coerce
import           Data.Finite
import           Data.Type.Tuple
import           GHC.TypeNats
import           Lens.Micro
import           Numeric.Backprop
import           Numeric.LinearAlgebra.Static.Backprop
import qualified Data.Vector.Sized                     as SV
import qualified Prelude.Backprop                      as B

type Loss a = forall s. Reifies s W => a -> BVar s a -> BVar s Double

crossEntropy :: KnownNat n => Loss (R n)
crossEntropy targ res = -(log res <.> auto targ)

crossEntropy1 :: Loss Double
crossEntropy1 targ res = -(log res * auto targ + log (1 - res) * auto (1 - targ))

squaredErrorV :: KnownNat n => Loss (R n)
squaredErrorV targ res = e <.> e
  where
    e = res - auto targ

totalSquaredError
  :: (Backprop (t Double), Num (t Double), Foldable t, Functor t)
    => Loss (t Double)
totalSquaredError targ res = B.sum (e * e)
  where
    e = auto targ - res

squaredError :: Loss Double
squaredError targ res = (res - auto targ) ** 2

absError :: Loss Double
absError targ res = abs (res - auto targ)

-- -- | Sum of covariances between matching components.  Not sure if anyone
-- -- uses this.
-- totalCov :: (Backprop (t Double), Foldable t, Functor t) => Loss (t Double)
-- totalCov targ res = -(xy / fromIntegral n - (x * y) / fromIntegral (n * n))
--   where
--     x = auto $ sum targ
--     y = B.sum res
--     xy = B.sum (auto targ * res)
--     n = length targ

-- klDivergence :: Loss Double
-- klDivergence =

sumLoss
    :: (Traversable t, Applicative t, Backprop a)
    => Loss a
    -> Loss (t a)
sumLoss l targ = sum . liftA2 l targ . sequenceVar

zipLoss
    :: (Traversable t, Applicative t, Backprop a)
    => t Double
    -> Loss a
    -> Loss (t a)
zipLoss xs l targ = sum
                  . liftA3 (\α t -> (* auto α) . l t) xs targ
                  . sequenceVar

sumLossDecay
    :: forall n a. (KnownNat n, Backprop a)
    => Double
    -> Loss a
    -> Loss (SV.Vector n a)
sumLossDecay β = zipLoss $ SV.generate (\i -> β ** (fromIntegral i - n))
  where
    n = fromIntegral $ maxBound @(Finite n)

lastLoss
    :: forall n a. (KnownNat (n + 1), Backprop a)
    => Loss a
    -> Loss (SV.Vector (n + 1) a)
lastLoss l targ = l (SV.last targ)
                . viewVar (coerced . SV.ix @(n + 1) maxBound)
                . B.coerce @_ @(ABP (SV.Vector (n + 1)) a)

coerced :: Coercible a b => Lens' a b
coerced f x = coerce <$> f (coerce x)
{-# INLINE coerced #-}

-- | Scale the result of a loss function.
scaleLoss :: Double -> Loss a -> Loss a
scaleLoss β l x = (* auto β) . l x

-- | Lift and sum a loss function over the components of a ':&'.
t2Loss
    :: (Backprop a, Backprop b)
    => Loss a                   -- ^ loss on first component
    -> Loss b                   -- ^ loss on second component
    -> Loss (a :# b)
t2Loss f g (xT :# yT) (xR :## yR) = f xT xR + g yT yR

max_stars_repo_name: mstksg/backprop-learn

max_issues_repo_name: mstksg/backprop-learn

max_forks_repo_name: mstksg/backprop-learn


text:
{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Statistics.Distribution.Beta
-- Copyright   :  (C) 2012 Edward Kmett,
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  DeriveDataTypeable
--
----------------------------------------------------------------------------
module Statistics.Distribution.Beta
  ( BetaDistribution(..)
  , betaDistr
  ) where

import Numeric.SpecFunctions
import Numeric.MathFunctions.Constants (m_NaN)
import qualified Statistics.Distribution as D
import Data.Typeable

data BetaDistribution = BD
 { bdAlpha :: {-# UNPACK #-} !Double
 , bdBeta  :: {-# UNPACK #-} !Double
 } deriving (Eq,Read,Show,Typeable)

betaDistr :: Double -> Double -> BetaDistribution
betaDistr a b
  | a < 0 = error $ msg ++ "alpha must be positive. Got " ++ show a
  | b < 0 = error $ msg ++ "beta must be positive. Got " ++ show b
  | otherwise = BD a b
  where msg = "Statistics.Distribution.Beta.betaDistr: "
{-# INLINE betaDistr #-}

instance D.Distribution BetaDistribution where
  cumulative (BD a b) x
    | x <= 0 = 0
    | otherwise = incompleteBeta a b x
  {-# INLINE cumulative #-}

instance D.Mean BetaDistribution where
  mean (BD a b) = a / (a + b)
  {-# INLINE mean #-}

instance D.MaybeMean BetaDistribution where
  maybeMean = Just . D.mean
  {-# INLINE maybeMean #-}

instance D.Variance BetaDistribution where
  variance (BD a b) = a*b / (apb*apb*(apb+1))
    where apb = a + b
  {-# INLINE variance #-}

-- invert a monotone function
invertMono :: (Double -> Double) -> Double -> Double -> Double -> Double
invertMono f l0 h0 b = go l0 h0 where
  go l h
    | h - l < epsilon = m
    | otherwise = case compare (f m) b of
      LT -> go m h
      EQ -> m
      GT -> go l m
    where m = l + (h-l)/2
          epsilon = 1e-12
{-# INLINE invertMono #-}

instance D.ContDistr BetaDistribution where
  density (BD a b) x
   | a <= 0 || b <= 0 = m_NaN
   | x <= 0 = 0
   | x >= 1 = 0
   | otherwise = exp $ (a-1)*log x + (b-1)*log (1-x) - logBeta a b
  {-# INLINE density #-}

  quantile d p
    | p < 0 = error $ "probability must be positive. Got " ++ show p
    | p > 1 = error $ "probability must be less than 1. Got " ++ show p
    | otherwise = invertMono (D.cumulative d) 0 1 p
  {-# INLINE quantile #-}

instance D.MaybeVariance BetaDistribution where
  maybeVariance = Just . D.variance
  {-# INLINE maybeVariance #-}

-- TODO: D.ContGen for rbeta

max_stars_repo_name: ekmett/order-statistics

max_issues_repo_name: ekmett/order-statistics

max_forks_repo_name: ekmett/order-statistics


text:
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE Strict                #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-|
Module      : Grenade.Layers.Tanh
Description : Hyperbolic tangent nonlinear layer
Copyright   : (c) Huw Campbell, 2016-2017
License     : BSD2
Stability   : experimental
-}
module Grenade.Layers.Tanh
  ( Tanh(..)
  , SpecTanh (..)
  , specTanh1D
  , specTanh2D
  , specTanh3D
  , specTanh
  , tanhLayer
  ) where

import           Control.DeepSeq                (NFData (..))
import           Data.Constraint                (Dict (..))
import           Data.Reflection                (reifyNat)
import           Data.Serialize
import           Data.Singletons
import           GHC.Generics                   (Generic)
import           GHC.TypeLits
import qualified Numeric.LinearAlgebra.Static   as LAS
import           Unsafe.Coerce                  (unsafeCoerce)

import           Grenade.Core
import           Grenade.Dynamic
import           Grenade.Dynamic.Internal.Build
import           Grenade.Utils.Conversion
import           Grenade.Utils.Vector

-- | A Tanh layer.
--   A layer which can act between any shape of the same dimension, performing a tanh function.
data Tanh = Tanh
  deriving (Generic,NFData,Show)

instance UpdateLayer Tanh where
  type Gradient Tanh = ()
  runUpdate _ _ _ = Tanh

instance RandomLayer Tanh where
  createRandomWith _ _ = return Tanh

instance Serialize Tanh where
  put _ = return ()
  get = return Tanh

instance (a ~ b, SingI a) => Layer Tanh a b where
  type Tape Tanh a b = S a
  -- runForwards _ (S1DV v) = (S1DV v, S1DV $ mapVectorInPlace tanh v) -- This is inplace replacement!
  -- runForwards _ (S2DV v) = (S2DV v, S2DV $ mapVectorInPlace tanh v) -- This is inplace replacement!
  runForwards _ a        = (a, tanh a)
  runBackwards _ (S1DV v) (S1DV gs) = ((), S1DV $ zipWithVector (\t g -> max 0.005 (1 - (tanh t) ^ (2 :: Int)) * g) v gs)
  runBackwards _ (S2DV v) (S2DV gs) = ((), S2DV $ zipWithVector (\t g -> max 0.005 (1 - (tanh t) ^ (2 :: Int)) * g) v gs)
  runBackwards _ (S1D a) (S1D g)= ((), S1D $ LAS.dvmap (max 0.005) (tanh' a) * g)
  runBackwards _ (S2D a) (S2D g)= ((), S2D $ LAS.dmmap (max 0.005) (tanh' a) * g)
  runBackwards _ (S3D a) (S3D g)= ((), S3D $ LAS.dmmap (max 0.005) (tanh' a) * g)
  runBackwards l x y = runBackwards l x (toLayerShape x y)
  -- runBackwards _ a g = ((), tanh' a * g)

tanh' :: (Floating a) => a -> a
tanh' t = 1 - s ^ (2 :: Int)  where s = tanh t

-------------------- DynamicNetwork instance --------------------

instance FromDynamicLayer Tanh where
  fromDynamicLayer inp _ _ = SpecNetLayer $ SpecTanh (tripleFromSomeShape inp)

instance ToDynamicLayer SpecTanh where
  toDynamicLayer _ _ (SpecTanh (rows, cols, depth)) =
     reifyNat rows $ \(_ :: (KnownNat rows) => Proxy rows) ->
     reifyNat cols $ \(_ :: (KnownNat cols) => Proxy cols) ->
     reifyNat depth $ \(_ :: (KnownNat depth) => Proxy depth) ->
     case (rows, cols, depth) of
         (_, 1, 1)    -> return $ SpecLayer Tanh (sing :: Sing ('D1 rows)) (sing :: Sing ('D1 rows))
         (_, _, 1) -> return $ SpecLayer Tanh (sing :: Sing ('D2 rows cols)) (sing :: Sing ('D2 rows cols))
         _    -> case (unsafeCoerce (Dict :: Dict()) :: Dict (KnownNat (rows GHC.TypeLits.* depth))) of
           Dict -> return $ SpecLayer Tanh (sing :: Sing ('D3 rows cols depth)) (sing :: Sing ('D3 rows cols depth))

-- | Create a specification for a Tanh layer.
specTanh1D :: Integer -> SpecNet
specTanh1D i = specTanh3D (i, 1, 1)

-- | Create a specification for a Tanh layer.
specTanh2D :: (Integer, Integer) -> SpecNet
specTanh2D (i, j) = specTanh3D (i, j, 1)

-- | Create a specification for a Tanh layer.
specTanh3D :: (Integer, Integer, Integer) -> SpecNet
specTanh3D = SpecNetLayer . SpecTanh

-- | Create a specification for a Tanh layer.
specTanh :: (Integer, Integer, Integer) -> SpecNet
specTanh = SpecNetLayer . SpecTanh

-- | Add a Tanh layer to your build.
tanhLayer :: BuildM ()
tanhLayer = buildGetLastLayerOut >>= buildAddSpec . SpecNetLayer . SpecTanh

-------------------- GNum instances --------------------

instance GNum Tanh where
  _ |* Tanh = Tanh
  _ |+ Tanh = Tanh
  sumG _ = Tanh

max_stars_repo_name: schnecki/grenade

max_issues_repo_name: schnecki/grenade

max_forks_repo_name: schnecki/grenade


text:
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE BangPatterns          #-}
-- |
-- Module     : Data.Matrix.Generic.Mutable
-- Copyright  : Copyright (c) 2012 Aleksey Khudyakov <alexey.skladnoy@gmail.com>
-- License    : BSD3
-- Maintainer : Aleksey Khudyakov <alexey.skladnoy@gmail.com>
-- Stability  : experimental
--
-- Interface for generic mutable matrices. For matrix transposition
-- and conjugate transposition newtype wrappers are used.
module Data.Matrix.Generic.Mutable (
    -- * Type class
    IsMMatrix(..)
    -- * Accesors
  , rows
  , cols
  , shape
    -- * Reading and writing
  , read
  , write
  , unsafeRead
  , unsafeWrite
  , cloneShape
  , clone
    -- * Newtype wrappers
  , TransposedM(..)
  , ConjugatedM(..)
  ) where

import Control.Monad.Primitive
import Data.Complex             (Complex,conjugate)
import Prelude hiding (read)

----------------------------------------------------------------
-- Type class
----------------------------------------------------------------

-- | Type class of mutable matrices. Since there's many way to lay
--   matrix in memory there isn't many operation which work for all of
--   them.
--
--   Indexing uses following form: @(row,column)@
class IsMMatrix mat a where
  -- | Number of rows.
  basicRows :: mat s a -> Int
  -- | Number of columns.
  basicCols :: mat s a -> Int
  -- | Whether index could be mutated. E.g. not every element of
  --   banded matrix could be written to. Function need not to check
  --   that indices are inside of the matrix and free to return anything if
  --   they are outside.
  basicIsIndexMutable :: mat s a -> (Int,Int) -> Bool
  -- | Retrive element at given index. It should alway succed if row
  --   and column numbers are in range.
  basicUnsafeRead :: PrimMonad m => mat (PrimState m) a -> (Int,Int) -> m a
  -- | Write element at given index.
  basicUnsafeWrite :: PrimMonad m => mat (PrimState m) a -> (Int,Int) -> a -> m ()
  -- | Create matrix with same dimensions. Elements' values are undefined
  --
  --   Unlike vector which have only length there are many kinds of
  --   matrices. it's not possible to write such function from simpler ones.
  basicCloneShape :: PrimMonad m => mat (PrimState m) a -> m (mat (PrimState m) a)
  -- | Create copy of matrix.
  basicClone :: PrimMonad m => mat (PrimState m) a -> m (mat (PrimState m) a)

----------------------------------------------------------------
-- Accesors
----------------------------------------------------------------

-- | Number of rows.
rows :: IsMMatrix mat a => mat s a -> Int
{-# INLINE rows #-}
rows = basicRows

-- | Number of columns.
cols :: IsMMatrix mat a => mat s a -> Int
{-# INLINE cols #-}
cols = basicCols

-- | Shape of the matrix.
shape :: IsMMatrix mat a => mat s a -> (Int,Int)
{-# INLINE shape #-}
shape m = (rows m, cols m)

-- | Whether index could be mutated. E.g. not every element of banded
--   matrix could be written to. Function need not to check that
--   indices are inside of the matrix and free to return anything if
--   they are outside
isIndexMutable :: IsMMatrix mat a => mat s a -> (Int, Int) -> Bool
{-# INLINE isIndexMutable #-}
isIndexMutable = basicIsIndexMutable

----------------------------------------------------------------
-- Read/write
----------------------------------------------------------------

-- | Read matrix element at given index. It should alway succed if row
--   and column numbers are in range.
read :: (PrimMonad m, IsMMatrix mat a) => mat (PrimState m) a -> (Int,Int) -> m a
{-# INLINE read #-}
read m i@(!r,!c)
  | r < 0 || r >= rows m = error "Numeric.BLAS.Matrix.Mutable.read: row out of bounds"
  | c < 0 || r >= cols m = error "Numeric.BLAS.Matrix.Mutable.read: column out of bounds"
  | otherwise            = unsafeRead m i

-- | Write element to matrix at given index. It could be impossible to
--   change values of some elements.
write :: (PrimMonad m, IsMMatrix mat a) => mat (PrimState m) a -> (Int,Int) -> a -> m ()
{-# INLINE write #-}
write m i@(!r,!c)
  | r < 0 || r >= rows m = error "Numeric.BLAS.Matrix.Mutable.write: row out of bounds"
  | c < 0 || r >= cols m = error "Numeric.BLAS.Matrix.Mutable.write: column out of bounds"
  | isIndexMutable m i   = basicUnsafeWrite m i
  | otherwise            = error "Numeric.BLAS.Matrix.Mutable.write: index is not mutable"

-- | Read element from matrix without range checking
unsafeRead :: (PrimMonad m, IsMMatrix mat a) => mat (PrimState m) a -> (Int, Int) -> m a
{-# INLINE unsafeRead #-}
unsafeRead = basicUnsafeRead

-- | Write element to matrix without range checking.
unsafeWrite :: (PrimMonad m, IsMMatrix mat a) => mat (PrimState m) a -> (Int, Int) -> a -> m ()
{-# INLINE unsafeWrite #-}
unsafeWrite = basicUnsafeWrite

-- | Create matrix with same dimensions. Elements' values are undefined
--
--   Unlike vector which have only length there are many kinds of
--   matrices. it's not possible to write such function from simpler ones.
cloneShape :: (PrimMonad m, IsMMatrix mat a) => mat (PrimState m) a -> m (mat (PrimState m) a)
{-# INLINE cloneShape #-}
cloneShape = basicCloneShape

-- | Create copy of matrix.
clone :: (PrimMonad m, IsMMatrix mat a) => mat (PrimState m) a -> m (mat (PrimState m) a)
{-# INLINE clone #-}
clone = basicClone

----------------------------------------------------------------
-- Newtypes
----------------------------------------------------------------

-- | Transposed matrix
newtype TransposedM mat s a = TransposedM { unTranspose :: mat s a }

instance IsMMatrix mat a => IsMMatrix (TransposedM mat) a where
  basicRows (TransposedM m) = cols m
  {-# INLINE basicRows #-}
  basicCols (TransposedM m) = rows m
  {-# INLINE basicCols #-}
  basicIsIndexMutable (TransposedM m) (i,j)   = isIndexMutable m (j,i)
  {-# INLINE basicIsIndexMutable #-}
  basicUnsafeRead     (TransposedM m) (i,j)   = unsafeRead     m (j,i)
  {-# INLINE basicUnsafeRead #-}
  basicUnsafeWrite    (TransposedM m) (i,j) x = unsafeWrite    m (j,i) x
  {-# INLINE basicUnsafeWrite #-}
  basicCloneShape     (TransposedM m) = do { r <- basicCloneShape m; return $ TransposedM r }
  {-# INLINE basicCloneShape #-}
  basicClone          (TransposedM m) = do { r <- basicCloneShape m; return $ TransposedM r }
  {-# INLINE basicClone #-}

-- | Conjugate-transposed matrix
newtype ConjugatedM mat s a = ConjugatedM { unConjugate :: mat s a }

instance (IsMMatrix mat (Complex a), RealFloat a) => IsMMatrix (ConjugatedM mat) (Complex a) where
  basicRows (ConjugatedM m) = basicCols m
  {-# INLINE basicRows #-}
  basicCols (ConjugatedM m) = rows m
  {-# INLINE basicCols #-}
  basicIsIndexMutable (ConjugatedM m) (i,j)   = isIndexMutable m (j,i)
  {-# INLINE basicIsIndexMutable #-}
  basicUnsafeRead (ConjugatedM m) (i,j)
    | j >= i    = unsafeRead m (j,i)
    | otherwise = do { x <- unsafeRead m (j,i); return $! conjugate x }
  {-# INLINE basicUnsafeRead #-}
  basicUnsafeWrite (ConjugatedM m) (i,j) x
    | j >= i    = unsafeWrite m (j,i) x
    | otherwise = unsafeWrite m (j,i) $! conjugate x
  {-# INLINE basicUnsafeWrite #-}
  basicCloneShape     (ConjugatedM m) = do { r <- basicCloneShape m; return $ ConjugatedM r }
  {-# INLINE basicCloneShape #-}
  basicClone          (ConjugatedM m) = do { r <- basicCloneShape m; return $ ConjugatedM r }
  {-# INLINE basicClone #-}

max_stars_repo_name: Shimuuar/blas-lapack

max_issues_repo_name: Shimuuar/blas-lapack

max_forks_repo_name: Shimuuar/blas-lapack


text:
module Lib where

import           Constants    (pitchStandard, sampleRate, volume)
import           Data.Complex
import           Envelope
import           Types

-- Frequency decrease magic number. Frequency of note starts at 200% and quickly decreases
-- to 100% to simulate the initial hit. Increasing `kFreq` increases the rate
-- of decrease.
kFreq = 0.0015

-- https://pages.mtu.edu/~suits/NoteFreqCalcs.html
frequency :: HalfNotes -> Frequency
frequency n = pitchStandard * (2 ** (1.0 / 12.0)) ** n

-- https://dsp.stackexchange.com/questions/2051/why-does-a-wave-continuously-decreasing-in-frequency-start-increasing-its-freque
--
--
-- TODO Smoothly go between two frequencies
--
-- https://dsp.stackexchange.com/questions/971/how-to-create-a-sine-wave-generator-that-can-smoothly-transition-between-frequen?noredirect=1&lq=1
--
-- https://github.com/rmichela/Acoustico/blob/194945595e78d1e0d1a46d9ffde03fc8a7212d38/phasor.go
--
--

data TrigGenerator
  = TrigGenerator
      { _time          :: Double
      , _stabilityTime :: Double
      , phasor         :: Complex Double
      , sampleRate     :: Double
      }

wave :: Double -> Frequency -> TimeStamp -> Double
wave amp hz t = volume * sin (2 * pi * t * hz / sampleRate)

signal :: Frequency -> [Pulse]
signal hz =
  map
    (\t ->
      wave volume hz t
      * attack t
      * decay t
      * sustain t
      * release t)
     timestamps
  where
    Envelope attack decay sustain release = makeEnvelope
    timestamps = [1.0..sampleRate]

pulses :: HalfNotes -> Beats -> [Pulse]
pulses n beats = signal (frequency n)

max_stars_repo_name: lsund/dsp-haskell

max_issues_repo_name: lsund/dsp-haskell

max_forks_repo_name: lsund/dsp-haskell


text:
-- gaussian_integers.hs
-- to find prime numbers in Gaussian integers

import Data.Complex

-- merge two sorted sequence
-- f is a function that helps to compare
merge :: Ord b => (a -> b) -> [a] -> [a] -> [a]
merge _ xs [] = xs
merge _ [] ys = ys
merge f u@(x:xs) v@(y:ys)
  | f x > f y  = y : merge f u ys
  | f x <= f y = x : merge f xs v
merge _ _ _ = error "merge: this should not happen"

mergeSort :: Ord b => (a -> b) -> [a] -> [a]
mergeSort f us = let n = length us
               in if n < 2
                  then us
                  else let (xs, ys) = splitAt (n `div` 2) us
                       in merge f (mergeSort f xs) (mergeSort f ys)

-- ssq : "sum of squares"
ssq :: Num a => (a, a) -> a
ssq (a, b) = a*a + b*b

-- r'seq : "the integer points on the plane, sorted by distance from origin"
r'seq :: [(Integer, Integer)]
r'seq = loop 0 0 []
  where
    loop _ _ [] = loop 1 0 [(0,1), (1,1)]
    loop k l s@((x,y):_)
          | x < l     = let (us, vs) = splitAt (fromIntegral (l+1)) s
                        in us ++ loop k (l+1) vs
          | otherwise = let k' = k + 1
                            l' = floor $ sqrt $ fromIntegral k'
                            t  = zip (replicate (fromIntegral (k+2)) k') [0..k']
                            s' = merge ssq s $ t
                        in loop k' l' s'

-- multiplication of Complex (Integers), which is not provided
infix 7 `times`
times :: Num a => Complex a -> Complex a -> Complex a
(a:+b) `times` (c:+d) = (a*c-b*d) :+ (a*d+b*c)

-- return True if a+bi divides c+di
infix 4 `divides`
divides :: Integral a => Complex a -> Complex a -> Bool
(a:+b) `divides` (c:+d) = let (m:+n) = (a:+(-b)) `times` (c:+d)
                              p = ssq (a, b)
                          in (m `mod` p) == 0 && (n `mod` p) == 0

-- the Gaussian primes
g'primes :: [Complex Integer]
g'primes = sieve $ tail r'seq
  where sieve ((x,y):rest)
          = let ns = case () of _
                                  | y == 0 -> [x:+0,0:+x,(-x):+0,0:+(-x)]
                                  | x == y -> [x:+x,x:+(-x),(-x):+x,(-x):+(-x)]
                                  | otherwise ->  [x:+y,y:+x,(-y):+x,(-x):+y]
                                                 ++ [(-x):+(-y),(-y):+(-x)]
                                                 ++ [y:+(-x),x:+(-y)]
            in ns ++ sieve [(x,y)|(x,y) <- rest, not $ any (`divides` x:+y) ns]

main :: IO ()
--main = mapM_ (putStrLn . show) g'primes
main = print $ map (\(a:+b) -> (a,b)) g'primes

max_stars_repo_name: sclereid/collection

max_issues_repo_name: sclereid/collection

max_forks_repo_name: sclereid/collection


text:
module DecisionTree where

import Data.Function    ((&))
import Foreign.Storable (Storable)

import           Data.Map.Strict            (Map)
import qualified Data.Map.Strict            as M
import qualified Data.Vector.Storable       as V
import           Numeric.LinearAlgebra
import           Numeric.LinearAlgebra.Data as N

{-
building a decision tree:

- get info gains for each column
- group by top scoring column
- repeat, with smaller matrices

-}

{-
let v = fromList [0, 0, 1, 0, 0, 1, 0, 0, 2, 2, 0, 2] :: Vector I

entropy v
-}

entropy :: (Ord a, Storable a) => Vector a -> Double
entropy vec =
    let
        n =
            fromIntegral $ V.length vec

        proportions =
            count vec
                & M.elems
                & map fromIntegral
                & map (/ n)

        componentEntropies =
            [ -p * logBase 2 p | p <- proportions ]
    in
        sum componentEntropies

count :: (Ord a, Storable a) => Vector a -> Map a Int
count vec =
    V.foldl insertCount M.empty vec
    where
        insertCount :: Ord a => Map a Int -> a -> Map a Int
        insertCount countDict el = M.insertWith (+) el 1 countDict

{-
let v1 = fromList [0, 0, 1, 0, 0, 1, 0, 0, 2, 2, 0, 2] :: Vector I
let v2 = fromList [1, 2, 3, 4, 5, 5, 3, 5, 6, 8, 9, 5] :: Vector I

informationGain v1 v2
-}

informationGain :: (Ord a, Storable a) => Vector a -> Vector a -> Double
informationGain resultVector featureVector =
    let
        groupedResults =
            groupByVector featureVector resultVector

        n =
            fromIntegral $ V.length featureVector

        vecLen vec = fromIntegral (V.length vec)

        weightedEntropies =
            groupedResults
                & M.elems
                & map (\v -> (vecLen v / n) * entropy v)
    in
        sum weightedEntropies

informationGains :: Matrix I -> [Double]
informationGains mat =
    let
        featureVectors = N.toColumns mat
        resultVector = lastColumn mat
    in
        map (informationGain resultVector) featureVectors

groupByVector :: (Storable a, Storable b, Ord a) => Vector a -> Vector b -> Map a (Vector b)
groupByVector groupingVector targetVector =
    let
        groupedIndices =
            indicesMap groupingVector

        getAtIndices vec indices =
            V.ifilter (\i _ -> elem i indices) vec
    in
        groupedIndices
            & M.map (getAtIndices targetVector)

groupBy :: (Ord a, Element a) => Matrix a -> Int -> Map a (Matrix a)
groupBy mat columnIndex =
    let
        groupingVector =
            mat ¿ [columnIndex]
                & flatten

        groupedIndices =
            indicesMap groupingVector
    in
        groupedIndices
            & M.map (\v -> removeColumn (mat ? v) columnIndex)

indicesMap :: (Ord a, Storable a) => Vector a -> Map a [Int]
indicesMap vec =
    V.ifoldl insertIndex M.empty vec
    where
        insertIndex :: Ord a => Map a [Int] -> Int -> a -> Map a [Int]
        insertIndex indicesDict i el =
            M.insertWith (++) el [i] indicesDict

removeColumn :: (Element a) => Matrix a -> Int -> Matrix a
removeColumn m i =
    let
        m1 = m ?? (All, Take i)
        m2 = m ?? (All, Drop (i+1))
    in
    m1 ||| m2

lastColumn :: Matrix I -> Vector I
lastColumn m =
    let (_, width) = size m
    in flatten $ m ¿ [width-1]


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes   #-}

module Criterion.Collection.Sample
  ( Benchmark(..)
  , SampleData(..)
  , MeasurementMode(..)
  , WorkloadMode(..)
  , computeMeanAndStddev
  , compute95thPercentile
  , computeMax
  , takeSample
  , takeSamples
  ) where

import           Control.DeepSeq
import           Control.Monad
import           Control.Monad.Trans
import           Criterion                           hiding (Benchmark)
import           Criterion.Collection.Internal.Types
import           Criterion.Config
import           Criterion.Environment
import           Criterion.IO.Printf
import           Criterion.Measurement
import           Criterion.Monad
import           Data.IORef
import           Data.List                           (foldl')
import           Data.Monoid
import qualified Data.Vector                         as V
import qualified Data.Vector.Unboxed                 as U
import           Statistics.Quantile                 (cadpw, continuousBy)
import           Statistics.Sample
import           System.Mem                          (performGC)
import           System.Random.MWC
import           Text.Printf                         (printf)

------------------------------------------------------------------------------
data MeasurementMode = PerBatch | PerOperation
data WorkloadMode = Pure | Mutating

------------------------------------------------------------------------------
data SampleData = SampleData {
      sdInputSize :: !Int       -- ^ what was the size of the input for this
                                -- sample?
    , sdNumOps    :: !Int       -- ^ how many operations are covered by this
                                -- sample? For a per-operation measurement,
                                -- this value would be \"1\", and for a batch
                                -- measurement this value would be the number
                                -- of items in the batch.
    , sdData      :: !Sample    -- ^ sample data.
    }

instance Show SampleData where
    show (SampleData is nop da) = "<SampleData inputSize=" ++ show is
                                  ++ ", nops=" ++ show nop
                                  ++ ", sample size=" ++ show (U.length da)
                                  ++ ">"

------------------------------------------------------------------------------
data Benchmark op = Benchmark {
      benchmarkName     :: String
    , dataStructures    :: [(String, DataStructure op)]
    , inputSizes        :: [Int]
    , workloadGenerator :: WorkloadGenerator op
}

------------------------------------------------------------------------------
-- | Given some sample data, compute the mean time per operation (in seconds)
-- and standard deviation
computeMeanAndStddev :: SampleData -> (Double, Double)
computeMeanAndStddev (SampleData _ nops sample) = (v,s)
  where
    nopsReal         = fromIntegral nops
    (meanValue, var) = meanVarianceUnb sample
    stddev           = sqrt $ abs var
    !v               = meanValue / nopsReal
    !s               = stddev / nopsReal

------------------------------------------------------------------------------
-- | Given some sample data, compute the 95th percentile.
compute95thPercentile :: SampleData -> Double
compute95thPercentile (SampleData _ nops sample) = v
  where
    nopsReal         = fromIntegral nops
    quantile         = continuousBy cadpw 19 20 sample
    v                = quantile / nopsReal

------------------------------------------------------------------------------
-- | Given some sample data, compute the maximum value
computeMax :: SampleData -> Double
computeMax (SampleData _ nops sample) = v
  where
    nopsReal         = fromIntegral nops
    maxval           = U.foldl' max 0 sample
    v                = maxval / nopsReal

------------------------------------------------------------------------------
takeSample :: (NFData op) =>
              MeasurementMode
           -> WorkloadMode
           -> Benchmark op
           -> Environment
           -> GenIO
           -> Int
           -> Criterion [SampleData]
takeSample !mMode !wMode !benchmark !env !rng !inputSize = do
    workload <- liftIO $ runWorkloadMonad (workGen inputSize) rng
    let setupOperations = setupWork workload
    let genWorkData     = genWorkload workload

    case mMode of
      PerBatch     -> batch setupOperations genWorkData
      PerOperation -> perOp setupOperations genWorkData

  where
    --------------------------------------------------------------------------
    dss       = dataStructures benchmark
    workGen   = workloadGenerator benchmark

    --------------------------------------------------------------------------
    batch setupOperations genWorkData = do
        workData <- liftIO $ runWorkloadMonad (genWorkData $ inputSize `div` 2)
                                              rng
        let nOps = V.length workData
        mapM (batchOne setupOperations workData nOps) dss

    --------------------------------------------------------------------------
    mkRunOp runOpMutating =
        let runOpPure = \m op -> do
                            m' <- runOpMutating m op
                            return $! m' `seq` m
        in case wMode of
             Pure     -> runOpPure
             Mutating -> runOpMutating

    --------------------------------------------------------------------------
    runWorkData workData chunkSize runOp start i val = go i val
      where
        go !i !val
            | i >= chunkSize = return val
            | otherwise = do
                  let op = V.unsafeIndex workData (start+i)
                  !val' <- runOp val op
                  go (i+1) val'

    --------------------------------------------------------------------------
    batchOne setupOperations workData nOps
             (name, (DataStructure emptyValue runOpMutating)) = do
        note $ "running batch benchmark on " ++ name ++ "\n"
        let minTime = envClockResolution env * 1000
        cfg <- getConfig
        let proc = V.foldM' runOpMutating
        let mkStartValue = emptyValue inputSize >>= flip proc setupOperations
        startValue1 <- liftIO mkStartValue

        liftIO performGC
        let tProc = runWorkData workData nOps runOpMutating 0 0

        prolix $ "running test batch with " ++ show nOps
                 ++ " work items\n"

        (tm,_) <- liftIO $ time (tProc startValue1)

        prolix $ "running initial timing on " ++ show nOps
                 ++ " work items\n"

        let iters = max 5 (ceiling (minTime / tm))

        prolix $ "running benchmark on " ++ show nOps
                 ++ " work items, " ++ show iters ++ " iterations\n"

        sample <- liftIO $ U.generateM iters $ \_ -> do
                      sv <- mkStartValue
                      performGC
                      (!tm,_) <- time (tProc sv)
                      return $ tm - clockCost

        prolix $ "finished batch benchmark on " ++ name ++ "\n"
        return (SampleData inputSize nOps sample)

    --------------------------------------------------------------------------
    perOp setupOperations genWorkData = do
        -- FIXME: lifted this code from criterion, is there some way to merge
        -- them?
        _ <- prolix "generating seed workload"
        seedData <- liftIO $ runWorkloadMonad (genWorkData 1000) rng
        _ <- prolix "seed workload generated"

        workData <- liftIO $ runWorkloadMonad (genWorkData inputSize) rng
        mapM (perOpOne setupOperations workData seedData) dss

    --------------------------------------------------------------------------
    perOpOne setupOperations workData seedData
             (name, (DataStructure emptyValue runOpMutating)) = do
        let runOp = mkRunOp runOpMutating
        let proc = V.foldM' runOpMutating

        note $ "running per-op benchmark on " ++ name ++ "\n"

        startValue <- liftIO (emptyValue inputSize >>=
                              flip proc setupOperations)
        liftIO performGC

        -- warm up clock
        _ <- liftIO $ runForAtLeast 0.1 10000 (`replicateM_` getTime)
        let minTime = envClockResolution env * 1000

        (testTime, testIters, startValue') <-
            liftIO $ timeSeed (min minTime 0.1) seedData runOp startValue
        _   <- note "ran %d iterations in %s\n" testIters (secs testTime)
        cfg <- getConfig

        let testItersD       = fromIntegral testIters
        let sampleCount      = fromLJ cfgSamples cfg
        let timePer          = (testTime - testItersD * clockCost) / testItersD
        let chunkSizeD       = minTime / timePer
        let chunkSize        = min (V.length workData) (ceiling chunkSizeD)
        let nSamples1        = min (chunkSize * sampleCount) (V.length workData)
        let numItersD        = fromIntegral nSamples1 / fromIntegral chunkSize
        let nSamples = max 1 (floor numItersD * chunkSize)

        _ <- note "collecting %d samples (in chunks of %d) in estimated %s\n"
                  nSamples chunkSize
                  (secs ((chunkSizeD * timePer + clockCost)*numItersD))

        (sample,_) <- mkSample chunkSize nSamples workData startValue' runOp
        liftIO performGC
        return (SampleData inputSize chunkSize sample)

    --------------------------------------------------------------------------
    mkSample chunkSize nSamples workData startValue runOp = liftIO $ do
        valRef <- newIORef startValue

        let numItersD = fromIntegral nSamples / fromIntegral chunkSize
        -- make sure nSamples is an integral multiple of chunkSize
        let numIters = max 1 (floor (numItersD :: Double))

        sample <- U.generateM numIters $ \chunk -> do
            !val <- readIORef valRef
            (!tm, val') <- time (runWorkData workData chunkSize runOp
                                             (chunk*chunkSize) 0 val)
            writeIORef valRef val'
            return $ tm - clockCost

        val <- readIORef valRef
        return (sample :: U.Vector Double, val)

    --------------------------------------------------------------------------
    clockCost = envClockCost env

    --------------------------------------------------------------------------
    timeSeed howLong seedData runOp startValue =
        loop startValue seedData (0::Int) =<< getTime
      where
        loop sv seed iters initTime = do
            now <- getTime
            let n = V.length seed
            when (now - initTime > howLong * 10) $
                 fail (printf "took too long to run: seed %d, iters %d"
                              (V.length seed) iters)
            (elapsed, (_,sv')) <- time (mkSample 1 n seed sv runOp)

            if elapsed < howLong
              then loop sv' (seed `mappend` seed) (iters+1) initTime
              else return (elapsed, n, sv')

------------------------------------------------------------------------------
takeSamples :: (NFData op) =>
               MeasurementMode
            -> WorkloadMode
            -> Benchmark op
            -> Environment
            -> GenIO
            -> Criterion [(String, [SampleData])]
takeSamples !mMode !wMode !benchmark !env !rng = do
    let szs = inputSizes benchmark
    when (null szs) $ fail "No input sizes defined"

    ssamples <- mapM (takeSample mMode wMode benchmark env rng) szs
    let names = map fst $ dataStructures benchmark
    let inputs = foldl' combine (map (const []) names) (reverse ssamples)

    return $ names `zip` inputs

  where
    combine :: [[SampleData]] -> [SampleData] -> [[SampleData]]
    combine int samples = map (uncurry (flip (:))) (int `zip` samples)

max_stars_repo_name: sanjaymsh/hashtables

max_issues_repo_name: sanjaymsh/hashtables

max_forks_repo_name: sanjaymsh/hashtables


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

module Protolude (
  module X,
  module Base,
  identity,
  map,
  uncons,
  unsnoc,
  applyN,
  print,
  throwIO,
  throwTo,
  show,
  pass,
  guarded,
  guardedA,
  LText,
  LByteString,
  liftIO1,
  liftIO2,
#if !MIN_VERSION_base(4,8,0)
  (&),
  scanl',
#endif
  die,
) where

-- Protolude module exports.
import Debug as X
import Protolude.List as X
import Protolude.Show as X
import Protolude.Bool as X
import Protolude.Monad as X
import Protolude.Functor as X
import Protolude.Either as X
import Protolude.Applicative as X
import Protolude.Conv as X
import Protolude.Panic as X
import Protolude.Exceptions as X
import Protolude.Semiring as X

import Protolude.Base as Base hiding (
    putStr           -- Overriden by Show.putStr
  , putStrLn         -- Overriden by Show.putStrLn
  , print            -- Overriden by Protolude.print
  , show             -- Overriden by Protolude.show
  , showFloat        -- Custom Show instances deprecated.
  , showList         -- Custom Show instances deprecated.
  , showSigned       -- Custom Show instances deprecated.
  , showSignedFloat  -- Custom Show instances deprecated.
  , showsPrec        -- Custom Show instances deprecated.
  )
import qualified Protolude.Base as PBase

-- Used for 'show', not exported.
import Data.String (String)
import Data.String as X (IsString)

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

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

-- Base typeclasses
import Data.Eq as X (
    Eq(..)
  )
import Data.Ord as X (
    Ord(..)
  , Ordering(..)
  , Down(..)
  , comparing
  )
import Data.Traversable as X
import Data.Foldable as X hiding (
    foldr1
  , foldl1
  , product
  , sum
  )
import Data.Functor.Identity as X (
    Identity(..)
  )

#if MIN_VERSION_base(4,9,0)
import Data.List.NonEmpty as X (
    NonEmpty(..)
  , nonEmpty
  )
import Data.Semigroup as X (
    Semigroup(sconcat, stimes)
  , WrappedMonoid
  , Option(..)
  , option
  , diff
  , cycle1
  , stimesMonoid
  , stimesIdempotent
  , stimesIdempotentMonoid
  , mtimesDefault
  )
#endif

import Data.Monoid as X

#if !MIN_VERSION_base(4,8,0)
import Protolude.Bifunctor as X (Bifunctor(..))
#else
import Data.Bifunctor as X (Bifunctor(..))
#endif

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

-- Data structures
import Data.Tuple as X (
    fst
  , snd
  , curry
  , uncurry
  , swap
  )

import Data.List as X (
    splitAt
  , break
  , intercalate
  , isPrefixOf
  , drop
  , filter
  , reverse
  , replicate
  , take
  , sortBy
  , sort
  , intersperse
  , transpose
  , subsequences
  , permutations
  , scanl
#if MIN_VERSION_base(4,8,0)
  , scanl'
#endif
  , scanr
  , iterate
  , repeat
  , cycle
  , unfoldr
  , takeWhile
  , dropWhile
  , group
  , inits
  , tails
  , zipWith
  , zip
  , unzip
  , genericLength
  , genericTake
  , genericDrop
  , genericSplitAt
  , genericReplicate
  )

#if !MIN_VERSION_base(4,8,0)
-- These imports are required for the scanl' rewrite rules
import GHC.Exts (build)
import Data.List (tail)
#endif

-- Hashing
import Data.Hashable as X (
    Hashable
  , hash
  , hashWithSalt
  , hashUsing
  )

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 MIN_VERSION_base(4,7,0)
import Data.Proxy as X (
    Proxy(..)
  )

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

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

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

#endif

#if MIN_VERSION_base(4,8,0)
import Data.Void as X (
    Void
  , absurd
  , vacuous
  )
#endif

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

  , runState
  , execState
  , evalState

  , runStateT
  , execStateT
  , evalStateT
  )

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

import Control.Monad.Trans.Except as X (
    throwE
  , catchE
  )

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

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

-- Base types
import Data.Int as X (
    Int
  , Int8
  , Int16
  , Int32
  , Int64
  )
import Data.Bits as X hiding (
    unsafeShiftL
  , unsafeShiftR
  )
import Data.Word as X (
    Word
  , Word8
  , Word16
  , Word32
  , Word64
#if MIN_VERSION_base(4,7,0)
  , byteSwap16
  , byteSwap32
  , byteSwap64
#endif
  )

import Data.Either as X (
    Either(..)
  , either
  , lefts
  , rights
  , partitionEithers
#if MIN_VERSION_base(4,7,0)
  , isLeft
  , isRight
#endif
  )

import Data.Complex as X (
    Complex(..)
  , realPart
  , imagPart
  , mkPolar
  , cis
  , polar
  , magnitude
  , phase
  , conjugate
  )
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
#if MIN_VERSION_base(4,8,0)
  , (&)
#endif
  )

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

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

-- Text
import Data.Text as X (
    Text
  , lines
  , words
  , unlines
  , unwords
  )
import qualified Data.Text.Lazy

import Data.Text.IO as X (
    getLine
  , getContents
  , interact
  , readFile
  , writeFile
  , appendFile
  )

import Data.Text.Lazy as X (
    toStrict
  , fromStrict
  )

import Data.Text.Encoding as X (
    encodeUtf8
  , decodeUtf8
  , decodeUtf8'
  , decodeUtf8With
  )

import Data.Text.Encoding.Error as X (
    OnDecodeError
  , OnError
  , UnicodeException
  , lenientDecode
  , strictDecode
  , ignore
  , replace
  )

-- IO
import System.Environment as X (getArgs)
import qualified System.Exit
import System.Exit as X (
    ExitCode(..)
  , exitWith
  , exitFailure
  , exitSuccess
  )
import System.IO as X (
    Handle
  , FilePath
  , IOMode(..)
  , stdin
  , stdout
  , stderr
  , withFile
  , openFile
  )

-- ST
import Control.Monad.ST as X (
    ST
  , runST
  , fixST
  )

-- Concurrency and Parallelism
import Control.Exception as X hiding (
    throw    -- Impure throw is forbidden.
  , throwIO
  , throwTo
  , assert
  , Handler(..)
  )

import qualified Control.Exception

import Control.Monad.STM as X (
    STM
  , atomically
#if !(MIN_VERSION_stm(2,5,0))
  , always
  , alwaysSucceeds
#endif
  , retry
  , orElse
  , check
  , throwSTM
  , catchSTM
  )
import Control.Concurrent as X hiding (
    throwTo
  , yield
  )
import Control.Concurrent.Async as X (
    Async(..)
  , Concurrently(..)
  , async
  , asyncBound
  , asyncOn
  , withAsync
  , withAsyncBound
  , withAsyncOn
  , wait
  , poll
  , waitCatch
  , cancel
  , cancelWith
  , asyncThreadId
  , waitAny
  , waitAnyCatch
  , waitAnyCancel
  , waitAnyCatchCancel
  , waitEither
  , waitEitherCatch
  , waitEitherCancel
  , waitEitherCatchCancel
  , waitEither_
  , waitBoth
  , link
  , link2
  , race
  , race_
  , concurrently
  )

import Foreign.Ptr as X (IntPtr, WordPtr)
import Foreign.Storable as X (Storable)
import Foreign.StablePtr as X (StablePtr)

-- 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

#if !MIN_VERSION_base(4,8,0)
infixl 1 &

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

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)

unsnoc :: [x] -> Maybe ([x],x)
unsnoc = foldr go Nothing
  where
    go x mxs = Just (case mxs of
       Nothing -> ([], x)
       Just (xs, e) -> (x:xs, e))

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

throwIO :: (X.MonadIO m, Exception e) => e -> m a
throwIO = liftIO . Control.Exception.throwIO

throwTo :: (X.MonadIO m, Exception e) => ThreadId -> e -> m ()
throwTo tid e = liftIO (Control.Exception.throwTo tid e)

-- | Do nothing returning unit inside applicative.
pass :: Applicative f => f ()
pass = pure ()

guarded :: (Alternative f) => (a -> Bool) -> a -> f a
guarded p x = X.bool empty (pure x) (p x)

guardedA :: (Functor f, Alternative t) => (a -> f Bool) -> a -> f (t a)
guardedA p x = X.bool empty (pure x) <$> p x

-- | Lift an 'IO' operation with 1 argument into another monad
liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b
liftIO1 = (.) liftIO

-- | Lift an 'IO' operation with 2 arguments into another monad
liftIO2 :: MonadIO m => (a -> b -> IO c) -> a -> b -> m c
liftIO2 = ((.).(.)) liftIO

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

#if MIN_VERSION_base(4,8,0)
die :: Text -> IO a
die err = System.Exit.die (toS err)
#else
die :: Text -> IO a
die err = hPutStrLn stderr err >> exitFailure
#endif

#if !MIN_VERSION_base(4,8,0)
-- This is a literal copy of the implementation in GHC.List in base-4.10.1.0.

-- | A strictly accumulating version of 'scanl'
{-# NOINLINE [1] scanl' #-}
scanl'           :: (b -> a -> b) -> b -> [a] -> [b]
scanl' = scanlGo'
  where
    scanlGo'           :: (b -> a -> b) -> b -> [a] -> [b]
    scanlGo' f !q ls    = q : (case ls of
                            []   -> []
                            x:xs -> scanlGo' f (f q x) xs)

{-# RULES
"scanl'"  [~1] forall f a bs . scanl' f a bs =
  build (\c n -> a `c` foldr (scanlFB' f c) (flipSeqScanl' n) bs a)
"scanlList'" [1] forall f a bs .
    foldr (scanlFB' f (:)) (flipSeqScanl' []) bs a = tail (scanl' f a bs)
 #-}

{-# INLINE [0] scanlFB' #-}
scanlFB' :: (b -> a -> b) -> (b -> c -> c) -> a -> (b -> c) -> b -> c
scanlFB' f c = \b g -> \x -> let !b' = f x b in b' `c` g b'

{-# INLINE [0] flipSeqScanl' #-}
flipSeqScanl' :: a -> b -> a
flipSeqScanl' a !_b = a
#endif

max_stars_repo_name: asterite/protolude

max_issues_repo_name: asterite/protolude

max_forks_repo_name: asterite/protolude