text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Trustworthy #-}

#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE NoPolyKinds #-}
{-# LANGUAGE NoDataKinds #-}
#endif

-- Disable the warnings generated by 'to', 'ito', 'like', 'ilike'.
-- These functions are intended to produce 'Getters'. Without this constraint
-- users would get warnings when annotating types at uses of these functions.
#if __GLASGOW_HASKELL__ >= 711
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif

#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -Wno-trustworthy-safe #-}
#endif
-------------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Getter
-- Copyright   :  (C) 2012-16 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  Rank2Types
--
--
-- A @'Getter' s a@ is just any function @(s -> a)@, which we've flipped
-- into continuation passing style, @(a -> r) -> s -> r@ and decorated
-- with 'Const' to obtain:
--
-- @type 'Getting' r s a = (a -> 'Const' r a) -> s -> 'Const' r s@
--
-- If we restrict access to knowledge about the type 'r', we could get:
--
-- @type 'Getter' s a = forall r. 'Getting' r s a@
--
-- However, for 'Getter' (but not for 'Getting') we actually permit any
-- functor @f@ which is an instance of both 'Functor' and 'Contravar.Functor':
--
-- @type 'Getter' s a = forall f. ('Contravar.Functor' f, 'Functor' f) => (a -> f a) -> s -> f s@
--
-- Everything you can do with a function, you can do with a 'Getter', but
-- note that because of the continuation passing style ('.') composes them
-- in the opposite order.
--
-- Since it is only a function, every 'Getter' obviously only retrieves a
-- single value for a given input.
--
-- A common question is whether you can combine multiple 'Getter's to
-- retrieve multiple values. Recall that all 'Getter's are 'Fold's and that
-- we have a @'Monoid' m => 'Applicative' ('Const' m)@ instance to play
-- with. Knowing this, we can use @'Data.Monoid.<>'@ to glue 'Fold's
-- together:
--
-- >>> import Data.Monoid
-- >>> (1, 2, 3, 4, 5) ^.. (_2 <> _3 <> _5)
-- [2,3,5]
--
-------------------------------------------------------------------------------
module Control.Lens.Getter
  (
  -- * Getters
    Getter -- , IndexedGetter
  , Getting -- , IndexedGetting
  , Accessing
  -- * Building Getters
  , to
--  , ito
  , like
--  , ilike
  -- * Combinators for Getters and Folds
  , (^.)
  , view, views
  , use, uses
  , listening, listenings
{-
  -- * Indexed Getters
  -- ** Indexed Getter Combinators
  , (^@.)
  , iview, iviews
  , iuse, iuses
  , ilistening, ilistenings
-}
  -- * Implementation Details
  , getting
  , Const(..)
  ) where

import Control.Applicative
--import Control.Lens.Internal.Indexed
import Control.Lens.Type
import Control.Monad.Reader.Class as Reader
import Control.Monad.State        as State
import Control.Monad.Writer       as Writer
import Data.Functor.Contravariant (gmap, phantom)
import qualified Data.Functor.Contravariant as Contravar
import Data.Profunctor
import Data.Profunctor.Unsafe

-- $setup
-- >>> :set -XNoOverloadedStrings
-- >>> import Control.Lens
-- >>> import Data.List.Lens
-- >>> import Debug.SimpleReflect.Expr
-- >>> import Debug.SimpleReflect.Vars as Vars hiding (f,g)
-- >>> let f :: Expr -> Expr; f = Debug.SimpleReflect.Vars.f
-- >>> let g :: Expr -> Expr; g = Debug.SimpleReflect.Vars.g

infixl 8 ^. {- , ^@. -}

-------------------------------------------------------------------------------
-- Getters
-------------------------------------------------------------------------------

-- | Build an (index-preserving) 'Getter' from an arbitrary Haskell function.
--
-- @
-- 'to' f '.' 'to' g ≡ 'to' (g '.' f)
-- @
--
-- @
-- a '^.' 'to' f ≡ f a
-- @
--
-- >>> a ^.to f
-- f a
--
-- >>> ("hello","world")^.to snd
-- "world"
--
-- >>> 5^.to succ
-- 6
--
-- >>> (0, -5)^._2.to abs
-- 5
--
-- @
-- 'to' :: (s -> a) -> 'IndexPreservingGetter' s a
-- @
to :: (Profunctor p, Contravar.Functor f) => (s -> a) -> Optic' p f s a
to k = dimap k (gmap k)
{-# INLINE to #-}

{-
-- |
-- @
-- 'ito' :: (s -> (i, a)) -> 'IndexedGetter' i s a
-- @
ito :: (Indexable i p, Contravar.Functor f) => (s -> (i, a)) -> Over' p f s a
ito k = dimap k (gmap (snd . k)) . uncurry . indexed
{-# INLINE ito #-}
-}

-- | Build an constant-valued (index-preserving) 'Getter' from an arbitrary Haskell value.
--
-- @
-- 'like' a '.' 'like' b ≡ 'like' b
-- a '^.' 'like' b ≡ b
-- a '^.' 'like' b ≡ a '^.' 'to' ('const' b)
-- @
--
-- This can be useful as a second case 'failing' a 'Fold'
-- e.g. @foo `failing` 'like' 0@
--
-- @
-- 'like' :: a -> 'IndexPreservingGetter' s a
-- @
like :: (Profunctor p, Contravar.Functor f, Functor f) => a -> Optic' p f s a
like a = to (const a)
{-# INLINE like #-}

{-
-- |
-- @
-- 'ilike' :: i -> a -> 'IndexedGetter' i s a
-- @
ilike :: (Indexable i p, Contravar.Functor f, Functor f) => i -> a -> Over' p f s a
ilike i a = ito (const (i, a))
{-# INLINE ilike #-}
-}

-- | When you see this in a type signature it indicates that you can
-- pass the function a 'Lens', 'Getter',
-- 'Control.Lens.Traversal.Traversal', 'Control.Lens.Fold.Fold',
-- 'Control.Lens.Prism.Prism', 'Control.Lens.Iso.Iso', or one of
-- the indexed variants, and it will just \"do the right thing\".
--
-- Most 'Getter' combinators are able to be used with both a 'Getter' or a
-- 'Control.Lens.Fold.Fold' in limited situations, to do so, they need to be
-- monomorphic in what we are going to extract with 'Control.Applicative.Const'. To be compatible
-- with 'Lens', 'Control.Lens.Traversal.Traversal' and
-- 'Control.Lens.Iso.Iso' we also restricted choices of the irrelevant @t@ and
-- @b@ parameters.
--
-- If a function accepts a @'Getting' r s a@, then when @r@ is a 'Data.Monoid.Monoid', then
-- you can pass a 'Control.Lens.Fold.Fold' (or
-- 'Control.Lens.Traversal.Traversal'), otherwise you can only pass this a
-- 'Getter' or 'Lens'.
type Getting r s a = (a -> Const r a) -> s -> Const r s

{-
-- | Used to consume an 'Control.Lens.Fold.IndexedFold'.
type IndexedGetting i m s a = Indexed i a (Const m a) -> s -> Const m s
-}

-- | This is a convenient alias used when consuming (indexed) getters and (indexed) folds
-- in a highly general fashion.
type Accessing p m s a = p a (Const m a) -> s -> Const m s

-------------------------------------------------------------------------------
-- Getting Values
-------------------------------------------------------------------------------

-- | View the value pointed to by a 'Getter', 'Control.Lens.Iso.Iso' or
-- 'Lens' or the result of folding over all the results of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- at a monoidal value.
--
-- @
-- 'view' '.' 'to' ≡ 'id'
-- @
--
-- >>> view (to f) a
-- f a
--
-- >>> view _2 (1,"hello")
-- "hello"
--
-- >>> view (to succ) 5
-- 6
--
-- >>> view (_2._1) ("hello",("world","!!!"))
-- "world"
--
--
-- As 'view' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restricted signatures:
--
-- @
-- 'view' ::             'Getter' s a     -> s -> a
-- 'view' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Fold.Fold' s m       -> s -> m
-- 'view' ::             'Control.Lens.Iso.Iso'' s a       -> s -> a
-- 'view' ::             'Lens'' s a      -> s -> a
-- 'view' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Traversal.Traversal'' s m -> s -> m
-- @
--
-- In a more general setting, such as when working with a 'Monad' transformer stack you can use:
--
-- @
-- 'view' :: 'MonadReader' s m             => 'Getter' s a     -> m a
-- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Fold.Fold' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.Lens.Iso.Iso'' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'Lens'' s a      -> m a
-- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.Lens.Traversal.Traversal'' s a -> m a
-- @
view :: MonadReader s m => Getting a s a -> m a
view l = Reader.asks (getConst #. l Const)
{-# INLINE view #-}

-- | View a function of the value pointed to by a 'Getter' or 'Lens' or the result of
-- folding over the result of mapping the targets of a 'Control.Lens.Fold.Fold' or
-- 'Control.Lens.Traversal.Traversal'.
--
-- @
-- 'views' l f ≡ 'view' (l '.' 'to' f)
-- @
--
-- >>> views (to f) g a
-- g (f a)
--
-- >>> views _2 length (1,"hello")
-- 5
--
-- As 'views' is commonly used to access the target of a 'Getter' or obtain a monoidal summary of the targets of a 'Fold',
-- It may be useful to think of it as having one of these more restricted signatures:
--
-- @
-- 'views' ::             'Getter' s a     -> (a -> r) -> s -> r
-- 'views' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Fold.Fold' s a       -> (a -> m) -> s -> m
-- 'views' ::             'Control.Lens.Iso.Iso'' s a       -> (a -> r) -> s -> r
-- 'views' ::             'Lens'' s a      -> (a -> r) -> s -> r
-- 'views' :: 'Data.Monoid.Monoid' m => 'Control.Lens.Traversal.Traversal'' s a -> (a -> m) -> s -> m
-- @
--
-- In a more general setting, such as when working with a 'Monad' transformer stack you can use:
--
-- @
-- 'views' :: 'MonadReader' s m             => 'Getter' s a     -> (a -> r) -> m r
-- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s a       -> (a -> r) -> m r
-- 'views' :: 'MonadReader' s m             => 'Control.Lens.Iso.Iso'' s a       -> (a -> r) -> m r
-- 'views' :: 'MonadReader' s m             => 'Lens'' s a      -> (a -> r) -> m r
-- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> r) -> m r
-- @
--
-- @
-- 'views' :: 'MonadReader' s m => 'Getting' r s a -> (a -> r) -> m r
-- @
views :: MonadReader s m => LensLike' (Const r) s a -> (a -> r) -> m r
views l f = Reader.asks (getConst #. l (Const #. f))
{-# INLINE views #-}

-- | View the value pointed to by a 'Getter' or 'Lens' or the
-- result of folding over all the results of a 'Control.Lens.Fold.Fold' or
-- 'Control.Lens.Traversal.Traversal' that points at a monoidal values.
--
-- This is the same operation as 'view' with the arguments flipped.
--
-- The fixity and semantics are such that subsequent field accesses can be
-- performed with ('Prelude..').
--
-- >>> (a,b)^._2
-- b
--
-- >>> ("hello","world")^._2
-- "world"
--
-- >>> import Data.Complex
-- >>> ((0, 1 :+ 2), 3)^._1._2.to magnitude
-- 2.23606797749979
--
-- @
-- ('^.') ::             s -> 'Getter' s a     -> a
-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.Lens.Fold.Fold' s m       -> m
-- ('^.') ::             s -> 'Control.Lens.Iso.Iso'' s a       -> a
-- ('^.') ::             s -> 'Lens'' s a      -> a
-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.Lens.Traversal.Traversal'' s m -> m
-- @
(^.) :: s -> Getting a s a -> a
s ^. l = getConst (l Const s)
{-# INLINE (^.) #-}

-------------------------------------------------------------------------------
-- MonadState
-------------------------------------------------------------------------------

-- | Use the target of a 'Lens', 'Control.Lens.Iso.Iso', or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that points
-- to a monoidal value.
--
-- >>> evalState (use _1) (a,b)
-- a
--
-- >>> evalState (use _1) ("hello","world")
-- "hello"
--
-- @
-- 'use' :: 'MonadState' s m             => 'Getter' s a     -> m a
-- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s r       -> m r
-- 'use' :: 'MonadState' s m             => 'Control.Lens.Iso.Iso'' s a       -> m a
-- 'use' :: 'MonadState' s m             => 'Lens'' s a      -> m a
-- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s r -> m r
-- @
use :: MonadState s m => Getting a s a -> m a
use l = State.gets (view l)
{-# INLINE use #-}

-- | Use the target of a 'Lens', 'Control.Lens.Iso.Iso' or
-- 'Getter' in the current state, or use a summary of a
-- 'Control.Lens.Fold.Fold' or 'Control.Lens.Traversal.Traversal' that
-- points to a monoidal value.
--
-- >>> evalState (uses _1 length) ("hello","world")
-- 5
--
-- @
-- 'uses' :: 'MonadState' s m             => 'Getter' s a     -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Fold.Fold' s a       -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'Lens'' s a      -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'Control.Lens.Iso.Iso'' s a       -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.Lens.Traversal.Traversal'' s a -> (a -> r) -> m r
-- @
--
-- @
-- 'uses' :: 'MonadState' s m => 'Getting' r s t a b -> (a -> r) -> m r
-- @
uses :: MonadState s m => LensLike' (Const r) s a -> (a -> r) -> m r
uses l f = State.gets (views l f)
{-# INLINE uses #-}

-- | This is a generalized form of 'listen' that only extracts the portion of
-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'listening' :: 'MonadWriter' w m             => 'Getter' w u     -> m a -> m (a, u)
-- 'listening' :: 'MonadWriter' w m             => 'Lens'' w u      -> m a -> m (a, u)
-- 'listening' :: 'MonadWriter' w m             => 'Iso'' w u       -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Fold' w u       -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Traversal'' w u -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'Prism'' w u     -> m a -> m (a, u)
-- @
listening :: MonadWriter w m => Getting u w u -> m a -> m (a, u)
listening l m = do
  (a, w) <- listen m
  return (a, view l w)
{-# INLINE listening #-}

{-
-- | This is a generalized form of 'listen' that only extracts the portion of
-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'ilistening' :: 'MonadWriter' w m             => 'IndexedGetter' i w u     -> m a -> m (a, (i, u))
-- 'ilistening' :: 'MonadWriter' w m             => 'IndexedLens'' i w u      -> m a -> m (a, (i, u))
-- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'IndexedFold' i w u       -> m a -> m (a, (i, u))
-- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'IndexedTraversal'' i w u -> m a -> m (a, (i, u))
-- @
ilistening :: MonadWriter w m => IndexedGetting i (i, u) w u -> m a -> m (a, (i, u))
ilistening l m = do
  (a, w) <- listen m
  return (a, iview l w)
{-# INLINE ilistening #-}
-}

-- | This is a generalized form of 'listen' that only extracts the portion of
-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'listenings' :: 'MonadWriter' w m             => 'Getter' w u     -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: 'MonadWriter' w m             => 'Lens'' w u      -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: 'MonadWriter' w m             => 'Iso'' w u       -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Fold' w u       -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Traversal'' w u -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'Prism'' w u     -> (u -> v) -> m a -> m (a, v)
-- @
listenings :: MonadWriter w m => Getting v w u -> (u -> v) -> m a -> m (a, v)
listenings l uv m = do
  (a, w) <- listen m
  return (a, views l uv w)
{-# INLINE listenings #-}

{-
-- | This is a generalized form of 'listen' that only extracts the portion of
-- the log that is focused on by a 'Getter'. If given a 'Fold' or a 'Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'ilistenings' :: 'MonadWriter' w m             => 'IndexedGetter' w u     -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: 'MonadWriter' w m             => 'IndexedLens'' w u      -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'IndexedFold' w u       -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'IndexedTraversal'' w u -> (i -> u -> v) -> m a -> m (a, v)
-- @
ilistenings :: MonadWriter w m => IndexedGetting i v w u -> (i -> u -> v) -> m a -> m (a, v)
ilistenings l iuv m = do
  (a, w) <- listen m
  return (a, iviews l iuv w)
{-# INLINE ilistenings #-}
-}

------------------------------------------------------------------------------
-- Indexed Getters
------------------------------------------------------------------------------

{-
-- | View the index and value of an 'IndexedGetter' into the current environment as a pair.
--
-- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of
-- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted.
iview :: MonadReader s m => IndexedGetting i (i,a) s a -> m (i,a)
iview l = asks (getConst #. l (Indexed $ \i -> Const #. (,) i))
{-# INLINE iview #-}

-- | View a function of the index and value of an 'IndexedGetter' into the current environment.
--
-- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer.
--
-- @
-- 'iviews' ≡ 'Control.Lens.Fold.ifoldMapOf'
-- @
iviews :: MonadReader s m => IndexedGetting i r s a -> (i -> a -> r) -> m r
iviews l f = asks (getConst #. l (Const #. Indexed f))
{-# INLINE iviews #-}

-- | Use the index and value of an 'IndexedGetter' into the current state as a pair.
--
-- When applied to an 'IndexedFold' the result will most likely be a nonsensical monoidal summary of
-- the indices tupled with a monoidal summary of the values and probably not whatever it is you wanted.
iuse :: MonadState s m => IndexedGetting i (i,a) s a -> m (i,a)
iuse l = gets (getConst #. l (Indexed $ \i -> Const #. (,) i))
{-# INLINE iuse #-}

-- | Use a function of the index and value of an 'IndexedGetter' into the current state.
--
-- When applied to an 'IndexedFold' the result will be a monoidal summary instead of a single answer.
iuses :: MonadState s m => IndexedGetting i r s a -> (i -> a -> r) -> m r
iuses l f = gets (getConst #. l (Const #. Indexed f))
{-# INLINE iuses #-}

-- | View the index and value of an 'IndexedGetter' or 'IndexedLens'.
--
-- This is the same operation as 'iview' with the arguments flipped.
--
-- The fixity and semantics are such that subsequent field accesses can be
-- performed with ('Prelude..').
--
-- @
-- ('^@.') :: s -> 'IndexedGetter' i s a -> (i, a)
-- ('^@.') :: s -> 'IndexedLens'' i s a  -> (i, a)
-- @
--
-- The result probably doesn't have much meaning when applied to an 'IndexedFold'.
(^@.) :: s -> IndexedGetting i (i, a) s a -> (i, a)
s ^@. l = getConst $ l (Indexed $ \i -> Const #. (,) i) s
{-# INLINE (^@.) #-}
-}

-- | Coerce a 'Getter'-compatible 'Optical' to an 'Optical''. This
-- is useful when using a 'Traversal' that is not simple as a 'Getter' or a
-- 'Fold'.
--
-- @
-- 'getting' :: 'Traversal' s t a b          -> 'Fold' s a
-- 'getting' :: 'Lens' s t a b               -> 'Getter' s a
-- 'getting' :: 'IndexedTraversal' i s t a b -> 'IndexedFold' i s a
-- 'getting' :: 'IndexedLens' i s t a b      -> 'IndexedGetter' i s a
-- @
getting :: (Profunctor p, Profunctor q, Functor f, Contravar.Functor f)
        => Optical p q f s t a b -> Optical' p q f s a
getting l f = rmap phantom . l $ rmap phantom f


text:
{-# LANGUAGE ConstraintKinds, PolyKinds, TypeFamilies #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}

module CFunctor where

import Generics.SOP.Constraint
import Numeric.LinearAlgebra hiding (C)

class CFunctor f where
  type C f :: * -> Constraint
  cfmap :: (C f a, C f b) => (a -> b) -> f a -> f b

{-
instance {-# OVERLAPPABLE #-} Functor f => CFunctor f where
  type C f = Top
  cfmap = fmap
-}

instance CFunctor Vector where
  type C Vector = And Element (Container Vector)
  cfmap = cmap

ext: hs


text:
{-# LANGUAGE DataKinds, TypeFamilies #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
-- | Matrix-based (meaning that dual numbers for gradient computation
-- consider matrices, not scalars, as the primitive differentiable type)
-- implementation of fully connected neutral network for classification
-- of MNIST digits. Sports 2 hidden layers.
module HordeAd.Tool.MnistFcnnMatrix where

import Prelude

import           Control.Exception (assert)
import qualified Data.Array.DynamicS as OT
import qualified Data.Vector.Generic as V
import           GHC.Exts (inline)
import           Numeric.LinearAlgebra (Vector)

import HordeAd.Core.DualNumber
import HordeAd.Core.Engine
import HordeAd.Core.PairOfVectors (DualNumberVariables, var1, var2)
import HordeAd.Tool.MnistData

fcnnMnistLen2 :: Int -> Int -> (Int, [Int], [(Int, Int)], [OT.ShapeL])
fcnnMnistLen2 widthHidden widthHidden2 =
  ( 0
  , [widthHidden, widthHidden2, sizeMnistLabel]
  , [ (widthHidden, sizeMnistGlyph)
    , (widthHidden2, widthHidden)
    , (sizeMnistLabel, widthHidden2) ]
  , []
  )

-- | Fully connected neural network for the MNIST digit classification task.
-- There are two hidden layers and both use the same activation function.
-- The output layer uses a different activation function.
-- The width of the layers is determined by the dimensions of the matrices
-- and vectors given as dual number parameters (variables).
-- The dimensions, in turn, can be computed by the @len*@ functions
-- on the basis of the requested widths, see above.
fcnnMnist2 :: forall d r m. DualMonad d r m
           => (DualNumber d (Vector r) -> m (DualNumber d (Vector r)))
           -> (DualNumber d (Vector r) -> m (DualNumber d (Vector r)))
           -> Vector r
           -> DualNumberVariables d r
           -> m (DualNumber d (Vector r))
fcnnMnist2 factivationHidden factivationOutput input variables = do
  let !_A = assert (sizeMnistGlyph == V.length input) ()
      weightsL0 = var2 variables 0
      biasesV0 = var1 variables 0
      weightsL1 = var2 variables 1
      biasesV1 = var1 variables 1
      weightsL2 = var2 variables 2
      biasesV2 = var1 variables 2
  let hiddenLayer1 = weightsL0 #>!! input + biasesV0
  nonlinearLayer1 <- factivationHidden hiddenLayer1
  let hiddenLayer2 = weightsL1 #>! nonlinearLayer1 + biasesV1
  nonlinearLayer2 <- factivationHidden hiddenLayer2
  let outputLayer = weightsL2 #>! nonlinearLayer2 + biasesV2
  factivationOutput outputLayer

-- | The neural network applied to concrete activation functions
-- and composed with the appropriate loss function.
fcnnMnistLoss2
  :: DualMonad d r m
  => MnistData r -> DualNumberVariables d r -> m (DualNumber d r)
fcnnMnistLoss2 (input, target) variables = do
  result <- inline fcnnMnist2 logisticAct softMaxActV input variables
  lossCrossEntropyV target result

-- | The neural network applied to concrete activation functions
-- and composed with the appropriate loss function, using fused
-- softMax and cross entropy as the loss function.
fcnnMnistLossFused2
  :: DualMonad d r m
  => MnistData r -> DualNumberVariables d r -> m (DualNumber d r)
fcnnMnistLossFused2 (input, target) variables = do
  result <- inline fcnnMnist2 logisticAct return input variables
  lossSoftMaxCrossEntropyV target result

fcnnMnistLossFusedRelu2
  :: DualMonad d r m
  => MnistData r -> DualNumberVariables d r -> m (DualNumber d r)
fcnnMnistLossFusedRelu2 (input, target) variables = do
  result <- inline fcnnMnist2 reluAct return input variables
  lossSoftMaxCrossEntropyV target result

-- | A function testing the neural network given testing set of inputs
-- and the trained parameters.
fcnnMnistTest2
  :: forall r. IsScalar 'DModeGradient r
  => [MnistData r] -> Domains r -> r
fcnnMnistTest2 inputs parameters =
  let matchesLabels :: MnistData r -> Bool
      matchesLabels (glyph, label) =
        let nn = inline (fcnnMnist2 @'DModeGradient)
                        logisticAct softMaxActV glyph
            value = primalValue nn parameters
        in V.maxIndex value == V.maxIndex label
  in fromIntegral (length (filter matchesLabels inputs))
     / fromIntegral (length inputs)

max_stars_repo_name: Mikolaj/horde-ad

max_issues_repo_name: Mikolaj/horde-ad

max_forks_repo_name: Mikolaj/horde-ad


text:
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeInType          #-}
{-# LANGUAGE TypeOperators       #-}

module TensorOps.Learn.NeuralNet.Recurrent
  ( Network
  , buildNet
  , netParams
  , runNetwork
  , runNetworkSt
  , genNet
  , fullyConnected
  , ffLayer
  , stateless
  , (~*~)
  , (*~)
  , (~*)
  , nmap
  , trainNetwork
  , trainNetwork'
  , networkGradient
  ) where

import           Control.Category
import           Control.DeepSeq
import           Control.Monad.Primitive
import           Control.Monad.State
import           Data.Kind
import           Data.Singletons
import           Data.Singletons.Prelude               (Sing(..))
import           Data.Type.Combinator
import           Data.Type.Conjunction
import           Data.Type.Length                      as TCL
import           Data.Type.Length.Util                 as TCL
import           Data.Type.Nat
import           Data.Type.Product                     as TCP
import           Data.Type.Product.Util                as TCP
import           Data.Type.Sing
import           Data.Type.Uniform
import           Data.Type.Vector                      as TCV
import           Data.Type.Vector.Util                 as TCV
import           Prelude hiding                        ((.), id)
import           Statistics.Distribution.Normal
import           System.Random.MWC
import           TensorOps.Learn.NeuralNet
import           TensorOps.NatKind
import           TensorOps.TOp                         as TO
import           TensorOps.Tensor                      as TT
import           TensorOps.Types
import           Type.Class.Higher
import           Type.Class.Higher.Util
import           Type.Class.Known
import           Type.Class.Witness
import           Type.Family.List
import           Type.Family.List.Util
import           Type.Family.Nat
import           Unsafe.Coerce
import qualified TensorOps.Learn.NeuralNet.FeedForward as FF

data Network :: ([k] -> Type) -> k -> k -> Type where
    N :: { _nsSs    :: !(Sing ss)
         , _nsPs    :: !(Sing ps)
         , _nOp     :: !(TOp ('[i] ': ss ++ ps) ('[o] ': ss))
         , _nState  :: !(Prod t ss)
         , _nParams :: !(Prod t ps)
         } -> Network t i o

instance NFData1 t => NFData (Network t i o) where
    rnf = \case
      N _ _ o p s -> o `seq` p `deepseq1` s `deepseq1` ()
    {-# INLINE rnf #-}

netParams
    :: Network t i o
    -> (forall ss ps. (SingI ss, SingI ps) => Prod t ss -> Prod t ps -> r)
    -> r
netParams = \case
    N sS sP _ s p -> \f -> f s p \\ sS \\ sP

buildNet
    :: forall ss ps i o t. (SingI ss, SingI ps)
    => TOp ('[i] ': ss ++ ps) ('[o] ': ss)  -- ^ Tensor operation for network
    -> Prod t ss        -- ^ Initial states
    -> Prod t ps        -- ^ Network parameters
    -> Network t i o
buildNet = N sing sing

fullyConnected
    :: forall k (i :: k) (o :: k) (m :: Type -> Type) (t :: [k] -> Type).
     ( SingI i
     , SingI o
     , PrimMonad m
     , Tensor t
     )
    => Activation k         -- ^ Activation function for internal state
    -> Gen (PrimState m)
    -> m (Network t i o)
fullyConnected a g = (\s w w' b -> buildNet @'[ '[o] ] @'[ '[o,o], '[o,i], '[o] ]
                                     fc (s :< Ø) (w' :< w :< b :< Ø)
                     )
          <$> genRand (normalDistr 0 0.5) g
          <*> genRand (normalDistr 0 0.5) g
          <*> genRand (normalDistr 0 0.5) g
          <*> genRand (normalDistr 0 0.5) g
  where
    fc  :: TOp '[ '[i], '[o], [o,o], '[o,i], '[o]] '[ '[o], '[o] ]
    fc = secondOp @'[ '[i] ] (
           firstOp @'[ '[o,i], '[o] ] (TO.swap >>> TO.matVec)
       >>> firstOp @'[ '[o] ]         TO.swap
         )
     >>> firstOp @'[ '[o], '[o] ] (TO.swap >>> TO.matVec)
     >>> TO.add3
     >>> TO.duplicate
     >>> secondOp @'[ '[o] ] (getAct a)
    {-# INLINE fc #-}
{-# INLINE fullyConnected #-}

-- | Convert a neural network from "TensorOps.Learn.NeuralNet.FeedForward"
-- to a stateless 'Network'.
--
-- Can be thought a functor from the category of stateless neural networks
-- to the category of stateful (recurrent) ones.
stateless
    :: FF.Network t i o
    -> Network t i o
stateless = \case
    FF.N sP o p -> N SNil sP o Ø p
{-# INLINE stateless #-}

ffLayer
    :: forall i o m t. (SingI i, SingI o, PrimMonad m, Tensor t)
    => Gen (PrimState m)
    -> m (Network t i o)
ffLayer g = stateless <$> FF.ffLayer g
{-# INLINE ffLayer #-}

genNet
    :: forall k o i m (t :: [k] -> Type). (SingI o, SingI i, PrimMonad m, Tensor t)
    => [(Integer, (Activation k, Maybe (Activation k)))]
    -> Activation k
    -> Maybe (Activation k)
    -> Gen (PrimState m)
    -> m (Network t i o)
genNet xs0 f fS g = go sing xs0
  where
    go  :: forall (j :: k). ()
        => Sing j
        -> [(Integer, (Activation k, Maybe (Activation k)))]
        -> m (Network t j o)
    go sj = (\\ sj) $ \case
      []        -> fmap (*~ getAct f) $ case fS of
        Just fS' -> fullyConnected fS' g
        Nothing  -> ffLayer g
      (x,(f', fS')):xs -> withNatKind x $ \sl -> (\\ sl) $ do
        n <- go sl xs
        l <- case fS' of
          Nothing   -> ffLayer g
          Just fS'' -> fullyConnected fS'' g
        return $ l *~ getAct f' ~*~ n
    {-# INLINE go #-}
{-# INLINE genNet #-}

instance Category (Network t) where
    id  = N SNil SNil idOp Ø Ø
    (.) = flip (~*~)

(~*~)
    :: forall k (t :: [k] -> Type) a b c. ()
    => Network t a b
    -> Network t b c
    -> Network t a c
(~*~) = \case
  N (sSs1 :: Sing ss1)
    (sPs1 :: Sing ps1)
    (o1   :: TOp ('[a] ': ss1 ++ ps1) ('[b] ': ss1))
    (s1   :: Prod t ss1)
    (p1   :: Prod t ps1) -> \case
    N (sSs2 :: Sing ss2)
      (sPs2 :: Sing ps2)
      (o2   :: TOp ('[b] ': ss2 ++ ps2) ('[c] ': ss2))
      (s2   :: Prod t ss2)
      (p2   :: Prod t ps2) ->
      let lSs1 :: Length ss1
          lSs1 = singLength sSs1
          lSs2 :: Length ss2
          lSs2 = singLength sSs2
          lPs1 :: Length ps1
          lPs1 = singLength sPs1
          lPs2 :: Length ps2
          lPs2 = singLength sPs2
          o :: TOp ('[a] ': (ss2 ++ ss1) ++ (ps1 ++ ps2)) ('[c] ': ss2 ++ ss1)
                    -- all these proofs lol
          o     = (\\ (unsafeCoerce Refl :: ((ss2 ++ ss1) ++ ps1) ++ ps2 :~: (ss2 ++ ss1) ++ (ps1 ++ ps2))) $
                  (\\ (unsafeCoerce Refl :: ((ss1 ++ ps1) ++ ss2) ++ ps2 :~: (ss1 ++ ps1) ++ (ss2 ++ ps2))) $
                  (\\ appendAssoc lSs1 lSs2 lPs2                  ) $
                  (\\ appendAssoc lSs2 lSs1 lPs1                  ) $
                  (\\ (lSs2 `TCL.append'` lSs1) `TCL.append'` lPs1) $
                  (\\ (lSs1 `TCL.append'` lPs1) `TCL.append'` lSs2) $
                  (\\ lSs1                                        ) $
                  (\\ lSs2                                        ) $
                  (\\ lSs1 `TCL.append'` lPs1                     ) $
                  (\\ lSs2 `TCL.append'` lPs2                     ) $
                    secondOp @'[ '[a] ]
                      (firstOp @ps2 (TO.swap' lSs2 (lSs1 `TCL.append'` lPs1))
                      )
                >>> firstOp @(ss2 ++ ps2) o1
                >>> secondOp @'[ '[b] ] (TO.swap' lSs1 (lSs2 `TCL.append'` lPs2))
                >>> firstOp @ss1 o2
      in  N (sSs2 %:++ sSs1)
            (sPs1 %:++ sPs2)
            o
            (s2 `TCP.append'` s1)
            (p1 `TCP.append'` p2)
infixr 4 ~*~
{-# INLINE (~*~) #-}

runNetwork
    :: (RealFloat (ElemT t), Tensor t)
    => Network t i o
    -> t '[i]
    -> (t '[o], Network t i o)
runNetwork (N sS sO o s p) x =
        (\case y :< s' -> (y, N sS sO o s' p))
      . runTOp o
      $ x :< (s `TCP.append'` p)
{-# INLINE runNetwork #-}

runNetworkSt
    :: (RealFloat (ElemT t), Tensor t, MonadState (Network t i o) m)
    => t '[i]
    -> m (t '[o])
runNetworkSt x = state $ flip runNetwork x

(~*) :: TOp '[ '[a] ] '[ '[b] ]
     -> Network t b c
     -> Network t a c
f ~* N sS sO o s p = N sS sO (f *>> o) s p
infixr 4 ~*
{-# INLINE (~*) #-}

(*~) :: Network t a b
     -> TOp '[ '[b] ] '[ '[c] ]
     -> Network t a c
N sS sO o s p *~ f = N sS sO (o >>> firstOp f) s p
infixl 5 *~
{-# INLINE (*~) #-}

nmap
     :: SingI o
     => (forall a. RealFloat a => a -> a)
     -> Network t i o
     -> Network t i o
nmap f n = n *~ TO.map f
{-# INLINE nmap #-}

netGrad
    :: forall k n (t :: [k] -> Type) (i :: k) (o :: k) ss ps.
     ( Tensor t
     , RealFloat (ElemT t)
     , SingI i
     , SingI o
     )
    => TOp '[ '[o], '[o] ] '[ '[] ]
    -> Vec n (t '[i])
    -> Vec n (t '[o])
    -> Sing ss
    -> Sing ps
    -> TOp ('[i] ': ss ++ ps) ('[o] ': ss)
    -> Prod t ss
    -> Prod t ps
    -> (Vec n (t '[i]), (Prod t ss, Prod t ps))
netGrad loss xs ys sS sP o s p =
      (prodToVec' I n grI, splitProd @ps lS grSP)
  where
    n :: Nat n
    n = known   \\ xs
    lS :: Length ss
    lS = singLength sS
    lP :: Length ps
    lP = singLength sP
    sO :: Sing (Replicate n '[o])
    sO = replicateSing (sing :: Sing '[o]) n
    lI :: Length (Replicate n '[i])
    lI = replicateLength @'[i] n
    lO :: Length (Replicate n '[o])
    lO = replicateLength @'[o] n
    unrolled
        :: TOp (Replicate n '[i] ++ ss ++ ps) (Replicate n '[o])
    unrolled = (\\ sS %:++ sO) $
               (\\ sS %:++ sP) $
                 unroll sS sP o n
             >>> TO.drop @(Replicate n '[o]) lS
    o'  :: TOp (Replicate n '[i] ++ ss ++ ps ++ Replicate n '[o]) '[ '[] ]
    o' = (\\ appendAssoc lI (lS `TCL.append'` lP) lO) $
         (\\ appendAssoc lS lP lO) $
         (\\ lI `TCL.append'` lS `TCL.append'` lP) $
         (\\ lO) $
            firstOp @(Replicate n '[o]) unrolled
        >>> rollup @k lS lP loss n
    xs' :: Prod t (Replicate n '[i] ++ ss ++ ps ++ Replicate n '[o])
    xs' = vecToProd' getI (TCV.reverse' xs) `TCP.append'` (s
            `TCP.append'` (
              p `TCP.append'` vecToProd' getI ys
            )
          )
    grad :: Prod t (Replicate n '[i] ++ ss ++ ps)
    grad = (\\ (unsafeCoerce Refl :: Replicate n '[i] ++ ss ++ ps ++ Replicate n '[o]
                                 :~: (Replicate n '[i] ++ ss ++ ps) ++ Replicate n '[o]
               )
           ) $
      takeProd @(Replicate n '[o]) (lI `TCL.append'` lS `TCL.append'` lP) $ gradTOp o' xs'
    grI   :: Prod t (Replicate n '[i])
    grSP  :: Prod t (ss ++ ps)
    (grI, grSP) = splitProd @(ss ++ ps) lI grad
{-# INLINE netGrad #-}

trainNetwork'
    :: forall k n (t :: [k] -> Type) (i :: k) (o :: k).
     ( Tensor t
     , RealFloat (ElemT t)
     , SingI i
     , SingI o
     )
    => TOp '[ '[o], '[o] ] '[ '[] ]     -- ^ loss function (input, target)
    -> ElemT t          -- ^ train rate for initial state
    -> ElemT t          -- ^ train rate for network parameters
    -> Vec n (t '[i])   -- ^ inputs
    -> Vec n (t '[o])   -- ^ targets
    -> Network t i o
    -> Network t i o
trainNetwork' loss rS rP xs ys = \case
    N sS sP o s p ->
      let (gS, gP) = snd $ netGrad loss xs ys sS sP o s p
          s' = map1 (f rS) $ zipProd3 (singProd sS) s gS
          p' = map1 (f rP) $ zipProd3 (singProd sP) p gP
      in  N sS sP o s' p'
  where
    f   :: forall ns. ()
        => ElemT t
        -> (Sing :&: t :&: t) ns
        -> t ns
    f r !(s1 :&: p1 :&: g1) =
      TT.zip (\(!p2) (!g2) -> p2 - r * g2) p1 g1 \\ s1
    {-# INLINE f #-}
{-# INLINE trainNetwork #-}

trainNetwork
    :: forall k (t :: [k] -> Type) (i :: k) (o :: k).
     ( Tensor t
     , RealFloat (ElemT t)
     , SingI i
     , SingI o
     )
    => TOp '[ '[o], '[o] ] '[ '[] ]     -- ^ loss function (input, target)
    -> ElemT t          -- ^ train rate for initial state
    -> ElemT t          -- ^ train rate for network parameters
    -> [(t '[i], t '[o])]   -- ^ inputs and targets
    -> Network t i o
    -> Network t i o
trainNetwork loss rS rP xsys n = withV xsys $ \v ->
    let (xs, ys) = TCV.unzip' v
    in  trainNetwork' loss rS rP xs ys n

networkGradient
    :: forall k n (t :: [k] -> Type) (i :: k) (o :: k) r.
     ( Tensor t
     , RealFloat (ElemT t)
     , SingI i
     , SingI o
     )
    => TOp '[ '[o], '[o] ] '[ '[] ]     -- ^ loss function (output, target)
    -> Vec n (t '[i])       -- ^ inputs
    -> Vec n (t '[o])       -- ^ targets
    -> Network t i o
    -> (forall ss ps. (SingI ss, SingI ps) => Vec n (t '[i]) -> Prod t ss -> Prod t ps -> r)
    -> r
networkGradient loss xs ys = \case
    N sS sP o s p -> \f -> case netGrad loss xs ys sS sP o s p of
      (gI, (gS, gP)) -> f gI gS gP \\ sS \\ sP
{-# INLINE networkGradient #-}

unroll
    :: forall ss ps i o n. (SingI (ss ++ ps), SingI i)
    => Sing ss
    -> Sing ps
    -> TOp ('[i] ': ss ++ ps) ('[o] ': ss)
    -> Nat n
    -> TOp (Replicate n '[i] ++ ss ++ ps) (ss ++ Replicate n '[o])
unroll sS sP o = \case
    Z_              -> TO.take lS lP    \\ appendNil lS
    S_ (m :: Nat m) -> (\\ (unsafeCoerce Refl :: Replicate m '[i] ++ '[i] ': ss ++ ps
                                             :~: '[i] ': Replicate m '[i] ++ ss ++ ps
                           )
                       ) $
                       (\\ (unsafeCoerce Refl :: (Replicate m '[i] ++ ss ++ ps) ++ '[ '[o] ]
                                             :~: Replicate m '[i] ++ ss ++ (ps >: '[o])
                           )
                       ) $
                       (\\ (unsafeCoerce Refl :: (ss ++ Replicate m '[o]) ++ '[ '[o] ]
                                             :~: ss ++ '[o] ': Replicate m '[o]
                           )
                       ) $
                       (\\ appendAssoc lS lP (LS LZ :: Length '[ '[o] ])) $
                       (\\ appendSnoc lP (Proxy @'[o])) $
                       (\\ replicateLength @'[i] m `TCL.append'` lS `TCL.append'` lP) $
                       (\\ lS `TCL.append'` replicateLength @'[o] m) $
                       (\\ replicateLength @'[i] m) $
                       (\\ lS) $
          secondOp @(Replicate m '[i]) @('[i] ': ss ++ ps) @(ss ++ ps >: '[o]) (
                (o &&& TO.drop @ps @('[i] ': ss) (LS lS))
            >>> TO.swap' (LS LZ) (lS `TCL.append'` lP)
          )
      >>> firstOp @'[ '[o] ] @(Replicate m '[i] ++ ss ++ ps) @(ss ++ Replicate m '[o]) (
            unroll sS sP o m
          )
  where
    lS :: Length ss
    lS = singLength sS
    lP :: Length ps
    lP = singLength sP
{-# INLINE unroll #-}

rollup
    :: forall k (ss :: [[k]]) (ps :: [[k]]) (o :: k) (n :: N). ()
    => Length ss
    -> Length ps
    -> TOp '[ '[o], '[o] ] '[ '[] ]
    -> Nat n
    -> TOp (Replicate n '[o] ++ Replicate n '[o]) '[ '[] ]
rollup lS lP loss = \case
    Z_                     -> TO.konst (US UØ) 0
    S_ Z_                  -> loss
    S_ (m@(S_ _) :: Nat m) ->
      let lO :: Length (Replicate m '[o])
          lO = replicateLength @'[o] m
      in  (\\ (unsafeCoerce Refl :: Replicate m '[o] ++ '[o] ': '[o] ': Replicate m '[o]
                                :~: '[o] ': Replicate m '[o] ++ '[o] ': Replicate m '[o]
              )
            ) $
            (\\ appendSnoc lO (Proxy @'[])) $
            (\\ lO) $
            (\\ lO `TCL.append'` lO) $
            (\\ appendAssoc lO lO (LS LZ :: Length '[ '[] ])) $
              secondOp @(Replicate m '[o]) @('[o] ': '[o] ': Replicate m '[o]) @(Replicate m '[o] >: '[]) (
                  firstOp @(Replicate m '[o]) @('[ '[o], '[o] ]) @('[ '[] ]) loss
                >>> TO.swap' @'[ '[] ] @(Replicate m '[o]) (LS LZ) lO
              )
            >>> firstOp @'[ '[] ] @(Replicate m '[o] ++ Replicate m '[o]) @'[ '[] ] (
                  rollup lS lP loss m
                )
            >>> TO.add
{-# INLINE rollup #-}

max_stars_repo_name: mstksg/tensor-ops

max_issues_repo_name: mstksg/tensor-ops

max_forks_repo_name: mstksg/tensor-ops


text:
{-# LANGUAGE Rank2Types, FlexibleContexts #-}
module Numeric.MaxEnt.Deconvolution.Internal where
import Numeric.MaxEnt
import Data.List.Split
import Data.List
import Debug.Trace
import Numeric.Integration.TanhSinh
import Numeric.AD
import Control.Applicative
import Numeric.MaxEnt.Deconvolution.Convolution2D
import Math.GaussianQuadratureIntegration
import Numeric.MaxEnt.Deconvolution.GaussianPSF
import Debug.Trace
import Data.Word
import Data.Array.Repa hiding ((++), map, transpose, toList)
import qualified Data.Array.Repa as R
import qualified Data.Array.Repa.Eval as R
import qualified Data.Array.Repa.Repr.ForeignPtr as R
import qualified Data.Vector.Unboxed as UV
import Control.Lens hiding (ala)
import System.FilePath.Lens
import qualified Data.Vector.Storable as VS
import Foreign.Marshal.Array
import System.IO.Unsafe
import Foreign.ForeignPtr.Safe
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as BS
import Codec.Picture.Png
import Codec.Picture.Types
import Numeric
import Unsafe.Coerce
import qualified Data.Vector.Storable as S
import Numeric.MaxEnt.Deconvolution.Iterative
import Numeric.LinearAlgebra
import Data.Packed.Matrix
--import Numeric.MaxEnt.Deconvolution.IterativeRepa
--import qualified Data.Array.Repa 			        as A
--import qualified Data.Array.Repa.Repr.Unboxed   as U
--import qualified Data.Array.Repa.Stencil		        as A
--import qualified Data.Array.Repa.Stencil.Dim2	        as A
--import Data.Functor.Identity

traceIt x = trace (show x) x

traceItNote :: Show a => String -> a -> a
traceItNote msg x = trace (msg ++ show x) x

gaussianConvolve2D :: Double -> [[Double]] -> [[Double]]
gaussianConvolve2D var xs =
    convolve2DZeroBoundary (sampleGaussian2D var width height) $ xs where
        width = length . head $ xs
        height = length xs

gaussianConvolve2D' :: Double -> [[Double]] -> [[Double]]
gaussianConvolve2D' var xs =
    convolve2DZeroBoundary (sampleGaussian2D' var width height) $ xs where
        width = length . head $ xs
        height = length xs

--deconvolve2D :: [[Double]] -> [Double] -> Either String [[Double]]
deconvolve2D steps psf image = result where
    convoPSF = toConvolve2DZeroBoundary 0 psf

    total = sum . concat $ image
    width = length . head $ image
    height = length image

    normalizedImage  = normalize . concat $ image

    fromLinearImage = chunksOf width . map (total*)

    -- I think here I can
    result = case linear 0.001 (LC convoPSF normalizedImage) of
        Right x -> Right $ fromLinearImage $ S.toList x
        Left x  -> Left $ show x

    --result = Right $ fromLinearImage $ toList $
    --    update steps (fromLists convoPSF) (fromList normalizedImage)

    --result = Right $ fromLinearImage $ A.toList $
    --    runIdentity $ update' steps psf (fromListUnboxed (Z :. width :. height) normalizedImage) $
    --        (delay $ fromListUnboxed (Z :. width :. height) $ replicate (width * height) 0)

    --result = Right $ fromLinearImage $ last $ linear'' (LC convoPSF normalizedImage) :: Either String [[Double]]

--testPSF :: (RealFloat a)
--       => [[a]]
testPSF = gaussianPSF 0.25 5 5

--          -> a -> Int -> Int -> [[a]]
gsamples var width height = gaussianPSF var width height

testInput :: [[Double]]
testInput = [[0,0,0], [0.0, 1.0, 0.0], [0,0,0]]

testInput1 :: [[Double]]
testInput1 = [[0,  0,   0, 0,   0],
              [0,  1.0/9.0,  1.0/9.0, 1.0/9.0,   0],
              [0,  1.0/9.0,  1.0/9.0, 1.0/9.0,   0],
              [0,  1.0/9.0,  1.0/9.0, 1.0/9.0,   0],
              [0,  0,   0, 0,   0]]

testInput2 :: [[Double]]
testInput2 = [[0,  0, 0,   0,   0],
              [0,  0, 0,   0,   0],
              [0,  0, 1.0, 0,   0],
              [0,  0, 0,   0,   0],
              [0,  0, 0,   0,   0]]

testInput3 :: [[Double]]
testInput3 = map (map (1.0-)) testInput2

testDecon :: Either String [[Double]]
testDecon = deconvolve2D 1000 testPSF
    (gaussianConvolve2D  0.25 testInput2)

roundTrip :: Double -> [[Double]] -> Either String [[Double]]
roundTrip var image = deconvolve2D 1000 (gsamples var width height) $
    (gaussianConvolve2D var image) where
        width = length . head $ image
        height = length image

printRT var = either show (show . FloatList) . roundTrip var

toWord8 :: Double -> Word8
toWord8 x = floor $ x * 256.0

--testId ::  (forall a. RealFloat a => [[a]]) -> [[Double]] -> Either String [[Double]]
testId x y = Right y

getR (PixelRGBA8 x _ _ _) = x

toPixel x = [x, x, x, 255]

--TODO make an image that matches the one above
--make increasingly larger examples until I can find the smallest ont
--that exhibits the problem
deconvolve' :: Int -> Double -> Image Pixel8 -> Image Pixel8
deconvolve' steps var i@(Image width height dat) = result where
    input = [[fromIntegral (pixelAt i w h) / 256.0 |
        w <- [0..(width  - 1)]] |
        h <- [0..(height - 1)]  ]

        --
    result = case deconvolve2D steps (gsamples var width height) input of
        Right z -> Image width height . VS.fromList $ concatMap (map toWord8) z
        Left x  -> error ""  --   $ show x

-- The test that I should have, is
-- open a file and blur it
-- and then unblur it
blurImage :: Double -> Image Pixel8 -> Image Pixel8
blurImage var i@(Image width height dat) = result where
    input = [[fromIntegral (pixelAt i w h) / 256.0 |
        w <- [0..(width  - 1)]] |
        h <- [0..(height - 1)]  ]

    blured = gaussianConvolve2D' var input

    result = Image width height $ VS.fromList $ reverse $ concatMap (map toWord8) $ transpose blured

deconvolve :: Int -> Double -> FilePath -> Int -> IO ()
deconvolve steps var filePath i = do
    let outputPath = basename %~ (++ "_decon" ++ show i) $ filePath
    pngBytes <- BS.readFile filePath
    let image = either error id . decodePng $ pngBytes
        newImage = case image of
            ImageY8 x -> deconvolve' steps var x
            x -> error $ "bad format"
    writePng outputPath newImage

deconvolve2 :: Int -> Double -> FilePath -> IO ()
deconvolve2 steps var filePath = do
    let outputPath = basename %~ (++ "_decon") $ filePath
        blurPath   = basename %~ (++ "_blur") $ filePath
    pngBytes <- BS.readFile filePath
    let image = either error id . decodePng $ pngBytes

    newImage <- case image of
        ImageY8 x -> do
            --blur the image and write out the blured one
            let blurImaged = blurImage var x

            writePng blurPath blurImaged
            return $ deconvolve' steps var blurImaged
        x -> error $ "bad format"
    writePng outputPath newImage

max_stars_repo_name: jfischoff/Sharpen

max_issues_repo_name: jfischoff/Sharpen

max_forks_repo_name: jfischoff/Sharpen


text:
{-# language QuasiQuotes #-}
{- |
Module       : Main
Description  : Main entry point into FractalStream
-}
module Main where

import qualified Data.Color as FSColor
import UI.WX.Viewer
import Control.Concurrent
import Control.Monad.State
import Data.Planar
import Data.Complex
import Text.RawString.QQ

import Language.Code.Simulator
import Language.Type
import Language.Environment
import Language.Effect
import Language.Code.Parser
import Language.Value.Parser
import Data.Proxy

import Actor.Settings
import Actor.Tool
import Actor.Viewer
import Event
import Language.Effect.Draw
import Language.Effect.Render
import Language.Effect.Provide
import Language.Code
import Backend.LLVM

main :: IO ()
main = do
    tid <- myThreadId
    bound <- isCurrentThreadBound
    capInfo <- threadCapability tid
    putStrLn ("Hello from main, on thread " ++ show tid ++ " "
              ++ show capInfo ++ " " ++ show bound)
    wxMain
    putStrLn "main is done"

wxMain :: IO ()
wxMain = do
    tid <- myThreadId
    bound <- isCurrentThreadBound
    capInfo <- threadCapability tid
    putStrLn ("Hello from wxMain, on thread " ++ show tid ++ " " ++ show capInfo ++ " " ++ show bound)
    let env = declare @"maxIters" IntegerType
            $ declare @"maxRadius" RealType
            $ declare @"x" RealType
            $ declare @"y" RealType
            $ endOfDecls
    withCompiledCode env mandelProgram0 $ \kernel -> do
      let action bs ss dz z out = runJX kernel out (fromIntegral bs) (fromIntegral ss) dz 100 10 z
      wxView viewport action mainViewer
  where
    viewport = flippedRectangle (-2.5, 2) (1.5, -2)

flag :: String
flag = [r|
if x < -0.65 then
  dark green
else if x > 0.65 then
  orange
else
  white|]

grid :: String
grid = [r|
init z : C to x + i y
init fz : C to sin z
init dfz : C to cos z
init size : R to 0.01 * |dfz|
if |sin (pi re(fz))| < size or |sin (pi im(fz))| < size then
  light blue
else
  white|]

mandelProgram0 :: String
mandelProgram0 = [r|
init C : C to x + i y
init z : C to 0
init k : Z to 0
loop
  set z to z z + C
  set k to k + 1
  |z| < maxRadius and k < maxIters
if k = maxIters then
  black
else
  init c1 : Color to if im(z) > 0 then blue else yellow
  init c2 : Color to if im(z) > 0 then green else orange
  init s : R to k + 1 - (log (log (|z|^2) / 2)) / log 2
  set s to cos (s pi / 10)
  set s to s s
  blend (s, c1, c2)|]

juliaProgram0 :: String
juliaProgram0 = [r|
init C : C to -0.12256 + 0.74486i
init z : C to x + i y
init k : Z to 0
init r2 : R to maxRadius * maxRadius
loop
  set z to z z + C
  set k to k + 1
  re(z) re(z) + im(z) im(z) < r2 and k < maxIters
if k = maxIters then
  black
else
  init c1 : Color to if im(z) > 0 then blue else yellow
  init c2 : Color to if im(z) > 0 then green else orange
  init s : R to k + 1 - (log (log (|z|^2) / 2)) / log 2
  set s to cos (s pi / 10)
  set s to s s
  blend (s, c1, c2)
|]

mandelProgram :: String
mandelProgram = [r|
init C : C to -0.11 + 0.75i
init z : C to x + i y
init k : Z to 0
init r2 : R to maxRadius * maxRadius
loop
  set z to z z + C
  set k to k + 1
  |z|^2 < r2 and k < maxIters
if k >= maxIters then
  black
else
  init s : R to k + 1 - (log ((log (|z|^2)) / 2)) / log 2
  set s to mod(s, 10) / 10
  init c1 : Color to blue
  init c2 : Color to white
  if im z > 0 then
    set c1 to yellow
    set c2 to red
  else
    pass
  if s < 0.5 then
    blend(2s, c1, c2)
  else
    blend(2s - 1, c2, c1)|]

mandelProgram' :: String
mandelProgram' = [r|
init curImage : bitmap <- render in x y plane (viewWidth,viewHeight) (-2,2) (1 / 128, 1 / 128)
  init C : C to -0.11 + 0.75i
  set complex z to x + i y
  set integer k to 0
  set real r2 to maxRadius * maxRadius
  loop
    set z to z z + C
    set k to k + 1
    re z re z + im z im z < r2 and k < maxIters
  if k >= maxIters then
    black
  else
    set s : R to k + 1 - (log ((log (|z|^2)) / 2)) / log 2
    set s to mod(s, 10) / 10
    set c1 : Color to blue
    set c2 : Color to white
    if im z > 0 then
      set c1 to yellow
      set c2 to red
    else
      pass
    if s < 0.5 then
      blend(2s, c1, c2)
    else
      blend(2s - 1, c2, c1)|]

mandelProgram'' :: String
mandelProgram'' = [r|
curImage : Image
curImage ⟵ render in x y plane (viewWidth,viewHeight) (-2,2) (1 / 128, 1 / 128)
  C : Complex
  C = -0.11 + 0.75i
  z : Complex
  z = x + i y

  repeat maxIters times with counter k
      z = z² + C
  while |z| < maxRadius

  if k = maxIters then
    black
  else
    s : Real
    s = if use_smoothing then k + 1 - log (log |z|² / 2) / log 2 else k
    s = mod (s, speed) / speed
    c₁ = blue  : Color
    c₂ = white : Color
    if im z > 0 then
        c₁ = yellow
        c₂ = red
    if s < 0.5 then
      blend(2s, c₁, c₂)
    else
      blend(2s - 1, c₂, c₁)|]

traceProgram :: String
traceProgram = [r|
init C : C to -0.11 + 0.75i
init z : C to posX + posY i
init z0 : C to 0
init k : Z to 0
erase
use white for line
loop
    set z0 to z
    set z to z z + C
    draw point at z0
    draw line from z0 to z
    set k to k + 1
    k < 100|]

traceProgram' :: String
traceProgram' = [r|
C : ℂ
C = -0.11 + 0.75i

z : ℂ
z = x + i y

z₀ : ℂ
z₀ = 0

erase
use white for line
repeat 100 times
    z₀ = z
    z  = z² + C
    draw point at z₀
    draw line from z₀ to z
|]

traceTool :: Tool '[Draw]
traceTool = Tool{..}
  where
    toolName = "Trace"
    toolHelp = "Click on a point to draw its trace"

    toolSettings = Settings{..}
    settingsList  = Bind (Proxy @"steps") IntegerType
                    (Setting Proxy (Scalar IntegerType 100)
                      (Just ("Trace steps",
                              [ InputValidator
                                "Trace steps must be non-negative"
                                validator ])))
                    $ EmptyContext
    settingsEnv = declare @"steps" IntegerType endOfDecls
    settingsTitle = "Trace settings"
    onChanged     = Nothing

    onClick = Just ( Fix
                   $ Effect Proxy Proxy VoidType
                   $ Provide posEnv settingsEnv VoidType trace)
    onMouseDown = Nothing
    onMouseUp = Nothing
    onMotion = Nothing
    onDrag = Nothing
    buttons = []
    env  = declare @"posX" RealType
         $ declare @"posY" RealType
         $ settingsEnv
    trace = case parseCode (EP (ParseEff noParser $ ParseEff drawEffectParser NoEffs)) env VoidType traceProgram of
      Right p -> p
      Left e  -> error (show e)

    validator = case parseValue settingsEnv BooleanType "steps > 0" of
      Right p -> p
      Left e -> error (show e)

mainViewer :: Viewer
mainViewer = Viewer{..}
  where
    onTimer = Nothing
    viewerTools = [traceTool]
    viewerSettings = Settings{..}
    settingsList = Bind (Proxy @"maxRadius") RealType
                     (Setting Proxy (Scalar RealType 10)
                       (Just ("Max. radius", [])))
                 $ Bind (Proxy @"maxIters") IntegerType
                     (Setting Proxy (Scalar IntegerType 100)
                       (Just ("Max. iterations", [])))
                 $ EmptyContext
    settingsEnv = contextToEnv settingsList

    settingsTitle = "FractalStream demo viewer settings"
    onChanged = Nothing
    onResize  = Nothing
    onRefresh = Just ( Fix
                     $ Effect Proxy Proxy VoidType
                     $ Provide EmptyEnvProxy settingsEnv VoidType mandelCode)
    viewToModel = case parseValue envV2M (PairType RealType RealType) v2m of
      Right c -> c
      Left e -> error (show e)
    modelToView = case parseValue envM2V (PairType RealType RealType) m2v of
      Right c -> c
      Left e -> error (show e)

    envV2M = declare @"viewX" RealType
           $ declare @"viewY" RealType
           $ env

    envM2V = declare @"modelX" RealType
           $ declare @"modelY" RealType
           $ env

    env = declare @"maxRadius" RealType
        $ declare @"maxIters"  IntegerType
        $ endOfDecls

    v2m = "((viewX - 256) / 128, (viewY - 256) / 128)"
    m2v = "(128 modelX + 256, 128 modelY + 256)"

    mandelCode = case parseCode (EP (ParseEff noParser $ ParseEff renderEffectParser NoEffs)) settingsEnv VoidType mandelProgram' of
      Right c -> c
      Left e  -> error (show e)

mandel' :: Int -> Double -> Complex Double -> FSColor.Color
mandel' maxIters maxRadius (x :+ y) =
  let ctx = Bind (Proxy @"x") RealType x
          $ Bind (Proxy @"y") RealType y
          $ Bind (Proxy @"maxRadius") RealType maxRadius
          $ Bind (Proxy @"maxIters") IntegerType (fromIntegral maxIters)
          $ EmptyContext
  in evalState (simulate NoHandler prog) (ctx, ())
 where
   prog = case parseCode (EP NoEffs) env ColorType mandelProgram of
     Right p -> p
     Left _  -> case parseCode (EP NoEffs) env ColorType "dark red" of
       Right p -> p
       Left e  -> error (show e) -- should be unreachable
   env = declare @"x" RealType
       $ declare @"y" RealType
       $ declare @"maxRadius" RealType
       $ declare @"maxIters" IntegerType
       $ endOfDecls

max_stars_repo_name: matt-noonan/FractalStream

max_issues_repo_name: matt-noonan/FractalStream

max_forks_repo_name: matt-noonan/FractalStream


text:
module NeuralNet.LayerSpec (layerSpec) where

import Test.Hspec
import NeuralNet.Net
import NeuralNet.Activation
import NeuralNet.Example
import NeuralNet.Layer
import Control.Exception (evaluate)
import Numeric.LinearAlgebra

layerSpec :: SpecWith ()
layerSpec =
  describe "NeuralNet.Layer" $ do
    describe "layerForward" $ do
      it "errors on wrong number of inputs" $
        let
          nn = buildNNFromList (3, [LayerDefinition ReLU 1]) [1, 2, 3, 4]
          firstLayer = head (nnLayers nn)
        in evaluate (layerForward firstLayer [1]) `shouldThrow` anyErrorCall

      it "calculates correctly for single output" $
        let
          nn = buildNNFromList (3, [LayerDefinition ReLU 1]) [1, 2, 3, 4]
          firstLayer = head (nnLayers nn)
        in layerForward firstLayer [1, 1, 2] `shouldBe` [13.0]

      it "calculates correctly for multiple output" $
        let
          nn = buildNNFromList (3, [LayerDefinition ReLU 2]) [1, 4, 2, 5, 3, 6, 7, 8]
          firstLayer = head (nnLayers nn)
        in layerForward firstLayer [1, 1, 2] `shouldBe` [16.0, 28.0]

      it "applies activation" $
        let
          nn = buildNNFromList (3, [LayerDefinition Sigmoid 2]) [1, -1, -1, 1, 1, -1, 1, -1]
          firstLayer = head (nnLayers nn)
        in layerForward firstLayer [1, 1, 1] `shouldBe` [0.5, 0.5]

    describe "layerForwardSet" $ do
      it "calculates correctly for multiple output" $
        let
          nn = buildNNFromList (3, [LayerDefinition ReLU 2]) [1, 4, 2, 5, 3, 6, 7, 8]
          firstLayer = head (nnLayers nn)
          examples = exampleSetX (createExampleSet [([1, 1, 2], 0)])
          result = layerForwardSet firstLayer examples
        in forwardPropA result `shouldBe` fromLists [[16.0], [28.0]]

      it "calculates correctly for multiple examples, multiple output" $
        let
          nn = buildNNFromList (3, [LayerDefinition ReLU 2]) [1, 4, 2, 5, 3, 6, 7, 8]
          firstLayer = head (nnLayers nn)
          examples = exampleSetX (createExampleSet [([1, 1, 2], 0), ([1, 1, 0], 0)])
          result = layerForwardSet firstLayer examples
        in forwardPropA result `shouldBe` fromLists [[16, 12], [28, 16]]

max_stars_repo_name: danielholmes/neural-net

max_issues_repo_name: danielholmes/neural-net

max_forks_repo_name: danielholmes/neural-net


text:
import HLearn.Algebra
import HLearn.Models.Distributions

import Control.Monad
import Control.Monad.ST
import Data.List
import Data.STRef
import Data.Number.LogFloat
import qualified Control.ConstraintKinds as CK

import Statistics.Distribution
import Statistics.Distribution.Normal

import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector.Generic as G
import qualified Data.Foldable as F

import qualified Data.Vector as V
import qualified Data.Foldable as F
size=10^7
main = do
    print $ (foldl' mappend mempty $ map train1dp [(0::Double)..size] :: Gaussian Double)
    putStrLn "done."
--     print $ (train (concat $ replicate (10^6) ["a","b"]) :: Categorical String Double)
--     print $ (train [1..fromIntegral size::Double] :: Gaussian Double)
--     print $ (train (VU.enumFromN (0::Double) size) :: Gaussian Double)
--     print $ normalFromSample $ VU.enumFromN 0 size

max_stars_repo_name: silky/HLearn


text:
{-# OPTIONS_GHC -Wall            #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE TupleSections       #-}

{-|

  Module      : AutoBench.Internal.IO
  Description : AutoBench's internal IO.
  Copyright   : (c) 2018 Martin Handley
  License     : BSD-style
  Maintainer  : martin.handley@nottingham.ac.uk
  Stability   : Experimental
  Portability : GHC

  This module deals with all AutoBench's internal IO, including:

  * System saving to/loading from files;
  * Generating/compiling/executing benchmarking files;
  * Cleaning up temporary files created for/during benchmarking;

-}

{-
   ----------------------------------------------------------------------------
   <TO-DO>:
   ----------------------------------------------------------------------------
   - generateBenchmarks error handling?
   - It would be nice for the generating benchmarking file to be nicely
     formatted;
   - Add more validation to generateBenchmarkingReport;
   - Handle CTRL-C?
-}

module AutoBench.Internal.IO
  (

  -- * IO for benchmarking files
    generateBenchmarkingFile            -- Generate a benchmarking file to benchmark all the test programs in a given test suite
  , generateTestReport                  -- Generate a 'TestReport' that summarises the system's testing phase.
  , compileBenchmarkingFile             -- Compile benchmarking file using zero or more user-specified compiler flags.
  , deleteAllFiles                      -- Delete all files created by the system.
  , deleteBenchmarkingFiles             -- Delete all files created for/during the benchmarking phase.
  , deleteTemporarySystemFiles          -- Delete temporary system files created for/during the benchmarking phase.
  -- * Helper functions
  , anyKeyExit                          -- Press any key to exit.
  , discoverInputFiles                  -- Discover potential input files in the working directory.
  , execute                             -- Execute a file, capturing its output to STDOUT and printing it to the command line.
  , generateBenchmarkingFilename        -- Generate a valid filename for the benchmarking file from the filename of the user input file.
  , nestPutStr                          -- Output documents at a specific level of nesting using 'putStr'.
  , nestPutStrLn                        -- Output documents at a specific level of nesting using 'putStrLn'.
  , spacer                              -- Output @n@ line spaces to the command line.

  ) where

import           Control.Exception         (catch)
import           Control.Exception.Base    (throwIO)
import           Control.Monad             (unless, void)
import           Control.Monad.Catch       (throwM)
import           Criterion.IO              (readJSONReports)
import qualified Data.ByteString           as BS
import qualified Data.ByteString.Char8     as C
import           Data.List                 ( groupBy, isInfixOf, partition, sort
                                           , sortBy )
import qualified Data.Map                  as Map
import           Data.Ord                  (comparing)
import qualified Data.Vector               as V
import qualified DynFlags                  as GHC
import qualified GHC                       as GHC
import qualified GHC.Paths                 as GHC
import           Statistics.Types          (estPoint)
import           System.Directory          ( doesFileExist, getDirectoryContents
                                           , removeFile )
import           System.FilePath.Posix     ( dropExtension, takeBaseName
                                           , takeDirectory, takeExtension )
import           System.IO                 (Handle, hFlush, stdout)
import           System.IO.Error           (isDoesNotExistError)
import qualified Text.PrettyPrint.HughesPJ as PP
import qualified Text.Megaparsec           as MP

import System.Process
  ( ProcessHandle
  , StdStream(..)
  , createProcess
  , getProcessExitCode
  , proc
  , std_out
  )

import Criterion.Types
 ( Report
 , anMean
 , anOutlierVar
 , anRegress
 , anStdDev
 , ovEffect
 , ovFraction
 , regCoeffs
 , regResponder
 , reportAnalysis
 , reportName
 , reportMeasured
 )

import AutoBench.Internal.AbstractSyntax (Id, ModuleName, prettyPrint, qualIdt)
import AutoBench.Internal.UserIO         (printGoodbyeMessage)
import AutoBench.Internal.Utils          (Parser, allEq, integer, symbol)
import AutoBench.Internal.Types
  ( BenchReport(..)
  , DataOpts(..)
  , DataSize(..)
  , InputError(..)
  , SimpleReport(..)
  , SystemError(..)
  , TestReport(..)
  , TestSuite(..)
  , UserInputs(..)
  )

-- * IO for benchmarking files:

-- | Generate a benchmarking file to benchmark all the test programs in a
-- given test suite. This includes generating/supplying necessary test data.
--
-- Note that the names of test programs and sizes of test inputs are encoded
-- into each benchmark's (i.e., test case's) title to keep track of
-- measurements. This allows for simple but necessary validation checks to be
-- performed on the JSON report file created by Criterion to ensure that test
-- results agree with test inputs. (The checks are done by
-- 'generateBenchmarkingReport'.)
generateBenchmarkingFile
  :: FilePath       -- ^ Filepath to save benchmarking file.
  -> ModuleName     -- ^ User input file's module name.
  -> UserInputs     -- ^ Parsed/categorised user inputs (to cross-reference).
  -> Id             -- ^ The chosen test suite's identifier.
  -> TestSuite      -- ^ The chosen test suite.
  -> IO ()
generateBenchmarkingFile fp mn inps tsIdt ts = do
  -- Generate functional call that will in turn generate the appropriate
  -- benchmarks.
  gFunc <- genFunc gen nf unary
  -- Generate file contents and write to file.
  writeFile fp (PP.render $ contents gFunc)

  where
    ---------------------------------------------------------------------------
    -- ** CHANGING THE CONTENTS WILL BREAK THE SYSTEM **
    ---------------------------------------------------------------------------
    -- Note: imports/definitions are qualified to avoid ambiguity.

    contents gFunc = PP.vcat
      [ PP.text ""
      , PP.text "module Main (main) where"
      , PP.text ""
      , PP.text "import qualified AutoBench.Internal.Benchmarking"       -- Import all generation functions.
      , PP.text "import qualified" PP.<+> PP.text mn                     -- Import user input file.
      , PP.text ""
      , PP.text "main :: IO ()"                                          -- Generate a main function.
      , PP.text "main  = AutoBench.Internal.Benchmarking.runBenchmarks"  -- Run benchmarks.
          PP.<+> PP.char '(' PP.<> gFunc PP.<> PP.char ')'               -- Generate benchmarks.
          PP.<+> PP.text (prettyPrint . qualIdt mn $ tsIdt)              -- Identifier of chosen test suite (for run cfg).
      ]

    ---------------------------------------------------------------------------
    -- ** CHANGING THE NAMES OF THESE FUNCTIONS WILL BREAK THE SYSTEM **
    ---------------------------------------------------------------------------
    -- Important note: each function below encodes the name of test programs
    -- and input sizes into the titles of benchmark test cases.
    ---------------------------------------------------------------------------

    -- Generate benchmarking function call.
    -- genFunc gen? nf? unary?
    genFunc :: Bool -> Bool -> Bool -> IO PP.Doc
    -- genBenchmarksGenNfUn:
    -- Generated test data, results to nf, unary test programs.
    genFunc True True True = return
      (genGenFunc "AutoBench.Internal.Benchmarking.genBenchmarksGenNfUn")
    -- genBenchmarksGenWhnfUn:
    -- Generated test data, results to whnf, unary test programs.
    genFunc True False True = return
      (genGenFunc "AutoBench.Internal.Benchmarking.genBenchmarksGenWhnfUn")
     -- genBenchmarksGenNfBin:
     -- Generated test data, results to nf, binary test programs.
    genFunc True  True  False = return
      (genGenFunc "AutoBench.Internal.Benchmarking.genBenchmarksGenNfBin")
    -- genBenchmarksGenWhnfBin:
    -- Generated test data, results to whnf, binary test programs.
    genFunc True  False False = return
      (genGenFunc "AutoBench.Internal.Benchmarking.genBenchmarksGenWhnfBin")
    -- genBenchmarksManNfUn:
    -- User-specified test data, results to nf, unary test programs.
    genFunc False True True =
      genManFunc "AutoBench.Internal.Benchmarking.genBenchmarksManNfUn"
    -- genBenchmarksManWhnfUn:
    -- User-specified test data, results to whnf, unary test programs.
    genFunc False False True =
      genManFunc "AutoBench.Internal.Benchmarking.genBenchmarksManWhnfUn"
    -- genBenchmarksManNfBin:
    -- User-specified test data, results to nf, binary test programs.
    genFunc False True False =
       genManFunc "AutoBench.Internal.Benchmarking.genBenchmarksManNfBin"
    -- genBenchmarksManWhnfBin:
    -- User-specified test data, results to whnf, binary test programs.
    genFunc False False False =
       genManFunc "AutoBench.Internal.Benchmarking.genBenchmarksManWhnfBin"

    -- Generate function call for benchmarks requiring automatically generated
    -- test data.
    genGenFunc :: Id -> PP.Doc
    genGenFunc func = PP.hsep $
        [ PP.text func
        , ppList $ fmap ppTuple qualProgs
        , PP.text (prettyPrint . qualIdt mn $ tsIdt)
        ]

    -- Generate function call for benchmarks using user-specified test data.
    genManFunc :: Id -> IO PP.Doc
    genManFunc func = do
      dat <- getManualDatIdt (_dataOpts ts)
      return $ PP.hsep
        [ PP.text func
        , ppList $ fmap ppTuple qualProgs
        , PP.text (prettyPrint . qualIdt mn $ tsIdt)
        , PP.text (prettyPrint . qualIdt mn $ dat)
        ]

    -- Pretty print an (identifier, program) tuple.
    ppTuple :: Id -> PP.Doc
    ppTuple idt = PP.char '('
      PP.<> PP.text (show idt)
      PP.<> PP.text ", "
      PP.<> PP.text idt
      PP.<> PP.char ')'

    -- Pretty print a comma-separated list.
    ppList :: [PP.Doc] -> PP.Doc
    ppList docs = PP.hcat $
      PP.char '[' : (PP.punctuate (PP.text ", ") docs) ++ [PP.char ']']

    -- Helpers

    -- Classifiers:
    unary = head (_progs ts) `elem` fmap fst (_unaryFuns inps)  -- Unary test programs?
    nf    = _nf ts                                              -- NF test results?
    gen   = case _dataOpts ts of                                -- Generate test data?
      Manual{} -> False
      Gen{}    -> True

    -- All test programs are qualified with the module name.
    qualProgs = fmap (prettyPrint . qualIdt mn) (_progs ts)

    -- Get the identifier of User-specified test data from 'DataOpts'.
    -- Questionable throwM error handling here? But better than a partial function.
    getManualDatIdt :: DataOpts -> IO Id
    getManualDatIdt (Manual s) = return s
    getManualDatIdt Gen{} =
      throwM (InternalErr $ "generateBenchmarks: unexpected 'Gen' setting.")

-- | Use GHC to compile the benchmarking file. Compile using the flags
-- specified in the 'TestSuite' used to generate the benchmarking file.
-- Includes the location of the user input file as a source directory in case
-- it is not the working directory. Any invalid compiler flags are returned
-- in case they affect test results.
compileBenchmarkingFile
  :: FilePath     -- ^ Benchmarking filepath.
  -> FilePath     -- ^ User input filepath.
  -> [String]     -- ^ GHC compiler flags.
  -> IO [String]  -- ^ Invalid compiler flags.
compileBenchmarkingFile benchFP userFP flags = do
  (success, invalidFlags) <- GHC.runGhc (Just GHC.libdir) $ do
    dflags <- GHC.getSessionDynFlags
    -- Add flags specified in 'TestSuite's '_ghcFlags' list.
    (dflags', invalidFlags, _) <- GHC.parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags)
    -- Include location of input file in import paths.
    let dflags'' = dflags' { GHC.importPaths = GHC.importPaths dflags ++ [takeDirectory userFP] }
    void $ GHC.setSessionDynFlags dflags''
    target <- GHC.guessTarget benchFP Nothing
    GHC.setTargets [target]
    success <- GHC.succeeded <$> GHC.load GHC.LoadAllTargets
    return (success, fmap GHC.unLoc invalidFlags)
  -- Throw an error if compilation fails.
  unless success (throwIO $ FileErr "Compilation failed.")
  -- Notify user of any invalid flags in case they affect test results.
  return invalidFlags

-- | Delete all files created for/during the benchmarking phase
-- of testing, including:
--
-- * Benchmarking Haskell module;
-- * Benchmarking binary;
-- * *.o, *.hi files;
-- * Temporary system files e.g., Criterion JSON report file.
deleteAllFiles :: FilePath -> FilePath -> [FilePath] -> IO ()
deleteAllFiles fBench fUser sysTmps =
  mapM_ removeIfExists (fUsers ++ fBenchs ++ sysTmps)
  where
    fUsers   = fmap (dropExtension fUser ++) exts
    fBench'  = dropExtension fBench
    fBenchs  = fBench : fBench' : fmap (fBench' ++ ) exts
    exts     = [".o", ".hi"]

    removeIfExists fp = removeFile fp `catch` handleExists
      where handleExists e | isDoesNotExistError e = return ()
                           | otherwise = throwIO e

-- | Delete files created for/during the benchmarking phase of testing,
-- including:
--
-- * Benchmarking Haskell module;
-- * Benchmarking binary;
-- * *.o, *.hi files;
deleteBenchmarkingFiles :: FilePath -> FilePath -> IO ()
deleteBenchmarkingFiles fBench fUser =
  mapM_ removeIfExists (fUsers ++ fBenchs)
  where
    fUsers   = fmap (dropExtension fUser ++) exts
    fBench'  = dropExtension fBench
    fBenchs  = fBench : fBench' : fmap (fBench' ++ ) exts
    exts     = [".o", ".hi"]

    removeIfExists fp = removeFile fp `catch` handleExists
      where handleExists e | isDoesNotExistError e = return ()
                           | otherwise = throwIO e

-- | Delete temporary files created for/during the benchmarking phase
-- of testing, e.g., Criterion JSON report file.
deleteTemporarySystemFiles :: [FilePath] -> IO ()
deleteTemporarySystemFiles systemTemps =
  mapM_ removeIfExists systemTemps
  where
    removeIfExists fp = removeFile fp `catch` handleExists
      where handleExists e | isDoesNotExistError e = return ()
                           | otherwise = throwIO e

-- | Generate a test report to summarise the system's testing phase. This
-- includes parsing the JSON benchmark report file created by Criterion
-- in order to generate a 'BenchReport': see 'generateBenchmarkingReport'.
generateTestReport
  :: ModuleName -- Module name of user input file.
  -> TestSuite  -- TestSuite used to generate benchmarking file.
  -> FilePath   -- Filepath of Criterion's JSON report.
  -> Bool       -- Whether test programs are semantically equal according to QuickCheck testing.
  -> IO TestReport
generateTestReport mn ts fp eql = do
  -- Generate benchmarking report.
  benchRep <- generateBenchmarkingReport mn ts fp
  return TestReport
           { -- Copy 'TestSuite' settings:
             _tProgs    = sort $ fmap (prettyPrint . qualIdt mn) (_progs ts)
           , _tDataOpts = _dataOpts ts
           , _tNf       = _nf ts
           , _tGhcFlags = _ghcFlags ts
             -- Other test results:
           , _eql       = eql
           , _br        = benchRep
           }

-- | Parse a Criterion JSON report file and use the parsed '[Report]'s to
-- generate a 'BenchReport' that summarises the benchmarking phase of testing.
-- The 'BenchReport' includes a 'SimpleReport' for each test case and baseline
-- measurements, if applicable.
--
-- Some background information:
-- When generating the benchmarking file using 'generateBenchmarkingFile',
-- the names of test programs and input sizes are encoded into the titles of
-- benchmarks. The 'Report' titles are decoded here and checked against the
-- settings of the 'TestSuite used to generate the benchmarks initially.
generateBenchmarkingReport                                                                          -- <TO-DO>: Check input size against the 'UserInputs' data structure.
  :: ModuleName -- Module name of user input file.
  -> TestSuite  -- TestSuite used to generate benchmarking file.                                    -- <TO-DO>: Are these checks sufficient?
  -> FilePath   -- Filepath of Criterion's JSON report.
  -> IO BenchReport
generateBenchmarkingReport mn ts fp = do
  -- Check file exists.
  exists <- doesFileExist fp
  unless exists (throwIO $ FileErr $ "Cannot locate Criterion report: " ++ fp)
  -- Generate 'BenchReport' largely from Criterion's JSON results.
  -- Parse Criterion JSON report.
  readJSONReports fp >>= \case
    -- Parse error.
    Left err -> throwIO (FileErr $ "Invalid Criterion report: " ++ err)
    -- Parsed 'ReportFileContents', only care about 'Report's.
    Right (_, _, reps) ->
      -- Reports are organised differently depending on whether baseline
      -- measurements were taken so separate the baseline measurements.
      let (bls, nonBls) = partition (("Baseline for" `isInfixOf`) . reportName) reps
      in case bls of
        -- If there isn't any baseline measurements, all reports are
        -- test program measurements and have titles such as
        -- Input Size 5/p1    Input Size 5/p2     Input Size 5/p3    for unary.
        -- Input Sizes (5, 5)/p1     Input Sizes (5, 5)/p2           for binary.
        [] -> case noBaselines reps of -- Use 'parseRepName' to parse titles to
                                       -- (Id, DataSize) tuples.
          Nothing -> throwIO $ FileErr $ "Incompatible Criterion report."
          Just xs -> return $ convertReps [] (zip reps xs)
        -- If baseline measurements have been taken, then reports relating
        -- to test program measurements have titles such as:
        -- With Baseline/Input Size 5/p1 etc.
        -- And baseline measurements have titles such as:
        -- With Baseline/Baseline Measurement for Input Size 5.
        _  -> case withBaselines bls nonBls of
           -- Use 'parseRepName' to parse titles to (Id, DataSize) tuples
           -- and 'parseBaseline' to parse baseline measurements to same format.
          Nothing -> throwIO $ FileErr $ "Incompatible Criterion report."
          Just (nBls, nNonBls) ->
            return $ convertReps (zip bls nBls) (zip nonBls nNonBls)

    where
      -- Qualified '_progs' list
      progs = sort $ fmap (prettyPrint . qualIdt mn) (_progs ts)

      -- The overall idea is that the titles of the Criterion reports encode
      -- the names of test programs and the sizes of test inputs. The titles
      -- are decoded and the parsed data is checked against the settings of the
      -- 'TestSuite' used to generate the benchmarks in the first place. This is
      -- perhaps a little over cautious but I think it's worth it.

      -- Parse the report titles of the baseline and test program measurements.
      withBaselines
        :: [Report] -- Baseline measurements.
        -> [Report] -- Test program measurements.
        -> Maybe ([(Id, DataSize)], [(Id, DataSize)])
      withBaselines _ [] = Nothing
      withBaselines bls nonBls = do

        -- Parse titles of baseline measurements. dropWhile (/= 'I') "With
        -- Baseline/Baseline Measurement for Input Size 5" ===> "Input Size 5",
        -- then can use 'parseBaseline'.
        nBls <- sequence $ fmap (MP.parseMaybe parseBaseline .
          dropWhile (/= 'I') . reportName) bls

        -- Parse titles of test program measurements.
        -- dropWhile (/= 'I') "With Baseline/Input Size 5/p1" ===> "Input Size
        -- 5/p1", then can use 'parseRepName'.
        nNonBls <- sequence $ fmap (MP.parseMaybe parseRepName .
          dropWhile (/= 'I') . reportName) nonBls
        -- Group parse results relating to the same test program by grouping
        -- by identifier.

        let nNonBlss = groupBy (\x1 x2 -> fst x1 == fst x2) $
                         sortBy (comparing fst) nNonBls
        -- The size range of test data for each test program.
            sizes = fmap (sort . fmap snd) nNonBlss
        -- Validation checks:
        if | not (allEq $ sort (fmap snd nBls) : sizes) -> Nothing                        -- (1) Make sure same number of measurements for each program
                                                                                --     and all have same input sizes.
           | not $ (sort $ fmap (fst . head) nNonBlss) == progs -> Nothing                -- (2) Make sure test programs match those in the 'TestSuite's '_progs' list.
                                                                                -- (3) <TO-DO>: Some form of input size check against 'UserInputs' data structure.
           | otherwise -> Just (nBls, nNonBls)

      -- Parse the report titles of just the test program measurements.
      noBaselines :: [Report] -> Maybe [(Id, DataSize)]
      noBaselines [] = Nothing
      noBaselines reps = do
        -- Parse titles of test program measurements.
        xs <- sequence $ fmap (MP.parseMaybe parseRepName . reportName) reps
        -- Group parse results relating to the same test program.
        let xss = groupBy (\x1 x2 -> fst x1 == fst x2) $ sortBy (comparing fst) xs
        -- The size range of test data for each test program.
            sizes = fmap (sort . fmap snd) xss
        -- Validation checks:
        if | not (allEq sizes) -> Nothing                                                 -- (1) Make sure same number of measurements for each program
                                                                                --     and all have same input sizes.
           | not $ (sort $ fmap (fst . head) xss) == progs -> Nothing                     -- (2) Make sure test programs match those in the 'TestSuite's '_progs' list.
                                                                                -- (3) <TO-DO>: Some form of input size check against 'UserInputs' data structure.
           | otherwise -> Just xs

      -- Convert a set of Criterion 'Report's from the same test into a
      -- 'BenchReport' by generating a 'SimpleReport' for each test case
      -- and baseline measurement. Copy over some settings from the 'TestSuite'
      -- used to generate the benchmarks initially.
      convertReps
        :: [(Report, (Id, DataSize))] -- Baseline measurements.
        -> [(Report, (Id, DataSize))] -- Test program measurements.
        -> BenchReport
      convertReps bls nonBls =
        BenchReport
          { -- Generate test program 'SimpleReport's.
            _reports = fmap (fmap $ uncurry toSimpleReport) .
              -- Group by test program's identifier.
              groupBy (\(_, (idt1, _)) (_, (idt2, _)) -> idt1 == idt2) .
              -- Sort by test program's identifier.
              sortBy  (\(_, (idt1, _)) (_, (idt2, _)) -> compare idt1 idt2) $ nonBls
          -- Generate 'SimpleReport's for baseline measurements.
          , _baselines = fmap (uncurry toSimpleReport) $ sortBy (comparing snd) bls
          }

        where

         -- Convert a Criterion 'Report' to a 'SimpleReport' for a given
         -- (test program identifier, input size).
         toSimpleReport :: Report -> (Id, DataSize) -> SimpleReport
         toSimpleReport rep (idt, size) =
           SimpleReport
              { _name    = idt
              , _size    = size
              , _runtime = getRegressTime -- Use the runtime predicted by linear regression, /not mean/.
                                          -- ** But fall back on mean if something goes wrong **.
               -- Note: Criterion uses a large number of samples to calculate its statistics.
               -- Each sample itself is a number of iterations, but then the measurements are
               -- standardised, so length here should work(?)
              , _samples    = V.length (reportMeasured rep)
              , _stdDev     = estPoint   . anStdDev     . reportAnalysis $ rep
              , _outVarEff  = ovEffect   . anOutlierVar . reportAnalysis $ rep
              , _outVarFrac = ovFraction . anOutlierVar . reportAnalysis $ rep
              }
           where
             -- Lookup the runtime predicted by linear regression.
             getRegressTime = case filter (\reg -> regResponder reg == "time")
               (anRegress $ reportAnalysis rep) of
                 [x] -> case estPoint <$> Map.lookup "iters" (regCoeffs x) of
                          Just d -> d
                          -- Fall back on mean.
                          Nothing -> mean
                 -- Fall back on mean.
                 _ -> mean

               where mean = estPoint . anMean . reportAnalysis $ rep

      -- Parser helpers to decode report titles: ------------------------------

      -- Parse a report's title into the corresponding test
      -- program's identifier and input size.
      parseRepName :: Parser (Id, DataSize)
      parseRepName  = do
        -- E.g., "Input Sizes (5, 5)/p1"
        -- E.g., "Input Size 5/p2"
        void $ (symbol "Input Sizes") MP.<|> (symbol "Input Size")
        ds <- parseDataSize
        void $ symbol "/"
        idt <- MP.manyTill MP.anySingle MP.eof
        return (idt, ds)

      -- Parse the encoded baseline size from the name of a Criterion report.
      -- E.g., Input Sizes (5, 5) or Input Size 5
      parseBaseline :: Parser (Id, DataSize)
      parseBaseline = do
        void $ (symbol "Input Sizes") MP.<|> (symbol "Input Size")
        ("Baseline measurements",) <$> parseDataSize                                                -- <TO-DO>: This is too important to be a string.

      -- Parse the encoded data size from the name of a Criterion report.
      -- E.g., (5, 5) or 5.
      parseDataSize :: Parser DataSize
      parseDataSize  = (do
        void $ symbol "("
        n1 <- integer
        void $ symbol ","
        n2 <- integer
        void $ symbol ")"
        return (SizeBin n1 n2)) MP.<|> (SizeUn <$> integer)

-- * Helper functions

-- | Execute a file, capturing its output to STDOUT and printing it to the
-- command line.
execute :: FilePath -> IO ()
execute fp = do
  let p = (proc fp []) { std_out = CreatePipe }
  (_, Just out, _, ph) <- createProcess p
  printOutput ph out
  where
    printOutput :: ProcessHandle -> Handle -> IO ()
    printOutput ph h = go
      where
        go = do
          bs <- BS.hGetNonBlocking h (64 * 1024)
          printLine bs
          ec <- getProcessExitCode ph
          maybe go (const $ do
            end <- BS.hGetContents h
            printLine end) ec
        printLine bs = unless (BS.null bs) (C.putStr bs)

-- | Generate a valid filename for the benchmarking file from the filename of
-- the user input file.
generateBenchmarkingFilename :: String -> IO String
generateBenchmarkingFilename s = do
  b1 <- doesFileExist s'
  b2 <- doesFileExist (addSuffix s')
  if b1 || b2
    then go s' 0
    else return (addSuffix s')
  where
    go :: String -> Int -> IO String
    go s_ i = do
      let s_' = s_ ++ show i
      b1 <- doesFileExist s_'
      b2 <- doesFileExist (addSuffix s_')
      if b1 || b2
        then go s_ (i + 1)
        else return (addSuffix s_')

    addSuffix = (++ ".hs")
    s'        = takeDirectory s ++ "/Bench" ++ takeBaseName s

-- | Discover potential input files in the working directory.
discoverInputFiles :: IO [FilePath]
discoverInputFiles  = filter ((== ".hs") . takeExtension) <$> getDirectoryContents "."

-- | Press any key to exit.
anyKeyExit :: IO ()
anyKeyExit  = do
  putStr "Press any key to exit... "
  hFlush stdout
  -- Want to use Haskeline here but can't.
  -- https://github.com/judah/haskeline/issues/74
  void getChar
  printGoodbyeMessage

-- | Output @n@ line spaces to the command line.
spacer :: Int -> IO ()
spacer n = putStrLn (replicate (n - 1) '\n') >> hFlush stdout

-- | Output documents at a specific level of nesting using 'putStr'.
nestPutStr :: Int -> PP.Doc -> IO ()
nestPutStr n doc = putStr (PP.render $ PP.nest n doc) >> hFlush stdout

-- | Output documents at a specific level of nesting using 'putStrLn'.
nestPutStrLn :: Int -> PP.Doc -> IO ()
nestPutStrLn n doc = putStrLn (PP.render $ PP.nest n doc) >> hFlush stdout

max_stars_repo_name: recursion-ninja/AutoBench

max_issues_repo_name: recursion-ninja/AutoBench

max_forks_repo_name: recursion-ninja/AutoBench