{-# LANGUAGE NegativeLiterals#-}

{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules#-}
module DocTest.Flat.Instances.Base where
import qualified DocTest
import Test.Tasty(TestTree,testGroup)
import Flat.Instances.Base
import Flat.Instances.Test
import Data.Fixed
import Data.Int
import Data.Complex(Complex(..))
import Numeric.Natural
import Data.Word
import Data.Ratio
import Flat.Run
import Data.Monoid
import qualified Data.List.NonEmpty as B
test = tstBits
y = 33

tests :: IO TestTree
tests = testGroup "Flat.Instances.Base" <$> sequence [  DocTest.test "src/Flat/Instances/Base.hs:104" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let w = Just (11::Word8); a = Alt w <> Alt (Just 24) in tst a == tst w )),  DocTest.test "src/Flat/Instances/Base.hs:107" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( let w = Just (11::Word8); a = Alt Nothing <> Alt w in tst a == tst w )),  DocTest.test "src/Flat/Instances/Base.hs:145" "[ExpectedLine [LineChunk \"(True,0,\\\"\\\")\"]]" (DocTest.asPrint( test () )),  DocTest.test "src/Flat/Instances/Base.hs:158" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test False )),  DocTest.test "src/Flat/Instances/Base.hs:161" "[ExpectedLine [LineChunk \"(True,1,\\\"1\\\")\"]]" (DocTest.asPrint( test True )),  DocTest.test "src/Flat/Instances/Base.hs:176" "[ExpectedLine [LineChunk \"(True,8,\\\"01100001\\\")\"]]" (DocTest.asPrint( test 'a' )),  DocTest.test "src/Flat/Instances/Base.hs:181" "[ExpectedLine [LineChunk \"(True,16,\\\"11001000 00000001\\\")\"]]" (DocTest.asPrint( test 'È' )),  DocTest.test "src/Flat/Instances/Base.hs:184" "[ExpectedLine [LineChunk \"(True,24,\\\"10001101 10011100 00000001\\\")\"]]" (DocTest.asPrint( test '不' )),  DocTest.test "src/Flat/Instances/Base.hs:200" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test (Nothing::Maybe Bool) )),  DocTest.test "src/Flat/Instances/Base.hs:203" "[ExpectedLine [LineChunk \"(True,2,\\\"10\\\")\"]]" (DocTest.asPrint( test (Just False::Maybe Bool) )),  DocTest.test "src/Flat/Instances/Base.hs:209" "[ExpectedLine [LineChunk \"(True,2,\\\"00\\\")\"]]" (DocTest.asPrint( test (Left False::Either Bool ()) )),  DocTest.test "src/Flat/Instances/Base.hs:212" "[ExpectedLine [LineChunk \"(True,1,\\\"1\\\")\"]]" (DocTest.asPrint( test (Right ()::Either Bool ()) )),  DocTest.test "src/Flat/Instances/Base.hs:218" "[ExpectedLine [LineChunk \"(True,16,\\\"11110110 00000001\\\")\"]]" (DocTest.asPrint( test (MkFixed 123 :: Fixed E0) )),  DocTest.test "src/Flat/Instances/Base.hs:221" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( test (MkFixed 123 :: Fixed E0) == test (MkFixed 123 :: Fixed E2) )),  DocTest.test "src/Flat/Instances/Base.hs:234" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Word8) )),  DocTest.test "src/Flat/Instances/Base.hs:237" "[ExpectedLine [LineChunk \"(True,8,\\\"11111111\\\")\"]]" (DocTest.asPrint( test (255::Word8) )),  DocTest.test "src/Flat/Instances/Base.hs:281" "[ExpectedLine [LineChunk \"(True,8,\\\"01111111\\\")\"]]" (DocTest.asPrint( test (127::Word) )),  DocTest.test "src/Flat/Instances/Base.hs:286" "[ExpectedLine [LineChunk \"(True,16,\\\"11111110 00000001\\\")\"]]" (DocTest.asPrint( test (254::Word) )),  DocTest.test "src/Flat/Instances/Base.hs:291" "[ExpectedLine [LineChunk \"(True,24,\\\"10000000 10000000 00000010\\\")\"]]" (DocTest.asPrint( test (32768::Word32) )),  DocTest.test "src/Flat/Instances/Base.hs:296" "[ExpectedLine [LineChunk \"True\"]]" (DocTest.asPrint( all (test (3::Word) ==) [test (3::Word16),test (3::Word32),test (3::Word64)] )),  DocTest.test "src/Flat/Instances/Base.hs:309" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Natural) )),  DocTest.test "src/Flat/Instances/Base.hs:312" "[ExpectedLine [LineChunk \"(True,144,\\\"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000010\\\")\"]]" (DocTest.asPrint( test (2^120::Natural) )),  DocTest.test "src/Flat/Instances/Base.hs:362" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int) )),  DocTest.test "src/Flat/Instances/Base.hs:365" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Int) )),  DocTest.test "src/Flat/Instances/Base.hs:368" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Int) )),  DocTest.test "src/Flat/Instances/Base.hs:371" "[ExpectedLine [LineChunk \"(True,8,\\\"00000011\\\")\"]]" (DocTest.asPrint( test (-2::Int) )),  DocTest.test "src/Flat/Instances/Base.hs:374" "[ExpectedLine [LineChunk \"(True,8,\\\"00000100\\\")\"]]" (DocTest.asPrint( test (2::Int) )),  DocTest.test "src/Flat/Instances/Base.hs:387" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Integer) )),  DocTest.test "src/Flat/Instances/Base.hs:390" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Integer) )),  DocTest.test "src/Flat/Instances/Base.hs:393" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Integer) )),  DocTest.test "src/Flat/Instances/Base.hs:396" "[ExpectedLine [LineChunk \"(True,8,\\\"00011111\\\")\"]]" (DocTest.asPrint( test (-(2^4)::Integer) )),  DocTest.test "src/Flat/Instances/Base.hs:399" "[ExpectedLine [LineChunk \"(True,8,\\\"00100000\\\")\"]]" (DocTest.asPrint( test (2^4::Integer) )),  DocTest.test "src/Flat/Instances/Base.hs:402" "[ExpectedLine [LineChunk \"(True,144,\\\"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (-(2^120)::Integer) )),  DocTest.test "src/Flat/Instances/Base.hs:405" "[ExpectedLine [LineChunk \"(True,144,\\\"10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 10000000 00000100\\\")\"]]" (DocTest.asPrint( test (2^120::Integer) )),  DocTest.test "src/Flat/Instances/Base.hs:416" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int8) )),  DocTest.test "src/Flat/Instances/Base.hs:419" "[ExpectedLine [LineChunk \"(True,8,\\\"11111110\\\")\"]]" (DocTest.asPrint( test (127::Int8) )),  DocTest.test "src/Flat/Instances/Base.hs:422" "[ExpectedLine [LineChunk \"(True,8,\\\"11111111\\\")\"]]" (DocTest.asPrint( test (-128::Int8) )),  DocTest.test "src/Flat/Instances/Base.hs:433" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int16) )),  DocTest.test "src/Flat/Instances/Base.hs:436" "[ExpectedLine [LineChunk \"(True,8,\\\"00000010\\\")\"]]" (DocTest.asPrint( test (1::Int16) )),  DocTest.test "src/Flat/Instances/Base.hs:439" "[ExpectedLine [LineChunk \"(True,8,\\\"00000001\\\")\"]]" (DocTest.asPrint( test (-1::Int16) )),  DocTest.test "src/Flat/Instances/Base.hs:442" "[ExpectedLine [LineChunk \"(True,24,\\\"11111111 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (minBound::Int16) )),  DocTest.test "src/Flat/Instances/Base.hs:447" "[ExpectedLine [LineChunk \"(True,24,\\\"11111110 11111111 00000011\\\")\"]]" (DocTest.asPrint( test (maxBound::Int16) )),  DocTest.test "src/Flat/Instances/Base.hs:460" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int32) )),  DocTest.test "src/Flat/Instances/Base.hs:463" "[ExpectedLine [LineChunk \"(True,40,\\\"11111111 11111111 11111111 11111111 00001111\\\")\"]]" (DocTest.asPrint( test (minBound::Int32) )),  DocTest.test "src/Flat/Instances/Base.hs:466" "[ExpectedLine [LineChunk \"(True,40,\\\"11111110 11111111 11111111 11111111 00001111\\\")\"]]" (DocTest.asPrint( test (maxBound::Int32) )),  DocTest.test "src/Flat/Instances/Base.hs:477" "[ExpectedLine [LineChunk \"(True,8,\\\"00000000\\\")\"]]" (DocTest.asPrint( test (0::Int64) )),  DocTest.test "src/Flat/Instances/Base.hs:480" "[ExpectedLine [LineChunk \"(True,80,\\\"11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001\\\")\"]]" (DocTest.asPrint( test (minBound::Int64) )),  DocTest.test "src/Flat/Instances/Base.hs:483" "[ExpectedLine [LineChunk \"(True,80,\\\"11111110 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111 00000001\\\")\"]]" (DocTest.asPrint( test (maxBound::Int64) )),  DocTest.test "src/Flat/Instances/Base.hs:502" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 00000000 00000000 00000000\\\")\"]]" (DocTest.asPrint( test (0::Float) )),  DocTest.test "src/Flat/Instances/Base.hs:505" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 00000000 00000000 00000001\\\")\"]]" (DocTest.asPrint( test (1.4012984643E-45::Float) )),  DocTest.test "src/Flat/Instances/Base.hs:508" "[ExpectedLine [LineChunk \"(True,32,\\\"00000000 01111111 11111111 11111111\\\")\"]]" (DocTest.asPrint( test (1.1754942107E-38::Float) )),  DocTest.test "src/Flat/Instances/Base.hs:535" "[ExpectedLine [LineChunk \"(True,16,\\\"00000100 00000010\\\")\"]]" (DocTest.asPrint( test (4 :+ 2 :: Complex Word8) )),  DocTest.test "src/Flat/Instances/Base.hs:543" "[ExpectedLine [LineChunk \"(True,16,\\\"00000011 00000100\\\")\"]]" (DocTest.asPrint( test (3%4::Ratio Word8) )),  DocTest.test "src/Flat/Instances/Base.hs:555" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test ([]::[Bool]) )),  DocTest.test "src/Flat/Instances/Base.hs:558" "[ExpectedLine [LineChunk \"(True,5,\\\"10100\\\")\"]]" (DocTest.asPrint( test [False,False] )),  DocTest.test "src/Flat/Instances/Base.hs:592" "[ExpectedLine [LineChunk \"(True,2,\\\"10\\\")\"]]" (DocTest.asPrint( test (B.fromList [True]) )),  DocTest.test "src/Flat/Instances/Base.hs:595" "[ExpectedLine [LineChunk \"(True,4,\\\"0100\\\")\"]]" (DocTest.asPrint( test (B.fromList [False,False]) )),  DocTest.test "src/Flat/Instances/Base.hs:605" "[ExpectedLine [LineChunk \"(True,1,\\\"0\\\")\"]]" (DocTest.asPrint( test (False,()) )),  DocTest.test "src/Flat/Instances/Base.hs:608" "[ExpectedLine [LineChunk \"(True,0,\\\"\\\")\"]]" (DocTest.asPrint( test ((),()) )),  DocTest.test "src/Flat/Instances/Base.hs:613" "[ExpectedLine [LineChunk \"(True,7,\\\"0111011\\\")\"]]" (DocTest.asPrint( test (False,True,True,True,False,True,True) ))]


module Prelude.Containers.Algo (module X) where

import Data.Vector.Lens as X
import Data.IntSet.Lens as X

import Data.Array.Lens as X
import Data.Bits.Lens as X
import Data.ByteString.Lens as X
-- import Data.ByteString.Lazy.Lens as X
-- import Data.ByteString.Strict.Lens as X
import Data.Complex.Lens as X
import Data.Data.Lens as X
import Data.Dynamic.Lens as X
-- import Data.HashSet.Lens as X hiding (setOf, setmapped)  -- conlicts with Data.IntSet.Lens
import Data.List.Lens as X
import Data.Map.Lens as X
import Data.Sequence.Lens as X hiding (sliced)  -- conlicts with Data.Vector.Lens
-- import Data.Set.Lens as X hiding (setOf, setmapped)    -- conlicts with Data.IntSet.Lens
import Data.Text.Lens as X
-- import Data.Text.Lazy.Lens as X
-- import Data.Text.Strict.Lens as X
import Data.Tree.Lens as X
import Data.Typeable.Lens as X
-- import Data.Vector.Generic.Lens as X


