{-|
Copyright  :  (C) 2016,      University of Twente,
                  2017,      QBayLogic, Google Inc.
                  2017-2019, Myrtle Software Ltd,
                  2021,      QBayLogic B.V.
License    :  BSD2 (see the file LICENSE)
Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>

'XException': An exception for uninitialized values

>>> show (errorX "undefined" :: Integer, 4 :: Int)
"(*** Exception: X: undefined
CallStack (from HasCallStack):
...
>>> showX (errorX "undefined" :: Integer, 4 :: Int)
"(undefined,4)"
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE Trustworthy #-}

module Clash.XException
  ( -- * 'XException': An exception for uninitialized values
    XException(..), errorX, isX, hasX, maybeIsX, maybeHasX, fromJustX, undefined,
    xToErrorCtx, xToError
    -- * Printing 'XException's as @undefined@
  , ShowX (..), showsX, printX, showsPrecXWith
    -- * Strict evaluation
  , seqX, seqErrorX, forceX, deepseqX, rwhnfX, defaultSeqX, hwSeqX
    -- * Structured undefined / deep evaluation with undefined values
  , NFDataX (rnfX, deepErrorX, hasUndefined, ensureSpine)
  )
where

import           Prelude             hiding (undefined)

import           Clash.Annotations.Primitive (hasBlackBox)
import           Clash.CPP           (maxTupleSize, fSuperStrict)
import           Clash.XException.Internal
import           Clash.XException.TH
import           Control.Exception
  (ErrorCall (..), Handler(..), catch, catches, evaluate, throw)
import           Control.DeepSeq     (NFData, rnf)
import           Data.Complex        (Complex)
import           Data.Either         (isLeft)
import           Data.Foldable       (toList)
import           Data.Int            (Int8, Int16, Int32, Int64)
import           Data.Ord            (Down (Down))
import           Data.Ratio          (Ratio, numerator, denominator)
import qualified Data.Semigroup      as SG
import qualified Data.Monoid         as M
import           Data.Sequence       (Seq(Empty, (:<|)))
import           Data.Word           (Word8, Word16, Word32, Word64)
import           Foreign.C.Types     (CUShort)
import           GHC.Generics
import           GHC.Natural         (Natural)
import           GHC.Stack
  (HasCallStack, callStack, prettyCallStack, withFrozenCallStack)
import           Numeric.Half        (Half)
import           System.IO.Unsafe    (unsafeDupablePerformIO)

-- $setup
-- >>> import Clash.Class.BitPack (pack)
-- >>> import Clash.Sized.Vector (Vec)
-- >>> import Clash.Sized.RTree (RTree)
-- >>> :set -fplugin GHC.TypeLits.Normalise
-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver

-- | Either 'seqX' or 'deepseqX' depending on the value of the cabal flag
-- '-fsuper-strict'. If enabled, 'defaultSeqX' will be 'deepseqX', otherwise
-- 'seqX'. Flag defaults to /false/ and thus 'seqX'.
defaultSeqX :: NFDataX a => a -> b -> b
defaultSeqX = if fSuperStrict then deepseqX else seqX
{-# INLINE defaultSeqX #-}
infixr 0 `defaultSeqX`

-- | Like 'error', but throwing an 'XException' instead of an 'ErrorCall'
--
-- The 'ShowX' methods print these error-values as @undefined@; instead of error'ing
-- out with an exception.
errorX :: HasCallStack => String -> a
errorX msg = throw (XException ("X: " ++ msg ++ "\n" ++ prettyCallStack callStack))

-- | Convert 'XException' to 'ErrorCall'
--
-- This is useful when tracking the source of 'XException' that gets eaten up by
-- 'Clash.Classes.BitPack.pack' inside of your circuit; since
-- 'Clash.Classes.BitPack.pack' translates 'XException' into undefined bits.
--
-- So for example if you have some large function f:
--
-- > f a b = ... pack a ... pack b ...
--
-- Where it is basically an error if either /a/ or /b/ ever throws an 'XException',
-- and so you want that to be reported the moment /a/ or /b/ is used, instead of
-- it being thrown when evaluating the result of /f/, then do:
--
-- > {-# LANGUAGE ViewPatterns #-}
-- > f (xToErrorCtx "a is X" -> a) (xToErrorCtx "b is X" -> b) = ...
--
-- Where we pass an extra string, for context, to know which argument evaluated
-- to an 'XException'. We can also use BangPatterns to report the potential
-- 'XException' being thrown by /a/ or /b/ even earlier, i.e. when /f/ is applied:
--
-- > {-# LANGUAGE ViewPatterns, BangPatterns #-}
-- > f (xToErrorCtx "a is X" -> !a) (xToErrorCtx "b is X" -> !b) = ...
--
-- __NB:__ Fully synthesizable, so doesn't have to be removed before synthesis
--
-- === __Example__
--
-- >>> :set -XViewPatterns -XDataKinds
-- >>> import Clash.Sized.BitVector
-- >>> import GHC.Stack
-- >>> :{
-- let h, h' :: Bit -> BitVector 8 -> BitVector 8
--     h (xToErrorCtx "a is X" -> a) (xToErrorCtx "b is X" -> b) = slice d7 d0 (pack a ++# b)
--     h' a b = slice d7 d0 (pack a ++# b)
-- :}
--
-- >>> h' (errorX "QQ") 3
-- 0b0000_0011
-- >>> h (errorX "QQ") 3
-- *** Exception: a is X
-- X: QQ
-- CallStack (from HasCallStack):
--   errorX, called at ...
-- <BLANKLINE>
xToErrorCtx :: String -> a -> a
xToErrorCtx ctx a = unsafeDupablePerformIO
  (catch (evaluate a >> return a)
         (\(XException msg) ->
           throw (ErrorCall (unlines [ctx,msg]))))
{-# NOINLINE xToErrorCtx #-}

-- | Convert 'XException' to 'ErrorCall'
--
-- This is useful when tracking the source of 'XException' that gets eaten up by
-- 'Clash.Classes.BitPack.pack' inside of your circuit; since
-- 'Clash.Classes.BitPack.pack' translates 'XException' into undefined bits.
--
-- So for example if you have some large function f:
--
-- > f a b = ... pack a ... pack b ...
--
-- Where it is basically an error if either /a/ or /b/ ever throws an 'XException',
-- and so you want that to be reported the moment /a/ or /b/ is used, instead of
-- it being thrown when evaluating the result of /f/, then do:
--
-- > {-# LANGUAGE ViewPatterns #-}
-- > f (xToError -> a) (xToError -> b) = ...
--
-- Unlike 'xToErrorCtx', where we have an extra String argument to distinguish
-- one call to 'xToError' to the other, 'xToError' will use the 'GHC.CallStack'
-- mechanism to aid the user in distinguishing different call to 'xToError'.
-- We can also use BangPatterns to report the potential 'XException' being
-- thrown by /a/ or /b/ even earlier, i.e. when /f/ is applied:
--
-- > {-# LANGUAGE ViewPatterns, BangPatterns #-}
-- > f (xToError -> !a) (xToError -> !b) = ...
--
-- __NB:__ Fully synthesizable, so doesn't have to be removed before synthesis
--
-- === __Example__
--
-- >>> :set -XViewPatterns -XDataKinds
-- >>> import Clash.Sized.BitVector
-- >>> import GHC.Stack
-- >>> :{
-- let f, g, h, h' :: HasCallStack => Bit -> BitVector 8 -> BitVector 8
--     f = g
--     g = h
--     h (xToError -> a) (xToError -> b) = slice d7 d0 (pack a ++# b)
--     h' a b = slice d7 d0 (pack a ++# b)
-- :}
--
-- >>> h' (errorX "QQ") 3
-- 0b0000_0011
-- >>> f (errorX "QQ") 3
-- *** Exception: CallStack (from HasCallStack):
--   xToError, called at ...
--   h, called at ...
--   g, called at ...
--   f, called at ...
-- X: QQ
-- CallStack (from HasCallStack):
--   errorX, called at ...
-- <BLANKLINE>
xToError :: HasCallStack => a -> a
xToError = xToErrorCtx (prettyCallStack callStack)
{-# INLINE xToError #-}

-- | Like 'seq', however, whereas 'seq' will always do:
--
-- > seq  _|_              b = _|_
--
-- 'seqX' will do:
--
-- > seqX (XException msg) b = b
-- > seqX _|_              b = _|_
seqX :: a -> b -> b
seqX a b = unsafeDupablePerformIO
  (catch (evaluate a >> return b) (\(XException _) -> return b))
{-# NOINLINE seqX #-}
infixr 0 `seqX`

-- | Like 'seqX', but will also catch ErrorCall exceptions which are thrown.
-- This should be used with care.
--
-- > seqErrorX (ErrorCall msg)  b = b
-- > seqErrorX (XException msg) b = b
-- > seqErrorX _|_              b = _|_
seqErrorX :: a -> b -> b
seqErrorX a b = unsafeDupablePerformIO
  ((evaluate a >> return b) `catches`
     [ Handler (\(XException _) -> return b)
     , Handler (\(ErrorCall _) -> return b)
     ])
{-# NOINLINE seqErrorX #-}
{-# ANN seqErrorX hasBlackBox #-}
infixr 0 `seqErrorX`

-- | Like 'seqX' in simulation, but will force its first argument to be rendered
-- in HDL. This is useful for components that need to be rendered in hardware,
-- but otherwise have no meaning in simulation. An example of such a component
-- would be an ILA: a component monitoring an internal signal of a design. The
-- output of such a component (typically a unit) can be passed as the first
-- argument to 'hwSeqX' to ensure the ILA ends up in the generated HDL.
--
-- __NB__: the result of 'hwSeqX' must (indirectly) be used at the very top of
-- a design. If it's not, Clash will remove it like it does for any other unused
-- circuit parts.
--
-- __NB__: Make sure the blackbox for the component with zero-width results
-- uses 'Clash.Netlist.BlackBox.Types.RenderVoid'
hwSeqX :: a -> b -> b
hwSeqX = seqX
{-# NOINLINE hwSeqX #-}
{-# ANN hwSeqX hasBlackBox #-}
infixr 0 `hwSeqX`

-- | Evaluate a value with given function, returning 'Nothing' if it throws
-- 'XException'.
--
-- > maybeX hasX 42                  = Just 42
-- > maybeX hasX (XException msg)    = Nothing
-- > maybeX hasX (3, XException msg) = Nothing
-- > maybeX hasX (3, _|_)            = _|_
-- > maybeX hasX _|_                 = _|_
-- >
-- > maybeX isX 42                  = Just 42
-- > maybeX isX (XException msg)    = Nothing
-- > maybeX isX (3, XException msg) = Just (3, XException msg)
-- > maybeX isX (3, _|_)            = Just (3, _|_)
-- > maybeX isX _|_                 = _|_
--
maybeX :: (a -> Either String a) -> a -> Maybe a
maybeX f a = either (const Nothing) Just (f a)

-- | Fully evaluate a value, returning 'Nothing' if it throws 'XException'.
--
-- > maybeX 42                  = Just 42
-- > maybeX (XException msg)    = Nothing
-- > maybeX (3, XException msg) = Nothing
-- > maybeX (3, _|_)            = _|_
-- > maybeX _|_                 = _|_
--
maybeHasX :: NFData a => a -> Maybe a
maybeHasX = maybeX hasX

-- | Evaluate a value to WHNF, returning 'Nothing' if it throws 'XException'.
--
-- > maybeIsX 42                  = Just 42
-- > maybeIsX (XException msg)    = Nothing
-- > maybeIsX (3, XException msg) = Just (3, XException msg)
-- > maybeIsX (3, _|_)            = Just (3, _|_)
-- > maybeIsX _|_                 = _|_
maybeIsX :: a -> Maybe a
maybeIsX = maybeX isX

-- | Fully evaluate a value, returning @'Left' msg@ if it throws 'XException'.
-- If you want to determine if a value contains undefined parts, use
-- 'hasUndefined' instead.
--
-- > hasX 42                  = Right 42
-- > hasX (XException msg)    = Left msg
-- > hasX (3, XException msg) = Left msg
-- > hasX (3, _|_)            = _|_
-- > hasX _|_                 = _|_
--
-- If a data structure contains multiple 'XException's, the "first" message is
-- picked according to the implementation of 'rnf'.
hasX :: NFData a => a -> Either String a
hasX a =
  unsafeDupablePerformIO
    (catch
      (evaluate (rnf a) >> return (Right a))
      (\(XException msg) -> return (Left msg)))
{-# NOINLINE hasX #-}

-- | Evaluate a value to WHNF, returning @'Left' msg@ if is a 'XException'.
--
-- > isX 42                  = Right 42
-- > isX (XException msg)    = Left msg
-- > isX (3, XException msg) = Right (3, XException msg)
-- > isX (3, _|_)            = (3, _|_)
-- > isX _|_                 = _|_
isX :: a -> Either String a
isX a =
  unsafeDupablePerformIO
    (catch
      (evaluate a >> return (Right a))
      (\(XException msg) -> return (Left msg)))
{-# NOINLINE isX #-}

-- | Like the 'Show' class, but values that normally throw an 'XException' are
-- converted to @undefined@, instead of error'ing out with an exception.
--
-- >>> show (errorX "undefined" :: Integer, 4 :: Int)
-- "(*** Exception: X: undefined
-- CallStack (from HasCallStack):
-- ...
-- >>> showX (errorX "undefined" :: Integer, 4 :: Int)
-- "(undefined,4)"
--
-- Can be derived using 'GHC.Generics':
--
-- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
-- >
-- > import Clash.Prelude
-- > import GHC.Generics
-- >
-- > data T = MkTA Int | MkTB Bool
-- >   deriving (Show,Generic,ShowX)
class ShowX a where
  -- | Like 'showsPrec', but values that normally throw an 'XException' are
  -- converted to @undefined@, instead of error'ing out with an exception.
  showsPrecX :: Int -> a -> ShowS

  -- | Like 'show', but values that normally throw an 'XException' are
  -- converted to @undefined@, instead of error'ing out with an exception.
  showX :: a -> String
  showX x = showsX x ""

  -- | Like 'showList', but values that normally throw an 'XException' are
  -- converted to @undefined@, instead of error'ing out with an exception.
  showListX :: [a] -> ShowS
  showListX ls s = showListX__ showsX ls s

  default showsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS
  showsPrecX = genericShowsPrecX

-- | Like 'print', but values that normally throw an 'XException' are
-- converted to @undefined@, instead of error'ing out with an exception
printX :: ShowX a => a -> IO ()
printX x = putStrLn $ showX x

instance ShowX ()

instance {-# OVERLAPPABLE #-} ShowX a => ShowX [a] where
  showsPrecX _ = showListX

instance ShowX Char where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Bool

instance ShowX Double where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX a => ShowX (Down a) where
  showsPrecX = showsPrecXWith showsPrecX

instance (ShowX a, ShowX b) => ShowX (Either a b)

instance ShowX Float where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Int where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Int8 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Int16 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Int32 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Int64 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Integer where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Natural where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX a => ShowX (Seq a) where
  showsPrecX _ = showListX . toList

instance ShowX Word where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Word8 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Word16 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Word32 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX Word64 where
  showsPrecX = showsPrecXWith showsPrec

instance ShowX a => ShowX (Maybe a)

instance ShowX a => ShowX (Ratio a) where
  showsPrecX = showsPrecXWith showsPrecX

instance ShowX a => ShowX (Complex a)

instance {-# OVERLAPPING #-} ShowX String where
  showsPrecX = showsPrecXWith showsPrec

-- | a variant of 'deepseqX' that is useful in some circumstances:
--
-- > forceX x = x `deepseqX` x
forceX :: NFDataX a => a -> a
forceX x = x `deepseqX` x
{-# INLINE forceX #-}

-- | 'deepseqX': fully evaluates the first argument, before returning the
-- second. Does not propagate 'XException's.
deepseqX :: NFDataX a => a -> b -> b
deepseqX a b = rnfX a `seq` b
{-# NOINLINE deepseqX #-}
infixr 0 `deepseqX`

-- | Reduce to weak head normal form
--
-- Equivalent to @\\x -> 'seqX' x ()@.
--
-- Useful for defining 'NFDataX.rnfX' for types for which NF=WHNF holds.
rwhnfX :: a -> ()
rwhnfX = (`seqX` ())
{-# INLINE rwhnfX #-}

-- | Class that houses functions dealing with /undefined/ values in Clash. See
-- 'deepErrorX' and 'rnfX'.
class NFDataX a where
  -- | Create a value where all the elements have an 'errorX',
  -- but the spine is defined.
  deepErrorX :: HasCallStack => String -> a

  default deepErrorX :: (HasCallStack, Generic a, GDeepErrorX (Rep a)) => String -> a
  deepErrorX = withFrozenCallStack $ to . gDeepErrorX

  -- | Determines whether any of parts of a given construct contain undefined
  -- parts. Note that a negative answer does not mean its bit representation
  -- is fully defined. For example:
  --
  -- >>> m = Nothing :: Maybe Bool
  -- >>> hasUndefined m
  -- False
  -- >>> pack m
  -- 0b0.
  -- >>> hasUndefined (pack m)
  -- True
  --
  hasUndefined :: a -> Bool

  default hasUndefined :: (Generic a, GHasUndefined (Rep a)) => a -> Bool
  hasUndefined = gHasUndefined . from

  -- | Create a value where at the very least the spine is defined. For example:
  --
  -- >>> spined = ensureSpine (errorX "?" :: (Int, Int))
  -- >>> case spined of (_, _) -> 'a'
  -- 'a'
  -- >>> fmap (const 'b') (ensureSpine undefined :: Vec 3 Int)
  -- 'b' :> 'b' :> 'b' :> Nil
  -- >>> fmap (const 'c') (ensureSpine undefined :: RTree 2 Int)
  -- <<'c','c'>,<'c','c'>>
  --
  -- For users familiar with 'Clash.Sized.Vector.lazyV': this is the generalized
  -- version of it.
  ensureSpine :: a -> a

  default ensureSpine :: (Generic a, GEnsureSpine (Rep a)) => a -> a
  ensureSpine = to . gEnsureSpine . from

  -- | Evaluate a value to NF. As opposed to 'NFData's
  -- 'rnf', it does not bubble up 'XException's.
  rnfX :: a -> ()

  default rnfX :: (Generic a, GNFDataX Zero (Rep a)) => a -> ()
  rnfX = grnfX RnfArgs0 . from

instance NFDataX ()

instance NFDataX b => NFDataX (a -> b) where
  deepErrorX = pure . deepErrorX
  rnfX = rwhnfX
  hasUndefined = error "hasUndefined on Undefined (a -> b): Not Yet Implemented"
  ensureSpine = id

instance NFDataX a => NFDataX (Down a) where
  deepErrorX = Down . deepErrorX
  rnfX d@(~(Down x)) = if isLeft (isX d) then () else rnfX x
  hasUndefined d@(~(Down x))= if isLeft (isX d) then True else hasUndefined x
  ensureSpine ~(Down x) = Down (ensureSpine x)

instance NFDataX Bool
instance NFDataX a => NFDataX [a]
instance (NFDataX a, NFDataX b) => NFDataX (Either a b)
instance NFDataX a => NFDataX (Maybe a)

instance NFDataX Char where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Double where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Float where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Int where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Int8 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Int16 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Int32 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Int64 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Integer where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Natural where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Word where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Word8 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Word16 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Word32 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Word64 where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX CUShort where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX Half where
  deepErrorX = errorX
  rnfX = rwhnfX
  hasUndefined = isLeft . isX
  ensureSpine = id

instance NFDataX a => NFDataX (Seq a) where
  deepErrorX = errorX
  rnfX s =
    if isLeft (isX s) then () else go s
   where
    go Empty = ()
    go (x :<| xs) = rnfX x `seq` go xs
  ensureSpine = id

  hasUndefined s =
    if isLeft (isX s) then True else go s
   where
    go Empty = False
    go (x :<| xs) = hasUndefined x || hasUndefined xs

instance NFDataX a => NFDataX (Ratio a) where
  deepErrorX = errorX
  rnfX r = rnfX (numerator r) `seq` rnfX (denominator r)
  hasUndefined r = isLeft (isX (numerator r)) || isLeft (isX (denominator r))
  ensureSpine = id

instance NFDataX a => NFDataX (Complex a) where
  deepErrorX = errorX

instance (NFDataX a, NFDataX b) => NFDataX (SG.Arg a b)
instance NFDataX (SG.All)
instance NFDataX (SG.Any)
instance NFDataX a => NFDataX (SG.Dual a)
instance NFDataX a => NFDataX (SG.Endo a)
instance NFDataX a => NFDataX (SG.First a)
instance NFDataX a => NFDataX (SG.Last a)
instance NFDataX a => NFDataX (SG.Max a)
instance NFDataX a => NFDataX (SG.Min a)
instance NFDataX a => NFDataX (SG.Product a)
instance NFDataX a => NFDataX (SG.Sum a)
instance NFDataX a => NFDataX (M.First a)
instance NFDataX a => NFDataX (M.Last a)

-- Sg.Option will be removed in 9.2. We can't locally disable deprecation
-- warnings (i.e., for this instance only) so we're prematurely removing it
-- instead.
#if __GLASGOW_HASKELL__ < 900
instance NFDataX a => NFDataX (SG.Option a)
#endif

-- | __N.B.__: The documentation only shows instances up to /3/-tuples. By
-- default, instances up to and including /12/-tuples will exist. If the flag
-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The
-- GHC imposed limit is either 62 or 64 depending on the GHC version.
mkShowXTupleInstances [2..maxTupleSize]

-- | __N.B.__: The documentation only shows instances up to /3/-tuples. By
-- default, instances up to and including /12/-tuples will exist. If the flag
-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The
-- GHC imposed limit is either 62 or 64 depending on the GHC version.
mkNFDataXTupleInstances [2..maxTupleSize]

-- | Call to 'errorX' with default string
undefined :: HasCallStack => a
undefined = errorX "undefined"

-- | Same as 'Data.Maybe.fromJust', but returns a bottom/undefined value that
-- other Clash constructs are aware of.
fromJustX :: HasCallStack => Maybe a -> a
fromJustX Nothing = errorX "isJustX: Nothing"
fromJustX (Just a) = a


{-# LANGUAGE RecordWildCards #-}
module Main where

import Control.Monad.Trans.Except
import System.IO
import Data.Word
import Data.Complex
import Foreign.C.Types
import Data.Monoid

import Control.Error.Util
import Foreign.Storable.Complex
import Options.Applicative
import Pipes as P
import Pipes.Prelude as P
import Data.Vector.Storable as VS hiding ((++))

import SDR.Util
import SDR.RTLSDRStream
import SDR.ArgUtils
import SDR.Serialize as S

data Options = Options {
    fileName   :: FilePath,
    frequency  :: Word32,
    sampleRate :: Word32,
    size       :: Maybe Int
}

optParser :: Parser Options
optParser = Options
          <$> strOption (
                 long "output  "
              <> short 'o'
              <> metavar "FILENAME"
              <> help "Output filename"
              )
          <*> option (fmap fromIntegral parseSize) (
                 long "frequency"
              <> short 'f'
              <> metavar "FREQUENCY"
              <> help "Frequency to tune to"
              )
          <*> option (fmap fromIntegral parseSize) (
                 long "samplerate"
              <> short 'r'
              <> metavar "RATE"
              <> help "Sample rate"
              )
          <*> optional (option (fmap fromIntegral parseSize) (
                 long "size"
              <> short 's'
              <> metavar "SIZE"
              <> help "Size of output file. If omitted, samples will be recorded until the program is killed"
              ))

opt :: ParserInfo Options
opt = info (helper <*> optParser) (fullDesc <> progDesc "Record IQ samples from an RTL2832 based device" <> header "RTLSDR Record")

doIt Options{..} = do
    str <- sdrStream (defaultRTLSDRParams frequency sampleRate) 1 16384
    lift $ withFile fileName WriteMode $ \handle ->
        runEffect $ str >-> maybe P.cat P.take size >-> P.map (interleavedIQUnsigned256ToFloat :: VS.Vector CUChar -> VS.Vector (Complex CFloat)) >-> S.toHandle handle

main = execParser opt >>= exceptT putStrLn return . doIt


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}

module Parser where

import           Control.Monad.Except
import           Data.Array
import           Data.Char
import           Data.Complex
import           Data.Ratio
import           Lib
import           Numeric
import           System.Environment
import           Text.Printf
import           Data.IORef
import           Text.ParserCombinators.Parsec
                                         hiding ( spaces )
import           LispTypes

trapError
  :: forall  a (m :: * -> *) . (MonadError a m, Show a) => m String -> m String
trapError action = action `catchError` (return . show)

extractValue :: ThrowsError a -> a
extractValue (Right val) = val

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~"

spaces :: Parser ()
spaces = skipMany1 space

parseString :: Parser LispVal
parseString = do
  char '"'
  x <- many (escapedChars <|> noneOf "\"")
  char '"'
  return $ String x

parseBool :: Parser LispVal
parseBool = do
  char '#'
  x <- oneOf "tf"
  return $ case x of
    't' -> Bool True
    'f' -> Bool False

escapedChars :: Parser Char
escapedChars = do
  char '\\'
  x <- oneOf "\\\"nrt"
  return $ case x of
    '\\' -> x
    '\"' -> '"'
    'n'  -> '\n'
    'r'  -> '\r'
    't'  -> '\t'

parseAtom :: Parser LispVal
parseAtom = do
  first <- letter <|> symbol
  rest  <- many (letter <|> symbol <|> digit)
  return $ Atom (first : rest)

parseChar :: Parser LispVal
parseChar = do
  string "#\\"
  value <- many1 alphaNum
  if length value == 1
    then return $ Character (head value)
    else case (map toLower value) of
      "space"   -> return $ Character ' '
      "newline" -> return $ Character '\n'
      _         -> fail "Invalid character literal"

parseDecimal1 :: Parser LispVal
parseDecimal1 = many1 digit >>= return . Number . read

parseDecimal2 :: Parser LispVal
parseDecimal2 = do
  try $ string "#d"
  parseDecimal1

parseOct :: Parser LispVal
parseOct = do
  try $ string "#o"
  x <- many1 octDigit
  return $ Number (oct2dig x)
  where oct2dig y = fst $ readOct y !! 0

parseHex :: Parser LispVal
parseHex = do
  try $ string "#h"
  x <- many1 hexDigit
  return $ Number (hex2dig x)
  where hex2dig y = fst $ readHex y !! 0

parseBin :: Parser LispVal
parseBin = do
  try $ string "#b"
  x <- many1 digit
  return $ Number (bin2dig x)
 where
  bin2dig = bin2dig' 0
  bin2dig' n "" = n
  bin2dig' n (x : xs) =
    let current = (n * 2) + (if x == '1' then 1 else 0) in bin2dig' current xs

parseInteger :: Parser LispVal
parseInteger =
  parseDecimal1 <|> parseDecimal2 <|> parseOct <|> parseHex <|> parseBin

parseFloat :: Parser LispVal
parseFloat = do
  ds <- many1 digit
  char '.'
  decs <- many1 digit
  return $ Float $ toFloat (ds ++ "." ++ decs)
  where toFloat xs = fst $ head $ readFloat xs

parseRatio :: Parser LispVal
parseRatio = do
  numerator <- many1 digit
  char '/'
  denominator <- many1 digit
  return $ Ratio (read numerator % read denominator)

toDouble :: LispVal -> Double
toDouble (Float  x) = x
toDouble (Number x) = fromIntegral x

parseComplex :: Parser LispVal
parseComplex = do
  r <- try parseFloat <|> parseInteger
  char '+'
  i <- try parseFloat <|> parseInteger
  char 'i'
  return $ Complex (toDouble r :+ toDouble i)

parseNumber :: Parser LispVal
parseNumber =
  try parseComplex <|> try parseFloat <|> try parseRatio <|> parseInteger

parseList :: Parser LispVal
parseList = do
  values <- sepBy parseExpr spaces
  return $ List values

parseDottedList :: Parser LispVal
parseDottedList = do
  head <- endBy parseExpr spaces
  tail <- char '.' >> spaces >> parseExpr
  return $ DottedList head tail

parseLists :: Parser LispVal
parseLists = do
  char '('
  value <- try parseList <|> parseDottedList
  char ')'
  return value

parseQuoted :: Parser LispVal
parseQuoted = do
  char '\''
  exp <- parseExpr
  return $ List [Atom "quote", exp]

parseQuasiquote :: Parser LispVal
parseQuasiquote = do
  char '`'
  exp <- parseExpr
  return $ List [Atom "quasiquote", exp]

parseUnquote :: Parser LispVal
parseUnquote = do
  char ','
  exp <- parseExpr
  return $ List [Atom "unquote", exp]

parseVector :: Parser LispVal
parseVector = do
  string "#("
  values <- sepBy parseExpr spaces
  char ')'
  return $ Vector (listArray (0, (length values) - 1) values)

parseQuotes :: Parser LispVal
parseQuotes = parseQuoted <|> parseQuasiquote <|> parseUnquote

parseExpr :: Parser LispVal
parseExpr =
  parseAtom
    <|> parseString
    <|> try parseBool
    <|> try parseVector
    <|> parseNumber
    <|> parseQuotes
    <|> parseLists

readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
  Left err -> throwError $ Parser err
  Right val -> return val

readExpr :: String -> ThrowsError LispVal
readExpr = readOrThrow parseExpr

readExprList = readOrThrow (endBy parseExpr spaces)

parseIt :: String -> Maybe LispVal
parseIt s = case parse parseExpr "lisp" s of
  Left  _ -> Nothing
  Right s -> Just s


module Main (main) where

import Criterion.Types
import qualified Data.Aeson as Aeson
import qualified Data.Vector as V
import Properties
import Statistics.Types (estimateFromErr, mkCL)
import Test.Tasty (defaultMain, testGroup)
import Test.Tasty.HUnit (testCase)
import Test.HUnit

r1 :: Report
r1 = Report 0 "" [] v1 s1 (Outliers 0 0 0 0 0) []
 where
  m1 = Measured 4.613000783137977e-05 3.500000000000378e-05 31432 1 0 0 0 0.0 0.0 0.0 0.0
  v1 = V.fromList [m1]
  est1 = estimateFromErr 0.0 (0.0, 0.0) (mkCL 0.0)
  s1 = SampleAnalysis [] 0.0 est1 est1 (OutlierVariance Unaffected "" 0.0)

m2 :: Measured
m2 = Measured {measTime = 1.1438998626545072e-5
              , measCpuTime = 1.2000000001677336e-5
              , measCycles = 6208
              , measIters = 1

              , measAllocated = minBound
              , measNumGcs = minBound
              , measBytesCopied = minBound

              , measMutatorWallSeconds = -1/0
              , measMutatorCpuSeconds = -1/0
              , measGcWallSeconds = -1/0
              , measGcCpuSeconds = -1/0}

main :: IO ()
main = defaultMain $ testGroup "Tests"
       [ Properties.tests
       , testCase "json-roundtrip1"
           (assertEqual "round trip simple Measured"
              (Right m2) (Aeson.eitherDecode (Aeson.encode m2)))
       , testCase "json-roundtrip2"
           (assertEqual "round trip simple Report"
              (Right r1) (Aeson.eitherDecode (Aeson.encode r1)))
       ]


{-# LANGUAGE DeriveGeneric, DeriveAnyClass, RankNTypes #-}

import GHC.Generics
import Generic.Random (genericArbitraryU)
import Test.Tasty
import Test.Tasty.QuickCheck as QC
import Data.Proxy
import Test.Tasty.Travis
import Data.Word
import Data.Int
import Data.Complex
import Data.Either

import Coalpit

data Basic = Basic Int String Double
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Basic where arbitrary = genericArbitraryU

data WithLists = WithLists [Int] [String] [Double]
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary WithLists where arbitrary = genericArbitraryU

data Record = Record { maybeInt :: Maybe Int
                     , maybeDouble :: Maybe Double
                     , str :: String
                     , listOfStrings :: [String]
                     , maybeNonEmptyListOfNumbers :: Maybe [Integer]
                     , otherString :: String
                     } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Record where arbitrary = genericArbitraryU

data Sum = Foo Int Bool
         | Bar
         | Baz (Int8, (Complex Float, Word16), Rational)
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Sum where arbitrary = genericArbitraryU

data Nested = Nested Record Basic WithLists Sum
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Nested where arbitrary = genericArbitraryU

data Polymorphic a b = Polymorphic (Maybe a) (Either a b)
  deriving (Generic, Eq, Show)
instance (Coalpit a, Coalpit b) => Coalpit (Polymorphic a b)
instance (Arbitrary a, Arbitrary b) => Arbitrary (Polymorphic a b) where
  arbitrary = genericArbitraryU

data Recursive = RecursiveA
               | RecursiveB Recursive
  deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary Recursive where arbitrary = genericArbitraryU

data NestedRecord = NestedRecord { record1 :: Maybe Record
                                 , record2 :: Maybe Record
                                 , record3 :: Maybe Record
                                 } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary NestedRecord where arbitrary = genericArbitraryU

data NestedSum = NestedFoo Record
               | NestedBar Sum Basic Nested
               | NestedBaz (Polymorphic Char Double)
               deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary NestedSum where arbitrary = genericArbitraryU

data RecursiveRecordMaybe = RecursiveRecordMaybe
  { rrm :: Maybe RecursiveRecordMaybe
  , record :: Maybe Record
  , guard :: Word8
  } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary RecursiveRecordMaybe where arbitrary = genericArbitraryU

data RecursiveRecordMaybe2 = RecursiveRecordMaybe2
  { record1' :: Maybe Record
  , rrm' :: Maybe (Maybe RecursiveRecordMaybe2)
  , record2' :: Maybe Record
  , guard' :: Word8
  } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary RecursiveRecordMaybe2 where arbitrary = genericArbitraryU

data RecordStrings = RecordStrings
  { s1 :: String
  , s2 :: String
  , s3 :: String
  } deriving (Generic, Eq, Show, Coalpit)
instance Arbitrary RecordStrings where arbitrary = genericArbitraryU

printAndParse :: (Coalpit a, Eq a)
              => Options -> Proxy a -> a -> Bool
printAndParse opt _ r = Right r == fromArgs opt (toArgs opt r)

printAndParseDSV :: (Coalpit a, Eq a)
                 -- It would take a long time to test with [a], so
                 -- just repeating it 0--2 times.
                 => Options -> Proxy a -> (a, Int) -> Bool
printAndParseDSV opt _ (x, n) =
  let xs = (replicate (n `mod` 3) x)
  in xs == (rights . map (readDSV opt) . lines . unlines . map (showDSV opt) $ xs)

variousTypes :: (forall a. (Coalpit a, Eq a, Show a, Arbitrary a) =>
                  Proxy a -> String -> TestTree)
             -> [TestTree]
variousTypes f =
  [ f (Proxy :: Proxy Basic) "Basic"
  , f (Proxy :: Proxy WithLists) "WithLists"
  , f (Proxy :: Proxy Record) "Record"
  , f (Proxy :: Proxy Sum) "Sum"
  , f (Proxy :: Proxy Nested) "Nested"
  , f (Proxy :: Proxy (Polymorphic Int Double)) "Polymorphic Int Double"
  , f (Proxy :: Proxy (Polymorphic Basic Record)) "Polymorphic Basic Record"
  , f (Proxy :: Proxy (Polymorphic Nested (Polymorphic Basic Sum)))
    "Polymorphic Nested (Polymorphic Basic Sum)"
  , f (Proxy :: Proxy Recursive) "Recursive"
  , f (Proxy :: Proxy NestedRecord) "NestedRecord"
  , f (Proxy :: Proxy NestedSum) "NestedSum"
  , f (Proxy :: Proxy RecursiveRecordMaybe) "RecursiveRecordMaybe"
  , f (Proxy :: Proxy RecursiveRecordMaybe2) "RecursiveRecordMaybe2"
  , f (Proxy :: Proxy RecordStrings) "RecordStrings"
  ]

variousOptions :: (Options -> [TestTree]) -> [TestTree]
variousOptions tt =
  [ testGroup (concat [ "alwaysUseSelName = ", show ausn
                      , ", omitNamedOptions = ", show ono])
    (tt defOpt { alwaysUseSelName = ausn
               , omitNamedOptions = ono })
  | ausn <- [True, False]
  , ono <- [True, False]
  ]

qcProps :: TestTree
qcProps = testGroup "Quickcheck properties"
  [ testGroup "Right == fromArgs opt . toArgs opt"
    (variousOptions $ \opt ->
        variousTypes $ \p n -> QC.testProperty n (printAndParse opt p))
  , testGroup
    "id == rights . map (readDSV opt) . lines . unlines . map (showDSV opt)"
    (variousOptions $ \opt ->
        variousTypes $ \p n -> QC.testProperty n (printAndParseDSV opt p))
  ]

main :: IO ()
main = travisTestReporter defaultConfig [] qcProps


{-# LANGUAGE RecordWildCards #-}
module SchemeParser.Printer where

import Data.Complex (Complex(..))
import Data.Ratio (numerator, denominator)

import SchemeParser.Types
import SchemeParser.Error

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

-- lispval

showVal :: LispVal -> String
showVal (LString s) = "\"" ++ s ++ "\""
showVal (LChar c) = "#\\" ++ [c]
showVal (LAtom a) = a
showVal LNil = "nil"
showVal (LNumber n) = show n
showVal (LFloat f) = show f
showVal (LRatio r) = show (numerator r) ++ "/" ++ show (denominator r)
showVal (LComplex (r :+ i)) = show r ++ "+" ++ show i ++ "i"
showVal (LBool True) = "#true"
showVal (LBool False) = "#false"
showVal (LList xs) = "(" ++ unwordsList xs ++ ")"
showVal (LDottedList hd tl) = "(" ++ unwordsList hd ++ " . " ++ showVal tl ++ ")"
showVal (LVector xs) = "#(" ++ unwordsList xs ++ ")"
showVal (LPrimFunc _) = "<primitive>"
showVal LFunc{..} = "(lambda (" ++ unwords (map show params) ++ vargs ++ ") ...)"
  where vargs = case vararg of Nothing -> ""
                               Just args -> " . " ++ args

instance Show LispVal where
  show = showVal

-- errors

showError :: LispError -> String
showError (UnboundVar message varname)  = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func)    = message ++ ": " ++ show func
showError (NumArgs expected found)      =
  "Expected " ++ show expected ++ " args; found values " ++ unwordsList found
showError (TypeMismatch expected found) =
  "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser parseErr)             = "Parse error at " ++ show parseErr
showError (Default message)             = message

instance Show LispError where
  show = showError


module Mllib.Types
    ( module Reexport
    ) where

import Data.Tree as Reexport (Tree, Forest)

import Numeric.LinearAlgebra.Data    as Reexport (fromList, toList, vector, size)
import Numeric.LinearAlgebra.Data    as Reexport (Vector, R)

-- TODO: replace it
import Numeric.LinearAlgebra.HMatrix as Reexport (norm_2)

import System.Random as Reexport (StdGen, mkStdGen)

-- ======== ANOTHER WAY TO IMPORT ========

{-
module Mllib.Types
    ( norm_2
    , fromList
    , Vector
    , R
    ) where

import Numeric.LinearAlgebra.HMatrix (norm_2)
import Numeric.LinearAlgebra.Data (fromList)
import Numeric.LinearAlgebra.Data (Vector, R)
-}


{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, GADTs, RecordWildCards #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

-- |
-- Module      : Criterion.Types
-- Copyright   : (c) 2009-2014 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Types for benchmarking.
--
-- The core type is 'Benchmarkable', which admits both pure functions
-- and 'IO' actions.
--
-- For a pure function of type @a -> b@, the benchmarking harness
-- calls this function repeatedly, each time with a different 'Int64'
-- argument (the number of times to run the function in a loop), and
-- reduces the result the function returns to weak head normal form.
--
-- For an action of type @IO a@, the benchmarking harness calls the
-- action repeatedly, but does not reduce the result.

module Criterion.Types
    (
    -- * Configuration
      Config(..)
    , Verbosity(..)
    -- * Benchmark descriptions
    , Benchmarkable(..)
    , Benchmark(..)
    -- * Measurements
    , Measured(..)
    , fromInt
    , toInt
    , fromDouble
    , toDouble
    , measureAccessors
    , measureKeys
    , measure
    , rescale
    -- * Benchmark construction
    , env
    , envWithCleanup
    , perBatchEnv
    , perBatchEnvWithCleanup
    , perRunEnv
    , perRunEnvWithCleanup
    , toBenchmarkable
    , bench
    , bgroup
    , addPrefix
    , benchNames
    -- ** Evaluation control
    , nf
    , whnf
    , nfIO
    , whnfIO
    -- * Result types
    , Outliers(..)
    , OutlierEffect(..)
    , OutlierVariance(..)
    , Regression(..)
    , KDE(..)
    , Report(..)
    , SampleAnalysis(..)
    , DataRecord(..)
    ) where

import Control.DeepSeq (NFData(rnf))
import Criterion.Measurement.Types
import Data.Aeson (FromJSON(..), ToJSON(..))
import Data.Binary (Binary(..), putWord8, getWord8)
import Data.Data (Data, Typeable)
import Data.Int (Int64)
import Data.Map (Map)
import GHC.Generics (Generic)
import Prelude ()
import Prelude.Compat
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import qualified Statistics.Types as St
import           Statistics.Resampling.Bootstrap ()

-- | Control the amount of information displayed.
data Verbosity = Quiet
               | Normal
               | Verbose
                 deriving (Eq, Ord, Bounded, Enum, Read, Show, Typeable, Data,
                           Generic)

-- | Top-level benchmarking configuration.
data Config = Config {
      confInterval :: St.CL Double
      -- ^ Confidence interval for bootstrap estimation (greater than
      -- 0, less than 1).
    , timeLimit    :: Double
      -- ^ Number of seconds to run a single benchmark.  (In practice,
      -- execution time will very slightly exceed this limit.)
    , resamples    :: Int
      -- ^ Number of resamples to perform when bootstrapping.
    , regressions  :: [([String], String)]
      -- ^ Regressions to perform.
    , rawDataFile  :: Maybe FilePath
      -- ^ File to write binary measurement and analysis data to.  If
      -- not specified, this will be a temporary file.
    , reportFile   :: Maybe FilePath
      -- ^ File to write report output to, with template expanded.
    , csvFile      :: Maybe FilePath
      -- ^ File to write CSV summary to.
    , jsonFile     :: Maybe FilePath
      -- ^ File to write JSON-formatted results to.
    , junitFile    :: Maybe FilePath
      -- ^ File to write JUnit-compatible XML results to.
    , verbosity    :: Verbosity
      -- ^ Verbosity level to use when running and analysing
      -- benchmarks.
    , template     :: FilePath
      -- ^ Template file to use if writing a report.
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

-- | Outliers from sample data, calculated using the boxplot
-- technique.
data Outliers = Outliers {
      samplesSeen :: !Int64
    , lowSevere   :: !Int64
    -- ^ More than 3 times the interquartile range (IQR) below the
    -- first quartile.
    , lowMild     :: !Int64
    -- ^ Between 1.5 and 3 times the IQR below the first quartile.
    , highMild    :: !Int64
    -- ^ Between 1.5 and 3 times the IQR above the third quartile.
    , highSevere  :: !Int64
    -- ^ More than 3 times the IQR above the third quartile.
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON Outliers
instance ToJSON Outliers

instance Binary Outliers where
    put (Outliers v w x y z) = put v >> put w >> put x >> put y >> put z
    get = Outliers <$> get <*> get <*> get <*> get <*> get
instance NFData Outliers

-- | A description of the extent to which outliers in the sample data
-- affect the sample mean and standard deviation.
data OutlierEffect = Unaffected -- ^ Less than 1% effect.
                   | Slight     -- ^ Between 1% and 10%.
                   | Moderate   -- ^ Between 10% and 50%.
                   | Severe     -- ^ Above 50% (i.e. measurements
                                -- are useless).
                     deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)

instance FromJSON OutlierEffect
instance ToJSON OutlierEffect

instance Binary OutlierEffect where
    put Unaffected = putWord8 0
    put Slight     = putWord8 1
    put Moderate   = putWord8 2
    put Severe     = putWord8 3
    get = do
        i <- getWord8
        case i of
            0 -> return Unaffected
            1 -> return Slight
            2 -> return Moderate
            3 -> return Severe
            _ -> fail $ "get for OutlierEffect: unexpected " ++ show i
instance NFData OutlierEffect

instance Semigroup Outliers where
    (<>) = addOutliers

instance Monoid Outliers where
    mempty  = Outliers 0 0 0 0 0
#if !(MIN_VERSION_base(4,11,0))
    mappend = addOutliers
#endif

addOutliers :: Outliers -> Outliers -> Outliers
addOutliers (Outliers s a b c d) (Outliers t w x y z) =
    Outliers (s+t) (a+w) (b+x) (c+y) (d+z)
{-# INLINE addOutliers #-}

-- | Analysis of the extent to which outliers in a sample affect its
-- standard deviation (and to some extent, its mean).
data OutlierVariance = OutlierVariance {
      ovEffect   :: OutlierEffect
    -- ^ Qualitative description of effect.
    , ovDesc     :: String
    -- ^ Brief textual description of effect.
    , ovFraction :: Double
    -- ^ Quantitative description of effect (a fraction between 0 and 1).
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON OutlierVariance
instance ToJSON OutlierVariance

instance Binary OutlierVariance where
    put (OutlierVariance x y z) = put x >> put y >> put z
    get = OutlierVariance <$> get <*> get <*> get

instance NFData OutlierVariance where
    rnf OutlierVariance{..} = rnf ovEffect `seq` rnf ovDesc `seq` rnf ovFraction

-- | Results of a linear regression.
data Regression = Regression {
    regResponder  :: String
    -- ^ Name of the responding variable.
  , regCoeffs     :: Map String (St.Estimate St.ConfInt Double)
    -- ^ Map from name to value of predictor coefficients.
  , regRSquare    :: St.Estimate St.ConfInt Double
    -- ^ R² goodness-of-fit estimate.
  } deriving (Eq, Read, Show, Typeable, Generic)

instance FromJSON Regression
instance ToJSON Regression

instance Binary Regression where
    put Regression{..} =
      put regResponder >> put regCoeffs >> put regRSquare
    get = Regression <$> get <*> get <*> get

instance NFData Regression where
    rnf Regression{..} =
      rnf regResponder `seq` rnf regCoeffs `seq` rnf regRSquare

-- | Result of a bootstrap analysis of a non-parametric sample.
data SampleAnalysis = SampleAnalysis {
      anRegress    :: [Regression]
      -- ^ Estimates calculated via linear regression.
    , anMean       :: St.Estimate St.ConfInt Double
      -- ^ Estimated mean.
    , anStdDev     :: St.Estimate St.ConfInt Double
      -- ^ Estimated standard deviation.
    , anOutlierVar :: OutlierVariance
      -- ^ Description of the effects of outliers on the estimated
      -- variance.
    } deriving (Eq, Read, Show, Typeable, Generic)

instance FromJSON SampleAnalysis
instance ToJSON SampleAnalysis

instance Binary SampleAnalysis where
    put SampleAnalysis{..} = do
      put anRegress; put anMean; put anStdDev; put anOutlierVar
    get = SampleAnalysis <$> get <*> get <*> get <*> get

instance NFData SampleAnalysis where
    rnf SampleAnalysis{..} =
        rnf anRegress `seq` rnf anMean `seq`
        rnf anStdDev `seq` rnf anOutlierVar

-- | Data for a KDE chart of performance.
data KDE = KDE {
      kdeType   :: String
    , kdeValues :: U.Vector Double
    , kdePDF    :: U.Vector Double
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON KDE
instance ToJSON KDE

instance Binary KDE where
    put KDE{..} = put kdeType >> put kdeValues >> put kdePDF
    get = KDE <$> get <*> get <*> get

instance NFData KDE where
    rnf KDE{..} = rnf kdeType `seq` rnf kdeValues `seq` rnf kdePDF

-- | Report of a sample analysis.
data Report = Report {
      reportNumber   :: Int
      -- ^ A simple index indicating that this is the /n/th report.
    , reportName     :: String
      -- ^ The name of this report.
    , reportKeys     :: [String]
      -- ^ See 'measureKeys'.
    , reportMeasured :: V.Vector Measured
      -- ^ Raw measurements.
    , reportAnalysis :: SampleAnalysis
      -- ^ Report analysis.
    , reportOutliers :: Outliers
      -- ^ Analysis of outliers.
    , reportKDEs     :: [KDE]
      -- ^ Data for a KDE of times.
    } deriving (Eq, Read, Show, Typeable, Generic)

instance FromJSON Report
instance ToJSON Report

instance Binary Report where
    put Report{..} =
      put reportNumber >> put reportName >> put reportKeys >>
      put reportMeasured >> put reportAnalysis >> put reportOutliers >>
      put reportKDEs

    get = Report <$> get <*> get <*> get <*> get <*> get <*> get <*> get

instance NFData Report where
    rnf Report{..} =
      rnf reportNumber `seq` rnf reportName `seq` rnf reportKeys `seq`
      rnf reportMeasured `seq` rnf reportAnalysis `seq` rnf reportOutliers `seq`
      rnf reportKDEs

data DataRecord = Measurement Int String (V.Vector Measured)
                | Analysed Report
                deriving (Eq, Read, Show, Typeable, Generic)

instance Binary DataRecord where
  put (Measurement i n v) = putWord8 0 >> put i >> put n >> put v
  put (Analysed r)        = putWord8 1 >> put r

  get = do
    w <- getWord8
    case w of
      0 -> Measurement <$> get <*> get <*> get
      1 -> Analysed    <$> get
      _ -> error ("bad tag " ++ show w)

instance NFData DataRecord where
  rnf (Measurement i n v) = rnf i `seq` rnf n `seq` rnf v
  rnf (Analysed r)        = rnf r

instance FromJSON DataRecord
instance ToJSON DataRecord


module Commands where

import Statistics
import Expense
import Parser
import Extras
import Errors
import Data.List
import Data.Maybe

-- arguments -> original -> filtered -> message/result
type CmdFunc = [String] -> [Expense] -> [Expense] -> Either String [Expense]

getCommandFunction :: String -> Maybe CmdFunc
getCommandFunction cmd = lookup cmd $ commandList

commandList :: [(String, CmdFunc)]
commandList = [("ls",   lsElements),
               -- ("add",  addElement),
               ("show", showElements)]

showElements :: CmdFunc
showElements []           _ _ = Left $ show $ MissingArgs "show"
showElements ["tags"]     _ l = Left $ tagStats l
showElements ["stats"]    o l = Left $ showStats o l
showElements ["months"]   _ l = Left $ monthStats l
showElements ("tags":_)   _ _ = Left $ show $ ExcessiveArgs "show tags"
showElements ("stats":_)  _ _ = Left $ show $ ExcessiveArgs "show stats"
showElements ("months":_) _ _ = Left $ show $ ExcessiveArgs "show months"
showElements (_:_)        _ _ = Left $ show $ UnknownArg "show"

addElement :: CmdFunc
addElement args _ expL
  | argsLen < 3 = Left $ show $ MissingArgs "add"
  | argsLen > 3 = Left $ show $ ExcessiveArgs "add"
  | otherwise   = case parseExpense $ unwords args of
    Right es -> Left  $ show es
    Left  e  -> Right $ resExpL e
  where argsLen   = length args
        resExpL e = expL ++ [e]

lsCommandList :: [(String, CmdFunc)]
lsCommandList = [("tags",   lsWithTags),
                 ("dates",  lsWithDates),
                 ("months", lsWithMonths),
                 ("years",  lsWithYears)]

lsElements :: CmdFunc
lsElements []  _ expL = Right expL
lsElements [x] _ _    = case lookup x lsCommandList of
  Nothing -> Left $ show $ UnknownArg "ls"
  Just _  -> Left $ show $ MissingArgs x
lsElements (x:xs) _ expL = case lookup x lsCommandList of
  Nothing -> lsElements [x] [] []
  Just f  -> f xs [] expL

lsWithDates :: CmdFunc
lsWithDates dates_ _ l
  | (length $ filter (== []) $ dates1) > 0 = Left $ show ParserErrDates
  | (length $ resL) > 0                    = Right resL
  | otherwise                              = Left $ show NoEntries
  where dates1 = map (maybeToList . parseDate) dates_
        dates  = map (!! 0) dates1
        resL   = foldl (\a e -> a ++ filterByDate e l) [] dates

lsWithMonths :: CmdFunc
lsWithMonths months_ _ expL
  | (length $ filter (== []) $ months1) > 0 = Left $ show ParserErrMonths
  | (length $ resL) > 0                     = Right resL
  | otherwise                               = Left $ show NoEntries
  where months1 = map (maybeToList . parseMonth) months_
        months  = map (!! 0) months1
        resL    = filter (\e -> (yearOf e `elem` map yearFrom months) &&
                                (monthOf e `elem` map monthFrom months)) expL

lsWithYears :: CmdFunc
lsWithYears years_ _ expL
  | (length $ filter (== []) $ years1) > 0 = Left $ show ParserErrYears
  | (length $ resL) > 0                    = Right resL
  | otherwise                              = Left $ show NoEntries
  where years1 = map (maybeToList . parseYear) years_
        years  = map (!! 0) years1
        resL   = filter (\e -> yearOf e `elem` map yearFrom years) expL

lsWithTags :: CmdFunc
lsWithTags tags_ _ l =
  if (length $ resL) > 0 then Right $ sort resL else Left $ show NoEntries
  where resL = foldl (\a e -> a ++ filterByTag e l) [] tags_

Projects/Personal Expenses Tracker (C)/archive/pet_haskell_master_complete/Commands.hs


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module HtmlReport
  ( htmlReport
  )
where

import           Data.Foldable                  ( traverse_ )
import           Data.Semigroup                 ( (<>) )
import           Data.ByteString.Lazy           ( ByteString )
import           Text.Blaze.Html5              as H
import           Text.Blaze.Html5.Attributes    ( src )
import           Text.Blaze.Html.Renderer.Utf8  ( renderHtml )

import           QuoteData
import           StatReport                     ( showStatEntryValue )
import           Statistics
import           Fmt

htmlReport title quotes si images = renderHtml $ docTypeHtml $ do
  H.head $ do
    H.title $ string title
    H.style style
  body $ do
    renderDiagrams images
    renderStatInfo si
    renderData quotes
 where
  style =
    "table {border-collapse: collapse}"
      <> "td, th {border: 1px solid black; padding: 3px}"
  renderDiagrams [] = pure ()
  renderDiagrams images = do
    h1 "Diagrams"
    traverse_ ((img!).src.toValue) images
  renderStatInfo [] = pure ()
  renderStatInfo si@((_, ses):_) = do
    h1 "Statistics Report"
    table $ do
        thead $ tr $ traverse_ th
              $ "Quotes Field" : [text $ fmt $ build $ stat s | s <- ses]
        tbody $ traverse_ statData2TR si
    statData2TR (qf, entries) = tr $ do
      td $ string $ show qf
      traverse_ (td.string.showStatEntryValue) entries
  renderData quotes = do
      h1 "Stock Quotes Data"
      table $ do
         thead $ tr
               $ traverse_ th ["Day", "Close", "Volume", "Open", "High", "Low"]
         tbody $ traverse_ quoteData2TR quotes
    quoteData2TR QuoteData {..} = tr $ do
      td $ string $ show day
      traverse_ (td.string.show) [close, volume, open, high, low]


{-# LANGUAGE ExistentialQuantification #-}
module LispTypes where

import           Control.Monad.Except
import           Text.ParserCombinators.Parsec
import           Data.Complex
import           Data.Array
import           Data.IORef
import           Text.Printf
import           System.IO

type IOThrowsError = ExceptT LispError IO

type Env = IORef [(String, IORef LispVal)]

data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)

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

instance Eq LispVal where
  (Atom x         ) == (Atom y         ) = x == y
  (List x         ) == (List y         ) = x == y
  (DottedList x x') == (DottedList y y') = x == y && x' == y'
  (Number    x    ) == (Number    y    ) = x == y
  (String    x    ) == (String    y    ) = x == y
  (Bool      x    ) == (Bool      y    ) = x == y
  (Character x    ) == (Character y    ) = x == y
  (Float     x    ) == (Float     y    ) = x == y
  (Ratio     x    ) == (Ratio     y    ) = x == y
  (Complex   x    ) == (Complex   y    ) = x == y
  (Vector    x    ) == (Vector    y    ) = x == y

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

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

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

showError :: LispError -> String
showError (UnboundVar     message  varname) = message ++ ": " ++ varname
showError (BadSpecialForm message  form   ) = message ++ ": " ++ show form
showError (NotFunction    message  func   ) = message ++ ": " ++ show func
showError (NumArgs        expected found  ) = printf
  "Expected %i args; found %i values %s"
  expected
  (length found)
  (unwordsVal found)
showError (TypeMismatch expected found) =
  "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser  parseErr) = "Parse error at " ++ show parseErr
showError (Default s       ) = s

instance Show LispError where
  show = showError

instance Show LispVal where
  show = showVal

type ThrowsError = Either LispError


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Myelin.PyNN.PyNN where

import Prelude hiding (id)

import Control.Monad.Except
import Control.Monad.State.Lazy
import Control.Lens
import Data.Aeson
import Data.List (intercalate)
import qualified Data.Map.Strict as Map
import Data.String.Interpolate
import qualified Data.ByteString.Lazy.Char8 as BS
import Numeric.LinearAlgebra
import Text.Regex as Regex

import Myelin.Model
import Myelin.Neuron
import Myelin.SNN

data PyNNPreample
  = PyNNPreample
    { configuration :: String
    }
    deriving (Eq, Show)

data PyNNModel = PyNNModel
  { _declarations :: [String]
  , _layers :: Map.Map String String -- ^ Layers between the nodes
  , _populations :: Map.Map String String -- ^ Nodes indexed by their Python variables
  }
  deriving (Eq, Show)

makeLenses ''PyNNModel

-- | An empty initial model
emptyPyNNModel :: PyNNModel
emptyPyNNModel = PyNNModel [] Map.empty Map.empty

type PyNNState = ExceptT String (State PyNNModel)

-- | Attempts to translate a network into a Python code string
translate :: Task -> PyNNPreample -> Either String String
translate (Task target network simulationTime) preample =
  let (result, (PyNNModel {..})) = runState (runExceptT $ translate' network) emptyPyNNModel
  in  case result of
        Left translationError -> Left $ "Failed to translate SNN model to Python: " ++ translationError
        Right _ ->
          let populationLines = unlines $ Map.elems _populations
              layerLines = unlines $ Map.elems _layers
              declarationLines = unlines $ _declarations
              preampleLines = pyNNPreample target preample
          in Right $ concat [preampleLines, populationLines, layerLines, declarationLines, training]
    where training = [i|
optimiser = v.GradientDescentOptimiser(0.1, simulation_time=#{simulationTime})
if __name__ == "__main__":
    v.Main(model).train(optimiser)
|]

translate' :: Network -> PyNNState ()
translate' Network {..} = do
  _ <- mapM pyNNNode _inputs
  _ <- mapM pyNNNode _nodes
  outputStrings <- mapM pyNNNode _outputs
  _ <- mapM pyNNEdge _edges
  layers <- fmap _layers get
  let decodeLayer = "l_decode = v.Decode(" ++ populationReference ((last $ _outputs) ^.id) ++ ")"
  let layersString = intercalate ", " $ Map.keys layers
  let model = "model = v.Model(" ++ layersString ++ ", l_decode)"
  declarations <>= [decodeLayer, model]

-- | The Python PyNN preamble for import statements
pyNNPreample :: ExecutionTarget -> PyNNPreample -> String
pyNNPreample target (PyNNPreample {..}) = let
 pyNNTarget =
   case target of
      Nest { .. } -> "nest"
      SpiNNaker -> "spiNNaker"
 in [i|import numpy as np
import volrpynn.#{pyNNTarget} as v
import pyNN.#{pyNNTarget} as pynn

#{configuration}

|]

pyNNNode :: Node -> PyNNState String
pyNNNode node = case node of
  Population {..} -> do
    pyNNPopulation _neuronType _numNeurons _id
  _ -> throwError $ "Unknown node type " ++ (show node)

--   SpikeSourceArray { .. } ->
--  SpikeSourcePoisson { .. } -> do

-- | Statefully encodes a pyNNPopulation, returning the variable name for that
--   population
pyNNPopulation :: NeuronType -> Integer -> Int -> PyNNState String
pyNNPopulation tpe numNeurons id =
  case pyNNPopulationString tpe numNeurons id of
    Right codeString -> populationVariable id codeString
    Left errorString -> throwError errorString

typeRegex = Regex.mkRegex "\"type\":\"\\w*\","

-- | Encodes a PyNN population as a string without state
pyNNPopulationString :: NeuronType -> Integer -> Int -> Either String String
pyNNPopulationString tpe numNeurons id =
  let params = BS.unpack $ encode tpe
      stripType = Regex.subRegex typeRegex params ""
  in  case tpe of
        IFCondExp { .. } -> Right $ "pynn.Population(" ++ (show numNeurons) ++ ", pynn.IF_cond_exp(**" ++ stripType ++ "))"
        _ -> Left $ "Unknown neuron type " ++ (show tpe)

-- | Creates and stores an Edge as a PyNN projection
pyNNEdge :: Edge -> PyNNState String
pyNNEdge projection = do
  (PyNNProjection {..}, inputs, outputs) <- pyNNProjection projection
  let popRef1 = concatReferences inputs
  let popRef2 = concatReferences outputs
  let code = "v." ++ layerType ++ "(" ++ popRef1 ++", " ++ popRef2 ++ (weightString weight) ++ (biasString bias) ++ ")"
  layerVariable code
    where
      concatReferences :: [Node] -> String
      concatReferences nodes =
        case length nodes of
          1 -> populationReference (nodes !! 0 ^. id)
          _ -> let strings = intercalate ", " $ map populationReference $ map (\node -> node ^. id) nodes
               in "(" ++ strings ++ ")"
      weightString (Just weight) =  ", weights=" ++ weight
      weightString Nothing = ""
      biasString (Just bias) = ", biases=" ++ bias
      biasString Nothing = ""

data PyNNProjection = PyNNProjection
  { bias :: Maybe String
  , layerType :: String
  , weight :: Maybe String
  }

-- | Create a PyNN Connector definition
pyNNProjection :: Edge-> PyNNState (PyNNProjection, [Node], [Node])
pyNNProjection (DenseProjection (Static Excitatory (AllToAll bias weight)) nodeIn nodeOut) = do
  b <- pyNNBias bias (_numNeurons nodeOut)
  w <- pyNNWeight weight (_numNeurons nodeIn) (_numNeurons nodeOut)
  return $ (PyNNProjection (Just b) "Dense" (Just w), [nodeIn], [nodeOut])
pyNNProjection (MergeProjection _ (nodeIn1, nodeIn2) nodeOut) = do
  let input1Size = (_numNeurons nodeIn1)
  let input2Size = (_numNeurons nodeIn2)
  return $ input1Size + input2Size
  return $ (PyNNProjection Nothing "Merge" Nothing, [nodeIn1, nodeIn2], [nodeOut])
pyNNProjection (ReplicateProjection (Static Excitatory (AllToAll bias weight)) nodeIn (nodeOut1, nodeOut2)) = do
  let inputSize = _numNeurons nodeIn
  let output1Size = _numNeurons nodeOut1
  let output2Size = _numNeurons nodeOut2
  outputSize <- if (output1Size == output2Size)
    then return $ output1Size
    else throwError $ "Replicaten connections require two outputs of the same size, found " ++ (show (output1Size, output2Size))
  w1 <- pyNNWeight weight inputSize output1Size
  w2 <- pyNNWeight weight inputSize output1Size
  let w = [i|(#{w1}, #{w2})|]
  b <- pyNNBias bias output1Size
  return $ (PyNNProjection (Just b) "Replicate" (Just w), [nodeIn], [nodeOut1, nodeOut2])
pyNNProjection p = throwError $ "Unknown projection effect" ++ (show p)

-- | Converts biases to a Python bias setting
pyNNBias :: Biases -> Integer -> PyNNState String
pyNNBias (BiasGenerator (Constant n)) _ = return (show n)
pyNNBias (BiasGenerator (GaussianRandom mean scale)) toSize
  = return [i|np.random.normal(#{mean}, #{scale}, (#{toSize}))|]
pyNNBias (Biases list) toSize = return [i|np.array(#{show list})|]

-- | Converts weights to a PyNN weight setting
pyNNWeight :: Weights -> Integer -> Integer -> PyNNState String
pyNNWeight (WeightGenerator (Constant n)) _ _ = return (show n)
pyNNWeight (WeightGenerator (GaussianRandom mean scale)) fromSize toSize
  = return [i|np.random.normal(#{mean}, #{scale}, (#{fromSize}, #{toSize}))|]
pyNNWeight (Weights matrix) fromSize toSize =
  let (rows, columns) = join bimap toInteger $ size matrix
      str = show $ toLists matrix
  in  if (rows == toSize && columns == fromSize)
      then return [i|np.array(#{str})|]
      else throwError $ [i|Expected sizes (#{toSize},#{fromSize}), but got (#{rows},#{columns})|]

populationReference :: Int -> String
populationReference nodeId = "p" ++ (show nodeId)

populationVariable :: Int -> String -> PyNNState String
populationVariable popId code = do
  let name = "p" ++ (show popId)
  let variable = pythonVariable name code
  populations %= (Map.insert name variable)
  return name

layerVariable :: String -> PyNNState String
layerVariable code = do
  projections <- use layers
  let name = "layer" ++ (show $ Map.size projections)
  let variable = pythonVariable name code
  layers %= (Map.insert name variable)
  return name

pythonVariable :: String -> String -> String
pythonVariable name value = name ++ " = " ++ value


{-# LANGUAGE FlexibleContexts #-}

module Numeric.Trainee.Data.Csv (
	parseCsv, parseCsvFile
	) where

import Prelude.Unicode

import Control.DeepSeq
import Control.Exception (throwIO)
import qualified Data.Vector as V
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Numeric.LinearAlgebra hiding (toList)

import Numeric.Trainee.Types
import Numeric.Trainee.Data.Common

parseCsv ∷ Bool → T.Text → CsvM (Sample (Vector a) (Vector a)) → Either String (Samples (Vector a) (Vector a))
parseCsv header' dat p = mapM (runCsvM p ∘ V.fromList ∘ T.split (≡ ',')) $ V.fromList $ dropHeader $ T.lines dat where
	dropHeader
		| header' = tail
		| otherwise = id

parseCsvFile ∷ Bool → FilePath → CsvM (Sample (Vector a) (Vector a)) → IO (Samples (Vector a) (Vector a))
parseCsvFile header' fpath p = do
	cts ← T.readFile fpath
	case parseCsv header' cts p of
		Left e → throwIO $ userError $ "Error parsing " ++ fpath ++ ": " ++ e
		Right rs → return $!! rs


{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}

#ifdef DEFAULT_SIGNATURES
{-# LANGUAGE DefaultSignatures #-}
#endif

#ifndef MIN_VERSION_base
#define MIN_VERSION_base(x,y,z) 1
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Each
-- Copyright   :  (C) 2012 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module Control.Lens.Each
  ( Each(..)
  ) where

import Control.Applicative
import Control.Lens.Classes
import Control.Lens.Iso
import Control.Lens.Indexed as Lens
import Control.Lens.IndexedTraversal
import Control.Lens.Traversal
import Data.ByteString as StrictB
import Data.ByteString.Lazy as LazyB
import Data.Complex
import Data.Functor.Identity
import Data.Int
import Data.Sequence as Seq
import Data.Text as StrictT
import Data.Text.Lazy as LazyT
import Data.Traversable
import Data.Tree as Tree
import Data.Word
import Data.Map as Map
import Data.IntMap as IntMap
import Data.HashMap.Lazy as HashMap
import Data.Vector as Vector
import Data.Vector.Primitive as Prim
import Data.Vector.Storable as Storable
import Data.Vector.Unboxed as Unboxed
import Data.Array.Unboxed as Unboxed
import Data.Array.IArray as IArray

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

-- | Extract 'each' element of a (potentially monomorphic) container.
--
-- Notably, when applied to a tuple, this generalizes 'Control.Lens.Traversal.both' to arbitrary homogeneous tuples.
--
-- >>> (1,2,3) & each *~ 10
-- (10,20,30)
--
-- It can also be used on monomorphic containers like 'StrictT.Text' or 'StrictB.ByteString'
--
-- >>> over each Char.toUpper ("hello"^.Text.packed)
-- "HELLO"
--
-- 'each' is an indexed traversal, so it can be used to access keys in many containers:
--
-- >>> itoListOf each $ Map.fromList [("hello",2),("world",4)]
-- [("hello",2),("world",4)]
--
-- >>> ("hello","world") & each.each %~ Char.toUpper
-- ("HELLO","WORLD")
class Functor f => Each i f s t a b | s -> i a, t -> i b, s b -> t, t a -> s where
  each :: Indexable i p => IndexedLensLike p f s t a b
#ifdef DEFAULT_SIGNATURES
  default each :: (Indexable Int p, Applicative f, Traversable g, s ~ g a, t ~ g b) => IndexedLensLike p f s t a b
  each = traversed
  {-# INLINE each #-}
#endif

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a) (b,b) a b@
instance (Applicative f, a~a', b~b') => Each Int f (a,a') (b,b') a b where
  each f ~(a,b) = (,) <$> f' (0 :: Int) a <*> f' 1 b
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a) (b,b,b) a b@
instance (Applicative f, a~a2, a~a3, b~b2, b~b3) => Each Int f (a,a2,a3) (b,b2,b3) a b where
  each f ~(a,b,c) = (,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a) (b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, b~b2, b~b3, b~b4) => Each Int f (a,a2,a3,a4) (b,b2,b3,b4) a b where
  each f ~(a,b,c,d) = (,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a) (b,b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, a~a5, b~b2, b~b3, b~b4, b~b5) => Each Int f (a,a2,a3,a4,a5) (b,b2,b3,b4,b5) a b where
  each f ~(a,b,c,d,e) = (,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a) (b,b,b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, b~b2, b~b3, b~b4, b~b5, b~b6) => Each Int f (a,a2,a3,a4,a5,a6) (b,b2,b3,b4,b5,b6) a b where
  each f ~(a,b,c,d,e,g) = (,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a,a) (b,b,b,b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7) => Each Int f (a,a2,a3,a4,a5,a6,a7) (b,b2,b3,b4,b5,b6,b7) a b where
  each f ~(a,b,c,d,e,g,h) = (,,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g <*> f' 6 h
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8) => Each Int f (a,a2,a3,a4,a5,a6,a7,a8) (b,b2,b3,b4,b5,b6,b7,b8) a b where
  each f ~(a,b,c,d,e,g,h,i) = (,,,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g <*> f' 6 h <*> f' 7 i
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' (a,a,a,a,a,a,a,a,a) (b,b,b,b,b,b,b,b,b) a b@
instance (Applicative f, a~a2, a~a3, a~a4, a~a5, a~a6, a~a7, a~a8, a~a9, b~b2, b~b3, b~b4, b~b5, b~b6, b~b7, b~b8, b~b9) => Each Int f (a,a2,a3,a4,a5,a6,a7,a8,a9) (b,b2,b3,b4,b5,b6,b7,b8,b9) a b where
  each f ~(a,b,c,d,e,g,h,i,j) = (,,,,,,,,) <$> f' (0 :: Int) a <*> f' 1 b <*> f' 2 c <*> f' 3 d <*> f' 4 e <*> f' 5 g <*> f' 6 h <*> f' 7 i <*> f' 8 j
    where f' = Lens.indexed f
  {-# INLINE each #-}

#if MIN_VERSION_base(4,4,0)
-- | @'each' :: ('RealFloat' a, 'RealFloat' b) => 'IndexedTraversal' 'Int' ('Complex' a) ('Complex' b) a b@
instance (Applicative f, RealFloat a, RealFloat b) => Each Int f (Complex a) (Complex b) a b where
  each f (a :+ b) = (:+) <$> f' (0 :: Int) a <*> f' 1 b
    where f' = Lens.indexed f
  {-# INLINE each #-}
#else
-- | @'each' :: 'IndexedTraversal' 'Int' ('Complex' a) ('Complex' b) a b@
instance Applicative f => Each Int f (Complex a) (Complex b) a b where
  each f (a :+ b) = (:+) <$> f' (0 :: Int) a <*> f' (1 :: Int) b
    where f' = Lens.indexed f
  {-# INLINE each #-}
#endif

-- | @'each' :: 'IndexedTraversal' c ('Map' c a) ('Map' c b) a b@
instance Applicative f => Each c f (Map c a) (Map c b) a b where
  each f m = sequenceA $ Map.mapWithKey f' m
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Map' c a) ('Map' c b) a b@
instance Applicative f => Each Int f (IntMap a) (IntMap b) a b where
  each f m = sequenceA $ IntMap.mapWithKey f' m
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' c ('HashMap' c a) ('HashMap' c b) a b@
instance Applicative f => Each c f (HashMap c a) (HashMap c b) a b where
  each = HashMap.traverseWithKey . Lens.indexed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' [a] [b] a b@
instance Applicative f => Each Int f [a] [b] a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Identity' a) ('Identity' b) a b@
instance Applicative f => Each Int f (Identity a) (Identity b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Maybe' a) ('Maybe' b) a b@
instance Applicative f => Each Int f (Maybe a) (Maybe b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Seq' a) ('Seq' b) a b@
instance Applicative f => Each Int f (Seq a) (Seq b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Tree' a) ('Tree' b) a b@
instance Applicative f => Each Int f (Tree a) (Tree b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' ('Vector.Vector' a) ('Vector.Vector' b) a b@
instance Applicative f => Each Int f (Vector.Vector a) (Vector.Vector b) a b where
  each = traversed
  {-# INLINE each #-}

-- | @'each' :: ('Prim' a, 'Prim' b) => 'IndexedTraversal' 'Int' ('Prim.Vector' a) ('Prim.Vector' b) a b@
instance (Applicative f, Prim a, Prim b) => Each Int f (Prim.Vector a) (Prim.Vector b) a b where
  each f v = Prim.fromListN (Prim.length v) <$> withIndex traversed f' (Prim.toList v)
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: ('Storable' a, 'Storable' b) => 'IndexedTraversal' 'Int' ('Storable.Vector' a) ('Storable.Vector' b) a b@
instance (Applicative f, Storable a, Storable b) => Each Int f (Storable.Vector a) (Storable.Vector b) a b where
  each f v = Storable.fromListN (Storable.length v) <$> withIndex traversed f' (Storable.toList v)
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: ('Unbox' a, 'Unbox' b) => 'IndexedTraversal' 'Int' ('Unboxed.Vector' a) ('Unboxed.Vector' b) a b@
instance (Applicative f, Unbox a, Unbox b) => Each Int f (Unboxed.Vector a) (Unboxed.Vector b) a b where
  each f v = Unboxed.fromListN (Unboxed.length v) <$> withIndex traversed f' (Unboxed.toList v)
    where f' = Lens.indexed f
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' 'StrictT.Text' 'StrictT.Text' 'Char' 'Char'@
instance Applicative f =>  Each Int f StrictT.Text StrictT.Text Char Char where
  each = iso StrictT.unpack StrictT.pack . traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int64' 'LazyT.Text' 'LazyT.Text' 'Char' 'Char'@
instance Applicative f => Each Int64 f LazyT.Text LazyT.Text Char Char where
  each = iso LazyT.unpack LazyT.pack . traversed64
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int' 'StrictB.ByteString' 'StrictB.ByteString' 'Char' 'Char'@
instance Applicative f => Each Int f StrictB.ByteString StrictB.ByteString Word8 Word8 where
  each = iso StrictB.unpack StrictB.pack . traversed
  {-# INLINE each #-}

-- | @'each' :: 'IndexedTraversal' 'Int64' 'LazyB.ByteString' 'LazyB.ByteString' 'Char' 'Char'@
instance Applicative f => Each Int64 f LazyB.ByteString LazyB.ByteString Word8 Word8 where
  each = iso LazyB.unpack LazyB.pack . traversed64
  {-# INLINE each #-}

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

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

-- | @'each' :: 'Control.Lens.IndexedSetter.IndexedSetter' i (i -> a) (i -> b) a b@
instance Settable f => Each i f (i -> a) (i -> b) a b where
  each f g = pure (\i -> untaintedDot (Lens.indexed f i) (g i))
  {-# INLINE each #-}


module Scheme.Data
  ( LispVal(..)
  , LispError(..)
  , showVal
  , ThrowsError
  , extractValue
  , trapError
  ) where

import Control.Monad.Error
import Data.Array
import Data.Complex (Complex(..))
import Text.ParserCombinators.Parsec hiding (spaces)

data LispVal
  = Atom String
  | List [LispVal]
  | DottedList [LispVal]
               LispVal
  | Number Integer
  | Ratio Rational
  | Float Double
  | Complex (Complex Double)
  | String String
  | Char Char
  | Bool Bool
  | Vector (Array Int LispVal)

instance Show LispVal where
  show = showVal

showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) =
  "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"

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

showError :: LispError -> String
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
showError (NumArgs expected found) =
  "Expected " ++ show expected ++ " args; found values " ++ unwordsList found
showError (TypeMismatch expected found) =
  "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr

instance Show LispError where
  show = showError

instance Error LispError where
  noMsg = Default "An error has occurred"
  strMsg = Default

type ThrowsError = Either LispError

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

trapError action = catchError action (return . show)

extractValue :: ThrowsError a -> a
extractValue (Right val) = val


{-# LANGUAGE Trustworthy #-}
-- |
-- Module      : Criterion.Monad
-- Copyright   : (c) 2009 Neil Brown
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- The environment in which most criterion code executes.
module Criterion.Monad
    (
      Criterion
    , withConfig
    , getGen
    , getOverhead
    ) where

import Control.Monad.Reader (asks, runReaderT)
import Control.Monad.Trans (liftIO)
import Control.Monad (when)
import Criterion.Measurement (measure, runBenchmark, secs)
import Criterion.Monad.Internal (Criterion(..), Crit(..))
import Criterion.Types hiding (measure)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Statistics.Regression (olsRegress)
import System.Random.MWC (GenIO, createSystemRandom)
import qualified Data.Vector.Generic as G

-- | Run a 'Criterion' action with the given 'Config'.
withConfig :: Config -> Criterion a -> IO a
withConfig cfg (Criterion act) = do
  g <- newIORef Nothing
  o <- newIORef Nothing
  runReaderT act (Crit cfg g o)

-- | Return a random number generator, creating one if necessary.
--
-- This is not currently thread-safe, but in a harmless way (we might
-- call 'createSystemRandom' more than once if multiple threads race).
getGen :: Criterion GenIO
getGen = memoise gen createSystemRandom

-- | Return an estimate of the measurement overhead.
getOverhead :: Criterion Double
getOverhead = do
  verbose <- asks ((== Verbose) . verbosity)
  memoise overhead $ do
    (meas,_) <- runBenchmark (whnfIO $ measure (whnfIO $ return ()) 1) 1
    let metric get = G.convert . G.map get $ meas
    let o = G.head . fst $
            olsRegress [metric (fromIntegral . measIters)] (metric measTime)
    when verbose . liftIO $
      putStrLn $ "measurement overhead " ++ secs o
    return o

-- | Memoise the result of an 'IO' action.
--
-- This is not currently thread-safe, but hopefully in a harmless way.
-- We might call the given action more than once if multiple threads
-- race, so our caller's job is to write actions that can be run
-- multiple times safely.
memoise :: (Crit -> IORef (Maybe a)) -> IO a -> Criterion a
memoise ref generate = do
  r <- Criterion $ asks ref
  liftIO $ do
    mv <- readIORef r
    case mv of
      Just rv -> return rv
      Nothing -> do
        rv <- generate
        writeIORef r (Just rv)
        return rv


{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Storage where

import qualified Data.ByteString.Lazy as BL
import Data.Csv
import qualified Data.Vector as V
import Data.Maybe
import GHC.Stack (HasCallStack)
import Data.Time.Clock
import Data.String.Utils (strip)

import Statistics.Sample

import Types

saveTiming :: Configuration -> RunInfo -> IO ()
saveTiming conf info =
  let scaleFactor = 1000
  in appendFile (storage conf)
    (show (round ((riTime info) * scaleFactor)::Int) ++ ", " ++ riCommand info ++ "\n")

-- | Load all runs; this may become expensive.
loadTiming :: Configuration -> IO [RunInfo]
loadTiming conf = do
  csvData <- BL.readFile (storage conf)
  case decode NoHeader csvData of
    Left err -> error (unlines [ "Could not decode storage."
                               , "  storage: "++storage conf
                               , "  error: "++err
                               ])
    Right v -> return $ V.toList ((\(time::NominalDiffTime, cmd :: String) -> RunInfo (strip cmd) time) <$> v)

instance FromField NominalDiffTime where
  parseField s = do
    count <- parseField s :: Parser Int
    pure (fromRational $ (toRational count) / 1000)

timesForCommand :: String -> [RunInfo] -> [NominalDiffTime]
timesForCommand cmd xs = mapMaybe maybeTime xs
  where
    maybeTime :: RunInfo -> Maybe NominalDiffTime
    maybeTime (RunInfo c t) | (strip c) == (strip cmd) = Just t
                            | otherwise = Nothing

statsForCommand :: HasCallStack => [NominalDiffTime] -> Stats
statsForCommand times =
  let realTimes :: [Double]
      realTimes = realToFrac <$> times
  in Stats
  { stCount = length times
  , stMax = maximum times
  , stMin = minimum times
  , stMean = mean $ V.fromList realTimes
  , stStdDev = stdDev $ V.fromList realTimes
  }


{-# LANGUAGE CPP               #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Marshal a limited subset of J arrays into Repa arrays.
--
-- = Tutorial
--
-- Suppose we wish to perform linear regression. In J we could do:
--
-- @
-- xs := 1 2 3
-- ys := 2 4 6
--
-- reg_result =: ys %. xs ^/ i.2
-- @
--
-- To do this with Haskell data:
--
-- @
-- do
--    jenv <- 'jinit' 'libLinux'
--
--    let hsArr0 = R.fromListUnboxed (R.ix1 3) [1.0,2.0,3.0]
--        hsArr1 = R.fromListUnboxed (R.ix1 3) [2.0,4.0,6.0]
--        jArr0 = 'JDoubleArr' $ R.copyS $ R.map (realToFrac :: Double -> CDouble) hsArr0
--        jArr1 = 'JDoubleArr' $ R.copyS $ R.map (realToFrac :: Double -> CDouble) hsArr1
--
--    'setJData' jenv "xs" jArr0
--    'setJData' jenv "ys" jArr1
--
--    'bsDispatch' jenv "reg_result =: ys %. xs ^/ i.2"
--
--    'JDoubleArr' res <- 'getJData' jenv "reg_result"
--    R.toList res
-- @
--
-- There are three steps to do the calculation, plus one to get a J environment.
--
--     (1) Use 'jinit' with the appropriate file path for your platform
--
--     2. Marshal Haskell values and send them to the J environment. To do so, we
--     use 'setJData', which takes a 'JData' containing a repa array or
--     a string.
--
--     3. Perform calculations within the J environment. Here, we use
--     'bsDispatch' to compute some results and assign them within J
--
--     4. Marshal J values back to Haskell. We use 'getJData'.
--
--
--  Since marshaling data between J and Haskell is expensive, it's best to do as
--  much computation as possible in J.
--
--  == Loading Profile
--
--  If you would like to use user libraries, you need to use 'jLoad' on the
--  'JEnv'. As an example:
--
--  @
--  do
--      jenv <- 'jinit' 'libLinux'
--      'jLoad' jenv ('linuxProfile' "9.02")
--      'bsDispatch' 'jenv' "load'tables/csv'"
--  @
--
--  This will load the CSV addon, assuming it is installed.
--
--  = FFI
--
--  If you want to marshal data yourself, say to use a @Vector@, look at 'JEnv'.
module Language.J ( -- * Environment
                    JEnv (..)
                  , jinit
                  , jLoad
                  , Profile (..)
                  , linuxProfile
                  , macProfile
                  , windowsProfile
#ifndef mingw32_HOST_OS
                  , libLinux
                  , libMac
                  , profLinux
#else
                  , libWindows
#endif
                  , bsDispatch
                  , bsOut
                  , JVersion
                  -- * Repa
                  , JData (..)
                  , getJData
                  , setJData
                  -- * Exceptions
                  , JErr (..)
                  -- * Vector helpers
                  , tryIntVect
                  , copyIntVect
                  -- * FFI
                  , J
                  , JDoType
                  , JGetMType
                  , JGetRType
                  , JSetAType
                  ) where

import           Control.Applicative             (pure, (<$>), (<*>))
import           Control.Exception               (Exception, throw)
import qualified Data.Array.Repa                 as R
import qualified Data.Array.Repa.Repr.ForeignPtr as RF
import qualified Data.ByteString                 as BS
import qualified Data.ByteString.Char8           as ASCII
import qualified Data.ByteString.Internal        as BS
import           Data.Complex                    (Complex (..))
import           Data.Functor                    (void)
import           Data.Semigroup                  ((<>))
import qualified Data.Vector.Unboxed             as V
import           Foreign.C.String                (CString)
import           Foreign.C.Types                 (CChar, CDouble, CInt (..), CLLong (..))
import           Foreign.ForeignPtr              (ForeignPtr, castForeignPtr, mallocForeignPtrBytes, withForeignPtr)
import           Foreign.Marshal                 (alloca, copyArray, mallocBytes, peekArray, pokeArray)
import           Foreign.Ptr                     (FunPtr, Ptr, castPtrToFunPtr, plusPtr)
import           Foreign.Storable                (Storable, peek, pokeByteOff, sizeOf)
import           System.Info                     (arch)
#ifndef mingw32_HOST_OS
import           System.Posix.ByteString         (RTLDFlags (RTLD_LAZY), RawFilePath, dlopen, dlsym)
#else
import           System.Win32.DLL                (getProcAddress, loadLibrary)
#endif

-- Upstream reference
-- https://github.com/jsoftware/stats_jserver4r/blob/4c94fc6df351fab34791aa9d78d158eaefd33b17/source/lib/j2r.c
-- https://github.com/jsoftware/stats_jserver4r/blob/4c94fc6df351fab34791aa9d78d158eaefd33b17/source/lib/r2j.c

-- | Abstract context
data J

data JEnv = JEnv { context   :: Ptr J
                 , evaluator :: JDoType
                 , reader    :: JGetMType
                 , out       :: JGetRType
                 , setter    :: JSetAType
                 }

type JDoType = Ptr J -> CString -> IO CInt
type JGetMType = Ptr J -> CString -> Ptr CLLong -> Ptr CLLong -> Ptr (Ptr CLLong) -> Ptr (Ptr CChar) -> IO CInt
type JGetRType = Ptr J -> IO CString
type JSetAType = Ptr J -> CLLong -> CString -> CLLong -> Ptr () -> IO CInt

foreign import ccall "dynamic" mkJDo :: FunPtr JDoType -> JDoType
foreign import ccall "dynamic" mkJInit :: FunPtr (IO (Ptr J)) -> IO (Ptr J)
foreign import ccall "dynamic" mkJGetM :: FunPtr JGetMType -> JGetMType
foreign import ccall "dynamic" mkJGetR :: FunPtr JGetRType -> JGetRType
foreign import ccall "dynamic" mkJSetA :: FunPtr JSetAType -> JSetAType

type JVersion = [Int]

squashVersion :: JVersion -> String
squashVersion = concatMap show

squashVersionBS :: JVersion -> BS.ByteString
squashVersionBS = ASCII.pack . squashVersion

#ifndef mingw32_HOST_OS
-- | Expected 'RawFilePath' to the library on a Linux machine.
libLinux :: RawFilePath
libLinux = "/usr/lib/" <> ASCII.pack arch <> "-linux-gnu/libj.so"

-- | Expected 'RawFilePath' to the library on Mac.
libMac :: JVersion -> RawFilePath
libMac v = "/Applications/j64-" <> squashVersionBS v <> "/bin/libj.dylib"
#else
-- | @since 0.1.1.0
libWindows :: JVersion -> FilePath
libWindows v = "C:\\Program Files\\J" <> squashVersion v <> "\\bin\\j.dll"
#endif

profLinux :: BS.ByteString -> BS.ByteString
profLinux v = "/etc/j/" <> v <> "/profile.ijs"

binpathLinux :: BS.ByteString
binpathLinux = "/usr/bin"

dllLinux :: BS.ByteString -> BS.ByteString
dllLinux v = "libj.so." <> v

-- | @since 0.1.2.0
linuxProfile :: BS.ByteString -- ^ J version, e.g. @"9.02"@
             -> Profile
linuxProfile ver = Profile (profLinux ver) binpathLinux (dllLinux ver)

-- | @since 0.1.2.0
macProfile :: JVersion
           -> Profile
macProfile v =
    let binPathMac = "/Applications/j64-" <> squashVersionBS v <> "/bin"
        in Profile (binPathMac <> "/profile.ijs") binPathMac (binPathMac <> "/libj.dylib")

-- | @since 0.1.2.0
windowsProfile :: JVersion
               -> Profile
windowsProfile v =
    let binPathWindows = "C:\\Program Files\\J" <> squashVersionBS v <> "\\bin"
        in Profile (binPathWindows <> "\\profile.ijs") binPathWindows (binPathWindows <> "j.dll")

-- | @since 0.1.2.0
data Profile = Profile { profPath :: BS.ByteString -- ^ @profile.ijs@
                       , binPath  :: BS.ByteString
                       , dllName  :: BS.ByteString
                       }

-- | Load user profile.
--
-- @since 0.1.2.0@
jLoad :: JEnv
      -> Profile
      -> IO ()
jLoad jenv (Profile fp bin dll) = bsDispatch jenv ("(3 : '0!:0 y')<'"<> fp <> "'[BINPATH_z_=:'" <> bin <> "'[LIBFILE_z_=:'" <> dll <> "'[ARGV_z_=:''")

-- | Get a J environment
--
-- Passing the resultant 'JEnv' between threads can cause unexpected bugs.
#ifndef mingw32_HOST_OS
jinit :: RawFilePath -- ^ Path to J library
      -> IO JEnv
jinit libFp = do
    libj <- dlopen libFp [RTLD_LAZY]
    jt <- mkJInit =<< dlsym libj "JInit"
    let jeval = mkJDo <$> dlsym libj "JDo"
    let jread = mkJGetM <$> dlsym libj "JGetM"
    let jOut = mkJGetR <$> dlsym libj "JGetR"
    let jSet = mkJSetA <$> dlsym libj "JSetA"
    JEnv jt <$> jeval <*> jread <*> jOut <*> jSet
#else
jinit :: FilePath
      -> IO JEnv
jinit libFp = do
    libj <- loadLibrary libFp
    jt <- mkJInit . castPtrToFunPtr =<< getProcAddress libj "JInit"
    let jeval = mkJDo . castPtrToFunPtr <$> getProcAddress libj "JDo"
    let jread = mkJGetM . castPtrToFunPtr <$> getProcAddress libj "JGetM"
    let jOut = mkJGetR . castPtrToFunPtr <$> getProcAddress libj "JGetR"
    let jSet = mkJSetA . castPtrToFunPtr <$> getProcAddress libj "JSetA"
    JEnv jt <$> jeval <*> jread <*> jOut <*> jSet
#endif

-- | Send some J code to the environment.
bsDispatch :: JEnv -> BS.ByteString -> IO ()
bsDispatch (JEnv ctx jdo _ _ _) bs =
    void $ BS.useAsCString bs $ jdo ctx

-- | Read last output
--
-- For debugging
bsOut :: JEnv -> IO BS.ByteString
bsOut (JEnv ctx _ _ jout _) = BS.packCString =<< jout ctx

-- | \( O(n) \) in the array size
--
-- Throws 'JErr' for unspported conversion types.
getJData :: R.Shape sh
         => JEnv -> BS.ByteString -- ^ Name of the value in question
         -> IO (JData sh)
getJData jenv bs = jData <$> getAtomInternal jenv bs

getAtomInternal :: JEnv -> BS.ByteString -- ^ Name of the value in question
                -> IO JAtom
getAtomInternal (JEnv ctx _ jget _ _) bs = do
    BS.useAsCString bs $ \name ->
        alloca $ \t ->
        alloca $ \s ->
        alloca $ \r ->
        alloca $ \d -> do
            jget ctx name t r s d
            ty' <- intToJType <$> peek t
            rank' <- peek r
            let intRank = fromIntegral rank'
            shape' <- peekArray intRank =<< peek s
            let mult = jTypeWidth ty'
            let resBytes = mult * intRank
            res <- mallocForeignPtrBytes resBytes
            let arrSz = mult * fromIntegral (product shape')
            withForeignPtr res $ \r' -> do
                d' <- peek d
                copyArray r' d' arrSz
            pure $ JAtom ty' shape' res

data JAtom = JAtom !JType ![CLLong] !(ForeignPtr CChar)

-- | J data backed by repa array
data JData sh = JIntArr !(R.Array RF.F sh CLLong)
              | JDoubleArr !(R.Array RF.F sh CDouble)
              | JComplexArr !(R.Array RF.F sh (Complex CDouble))
              | JBoolArr !(R.Array RF.F sh CChar)
              | JString !BS.ByteString

data JErr = TypeError
          | UnsupportedType
          deriving (Show, Exception)

-- | Copy into a 'V.Vector' 'Int', if possible.
--
-- Throws a 'JErr' on type error.
--
-- \( O(n) \)
--
-- @since 0.2.2.0
tryIntVect :: JData R.DIM1 -> V.Vector Int
tryIntVect (JIntArr arr) = R.toUnboxed (R.copyS $ R.map fromIntegral arr)
tryIntVect _             = throw TypeError

-- | \( O(n) \)
--
-- @since 0.2.2.0
copyIntVect :: V.Vector Int -> JData R.DIM1
copyIntVect = JIntArr . R.copyS . R.map fromIntegral . (\v -> R.fromUnboxed (R.ix1 $ V.length v) v)

-- | \( O(n) \) in the array size
setJData :: (R.Shape sh) => JEnv -> BS.ByteString -- ^ Name
                         -> JData sh -> IO CInt
setJData (JEnv ctx _ _ _ jset) name (JIntArr iarr) = BS.useAsCStringLen name $ \(n, sz) -> do
    (ds, d) <- repaArr JInteger iarr
    jset ctx (fromIntegral sz) n ds d
setJData (JEnv ctx _ _ _ jset) name (JDoubleArr iarr) = BS.useAsCStringLen name $ \(n, sz) -> do
    (ds, d) <- repaArr JDouble iarr
    jset ctx (fromIntegral sz) n ds d
setJData (JEnv ctx _ _ _ jset) name (JComplexArr iarr) = BS.useAsCStringLen name $ \(n, sz) -> do
    (ds, d) <- repaArr JComplex iarr
    jset ctx (fromIntegral sz) n ds d
setJData (JEnv ctx _ _ _ jset) name (JBoolArr iarr) = BS.useAsCStringLen name $ \(n, sz) -> do
    (ds, d) <- repaArr JBool iarr
    jset ctx (fromIntegral sz) n ds d
setJData (JEnv ctx _ _ _ jset) name (JString bs) = BS.useAsCStringLen name $ \(n, sz) -> do
    (ds, d) <- strArr bs
    jset ctx (fromIntegral sz) n ds d

-- | Return a @'Ptr' ()@ suitable to be passed to @JSetA@
--
-- To be used on integer, double, and complex arrays
repaArr :: (R.Shape sh, Storable e) => JType -> R.Array RF.F sh e -> IO (CLLong, Ptr ())
repaArr jty arr = do
    let (rank', sh) = repaSize arr
        sz = product sh
    let wid = 32 + fromIntegral (jTypeWidth jty) * (rank' + sz)
    ptr <- mallocBytes (fromIntegral wid)
    pokeByteOff ptr 0 (227 :: CLLong) -- I think this is because it's non-boxed
    pokeByteOff ptr (sizeOf (undefined :: CLLong)) (jTypeToInt jty)
    pokeByteOff ptr (2 * sizeOf (undefined :: CLLong)) sz
    pokeByteOff ptr (3 * sizeOf (undefined :: CLLong)) rank'
    let dimOff = 4 * sizeOf (undefined :: CLLong)
    pokeArray (ptr `plusPtr` dimOff) sh
    let dataOff = dimOff + fromIntegral rank' * sizeOf (undefined :: CLLong)
    withForeignPtr (RF.toForeignPtr arr) $ \src ->
        copyArray (ptr `plusPtr` dataOff) src (fromIntegral sz)
    pure (wid, ptr)

strArr :: BS.ByteString -> IO (CLLong, Ptr ())
strArr bs = do
    let len = BS.length bs
        wid = 40 + 8 * (1 + len `div` 8)
        len' = fromIntegral len :: CLLong
    ptr <- mallocBytes wid
    pokeByteOff ptr 0 (227 :: CLLong)
    pokeByteOff ptr (sizeOf (undefined :: CLLong)) (jTypeToInt JChar)
    pokeByteOff ptr (2 * sizeOf (undefined :: CLLong)) len'
    pokeByteOff ptr (3 * sizeOf (undefined :: CLLong)) (1 :: CLLong)
    pokeByteOff ptr (4 * sizeOf (undefined :: CLLong)) len'
    let dataOff = 5 * sizeOf (undefined :: CLLong)
    BS.useAsCString bs $ \pSrc ->
        copyArray (ptr `plusPtr` dataOff) pSrc len
    pure (fromIntegral wid, ptr)

repaSize :: (R.Source r e, R.Shape sh) => R.Array r sh e -> (CLLong, [CLLong])
repaSize arr = let sh = R.extent arr in (fromIntegral $ R.rank sh, fromIntegral <$> R.listOfShape sh)

-- | J types
data JType = JBool
           | JChar
           | JInteger
           | JDouble
           | JComplex

intToJType :: CLLong -> JType
intToJType 1  = JBool
intToJType 2  = JChar
intToJType 4  = JInteger
intToJType 8  = JDouble
intToJType 16 = JComplex
intToJType _  = throw UnsupportedType

jTypeToInt :: JType -> CLLong
jTypeToInt JBool    = 1
jTypeToInt JChar    = 2
jTypeToInt JInteger = 4
jTypeToInt JDouble  = 8
jTypeToInt JComplex = 16

jTypeWidth :: JType -> Int
jTypeWidth JBool    = sizeOf (undefined :: CChar)
jTypeWidth JChar    = sizeOf (undefined :: CChar)
jTypeWidth JInteger = sizeOf (undefined :: CLLong)
jTypeWidth JDouble  = sizeOf (undefined :: CDouble)
jTypeWidth JComplex = sizeOf (undefined :: Complex CDouble)

jData :: R.Shape sh => JAtom -> JData sh
jData (JAtom JInteger sh fp) = JIntArr $ RF.fromForeignPtr (R.shapeOfList $ fmap fromIntegral sh) (castForeignPtr fp)
jData (JAtom JDouble sh fp)  = JDoubleArr $ RF.fromForeignPtr (R.shapeOfList $ fmap fromIntegral sh) (castForeignPtr fp)
jData (JAtom JComplex sh fp) = JComplexArr $ RF.fromForeignPtr (R.shapeOfList $ fmap fromIntegral sh) (castForeignPtr fp)
jData (JAtom JBool sh fp)    = JBoolArr $ RF.fromForeignPtr (R.shapeOfList $ fmap fromIntegral sh) (castForeignPtr fp)
jData (JAtom JChar [l] fp)   = JString $ BS.fromForeignPtr (castForeignPtr fp) 0 (fromIntegral l)
jData (JAtom JChar _ _)      = error "Not supported."