text:
module Main
  ( main
  ) where

import           Control.Arrow
import           Control.Monad
import qualified Graphics.UI.GLFW    as GLFW
import           Lens.Micro.Platform ((%~), (&), (.~), (^.))

--import           Numeric.LinearAlgebra
import           Application
import           Cmd
import           Initializable
import           Keyboard
import           Matrix
import           MyState
import           Primitives.Cube
import           Primitives.Square
import           Rotation
import           View

newtype Action = Action
  { runAction :: MyState -> Update MyState
  }

type Update a = State (Cmd Action) a

-- Update
blueGreen Blue  = Green
blueGreen Green = Blue

noRun :: Action
noRun = Action return

run :: (MyState -> Update MyState) -> Action
run = Action

run1 :: (a -> MyState -> Update MyState) -> a -> Action
run1 f a = Action (f a)

run2 :: (a -> b -> MyState -> Update MyState) -> a -> b -> Action
run2 f a b = Action (f a b)

shutdown :: MyState -> Update MyState
shutdown state = do
  doPrint "Will shutdown"
  doShutdown
  return state

swapColor :: MyState -> Update MyState
swapColor state = return $ state & color %~ blueGreen

askTime :: Update ()
askTime = getTime (run timeFail) (run1 gotTime)

cameraMovement timeDiff = do
  keyPress GLFW.Key'W (run $ moveCamera timeDiff forward) noRun
  keyPress GLFW.Key'S (run $ moveCamera timeDiff (negate . forward)) noRun
  keyPress GLFW.Key'A (run $ moveCamera timeDiff leftward) noRun
  keyPress GLFW.Key'D (run $ moveCamera timeDiff (negate . leftward)) noRun
  keyPress GLFW.Key'Space (run $ moveCamera timeDiff upward) noRun
  keyPress GLFW.Key'C (run $ moveCamera timeDiff (negate . upward)) noRun

cubeMovement timeDiff = do
  keyPress GLFW.Key'Up (run $ moveSquare timeDiff yHat) noRun
  keyPress GLFW.Key'Down (run $ moveSquare timeDiff (-yHat)) noRun
  keyPress GLFW.Key'Right (run $ moveSquare timeDiff xHat) noRun
  keyPress GLFW.Key'Left (run $ moveSquare timeDiff (-xHat)) noRun

updateSpacing t = ((sin (t / 2) + 1) * 5) + 2

gotTime :: Double -> MyState -> Update MyState
gotTime t state = do
  askTime
  let timeDiff = t - state ^. lastTime
  cameraMovement timeDiff
  cubeMovement timeDiff
  return $ state & lastTime .~ t & spacing .~ updateSpacing t

timeFail :: MyState -> Update MyState
timeFail state = do
  askTime
  doPrint "Time: failed"
  return state

moveSquare distance dir state =
  return $ state & cubePos %~
  (+ (dir * realToFrac (state ^. movementSpeed) * realToFrac distance))

moveCamera distance dirF state =
  return $ state & camera . cameraPosition %~
  (+ (dirF state * realToFrac (state ^. movementSpeed) * realToFrac distance))

forward state = rotateV (negate zHat) $ mkXYRotation x y
  where
    (x, y) = state ^. camera . cameraRotation

leftward state = negate $ cross (forward state) yHat

upward state = yHat

mouseMoved x y state
  | abs x < 300 && abs y < 300 =
    return $! state & camera . cameraRotation %~
    (first (+ (negate x * 0.0001)) >>> second (+ (negate y * 0.0001)))
  | otherwise = return state

resize' :: Int -> Int -> MyState -> Update MyState
resize' w h state =
  return $ state & aspectRatio .~ fromIntegral w / fromIntegral h