{-# LANGUAGE OverloadedStrings #-}

module ML.Gym.Space where

import           ML.Gym.DType
import           ML.Gym.Range
import           ML.Gym.Shape
import           ML.Gym.Util
import           ML.Gym.Value

import qualified Control.Exception        as E
import           Control.Monad            (void)
import qualified CPython                  as Py
import qualified CPython.Constants        as Py
import qualified CPython.Protocols.Object as Py
import qualified CPython.Types            as Py
import qualified CPython.Types.Exception  as Py
import qualified CPython.Types.Module     as Py
import qualified Data.ByteString          as BS
import           Data.Complex             (Complex)
import           Data.Maybe               (fromMaybe)
import qualified Data.Text                as T
import           System.Environment       (getArgs, getProgName)
import           System.Exit
import           System.IO
import           System.Random            (randomRIO)

import           Debug.Trace

class SpaceSize a where
  spaceSize :: a -> Integer     -- Rename to something better

data GymSpace = GymSpaceDiscrete Integer        -- ^ Range: 0...(x-1)
              | GymSpaceBox GymRange GymShape   -- ^ 1D, 2D, or 3D matrix. Range sizes and shape must coincide.
              | GymSpaceTuple [GymSpace]        -- ^ Tuple of Spaces.
              deriving (Show, Eq)

instance SpaceSize GymSpace where
  spaceSize (GymSpaceDiscrete nr)                 = nr
  spaceSize (GymSpaceBox _ (GymShape1D x1))       = x1
  spaceSize (GymSpaceBox _ (GymShape2D x1 x2))    = x1 * x2
  spaceSize (GymSpaceBox _ (GymShape3D x1 x2 x3)) = x1 * x2 * x3
  spaceSize (GymSpaceTuple spaces)                = product (map spaceSize spaces)

toAction :: GymSpace -> Integer -> IO Py.SomeObject
toAction (GymSpaceDiscrete nr) idx
  | idx < 0 || idx > (nr - 1) = error "Action index out of range"
  | otherwise = Py.toObject <$> Py.toInteger idx
toAction (GymSpaceBox _ (GymShape1D x1)) idx = error "Box (probably continuous) actions currently not supported"
toAction (GymSpaceBox _ (GymShape2D x1 x2)) idx = error "Box (probably continuous) actions currently not supported"
toAction (GymSpaceBox _ (GymShape3D x1 x2 x3)) idx = error "Box (probably continuous) actions currently not supported"
toAction (GymSpaceTuple spaces) idx
  | idx >= fromIntegral (length cats) = error "action index is out of range"
  | otherwise = Py.toObject <$> (mapM (fmap Py.toObject . Py.toInteger) (cats !! fromIntegral idx) >>= Py.toList)
  where
    sizes = map spaceSize spaces
    cats = fromCats sizes

fromCats :: [Integer] -> [[Integer]]
fromCats []     = []
fromCats [x]    = map return [0..x-1]
fromCats (x:xs) = concatMap (\cat -> map (cat ++) (fromCats xs)) (fromCats [x])

fromIdx :: [Integer] -> Integer -> [Integer]
fromIdx cats idx =
  -- trace ("rev: " ++ show (reverse $ scanl1 (*) cats))
  zipWith toCat cats (reverse $ scanl1 (*) cats)
  where toCat i c =
          -- trace ("nr: " ++ show nr)
          -- trace ("c: " ++ show c)
          -- trace ("i: " ++ show i)
          (idx `div` (max 1 (c `div` 2))) `mod` i
        nr = product cats

test :: [Integer] -> Bool
test cats = do

  all (\i ->(fromCats cats !! i) == fromIdx cats (fromIntegral i)) [0..product (map fromIntegral cats)-1]

getGymRangeFromSpace :: GymSpace -> GymRange
getGymRangeFromSpace (GymSpaceDiscrete nr)  = GymRange GymInteger (GymScalar 0) (GymScalar $ fromIntegral nr-1)
getGymRangeFromSpace (GymSpaceBox rng _)    = rng
getGymRangeFromSpace (GymSpaceTuple spaces) =
  trace ("from: " ++ show spaces)
  trace ("to: " ++ show (combineRanges $ map getGymRangeFromSpace spaces))
  combineRanges $ map getGymRangeFromSpace spaces

toGymSpace :: Py.Object self => self -> IO GymSpace
toGymSpace space = mkSpaceRepr >>= toGymSpace'
  where
    mkSpaceRepr = fromMaybe (error "could not get gym action space") <$> python (Py.callMethodArgs space "__repr__" [] >>= pyToText)
    toGymSpace' txt
      | T.isPrefixOf "Discrete" txt = do
        n <- fromMaybe (error "Gym discrete space 'n' not recognized!") <$> python (Py.toUnicode "n" >>= Py.getAttribute space >>= pyToInteger)
        return $ GymSpaceDiscrete n
      | T.isPrefixOf "Box" txt = do
        dType <- python $ Py.toUnicode "dtype" >>= Py.getAttribute space >>= getGymDType
        range <- fromMaybe (error $ "could not get gym range: " ++ show dType ++ ", " ++ T.unpack txt) <$> python (getGymRange dType space)
        shape <- fromMaybe (error "could not get gym shape") <$> python (getGymShape space)
        return $ GymSpaceBox range shape
      | T.isPrefixOf "Tuple" txt = do
          list <- fromMaybe (error "Gym discrete space 'n' not recognized!") <$> python (Py.toUnicode "spaces" >>= Py.getAttribute space >>= pyToList)
          spaces <- mapM toGymSpace list
          return $ GymSpaceTuple spaces
      | otherwise = do
        putStrLn "Sample space: "
        python (Py.callMethodArgs space "sample" [] >>= flip Py.print stdout)
        error $ "ERROR: Gym space '" ++ T.unpack txt ++ "' not supported yet!"


{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}

import Data.List (filter, nub, sortBy, nubBy)
import Data.Function (on)
import Data.Maybe (mapMaybe, catMaybes, fromMaybe)
import Control.Monad (when, unless, forM_)
import Data.Bifunctor (second)
import Data.Either (partitionEithers)

import Criterion (Benchmarkable)
import Criterion.Types (Benchmark (..), Report (..), DataRecord( Analysed ), Config (..), SampleAnalysis (..), Verbosity (..), Regression (..))
import Criterion.Internal (runAndAnalyseOne)
import Criterion.Main.Options (defaultConfig)
import Criterion.Measurement (initializeTime, secs)
import Criterion.Monad (withConfig)

import qualified Data.Map as Map

import Statistics.Types (estPoint)

import BenchGraph.Types (ShadowedS (..))
import BenchGraph.Time (allBench, benchmarkCreation)
import BenchGraph.Named
import BenchGraph.Utils (defaultGr)

import Options.Applicative (execParser)

import Data.Aeson (encodeFile, decodeFileStrict)

import qualified Text.Tabular as T
import qualified Text.Tabular.AsciiArt as TAA

import Text.Printf (printf)

import Command
import ListS (listOfSuites, descs)

-- If you are trying to add your library using YourLib/Graph.hs:
--   Uncomment the corresponding lines, and you are ready to build and run

-- UNCOMMENT import qualified YourLib.Graph

import qualified Containers.Graph
#ifdef ALGA
import qualified Alga.Graph
#endif
#ifdef FGL
import qualified Fgl.PatriciaTree
#endif
#ifdef HASHGRAPH
import qualified HashGraph.Gr
#endif

import BenchGraph.Render.Types
import BenchGraph.Render.Result
import BenchGraph.Render.Best
import BenchGraph.Render.Abstract
import BenchGraph.Render.Common

#ifdef CHART
import BenchGraph.Render.Chart
#endif

-- We consider Benchmark equality using their name
instance Eq Benchmark where
  (==) = on (==) showBenchName

showBenchName :: Benchmark -> Name
showBenchName (Benchmark n _)  = n
showBenchName (BenchGroup n _) = n
showBenchName Environment{}    = error "Cannot show the bench name of an Env"

genReport :: [(String,Int)]
          -> Output
          -- ^ Output options
          -> [Named (Either (Named String) Benchmark)]
          -- ^ The list of benchmarks with their library name
          -> IO ()
genReport _ _ [] = putStrLn "\nNo data\n"
genReport gr flg arr = do
  unless notquickComp $ putStrLn $ let comp = head libNames
                                       oth =  head $ tail libNames
                                   in unwords ["\nComparing",comp,"to",oth,". It means that the displayed number will be k such that", comp,"= k *", oth ]
  results <- fmap catMaybes $ mapM mapped $ nubBy (liftExtract2 (==)) refinedarr
  maybe (return ()) (\x -> encodeFile x $ Result gr results) $ saveToFile flg
  case figOut flg of
    Nothing -> return ()
    (Just x) -> renderG gr x $ map (fmap removeTailLast) results
  where
    mapped e = do
      let bname = showBenchName $ snd e
      if notquickComp
        then do
          putStrLn $ unwords [replicate 2 '#',bname]
          maybe (return ()) (putStrLn . (++) "\nDescription: ") (lookup bname descs)
          putStrLn ""
        else putStr $ bname ++ ": "
      res <- toPrint (staOut flg) refinedarr $ snd e
      forM_ (filter (\(_,(a,_)) -> a == showBenchName (snd e)) noimpl) $ \no -> putStrLn $ unwords ["Not implemented for",fst no,"because",snd (snd no)] ++ "."
      case fmap (fmap (map (fmap (\x -> (getCriterionTime x, getStdDev x))))) res of
        Nothing -> return Nothing
        Just res' -> do
          let onlyLargeBenchs = removeTailLast res'
              removeStdDev = fmap (fmap (fmap fst))
          when (sumOut flg) $ if notquickComp
            then do
              printBest "was the fastest" $ removeStdDev res'
              printAbstract "faster" $ removeStdDev onlyLargeBenchs
            else printQuick (head libNames) $ removeStdDev onlyLargeBenchs
          return $ Just (bname,res')
    libNames = nub $ map fst arr
    notquickComp = staOut flg /= QuickComparison
    (noimpl,refinedarr) = partitionEithers $ map stripOutEither arr

renderG :: [(String,Int)] -> ChartOutput -> [(Name, Grouped [(Name, (Double, Double))])] -> IO ()
#ifdef CHART
renderG gr x results = mkChart "Time results" gr secs x $ Right $ sortBy (on compare fst) results
#else
renderG _ _ _ = return ()
#endif

-- | First stage
toPrint :: StaOut -> [Named Benchmark] -> Benchmark -> IO (Maybe (Grouped [Named Report]))
toPrint flg arr breport = doGrp flg toPrint1 $ getOtherGroups breport arr

-- | Second stage
toPrint1 :: StaOut -> [Named Benchmark] -> Benchmark -> IO (Maybe (Grouped [Named Report]))
toPrint1 flg arr breport = do
    when (flg == Ascii || flg == Html) $ putStrLn $ unwords ["###",showBenchName breport]
    res'@(Just (Group res)) <- grp
    let ch = mapMaybe tkGroup res :: [[Grouped [Named Report]]]
        results = reverse $ zip getNOtherGroups $ reverse $ map (mapMaybe tkSimple) ch :: [Named [[Named Report]]] -- Double reverse is necessary, since it can lack some data in the front of ch
        results' = map (fmap (makeAverage . map (map (fmap getCriterionTime))) ) results :: [Named [Named Double]]
    when (flg == Html) $ printHtml results' secs
    return res'
  where
    grp = doGrp flg (toPrint2 0) otherGroups
    getNOtherGroups = reverse $ map (showBenchName . snd) $ nubBy (liftExtract2 (==)) otherGroups
    otherGroups = getOtherGroups breport arr

-- | Last stage
toPrint2 :: Int -> StaOut -> [Named Benchmark] -> Benchmark -> IO (Maybe (Grouped [Named Report]))
toPrint2 lev flg arr breport = do
    when (not (null $ showBenchName breport) && flg == Ascii) $
      putStrLn $ unwords [replicate (4+lev) '#',showBenchName breport]
    case breport of
      BenchGroup{} -> doGrp flg (toPrint2 (lev+1)) $ getOtherGroups breport arr
      Benchmark{} -> do
        simples <- mapM (traverse benchmarkWithoutOutput) $ getOtherSimple breport arr
        when (flg == Ascii) $ putStrLn $ "\n" ++ showSimples simples
        return $ Just $ Simple "" simples -- False by default, changed after
      Environment{} -> error "Not wanted environnement"

getOtherGroups :: Benchmark -> [Named Benchmark] -> [Named Benchmark]
getOtherGroups breport = concatMap sequence . mapMaybe (traverse tkChilds) . filter ((== breport) . snd)

getOtherSimple :: Benchmark -> [Named Benchmark] -> [Named Benchmarkable]
getOtherSimple breport = mapMaybe (traverse tkSimpleB) . filter ((== breport) . snd)

doGrp :: StaOut
      -> (StaOut -> [Named Benchmark] -> Benchmark -> IO (Maybe (Grouped [Named Report])))
      -> [Named Benchmark]
      -> IO (Maybe (Grouped [Named Report]))
doGrp flg f otherGroups =
  case nubBy (liftExtract2 (==)) otherGroups of
    [] -> do
     when (flg == Ascii) $ putStrLn "\nNo data\n"
     return Nothing
    real -> do
     grp <- catMaybes <$> mapM (f flg otherGroups . snd) real
     return $ Just $ Group grp

-- | Bench only if it is possible
tkSimpleB :: Benchmark -> Maybe Benchmarkable
tkSimpleB (Benchmark _ b) = Just b
tkSimpleB _ = Nothing

-- | Get the childs of a BenchGroup, inserting the name of the library
tkChilds :: Benchmark -> Maybe [Benchmark]
tkChilds (BenchGroup _ childs) = Just childs
tkChilds _ = Nothing

showSimples :: [Named Report] -> String
showSimples arr = TAA.render id id id table
  where
    arr' = sortBy (on compare (getCriterionTime . snd)) arr
    arrD = map (\(_,r) -> [secs $ getCriterionTime r, printf "%.3f" $ getRSquare r ]) arr'
    libs = map fst arr'
    table = T.Table
      (T.Group T.NoLine $ map T.Header libs)
      (T.Group T.SingleLine [T.Header "Time", T.Header "R\178"])
      arrD

-- Return the regressed time or the mean if the other is not avaible
getCriterionTime :: Report -> Double
getCriterionTime t = estPoint $ lReg $ regCoeffs $ head $ anRegress $ reportAnalysis t
  where
    lReg = fromMaybe (anMean $ reportAnalysis t) . Map.lookup "iters"

getStdDev :: Report -> Double
getStdDev = estPoint . anStdDev . reportAnalysis

getRSquare :: Report -> Double
getRSquare = estPoint . regRSquare . head . anRegress . reportAnalysis

-- | Utilitary, disable the standard output of Criterion
benchmarkWithoutOutput :: Benchmarkable -> IO Report
benchmarkWithoutOutput bm = do
  initializeTime
  withConfig defaultConfig' $ do
    Analysed rpt <- runAndAnalyseOne 0 "function" bm
    return rpt
  where
    defaultConfig' = defaultConfig {verbosity = Quiet, timeLimit = 10}

main :: IO ()
main = execParser commandP >>= main'

main' :: Command -> IO ()
main' opts
  = case opts of
      List listOpt -> case listOpt of
                        Benchs -> putStr $ unlines grNames
                        Libs -> putStr $ unlines $ nub $ map fst listOfSuites ++ map fst (listOfCreation False [])
      Render filep dg -> do
        readed <- decodeFileStrict filep
        case readed of
          Nothing -> error "Malformed file"
          Just (Result gr res) -> renderG gr dg $ map (fmap removeTailLast) res
      Run opt nottodo' flg libs benchWithCreation dontBenchLittleOnes gr' -> do
        let modifyL = case libs of
              Nothing -> id
              Just libss -> filter (\x -> fst x `elem` libss)
            gr = mkGr gr'
            grList' = modifyL $ grList benchWithCreation dontBenchLittleOnes gr
            nottodo = fromMaybe [] nottodo'
            todo = case opt of
              Nothing -> grNames
              Just opt' -> case opt' of
                  Only bname -> bname
                  Part one' two -> let one = one' + 1
                                       per = length grNames `div` two
                                       f   = if one' + 1 == two then id else take (one*per)
                                    in drop ((one-1)*per) $ f grNames
            samples = filter (\(_,n) -> let nam = either fst showBenchName n in nam `elem` todo && nam `notElem` nottodo) grList'
        unless (staOut flg == QuickComparison) $ printHeader gr $ nub $ map (either fst showBenchName . snd) samples
        genReport gr flg samples
  where
    grNames = nub $ map (either fst showBenchName . snd) $ grList False False defaultGr
    grList benchWithCreation dontBenchLittleOnes gr = sortBy (on compare (either fst showBenchName . snd)) $
      map (fmap (\(Shadow s) -> second (allBench benchWithCreation dontBenchLittleOnes gr) s)) listOfSuites
      ++ listOfCreation dontBenchLittleOnes gr
    mkGr gr' = case gr' of
                 [] -> defaultGr
                 g -> g

-- Note: The layout of the list is important
listOfCreation :: Bool -> [(String,Int)] -> [Named (Either (String,String) Benchmark)]
listOfCreation dontBenchLittleOnes gr =
  [ ("Containers", Right $ benchmarkCreation dontBenchLittleOnes gr Containers.Graph.mk)
#ifdef ALGA
  , ("Alga", Right $ benchmarkCreation dontBenchLittleOnes gr Alga.Graph.mk )
#endif
#ifdef FGL
  , ("Fgl", Right $ benchmarkCreation dontBenchLittleOnes gr Fgl.PatriciaTree.mk)
#endif
#ifdef HASHGRAPH
  , ("Hash-Graph", Right $ benchmarkCreation dontBenchLittleOnes gr HashGraph.Gr.mk)
#endif
-- UNCOMMENT, ("YourFancyLibName", benchmarkCreation dontBenchLittleOnes gr YourLib.Graph.mk)
  ]


module Statistics.Iteratee (
  module S
) where

import Statistics.Iteratee.Sample as S
import Statistics.Iteratee.Uniform as S


{-# LANGUAGE ScopedTypeVariables #-}

import           Control.Monad.Primitive
import           Data.Complex
import           Control.Monad

import qualified Data.Vector.Generic               as VG
import qualified Data.Vector.Generic.Mutable       as VGM
import qualified Data.Vector.Storable              as VS
import qualified Data.Vector.Storable.Mutable      as VSM

import           Test.QuickCheck
import           Test.QuickCheck.Monadic
import           Test.Framework (defaultMain, testGroup)
import           Test.Framework.Providers.QuickCheck2 (testProperty)

import           SDR.FilterInternal
import           SDR.Util
import           SDR.CPUID

sameResultM :: Monad m => (a -> a -> Bool) -> [m a] -> m Bool
sameResultM _  []     = return True
sameResultM eq (x:xs) = do
    res  <- x
    ress <- sequence xs
    return $ all (eq res) ress

sameResult :: (a -> a -> Bool) -> [a] -> Bool
sameResult _ [] = True
sameResult eq (x:xs) = all (eq x) xs

tests info = [
        testGroup "filters" [
            testProperty "real"    propFiltersReal,
            testProperty "complex" propFiltersComplex
        ],
        testGroup "decimators" [
            testProperty "real"    propDecimationReal,
            testProperty "complex" propDecimationComplex
        ],
        testGroup "resamplers" [
            testProperty "real" propResamplingReal,
            testProperty "complex" propResamplingComplex
        ],
        testGroup "conversion" [
            testProperty "rtlsdr"  propConversionRTLSDR,
            testProperty "BladeRF" propConversionBladeRF
        ],
        testProperty "scaling"    propScaleReal
    ]
    where
    hasFeatures :: [(CPUInfo -> Bool, a)] -> [a]
    hasFeatures = map snd . filter (($ info) . fst)

    sizes           = elements [1024, 2048, 4096, 8192, 16384, 32768, 65536]
    numCoeffs       = elements [32, 64, 128, 256, 512]
    factors'        = [1, 2, 3, 5, 7, 11, 13, 17, 23]
    factors         = elements factors'

    propFiltersReal =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBuf ->
                forAll numCoeffs $ \numCoeffs ->
                    forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                        testFiltersReal size numCoeffs coeffs inBuf

    testFiltersReal :: Int -> Int -> [Float] -> [Float] -> Property
    testFiltersReal size numCoeffs coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = size - numCoeffs*2 + 1

        res <- run $ sameResultM eqDelta $ map (getResult num) $ hasFeatures [
                (const True, filterHighLevel       vCoeffs     num vInput),
                (const True, filterImperative1     vCoeffs     num vInput),
                (const True, filterImperative2     vCoeffs     num vInput),
                (const True, filterCRR             vCoeffs     num vInput),
                (hasSSE42,   filterCSSERR          vCoeffs     num vInput),
                (hasAVX,     filterCAVXRR          vCoeffs     num vInput),
                (hasSSE42,   filterCSSESymmetricRR vCoeffsHalf num vInput),
                (hasAVX,     filterCAVXSymmetricRR vCoeffsHalf num vInput)
            ]
        assert res

    propFiltersComplex =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBufR ->
                forAll (vectorOf size (choose (-10, 10))) $ \inBufI ->
                    forAll numCoeffs $ \numCoeffs ->
                        forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                            testFiltersComplex size numCoeffs coeffs $ zipWith (:+) inBufR inBufI

    testFiltersComplex :: Int -> Int -> [Float] -> [Complex Float] -> Property
    testFiltersComplex size numCoeffs coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = size - numCoeffs*2 + 1
            vCoeffs2    = VG.fromList $ duplicate $ coeffs ++ reverse coeffs

        res <- run $ sameResultM eqDeltaC $ map (getResult num) $ hasFeatures [
                (const True, filterHighLevel       vCoeffs  num vInput),
                (const True, filterCRC             vCoeffs  num vInput),
                (hasSSE42,   filterCSSERC          vCoeffs2 num vInput),
                (hasSSE42,   filterCSSERC2         vCoeffs  num vInput),
                (hasAVX,     filterCAVXRC          vCoeffs2 num vInput),
                (hasSSE42,   filterCSSESymmetricRC vCoeffsHalf num vInput),
                (hasAVX,     filterCAVXSymmetricRC vCoeffsHalf num vInput)
            ]
        assert res

    propDecimationReal =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBuf ->
                forAll numCoeffs $ \numCoeffs ->
                    forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                       forAll factors $ \factor ->
                            testDecimationReal size numCoeffs factor coeffs inBuf

    testDecimationReal :: Int -> Int -> Int -> [Float] -> [Float] -> Property
    testDecimationReal size numCoeffs factor coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = (size - numCoeffs*2 + 1) `quot` factor

        res <- run $ sameResultM eqDelta $ map (getResult num) $ hasFeatures [
                (const True, decimateHighLevel       factor vCoeffs     num vInput),
                (const True, decimateCRR             factor vCoeffs     num vInput),
                (hasSSE42,   decimateCSSERR          factor vCoeffs     num vInput),
                (hasAVX,     decimateCAVXRR          factor vCoeffs     num vInput),
                (hasSSE42,   decimateCSSESymmetricRR factor vCoeffsHalf num vInput),
                (hasAVX,     decimateCAVXSymmetricRR factor vCoeffsHalf num vInput)
            ]
        assert res

    propDecimationComplex =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBufR ->
                forAll (vectorOf size (choose (-10, 10))) $ \inBufI ->
                    forAll numCoeffs $ \numCoeffs ->
                        forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                            forAll factors $ \factor ->
                                testDecimationComplex size numCoeffs factor coeffs $ zipWith (:+) inBufR inBufI

    testDecimationComplex :: Int -> Int -> Int -> [Float] -> [Complex Float] -> Property
    testDecimationComplex size numCoeffs factor coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = (size - numCoeffs*2 + 1) `quot` factor
            vCoeffs2    = VG.fromList $ duplicate $ coeffs ++ reverse coeffs

        res <- run $ sameResultM eqDeltaC $ map (getResult num) $ hasFeatures [
                (const True, decimateHighLevel       factor vCoeffs  num vInput),
                (const True, decimateCRC             factor vCoeffs  num vInput),
                (hasSSE42,   decimateCSSERC          factor vCoeffs2 num vInput),
                (hasSSE42,   decimateCSSERC2         factor vCoeffs  num vInput),
                (hasAVX,     decimateCAVXRC          factor vCoeffs2 num vInput),
                (hasSSE42,   decimateCSSESymmetricRC factor vCoeffsHalf  num vInput),
                (hasAVX,     decimateCAVXRC2         factor vCoeffs  num vInput),
                (hasAVX,     decimateCAVXSymmetricRC factor vCoeffsHalf  num vInput)
            ]
        assert res

    propResamplingReal =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBuf ->
                forAll (elements [32 .. 512]) $ \numCoeffs ->
                    forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                       forAll (elements $ tail factors') $ \decimation ->
                           forAll (elements $ filter (< decimation) factors') $ \interpolation ->
                               forAll (elements [0..interpolation - 1]) $ \group ->
                                   testResamplingReal size group numCoeffs interpolation decimation coeffs inBuf

    testResamplingReal :: Int -> Int -> Int -> Int -> Int -> [Float] -> [Float] -> Property
    testResamplingReal size group numCoeffs interpolation decimation coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = (size - numCoeffs*2 + 1) `quot` decimation
            offset       = interpolation - 1 - ((interpolation + group * decimation - 1) `mod` interpolation)

        resampler3 <- run $ resampleCRR2   interpolation decimation (coeffs ++ reverse coeffs)
        resampler4 <- run $ resampleCSSERR interpolation decimation (coeffs ++ reverse coeffs)
        resampler5 <- run $ resampleCAVXRR interpolation decimation (coeffs ++ reverse coeffs)

        res <- run $ sameResultM eqDelta $ map (getResult num) $ hasFeatures [
                (const True, void . resampleHighLevel       interpolation decimation vCoeffs offset num vInput),
                (const True, void . resampleCRR             num interpolation decimation offset vCoeffs vInput),
                (const True, void . resampler3              group num vInput),
                (hasSSE42,   void . resampler4              group num vInput),
                (hasAVX,     void . resampler5              group num vInput)
            ]
        assert res

    propResamplingComplex =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBufR ->
                forAll (vectorOf size (choose (-10, 10))) $ \inBufI ->
                    forAll (elements [32 .. 512]) $ \numCoeffs ->
                        forAll (vectorOf numCoeffs (choose (-10, 10))) $ \coeffs ->
                           forAll (elements $ tail factors') $ \decimation ->
                               forAll (elements $ filter (< decimation) factors') $ \interpolation ->
                                   forAll (elements [0..interpolation - 1]) $ \group ->
                                       testResamplingComplex size group numCoeffs interpolation decimation coeffs $ zipWith (:+) inBufR inBufI

    testResamplingComplex :: Int -> Int -> Int -> Int -> Int -> [Float] -> [Complex Float] -> Property
    testResamplingComplex size group numCoeffs interpolation decimation coeffs inBuf = monadicIO $ do
        let vCoeffsHalf = VS.fromList coeffs
            vCoeffs     = VS.fromList $ coeffs ++ reverse coeffs
            vInput      = VS.fromList inBuf
            num         = (size - numCoeffs*2 + 1) `quot` decimation
            offset       = interpolation - 1 - ((interpolation + group * decimation - 1) `mod` interpolation)

        resampler3 <- run $ resampleCRC    interpolation decimation (coeffs ++ reverse coeffs)
        resampler4 <- run $ resampleCSSERC interpolation decimation (coeffs ++ reverse coeffs)
        resampler5 <- run $ resampleCAVXRC interpolation decimation (coeffs ++ reverse coeffs)

        res <- run $ sameResultM eqDeltaC $ map (getResult num) $ hasFeatures [
                (const True, void . resampleHighLevel       interpolation decimation vCoeffs offset num vInput),
                (const True, void . resampler3              group num vInput),
                (hasSSE42,   void . resampler4              group num vInput),
                (hasAVX,     void . resampler5              group num vInput)
            ]
        assert res

    propConversionRTLSDR =
        forAll sizes $ \size ->
            forAll (vectorOf (2 * size) (choose (-10, 10))) $ \inBuf ->
                testConversionRTLSDR size inBuf
    testConversionRTLSDR :: Int -> [Int] -> Property
    testConversionRTLSDR size inBuf = monadicIO $ do
        let vInput = VS.fromList $ map fromIntegral inBuf

        let res = sameResult eqDeltaC $ map VG.toList $ hasFeatures [
                (const True, (interleavedIQUnsigned256ToFloat    vInput :: VS.Vector (Complex Float))),
                (const True, interleavedIQUnsignedByteToFloat    vInput),
                (hasSSE42,   interleavedIQUnsignedByteToFloatSSE vInput),
                (hasAVX2,    interleavedIQUnsignedByteToFloatAVX vInput)
                ]
        assert res

    propConversionBladeRF =
        forAll sizes $ \size ->
            forAll (vectorOf (2 * size) (choose (-10, 10))) $ \inBuf ->
                testConversionBladeRF size inBuf
    testConversionBladeRF :: Int -> [Int] -> Property
    testConversionBladeRF size inBuf = monadicIO $ do
        let vInput = VS.fromList $ map fromIntegral inBuf

        let res = sameResult eqDeltaC $ map VG.toList $ hasFeatures [
                (const True, (interleavedIQSigned2048ToFloat   vInput :: VS.Vector (Complex Float))),
                (const True, interleavedIQSignedWordToFloat    vInput),
                (hasSSE42,   interleavedIQSignedWordToFloatSSE vInput),
                (hasAVX2,    interleavedIQSignedWordToFloatAVX vInput)
                ]
        assert res

    scales        = elements [0.1, 0.5, 1, 2, 10]
    propScaleReal =
        forAll sizes $ \size ->
            forAll (vectorOf size (choose (-10, 10))) $ \inBuf ->
                forAll scales $ \factor ->
                    testScaleReal size inBuf factor
    testScaleReal :: Int -> [Float] -> Float -> Property
    testScaleReal size inBuf factor = monadicIO $ do
        let vInput = VS.fromList inBuf

        res <- run $ sameResultM eqDelta $ map (getResult size) $ hasFeatures [
                (const True, scaleC    factor vInput),
                (hasSSE42,   scaleCSSE factor vInput),
                (hasAVX,     scaleCAVX factor vInput)
            ]
        assert res

    getResult :: (VSM.Storable a) => Int -> (VS.MVector RealWorld a -> IO b) -> IO [a]
    getResult size func = do
        outBuf <- VGM.new size
        func outBuf
        out :: VS.Vector a <- VG.freeze outBuf
        return $ VG.toList out
    eqDelta x y = all (uncurry eqDelta') $ zip x y
        where
        eqDelta' x y = abs (x - y) < 0.01
    eqDeltaC x y = all (uncurry eqDelta') $ zip x y
        where
        eqDelta' x y = magnitude (x - y) < 0.01
    duplicate :: [a] -> [a]
    duplicate = concatMap func
        where func x = [x, x]

main = do
    info <- getCPUInfo
    defaultMain $ tests info


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

module Pact.GasModel.GasModel where

import Control.Exception (bracket)
import Control.Monad (void, replicateM)
import Data.List (foldl', sortOn)
import GHC.Conc (numCapabilities)
import Statistics.Types (Estimate(..))

import qualified Criterion.Main as C
import qualified Criterion as C
import qualified Criterion.Types as C
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Data.Csv as Csv
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Options.Applicative as O

import Pact.Eval (eval)
import Pact.GasModel.GasTests
import Pact.GasModel.Types
import Pact.GasModel.Utils
import Pact.Types.Lang
import Pact.Types.Runtime hiding (GasPrice)

data Option = Option
  { _oFilter :: Maybe T.Text
  , _oBenchOnly :: Bool
  }
  deriving (Eq,Show)

options :: O.ParserInfo Option
options = O.info (O.helper <*> parser)
          (O.fullDesc <> O.header "Gas Model Benchmarks")
  where
    parser =
      Option
      <$> ((Just <$> O.strOption
            (O.short 'f' <> O.long "filter" <> O.metavar "NATIVE" <>
             O.help "Pipe-delimited list of natives to run")) O.<|>
            pure Nothing)
      <*> (O.flag False True
           (O.short 'b' <> O.long "bench" <> O.help "Just bench and display gas price"))

optionToGasTests
  :: Option
  -> [(NativeDefName, GasUnitTests)]
optionToGasTests opt = HM.toList $
  case _oFilter opt of
    Nothing -> unitTests
    Just ts -> HM.filterWithKey matchingFuns unitTests
      where tlist = NativeDefName <$> T.split (== '|') ts
            matchingFuns k _ = k `elem` tlist

type NanoSeconds = Double

secToNs :: Double -> NanoSeconds
secToNs dInSeconds =
  dInSeconds * 1000000000

newtype Average = Average Double
instance Csv.ToField Average where
  toField (Average avg) = Csv.toField avg

average :: (Foldable f) => f Double -> Average
average nums = Average $! totalSum / (fromIntegral size)
  where (totalSum,size) = foldl' f (0.0, 0 :: Int) nums
        f (!sum', !size') x = (sum' + x, size' + 1)

newtype GasPrice = GasPrice Integer
  deriving (Show)
instance Csv.ToField GasPrice where
  toField (GasPrice p) = Csv.toField p

gasPriceDivisor :: Double
gasPriceDivisor = 2500.0

gasPrice :: [NanoSeconds] -> GasPrice
gasPrice measurements = GasPrice price
  where
    (Average avg) = average measurements
    price = ceiling (avg / gasPriceDivisor)

exec
  :: EvalState
  -> EvalEnv e
  -> [Term Name]
  -> IO (Either PactError [Term Name], EvalState)
exec s e terms = runEval' s e $ mapM eval terms

mockRun
  :: PactExpression
  -> (EvalEnv e, EvalState)
  -> IO (Either PactError [Term Name], EvalState)
mockRun expr (env, state) = do
  terms <- compileCode (_pactExpressionFull expr)
  exec state env terms

setupEnv :: GasSetup e -> IO (EvalEnv e, EvalState)
setupEnv (GasSetup e s _ _) = do
  env <- e
  state <- s
  return (env, state)

mockRuns
  :: GasUnitTests
  -> IO ()
mockRuns tests = do
  void $ mapOverGasUnitTests tests run run
  where
    run expr dbSetup = do
      putStrLn $ "Dry run for " ++ T.unpack (getDescription expr dbSetup)

      (res,_) <- bracket (setupEnv dbSetup)
                         (gasSetupCleanup dbSetup)
                         (mockRun expr)
      eitherDie (getDescription expr dbSetup) res

-- | For debugging purposes
mockRuns'
  :: GasUnitTests
  -> IO [GasTestResult (Either PactError [Term Name], EvalState)]
mockRuns' tests = do
  mapOverGasUnitTests tests run run
  where
    run expr dbSetup = do
      bracket (setupEnv dbSetup) (gasSetupCleanup dbSetup) (mockRun expr)

bench
  :: PactExpression
  -> GasSetup e
  -> IO NanoSeconds
bench expr dbSetup = do
  terms <- compileCode (_pactExpressionFull expr)
  putStrLn $ T.unpack (getDescription expr dbSetup)
  report <- bracket setup teardown $ C.benchmark' . (run terms)
  return $ secToNs $
           estPoint $
           C.anMean $
           C.reportAnalysis report
  where
    setup = do
      s <- setupEnv dbSetup
      return $ NoopNFData s
    teardown (NoopNFData env) = do
      (gasSetupCleanup dbSetup) env
    run terms ~(NoopNFData (env, state)) =
          C.nfIO (exec state env terms)

benchesOnce
  :: GasUnitTests
  -> IO [GasTestResult Average]
benchesOnce tests =
  mapOverGasUnitTests tests run run
  where
    run expr setup = do
      means <- replicateM 1 $ bench expr setup
      return $! average means

-- | Benchmarks each native function's tests three times
benchesMultiple
  :: (NativeDefName, GasUnitTests)
  -> IO (NativeDefName, [GasTestResult Average])
benchesMultiple (funName, tests) = do
  results <- mapOverGasUnitTests tests run run
  return (funName, results)
  where
    batchSize = 3
    run expr setup = do
      means <- replicateM batchSize $ bench expr setup
      return $! average means

meansToCSVEncoding
  :: [GasTestResult Average]
  -> (Csv.Header, [Csv.NamedRecord])
meansToCSVEncoding results =
  (Csv.header headersField, map toNamedRecord results)
  where
    headersField =
      map Csv.toField (["function", "description",
                        "sqliteDbAverage (ns)", "mockDbAverage (ns)"] :: [T.Text])
    toNamedRecord (GasTestResult funName desc sqlAvg mockAvg) =
      Csv.namedRecord $
      zip headersField [Csv.toField (asString funName),
                        Csv.toField desc,
                        Csv.toField sqlAvg,
                        Csv.toField mockAvg
                       ]

writeRawCSV
  :: [GasTestResult Average]
  -> IO ()
writeRawCSV results = do
  let (headers, records) = meansToCSVEncoding results
      content = Csv.encodeByName headers records
  BSL8.writeFile "gas-model-raw-data.csv" content

sqliteGasPrice :: [GasTestResult Average] -> GasPrice
sqliteGasPrice rawResults = gasPrice dataPoints
  where
    dataPoints =
      map (liftAverage . _gasTestResultSqliteDb) onlySimpleTestResults
      where liftAverage (Average d) = d

    onlySimpleTestResults =
      filter simpleTestCheck rawResults
      where
        simpleTestCheck (GasTestResult _ desc _ _) =
          (not $ T.isInfixOf "med" desc) &&
          (not $ T.isInfixOf "long" desc)

encodeGasPrice
  :: [(NativeDefName, GasPrice)]
  -> (Csv.Header, [Csv.NamedRecord])
encodeGasPrice allPrices =
  (headers,
   map encodeFunctionPrice allPrices
  )
  where
    priceHeader =
      "gas price (" <> T.pack (show gasPriceDivisor) <> " ns)"
    functionNameHeader = "function"
    headers = Csv.header $
      map Csv.toField [functionNameHeader, priceHeader]

    encodeFunctionPrice (funName, price) =
      Csv.namedRecord $
      [(Csv.toField functionNameHeader) Csv..= asString funName] <>
      [(Csv.toField priceHeader) Csv..= price]

gasPriceExplanation :: [T.Text]
gasPriceExplanation = [purpose, numCores, os, hardwareNotes,
                       implementation, numOfIterations, backend, calcPrice, ""]
  where
    purpose = "Purpose: Calculate the gas price of Pact native functions using a data-driven model"
    numCores = "Number of cores available for benchmarks: " <> T.pack (show numCapabilities)
    os = "Operating System: <INSERT OS>"
    hardwareNotes = "More information on hardware used: <INSERT MORE INFORMATION ON HARDWARE USED>"
    implementation = "Implementation: For every native function, executes and benchmarks "
                     <> "(using Criterion) simple examples of said function."
    numOfIterations = "Number of iterations: Each function's tests are run three times against each backend type and averaged."
    backend = "Benchmark backend(s): [Sqlite db with `fastNoJournalPragmas`]"
    calcPrice = "From benchmark to a native function's price: For every backend type, all of the means of the function's"
                <>" benchmark examples are converted into nanoseconds, averaged together, divided by "
                <> T.pack (show gasPriceDivisor)
                <> ", and rounded up to the nearest integer."
                <> "Only the benchmark averages of the simple function tests are used when calculating the function's price."

writeGasPriceCSV
  :: [(NativeDefName, [GasTestResult Average])]
  -> IO ()
writeGasPriceCSV allResults = do
  let gasPrices = map (\(n,res) -> (n, sqliteGasPrice res)) allResults
      (headers, records) = encodeGasPrice gasPrices
      content = Csv.encodeByName headers records
      explanation = Csv.encode $
        map (\t -> Csv.record [Csv.toField t]) gasPriceExplanation
  BSL8.writeFile "gas-prices.csv" (explanation <> content)

coverageReport :: IO ()
coverageReport = do
  print $ "Missing benchmark tests for "
           ++ show (length untestedNatives)
           ++ " out of "
           ++ show (length allNatives)
           ++ " native functions."
  mapM_ (print . show) untestedNatives

main :: IO ()
main = do
  opt <- O.execParser options
  let tests = optionToGasTests opt

  -- Enforces that unit tests succeed
  putStrLn "Doing dry run of benchmark tests"
  mapM_ (mockRuns . snd) tests

  putStrLn "Running benchmark(s)"

  if _oBenchOnly opt then
    let displayGasPrice (funName, t) = do
          res <- benchesOnce t
          putStrLn $ (T.unpack (asString funName)) ++ ": " ++ show (sqliteGasPrice res)
          putStrLn ""
    in mapM_ displayGasPrice tests
  else do
    let testsSorted = sortOn fst tests
    allBenches <- mapM benchesMultiple testsSorted

    putStrLn "Exporting raw benchmarks data"
    writeRawCSV (concatMap snd allBenches)

    putStrLn "Exporting data-driven gas prices"
    writeGasPriceCSV allBenches

    putStrLn "Reporting coverage"
    coverageReport

-- | For debugging
runGasTestByName :: T.Text -> IO [GasTestResult (Either PactError [Term Name], EvalState)]
runGasTestByName nname = do
  case (unitTestFromDef (NativeDefName nname)) of
    Nothing -> eitherDie nname (Left ("gas tests not found" :: T.Text))
    Just g -> mockRuns' g

runAllGasTests :: IO ()
runAllGasTests = do
  mapM_ (mockRuns . snd) (HM.toList unitTests)


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE BangPatterns      #-}
{-| A simple, full dictionary, which maintains:

(1) A bijection of words and IDs (one to one);
(2) A count of every word
(3) Methods for keeping memory use under control using filtering

ID 0 is special in this implementation and represents the count and response of
the unknown word. This has some advantages:

(1) Remapping words after they are filtered is easy: map them to unknown, aka 0
(2) The lookup function is total (no undefined or Nothing to handle)
(3) It serves as a nice default (it looks like background noise)
(4) If you don't want that information, use (Vector.drop 1 vec) to eliminate it,
    or use ((Vector.//) vec [(0,0)]) to 0 it out.
|-}
module NLP.Albemarle.Dict
  ( -- * Using Dictionaries
  Dict(..)
  , counts
  , ids
  , countOf
  , idOf
  , select
  , selectMatrix
  , shift
  , size
  , asSparseMatrix
  , asSparseVector
  , asDenseVector

  -- * Creating Dictionaries
  , dictify
  , dictifyAllWords
  , dictifyFirstWords
  , dictifyDefault

  -- * Modifying Dictionaries
  , filterDict
  ) where
import ClassyPrelude
import Control.Monad.ST
import NLP.Albemarle
import qualified Data.Vector.Instances
import qualified Data.Vector.Generic as Vec
import Data.Vector.Generic ((//))
import qualified Data.Vector as BVec
import qualified Data.Vector.Unboxed as UVec
import qualified Data.Vector.Algorithms.Search as VSearch
import qualified Data.Vector.Algorithms.Intro as VSort
import qualified Data.List.Ordered as OList

import Data.Text (Text)
import qualified Data.Text as Text
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import System.IO.Streams (InputStream, OutputStream)
import qualified System.IO.Streams as Streams
import Numeric.LinearAlgebra (Matrix)
import qualified Numeric.LinearAlgebra as HMatrix
import qualified Numeric.LinearAlgebra.Data as HMatrix
import Lens.Micro.TH
import Lens.Micro
import Data.Tuple (swap)
import Data.List.Split

data Dict = Dict {
  _counts :: !(HashMap Text Int),
  _ids :: !(BVec.Vector Text)
} deriving (Show, Eq)

makeLenses ''Dict

instance Monoid Dict where
  mempty = Dict {_counts=mempty, _ids=Vec.singleton ""}
  -- | Union two Dicts (a synonym for mappend). Dict's of huge corpora can be a
  --   memory hog, so consider using filterDict occasionally to manage that.
  mappend left right = Dict {
      _counts = HashMap.unionWith (+) (left^.counts) (right^.counts),
      _ids = Vec.fromList
        $ OList.nub
        $ Vec.toList
        $ Vec.modify VSort.sort (left^.ids <> right^.ids)
    }
instance Semigroup Dict where
  (<>) = mappend

sortNewV v = Vec.modify VSort.sort $ Vec.fromList v

-- | Filter the dictionary: remove stopwords and hepaxes.
filterDict :: Int   -- ^ the minimum word occurences (to remove rare words)
  -> Float  -- ^ the maximum proportion (0,1] of a word (to remove stopwords)
  -> Int    -- ^ the maximum number of unique words total (to cap memory)
  -> Dict   -- ^ the original dictionary
  -> Dict   -- ^ new dictionary
filterDict min_thresh max_fraction max_words dict = let
  max_thresh = floor
    $ (max_fraction *)
    $ fromIntegral
    $ sum
    $ HashMap.elems
    $ dict^.counts
  new_counts =
    HashMap.fromList
    -- This makes sure we preserve the unknown if we can, otherwise 0.
    $ cons ("", HashMap.lookupDefault 0 "" $ dict^.counts)
    $ take max_words
    $ sortOn (negate.snd)
    $ HashMap.toList
    $ HashMap.filter (\v -> min_thresh<=v && v<=max_thresh)
    $ dict^.counts
  in Dict {
    _counts = new_counts,
    _ids = sortNewV $ HashMap.keys new_counts
  }

-- | Get from a dictionary how many times a word was encountered.
--   What exactly this means depends on if you train the dictionary with
--   dictifyAllWords or dictifyFirstWords.
--   Unknown words return a 0. Keep in mind that on account of filterDict this
--   may not mean it doesn't exist in the corpus; it might have been trimmed
--   because it was too common, too rare, or there wasn't enough memory
countOf :: Dict -> Text -> Int
countOf dict word = fromMaybe 0 $ HashMap.lookup word $ dict^.counts

-- | Get the ID of a word from a Dictionary. Unknown words get a 0 (by design).
idOf :: Dict -> Text -> Int
idOf Dict{_ids=vec} word = runST $ do
  mvec <- Vec.thaw vec
  idx <- VSearch.binarySearch mvec word -- Why is this not pure?!
  return $! maybe 0 (\it-> if it == word then idx else 0) $ (Vec.!?) vec idx

-- | Make a sparse vector representing one document using this dict.
--
--   The length of the vector is the size of the vocabulary, plus one. Keep in
--   mind that the length is determined at runtime so pay attention that you do
--   not use vectors from different dictionaries together lest you cause
--   runtime errors.
asSparseVector :: Dict -> [Text] -> SparseVector
asSparseVector dict = SparseVector (Vec.length $ dict^.ids)
  . sort -- Strictly speaking this isn't always necessary but it is for LSA
  -- . cons (0,0.0) -- This shows we count from 0 (it just happens to be 0.0 there)
  . HashMap.toList
  . HashMap.fromListWith (+)
  . fmap (\w-> (idOf dict w, 1.0))

-- | Make a sparse matrix representing one document using this dict.
--
--   The width of the matrix is the size of the vocabulary, plus one. Keep in
--   mind that the length is determined at runtime so pay attention that you do
--   not use matrices from different dictionaries together lest you cause
--   runtime errors.
--
--   This is equavalent to but faster than repeated SparseVectors because it
--   builds a Hashmap first [O(v)] and then uses that [O(1)/lookup] rather than
--   doing no preparation [O(0)] and repeatedly using binary search [O(log v)]
--   Usually this is a 10-fold or better speedup.
asSparseMatrix :: Dict -> [[Text]] -> SparseMatrix
asSparseMatrix dict = let
  toid word = HashMap.lookupDefault 0 word           -- this evalues many times
    $ HashMap.fromList $ zip (v2l $ dict^.ids) [0..] -- this evaluates once
  tovec = SparseVector (Vec.length $ dict^.ids)
    . sort -- Strictly speaking this isn't always necessary but it is for LSA
    -- . cons (0,0.0) -- This shows we count from 0 (it just happens to be 0.0 there)
    . HashMap.toList
    . HashMap.fromListWith (+)
    . fmap (\w-> (toid w, 1.0))
  in SparseMatrix (Vec.length $ dict^.ids)
    . fmap tovec

-- | Make a dense vector representing one document using this dict.
--
--   The length of the vector is the size of the vocabulary, plus one. Keep in
--   mind that the length is determined at runtime so pay attention that you do
--   not use vectors from different dictionaries together lest you cause
--   runtime errors.
asDenseVector :: Dict -> [Text] -> DenseVector
asDenseVector dict =
  Vec.accum (+) (Vec.replicate (Vec.length $ dict^.ids) 0)
  . fmap (\w-> (idOf dict w, 1.0))

-- | O(n + v log v) Create a dictionary from a single document
--   (also consider the [[Text]] -> Dictionary alternatives, they may be faster)
dictify :: [Text] -> Dict
dictify wds = let
  cts = HashMap.fromListWith (+)
    $ cons ("", 0) -- This is to preserve the 0-is-nothing property
    $ (\x -> (x, 1)) <$> wds
  in Dict {
    _counts = cts,
    _ids = sortNewV $ HashMap.keys cts
  }

-- | Create a dictionary from many documents, where every instance of every word
--   counts. (As opposed to dictifyFirstWords.) Might be faster than FirstWords.
dictifyAllWords :: [[Text]] -> Dict
dictifyAllWords = dictify . mconcat

-- | Create a dictionary from many documents, counting only the first instance
--   of each word in a given document. Might be slower than AllWords.
dictifyFirstWords :: [[Text]] -> Dict
dictifyFirstWords = dictifyAllWords . fmap (HashSet.toList . HashSet.fromList)

-- | Use some sensible defaults for making large dictionaries:
-- handle 10k documents at a time, remove word with <= 2 instances in 10k docs,
-- remove words in >= 50% of documents, and limit to 1000000 unique words.
dictifyDefault :: [[Text]] -> Dict
dictifyDefault =
  foldl' (\l r -> filterDict 2 0.5 1000000 $ l <> r) mempty
  . fmap (dictifyAllWords)
  . chunksOf 10000

-- | O(1) Retrieve the number of unique words in the vocabulary
size :: Dict -> Int
size dict = HashMap.size $ dict^.counts

-- | O(v) Retrieve the total number of (non-unique) words processed
support :: Dict -> Int
support dict = HashMap.foldl' (+) 0 $ dict^.counts

-- Just for internal use. It's polymorphic, so don't use the eta reduction
v2l a = Vec.toList a
l2v a = Vec.fromList a

-- | What indices into the old matrix will generate an approximation of the new
--   matrix? This is intended for something like
-- > ((HMatrix.?) old_matrix $ select remap) == something like new_matrix
--
--   It's useful for merging termdoc-matrices, SVD's, or the like.
select :: Dict -> Dict -> [Int]
select left right = let
  l = zip [0..] $ v2l $ left^.ids
  r = v2l $ right^.ids
  in select' r l -- backward!

-- | Compute a variant on indirect sorted set intersection. Only used for `select`
select' :: Ord a
  => [a] -- ^ Sorted list X
  -> [(Int, a)] -- ^ Sorted list Y
  -> [Int] -- ^ if X[i] in Y: then Y[Z[i]] = X[i]; else Z[i] = 0
select' [] _  = []
select' ox [] = map (const 0) ox -- Must stay in lock step with X
select' ox@(x:xs) oy@((iy,y):ys) = case compare x y of
  LT -> 0  : select' xs oy
  EQ -> iy : select' xs ys
  GT ->      select' ox ys

-- | Rearrange rows in a matrix to match the order in a new matrix, after a
--   dictionary merge or filter event.
selectMatrix :: Dict -> Dict -> HMatrix.Matrix Double -> HMatrix.Matrix Double
selectMatrix left right old_matrix = (HMatrix.?) old_matrix $ select left right

-- | Given a Remap, convert the original word ID into the new ID
--   (might be more useful curried)
shift :: Dict -> Dict -> Int -> Int
shift left right i = HashMap.lookupDefault 0 i
  $ HashMap.fromList
  $ find'
  (zip [0..] (v2l $ left^.ids))
  (zip [0..] (v2l $ right^.ids))

-- | Compute an indirect sorted set intersection. Only used for `shift`
find' :: Ord a
  => [(Int, a)] -- ^ Left sorted list X
  -> [(Int, a)] -- ^ Right sorted list Y
  -> [(Int, Int)] -- ^ Indices into X, Y representing the sorted intersection
find' [] new  = []
find' orig [] = []
find' ox@((ix,x):xs) oy@((iy,y):ys) = case compare x y of
  LT -> find' xs oy
  EQ -> (ix, iy) : find' xs ys
  GT -> find' ox ys


{-# language MagicHash #-}

module Prelude
  ( module P
  ) where

import Data.Either as P (Either(..))
import Streaming.Prelude as P (Stream, Of)
import Numeric as P (pi)
import Control.Monad as P (Monad(..))
import Data.Primitive.Instances ()
import Data.Complex as P (Complex(..))
import Control.Monad.ST as P (ST, runST)
import GHC.Err as P (error)
import GHC.Exts as P (Double(..),Int(..),Int#)
import Data.Function as P (($), id)
import Data.Bool as P (otherwise, Bool(..))
import Data.Bits as P (Bits(..))
import Data.Semigroup as P (Semigroup(..))
import Data.Monoid as P (Monoid(..))
import Control.Applicative as P (Applicative(..))
import Data.Semiring as P (Semiring(..), Ring(..), (+),(*),(-))
import Data.Int as P (Int)
import Data.Word as P (Word)
import GHC.Real as P (fromIntegral, (/), floor)
import Data.Eq as P (Eq(..))
import Data.Ord as P (Ord(..))
import Control.Monad.Primitive as P (PrimMonad(..))
import Data.Primitive.Types as P (Prim(..))
import Data.Primitive.PrimArray as P (PrimArray,MutablePrimArray)
import Data.Primitive.Contiguous as P (Contiguous,Element,Mutable)


{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Strict            #-}
-- Type.hs ---
--
-- Filename: Type.hs
-- Description:
-- Author: Manuel Schneckenreither
-- Maintainer:
-- Created: Wed Nov  1 17:40:44 2017 (+0100)
-- Version:
-- Package-Requires: ()
-- Last-Updated:
--           By:
--     Update #: 94
-- URL:
-- Doc URL:
-- Keywords:
-- Compatibility:
--
--

-- Commentary:
--
--
--
--

-- Change Log:
--
--
--
--
--
--
--

-- Code:

module SimSim.Order.Type where

import           ClassyPrelude
import           Control.DeepSeq
import           Data.Serialize
import           GHC.Generics
import           Statistics.Distribution
import           System.Random.MWC

import           SimSim.Block
import           SimSim.ProductType
import           SimSim.Time

type OrderId = Integer

-- | The message type is a record of user name, content and timestamp. Equality is defined by the orderId, that means
-- right after creating an order with @newOrder@ all orders are equal until fed into the simulation.
data Order = Order
  { orderId          :: !OrderId
  , productType      :: !ProductType
  , arrivalDate      :: !ArrivalDate
  , dueDate          :: !DueDate
  , released         :: !(Maybe Time)
  , prodStart        :: !(Maybe Time)
  , prodEnd          :: !(Maybe Time)
  , shipped          :: !(Maybe Time)
  , lastBlock        :: !Block
  , blockStartTime   :: !Time
  , nextBlock        :: !Block
  , orderCurrentTime :: !Time
  } deriving (Ord, Show, Generic, Serialize)

instance NFData Order where
  rnf (Order i tp ar dd rel st end sh last blSt nBl t) =
    rnf i `seq` rnf tp `seq` rnf ar `seq` rnf dd `seq` rnf1 rel `seq` rnf1 st `seq` rnf1 end `seq` rnf1 sh `seq` rnf last `seq` rnf blSt `seq` rnf nBl `seq` rnf t

instance Eq Order where
  x == y = orderId x == orderId y

-- | This function creates a new order.
newOrder :: ProductType -> ArrivalDate -> DueDate -> Order
newOrder productType arrDate dueDate =
  Order (-1) productType arrDate dueDate Nothing Nothing Nothing Nothing OrderPool arrDate OrderPool 0

orderSlackTime :: Order -> Time
orderSlackTime order = dueDate order - arrivalDate order

orderFgiTime :: Order -> Maybe Time
orderFgiTime order = (-) <$> shipped order <*> prodEnd order

orderBoTime :: Order -> Maybe Time
orderBoTime order = max 0 <$> ((-) <$> shipped order <*> Just (dueDate order))

orderWipTime :: Order -> Maybe Time
orderWipTime order = (-) <$> prodEnd order <*> prodStart order

orderFinishedProduction :: Order -> Bool
orderFinishedProduction order = isJust (prodEnd order)

orderFinishedAndTardyProduction :: Order -> Bool
orderFinishedAndTardyProduction order = maybe False (> dueDate order) (prodEnd order)

orderFinishedAndTardyShipped :: Order -> Bool
orderFinishedAndTardyShipped order = maybe False (> dueDate order) (shipped order)

orderTardinessProduction :: Order -> Maybe Time
orderTardinessProduction order = packTardy . subtract (dueDate order) =<< prodEnd order
  where packTardy x | x > 0 = return x
                    | otherwise = Nothing -- "not tardy"

orderTardinessShipped :: Order -> Maybe Time
orderTardinessShipped order = packTardy . subtract (dueDate order) =<< shipped order
  where packTardy x | x > 0 = return x
                    | otherwise = Nothing -- "not shipped"

setOrderId :: OrderId -> Order -> Order
setOrderId nr o = o {orderId = nr}

setOrderCurrentTime :: Time -> Order -> Order
setOrderCurrentTime t o = o {orderCurrentTime = t}

setOrderBlockStartTime :: Time -> Order -> Order
setOrderBlockStartTime t o = o { blockStartTime = t}

addToOrderCurrentTime :: Time -> Order -> Order
addToOrderCurrentTime t o = o {orderCurrentTime = orderCurrentTime o + t}

setReleaseTime :: Time -> Order -> Order
setReleaseTime t o = o {released = Just t}

setProdStartTime :: Time -> Order -> Order
setProdStartTime t o =
  if isNothing (prodStart o)
    then o {prodStart = Just t}
    else o

setProdEndTime :: Time -> Order -> Order
setProdEndTime t o =
  if isNothing (prodEnd o)
    then o {prodEnd = Just t}
    else o

setLastBlock :: Block -> Order -> Order
setLastBlock b o = o {lastBlock = b}

setNextBlock :: Block -> Order -> Order
setNextBlock b o = o {nextBlock = b}

setShippedTime :: Time -> Order -> Order
setShippedTime t o = o {shipped = Just t}

--
-- Type.hs ends here


module ComposableSDR.Sink
  ( fileSink
  , stdOutSink
  , audioFileSink
  , constellationPlotSink
  , AudioFormat(..)
  ) where

import           System.FilePath.Posix               (takeBaseName)
import           System.IO                           (stdout)

import           Data.Complex                        (imagPart, realPart)

import           Text.Printf

import qualified Control.Monad.Catch                 as MC

import qualified Sound.File.Sndfile                  as SF

import qualified Streamly.Internal.Data.Fold         as F
import qualified Streamly.Internal.Data.Fold.Types   as FL
import qualified Streamly.Internal.FileSystem.File   as FS
import qualified Streamly.Internal.FileSystem.Handle as FH
import qualified Streamly.Memory.Array               as A

import           ComposableSDR.Common
import           ComposableSDR.Types

{-# INLINABLE fileSink #-}
fileSink ::
     (MonadIO m, MC.MonadCatch m, Storable a)
  => FilePath
  -> FL.Fold m (A.Array a) ()
fileSink = FS.writeChunks

{-# INLINABLE stdOutSink #-}
stdOutSink ::
     (MonadIO m, MC.MonadCatch m, Storable a) => FL.Fold m (A.Array a) ()
stdOutSink = FH.writeChunks stdout

openAudioFile :: AudioFormat -> FilePath -> Int -> Int -> Int -> IO SF.Handle
openAudioFile fmt fp sr sn nch = SF.openFile (fp ++ ext) SF.WriteMode info
  where
    sfFmt AU  = (SF.HeaderFormatAu, ".au")
    sfFmt WAV = (SF.HeaderFormatWav, ".wav")
    (sff, ext) = sfFmt fmt
    info =
      SF.Info
        sn
        sr
        nch
        (SF.Format sff SF.SampleFormatFloat SF.EndianBig)
        1
        False

writeToAudioFile :: (MonadIO m) => SF.Handle -> A.Array Float -> m ()
writeToAudioFile h a = do
  _ <- liftIO $ SF.hPutBuffer h (toArray a)
  return ()

closeAudioFile :: SF.Handle -> IO ()
closeAudioFile = SF.hClose

audioFileSink ::
     (MC.MonadCatch m, MonadIO m)
  => AudioFormat
  -> Int
  -> Int
  -> Int
  -> String
  -> FL.Fold m (A.Array Float) ()
audioFileSink fmt sr sn nch fp =
  let wav = openAudioFile fmt fp sr sn nch
   in bracketIO wav closeAudioFile (F.drainBy . writeToAudioFile)

constellationPlotSink ::
     (MC.MonadCatch m, MonadIO m)
  => FilePath
  -> FL.Fold m (A.Array SamplesIQCF32) ()
constellationPlotSink fp =
  let writeHeader = writeFile fp $ unlines ["clear all; close all;", "v = [];"]
      toFloat (CFloat f) = f
      writeBody as =
        liftIO $
        appendFile fp $
        unlines $
          (\s ->
             printf
               "v(end+1) = %12.4e + j*%12.4e;"
               (toFloat $ realPart s)
               (toFloat $ imagPart s)) <$>
        A.toList as
      writeFooter =
        appendFile fp $
        unlines
          [ "n = length(v);"
          , "figure('color','white','position',[100 100 1200 400]);"
          , "plot(real(v), imag(v), 'x', 'Color',[0 0.2 0.4]);"
          , "xlabel('In-Phase');"
          , "ylabel('Quadrature');"
          , "grid on;"
          , "print -dpng -color \"-S1200,600\" " ++ takeBaseName fp ++ ".png"
          ]
   in bracketIO writeHeader (const writeFooter) (F.drainBy . const writeBody)


{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

--
-- Copyright (c) 2009-2011, ERICSSON AB
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--

module Feldspar.Core.Types where

import Data.Array.IO
import Data.Bits
import Data.Complex
import Data.Int
import Data.IORef
import Data.List
import Data.Typeable (Typeable, Typeable1)
import Data.Word
import Test.QuickCheck
import qualified Control.Monad.Par as MonadPar

import Data.Patch
import Data.Proxy

import Feldspar.Lattice
import Feldspar.Range

--------------------------------------------------------------------------------
-- * Heterogenous lists
--------------------------------------------------------------------------------

-- | Heterogeneous list
data a :> b = a :> b
  deriving (Eq, Ord, Show)

infixr 5 :>

instance (Lattice a, Lattice b) => Lattice (a :> b)
  where
    bot = bot :> bot
    top = top :> top
    (a1:>a2) \/ (b1:>b2) = (a1 \/ b1) :> (a2 \/ b2)
    (a1:>a2) /\ (b1:>b2) = (a1 /\ b1) :> (a2 /\ b2)

--------------------------------------------------------------------------------
-- * Integers
--------------------------------------------------------------------------------

-- | Target-dependent unsigned integers
newtype WordN = WordN Word32
  deriving
    ( Eq, Ord, Num, Enum, Ix, Real, Integral, Bits, Bounded, Typeable
    , Arbitrary )

type instance UnsignedRep WordN = Word32

-- | Target-dependent signed integers
newtype IntN = IntN Int32
  deriving
    ( Eq, Ord, Num, Enum, Ix, Real, Integral, Bits, Bounded, Typeable
    , Arbitrary )

type instance UnsignedRep IntN = Word32

instance Show WordN
  where
    show (WordN a) = show a

instance Show IntN
  where
    show (IntN a) = show a

-- | Type representation of 8 bits
data N8

-- | Type representation of 16 bits
data N16

-- | Type representation of 32 bits
data N32

-- | Type representation of 64 bits
data N64

-- | Type representation of the native number of bits on the target
data NNative

-- | Witness for 'N8', 'N16', 'N32', 'N64' or 'NNative'
data BitWidth n
  where
    N8      :: BitWidth N8
    N16     :: BitWidth N16
    N32     :: BitWidth N32
    N64     :: BitWidth N64
    NNative :: BitWidth NNative

bitWidth :: BitWidth n -> String
bitWidth N8      = "8"
bitWidth N16     = "16"
bitWidth N32     = "32"
bitWidth N64     = "64"
bitWidth NNative = "N"

-- | Type representation of \"unsigned\"
data U

-- | Type representation of \"signed\"
data S

-- | Witness for 'U' or 'S'
data Signedness s
  where
    U :: Signedness U
    S :: Signedness S

signedness :: Signedness s -> String
signedness U = "Word"
signedness S = "Int"

-- | A generalization of unsigned and signed integers. The first parameter
-- represents the signedness and the sectond parameter the number of bits.
type family GenericInt s n
type instance GenericInt U N8      = Word8
type instance GenericInt S N8      = Int8
type instance GenericInt U N16     = Word16
type instance GenericInt S N16     = Int16
type instance GenericInt U N32     = Word32
type instance GenericInt S N32     = Int32
type instance GenericInt U N64     = Word64
type instance GenericInt S N64     = Int64
type instance GenericInt U NNative = WordN
type instance GenericInt S NNative = IntN

type family WidthOf a
type instance WidthOf Word8  = N8
type instance WidthOf Int8   = N8
type instance WidthOf Word16 = N16
type instance WidthOf Int16  = N16
type instance WidthOf Word32 = N32
type instance WidthOf Int32  = N32
type instance WidthOf Word64 = N64
type instance WidthOf Int64  = N64
type instance WidthOf WordN  = NNative
type instance WidthOf IntN   = NNative

type family SignOf a
type instance SignOf Word8  = U
type instance SignOf Int8   = S
type instance SignOf Word16 = U
type instance SignOf Int16  = S
type instance SignOf Word32 = U
type instance SignOf Int32  = S
type instance SignOf Word64 = U
type instance SignOf Int64  = S
type instance SignOf WordN  = U
type instance SignOf IntN   = S

fromWordN :: BitWidth n -> WordN -> GenericInt U n
fromWordN N8      = fromInteger . toInteger
fromWordN N16     = fromInteger . toInteger
fromWordN N32     = fromInteger . toInteger
fromWordN N64     = fromInteger . toInteger
fromWordN NNative = id
  -- TODO Check that the number fits

fromIntN :: BitWidth n -> IntN -> GenericInt S n
fromIntN N8      = fromInteger . toInteger
fromIntN N16     = fromInteger . toInteger
fromIntN N32     = fromInteger . toInteger
fromIntN N64     = fromInteger . toInteger
fromIntN NNative = id
  -- TODO Check that the number fits

genericLen :: BitWidth n -> [a] -> GenericInt U n
genericLen N8      = genericLength
genericLen N16     = genericLength
genericLen N32     = genericLength
genericLen N64     = genericLength
genericLen NNative = genericLength

type Length = WordN
type Index  = WordN

--------------------------------------------------------------------------------
-- * Arrays
--------------------------------------------------------------------------------

-- | Array whose length is represented by an @n@-bit word
data TargetArr n a = TargetArr (GenericInt U n) [a]

--------------------------------------------------------------------------------
-- * Monadic Types
--------------------------------------------------------------------------------

-- | This class is used to allow constructs to be abstract in the monad
class MonadType m
  where
    voidTypeRep :: TypeRep (m ())
  -- TODO Since the `Mut` monad is already abstract, this class is probably only
  --      needed if we want to be able to use monadic constructs with different
  --      monad types.

--------------------------------------------------------------------------------
-- * Mutable data
--------------------------------------------------------------------------------

-- TODO Make newtypes?

-- | Monad for manipulation of mutable data
type Mut = IO

-- | Mutable references
instance Show (IORef a)
  where
    show _ = "IORef"

-- | Mutable arrays
type MArr a = IOArray Index a

instance Show (MArr a)
  where
    show _ = "MArr"

instance MonadType Mut
  where
    voidTypeRep = MutType UnitType

--------------------------------------------------------------------------------
-- * Par Monad
--------------------------------------------------------------------------------

-- | Monad for parallel constructs
type Par = MonadPar.Par

deriving instance Typeable1 Par

-- | Immutable references
type IV = MonadPar.IVar

deriving instance Typeable1 IV

instance Show (IV a)
  where
    show _ = "IVar"

instance Eq (IV a)
  where
    _ == _ = False

instance MonadType Par
  where
    voidTypeRep = ParType UnitType

--------------------------------------------------------------------------------
-- * Future values
--------------------------------------------------------------------------------

newtype FVal a = FVal {unFVal :: a}

deriving instance Typeable1 FVal

instance Show (FVal a)
  where
    show _ = "future"

instance Eq a => Eq (FVal a)
  where
    (FVal a) == (FVal b) = a == b

--------------------------------------------------------------------------------
-- * Type representation
--------------------------------------------------------------------------------

-- | Representation of supported types
data TypeRep a
  where
    UnitType      :: TypeRep ()
    BoolType      :: TypeRep Bool
    IntType       :: ( BoundedInt (GenericInt s n)
                     , Size (GenericInt s n) ~ Range (GenericInt s n)
                     ) =>
                       Signedness s -> BitWidth n -> TypeRep (GenericInt s n)
    FloatType     :: TypeRep Float
    DoubleType    :: TypeRep Double
    ComplexType   :: RealFloat a => TypeRep a -> TypeRep (Complex a)
    ArrayType     :: TypeRep a -> TypeRep [a]
    TargetArrType :: BitWidth n -> TypeRep a -> TypeRep (TargetArr n a)
    Tup2Type      :: TypeRep a -> TypeRep b -> TypeRep (a,b)
    Tup3Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep (a,b,c)
    Tup4Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep (a,b,c,d)
    Tup5Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep (a,b,c,d,e)
    Tup6Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep (a,b,c,d,e,f)
    Tup7Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep (a,b,c,d,e,f,g)
    FunType       :: TypeRep a -> TypeRep b -> TypeRep (a -> b)
    MutType       :: TypeRep a -> TypeRep (Mut a)
    RefType       :: TypeRep a -> TypeRep (IORef a)
    MArrType      :: TypeRep a -> TypeRep (MArr a)
    ParType       :: TypeRep a -> TypeRep (Par a)
    IVarType      :: TypeRep a -> TypeRep (IV a)
    FValType      :: TypeRep a -> TypeRep (FVal a)
      -- TODO `MArrType` Should have a target-specialized version. Or perhaps
      --      use a single type with a flag to distinguish between immutable and
      --      mutable arrays.

instance Show (TypeRep a)
  where
    show UnitType            = "()"
    show BoolType            = "Bool"
    show (IntType s n)       = signedness s ++ bitWidth n
    show FloatType           = "Float"
    show DoubleType          = "Double"
    show (ComplexType t)     = "(Complex " ++ show t ++ ")"
    show (ArrayType t)       = "[" ++ show t ++ "]"
    show (TargetArrType _ t) = "[" ++ show t ++ "]"
    show (Tup2Type ta tb)                = showTup [show ta, show tb]
    show (Tup3Type ta tb tc)             = showTup [show ta, show tb, show tc]
    show (Tup4Type ta tb tc td)          = showTup [show ta, show tb, show tc, show td]
    show (Tup5Type ta tb tc td te)       = showTup [show ta, show tb, show tc, show td, show te]
    show (Tup6Type ta tb tc td te tf)    = showTup [show ta, show tb, show tc, show td, show te, show tf]
    show (Tup7Type ta tb tc td te tf tg) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg]
    show (FunType ta tb)                 = show ta ++ " -> " ++ show tb
    show (MutType ta)                    = unwords ["Mut", show ta]
    show (RefType ta)                    = unwords ["Ref", show ta]
    show (MArrType ta)                   = unwords ["MArr", show ta]
    show (ParType ta)                    = unwords ["Par", show ta]
    show (IVarType ta)                   = unwords ["IVar", show ta]
    show (FValType ta)                   = unwords ["FVal", show ta]

argType :: TypeRep (a -> b) -> TypeRep a
argType (FunType ta _) = ta

resType :: TypeRep (a -> b) -> TypeRep b
resType (FunType _ tb) = tb

-- | Type equality witness
data TypeEq a b
  where
    TypeEq :: TypeEq a a

defaultSize :: TypeRep a -> Size a
defaultSize UnitType = universal
defaultSize BoolType = universal
defaultSize (IntType _ _) = universal
defaultSize FloatType = universal
defaultSize DoubleType = universal
defaultSize (ComplexType _) = universal
defaultSize (ArrayType t) = universal :> defaultSize t
--defaultSize (TargetArrType n t) = universal :> defaultSize t -- TODO
defaultSize (Tup2Type ta tb) =  ( defaultSize ta
                                , defaultSize tb
                                )
defaultSize (Tup3Type ta tb tc) = ( defaultSize ta
                                  , defaultSize tb
                                  , defaultSize tc
                                  )
defaultSize (Tup4Type ta tb tc td) = ( defaultSize ta
                                     , defaultSize tb
                                     , defaultSize tc
                                     , defaultSize td
                                     )
defaultSize (Tup5Type ta tb tc td te) = ( defaultSize ta
                                        , defaultSize tb
                                        , defaultSize tc
                                        , defaultSize td
                                        , defaultSize te
                                        )
defaultSize (Tup6Type ta tb tc td te tf) = ( defaultSize ta
                                           , defaultSize tb
                                           , defaultSize tc
                                           , defaultSize td
                                           , defaultSize te
                                           , defaultSize tf
                                           )
defaultSize (Tup7Type ta tb tc td te tf tg) = ( defaultSize ta
                                              , defaultSize tb
                                              , defaultSize tc
                                              , defaultSize td
                                              , defaultSize te
                                              , defaultSize tf
                                              , defaultSize tg
                                              )
defaultSize (FunType ta tb) = (defaultSize ta, defaultSize tb)
defaultSize (MutType ta) = defaultSize ta
defaultSize (RefType ta) = defaultSize ta
defaultSize (MArrType ta) = universal :> defaultSize ta
defaultSize (ParType ta) = defaultSize ta
defaultSize (IVarType ta) = defaultSize ta
defaultSize (FValType ta) = defaultSize ta

-- | Type equality on 'Signedness'
signEq :: Signedness s1 -> Signedness s2 -> Maybe (TypeEq s1 s2)
signEq U U = Just TypeEq
signEq S S = Just TypeEq
signEq _ _ = Nothing

-- | Type equality on 'BitWidth'
widthEq :: BitWidth n1 -> BitWidth n2 -> Maybe (TypeEq n1 n2)
widthEq N8      N8      = Just TypeEq
widthEq N16     N16     = Just TypeEq
widthEq N32     N32     = Just TypeEq
widthEq N64     N64     = Just TypeEq
widthEq NNative NNative = Just TypeEq
widthEq _ _ = Nothing

-- | Type equality on 'TypeRep'
typeEq :: TypeRep a -> TypeRep b -> Maybe (TypeEq a b)
typeEq UnitType UnitType = Just TypeEq
typeEq BoolType BoolType = Just TypeEq
typeEq (IntType s1 n1) (IntType s2 n2) = do
    TypeEq <- signEq s1 s2
    TypeEq <- widthEq n1 n2
    return TypeEq
typeEq FloatType FloatType = Just TypeEq
typeEq DoubleType DoubleType = Just TypeEq
typeEq (ComplexType t1) (ComplexType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (ArrayType t1) (ArrayType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (TargetArrType n1 t1) (TargetArrType n2 t2) = do
    TypeEq <- widthEq n1 n2
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (Tup2Type a1 b1) (Tup2Type a2 b2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    return TypeEq
typeEq (Tup3Type a1 b1 c1) (Tup3Type a2 b2 c2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    return TypeEq
typeEq (Tup4Type a1 b1 c1 d1) (Tup4Type a2 b2 c2 d2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    return TypeEq
typeEq (Tup5Type a1 b1 c1 d1 e1) (Tup5Type a2 b2 c2 d2 e2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    return TypeEq
typeEq (Tup6Type a1 b1 c1 d1 e1 f1) (Tup6Type a2 b2 c2 d2 e2 f2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    return TypeEq
typeEq (Tup7Type a1 b1 c1 d1 e1 f1 g1) (Tup7Type a2 b2 c2 d2 e2 f2 g2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    TypeEq <- typeEq c1 c2
    TypeEq <- typeEq d1 d2
    TypeEq <- typeEq e1 e2
    TypeEq <- typeEq f1 f2
    TypeEq <- typeEq g1 g2
    return TypeEq
typeEq (FunType a1 b1) (FunType a2 b2) = do
    TypeEq <- typeEq a1 a2
    TypeEq <- typeEq b1 b2
    return TypeEq
typeEq (MutType t1) (MutType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (RefType t1) (RefType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (MArrType a1) (MArrType a2) = do
    TypeEq <- typeEq a1 a2
    return TypeEq
typeEq (ParType t1) (ParType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (IVarType t1) (IVarType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq
typeEq (FValType t1) (FValType t2) = do
    TypeEq <- typeEq t1 t2
    return TypeEq

typeEq _ _ = Nothing

showTup :: [String] -> String
showTup as =  "(" ++ intercalate "," as ++ ")"

type family TargetType n a
type instance TargetType n ()              = ()
type instance TargetType n Bool            = Bool
type instance TargetType n Word8           = Word8
type instance TargetType n Int8            = Int8
type instance TargetType n Word16          = Word16
type instance TargetType n Int16           = Int16
type instance TargetType n Word32          = Word32
type instance TargetType n Int32           = Int32
type instance TargetType n Word64          = Word64
type instance TargetType n Int64           = Int64
type instance TargetType n WordN           = GenericInt U n
type instance TargetType n IntN            = GenericInt S n
type instance TargetType n Float           = Float
type instance TargetType n Double          = Double
type instance TargetType n (Complex a)     = Complex (TargetType n a)
type instance TargetType n [a]             = TargetArr n (TargetType n a)
type instance TargetType n (a,b)           = (TargetType n a, TargetType n b)
type instance TargetType n (a,b,c)         = (TargetType n a, TargetType n b, TargetType n c)
type instance TargetType n (a,b,c,d)       = (TargetType n a, TargetType n b, TargetType n c, TargetType n d)
type instance TargetType n (a,b,c,d,e)     = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e)
type instance TargetType n (a,b,c,d,e,f)   = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f)
type instance TargetType n (a,b,c,d,e,f,g) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g)
type instance TargetType n (IORef a)       = IORef (TargetType n a)
type instance TargetType n (MArr a)        = MArr (TargetType n a)
type instance TargetType n (IV a)          = IV (TargetType n a)
type instance TargetType n (FVal a)        = FVal (TargetType n a)

-- | The set of supported types
class (Eq a, Show a, Typeable a, Show (Size a), Lattice (Size a)) => Type a
  where
    -- | Gives the type representation a value.
    typeRep  :: TypeRep a
    sizeOf   :: a -> Size a
    toTarget :: BitWidth n -> a -> TargetType n a

instance Type ()      where typeRep = UnitType;          sizeOf _ = AnySize;      toTarget _ = id
instance Type Bool    where typeRep = BoolType;          sizeOf _ = AnySize;      toTarget _ = id
instance Type Word8   where typeRep = IntType U N8;      sizeOf = singletonRange; toTarget _ = id
instance Type Int8    where typeRep = IntType S N8;      sizeOf = singletonRange; toTarget _ = id
instance Type Word16  where typeRep = IntType U N16;     sizeOf = singletonRange; toTarget _ = id
instance Type Int16   where typeRep = IntType S N16;     sizeOf = singletonRange; toTarget _ = id
instance Type Word32  where typeRep = IntType U N32;     sizeOf = singletonRange; toTarget _ = id
instance Type Int32   where typeRep = IntType S N32;     sizeOf = singletonRange; toTarget _ = id
instance Type Word64  where typeRep = IntType U N64;     sizeOf = singletonRange; toTarget _ = id
instance Type Int64   where typeRep = IntType S N64;     sizeOf = singletonRange; toTarget _ = id
instance Type WordN   where typeRep = IntType U NNative; sizeOf = singletonRange; toTarget = fromWordN
instance Type IntN    where typeRep = IntType S NNative; sizeOf = singletonRange; toTarget = fromIntN
instance Type Float   where typeRep = FloatType;         sizeOf _ = AnySize;      toTarget _ = id
instance Type Double  where typeRep = DoubleType;        sizeOf _ = AnySize;      toTarget _ = id

instance (Type a, RealFloat a) => Type (Complex a)
  where
    typeRep             = ComplexType typeRep
    sizeOf _            = AnySize
    toTarget _ (_ :+ _) = error "TODO" -- toTarget n r :+ toTarget n i

instance Type a => Type [a]
  where
    typeRep       = ArrayType typeRep
    sizeOf as     = singletonRange (genericLength as) :> unions (map sizeOf as)
    toTarget n as = TargetArr (genericLen n as) $ map (toTarget n) as

instance (Type a, Type b) => Type (a,b)
  where
    typeRep = Tup2Type typeRep typeRep

    sizeOf (a,b) =
        ( sizeOf a
        , sizeOf b
        )

    toTarget n (a,b) =
        ( toTarget n a
        , toTarget n b
        )

instance (Type a, Type b, Type c) => Type (a,b,c)
  where
    typeRep = Tup3Type typeRep typeRep typeRep

    sizeOf (a,b,c) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        )

    toTarget n (a,b,c) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        )

instance (Type a, Type b, Type c, Type d) => Type (a,b,c,d)
  where
    typeRep = Tup4Type typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        )

    toTarget n (a,b,c,d) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        )

instance (Type a, Type b, Type c, Type d, Type e) => Type (a,b,c,d,e)
  where
    typeRep = Tup5Type typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        )

    toTarget n (a,b,c,d,e) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f) => Type (a,b,c,d,e,f)
  where
    typeRep = Tup6Type typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        )

    toTarget n (a,b,c,d,e,f) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        )

instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g) => Type (a,b,c,d,e,f,g)
  where
    typeRep = Tup7Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep

    sizeOf (a,b,c,d,e,f,g) =
        ( sizeOf a
        , sizeOf b
        , sizeOf c
        , sizeOf d
        , sizeOf e
        , sizeOf f
        , sizeOf g
        )

    toTarget n (a,b,c,d,e,f,g) =
        ( toTarget n a
        , toTarget n b
        , toTarget n c
        , toTarget n d
        , toTarget n e
        , toTarget n f
        , toTarget n g
        )

instance (Type a, Show (IORef a)) => Type (IORef a)
  where
    typeRep = RefType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: IORef"  -- TODO Requires IO

instance Type a => Type (MArr a)
  where
    typeRep = MArrType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: MArr"  -- TODO Requires IO

instance Type a => Type (IV a)
  where
    typeRep = IVarType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: IVar" -- TODO Requires IO

instance Type a => Type (FVal a)
  where
    typeRep = FValType typeRep

    sizeOf _ = universal

    toTarget = error "toTarget: FVal" -- TODO

typeRepByProxy :: Type a => Proxy a -> TypeRep a
typeRepByProxy _ = typeRep

--------------------------------------------------------------------------------
-- * Sized types
--------------------------------------------------------------------------------

data AnySize = AnySize
    deriving (Eq, Show, Ord)

anySizeFun :: AnySize -> AnySize
anySizeFun AnySize = AnySize

anySizeFun2 :: AnySize -> AnySize -> AnySize
anySizeFun2 AnySize AnySize = AnySize

instance Num AnySize
  where
    fromInteger _ = AnySize
    abs           = anySizeFun
    signum        = anySizeFun
    (+)           = anySizeFun2
    (-)           = anySizeFun2
    (*)           = anySizeFun2

instance Lattice AnySize
  where
    bot  = AnySize
    top  = AnySize
    (\/) = anySizeFun2
    (/\) = anySizeFun2

type family Size a

type instance Size ()              = AnySize
type instance Size Bool            = AnySize
type instance Size Word8           = Range Word8
type instance Size Int8            = Range Int8
type instance Size Word16          = Range Word16
type instance Size Int16           = Range Int16
type instance Size Word32          = Range Word32
type instance Size Int32           = Range Int32
type instance Size Word64          = Range Word64
type instance Size Int64           = Range Int64
type instance Size WordN           = Range WordN
type instance Size IntN            = Range IntN
type instance Size Float           = AnySize
type instance Size Double          = AnySize
type instance Size (Complex a)     = AnySize
type instance Size [a]             = Range Length :> Size a
type instance Size (TargetArr n a) = Range (GenericInt U n) :> Size a
type instance Size (a,b)           = (Size a, Size b)
type instance Size (a,b,c)         = (Size a, Size b, Size c)
type instance Size (a,b,c,d)       = (Size a, Size b, Size c, Size d)
type instance Size (a,b,c,d,e)     = (Size a, Size b, Size c, Size d, Size e)
type instance Size (a,b,c,d,e,f)   = (Size a, Size b, Size c, Size d, Size e, Size f)
type instance Size (a,b,c,d,e,f,g) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g)
type instance Size (a -> b)        = (Size a, Size b)
type instance Size (Mut a)         = Size a
type instance Size (IORef a)       = Size a
type instance Size (MArr a)        = Range Length :> Size a
type instance Size (Par a)         = Size a
type instance Size (IV a)          = Size a
type instance Size (FVal a)        = Size a

-- | A generalization of 'Range' that serves two purposes: (1) Adding an extra
-- 'Universal' constructor to support unbounded types ('Range' can only
-- represent bounded ranges), and (2) pack a 'BoundedInt' constraint with the
-- 'RangeSet' constructor. This is what allows 'sizeToRange' to be defined as a
-- total function with 'Type' as the only constraint.
data RangeSet a
  where
    RangeSet  :: BoundedInt a => Range a -> RangeSet a
    Universal :: RangeSet a

-- | Cast a 'Size' to a 'RangeSet'
sizeToRange :: forall a . Type a => Size a -> RangeSet a
sizeToRange sz = case typeRep :: TypeRep a of
    IntType _ _ -> RangeSet sz
    _           -> Universal

tIntN :: Patch IntN IntN
tIntN = id

tWordN :: Patch WordN WordN
tWordN = id

tIndex :: Patch Index Index
tIndex  = id

tLength :: Patch Length Length
tLength = id

tArr :: Patch a a -> Patch [a] [a]
tArr _ = id