keymap =
  concat
    [ [KeyPressed GLFW.Key'Escape (\_ -> run shutdown)]
    , [ KeyPressed
          GLFW.Key'M
          (\_ -> run (\state -> stopCaptureMouse >> return state))
      ]
    , KeyState <$> [GLFW.Key'Space] <*>
      [GLFW.KeyState'Pressed, GLFW.KeyState'Repeating] <*>
      [\_ -> run swapColor]
    ]

initialAction :: MyState -> Action
initialAction state =
  Action $ \_ -> do
    askTime
    return state

setup = do
  square <- create
  cube <- create
  terrain' <- create
  let state =
        initialState & squares .~ [square] & cubes .~ [cube] & terrain .~
        [terrain']
  return $ initialAction state

initState = do
  keyPresses keymap
  resize $ run2 resize'
  runIO setup
  captureMouse $ run2 mouseMoved
  return initialState

myApplication = Application runAction view

main :: IO ()
main = start DefaultConfig initState myApplication

max_stars_repo_name: aelg/haskell-render

max_issues_repo_name: aelg/haskell-render

max_forks_repo_name: aelg/haskell-render


text:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE FlexibleContexts #-}

--x-- import Turtle hiding (sortBy,char,text)
import Lib (someFunc)
import CPVO.Numeric (integrateAll,testFunc,getY0,delta)
import CPVO.IO
import CPVO.IO.MMOM
--x--
--x-- --import Turtle.Helper
--x-- import qualified Control.Foldl as Fold
import System.Environment (getArgs)
-- import qualified Data.Text as T
-- import qualified Data.Text.IO as T
-- import qualified Data.Text.Read as T
-- --x-- --import qualified Data.Text.Format as T
-- --x-- import Text.Printf as TP
-- import Data.List.Split
-- import Data.List
-- import Data.Maybe
-- import Data.Either (rights)
-- --x-- -------------------------
-- import Numeric.LinearAlgebra
-- --x-- import Numeric.LinearAlgebra.Devel (readMatrix)
-- --x-- import Numeric.LinearAlgebra.Data hiding (find)
-- import Data.Char (ord)
-- --x-- import System.Process as SP
-- --x-- import System.IO
-- --x-- -------------------------
-- --x-- import Text.PrettyPrint.Boxes hiding ((<>),cols,rows)
-- --x-- import qualified Text.PrettyPrint.Boxes as TB
-- --x-- import Data.List
-- --x-- -- ===============================================
-- -- start of Accelerate
-- -- import Data.Array.Accelerate              as A
-- -- import Data.Array.Accelerate.LLVM.Native  as CPU
-- -- import Data.Array.Accelerate.LLVM.PTX     as GPU
-- --

main = do
  let testArgs = [ "table02.tex"
                 ,"Atomic magnetic moment"
                 ,"{Atom Number}|{Atomic Orbital}|{Spin Density Integration}|{PDOS Integration}|{Difference}"
                 ,"-9:6","25","T","o","1","nico2o4"
                 ,"extendedNiCo2O4.normal/nico2o4.0GGA"
                 ,"Ni:Ni#3d:6:7:9:8:10","Co:Co#3d:6:7:8:9:10","O:O#2p:3:4:5" ]

  plotPDOS testArgs
  putStrLn "========beres======="

ext: hs

max_stars_repo_name: hasanalrasyid/cpvoh

max_issues_repo_name: hasanalrasyid/cpvoh

max_forks_repo_name: hasanalrasyid/cpvoh


text:
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

#if __GLASGOW_HASKELL__ < 708
{-# LANGUAGE Trustworthy #-}
#endif

#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 'R_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
-------------------------------------------------------------------------------
-- |
-- Module      :  Silica.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 @'R_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 'R_Getter' s a = forall r. 'Getting' r s a@
--
-- However, for 'R_Getter' (but not for 'Getting') we actually permit any
-- functor @f@ which is an instance of both 'Functor' and 'Contravariant':
--
-- @type 'R_Getter' s a = forall f. ('Contravariant' f, 'Functor' f) => (a -> f a) -> s -> f s@
--
-- Everything you can do with a function, you can do with a 'R_Getter', but
-- note that because of the continuation passing style ('.') composes them
-- in the opposite order.
--
-- Since it is only a function, every 'R_Getter' obviously only retrieves a
-- single value for a given input.
--
-- A common question is whether you can combine multiple 'R_Getter's to
-- retrieve multiple values. Recall that all 'R_Getter's are 'R_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 'R_Fold's
-- together:
--
-- >>> import Data.Monoid
-- >>> (1, 2, 3, 4, 5) ^.. (_2 <> _3 <> _5)
-- [2,3,5]
--
-------------------------------------------------------------------------------
module Silica.Getter
  (
  -- * R_Getters
    R_Getter, R_IndexedGetter
  , Getting, IndexedGetting
  , Accessing
  -- * Building R_Getters
  , to
  , uto
  , xto
  , ito
  , like
  , ilike
  -- * Combinators for R_Getters and R_Folds
  , (^.)
  , view, views
  , use, uses
  , listening, listenings
  -- * Indexed R_Getters
  -- ** Indexed R_Getter Combinators
  , (^@.)
  , iview, iviews
  , iuse, iuses
  , ilistening, ilistenings
  -- * Implementation Details
  , Contravariant(..)
  , pgetting
  , Const(..)
  ) where

import Control.Applicative
import Silica.Internal.Indexed
import Silica.Type
import Control.Monad.Reader.Class as Reader
import Control.Monad.State        as State
import Control.Monad.Writer       as Writer
import Data.Functor.Contravariant
import Data.Profunctor
import Data.Profunctor.Unsafe

-- $setup
-- >>> :set -XNoR_OverloadedStrings
-- >>> import Silica
-- >>> 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 ^., ^@.

asGetter :: AsGetter k => Optic' k s a -> Getter s a
asGetter = sub

asGetting :: AsGetting r k => Optic' k s a -> Getting r s a
asGetting = sub

asIndexedGetter :: AsIndexedGetter i k => Optic' k s a -> IndexedGetter i s a
asIndexedGetter = sub

asIndexedGetting :: AsIndexedGetting i r k => Optic' k s a -> IndexedGetting i r s a
asIndexedGetting = sub

runGetter :: AsGetter k => Optic' k s a -> R_Getter s a
runGetter = runOptic . asGetter

runGetting :: AsGetting r k => Optic' k s a -> R_Getting r s a
runGetting = runOptic . asGetting

-- runIndexedGetter :: AsIndexedGetter i k => Optic' k s a -> R_IndexedGetter i s a
-- runIndexedGetter = runOptic . asIndexedGetter

-------------------------------------------------------------------------------
-- R_Getters
-------------------------------------------------------------------------------

-- | Build an (index-preserving) 'R_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) -> 'R_IndexPreservingGetter' s a
-- @
to :: (s -> a) -> IndexPreservingGetter s a
to = xto
{-# INLINE to #-}

-- | Index-preserving 'to', for consistency
xto :: (s -> a) -> IndexPreservingGetter s a
xto k = Optic (rto k)
{-# INLINE xto #-}

-- | Unindexed 'to'
uto :: (s -> a) -> Getter s a
uto k = Optic (rto k)
{-# INLINE uto #-}

-- | General 'to'.
gto :: (Profunctor p, Contravariant f) => (s -> a) -> Proptic' p f s a
gto k = Optic (rto k)
{-# INLINE gto #-}

-- | Raw 'to'
rto :: (Profunctor p, Contravariant f) => (s -> a) -> R_Optic' p f s a
rto k = dimap k (contramap k)
{-# INLINE rto #-}

-- pto :: (Profunctor p, Contravariant f, AsProptic p f k) => (s -> a) -> Optic' k s a
-- pto k = Optic (rto k)
-- {-# INLINE pto #-}

ito :: (s -> (i, a)) -> IndexedGetter i s a
ito k = Optic (rito k)
{-# INLINE ito #-}

gito :: (Indexable i p, Contravariant f) => (s -> (i, a)) -> Over' p f s a
gito k = Optic (rito k)
{-# INLINE gito #-}

rito :: (Indexable i p, Contravariant f) => (s -> (i, a)) -> R_Over' p f s a
rito k = dimap k (contramap (snd . k)) . uncurry . indexed
{-# INLINE rito #-}

-- | Build an constant-valued (index-preserving) 'R_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 'R_Fold'
-- e.g. @foo `failing` 'like' 0@
--
-- @
-- 'like' :: a -> 'R_IndexPreservingGetter' s a
-- like :: (Profunctor p, Contravariant f, Functor f) => a -> R_Optic' p f s a
-- @
like :: a -> IndexPreservingGetter s a
like = xlike
{-# INLINE like #-}

xlike :: a -> IndexPreservingGetter s a
xlike a = xto (const a)
{-# INLINE xlike #-}

ulike :: a -> Getter s a
ulike a = uto (const a)
{-# INLINE ulike #-}

glike :: (Profunctor p, Contravariant f) => a -> Proptic' p f s a
glike a = gto (const a)
{-# INLINE glike #-}

ilike :: i -> a -> IndexedGetter i s a
ilike i a = ito (const (i, a))
{-# INLINE ilike #-}

gilike :: (Indexable i p, Contravariant f) => i -> a -> Over' p f s a
gilike i a = gito (const (i, a))
{-# INLINE gilike #-}

-- | When you see this in a type signature it indicates that you can
-- pass the function a 'R_Lens', 'R_Getter',
-- 'Control.R_Lens.R_Traversal.R_Traversal', 'Control.R_Lens.R_Fold.R_Fold',
-- 'Control.R_Lens.R_Prism.R_Prism', 'Control.R_Lens.R_Iso.R_Iso', or one of
-- the indexed variants, and it will just \"do the right thing\".
--
-- Most 'R_Getter' combinators are able to be used with both a 'R_Getter' or a
-- 'Control.R_Lens.R_Fold.R_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 'R_Lens', 'Control.R_Lens.R_Traversal.R_Traversal' and
-- 'Control.R_Lens.R_Iso.R_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.R_Lens.R_Fold.R_Fold' (or
-- 'Control.R_Lens.R_Traversal.R_Traversal'), otherwise you can only pass this a
-- 'R_Getter' or 'R_Lens'.
type R_Getting r s a = (a -> Const r a) -> s -> Const r s

-- | Used to consume an 'Control.R_Lens.R_Fold.R_IndexedFold'.
type R_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 'R_Getter', 'Control.R_Lens.R_Iso.R_Iso' or
-- 'R_Lens' or the result of folding over all the results of a
-- 'Control.R_Lens.R_Fold.R_Fold' or 'Control.R_Lens.R_Traversal.R_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"
--
--
-- R_As 'view' is commonly used to access the target of a 'R_Getter' or obtain a monoidal summary of the targets of a 'R_Fold',
-- It may be useful to think of it as having one of these more restricted signatures:
--
-- @
-- 'view' ::             'R_Getter' s a     -> s -> a
-- 'view' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Fold.R_Fold' s m       -> s -> m
-- 'view' ::             'Control.R_Lens.R_Iso.R_Iso'' s a       -> s -> a
-- 'view' ::             'R_Lens'' s a      -> s -> a
-- 'view' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Traversal.R_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             => 'R_Getter' s a     -> m a
-- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.R_Lens.R_Fold.R_Fold' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'Control.R_Lens.R_Iso.R_Iso'' s a       -> m a
-- 'view' :: 'MonadReader' s m             => 'R_Lens'' s a      -> m a
-- 'view' :: ('MonadReader' s m, 'Data.Monoid.Monoid' a) => 'Control.R_Lens.R_Traversal.R_Traversal'' s a -> m a
-- @
view :: (MonadReader s m, AsGetting a k) => Optic' k s a -> m a
view l = Reader.asks (getConst #. runGetting l Const)
{-# INLINE view #-}

-- | View a function of the value pointed to by a 'R_Getter' or 'R_Lens' or the result of
-- folding over the result of mapping the targets of a 'Control.R_Lens.R_Fold.R_Fold' or
-- 'Control.R_Lens.R_Traversal.R_Traversal'.
--
-- @
-- 'views' l f ≡ 'view' (l '.' 'to' f)
-- @
--
-- >>> views (to f) g a
-- g (f a)
--
-- >>> views _2 length (1,"hello")
-- 5
--
-- R_As 'views' is commonly used to access the target of a 'R_Getter' or obtain a monoidal summary of the targets of a 'R_Fold',
-- It may be useful to think of it as having one of these more restricted signatures:
--
-- @
-- 'views' ::             'R_Getter' s a     -> (a -> r) -> s -> r
-- 'views' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Fold.R_Fold' s a       -> (a -> m) -> s -> m
-- 'views' ::             'Control.R_Lens.R_Iso.R_Iso'' s a       -> (a -> r) -> s -> r
-- 'views' ::             'R_Lens'' s a      -> (a -> r) -> s -> r
-- 'views' :: 'Data.Monoid.Monoid' m => 'Control.R_Lens.R_Traversal.R_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             => 'R_Getter' s a     -> (a -> r) -> m r
-- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Fold.R_Fold' s a       -> (a -> r) -> m r
-- 'views' :: 'MonadReader' s m             => 'Control.R_Lens.R_Iso.R_Iso'' s a       -> (a -> r) -> m r
-- 'views' :: 'MonadReader' s m             => 'R_Lens'' s a      -> (a -> r) -> m r
-- 'views' :: ('MonadReader' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Traversal.R_Traversal'' s a -> (a -> r) -> m r
-- @
--
-- @
-- 'views' :: 'MonadReader' s m => 'Getting' r s a -> (a -> r) -> m r
-- @
views :: (MonadReader s m, AsLensLike (Const r) k) => Optic' k s a -> (a -> r) -> m r
views l f = Reader.asks (getConst #. runLensLike l (Const #. f))
{-# INLINE views #-}

-- | View the value pointed to by a 'R_Getter' or 'R_Lens' or the
-- result of folding over all the results of a 'Control.R_Lens.R_Fold.R_Fold' or
-- 'Control.R_Lens.R_Traversal.R_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 -> 'R_Getter' s a     -> a
-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.R_Lens.R_Fold.R_Fold' s m       -> m
-- ('^.') ::             s -> 'Control.R_Lens.R_Iso.R_Iso'' s a       -> a
-- ('^.') ::             s -> 'R_Lens'' s a      -> a
-- ('^.') :: 'Data.Monoid.Monoid' m => s -> 'Control.R_Lens.R_Traversal.R_Traversal'' s m -> m
-- @
(^.) :: AsGetting a k => s -> Optic' k s a -> a
s ^. l = getConst (runGetting l Const s)
{-# INLINE (^.) #-}

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

-- | Use the target of a 'R_Lens', 'Control.R_Lens.R_Iso.R_Iso', or
-- 'R_Getter' in the current state, or use a summary of a
-- 'Control.R_Lens.R_Fold.R_Fold' or 'Control.R_Lens.R_Traversal.R_Traversal' that points
-- to a monoidal value.
--
-- >>> evalState (use _1) (a,b)
-- a
--
-- >>> evalState (use _1) ("hello","world")
-- "hello"
--
-- @
-- 'use' :: 'MonadState' s m             => 'R_Getter' s a     -> m a
-- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Fold.R_Fold' s r       -> m r
-- 'use' :: 'MonadState' s m             => 'Control.R_Lens.R_Iso.R_Iso'' s a       -> m a
-- 'use' :: 'MonadState' s m             => 'R_Lens'' s a      -> m a
-- 'use' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Traversal.R_Traversal'' s r -> m r
-- @
use :: (MonadState s m, AsGetting a k) => Optic' k s a -> m a
use l = State.gets (view l)
{-# INLINE use #-}

-- | Use the target of a 'R_Lens', 'Control.R_Lens.R_Iso.R_Iso' or
-- 'R_Getter' in the current state, or use a summary of a
-- 'Control.R_Lens.R_Fold.R_Fold' or 'Control.R_Lens.R_Traversal.R_Traversal' that
-- points to a monoidal value.
--
-- >>> evalState (uses _1 length) ("hello","world")
-- 5
--
-- @
-- 'uses' :: 'MonadState' s m             => 'R_Getter' s a     -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Fold.R_Fold' s a       -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'R_Lens'' s a      -> (a -> r) -> m r
-- 'uses' :: 'MonadState' s m             => 'Control.R_Lens.R_Iso.R_Iso'' s a       -> (a -> r) -> m r
-- 'uses' :: ('MonadState' s m, 'Data.Monoid.Monoid' r) => 'Control.R_Lens.R_Traversal.R_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, AsLensLike (Const r) k) => Optic' k 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 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'listening' :: 'MonadWriter' w m             => 'R_Getter' w u     -> m a -> m (a, u)
-- 'listening' :: 'MonadWriter' w m             => 'R_Lens'' w u      -> m a -> m (a, u)
-- 'listening' :: 'MonadWriter' w m             => 'R_Iso'' w u       -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_Fold' w u       -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_Traversal'' w u -> m a -> m (a, u)
-- 'listening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_Prism'' w u     -> m a -> m (a, u)
-- @
listening :: (MonadWriter w m, AsGetting u k) => Optic' k 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 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'ilistening' :: 'MonadWriter' w m             => 'R_IndexedGetter' i w u     -> m a -> m (a, (i, u))
-- 'ilistening' :: 'MonadWriter' w m             => 'R_IndexedLens'' i w u      -> m a -> m (a, (i, u))
-- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_IndexedFold' i w u       -> m a -> m (a, (i, u))
-- 'ilistening' :: ('MonadWriter' w m, 'Monoid' u) => 'R_IndexedTraversal'' i w u -> m a -> m (a, (i, u))
-- @
ilistening :: (MonadWriter w m, AsIndexedGetting i (i, u) k) => Optic' k 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 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'listenings' :: 'MonadWriter' w m             => 'R_Getter' w u     -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: 'MonadWriter' w m             => 'R_Lens'' w u      -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: 'MonadWriter' w m             => 'R_Iso'' w u       -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_Fold' w u       -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_Traversal'' w u -> (u -> v) -> m a -> m (a, v)
-- 'listenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_Prism'' w u     -> (u -> v) -> m a -> m (a, v)
-- @
listenings :: forall u v w m k a. (MonadWriter w m, AsGetting v k) => Optic' k w u -> (u -> v) -> m a -> m (a, v)
listenings l uv m = do
  (a, w) <- listen m
  return (a, views (asLensLike (asGetting l :: Getting v w u)) 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 'R_Getter'. If given a 'R_Fold' or a 'R_Traversal'
-- then a monoidal summary of the parts of the log that are visited will be
-- returned.
--
-- @
-- 'ilistenings' :: 'MonadWriter' w m             => 'R_IndexedGetter' w u     -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: 'MonadWriter' w m             => 'R_IndexedLens'' w u      -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_IndexedFold' w u       -> (i -> u -> v) -> m a -> m (a, v)
-- 'ilistenings' :: ('MonadWriter' w m, 'Monoid' v) => 'R_IndexedTraversal'' w u -> (i -> u -> v) -> m a -> m (a, v)
-- @
ilistenings :: (MonadWriter w m, AsIndexedGetting i v k) => Optic' k 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 R_Getters
------------------------------------------------------------------------------

-- | View the index and value of an 'R_IndexedGetter' into the current environment as a pair.
--
-- When applied to an 'R_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, AsIndexedGetting i (i, a) k) => Optic' k s a -> m (i,a)
iview l = asks (getConst #. runOptic (asIndexedGetting l) (Indexed $ \i -> Const #. (,) i))
{-# INLINE iview #-}

-- | View a function of the index and value of an 'R_IndexedGetter' into the current environment.
--
-- When applied to an 'R_IndexedFold' the result will be a monoidal summary instead of a single answer.
--
-- @
-- 'iviews' ≡ 'Control.R_Lens.R_Fold.ifoldMapOf'
-- @
iviews :: (MonadReader s m, AsIndexedGetting i r k) => Optic' k s a -> (i -> a -> r) -> m r
iviews l f = asks (getConst #. runOptic (asIndexedGetting l) (Const #. Indexed f))
{-# INLINE iviews #-}

-- | Use the index and value of an 'R_IndexedGetter' into the current state as a pair.
--
-- When applied to an 'R_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, AsIndexedGetting i (i,a) k) => Optic' k s a -> m (i,a)
iuse l = gets (getConst #. runOptic (asIndexedGetting l) (Indexed $ \i -> Const #. (,) i))
{-# INLINE iuse #-}

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

-- | View the index and value of an 'R_IndexedGetter' or 'R_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 -> 'R_IndexedGetter' i s a -> (i, a)
-- ('^@.') :: s -> 'R_IndexedLens'' i s a  -> (i, a)
-- @
--
-- The result probably doesn't have much meaning when applied to an 'R_IndexedFold'.
(^@.) :: AsIndexedGetting i (i, a) k => s -> Optic' k s a -> (i, a)
s ^@. l = getConst $ runOptic (asIndexedGetting l) (Indexed $ \i -> Const #. (,) i) s
{-# INLINE (^@.) #-}

-- | Coerce a 'R_Getter'-compatible 'R_Optical' to an 'R_Optical''. This
-- is useful when using a 'R_Traversal' that is not simple as a 'R_Getter' or a
-- 'R_Fold'.
--
-- @
-- 'getting' :: 'R_Traversal' s t a b          -> 'R_Fold' s a
-- 'getting' :: 'R_Lens' s t a b               -> 'R_Getter' s a
-- 'getting' :: 'R_IndexedTraversal' i s t a b -> 'R_IndexedFold' i s a
-- 'getting' :: 'R_IndexedLens' i s t a b      -> 'R_IndexedGetter' i s a
-- @
rgetting :: (Profunctor p, Profunctor q, Functor f, Contravariant f)
        => R_Optical p q f s t a b -> R_Optical' p q f s a
rgetting l f = rmap phantom . l $ rmap phantom f

asOptical :: AsOptical p q f k => Optic k s t a b -> Optical p q f s t a b
asOptical = sub

ggetting :: (Profunctor p, Profunctor q, Functor f, Contravariant f, k <: A_Optical p q f)
         => Optic k s t a b -> Optical' p q f s a
ggetting l = Optic (rgetting (runOptic (asOptical l)))

pgetting :: (Profunctor p, Profunctor q, Functor f, Contravariant f)
        => Optical p q f s t a b -> Optical' p q f s a
pgetting l = Optic (rgetting (runOptic l))

max_stars_repo_name: galagora/silica

max_issues_repo_name: galagora/silica

max_forks_repo_name: galagora/silica


text:
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module: Chainweb.Test.SPV
-- Copyright: Copyright © 2018 - 2020 Kadena LLC.
-- License: MIT
-- Maintainer: Lars Kuhtz <lars@kadena.io>
-- Stability: experimental
--
-- TODO
--
module Chainweb.Test.SPV
( tests
, spvTransactionRoundtripTest
, spvTransactionOutputRoundtripTest
, apiTests
) where

import Control.Lens (view, (^?!))
import Control.Monad.Catch
import Control.Monad.IO.Class

import Data.Aeson
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.CAS
import Data.Foldable
import Data.Functor.Of
import qualified Data.List as L
import Data.LogMessage
import qualified Data.Vector.Unboxed as V

import Numeric.Natural

import Servant.Client

import Statistics.Regression

import qualified Streaming.Prelude as S

import Test.QuickCheck
import Test.Tasty
import Test.Tasty.HUnit

-- internal modules

import Chainweb.BlockHeader
import Chainweb.ChainId
import Chainweb.Cut
import Chainweb.CutDB
import Chainweb.Graph
import Chainweb.Mempool.Mempool (MockTx)
import Chainweb.Payload
import Chainweb.Payload.PayloadStore
import Chainweb.SPV
import Chainweb.SPV.CreateProof
import Chainweb.SPV.RestAPI.Client
import Chainweb.SPV.VerifyProof
import Chainweb.Test.CutDB
import Chainweb.Test.Utils
import Chainweb.TreeDB
import Chainweb.Utils
import Chainweb.Version

import Data.CAS.RocksDB

-- -------------------------------------------------------------------------- --
-- Test Tree

-- FIXME: These tests is randomized, and should either be rewritten using
-- quickCheck instead of HUnit or should be derandomized.
--
tests :: RocksDb -> TestTree
tests rdb = testGroup "SPV tests"
    [ testCaseStepsN "SPV transaction proof" 10 (spvTransactionRoundtripTest rdb version)
    , testCaseStepsN "SPV transaction output proof" 10 (spvTransactionOutputRoundtripTest rdb version)
    , apiTests rdb version
    , testCaseSteps "SPV transaction proof test" (spvTest rdb version)
    ]
  where
    version = Test petersonChainGraph

-- -------------------------------------------------------------------------- --
-- Utils

type Step = String -> IO ()

testCaseStepsN :: String -> Natural -> (Step -> Assertion) -> TestTree
testCaseStepsN name n test = testGroup name $ flip map [1..n] $ \i ->
    testCaseSteps ("Run test number " <> sshow i) test

-- Find a reachable target chain
--
targetChain :: Cut -> BlockHeader -> IO ChainId
targetChain c srcBlock = do
    cids <- generate (shuffle $ toList $ chainIds c)
    go cids
  where
    graph = _chainGraph c

    go [] = error
        $ "SPV proof test failed to find a reachable target chain. This is a bug in the test code"
        <> ". source block: " <> sshow srcBlock
        <> ". current cut: " <> sshow c
    go (h:t) = if isReachable h then return h else go t

    chainHeight trgChain = _blockHeight (c ^?! ixg trgChain)

    isReachable trgChain
        = _blockHeight srcBlock <= chainHeight trgChain - distance trgChain

    distance x = len $ shortestPath (_chainId srcBlock) x graph

-- -------------------------------------------------------------------------- --
-- Comprehensive SPV test for transaction proofs

-- | Creates a test chainweb instance and exhaustively creates SPV transaction
-- output proofs for each transaction on each chain.
--
-- Also checks that the size of the created proofs meets the expectations.
--
spvTest :: RocksDb -> ChainwebVersion -> Step -> IO ()
spvTest rdb v step = do
    withTestCutDbWithoutPact rdb v 100 logg $ \cutDb -> do
        curCut <- _cutMap <$> _cut cutDb

        -- for each blockheader h in cut
        samples <- S.each (toList curCut)
            -- for each ancestor ah of h
            & flip S.for (\h -> ancestors (cutDb ^?! cutDbBlockHeaderDb h) (_blockHash h))
            -- for each transaction in ah
            & flip S.for (\h -> getPayloads cutDb h)
            -- for each target chain c
            & flip S.for (\(a,b,c,d) -> S.each $ (a,b,c,d,) <$> toList (chainIds cutDb))
            -- Create and verify transaction output proof
            & S.mapM (go cutDb)
            -- Ingore all cases where a proof couldn't be created
            & S.concat
            & S.toList_

        -- Confirm size of proofs
        let (coef, r2) = regress samples
        step $ show r2
        step $ show coef
        assertBool
            ("proof size is not constant in the block height: r-value " <> sshow r2 <> " is < 0.8")
            (r2 > 0.8)
  where
    logg :: LogFunction
    -- logg _ msg = step $ T.unpack $ logText msg
    logg _ _ = return ()

    -- Stream of all transactions in a block. Each returned item is
    -- - block header
    -- - block size (tx count)
    -- - tx index
    -- - tx
    --
    getPayloads
        :: PayloadCasLookup cas
        => CutDb cas
        -> BlockHeader
        -> S.Stream (Of (BlockHeader, Int, Int, TransactionOutput)) IO ()
    getPayloads cutDb h = do
        pay <- liftIO $ casLookupM (view cutDbPayloadCas cutDb) (_blockPayloadHash h)
        let n = length $ _payloadWithOutputsTransactions pay
        S.each (zip [0..] $ fmap snd $ toList $ _payloadWithOutputsTransactions pay)
            & S.map (\(b,c) -> (h,n,b,c))

    -- Given
    -- - block header,
    -- - tx count of block,
    -- - tx index,
    -- - tx, and
    -- - target chain,
    --
    -- creates and verifies SPV proofs and returns list of
    -- - tx proof length
    -- - block size (tx count)
    -- - block height difference
    -- - distance between source chain and target chain
    -- - size of tx
    --
    go
        :: PayloadCasLookup cas
        => CutDb cas
        -> (BlockHeader, Int, Int, TransactionOutput, ChainId)
        -> IO (Maybe [Double])
    go cutDb (h, n, txIx, txOut, trgChain) = do

        let inner = do
                -- create inclusion proof for transaction
                proof <- createTransactionOutputProof cutDb trgChain
                    (_chainId h) -- source chain
                    (_blockHeight h) -- source block height
                    txIx -- transaction index
                subj <- verifyTransactionOutputProof cutDb proof
                assertEqual "transaction output proof subject matches transaction" txOut subj

                -- return (proof size, block size, height, distance, tx size)
                return
                    [ int $ BL.length $ encode proof
                    , int n
                    , int $ _blockHeight h
                    , int $ distance cutDb h trgChain
                    , int $ B.length (_transactionOutputBytes txOut)
                    ]

        isReachable <- reachable cutDb h trgChain
        try inner >>= \case
            Right x -> do
                let msg = "SPV proof creation succeeded although target chain is not reachable ("
                        <> "source height: " <> sshow (_blockHeight h)
                        <> ", distance: " <> sshow (distance cutDb h trgChain)
                        <> ")"
                assertBool msg isReachable
                return (Just x)
            Left SpvExceptionTargetNotReachable{} -> do
                let msg = "SPV proof creation failed although target chain is reachable ("
                        <> "source height: " <> sshow (_blockHeight h)
                        <> ", distance: " <> sshow (distance cutDb h trgChain)
                        <> ")"
                assertBool msg (not isReachable)
                return Nothing
            Left e -> throwM e

    -- Distance between source chain an target chain
    --
    distance cutDb h trgChain = length
        $ shortestPath (_chainId h) trgChain
        $ _chainGraph cutDb

    -- Check whether target chain is reachable from the source block
    --
    reachable :: CutDb as -> BlockHeader -> ChainId -> IO Bool
    reachable cutDb h trgChain = do
        m <- maxRank $ cutDb ^?! cutDbBlockHeaderDb trgChain
        return $ (int m - int (_blockHeight h)) >= distance cutDb h trgChain

    -- regression model with @createTransactionOutputProof@. Proof size doesn't
    -- depend on target height.
    --
    -- (This proof size is logarithmic in the block size and linear in the
    -- distance and transation size)
    --
    regress r
        | [proofSize, blockSize, _heightDiff, chainDist, txSize] <- V.fromList <$> L.transpose r
            = olsRegress [V.map (logBase 2) blockSize, chainDist, txSize] proofSize
        | otherwise = error "Chainweb.Test.SPV.spvTest.regress: fail to match regressor list. This is a bug in the test code."

    -- regression model for @createTransactionOutputProof'@. Proof size depends
    -- on target height.
    --
    -- regressWithHeightDiff r
    --     | [proofSize, blockSize, heightDiff, chainDist, txSize] <- V.fromList <$> L.transpose r
    --         = olsRegress [V.map (logBase 2) blockSize, heightDiff, chainDist, txSize] proofSize
    --     | otherwise = error "Chainweb.Test.SPV.spvTest.regress: fail to match regressor list. This is a bug in the test code."

-- -------------------------------------------------------------------------- --
-- SPV Tests

spvTransactionRoundtripTest :: RocksDb -> ChainwebVersion -> Step -> IO ()
spvTransactionRoundtripTest rdb v step = do
    step "setup cut db"
    withTestCutDbWithoutPact rdb v 100 (\_ _ -> return ()) $ \cutDb -> do
        step "pick random transaction"
        (h, txIx, tx, _) <- randomTransaction cutDb

        step "pick a reachable target chain"
        curCut <- _cut cutDb
        trgChain <- targetChain curCut h

        step "create inclusion proof for transaction"
        proof <- createTransactionProof
            cutDb
                -- CutDb
            trgChain
                -- target chain
            (_chainId h)
                -- source chain
            (_blockHeight h)
                -- source block height
            txIx
                -- transaction index

        step "json encoding roundtrip of proof"
        assertEqual "decode proof equals original proof"
            (Right proof)
            (eitherDecode (encode proof))

        step "verify proof"
        subj <- verifyTransactionProof cutDb proof

        step "confirm that proof subject matches transaction"
        assertEqual "proof subject matches transaction" tx subj

spvTransactionOutputRoundtripTest :: RocksDb -> ChainwebVersion -> Step -> IO ()
spvTransactionOutputRoundtripTest rdb v step = do
    step "setup cut db"
    withTestCutDbWithoutPact rdb v 100 (\_ _ -> return ()) $ \cutDb -> do

        step "pick random transaction output"
        (h, outIx, _, out) <- randomTransaction cutDb

        step "pick a reachable target chain"
        curCut <- _cut cutDb
        trgChain <- targetChain curCut h

        step "create inclusion proof for transaction output"
        proof <- createTransactionOutputProof
            cutDb
                -- CutDb
            trgChain
                -- target chain
            (_chainId h)
                -- source chain
            (_blockHeight h)
                -- source block height
            outIx
                -- transaction index

        step "json encoding roundtrip of proof"
        assertEqual "decode proof equals original proof"
            (Right proof)
            (eitherDecode (encode proof))

        step "verify proof"
        subj <- verifyTransactionOutputProof cutDb proof

        step "confirm that proof subject matches transaction output"
        assertEqual "proof subject matches transaction output" out subj

-- -------------------------------------------------------------------------- --
-- REST API

type TestClientEnv_ cas = TestClientEnv MockTx cas

apiTests :: RocksDb -> ChainwebVersion -> TestTree
apiTests rdb v = withTestPayloadResource rdb v 100 (\_ _ -> return ()) $ \dbIO ->
    testGroup "SPV API tests"
        [ withPayloadServer False v dbIO (payloadDbs . view cutDbPayloadCas <$> dbIO) $ \env ->
            testCaseStepsN "spv api tests (without tls)" 10 (txApiTests env)
        , withPayloadServer True v dbIO (payloadDbs . view cutDbPayloadCas <$> dbIO) $ \env ->
            testCaseStepsN "spv api tests (with tls)" 10 (txApiTests env)
        ]
  where
    cids = toList $ chainIds v

    payloadDbs :: PayloadCasLookup cas' => PayloadDb cas' -> [(ChainId, PayloadDb cas')]
    payloadDbs db = (, db) <$> cids

txApiTests :: PayloadCasLookup cas => IO (TestClientEnv_ cas) -> Step -> IO ()
txApiTests envIO step = do
    PayloadTestClientEnv env cutDb _payloadDbs v <- envIO
    step "pick random transaction"
    (h, txIx, tx, out) <- randomTransaction cutDb

    step $ "picked random transaction, height: " <> sshow (_blockHeight h) <> ", ix: " <> sshow txIx

    curCut <- _cut cutDb
    trgChain <- targetChain curCut h
    step $ "picked a reachable target chain, chain id: " <> sshow trgChain

    -- Transaction Proof:

    step "request transaction proof"
    txProof <- flip runClientM env $
        spvGetTransactionProofClient v trgChain (_chainId h) (_blockHeight h) (int txIx)

    case txProof of

        Left err ->
            assertFailure $ "request for transaction proof failed: " <> sshow err

        Right proof -> do
            step "verify transaction proof"
            subj <- verifyTransactionProof cutDb proof

            step "confirm that transaction proof subject matches transaction"
            assertEqual "proof subject matches transaction" tx subj

    -- Transaction Output Proof:

    step "request transaction output proof"
    outProof <- flip runClientM env $
        spvGetTransactionOutputProofClient v trgChain (_chainId h) (_blockHeight h) (int txIx)

    case outProof of

        Left err ->
            assertFailure $ "request for transaction output proof failed: " <> sshow err

        Right proof -> do
            step "verify transaction output proof"
            subj <- verifyTransactionOutputProof cutDb proof

            step "confirm that transaction output proof subject matches transaction output"
            assertEqual "proof subject matches transaction output" out subj

max_stars_repo_name: ryantrinkle/chainweb-node

max_issues_repo_name: ryantrinkle/chainweb-node

max_forks_repo_name: ryantrinkle/chainweb-node


text:
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_HADDOCK hide #-}
module Data.Vector.Unboxing.Internal
  (Unboxable(Rep)
  ,Vector(UnboxingVector)
  ,MVector(UnboxingMVector)
  ,Generics(..)
  ,Enum(..)
  ,EnumRep(..)
  ,coerceVector
  ,liftCoercion
  ,vectorCoercion
  ,toUnboxedVector
  ,fromUnboxedVector
  ,coercionWithUnboxedVector
  ,coerceMVector
  ,liftCoercionM
  ,mVectorCoercion
  ,toUnboxedMVector
  ,fromUnboxedMVector
  ,coercionWithUnboxedMVector
  ) where
import Prelude hiding (Enum)
import qualified Prelude
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Generic.Mutable as GM
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Unboxed.Mutable as UM
import qualified Data.Vector.Fusion.Bundle as Bundle
import Data.Coerce
import Data.Type.Coercion
import Data.Int
import Data.Word
import qualified GHC.Generics
import Data.Type.Bool
import qualified Data.Complex
import qualified Data.Functor.Identity
import qualified Data.Functor.Const
import qualified Data.Functor.Compose
import qualified Data.Ord
import qualified Data.Semigroup
import qualified Data.Monoid
import GHC.Exts (IsList(..))
import Control.DeepSeq (NFData(..))
import Text.Read (Read(..),readListPrecDefault)
import GHC.TypeLits (TypeError,ErrorMessage(Text))

newtype Vector a = UnboxingVector (U.Vector (Rep a))
newtype MVector s a = UnboxingMVector (UM.MVector s (Rep a))

type instance G.Mutable Vector = MVector

-- | Types that can be stored in unboxed vectors ('Vector' and 'MVector').
--
-- You can define instances of this class like:
--
-- > newtype Foo = Foo Int
-- > instance Unboxable Foo where
-- >   type Rep Foo = Int
--
-- The type specified by 'Rep' needs to be an instance of 'U.Unbox',
-- and coercion must be possible between the two types.
--
-- Instances can also be derived with @GeneralizedNewtypeDeriving@.
-- GND always works if the base type is an instance of 'Unboxable'.
--
-- If you want to have non-trivial correspondence between the type and the representation,
-- use 'Generics' wrapper with @DerivingVia@.
--
-- Note that @UndecidableInstances@ is needed if you use GND or @DerivingVia@ to derive instances.
class U.Unbox (Rep a) => Unboxable a where
  -- | The underlying type of @a@.  Must be an instance of 'U.Unbox'.
  type Rep a

  -- Hidden members:

  -- Used by 'coerceVector'
  type CoercibleRep a
  type CoercibleRep a = Rep a

  -- True if both 'unboxingFrom and 'unboxingTo' are just 'coerce'
  type IsTrivial a :: Bool
  type IsTrivial a = 'True
  -- TODO: Use ConstraintKinds?

  unboxingFrom :: a -> Rep a
  default unboxingFrom :: Coercible a (Rep a) => a -> Rep a
  unboxingFrom = coerce
  {-# INLINE unboxingFrom #-}

  unboxingTo :: Rep a -> a
  default unboxingTo :: Coercible a (Rep a) => Rep a -> a
  unboxingTo = coerce
  {-# INLINE unboxingTo #-}

coerceVector :: (Coercible a b, Unboxable a, Unboxable b, CoercibleRep a ~ CoercibleRep b, Rep a ~ Rep b) => Vector a -> Vector b
coerceVector = coerce
{-# INLINE coerceVector #-}

liftCoercion :: (Unboxable a, Unboxable b, CoercibleRep a ~ CoercibleRep b, Rep a ~ Rep b) => Coercion a b -> Coercion (Vector a) (Vector b)
liftCoercion Coercion = Coercion
{-# INLINE liftCoercion #-}

vectorCoercion :: (Coercible a b, Unboxable a, Unboxable b, CoercibleRep a ~ CoercibleRep b, Rep a ~ Rep b) => Coercion (Vector a) (Vector b)
vectorCoercion = Coercion
{-# INLINE vectorCoercion #-}

toUnboxedVector :: (Unboxable a, Rep a ~ a, IsTrivial a ~ 'True) => Vector a -> U.Vector a
toUnboxedVector = coerce
{-# INLINE toUnboxedVector #-}

fromUnboxedVector :: (Unboxable a, Rep a ~ a, IsTrivial a ~ 'True) => U.Vector a -> Vector a
fromUnboxedVector = coerce
{-# INLINE fromUnboxedVector #-}

coerceMVector :: (Coercible a b, Unboxable a, Unboxable b, CoercibleRep a ~ CoercibleRep b, Rep a ~ Rep b) => MVector s a -> MVector s b
coerceMVector = coerce
{-# INLINE coerceMVector #-}

liftCoercionM :: (Unboxable a, Unboxable b, CoercibleRep a ~ CoercibleRep b, Rep a ~ Rep b) => Coercion a b -> Coercion (MVector s a) (MVector s b)
liftCoercionM Coercion = Coercion
{-# INLINE liftCoercionM #-}

mVectorCoercion :: (Coercible a b, Unboxable a, Unboxable b, CoercibleRep a ~ CoercibleRep b, Rep a ~ Rep b) => Coercion (MVector s a) (MVector s b)
mVectorCoercion = Coercion
{-# INLINE mVectorCoercion #-}

toUnboxedMVector :: (Unboxable a, Rep a ~ a, IsTrivial a ~ 'True) => MVector s a -> UM.MVector s a
toUnboxedMVector = coerce
{-# INLINE toUnboxedMVector #-}

fromUnboxedMVector :: (Unboxable a, Rep a ~ a, IsTrivial a ~ 'True) => UM.MVector s a -> MVector s a
fromUnboxedMVector = coerce
{-# INLINE fromUnboxedMVector #-}

coercionWithUnboxedVector :: (Unboxable a, Rep a ~ a, IsTrivial a ~ 'True) => Coercion (Vector a) (U.Vector a)
coercionWithUnboxedVector = Coercion
{-# INLINE coercionWithUnboxedVector #-}

coercionWithUnboxedMVector :: (Unboxable a, Rep a ~ a, IsTrivial a ~ 'True) => Coercion (MVector s a) (U.MVector s a)
coercionWithUnboxedMVector = Coercion
{-# INLINE coercionWithUnboxedMVector #-}

--
-- Generics
--

-- | A newtype wrapper to be used with @DerivingVia@.
--
-- Usage:
--
-- > data Bar = Bar !Int !Int
-- >   deriving Generic
-- >   deriving Unboxable via Generics Bar
newtype Generics a = Generics a

instance (GHC.Generics.Generic a, U.Unbox (Rep' (GHC.Generics.Rep a)), Unboxable' (GHC.Generics.Rep a)) => Unboxable (Generics a) where
  type Rep (Generics a) = Rep' (GHC.Generics.Rep a)
  type CoercibleRep (Generics a) = a
  type IsTrivial (Generics a) = 'False
  unboxingFrom (Generics x) = from' (GHC.Generics.from x)
  {-# INLINE unboxingFrom #-}
  unboxingTo y = Generics (GHC.Generics.to (to' y))
  {-# INLINE unboxingTo #-}

class Unboxable' f where
  type Rep' f
  from' :: f x -> Rep' f
  to' :: Rep' f -> f x
instance Unboxable' GHC.Generics.U1 where
  type Rep' GHC.Generics.U1 = ()
  from' _ = ()
  to' _ = GHC.Generics.U1
  {-# INLINE from' #-}
  {-# INLINE to' #-}
instance Unboxable c => Unboxable' (GHC.Generics.K1 i c) where
  type Rep' (GHC.Generics.K1 i c) = Rep c
  from' = {- from . GHC.Generics.unK1 -} coerce (unboxingFrom :: c -> Rep c)
  to' = {- GHC.Generics.K1 . to -} coerce (unboxingTo :: Rep c -> c)
  {-# INLINE from' #-}
  {-# INLINE to' #-}
instance Unboxable' f => Unboxable' (GHC.Generics.M1 i c f) where
  type Rep' (GHC.Generics.M1 i c f) = Rep' f
  from' = from' . GHC.Generics.unM1
  to' = GHC.Generics.M1 . to'
  {-# INLINE from' #-}
  {-# INLINE to' #-}
instance (Unboxable' f, Unboxable' g) => Unboxable' (f GHC.Generics.:*: g) where
  type Rep' (f GHC.Generics.:*: g) = (Rep' f, Rep' g)
  from' (x GHC.Generics.:*: y) = (from' x, from' y)
  to' (x, y) = (to' x GHC.Generics.:*: to' y)
  {-# INLINE from' #-}
  {-# INLINE to' #-}
instance Unboxable' (f GHC.Generics.:+: g) where
  type Rep' (f GHC.Generics.:+: g) = TypeError ('Text "Cannot derive Unboxable instance for a sum type.")
  from' = undefined
  to' = undefined

--
-- Enum
--

-- | A newtype wrapper to be used with @DerivingVia@.
-- The value will be stored as 'Int', via `fromEnum`/`toEnum`.
--
-- Usage:
--
-- > data Direction = North | South | East | West
-- >   deriving Enum
-- >   deriving Data.Vector.Unboxing.Unboxable via Data.Vector.Unboxing.Enum Bar
newtype Enum a = Enum a
instance (Prelude.Enum a) => Unboxable (Enum a) where
  type Rep (Enum a) = Int
  type CoercibleRep (Enum a) = a
  type IsTrivial (Enum a) = 'False
  unboxingFrom (Enum x) = fromEnum x
  {-# INLINE unboxingFrom #-}
  unboxingTo y = Enum (toEnum y)
  {-# INLINE unboxingTo #-}

-- | A newtype wrapper to be used with @DerivingVia@.
--
-- Usage:
--
-- > data Direction = North | South | East | West
-- >   deriving Enum
-- >   deriving Data.Vector.Unboxing.Unboxable via Data.Vector.Unboxing.EnumRep Int8 Bar
newtype EnumRep rep a = EnumRep a
instance (Prelude.Enum a, Integral rep, U.Unbox rep) => Unboxable (EnumRep rep a) where
  type Rep (EnumRep rep a) = rep
  type CoercibleRep (EnumRep rep a) = a
  type IsTrivial (EnumRep rep a) = 'False
  unboxingFrom (EnumRep x) = fromIntegral (fromEnum x)
  {-# INLINE unboxingFrom #-}
  unboxingTo y = EnumRep (toEnum (fromIntegral y))
  {-# INLINE unboxingTo #-}

--
-- Instances
--

instance (Unboxable a) => IsList (Vector a) where
  type Item (Vector a) = a
  fromList = G.fromList
  fromListN = G.fromListN
  toList = G.toList
  {-# INLINE fromList #-}
  {-# INLINE fromListN #-}
  {-# INLINE toList #-}

instance (Eq a, Unboxable a) => Eq (Vector a) where
  xs == ys = Bundle.eq (G.stream xs) (G.stream ys)
  xs /= ys = not (Bundle.eq (G.stream xs) (G.stream ys))
  {-# INLINE (==) #-}
  {-# INLINE (/=) #-}

instance (Ord a, Unboxable a) => Ord (Vector a) where
  compare xs ys = Bundle.cmp (G.stream xs) (G.stream ys)
  {-# INLINE compare #-}

instance (Show a, Unboxable a) => Show (Vector a) where
  showsPrec = G.showsPrec
  {-# INLINE showsPrec #-}

instance (Read a, Unboxable a) => Read (Vector a) where
  readPrec = G.readPrec
  readListPrec = readListPrecDefault
  {-# INLINE readPrec #-}
  {-# INLINE readListPrec #-}

instance (Unboxable a) => Data.Semigroup.Semigroup (Vector a) where
  (<>) = (G.++)
  sconcat = G.concatNE
  {-# INLINE (<>) #-}
  {-# INLINE sconcat #-}

instance (Unboxable a) => Data.Monoid.Monoid (Vector a) where
  mempty = G.empty
  mappend = (Data.Semigroup.<>)
  mconcat = G.concat
  {-# INLINE mempty #-}
  {-# INLINE mappend #-}
  {-# INLINE mconcat #-}

instance NFData (Vector a) where
  rnf !_ = () -- the content is unboxed

instance (Unboxable a) => GM.MVector MVector a where
  basicLength (UnboxingMVector mv)                           = GM.basicLength mv
  basicUnsafeSlice i l (UnboxingMVector mv)                  = UnboxingMVector (GM.basicUnsafeSlice i l mv)
  basicOverlaps (UnboxingMVector mv) (UnboxingMVector mv')   = GM.basicOverlaps mv mv'
  basicUnsafeNew l                                           = UnboxingMVector <$> GM.basicUnsafeNew l
  basicInitialize (UnboxingMVector mv)                       = GM.basicInitialize mv
  basicUnsafeReplicate i x                                   = UnboxingMVector <$> GM.basicUnsafeReplicate i (unboxingFrom x)
  basicUnsafeRead (UnboxingMVector mv) i                     = unboxingTo <$> GM.basicUnsafeRead mv i
  basicUnsafeWrite (UnboxingMVector mv) i x                  = GM.basicUnsafeWrite mv i (unboxingFrom x)
  basicClear (UnboxingMVector mv)                            = GM.basicClear mv
  basicSet (UnboxingMVector mv) x                            = GM.basicSet mv (unboxingFrom x)
  basicUnsafeCopy (UnboxingMVector mv) (UnboxingMVector mv') = GM.basicUnsafeCopy mv mv'
  basicUnsafeMove (UnboxingMVector mv) (UnboxingMVector mv') = GM.basicUnsafeMove mv mv'
  basicUnsafeGrow (UnboxingMVector mv) n                     = UnboxingMVector <$> GM.basicUnsafeGrow mv n
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicOverlaps #-}
  {-# INLINE basicUnsafeNew #-}
  {-# INLINE basicInitialize #-}
  {-# INLINE basicUnsafeRead #-}
  {-# INLINE basicUnsafeWrite #-}
  {-# INLINE basicClear #-}
  {-# INLINE basicSet #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE basicUnsafeMove #-}
  {-# INLINE basicUnsafeGrow #-}

instance (Unboxable a) => G.Vector Vector a where
  basicUnsafeFreeze (UnboxingMVector mv)                  = UnboxingVector <$> G.basicUnsafeFreeze mv
  basicUnsafeThaw (UnboxingVector v)                      = UnboxingMVector <$> G.basicUnsafeThaw v
  basicLength (UnboxingVector v)                          = G.basicLength v
  basicUnsafeSlice i l (UnboxingVector v)                 = UnboxingVector (G.basicUnsafeSlice i l v)
  basicUnsafeIndexM (UnboxingVector v) i                  = unboxingTo <$> G.basicUnsafeIndexM v i
  basicUnsafeCopy (UnboxingMVector mv) (UnboxingVector v) = G.basicUnsafeCopy mv v
  elemseq (UnboxingVector v) x y                          = G.elemseq v (unboxingFrom x) y -- ?
  {-# INLINE basicUnsafeFreeze #-}
  {-# INLINE basicUnsafeThaw #-}
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicUnsafeIndexM #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE elemseq #-}

--
-- Unboxable instances
--

instance Unboxable Bool where   type Rep Bool = Bool
instance Unboxable Char where   type Rep Char = Char
instance Unboxable Double where type Rep Double = Double
instance Unboxable Float where  type Rep Float = Float
instance Unboxable Int where    type Rep Int = Int
instance Unboxable Int8 where   type Rep Int8 = Int8
instance Unboxable Int16 where  type Rep Int16 = Int16
instance Unboxable Int32 where  type Rep Int32 = Int32
instance Unboxable Int64 where  type Rep Int64 = Int64
instance Unboxable Word where   type Rep Word = Word
instance Unboxable Word8 where  type Rep Word8 = Word8
instance Unboxable Word16 where type Rep Word16 = Word16
instance Unboxable Word32 where type Rep Word32 = Word32
instance Unboxable Word64 where type Rep Word64 = Word64
instance Unboxable () where     type Rep () = ()

instance (Unboxable a) => Unboxable (Data.Complex.Complex a) where
  type Rep (Data.Complex.Complex a) = Data.Complex.Complex (Rep a)
  type CoercibleRep (Data.Complex.Complex a) = Data.Complex.Complex (CoercibleRep a)
  type IsTrivial (Data.Complex.Complex a) = IsTrivial a
  unboxingFrom = fmap unboxingFrom
  unboxingTo = fmap unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance (Unboxable a, Unboxable b) => Unboxable (a, b) where
  type Rep (a, b) = (Rep a, Rep b)
  type CoercibleRep (a, b) = (CoercibleRep a, CoercibleRep b)
  type IsTrivial (a, b) = IsTrivial a && IsTrivial b
  unboxingFrom (a, b) = (unboxingFrom a, unboxingFrom b)
  unboxingTo (a, b) = (unboxingTo a, unboxingTo b)
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance (Unboxable a, Unboxable b, Unboxable c) => Unboxable (a, b, c) where
  type Rep (a, b, c) = (Rep a, Rep b, Rep c)
  type CoercibleRep (a, b, c) = (CoercibleRep a, CoercibleRep b, CoercibleRep c)
  type IsTrivial (a, b, c) = IsTrivial a && IsTrivial b && IsTrivial c
  unboxingFrom (a, b, c) = (unboxingFrom a, unboxingFrom b, unboxingFrom c)
  unboxingTo (a, b, c) = (unboxingTo a, unboxingTo b, unboxingTo c)
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance (Unboxable a, Unboxable b, Unboxable c, Unboxable d) => Unboxable (a, b, c, d) where
  type Rep (a, b, c, d) = (Rep a, Rep b, Rep c, Rep d)
  type CoercibleRep (a, b, c, d) = (CoercibleRep a, CoercibleRep b, CoercibleRep c, CoercibleRep d)
  type IsTrivial (a, b, c, d) = IsTrivial a && IsTrivial b && IsTrivial c && IsTrivial d
  unboxingFrom (a, b, c, d) = (unboxingFrom a, unboxingFrom b, unboxingFrom c, unboxingFrom d)
  unboxingTo (a, b, c, d) = (unboxingTo a, unboxingTo b, unboxingTo c, unboxingTo d)
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance (Unboxable a, Unboxable b, Unboxable c, Unboxable d, Unboxable e) => Unboxable (a, b, c, d, e) where
  type Rep (a, b, c, d, e) = (Rep a, Rep b, Rep c, Rep d, Rep e)
  type CoercibleRep (a, b, c, d, e) = (CoercibleRep a, CoercibleRep b, CoercibleRep c, CoercibleRep d, CoercibleRep e)
  type IsTrivial (a, b, c, d, e) = IsTrivial a && IsTrivial b && IsTrivial c && IsTrivial d && IsTrivial e
  unboxingFrom (a, b, c, d, e) = (unboxingFrom a, unboxingFrom b, unboxingFrom c, unboxingFrom d, unboxingFrom e)
  unboxingTo (a, b, c, d, e) = (unboxingTo a, unboxingTo b, unboxingTo c, unboxingTo d, unboxingTo e)
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance (Unboxable a, Unboxable b, Unboxable c, Unboxable d, Unboxable e, Unboxable f) => Unboxable (a, b, c, d, e, f) where
  type Rep (a, b, c, d, e, f) = (Rep a, Rep b, Rep c, Rep d, Rep e, Rep f)
  type CoercibleRep (a, b, c, d, e, f) = (CoercibleRep a, CoercibleRep b, CoercibleRep c, CoercibleRep d, CoercibleRep e, CoercibleRep f)
  type IsTrivial (a, b, c, d, e, f) = IsTrivial a && IsTrivial b && IsTrivial c && IsTrivial d && IsTrivial e && IsTrivial f
  unboxingFrom (a, b, c, d, e, f) = (unboxingFrom a, unboxingFrom b, unboxingFrom c, unboxingFrom d, unboxingFrom e, unboxingFrom f)
  unboxingTo (a, b, c, d, e, f) = (unboxingTo a, unboxingTo b, unboxingTo c, unboxingTo d, unboxingTo e, unboxingTo f)
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

{-
GND for type classes with associated type families is not available until GHC 8.2.
With GHC 8.2 or later, one can derive these instances like:

> deriving instance Unboxable a => Unboxable (Data.Functor.Identity.Identity a)
> deriving instance Unboxable a => Unboxable (Data.Functor.Const.Const a b)
> deriving instance Unboxable a => Unboxable (Data.Semigroup.Min a)
> deriving instance Unboxable a => Unboxable (Data.Semigroup.Max a)
> deriving instance Unboxable a => Unboxable (Data.Semigroup.First a)
> deriving instance Unboxable a => Unboxable (Data.Semigroup.Last a)
> deriving instance Unboxable a => Unboxable (Data.Semigroup.WrappedMonoid a)
> deriving instance Unboxable a => Unboxable (Data.Monoid.Dual a)
> deriving instance Unboxable Data.Monoid.All
> deriving instance Unboxable Data.Monoid.Any
> deriving instance Unboxable a => Unboxable (Data.Monoid.Sum a)
> deriving instance Unboxable a => Unboxable (Data.Monoid.Product a)
> deriving instance Unboxable a => Unboxable (Data.Ord.Down a)
-}

instance Unboxable a => Unboxable (Data.Functor.Identity.Identity a) where
  type Rep (Data.Functor.Identity.Identity a) = Rep a
  unboxingFrom = unboxingFrom .# Data.Functor.Identity.runIdentity
  unboxingTo = Data.Functor.Identity.Identity #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable a => Unboxable (Data.Functor.Const.Const a b) where
  type Rep (Data.Functor.Const.Const a b) = Rep a
  unboxingFrom = unboxingFrom .# Data.Functor.Const.getConst
  unboxingTo = Data.Functor.Const.Const #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable a => Unboxable (Data.Semigroup.Min a) where
  type Rep (Data.Semigroup.Min a) = Rep a
  unboxingFrom = unboxingFrom .# Data.Semigroup.getMin
  unboxingTo = Data.Semigroup.Min #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable a => Unboxable (Data.Semigroup.Max a) where
  type Rep (Data.Semigroup.Max a) = Rep a
  unboxingFrom = unboxingFrom .# Data.Semigroup.getMax
  unboxingTo = Data.Semigroup.Max #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable a => Unboxable (Data.Semigroup.First a) where
  type Rep (Data.Semigroup.First a) = Rep a
  unboxingFrom = unboxingFrom .# Data.Semigroup.getFirst
  unboxingTo = Data.Semigroup.First #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable a => Unboxable (Data.Semigroup.Last a) where
  type Rep (Data.Semigroup.Last a) = Rep a
  unboxingFrom = unboxingFrom .# Data.Semigroup.getLast
  unboxingTo = Data.Semigroup.Last #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable a => Unboxable (Data.Semigroup.WrappedMonoid a) where
  type Rep (Data.Semigroup.WrappedMonoid a) = Rep a
  unboxingFrom = unboxingFrom .# Data.Semigroup.unwrapMonoid
  unboxingTo = Data.Semigroup.WrapMonoid #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable a => Unboxable (Data.Monoid.Dual a) where
  type Rep (Data.Monoid.Dual a) = Rep a
  unboxingFrom = unboxingFrom .# Data.Monoid.getDual
  unboxingTo = Data.Monoid.Dual #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable Data.Monoid.All where
  type Rep Data.Monoid.All = Bool

instance Unboxable Data.Monoid.Any where
  type Rep Data.Monoid.Any = Bool

instance Unboxable a => Unboxable (Data.Monoid.Sum a) where
  type Rep (Data.Monoid.Sum a) = Rep a
  unboxingFrom = unboxingFrom .# Data.Monoid.getSum
  unboxingTo = Data.Monoid.Sum #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable a => Unboxable (Data.Monoid.Product a) where
  type Rep (Data.Monoid.Product a) = Rep a
  unboxingFrom = unboxingFrom .# Data.Monoid.getProduct
  unboxingTo = Data.Monoid.Product #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable a => Unboxable (Data.Ord.Down a) where
  type Rep (Data.Ord.Down a) = Rep a
  unboxingFrom = unboxingFrom .# (\(Data.Ord.Down x) -> x)
  unboxingTo = Data.Ord.Down #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable Ordering where
  type Rep Ordering = Int8
  unboxingFrom x = fromIntegral (fromEnum x)
  unboxingTo y = toEnum (fromIntegral y)
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance (Unboxable a, Unboxable b) => Unboxable (Data.Semigroup.Arg a b) where
  type Rep (Data.Semigroup.Arg a b) = (Rep a, Rep b)
  unboxingFrom (Data.Semigroup.Arg x y) = (unboxingFrom x, unboxingFrom y)
  unboxingTo (x, y) = Data.Semigroup.Arg (unboxingTo x) (unboxingTo y)
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

instance Unboxable (f a) => Unboxable (Data.Monoid.Alt f a) where
  type Rep (Data.Monoid.Alt f a) = Rep (f a)
  unboxingFrom = unboxingFrom .# Data.Monoid.getAlt
  unboxingTo = Data.Monoid.Alt #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

{-
-- Since base-4.12.0.0
instance Unboxable (f a) => Unboxable (Data.Monoid.Ap f a) where
  type Rep (Data.Monoid.Ap f a) = Rep (f a)
  unboxingFrom = unboxingFrom .# Data.Monoid.getAp
  unboxingTo = Data.Monoid.Ap #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}
-}

instance Unboxable (f (g a)) => Unboxable (Data.Functor.Compose.Compose f g a) where
  type Rep (Data.Functor.Compose.Compose f g a) = Rep (f (g a))
  unboxingFrom = unboxingFrom .# Data.Functor.Compose.getCompose
  unboxingTo = Data.Functor.Compose.Compose #. unboxingTo
  {-# INLINE unboxingFrom #-}
  {-# INLINE unboxingTo #-}

infixr 9 #.
infixl 8 .#

(#.) :: Coercible b c => (b -> c) -> (a -> b) -> a -> c
_ #. f = coerce f
{-# INLINE (#.) #-}

(.#) :: Coercible a b => (b -> c) -> (a -> b) -> a -> c
f .# _ = coerce f
{-# INLINE (.#) #-}

max_stars_repo_name: minoki/unboxing-vector

max_issues_repo_name: minoki/unboxing-vector

max_forks_repo_name: minoki/unboxing-vector


text:
module Eventlog.Total(total) where

import Control.Monad.State.Strict (State(), execState, get, put, modify)
import Data.Map (Map, empty, alter)
import Prelude hiding (init, lookup, lines, words, drop, length, readFile)

import Eventlog.Types
import qualified Data.Vector as V
import Statistics.LinearRegression

data Parse =
  Parse
  { totals    :: !(Map Bucket (Double, Double, [(Double, Double)])) -- compute running totals and total of squares
  , count     :: !Int                         -- number of frames
  , times     :: [Double]
  }

parse0 :: Parse
parse0 = Parse{ totals = empty, count = 0, times = [] }

total :: [Frame] -> (Int, Map Bucket (Double, Double, Maybe (Double, Double, Double)))
total fs =
  let parse1 = flip execState parse0 . mapM_ parseFrame $ fs
  in  (
       count parse1
      , fmap (stddev $ fromIntegral (count parse1)) (totals parse1)
      )

stddev :: Double -> (Double, Double, [(Double, Double)]) -> (Double, Double, Maybe (Double, Double, Double))
stddev s0 (s1, s2, samples) = (s1, sqrt (s0 * s2 - s1 * s1) / s0, slope)
  where
    m = maximum values
    mt = maximum timesv
    (timesv, values) = unzip (reverse samples)
    yvect = V.fromList (map (/ m) values)
    xvect = V.fromList (map (/ mt) timesv)
    slope = -- TODO: Distinguish these cases
            case samples of
              [] -> Nothing
              -- Linear regression is meaningless with 1 sample
              [_] -> Nothing
              _
                -- All values are the same leads to NaN r2
                | V.all (1 ==) yvect -> Nothing
                | otherwise -> Just $! linearRegressionRSqr xvect yvect

parseFrame :: Frame -> State Parse ()
parseFrame (Frame time ls) = do
  mapM_ (inserter time) ls
  modify $ \p -> p{ count = count p + 1 }

inserter :: Double -> Sample -> State Parse Double
inserter t (Sample k v) = do
  p <- get
  put $! p { totals = alter (accum t v) k (totals p) }
  return $! v

accum :: Double -> Double -> Maybe (Double, Double, [(Double, Double)]) -> Maybe (Double, Double, [(Double, Double)])
accum t x Nothing  = Just $! ((((,,) $! x) $! (x * x)) $! [(t, x)])
accum t x (Just (y, yy, ys)) = Just $! ((((,,) $! (x + y)) $! (x * x + yy)) $! (t, x):ys)


text:
----------------------------------------------------------
-- QISKIT DEMO -------------------------------------------
----------------------------------------------------------

-- imports:

import Quipper
import Quipper.Internal

import Quantum.Synthesis.Matrix
import Quantum.Synthesis.Ring
import Quipper.Libraries.Synthesis

import Data.Complex
import Data.Ratio

import Quipper.Libraries.Simulation

----------------------------------------------------------
-- How to write your quantum circuit? --------------------
----------------------------------------------------------
-- There are many ways to implement a quantum circuit
-- * Manual implementation
-- * With circuit's matrix
-- * Simulation

----------------------------------------------------------
-- * Manual implementation

mybell1 :: Bool -> Circ (Qubit, Qubit)
mybell1 b = do
  q <- qinit b
  x <- hadamard q
  y <- qinit False
  y <- qnot y `controlled` x
  return (x,y)

main1 :: IO ()
main1 = do
  print_simple Preview (mybell1 False)

--------------------------------------------------------------
-- * From a matrix

invsq2 :: Cplx (RootTwo (Ratio Integer))
invsq2 = Cplx (RootTwo 0 (1 % 2)) 0   :: Cplx (RootTwo (Ratio Integer))

mymatrix :: Matrix Four Four (Cplx (RootTwo (Ratio Integer)))
mymatrix = matrix  [[ invsq2, 0, invsq2, 0],
                    [ 0, invsq2, 0, invsq2],
                    [ 0, invsq2, 0, -invsq2],
                    [ invsq2, 0, -invsq2, 0]]

synthesized = exact_synthesis mymatrix

mybell2 :: Bool -> Bool -> Circ (Qubit, Qubit)
mybell2 a b = do
  x <- qinit a
  y <- qinit b
  synthesized [x,y]
  return (x,y)

main2 :: IO ()
main2 = do
  print_simple Preview (mybell2 False False)

----------------------------------------------------------------
-- * Simulate function
simulate :: Circ (Qubit,Qubit) -> IO ()
simulate circuit = print (sim_generic (1.0::Float) circuit)

main3 :: IO ()
main3 = do
  simulate (mybell1 False)

main4 :: IO ()
main4 = do
  simulate (mybell2 False False)

-- ----------------------------------------------------------------------
-- * Main

main = do
  putStrLn "\n \n choose an option:"
  putStrLn " 1 - PDF manual implementation of circuit\n"
  putStrLn " 2 - PDF matrix implementation of circuit\n"
  putStrLn " 3 - simulation of first circuit\n"
  putStrLn " 4 - simulation of the second circuit\n"
  line <- getLine
  case line of
    "1" -> do main1
              main
    "2" -> do main2
              main
    "3" -> do main3
              main
    "4" -> do main4
              main
    _ -> do main


text:
module WWN

where

import Data.List
import Data.Ratio
import Data.Char
import Data.Complex
import Nats

binary :: Integral a => a -> [Int]
binary x = reverse (bits x)
  where bits 0 = [0]
        bits 1 = [1]
        bits n = fromIntegral (rem n 2) : bits (quot n 2)

showDigits :: [Int] -> String
showDigits = map intToDigit

bin ::  Integral a => a -> String
bin = showDigits . binary

coprime :: Integer -> Integer -> Bool
coprime m n = (gcd m n) == 1

gcde :: Integral a => a -> a -> (a,a,a)
gcde a b | a == 0 && b == 0 = error "gcd undefined"
         | a < 0  || b < 0  = error "gcd undefined"
         | a == 0           = (b,0,1)
         |           b == 0 = (a,1,0)
         | a > b            = let
                               (k,r)   = quotRem a b
                               (d,x,y) = gcde b r
                              in (d, y, x-k*y)
         | otherwise        = let
                               (k,r)   = quotRem b a
                               (d,x,y) = gcde a r
                              in (d, x-k*y, y)

data Sgn = P | N deriving (Eq,Show)
type MyInt = (Sgn,Natural)

myplus :: MyInt -> MyInt -> MyInt
myplus (s1,m) (s2,n) | s1 == s2           = (s1,m+n)
                     | s1 == P  && n <= m = (P,m-n)
                     | s1 == P  && n > m  = (N,n-m)
                     | otherwise          = myplus (s2,n) (s1,m)

type NatPair = (Natural,Natural)

plus1 :: NatPair -> NatPair -> NatPair
plus1 (m1, m2) (n1, n2) = (m1+n1, m2+n2)

subtr1 :: NatPair -> NatPair -> NatPair
subtr1 (m1, m2) (n1, n2) = plus1 (m1, m2) (n2, n1)

mult1 :: NatPair -> NatPair -> NatPair
mult1 (m1, m2) (n1, n2) = (m1*n1 + m2*n2, m1*n2 + m2*n1)

eq1 :: NatPair -> NatPair -> Bool
eq1 (m1, m2) (n1, n2) = (m1+n2) == (m2+n1)

reduce1 :: NatPair -> NatPair
reduce1 (m1,Z) = (m1,Z)
reduce1 (Z,m2) = (Z,m2)
reduce1 (S m1, S m2) = reduce1 (m1, m2)

decExpand :: Rational -> [Integer]
decExpand x | x < 0     = error "negative argument"
            | r == 0    = [q]
            | otherwise = q : decExpand ((r*10) % d)
   where
   (q,r) = quotRem n d
   n     = numerator x
   d     = denominator x

decForm :: Rational -> (Integer,[Int],[Int])
decForm x | x < 0     = error "negative argument"
          | otherwise = (q,ys,zs)
  where
  (q,r)   = quotRem n d
  n       = numerator x
  d       = denominator x
  (ys,zs) = decF (r*10) d []

decF :: Integer -> Integer -> [(Int,Integer)] -> ([Int],[Int])
decF n d xs | r == 0        = (reverse (q: (map fst xs)),[])
            | elem (q,r) xs = (ys,zs)
            | otherwise     =  decF (r*10) d ((q,r):xs)
     where
     (q',r)  = quotRem n d
     q       = fromIntegral q'
     xs'     = reverse xs
     Just k  = elemIndex (q,r) xs'
     (ys,zs) = splitAt k (map fst xs')

mechanicsRule :: Rational -> Rational -> Rational
mechanicsRule p x = (1 % 2) * (x + (p * (recip x)))

mechanics :: Rational -> Rational -> [Rational]
mechanics p x = iterate (mechanicsRule p) x

sqrtM :: Rational -> [Rational]
sqrtM p | p < 0     = error "negative argument"
        | otherwise = mechanics p s
   where
   s = if xs == [] then 1 else last xs
   xs = takeWhile  (\ m -> m^2 <= p) [1..]

approximate :: Rational -> [Rational] -> Rational
approximate eps (x:y:zs)
  | abs (y-x) < eps = y
  | otherwise       = approximate eps (y:zs)

apprx :: [Rational] -> Rational
apprx = approximate (1/10^6)

mySqrt :: Rational -> Rational
mySqrt p = apprx (sqrtM p)

solveQ :: (Complex Float, Complex Float, Complex Float)
                               -> (Complex Float, Complex Float)
solveQ =  \ (a,b,c) -> if a == 0 then error "not quadratic"
                                 else let d = b^2 - 4*a*c in
                                           ((- b + sqrt d) / 2*a,
                                            (- b - sqrt d) / 2*a)

max_stars_repo_name: palutz/fpLogic

max_issues_repo_name: palutz/fpLogic

max_forks_repo_name: palutz/fpLogic