{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import Data.List (dropWhileEnd, intersperse)

import System.Random.MWC.Probability (Gen)
import qualified System.Random.MWC.Probability as MWC
import Control.Monad.Trans.State.Strict (execStateT)

import Statistics.Distribution.Normal
import Statistics.Distribution.Uniform

import Conduit
import System.Environment (getArgs)

import Data.Model
import Numeric.MCMC

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M

import qualified Data.ByteString as BS (readFile)
import Data.Aeson

-- ~from https://hackage.haskell.org/package/declarative-0.2.1/docs/src/Numeric-MCMC.html#mcmc
-- A Markov chain driven by an arbitrary transition operator.
-- now using Conduit instead of Pipes
chain
  :: PrimMonad m
  => Transition m b
  -> b
  -> Gen (PrimState m)
  -> Producer m b
chain transition = loop where
  loop state prng = do
    next <- lift (MWC.sample (execStateT transition state) prng)
    yield next
    loop next prng

takeWhileEnd :: (a -> Bool) -> [a] -> [a]
takeWhileEnd f xs = case span f xs of
                         (ys, [])    -> ys
                         (_, (_:ys)) -> takeWhileEnd f ys

takeEveryC :: Monad m => Int -> Conduit a m a
takeEveryC n = do dropC (n-1)
                  x <- await
                  case x of
                       Just y -> yield y >> takeEveryC n
                       Nothing -> return ()

showList' :: [String] -> String
showList' = mconcat . intersperse ","

regions :: [RegName]
regions = [ "lvJ_1tag_0addtag_unblind_SR"
          , "lvJ_2tag_0addtag_unblind_SR"
          , "lvJ_1tag_1paddtag_unblind_SR"
          , "lvJ_1tag_0addtag_unblind_lowMH"
          , "lvJ_2tag_0addtag_unblind_lowMH"
          , "lvJ_1tag_1paddtag_unblind_lowMH"
          , "lvJ_1tag_0addtag_unblind_highMH"
          , "lvJ_2tag_0addtag_unblind_highMH"
          , "lvJ_1tag_1paddtag_unblind_highMH"
          ]

processes :: [ProcName]
processes  = [ "TTbar"
             , "Wb"
             , "Wc"
             , "Wl"
             , "stopWt"
             , "stopt"
             , "HVTWHlvqq2000"
             ]

shapeNPs :: [String]
shapeNPs = [ "EG_RESOLUTION_ALL__1up"
           , "EG_SCALE_ALL__1up"
           , "EL_EFF_ID_TotalCorrUncertainty__1up"
           , "EL_EFF_Iso_TotalCorrUncertainty__1up"
           , "EL_EFF_Reco_TotalCorrUncertainty__1up"
           , "EL_EFF_Trigger_TotalCorrUncertainty__1up"
           -- , "EXTRAP__1up"
           , "FATJET_JER__1up"
           , "FATJET_JMR__1up"
           , "FT_EFF_Eigen_B_0__1up"
           , "FT_EFF_Eigen_B_1__1up"
           , "FT_EFF_Eigen_B_2__1up"
           , "FT_EFF_Eigen_C_0__1up"
           , "FT_EFF_Eigen_C_1__1up"
           , "FT_EFF_Eigen_C_2__1up"
           , "FT_EFF_Eigen_C_3__1up"
           , "FT_EFF_Eigen_Light_0__1up"
           , "FT_EFF_Eigen_Light_1__1up"
           , "FT_EFF_Eigen_Light_2__1up"
           , "FT_EFF_Eigen_Light_3__1up"
           , "FT_EFF_Eigen_Light_4__1up"
           , "FT_EFF_extrapolation__1up"
           , "FT_EFF_extrapolation_from_charm__1up"
           , "JET_GroupedNP_1__1up"
           , "JET_GroupedNP_2__1up"
           , "JET_GroupedNP_3__1up"
           , "JET_JER_SINGLE_NP__1up"
           , "JET_Rtrk_Baseline__1up"
           , "JET_Rtrk_Modelling__1up"
           , "JET_Rtrk_Tracking__1up"
           , "MET_SoftTrk_ResoPara__1up"
           , "MET_SoftTrk_ResoPerp__1up"
           , "MET_SoftTrk_Scale__1up"
           -- , "MODEL_TTbar_Herwig__1up"
           -- , "MODEL_TTbar_aMcAtNlo__1up"
           -- , "MODEL_TTbar_rad__1up"
           , "MUONS_ID__1up"
           , "MUONS_MS__1up"
           , "MUONS_SCALE__1up"
           , "MUON_EFF_STAT__1up"
           , "MUON_EFF_SYS__1up"
           , "MUON_EFF_TrigStatUncertainty__1up"
           , "MUON_EFF_TrigSystUncertainty__1up"
           , "MUON_ISO_STAT__1up"
           , "MUON_ISO_SYS__1up"
           , "MUON_TTVA_STAT__1up"
           , "MUON_TTVA_SYS__1up"
           ]

main :: IO ()
main = do infiles <- getArgs
          let f Nothing = error "parse error."
              f (Just m) = fmap (rebinH 10 . snd) m

          let g k = let (procN, regN) = break (== '_') . takeWhileEnd (/= '/') . dropWhileEnd (/= '_') $ k
                    in  (ProcName procN, RegName . init . tail $ regN)

          fhs <- traverse (\fn -> (fn,) . decodeStrict <$> BS.readFile fn) infiles
                :: IO [(String, Maybe (Map String (String, Hist)))]

          let hs' = M.fromList $ map (\(ss, m) -> (g ss, f m)) fhs

          let regH regname procname varname = hs' M.! (procname, regname) M.! varname
          let procHs procname varname = M.fromList [(regn, regH regn procname varname) | regn <- regions]
          let varHs varname = M.fromList [(procn, procHs procn varname) | procn <- processes]

          let systHs = M.fromList $ map (\v -> (v, varHs v)) shapeNPs

          let nomHs = M.fromList $ map (\p -> (p, procHs p "nominal")) processes :: Prediction
          let dataHs = M.fromList $ map (\r -> (r, fmap round $ regH r "data" "nominal")) regions :: Dataset
          -- let dataHs = expectedData nomHs

          let sysDiffs = fmap (M.intersectionWith (M.intersectionWith (flip subH)) nomHs) systHs

          let shapeSysts = map (\(n, p) -> shapeParam standard n p) $ M.toList sysDiffs
          let normSysts = [ procNormParam (uniformDistr (-100.0) 100.0) 1.0 "HVTWHlvqq2000"
                          , procNormParam standard 0.3 "TTbar"
                          , procNormParam standard 0.3 "Wb"
                          , procNormParam standard 0.2 "Wc"
                          , procNormParam standard 0.1 "Wl"
                          ]

          let systs = normSysts ++ shapeSysts

          putStrLn . showList' . ("likelihood" :) $ map mpName systs

          -- start every NP at 0.0.
          let initial = map (const 0.0) systs

          let llh = modelLLH dataHs nomHs systs :: [Double] -> Double

          let t = Target llh Nothing
          let c = Chain t (llh initial) initial Nothing

          -- TODO
          -- I think the signal normalization needs a different step
          -- size...
          let trans = metropolis 0.1
          -- let trans = slice 0.1

          withSystemRandom . asGenIO $
                \gen -> chain trans c gen
                     =$ (dropC 5000 >> takeEveryC 20 =$ takeC 10000)
                     $$ mapM_C (\(Chain _ lhood xs _) -> putStrLn . showList' . fmap show $ lhood:xs)


{-# LANGUAGE LambdaCase #-}
module Statistics.Graph
    ( graphF
    , writeGraph
    ) where

import           Universum hiding (unlines)

import           Control.Foldl (Fold (..))
import           Data.Graph.Inductive.Graph (Graph (mkGraph))
import           Data.Graph.Inductive.PatriciaTree (Gr)
import           Data.GraphViz (DotGraph)
import qualified Data.GraphViz as G
import qualified Data.GraphViz.Attributes.Complete as A
import           Data.GraphViz.Commands.IO (hPutDot)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import           Data.Set (Set)
import qualified Data.Set as S
import           Pos.Util (withTempFile)
import           Prelude (unlines)
import           System.Exit (ExitCode (ExitSuccess))
import           System.IO (hGetContents, hPutStrLn)
import           System.Process (readProcessWithExitCode)

import           JSONLog (IndexedJLTimedEvent)
import           Statistics.Block (BlockHeader (..), blockChain, blockHeadersF)
import           Types

graphF :: Fold IndexedJLTimedEvent (DotGraph Int)
graphF = f <$> blockHeadersF
  where
    f :: Map BlockHash BlockHeader -> DotGraph Int
    f m =
        let nodes = zip [1..] $ [bh | (_, bh) <- M.toList m]
            h2i   = M.fromList [(bhHash bh, i) | (i, bh) <- nodes]
            edges = do
                (i, bh) <- nodes
                let h = bhHash bh
                    h' = bhPrevBlock $ m M.! h
                guard $ M.member h' h2i
                return (i, h2i M.! h', ())
            g     = mkGraph nodes edges :: Gr BlockHeader ()
        in  G.graphToDot G.nonClusteredParams { G.fmtNode = fmt } g
      where
        chain :: Set BlockHash
        chain = blockChain m

        fmt :: (Int, BlockHeader) -> G.Attributes
        fmt (_, bh) = [ A.Label $ A.StrLabel $ toLText $ unlines labels
                      , A.FillColor (if S.member (bhHash bh) chain
                            then [A.WC (A.X11Color G.Yellow) Nothing]
                            else [A.WC (A.X11Color G.LightGray) Nothing])
                      , A.Style [A.SItem A.Filled []]
                      ]
          where
            labels :: [String]
            labels = [ '#' : take 6 (toString $ bhHash bh)
                     , show (bhNode bh)
                     , show (bhSlot bh)
                     ]

writeGraph :: FilePath -> DotGraph Int -> IO Bool
writeGraph f g = withTempFile "." "graph.dot" $ \_ h -> do
    hPutDot h g
    b <- G.isGraphvizInstalled
    case b of
        True -> do
            input <- hGetContents h
            ex <- view _1 <$> readProcessWithExitCode "dot" ["-Tpng", "-o" ++ f] input
            case ex of
                ExitSuccess -> return True
                _           -> hPutStrLn Universum.stderr ("Creating the graph failed, " ++ show ex) >> return False
        False -> hPutStrLn stderr "Cannot produce graph without dot. Please install graphviz." >> return False


{-# language GADTs                 #-}
{-# language StandaloneDeriving    #-}
{-# language TypeOperators         #-}
{-# language FlexibleInstances     #-}
{-# language FlexibleContexts      #-}
{-# language UndecidableInstances  #-}
{-# language MultiParamTypeClasses #-}
{-# language ConstraintKinds       #-}
{-# language TypeFamilies          #-}

{-# options_ghc -fwarn-incomplete-patterns #-}

module Feldspar.Software.Expression where

import Feldspar.Sugar
import Feldspar.Representation
import Feldspar.Software.Primitive
import Data.Struct

import Data.Complex (Complex)
import Data.Int
import Data.Word
import Data.List (genericTake)
import Data.Constraint
import Data.Typeable (Typeable)

-- syntactic.
import Language.Syntactic hiding (Signature, Args)
import Language.Syntactic.Functional hiding (Lam)
import Language.Syntactic.Functional.Tuple
import qualified Language.Syntactic as Syn

-- imperative-edsl.
import Language.Embedded.Expression

--------------------------------------------------------------------------------
-- * Software expressions.
--------------------------------------------------------------------------------

type instance Pred SoftwareDomain = SoftwarePrimType

--------------------------------------------------------------------------------
-- hmm...

type instance ExprOf   (SExp a) = SExp
type instance PredOf   SExp     = SoftwarePrimType
type instance DomainOf SExp     = SoftwareDomain
type instance RepresentationOf SoftwarePrimType = SoftwarePrimTypeRep

--------------------------------------------------------------------------------
-- ** Software types.

-- | Representation of supported software types.
type STypeRep  = TypeRep SoftwarePrimType SoftwarePrimTypeRep

-- | ...
type STypeRepF = TypeRepF SoftwarePrimType SoftwarePrimTypeRep

instance Type SoftwarePrimType Bool   where typeRep = Node BoolST
instance Type SoftwarePrimType Int8   where typeRep = Node Int8ST
instance Type SoftwarePrimType Int16  where typeRep = Node Int16ST
instance Type SoftwarePrimType Int32  where typeRep = Node Int32ST
instance Type SoftwarePrimType Int64  where typeRep = Node Int64ST
instance Type SoftwarePrimType Word8  where typeRep = Node Word8ST
instance Type SoftwarePrimType Word16 where typeRep = Node Word16ST
instance Type SoftwarePrimType Word32 where typeRep = Node Word32ST
instance Type SoftwarePrimType Word64 where typeRep = Node Word64ST
instance Type SoftwarePrimType Float  where typeRep = Node FloatST
instance Type SoftwarePrimType Double where typeRep = Node DoubleST
instance Type SoftwarePrimType (Complex Float)  where typeRep = Node ComplexFloatST
instance Type SoftwarePrimType (Complex Double) where typeRep = Node ComplexDoubleST

-- | Compare two software types for equality.
softwareTypeEq :: STypeRep a -> STypeRep b -> Maybe (Dict (a ~ b))
softwareTypeEq (Node t)       (Node u) = softwarePrimTypeEq t u
softwareTypeEq (Branch t1 u1) (Branch t2 u2) = do
  Dict <- softwareTypeEq t1 t2
  Dict <- softwareTypeEq u1 u2
  return Dict
softwareTypeEq _ _ = Nothing

-- | Construct the software type representation of 'a'.
softwareTypeRep :: Struct SoftwarePrimType c a -> STypeRep a
softwareTypeRep = mapStruct (const softwareRep)

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

-- | Short-hand for software types.
type SType    = Type SoftwarePrimType

-- | Short-hand for primitive software types.
type SType'   = PrimType SoftwarePrimType

--------------------------------------------------------------------------------
-- ** Software expression symbols.

data AssertionLabel =
    -- ^ Internal assertion to guarantee meaningful results.
    InternalAssertion
    -- ^ User made assertion.
  | UserAssertion String
  deriving (Eq, Show)

-- | Guard a value with an assertion.
data GuardVal sig
  where
    GuardVal :: AssertionLabel -> String -> GuardVal (Bool :-> a :-> Full a)

deriving instance Eq       (GuardVal a)
deriving instance Show     (GuardVal a)
deriving instance Typeable (GuardVal a)

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

-- | Hint that a value may appear in an invariant
data HintVal sig
  where
    HintVal :: SoftwarePrimType a => HintVal (a :-> b :-> Full b)

deriving instance Eq       (HintVal a)
deriving instance Show     (HintVal a)
deriving instance Typeable (HintVal a)

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

-- | For loop.
data ForLoop sig
  where
    ForLoop :: SType st =>
        ForLoop (Length :-> Length :-> st :-> (Index -> st -> st) :-> Full st)

deriving instance Eq       (ForLoop a)
deriving instance Show     (ForLoop a)
deriving instance Typeable (ForLoop a)

--------------------------------------------------------------------------------
{-
-- |
data Foreign sig
  where
    Foreign :: Signature sig => String -> Denotation sig -> Foreign sig
-}
--------------------------------------------------------------------------------

-- | Software symbols.
type SoftwareConstructs =
          BindingT
  Syn.:+: Let
  Syn.:+: Tuple
  Syn.:+: SoftwarePrimConstructs
  Syn.:+: Construct
  -- ^ Software specific symbol.
  Syn.:+: GuardVal
  Syn.:+: HintVal
  Syn.:+: ForLoop

-- | Software symbols tagged with their type representation.
type SoftwareDomain = SoftwareConstructs :&: TypeRepF SoftwarePrimType SoftwarePrimTypeRep

-- | Software expressions.
newtype SExp a = SExp { unSExp :: ASTF SoftwareDomain a }

-- | Evaluate a closed software expression.
eval :: (Syntactic a, Domain a ~ SoftwareDomain) => a -> Internal a
eval = evalClosed . desugar

-- | Sugar a software symbol as a smart constructor.
sugarSymSoftware
  :: ( Syn.Signature sig
       , fi  ~ SmartFun dom sig
       , sig ~ SmartSig fi
       , dom ~ SmartSym fi
       , dom ~ SoftwareDomain
       , SyntacticN f fi
       , sub :<: SoftwareConstructs
       , Type SoftwarePrimType (DenResult sig)
       )
    => sub sig -> f
sugarSymSoftware = sugarSymDecor $ ValT $ typeRep

-- | Sugar a software symbol as a primitive smart constructor.
sugarSymPrimSoftware
    :: ( Syn.Signature sig
       , fi  ~ SmartFun dom sig
       , sig ~ SmartSig fi
       , dom ~ SmartSym fi
       , dom ~ SoftwareDomain
       , SyntacticN f fi
       , sub :<: SoftwareConstructs
       , SoftwarePrimType (DenResult sig)
       )
    => sub sig -> f
sugarSymPrimSoftware = sugarSymDecor $ ValT $ Node softwareRep

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

instance Syntactic (SExp a)
  where
    type Domain   (SExp a) = SoftwareDomain
    type Internal (SExp a) = a

    desugar = unSExp
    sugar   = SExp

instance Syntactic (Struct SoftwarePrimType SExp a)
  where
    type Domain   (Struct SoftwarePrimType SExp a) = SoftwareDomain
    type Internal (Struct SoftwarePrimType SExp a) = a

    desugar (Node a)     = unSExp a
    desugar (Branch a b) = sugarSymDecor (ValT $ Branch ta tb) Pair a' b'
      where
        a' = desugar a
        b' = desugar b
        ValT ta = getDecor a'
        ValT tb = getDecor b'

    sugar a = case getDecor a of
      ValT (Node _)       -> Node $ SExp a
      ValT (Branch ta tb) -> Branch
        (sugarSymDecor (ValT ta) Fst a)
        (sugarSymDecor (ValT tb) Snd a)
      FunT _ _ -> error "Syntactic can't sugar a function."

instance Tuples SoftwareDomain
  where
    pair   = sugarSymSoftware Pair
    first  = sugarSymSoftware Fst
    second = sugarSymSoftware Snd

instance FreeExp SExp
  where
    type FreePred SExp = PrimType SoftwarePrimType
    constExp = sugarSymSoftware . Lit
    varExp   = sugarSymSoftware . FreeVar

--------------------------------------------------------------------------------
-- syntactic instances.

instance Eval GuardVal
  where
    evalSym (GuardVal InternalAssertion msg) = \cond a ->
      if cond then a else error $ "Internal assertion failure: " ++ show msg
    evalSym (GuardVal (UserAssertion ass) msg) = \cond a ->
      if cond then a else error $ "User assertion " ++ show ass ++ " failure: " ++ show msg

instance Symbol GuardVal
  where
    symSig (GuardVal _ _) = signature

instance Render GuardVal
  where
    renderSym  = show
    renderArgs = renderArgsSmart

instance EvalEnv GuardVal env

instance StringTree GuardVal

instance Equality GuardVal

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

instance Eval HintVal
  where
    evalSym (HintVal) = flip const

instance Symbol HintVal
  where
    symSig (HintVal) = signature

instance Render HintVal
  where
    renderSym  = show
    renderArgs = renderArgsSmart

instance EvalEnv    HintVal env
instance StringTree HintVal
instance Equality   HintVal

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

instance Eval ForLoop
  where
    evalSym ForLoop = \min max init body ->
      foldl (flip body) init [min..max]

instance Symbol ForLoop
  where
    symSig (ForLoop) = signature

instance Render ForLoop
  where
    renderSym  = show
    renderArgs = renderArgsSmart

instance EvalEnv    ForLoop env
instance StringTree ForLoop
instance Equality   ForLoop

--------------------------------------------------------------------------------
-- *** Temporary fix until GHC fixes their class resolution for DTC ***

instance {-# OVERLAPPING #-} Project sub SoftwareConstructs =>
    Project sub (AST SoftwareDomain)
  where
    prj (Sym s) = Syn.prj s
    prj _ = Nothing

instance {-# OVERLAPPING #-} Project sub SoftwareConstructs =>
    Project sub SoftwareDomain
  where
    prj (expr :&: info) = Syn.prj expr

instance {-# OVERLAPPING #-} Project BindingT SoftwareConstructs
  where
    prj (InjL a) = Just a
    prj _ = Nothing

instance {-# OVERLAPPING #-} Project Let SoftwareConstructs
  where
    prj (InjR (InjL a)) = Just a
    prj _ = Nothing

instance {-# OVERLAPPING #-} Project Tuple SoftwareConstructs
  where
    prj (InjR (InjR (InjL a))) = Just a
    prj _ = Nothing

instance {-# OVERLAPPING #-} Project SoftwarePrimConstructs SoftwareConstructs
  where
    prj (InjR (InjR (InjR (InjL a)))) = Just a
    prj _ = Nothing

instance {-# OVERLAPPING #-} Project Construct SoftwareConstructs
  where
    prj (InjR (InjR (InjR (InjR (InjL a))))) = Just a
    prj _ = Nothing

instance {-# OVERLAPPING #-} Project GuardVal SoftwareConstructs
  where
    prj (InjR (InjR (InjR (InjR (InjR (InjL a)))))) = Just a
    prj _ = Nothing

instance {-# OVERLAPPING #-} Project HintVal SoftwareConstructs
  where
    prj (InjR (InjR (InjR (InjR (InjR (InjR (InjL a))))))) = Just a
    prj _ = Nothing

instance {-# OVERLAPPING #-} Project ForLoop SoftwareConstructs
  where
    prj (InjR (InjR (InjR (InjR (InjR (InjR (InjR a))))))) = Just a
    prj _ = Nothing

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


{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE DefaultSignatures #-}
#endif

#if __GLASGOW_HASKELL__ >= 705
{-# LANGUAGE PolyKinds #-}
#endif

#if __GLASGOW_HASKELL__ >= 710
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif

module Generics.Deriving.Foldable (
  -- * Generic Foldable class
    GFoldable(..)

  -- * Default method
  , gfoldMapdefault

  -- * Derived functions
  , gtoList
  , gconcat
  , gconcatMap
  , gand
  , gor
  , gany
  , gall
  , gsum
  , gproduct
  , gmaximum
  , gmaximumBy
  , gminimum
  , gminimumBy
  , gelem
  , gnotElem
  , gfind

  -- * Internal Foldable class
  , GFoldable'(..)
  ) where

import           Control.Applicative (Const, ZipList)

import           Data.Maybe
import qualified Data.Monoid as Monoid (First, Last, Product(..), Sum(..))
import           Data.Monoid (All(..), Any(..), Dual(..), Endo(..))
#if !(MIN_VERSION_base(4,8,0))
import           Data.Monoid (Monoid(..))
#endif

import           Generics.Deriving.Base

#if MIN_VERSION_base(4,4,0)
import           Data.Complex (Complex)
#endif

#if MIN_VERSION_base(4,6,0)
import           Data.Ord (Down)
#else
import           GHC.Exts (Down)
#endif

#if MIN_VERSION_base(4,7,0)
import           Data.Proxy (Proxy)
#endif

#if MIN_VERSION_base(4,8,0)
import           Data.Functor.Identity (Identity)
#endif

#if MIN_VERSION_base(4,9,0)
import qualified Data.Functor.Product as Functor (Product)
import qualified Data.Functor.Sum as Functor (Sum)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.Semigroup as Semigroup (First, Last)
import           Data.Semigroup (Arg, Max, Min, WrappedMonoid)
#endif

--------------------------------------------------------------------------------
-- Generic fold
--------------------------------------------------------------------------------

class GFoldable' t where
  gfoldMap' :: Monoid m => (a -> m) -> t a -> m

instance GFoldable' V1 where
  gfoldMap' _ _ = mempty

instance GFoldable' U1 where
  gfoldMap' _ U1 = mempty

instance GFoldable' Par1 where
  gfoldMap' f (Par1 a) = f a

instance GFoldable' (K1 i c) where
  gfoldMap' _ (K1 _) = mempty

instance (GFoldable f) => GFoldable' (Rec1 f) where
  gfoldMap' f (Rec1 a) = gfoldMap f a

instance (GFoldable' f) => GFoldable' (M1 i c f) where
  gfoldMap' f (M1 a) = gfoldMap' f a

instance (GFoldable' f, GFoldable' g) => GFoldable' (f :+: g) where
  gfoldMap' f (L1 a) = gfoldMap' f a
  gfoldMap' f (R1 a) = gfoldMap' f a

instance (GFoldable' f, GFoldable' g) => GFoldable' (f :*: g) where
  gfoldMap' f (a :*: b) = mappend (gfoldMap' f a) (gfoldMap' f b)

instance (GFoldable f, GFoldable' g) => GFoldable' (f :.: g) where
  gfoldMap' f (Comp1 x) = gfoldMap (gfoldMap' f) x

instance GFoldable' UAddr where
  gfoldMap' _ (UAddr _) = mempty

instance GFoldable' UChar where
  gfoldMap' _ (UChar _) = mempty

instance GFoldable' UDouble where
  gfoldMap' _ (UDouble _) = mempty

instance GFoldable' UFloat where
  gfoldMap' _ (UFloat _) = mempty

instance GFoldable' UInt where
  gfoldMap' _ (UInt _) = mempty

instance GFoldable' UWord where
  gfoldMap' _ (UWord _) = mempty

class GFoldable t where
  gfoldMap :: Monoid m => (a -> m) -> t a -> m
#if __GLASGOW_HASKELL__ >= 701
  default gfoldMap :: (Generic1 t, GFoldable' (Rep1 t), Monoid m)
                   => (a -> m) -> t a -> m
  gfoldMap = gfoldMapdefault
#endif

  gfold :: Monoid m => t m -> m
  gfold = gfoldMap id

  gfoldr :: (a -> b -> b) -> b -> t a -> b
  gfoldr f z t = appEndo (gfoldMap (Endo . f) t) z

  gfoldr' :: (a -> b -> b) -> b -> t a -> b
  gfoldr' f z0 xs = gfoldl f' id xs z0
    where f' k x z = k $! f x z

  gfoldl :: (a -> b -> a) -> a -> t b -> a
  gfoldl f z t = appEndo (getDual (gfoldMap (Dual . Endo . flip f) t)) z

  gfoldl' :: (a -> b -> a) -> a -> t b -> a
  gfoldl' f z0 xs = gfoldr f' id xs z0
    where f' x k z = k $! f z x

  gfoldr1 :: (a -> a -> a) -> t a -> a
  gfoldr1 f xs = fromMaybe (error "gfoldr1: empty structure")
                   (gfoldr mf Nothing xs)
    where
      mf x Nothing = Just x
      mf x (Just y) = Just (f x y)

  gfoldl1 :: (a -> a -> a) -> t a -> a
  gfoldl1 f xs = fromMaybe (error "foldl1: empty structure")
                   (gfoldl mf Nothing xs)
    where
      mf Nothing y = Just y
      mf (Just x) y = Just (f x y)

gfoldMapdefault :: (Generic1 t, GFoldable' (Rep1 t), Monoid m)
                => (a -> m) -> t a -> m
gfoldMapdefault f x = gfoldMap' f (from1 x)

-- Base types instances
instance GFoldable ((,) a) where
  gfoldMap = gfoldMapdefault

instance GFoldable [] where
  gfoldMap = gfoldMapdefault

#if MIN_VERSION_base(4,9,0)
instance GFoldable (Arg a) where
  gfoldMap = gfoldMapdefault
#endif

#if MIN_VERSION_base(4,4,0)
instance GFoldable Complex where
  gfoldMap = gfoldMapdefault
#endif

instance GFoldable (Const m) where
  gfoldMap = gfoldMapdefault

instance GFoldable Down where
  gfoldMap = gfoldMapdefault

instance GFoldable Dual where
  gfoldMap = gfoldMapdefault

instance GFoldable (Either a) where
  gfoldMap = gfoldMapdefault

instance GFoldable Monoid.First where
  gfoldMap = gfoldMapdefault

#if MIN_VERSION_base(4,9,0)
instance GFoldable (Semigroup.First) where
  gfoldMap = gfoldMapdefault
#endif

#if MIN_VERSION_base(4,8,0)
instance GFoldable Identity where
  gfoldMap = gfoldMapdefault
#endif

instance GFoldable Monoid.Last where
  gfoldMap = gfoldMapdefault

#if MIN_VERSION_base(4,9,0)
instance GFoldable Semigroup.Last where
  gfoldMap = gfoldMapdefault

instance GFoldable Max where
  gfoldMap = gfoldMapdefault
#endif

instance GFoldable Maybe where
  gfoldMap = gfoldMapdefault

#if MIN_VERSION_base(4,9,0)
instance GFoldable Min where
  gfoldMap = gfoldMapdefault

instance GFoldable NonEmpty where
  gfoldMap = gfoldMapdefault
#endif

instance GFoldable Monoid.Product where
  gfoldMap = gfoldMapdefault

#if MIN_VERSION_base(4,9,0)
instance (GFoldable f, GFoldable g) => GFoldable (Functor.Product f g) where
  gfoldMap = gfoldMapdefault
#endif

#if MIN_VERSION_base(4,7,0)
instance GFoldable Proxy where
  gfoldMap = gfoldMapdefault
#endif

instance GFoldable Monoid.Sum where
  gfoldMap = gfoldMapdefault

#if MIN_VERSION_base(4,9,0)
instance (GFoldable f, GFoldable g) => GFoldable (Functor.Sum f g) where
  gfoldMap = gfoldMapdefault

instance GFoldable WrappedMonoid where
  gfoldMap = gfoldMapdefault
#endif

instance GFoldable ZipList where
  gfoldMap = gfoldMapdefault

gtoList :: GFoldable t => t a -> [a]
gtoList = gfoldr (:) []

gconcat :: GFoldable t => t [a] -> [a]
gconcat = gfold

gconcatMap :: GFoldable t => (a -> [b]) -> t a -> [b]
gconcatMap = gfoldMap

gand :: GFoldable t => t Bool -> Bool
gand = getAll . gfoldMap All

gor :: GFoldable t => t Bool -> Bool
gor = getAny . gfoldMap Any

gany :: GFoldable t => (a -> Bool) -> t a -> Bool
gany p = getAny . gfoldMap (Any . p)

gall :: GFoldable t => (a -> Bool) -> t a -> Bool
gall p = getAll . gfoldMap (All . p)

gsum :: (GFoldable t, Num a) => t a -> a
gsum = Monoid.getSum . gfoldMap Monoid.Sum

gproduct :: (GFoldable t, Num a) => t a -> a
gproduct = Monoid.getProduct . gfoldMap Monoid.Product

gmaximum :: (GFoldable t, Ord a) => t a -> a
gmaximum = gfoldr1 max

gmaximumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a
gmaximumBy cmp = gfoldr1 max'
  where max' x y = case cmp x y of
                        GT -> x
                        _  -> y

gminimum :: (GFoldable t, Ord a) => t a -> a
gminimum = gfoldr1 min

gminimumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a
gminimumBy cmp = gfoldr1 min'
  where min' x y = case cmp x y of
                        GT -> y
                        _  -> x

gelem :: (GFoldable t, Eq a) => a -> t a -> Bool
gelem = gany . (==)

gnotElem :: (GFoldable t, Eq a) => a -> t a -> Bool
gnotElem x = not . gelem x

gfind :: GFoldable t => (a -> Bool) -> t a -> Maybe a
gfind p = listToMaybe . gconcatMap (\ x -> if p x then [x] else [])


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
{- |
Module      : Language.Scheme.Types
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

Maintainer  : github.com/justinethier
Stability   : experimental
Portability : portable

This module contains top-level data type definitions, environments, error types, and associated functions.

-}

module Language.Scheme.Types
    (
    -- * Environments
      Env (..)
    , nullEnv
    -- * Error Handling
    , LispError (..)
    , ThrowsError
    , IOThrowsError
    , liftThrows
    , showCallHistory
    -- * Types and related functions
    , LispVal (
          Atom
        , List
        , DottedList
        , Vector
        , ByteVector
        , HashTable
        , Number
        , Float
        , Complex
        , Rational
        , String
        , Char
        , Bool
        , PrimitiveFunc
        , Func
             , params
             , vararg
             , body
             , closure
        , HFunc
             , hparams
             , hvararg
             , hbody
             , hclosure
        , IOFunc
        , CustFunc
        , EvalFunc
        , Pointer
             , pointerVar
             , pointerEnv
        , Opaque
        , Port
        , Continuation
             , contClosure
             , currentCont
             , nextCont
             , dynamicWind
             , contCallHist
        , Syntax
             , synClosure
             , synRenameClosure
             , synDefinedInMacro
             , synEllipsis
             , synIdentifiers
             , synRules
        , SyntaxExplicitRenaming
        , LispEnv
        , EOF
        , Nil)
    , nullLisp
    , toOpaque
    , fromOpaque
    , DeferredCode (..)
    , DynamicWinders (..)
    , makeNullContinuation
    , makeCPS
    , makeCPSWArgs
    , eqv
    , eqvList
    , eqVal
    , box
    , makeFunc
    , makeNormalFunc
    , makeVarargs
    , makeHFunc
    , makeNormalHFunc
    , makeHVarargs
    , validateFuncParams
    )
 where
import Control.Monad.Error
import Data.Complex
import Data.Array
import qualified Data.ByteString as BS
import Data.Dynamic
import qualified Data.Knob as DK
import qualified Data.List as DL
import Data.IORef
import qualified Data.Map
-- import Data.Maybe
import Data.Ratio
import System.IO
import Text.ParserCombinators.Parsec hiding (spaces)

-- Environment management

-- |A Scheme environment containing variable bindings of form @(namespaceName, variableName), variableValue@
data Env = Environment {
        parentEnv :: (Maybe Env),
        bindings :: (IORef (Data.Map.Map String (IORef LispVal))),
        pointers :: (IORef (Data.Map.Map String (IORef [LispVal])))
    }

instance Eq Env where
    (Environment _ xb xpts) == (Environment _ yb ypts) =
      (xb == yb) && (xpts == ypts)

-- |An empty environment
nullEnv :: IO Env
nullEnv = do
    nullBindings <- newIORef $ Data.Map.fromList []
    nullPointers <- newIORef $ Data.Map.fromList []
    return $ Environment Nothing nullBindings nullPointers

-- |Types of errors that may occur when evaluating Scheme code
data LispError = NumArgs (Maybe Integer) [LispVal] -- ^Invalid number of function arguments
  | TypeMismatch String LispVal -- ^Type error
  | Parser ParseError -- ^Parsing error
  | BadSpecialForm String LispVal -- ^Invalid special (built-in) form
  | UnboundVar String String -- ^ A referenced variable has not been declared
  | DivideByZero -- ^Divide by Zero error
  | NotImplemented String -- ^ Feature is not implemented
  | InternalError String {- ^An internal error within husk; in theory user (Scheme) code
                         should never allow one of these errors to be triggered. -}
  | Default String -- ^Default error
  | ErrorWithCallHist LispError [LispVal] -- ^Wraps an error to also include the current call history

-- |Create a textual description for a 'LispError'
showError :: LispError -> String
showError (NumArgs (Just expected) found) = "Expected " ++ show expected
                                  ++ " args but found "
                                  ++ (show $ length found)
                                  ++ " values: " ++ unwordsList found
showError (NumArgs Nothing found) = "Incorrect number of args, "
                                    ++ " found "
                                    ++ (show $ length found)
                                    ++ " values: " ++ unwordsList found
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected
                                  ++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ ": " ++ show parseErr
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (DivideByZero) = "Division by zero"
showError (NotImplemented message) = "Not implemented: " ++ message
showError (InternalError message) = "An internal error occurred: " ++ message
showError (Default message) = "Error: " ++ message
showError (ErrorWithCallHist err stack) = showCallHistory (show err) stack

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

-- |Display call history for an error
showCallHistory :: String -> [LispVal] -> String
showCallHistory message hist = do
  let nums :: [Int]
      nums = [0..]
      ns = take (length hist) nums
  message ++ "\n\nCall History:\n" ++
    (unlines $ map (\(n, s) -> ('#' : show n) ++ ": " ++ show s)
                   (zip ns $ reverse hist))

-- |Container used by operations that could throw an error
type ThrowsError = Either LispError

-- |Container used to provide error handling in the IO monad
type IOThrowsError = ErrorT LispError IO

-- |Lift a ThrowsError into the IO monad
liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val

-- |Scheme data types
data LispVal = Atom String
 -- ^Symbol
 | List [LispVal]
 -- ^List
 | DottedList [LispVal] LispVal
 -- ^Pair
 | Vector (Array Int LispVal)
 -- ^Vector
 | ByteVector BS.ByteString
 -- ^ByteVector from R7RS
 | HashTable (Data.Map.Map LispVal LispVal)
 {- ^Hash table.
 Technically this could be a derived data type instead of being built-in to the
 interpreter. And perhaps in the future it will be. But for now, a hash table
 is too important of a data type to not be included. -}
 --
 -- Map is technically the wrong structure to use for a hash table since it is based on a binary tree and hence operations tend to be O(log n) instead of O(1). However, according to <http://www.opensubscriber.com/message/haskell-cafe@haskell.org/10779624.html> Map has good performance characteristics compared to the alternatives. So it stays for the moment...
 --
 | Number Integer -- ^Integer number
 {- FUTURE: rename this to @Integer@ (or @WholeNumber@ or something else more meaningful)
 Integer -}
 | Float Double -- ^Double-precision floating point number
 {- FUTURE: rename this @Real@ instead of @Float@...
 Floating point -}
 | Complex (Complex Double)
 -- ^Complex number
 | Rational Rational
 -- ^Rational number
 | String String
 -- ^String
 | Char Char
 -- ^Character
 | Bool Bool
 -- ^Boolean
 | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
 -- ^Primitive function
 | Func {params :: [String],
         vararg :: (Maybe String),
         body :: [LispVal],
         closure :: Env
        }
 -- ^Function written in Scheme
 | HFunc {hparams :: [String],
          hvararg :: (Maybe String),
          hbody :: (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal),
          hclosure :: Env
        }
 -- ^Function formed from a Haskell function
 | IOFunc ([LispVal] -> IOThrowsError LispVal)
 -- ^Primitive function within the IO monad
 | EvalFunc ([LispVal] -> IOThrowsError LispVal)
 {- ^Function within the IO monad with access to
 the current environment and continuation. -}
 | CustFunc ([LispVal] -> IOThrowsError LispVal)
 -- ^A custom function written by code outside of husk.
 --  Any code that uses the Haskell API should define custom
 --  functions using this data type.
 | Pointer { pointerVar :: String
            ,pointerEnv :: Env }
 -- ^Pointer to an environment variable.
 | Opaque Dynamic
 -- ^Opaque Haskell value.
 | Port Handle (Maybe DK.Knob)
 -- ^I/O port
 | Continuation {  contClosure :: Env                   -- Environment of the continuation
                 , currentCont :: (Maybe DeferredCode)  -- Code of current continuation
                 , nextCont :: (Maybe LispVal)          -- Code to resume after body of cont
                 , dynamicWind :: (Maybe [DynamicWinders]) -- Functions injected by (dynamic-wind)
                 , contCallHist :: [LispVal] -- Active call history
                }
 -- ^Continuation
 | Syntax { synClosure :: Maybe Env       -- ^ Code env in effect at definition time, if applicable
          , synRenameClosure :: Maybe Env -- ^ Renames (from macro hygiene) in effect at def time;
                                          --   only applicable if this macro defined inside another macro.
          , synDefinedInMacro :: Bool     -- ^ Set if macro is defined within another macro
          , synEllipsis :: String         -- ^ String to use as the ellipsis identifier
          , synIdentifiers :: [LispVal]   -- ^ Literal identifiers from syntax-rules
          , synRules :: [LispVal]         -- ^ Rules from syntax-rules
   } -- ^ Type to hold a syntax object that is created by a macro definition.
     --   Syntax objects are not used like regular types in that they are not
     --   passed around within variables. In other words, you cannot use set! to
     --   assign a variable to a syntax object. But they are used during function
     --   application. In any case, it is convenient to define the type here
     --   because syntax objects are stored in the same environments and
     --   manipulated by the same functions as regular variables.
 | SyntaxExplicitRenaming LispVal
   -- ^ Syntax for an explicit-renaming macro
 | LispEnv Env
   -- ^ Wrapper for a scheme environment
 | EOF
   -- ^ End of file indicator
 | Nil String
 -- ^Internal use only; do not use this type directly.

-- | Scheme /null/ value
nullLisp :: LispVal
nullLisp = List []

-- |Convert a Haskell value to an opaque Lisp value.
toOpaque :: Typeable a => a -> LispVal
toOpaque = Opaque . toDyn

-- |Convert an opaque Lisp value back into a Haskell value of the appropriate
--  type, or produce a TypeMismatch error.
fromOpaque :: forall a. Typeable a => LispVal -> ThrowsError a
-- fromOpaque (Opaque o) | isJust $ fromDynamic o = fromJust $ fromDynamic o
-- fromOpaque badArg = throwError $ TypeMismatch (show $ toOpaque (undefined :: a)) badArg

-- Old version that used ViewPatterns
fromOpaque (Opaque (fromDynamic -> Just v)) = return v
fromOpaque badArg = throwError $ TypeMismatch (show $ toOpaque (undefined :: a)) badArg

-- |Container to hold code that is passed to a continuation for deferred execution
data DeferredCode =
    SchemeBody [LispVal] | -- ^A block of Scheme code
    HaskellBody {
       contFunction :: (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
     , contFunctionArgs :: (Maybe [LispVal]) -- Arguments to the higher-order function
    } -- ^A Haskell function

-- |Container to store information from a dynamic-wind
data DynamicWinders = DynamicWinders {
    before :: LispVal -- ^Function to execute when resuming continuation within extent of dynamic-wind
  , after :: LispVal -- ^Function to execute when leaving extent of dynamic-wind
}

showDWVal :: DynamicWinders -> String
showDWVal (DynamicWinders b a) = "(" ++ (show b) ++ " . " ++ (show a) ++ ")"

instance Show DynamicWinders where show = showDWVal

-- |Make an /empty/ continuation that does not contain any code
makeNullContinuation :: Env -> LispVal
makeNullContinuation env = Continuation env Nothing Nothing Nothing []

-- |Make a continuation that takes a higher-order function (written in Haskell)
makeCPS :: Env
        -- ^ Environment
        -> LispVal
        -- ^ Current continuation
        -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
        -- ^ Haskell function
        -> LispVal
        -- ^ The Haskell function packaged as a LispVal
makeCPS env cont@(Continuation {contCallHist=hist}) cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) (dynamicWind cont) hist
makeCPS env cont cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) Nothing [] -- This overload just here for completeness; it should never be used

-- |Make a continuation that stores a higher-order function and arguments to that function
makeCPSWArgs :: Env
        -- ^ Environment
        -> LispVal
        -- ^ Current continuation
        -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
        -- ^ Haskell function
        -> [LispVal]
        -- ^ Arguments to the function
        -> LispVal
        -- ^ The Haskell function packaged as a LispVal
makeCPSWArgs env cont@(Continuation {dynamicWind=dynWind,contCallHist=hist}) cps args =
    Continuation
        env
        (Just (HaskellBody cps (Just args)))
        (Just cont) dynWind hist
makeCPSWArgs env cont cps args =
    -- This overload just here for completeness; it should never be used
    Continuation
        env
        (Just (HaskellBody cps (Just args)))
        (Just cont) Nothing []

instance Ord LispVal where
  compare (Bool a) (Bool b) = compare a b
  compare (Number a) (Number b) = compare a b
  compare (Rational a) (Rational b) = compare a b
  compare (Float a) (Float b) = compare a b
  compare (String a) (String b) = compare a b
  compare (Char a) (Char b) = compare a b
  compare (Atom a) (Atom b) = compare a b
{- compare (DottedList xs x) (DottedList xs x) = compare a b
Vector
HashTable
List
Func
Others? -}
  compare a b = compare (show a) (show b) -- Hack (??): sort alphabetically when types differ or have no handlers

-- |Compare two 'LispVal' instances
eqv :: [LispVal]
    -- ^ A list containing two values to compare
    -> ThrowsError LispVal
    -- ^ Result wrapped as a Bool
eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
eqv [(Complex arg1), (Complex arg2)] = return $ Bool $ arg1 == arg2
eqv [(Rational arg1), (Rational arg2)] = return $ Bool $ arg1 == arg2
eqv [(Float arg1), (Float arg2)] = return $ Bool $ arg1 == arg2
eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
eqv [(Char arg1), (Char arg2)] = return $ Bool $ arg1 == arg2
eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [(Vector arg1), (Vector arg2)] = eqv [List (elems arg1), List (elems arg2)]
eqv [(ByteVector a), (ByteVector b)] = return $ Bool $ a == b
eqv [(HashTable arg1), (HashTable arg2)] =
  eqv [List (map (\ (x, y) -> List [x, y]) $ Data.Map.toAscList arg1),
       List (map (\ (x, y) -> List [x, y]) $ Data.Map.toAscList arg2)]
--
-- This comparison function may be too simplistic. Basically we check to see if
-- functions have the same calling interface. If they do, then we compare the
-- function bodies for equality.
--
--FUTURE:
--
-- The real solution for this and many of the other comparison functions is to
-- assign memory locations to data. Then we can just compare memory locations
-- in cases such as this one. But that is a much larger change.
eqv [x@(Func _ _ xBody _), y@(Func _ _ yBody _)] = do
  if (show x) /= (show y)
     then return $ Bool False
     else eqvList eqv [List xBody, List yBody]
eqv [x@(HFunc{}), y@(HFunc{})] = do
  if (show x) /= (show y)
     then return $ Bool False
     else return $ Bool True
--
eqv [x@(PrimitiveFunc _), y@(PrimitiveFunc _)] = return $ Bool $ (show x) == (show y)
eqv [x@(IOFunc _), y@(IOFunc _)] = return $ Bool $ (show x) == (show y)
eqv [x@(CustFunc _), y@(CustFunc _)] = return $ Bool $ (show x) == (show y)
eqv [x@(EvalFunc _), y@(EvalFunc _)] = return $ Bool $ (show x) == (show y)
-- FUTURE: comparison of two continuations
eqv [l1@(List _), l2@(List _)] = eqvList eqv [l1, l2]
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs (Just 2) badArgList

-- |Compare two lists of haskell values, using the given comparison function
eqvList :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal
eqvList eqvFunc [(List arg1), (List arg2)] =
    return $ Bool $ (length arg1 == length arg2) &&
                    all eqvPair (zip arg1 arg2)
    where eqvPair (x1, x2) = case eqvFunc [x1, x2] of
                               Left _ -> False
                               Right (Bool val) -> val
                               _ -> False -- OK?
eqvList _ _ = throwError $ Default "Unexpected error in eqvList"

-- |A more convenient way to call /eqv/
eqVal :: LispVal -> LispVal -> Bool
eqVal a b = do
  let result = eqv [a, b]
  case result of
    Left _ -> False
    Right (Bool val) -> val
    _ -> False -- Is this OK?

instance Eq LispVal where
  x == y = eqVal x y

-- |Create a textual description of a 'LispVal'
showVal :: LispVal -> String
showVal (Nil _) = ""
showVal (EOF) = "#!EOF"
showVal (LispEnv _) = "<env>"
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Char chr) = [chr]
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Complex contents) = show (realPart contents) ++ "+" ++ (show $ imagPart contents) ++ "i"
showVal (Rational contents) = (show (numerator contents)) ++ "/" ++ (show (denominator contents))
showVal (Float contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (Vector contents) = "#(" ++ unwordsList (Data.Array.elems contents) ++ ")"
showVal (ByteVector contents) = "#u8(" ++ unwords (map show (BS.unpack contents)) ++ ")"
showVal (HashTable _) = "<hash-table>"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")"
showVal (PrimitiveFunc _) = "<primitive>"
showVal (Continuation {}) = "<continuation>"
showVal (Syntax {}) = "<syntax>"
showVal (SyntaxExplicitRenaming _) = "<er-macro-transformer syntax>"
showVal (Func {params = args, vararg = varargs, body = _, closure = _}) =
  "(lambda (" ++ unwords args ++
    (case varargs of
      Nothing -> ""
      Just arg -> " . " ++ arg) ++ ") ...)"
showVal (HFunc {hparams = args, hvararg = varargs, hbody = _, hclosure = _}) =
  "(lambda (" ++ unwords args ++
    (case varargs of
      Nothing -> ""
      Just arg -> " . " ++ arg) ++ ") ...)"
showVal (Port _ _) = "<IO port>"
showVal (IOFunc _) = "<IO primitive>"
showVal (CustFunc _) = "<custom primitive>"
showVal (EvalFunc _) = "<procedure>"
showVal (Pointer p _) = "<ptr " ++ p ++ ">"
showVal (Opaque d) = "<Haskell " ++ show (dynTypeRep d) ++ ">"

-- |A helper function to make pointer deref code more concise
box :: LispVal -> IOThrowsError [LispVal]
box a = return [a]

-- |Convert a list of Lisp objects into a space-separated string
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal

-- |Allow conversion of lispval instances to strings
instance Show LispVal where show = showVal

-- Functions required by the interpreter --

-- |Create a scheme function
makeFunc :: -- forall (m :: * -> *).
            (Monad m) =>
            Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal
makeFunc varargs env fparams fbody = return $ Func (map showVal fparams) varargs fbody env

-- |Create a normal scheme function
makeNormalFunc :: (Monad m) => Env
               -> [LispVal]
               -> [LispVal]
               -> m LispVal
makeNormalFunc = makeFunc Nothing

-- |Create a scheme function that can receive any number of arguments
makeVarargs :: (Monad m) => LispVal -> Env
                        -> [LispVal]
                        -> [LispVal]
                        -> m LispVal
makeVarargs = makeFunc . Just . showVal

-- Functions required by a compiled program --

-- |Create a haskell function
makeHFunc ::
            (Monad m) =>
            Maybe String
         -> Env
         -> [String]
         -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
--         -> String
         -> m LispVal
makeHFunc varargs env fparams fbody = return $ HFunc fparams varargs fbody env --(map showVal fparams) varargs fbody env
-- |Create a normal haskell function
makeNormalHFunc :: (Monad m) =>
                  Env
               -> [String]
               -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
               -> m LispVal
makeNormalHFunc = makeHFunc Nothing

-- |Create a haskell function that can receive any number of arguments
makeHVarargs :: (Monad m) => LispVal
                        -> Env
                        -> [String]
                        -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)
                        -> m LispVal
makeHVarargs = makeHFunc . Just . showVal

-- |Validate formal function parameters.
validateFuncParams :: [LispVal] -> Maybe Integer -> IOThrowsError Bool
--validateFuncParams [Atom _] _ = return True
validateFuncParams ps (Just n) = do
  if length ps /= fromInteger n
     then throwError $ NumArgs (Just n) ps
     else validateFuncParams ps Nothing
validateFuncParams ps Nothing = do
  let syms = filter filterArgs ps
  if (length syms) /= (length ps)
     then throwError $ Default $
             "Invalid lambda parameter(s): " ++ show (List ps)
     else do
         let strs = DL.sort $ map (\ (Atom a) -> a) ps
         case dupe strs of
            Just d -> throwError $ Default $
                         "Duplicate lambda parameter " ++ d
            _ -> return True
 where
  filterArgs (Atom _) = True
  filterArgs _ = False

  dupe (a : b : rest)
    | a == b = Just a
    | otherwise = dupe (b : rest)
  dupe _ = Nothing


module Statistics.Classification.ConfusionMatrix (
    module ConfusionMatrix
  ) where

import Statistics.Classification.ConfusionMatrix.Binary as ConfusionMatrix
import Statistics.Classification.ConfusionMatrix.Multi as ConfusionMatrix


module Overture.Data ( module Data.Void
                     , module Data.Maybe
                     , module Data.Either
                     , module Data.These
                     , module Data.List
                     , module Data.Ord
                     , module Data.Monoid
                     , module Data.Foldable
                     , module Data.Traversable
                     , module Data.Complex
                     , module Data.Ix
                     -- * Renamed functions
                     , unit, (++)
                     -- * Generic equivalents
                     , map, replicate, drop, take, splitAt, length
                     -- * Replacements for needlessly partial functions
                     , head, tail, last, init, cycle, atIndex
                     , read, readEither
                     -- * Assorted utility functions
                     , enumerate, takeUntil2
                     , (??), justIf
                     , between
                     , rightIf, isLeft, isRight, eitherToMaybe, fromEither
                     ) where

import Data.Either
import Data.These
import Data.Void
import Data.Maybe ( maybe, fromMaybe, isNothing, isJust
                  , catMaybes, mapMaybe, maybeToList
                  )
import Data.List ( unfoldr, intersperse, intercalate, sort
                 , sortBy, groupBy, partition, stripPrefix
                 )
import Data.Ord (comparing)
import Data.Monoid (Monoid(..))
import Data.Foldable
import Data.Traversable
import Data.Complex (Complex(..), realPart, imagPart)
import Data.Ix

import Control.Applicative
import Text.ParserCombinators.ReadPrec
import Text.ParserCombinators.ReadP as ReadP hiding (between)
import Text.Read hiding (read)
import qualified Prelude
import qualified Data.List as List
import Overture.ExportPrelude
import Prelude ()

-- better names

-- | Alias for 'mempty'
unit :: (Monoid a) => a
unit = mempty

infixr 5 ++

-- | Alias for 'mappend'
(++) :: (Monoid a) => a -> a -> a
(++) = mappend

-- | A better name for 'fmap'.
map :: (Functor f) => (a -> b) -> (f a -> f b)
map = fmap

replicate :: (Integral z) => z -> a -> [a]
replicate = List.genericReplicate

drop :: (Integral z) => z -> [a] -> [a]
drop = List.genericDrop

take :: (Integral z) => z -> [a] -> [a]
take = List.genericTake

length :: (Integral z) => [a] -> z
length = List.genericLength

splitAt :: (Integral z) => z -> [a] -> ([a], [a])
splitAt = List.genericSplitAt

head :: [a] -> Maybe a
head []    = Nothing
head (x:_) = Just x

tail :: [a] -> Maybe [a]
tail []     = Nothing
tail (_:xs) = Just xs

last :: [a] -> Maybe a
last []     = Nothing
last [x]    = Just x
last (_:xs) = last xs

init :: [a] -> Maybe [a]
init []     = Nothing
init [_]    = Just []
init (x:xs) = (x:) <$> init xs

cycle :: [a] -> Maybe [a]
cycle [] = Nothing
cycle xs = Just $ Prelude.cycle xs

atIndex :: [a] -> Integer -> Maybe a
atIndex xs n = head $ drop n xs

readEither :: (Read a) => String -> Either String a
readEither s =
  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
    [x] -> Right x
    []  -> Left "no parse"
    _   -> Left "ambiguous parse"
 where
  read' = readPrec >>= \x -> lift ReadP.skipSpaces >> return x

read :: (Read a) => String -> Maybe a
read s = case readEither s of
    Left  _ -> Nothing
    Right x -> Just x

-- | A list from 'minBound' to 'maxBound'.
enumerate :: (Enum a, Bounded a) => [a]
enumerate = [minBound .. maxBound]

-- | Takes a prefix of a list until two successive elements satisfy the
--   given predicate, keeping the first.
takeUntil2 :: (a -> a -> Bool) -> [a] -> [a]
takeUntil2 f (x1:x2:xs) | f x1 x2   = [x1]
                        | otherwise = x1:takeUntil2 f (x2:xs)
takeUntil2 _ xs = xs

-- | A synonym for 'fromMaybe' with inverted arguments. Right-associative to
--   allow chaining, e.g. @x ?? y ?? z@.
(??) :: Maybe a -> a -> a
(??) = flip fromMaybe

infixr 3 ??

-- | Keeps or discards values based on a predicate. Useful for unfolds.
justIf :: (a -> Bool) -> a -> Maybe a
justIf p x | p x 	   = Just x
           | otherwise = Nothing

-- | Encodes the result of a predicate using 'Either'.
rightIf :: (a -> Bool) -> (a -> Either a a)
rightIf p x = if p x then Right x else Left x

between :: (Ord a) => a -> a -> a -> Bool
between a z = (&&) <$> (> a) <*> (< z)

isLeft :: Either a b -> Bool
isLeft (Left _) = True
isLeft _        = False

isRight :: Either a b -> Bool
isRight (Right _) = True
isRight _         = False

eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe = either (\_ -> Nothing) Just

fromEither :: (a -> b) -> Either a b -> b
fromEither f (Left l)  = f l
fromEither _ (Right r) = r

-- | Case analysis for 'Bool'.
bool :: r -> r -> Bool -> r
bool f _ False = f
bool _ t True  = t

-- some missing instances

instance Foldable ((,) a) where
    foldr f z (_, x) = f x z

instance Traversable ((,) a) where
    sequenceA (x, y) = (,) x <$> y


module LexerSpec where

import Test.Hspec
import Data.Either
import Data.Complex
import Control.Exception (evaluate)

import qualified Lexer as L
import qualified Text.ParserCombinators.Parsec as PC
import qualified Text.ParserCombinators.Parsec.Error as PCError

instance Eq PC.ParseError where
         (==) x y = show x == show y

isLeft = null . rights . return

floatEqual x y = abs (x - y) < 1.0e-8
rightFloatEq y (Right x) = floatEqual x y
rightFloatEq _ _ = False

rightComplexEq (y1 :+ y2) (Right (x1 :+ x2)) = (floatEqual x1 y1) && (floatEqual x2 y2)
rightComplexEq _ _ = False

main = hspec $ do
  describe "rawParse" $ do
    it "parses identifiers" $ do
      L.parse L.identifier "a" `shouldBe` Right "a"
      L.parse L.identifier "_" `shouldBe` Right "_"
      L.parse L.identifier "_x9" `shouldBe` Right "_x9"
      L.parse L.identifier "ThisVariableIsExported" `shouldBe` Right "ThisVariableIsExported"
      L.parse L.identifier "αβ" `shouldBe` Right "αβ"
      L.parse L.identifier "foreach" `shouldBe` Right "foreach"
      L.parse L.identifier "for2" `shouldBe` Right "for2"
      L.parse L.identifier "breakage" `shouldBe` Right "breakage"

    it "parses keywords" $ do
      L.parse (L.keyword "for") "for" `shouldBe` Right ()
      L.parse (L.keyword "break") "break" `shouldBe` Right ()
      L.parse (L.keyword "continue") "continue" `shouldBe` Right ()
      L.parse (L.keyword "defer") "defer" `shouldBe` Right ()
      L.parse (L.keyword "for") "foreach" `shouldSatisfy` isLeft

    it "parses operators and delimiters" $ do
      L.parse (L.operator "+") "+" `shouldBe` Right ()
      L.parse (L.operator "+=") "+=" `shouldBe` Right ()
      L.parse (L.operator "&") "&" `shouldBe` Right ()
      L.parse (L.operator "&&") "&&" `shouldBe` Right ()
      L.parse (L.operator "&=") "&=" `shouldBe` Right ()
      L.parse (L.operator "&") "&&" `shouldSatisfy` isLeft

    it "parses integer literals" $ do
      L.parse L.integer "0" `shouldBe` Right 0
      L.parse L.integer "42" `shouldBe` Right 42
      L.parse L.integer "0600" `shouldBe` Right 0o600
      L.parse L.integer "0xBadFace3f" `shouldBe` Right 0xBadFace3f
      L.parse L.integer "894864549864587456180" `shouldBe` Right 894864549864587456180

    it "parses floating-point literals" $ do
      L.parse L.float "0." `shouldBe` Right 0.0
      L.parse L.float "72.40" `shouldBe` Right 72.4
      L.parse L.float "072.40" `shouldBe` Right 72.4
      L.parse L.float "2.71828" `shouldBe` Right 2.71828
      L.parse L.float "1.e+0" `shouldBe` Right 1.0
      L.parse L.float "6.67428e-11" `shouldBe` Right 6.67428e-11
      L.parse L.float "1E6" `shouldBe` Right 1.0e6
      L.parse L.float ".25" `shouldBe` Right 0.25
      L.parse L.float ".12345E+5" `shouldSatisfy` (rightFloatEq 0.12345e5)

    it "parses imaginary literals" $ do
      L.parse L.imaginary "0i" `shouldBe` Right (0 :+ 0)
      L.parse L.imaginary "011i" `shouldBe` Right (0 :+ 0o11)
      L.parse L.imaginary "0.i" `shouldBe` Right (0 :+ 0.0)
      L.parse L.imaginary "2.718128i" `shouldBe` Right (0 :+ 2.718128)
      L.parse L.imaginary "1.e+0i" `shouldBe` Right (0 :+ 1.0)
      L.parse L.imaginary "6.67428e-11i" `shouldBe` Right (0 :+ 6.67428e-11)
      L.parse L.imaginary "1E6i" `shouldBe` Right (0 :+ 1.0e6)
      L.parse L.imaginary ".25i" `shouldBe` Right (0 :+ 0.25)
      L.parse L.imaginary ".12345E+5i" `shouldSatisfy` rightComplexEq (0 :+ 0.12345e5)

    it "parses runes" $ do
      L.parse L.char "'a'" `shouldBe` Right 'a'
      L.parse L.char "'ä'" `shouldBe` Right 'ä'
      L.parse L.char "'本'" `shouldBe` Right '本'
      L.parse L.char "'\\t'" `shouldBe` Right '\t'
      L.parse L.char "'\\000'" `shouldBe` Right '\0'
      L.parse L.char "'\\007'" `shouldBe` Right '\7'
      L.parse L.char "'\\377'" `shouldBe` Right '\255'
      L.parse L.char "'\\x07'" `shouldBe` Right '\x7'
      L.parse L.char "'\\xff'" `shouldBe` Right '\xff'
      L.parse L.char "'\\u12e4'" `shouldBe` Right 'ዤ'
      L.parse L.char "'\\U0010FFFD'" `shouldBe` Right '\x10fffd'
      L.parse L.char "'\\\''" `shouldBe` Right '\''
      L.parse L.char "'aa'" `shouldSatisfy` isLeft
      L.parse L.char "'\\xa'" `shouldSatisfy` isLeft
      L.parse L.char "'\\0'" `shouldSatisfy` isLeft

    it "parses strings" $ do
      L.parse L.string "\"abc\"" `shouldBe` Right "abc"
      L.parse L.string "`abc`" `shouldBe` Right "abc"
      L.parse L.string "\"\\\\n\\n\\\\n\"" `shouldBe` Right "\\n\n\\n"
      L.parse L.string "`\\n\n\\n`" `shouldBe` Right "\\n\n\\n"
      L.parse L.string "\"\\n\"" `shouldBe` Right "\n"
      L.parse L.string "`\"`" `shouldBe` Right "\""
      L.parse L.string "\"\\\"\"" `shouldBe` Right "\""
      L.parse L.string "\"Hello, world!\\n\"" `shouldBe` Right "Hello, world!\n"
      L.parse L.string "\"日本語\"" `shouldBe` Right "日本語"
      L.parse L.string "\"\\u65e5本\\U00008a9e\"" `shouldBe` Right "\x65e5本\x00008a9e"
      L.parse L.string "\"\\xff\\u00FF\"" `shouldBe` Right "\xff\x00ff"
      L.parse L.string "\"\\uD800\"" `shouldBe` Right "\xd800"


module Statistics.CSV
    ( txCntInChainMemPoolToCSV
    , focusToCSV
    ) where

import           Control.Monad.Random (MonadRandom (..), evalRandT)
import qualified Data.Text as T
import           System.IO (hPutStrLn)
import           System.Random (mkStdGen)

import           Pos.Infra.Util.JsonLog.Events (JLMemPool (..), MemPoolModifyReason (..))
import           Statistics.Focus (Focus (..))
import           Types
import           Universum

txCntInChainMemPoolToCSV :: FilePath
                         -> Double
                         -> [(NodeId, Timestamp, Int)]
                         -> [(NodeId, Timestamp, JLMemPool)]
                         -> IO ()
txCntInChainMemPoolToCSV f sp txCnt mp =
    flip evalRandT (mkStdGen 918273) $ liftIO $ withFile f WriteMode $ \h -> do
        hPutStrLn h "time,txCount,txType,node"
        for_ txCnt $ \(n, ts, cnt) -> csvLine h "written" n ts (fromIntegral cnt)
        for_ mp $ \(n, ts, p@JLMemPool{..}) ->
            whenM (inSample jlmReason) $ do
                csvLine h (toTxType "Wait" p) n ts jlmWait
                csvLine h (toTxType "Modify" p) n ts jlmModify
                csvLine h (toTxType "SizeAfter" p) n ts (fromIntegral jlmSizeAfter)
  where
    csvLine :: MonadIO m => Handle -> String -> NodeId -> Timestamp -> Integer -> m ()
    csvLine h txType node time txCount = liftIO $ hPutStrLn h $ show (fromIntegral time :: Integer)
        ++ "," ++ show txCount ++ "," ++ txType ++ "," ++ toString node

    draw :: MonadRandom m => m Bool
    draw = (<= sp) <$> getRandomR (0, 1)

    inSample :: MonadRandom m => MemPoolModifyReason -> m Bool
    inSample ProcessTransaction = draw
    inSample _                      = return True

    toTxType :: String -> JLMemPool -> String
    toTxType s JLMemPool{..} =
        let reason = case jlmReason of
                ApplyBlock             -> "ApplyBlock"
                ApplyBlockWithRollback -> "ApplyBlockWithRollback"
                ProcessTransaction     -> "ProcessTransaction"
        in  "mp_" ++ reason ++ "_" ++ s

focusToCSV :: FilePath -> [(Timestamp, NodeId, Focus)] -> IO ()
focusToCSV f xs = withFile f WriteMode $ \h -> do
    hPutStrLn h "time,delta_first_seconds,delta_step_seconds,node,type,block/error"
    case xs of
        []                -> return ()
        ((ts0, _, _) : _) -> foldM_ (step h ts0) ts0 xs
  where
    step :: Handle -> Timestamp -> Timestamp -> (Timestamp, NodeId, Focus) -> IO Timestamp
    step h ts0 ts (ts', n, y) = do
        let dt0 = fromIntegral (ts' - ts0) / 1000000 :: Double
            dt  = fromIntegral (ts' - ts ) / 1000000 :: Double
        case y of
            Received me         -> csvLine h ts' dt0 dt n "received" $ maybe "" show me
            InCreatedBlock hash -> csvLine h ts' dt0 dt n "created" $ T.take 6 hash
            InAdoptedBlock hash -> csvLine h ts' dt0 dt n "adopted" $ T.take 6 hash
        return ts'

    csvLine :: Handle -> Timestamp -> Double -> Double -> NodeId -> String -> BlockHash -> IO ()
    csvLine h ts dt0 dt node t he =
        hPutStrLn h $ show ts ++ "," ++ show dt0 ++ "," ++ show dt ++ "," ++ show node ++ "," ++ t
            ++ "," ++ toString he


{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
-- FIXME: PropSize and Switch not matched by semantics.
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}

--
-- Copyright (c) 2019, 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.Semantics (Semantics(..), semantics) where

import Control.Monad
import Control.Monad.Par.Scheds.TraceInternal (yield)
import Data.Array.IArray
import Data.Array.IO
import Data.Array.Unsafe (unsafeFreeze)
import Data.Bits
import Data.Complex
import Data.Function (on)
import Data.IORef
import Data.List
import Feldspar.Core.Representation
import Feldspar.Core.NestedTuples
import Feldspar.Core.Types
import qualified Control.Exception as C
import qualified Control.Monad.Par as CMP
import System.IO.Unsafe

data Semantics a = Sem {semStr :: String, semSem :: a}

semantics :: Op a -> Semantics a
-- Feldspar.Core.Constructs.Array
semantics Append    = Sem "(++)" (++)
semantics GetIx     = Sem "(!)" evalGetIx
semantics GetLength = Sem "getLength" genericLength
semantics SetLength = Sem "setLength"
        (\n as -> genericTake n (as ++ repeat err))
      where
        err = error "reading uninitialized array element"
semantics Parallel = Sem "parallel"
        (\len ixf -> genericTake len $ map ixf [0..])
semantics Sequential = Sem "sequential"
        (\len i step -> genericTake len $
                        snd $ mapAccumL (\a ix -> swap (step ix a)) i [0..])
      where swap t = (nsnd t, nfst t)
semantics SetIx = Sem "setIx" evalSetIx
-- Feldspar.Core.Constructs.Binding
semantics Let = Sem "let" (flip ($))
-- Feldspar.Core.Constructs.Bits
semantics BAnd          = Sem "(.&.)"      (.&.)
semantics BOr           = Sem "(.|.)"      (.|.)
semantics BXor          = Sem "xor"        xor
semantics Complement    = Sem "complement" complement
semantics Bit           = Sem "bit"           (bit . fromIntegral)
semantics SetBit        = Sem "setBit"        (liftIntWord setBit)
semantics ClearBit      = Sem "clearBit"      (liftIntWord clearBit)
semantics ComplementBit = Sem "complementBit" (liftIntWord complementBit)
semantics TestBit       = Sem "testBit"       (liftIntWord testBit)
semantics ShiftLU       = Sem "shiftLU"     (liftIntWord shiftL)
semantics ShiftRU       = Sem "shiftRU"     (liftIntWord shiftR)
semantics ShiftL        = Sem "shiftL"      (liftInt shiftL)
semantics ShiftR        = Sem "shiftR"      (liftInt shiftR)
semantics RotateLU      = Sem "rotateLU"    (liftIntWord rotateL)
semantics RotateRU      = Sem "rotateRU"    (liftIntWord rotateR)
semantics RotateL       = Sem "rotateL"     (liftInt rotateL)
semantics RotateR       = Sem "rotateR"     (liftInt rotateR)
semantics ReverseBits   = Sem "reverseBits" evalReverseBits
semantics BitScan       = Sem "bitScan"  evalBitScan
semantics BitCount      = Sem "bitCount" evalBitCount
-- Feldspar.Core.Constructs.Complex
semantics MkComplex = Sem "complex"   (:+)
semantics RealPart  = Sem "creal"     realPart
semantics ImagPart  = Sem "cimag"     imagPart
semantics Conjugate = Sem "conjugate" conjugate
semantics MkPolar   = Sem "mkPolar"   mkPolar
semantics Magnitude = Sem "magnitude" magnitude
semantics Phase     = Sem "phase"     phase
semantics Cis       = Sem "cis"       cis
-- Feldspar.Core.Constructs.Condition
semantics Condition = Sem "condition" (\ c t e -> if c then t else e)
-- Feldspar.Core.Constructs.ConditionM
semantics ConditionM = Sem "if" ifM
      where
        ifM cond e t = if cond then e else t
-- Feldspar.Core.Constructs.Conversion
semantics F2I     = Sem "f2i"     truncate
semantics I2N     = Sem "i2n"     (fromInteger.toInteger)
semantics B2I     = Sem "b2i"     (\b -> if b then 1 else 0)
semantics Round   = Sem "round"   round
semantics Ceiling = Sem "ceiling" ceiling
semantics Floor   = Sem "floor"   floor
-- Feldspar.Core.Constructs.Elements
semantics EMaterialize    = Sem "materialize" ematerialize
semantics EWrite          = Sem "write" (\ix e -> Elements [(ix, e)])
semantics ESkip           = Sem "skip" (Elements [])
semantics EPar            = Sem "par" (\(Elements l) (Elements r) -> Elements (l ++ r))
semantics EparFor         = Sem "parFor" eparFor
-- Feldspar.Core.Constructs.Eq
semantics Equal    = Sem "(==)" (==)
semantics NotEqual = Sem "(/=)" (/=)
-- Feldspar.Core.Constructs.Error
semantics Undefined    = Sem "undefined" undefined
semantics (Assert msg) = Sem "assert"
        (\cond a -> if cond then a else error ("Assert failed: " ++ msg))
-- Feldspar.Core.Constructs.FFI
semantics (ForeignImport name f) = Sem name $ unEqBox f
-- Feldspar.Core.Constructs.Floating
semantics Pi      = Sem "pi"      Prelude.pi
semantics Exp     = Sem "exp"     Prelude.exp
semantics Sqrt    = Sem "sqrt"    Prelude.sqrt
semantics Log     = Sem "log"     Prelude.log
semantics Pow     = Sem "(**)"    (Prelude.**)
semantics LogBase = Sem "logBase" Prelude.logBase
semantics Sin     = Sem "sin"     Prelude.sin
semantics Tan     = Sem "tan"     Prelude.tan
semantics Cos     = Sem "cos"     Prelude.cos
semantics Asin    = Sem "asin"    Prelude.asin
semantics Atan    = Sem "atan"    Prelude.atan
semantics Acos    = Sem "acos"    Prelude.acos
semantics Sinh    = Sem "sinh"    Prelude.sinh
semantics Tanh    = Sem "tanh"    Prelude.tanh
semantics Cosh    = Sem "cosh"    Prelude.cosh
semantics Asinh   = Sem "asinh"   Prelude.asinh
semantics Atanh   = Sem "atanh"   Prelude.atanh
semantics Acosh   = Sem "acosh"   Prelude.acosh
-- Feldspar.Core.Constructs.Fractional
semantics DivFrac = Sem "(/)" (/)
-- Feldspar.Core.Constructs.Future
semantics MkFuture = Sem "future" FVal
semantics Await    = Sem "await"  unFVal
-- Feldspar.Core.Constructs.Integral
semantics Quot = Sem "quot" quot
semantics Rem  = Sem "rem"  rem
semantics Div  = Sem "div"  div
semantics Mod  = Sem "mod"  mod
semantics IExp = Sem "(^)"  (^)
-- Feldspar.Core.Constructs.Literal
semantics (Literal l) = Sem "lit" l
-- Feldspar.Core.Constructs.Logic
semantics And = Sem "(&&)" (&&)
semantics Or  = Sem "(||)" (||)
semantics Not = Sem "not"  not
-- Feldspar.Core.Constructs.Loop
semantics While = Sem "while" while
      where
        while cond body = do
                            c <- cond
                            when c (body >> while cond body)
semantics For = Sem "for" for
      where
        for 0 _    = return ()
        for l body = forM_ [0..l-1] body
semantics ForLoop = Sem "forLoop" forLoop
      where
        forLoop 0 initial _    = initial
        forLoop l initial body = foldl (flip body) initial [0..l-1]
semantics WhileLoop = Sem "whileLoop" whileLoop
      where
        whileLoop initial cond body = go initial
          where
            go st | cond st   = go $ body st
                  | otherwise = st
-- Feldspar.Core.Constructs.MutableArray
semantics NewArr    = Sem "newMArr"  $ \l -> newArray (mkBounds $ toInteger l)
semantics NewArr_   = Sem "newMArr_" $ \l -> newListArray (mkBounds $ toInteger l)
        [error $ "Undefined element at index " ++ show (i::Integer) | i <- [0..]]
semantics GetArr    = Sem "getMArr"  $ \arr i -> readArray arr (toInteger i)
semantics SetArr    = Sem "setMArr"  $ \arr i -> writeArray arr (toInteger i)
semantics ArrLength = Sem "arrLength" (getBounds >=> \(l,u) -> return $ fromInteger (u-l+1))
-- Feldspar.Core.Constructs.Mutable
semantics Run = Sem "runMutable" unsafePerformIO
semantics Bind = Sem "(>>=)" (>>=)
semantics Then = Sem "(>>)" (>>)
semantics When = Sem "when" when
semantics Return = Sem "return" return
-- Feldspar.Core.Constructs.MutableReference
semantics NewRef = Sem "newRef" newIORef
semantics GetRef = Sem "getRef" readIORef
semantics SetRef = Sem "setRef" writeIORef
semantics ModRef = Sem "modRef" (\r f -> readIORef r >>= writeIORef r . f)
-- Feldspar.Core.Constructs.MutableToPure
semantics RunMutableArray = Sem "runMutableArray" runMutableArrayEval
semantics WithArray       = Sem "withArray"       withArrayEval
-- Nested tuples
semantics Cons  = Sem "cons"  (:*)
semantics Nil   = Sem "nil"   TNil
semantics Car   = Sem "car"   (\ (x :* _) -> x)
semantics Cdr   = Sem "cdr"   (\ (_ :* y) -> y)
semantics Tup   = Sem "tup"   id
-- Feldspar.Core.Constructs.NoInline
semantics NoInline  = Sem "NoInline" id
-- Feldspar.Core.Constructs.Num
semantics Abs  = Sem "abs" abs
semantics Sign = Sem "signum" signum
semantics Add  = Sem "(+)" (+)
semantics Sub  = Sem "(-)" (-)
semantics Mul  = Sem "(*)" (*)
-- Feldspar.Core.Constructs.Ord
semantics LTH = Sem "(<)"  (<)
semantics GTH = Sem "(>)"  (>)
semantics LTE = Sem "(<=)" (<=)
semantics GTE = Sem "(>=)" (>=)
semantics Min = Sem "min"  min
semantics Max = Sem "max"  max
-- Feldspar.Core.Constructs.Par
semantics ParRun    = Sem "runPar" CMP.runPar
semantics ParNew    = Sem "new" CMP.new
semantics ParGet    = Sem "get" CMP.get
semantics ParPut    = Sem "put" CMP.put_
semantics ParFork   = Sem "fork" CMP.fork
semantics ParYield  = Sem "yield" yield
-- Feldspar.Core.Constructs.RealFloat
semantics Atan2   = Sem "atan2" Prelude.atan2
-- Feldspar.Core.Constructs.Save
semantics Save = Sem "save" id

-- | Support for Array
evalGetIx :: (Integral a, Show a) => [p] -> a -> p
evalGetIx as i
    | 0 <= i && i < len = genericIndex as i
    | otherwise = error $ unwords
        [ "getIx: accessing index"
        , show i
        , "outside the bounds of an array of length"
        , show len
        ]
    where
      len = genericLength as

evalSetIx :: (Integral b, Show b) => [a] -> b -> a -> [a]
evalSetIx as i v
    | 0 <= i && i < len = genericTake i as ++ [v] ++ genericDrop (i+1) as
    | otherwise = error $ unwords
        [ "setIx: assigning index"
        , show i
        , "outside the bounds of an array of length"
        , show len
        ]
    where
      len = genericLength as

-- | Support for Bits
liftIntWord :: (a -> Int -> b) -> a -> WordN -> b
liftIntWord f x = f x . fromIntegral

liftInt :: (a -> Int -> b) -> a -> IntN -> b
liftInt f x = f x . fromIntegral

evalReverseBits :: (Num b, FiniteBits b) => b -> b
evalReverseBits b = revLoop b 0 (0 `asTypeOf` b)
  where
    bSz = finiteBitSize b
    revLoop x i n | i >= bSz    = n
                  | testBit x i = revLoop x (i+1) (setBit n (bSz - i - 1))
                  | otherwise   = revLoop x (i+1) n

evalBitScan :: (FiniteBits b) => b -> WordN
evalBitScan b =
   if isSigned b
   then scanLoop b (testBit b (finiteBitSize b - 1)) (finiteBitSize b - 2) 0
   else scanLoop b False (finiteBitSize b - 1) 0
  where
    scanLoop x t i n | i Prelude.< 0            = n
                     | testBit x i Prelude./= t = n
                     | otherwise                = scanLoop x t (i-1) (n+1)

evalBitCount :: (FiniteBits b) => b -> WordN
evalBitCount b = loop b (finiteBitSize b - 1) 0
  where
    loop x i n | i Prelude.< 0 = n
               | testBit x i   = loop x (i-1) (n+1)
               | otherwise     = loop x (i-1) n

-- | Support for Elements
ematerialize :: Length -> Elements a -> [a]
ematerialize l (Elements xs) = map snd xs'
  where xs' = genericTake l $ sortBy (compare `on` fst) xs

eparFor :: Length -> (Index -> Elements a) -> Elements a
eparFor len ixf = Elements $ concatMap (\(Elements vs) -> vs) xs
      where xs = genericTake len $ map ixf [0..]

-- | Support for MultableArray
-- | Calculate array bounds. If the length is zero, flip the arguments to
-- make an empty range
mkBounds :: Integer -> (Integer,Integer)
mkBounds l = (0, pred l)

-- | Support for MutableToPure
runMutableArrayEval :: forall a . Mut (MArr a) -> [a]
runMutableArrayEval m = unsafePerformIO $
                        do marr <- m
                           iarr <- unsafeFreeze marr
                           return (elems (iarr :: Array Integer a))

withArrayEval :: forall a b. MArr a -> ([a] -> Mut b) -> Mut b
withArrayEval ma f
    = do a <- f (elems (unsafePerformIO $ freeze ma :: Array Integer a))
         C.evaluate a


module HashedExpression.Internal.Utils where

import Data.Array
import Data.Complex
import qualified Data.IntMap.Strict as IM
import Data.List.Split (splitOn)
import Data.Map (Map, fromList)
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Time (diffUTCTime, getCurrentTime)
import GHC.IO.Unsafe (unsafePerformIO)
import GHC.Stack (HasCallStack)
import HashedExpression.Internal.Expression
import HashedExpression.Internal.Hash
import HashedExpression.Internal.Node
import HashedExpression.Prettify
import Prelude hiding ((^))
import qualified Prelude

-- | Forward pipe operator in Elm
(|>) :: a -> (a -> b) -> b
(|>) = flip ($)

infixl 1 |>

-- | Chain a list of endomorphisms to a endomorphism
chain :: [a -> a] -> a -> a
chain = flip $ foldl (|>)

-- |
read2DValues :: FilePath -> IO (Array (Int, Int) Double)
read2DValues filePath = do
  rows <- lines <$> readFile filePath
  let doubleRows = map (map read . splitOn " ") rows
  let numRow = length doubleRows
      numCol = length . head $ doubleRows
      allDoubles = concat doubleRows
  return $ listArray ((0, 0), (numRow - 1, numCol - 1)) allDoubles

--        allDoubles = map read . concat $ rows

-- |
mapBoth :: (a -> b) -> (a, a) -> (b, b)
mapBoth f (x, y) = (f x, f y)

-- |
mapSecond :: (b -> c) -> [(a, b)] -> [(a, c)]
mapSecond _ [] = []
mapSecond f ((x, y) : rest) = (x, f y) : mapSecond f rest

-- |
measureTime :: IO a -> IO ()
measureTime action = do
  beforeTime <- getCurrentTime
  action
  afterTime <- getCurrentTime
  putStrLn $ "Took " ++ show (diffUTCTime afterTime beforeTime) ++ " seconds"

-- |
bringMaybeOut :: (Maybe a, Maybe b) -> Maybe (a, b)
bringMaybeOut (Just x, Just y) = Just (x, y)
bringMaybeOut _ = Nothing

-- | Check if all elements of the list is equal
allEqual :: (Eq a) => [a] -> Bool
allEqual xs = and $ zipWith (==) (safeTail xs) xs
  where
    safeTail [] = []
    safeTail (x : xs) = xs

fromR :: Double -> Complex Double
fromR x = x :+ 0

ensureSameShape :: Expression d et1 -> Expression d et2 -> a -> a
ensureSameShape e1 e2 after
  | expressionShape e1 == expressionShape e2 = after
  | otherwise =
    error $
      "Ensure same shape failed "
        ++ show (prettifyDebug e1)
        ++ " "
        ++ show (prettifyDebug e2)

ensureSameShapeList :: [Expression d et] -> a -> a
ensureSameShapeList es after
  | allEqual (map expressionShape es) = after
  | otherwise =
    error $ "Ensure same shape failed " ++ show (map expressionShape es)

constWithShape :: Shape -> Double -> Expression d R
constWithShape shape val = Expression h (IM.fromList [(h, node)])
  where
    node = (shape, Const val)
    h = hash node

varWithShape :: Shape -> String -> (ExpressionMap, NodeID)
varWithShape shape name = (IM.fromList [(h, node)], h)
  where
    node = (shape, Var name)
    h = hash node

-- |
isScalarShape :: Shape -> Bool
isScalarShape = null

-- |
pullConstant :: ExpressionMap -> NodeID -> Maybe (Shape, Double)
pullConstant mp n
  | (shape, Const c) <- retrieveInternal n mp = Just (shape, c)
  | otherwise = Nothing

-- |
pullConstants :: ExpressionMap -> [NodeID] -> Maybe (Shape, [Double])
pullConstants mp ns
  | xs@(x : _) <- mapMaybe (pullConstant mp) ns = Just (fst x, map snd xs)
  | otherwise = Nothing

-- |
isZero :: ExpressionMap -> NodeID -> Bool
isZero mp nId
  | Const 0 <- retrieveNode nId mp = True
  | RealImag arg1 arg2 <- retrieveNode nId mp,
    Const 0 <- retrieveNode arg1 mp,
    Const 0 <- retrieveNode arg2 mp =
    True
  | otherwise = False

-- |
isOne :: ExpressionMap -> NodeID -> Bool
isOne mp nId
  | Const 1 <- retrieveNode nId mp = True
  | RealImag arg1 arg2 <- retrieveNode nId mp,
    Const 1 <- retrieveNode arg1 mp,
    Const 0 <- retrieveNode arg2 mp =
    True
  | otherwise = False

-- |
isConstant :: ExpressionMap -> NodeID -> Bool
isConstant mp nId
  | Const _ <- retrieveNode nId mp = True
  | otherwise = False

-- |
pullSumOperands :: ExpressionMap -> NodeID -> [NodeID]
pullSumOperands mp nId
  | Sum _ operands <- retrieveNode nId mp = operands
  | otherwise = [nId]

-- |
pullProdOperands :: ExpressionMap -> NodeID -> [NodeID]
pullProdOperands mp nId
  | Mul _ operands <- retrieveNode nId mp = operands
  | otherwise = [nId]

-- |
aConst :: Shape -> Double -> (ExpressionMap, NodeID)
aConst shape val = (IM.fromList [(h, node)], h)
  where
    node = (shape, Const val)
    h = hash node

-- |
dVarWithShape :: Shape -> String -> (ExpressionMap, NodeID)
dVarWithShape shape name = (IM.fromList [(h, node)], h)
  where
    node = (shape, DVar name)
    h = hash node

showT :: Show a => a -> T.Text
showT = T.pack . show

-- |
maybeVariable :: DimensionType d => Expression d R -> Maybe (String, Shape)
maybeVariable (Expression nID mp) = case retrieveInternal nID mp of
  (shape, Var name) -> Just (name, shape)
  _ -> Nothing

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

-- | MARK: (+)
-------------------------------------------------------------------------------
instance Num (Array Int Double) where
  (+) arr1 arr2 =
    listArray
      (0, size - 1)
      [x + y | i <- [0 .. size - 1], let x = arr1 ! i, let y = arr2 ! i]
    where
      size = length . elems $ arr1
  negate arr =
    listArray (0, size - 1) [- x | i <- [0 .. size - 1], let x = arr ! i]
    where
      size = length . elems $ arr
  (*) arr1 arr2 =
    listArray
      (0, size - 1)
      [x * y | i <- [0 .. size - 1], let x = arr1 ! i, let y = arr2 ! i]
    where
      size = length . elems $ arr1
  abs = error "TODO"
  signum = error "N/A"
  fromInteger = error "TODO"

instance Num (Array Int (Complex Double)) where
  (+) arr1 arr2 =
    listArray
      (0, size - 1)
      [x + y | i <- [0 .. size - 1], let x = arr1 ! i, let y = arr2 ! i]
    where
      size = length . elems $ arr1
  negate arr =
    listArray (0, size - 1) [- x | i <- [0 .. size - 1], let x = arr ! i]
    where
      size = length . elems $ arr
  (*) arr1 arr2 =
    listArray
      (0, size - 1)
      [x * y | i <- [0 .. size - 1], let x = arr1 ! i, let y = arr2 ! i]
    where
      size = length . elems $ arr1
  abs = error "TODO"
  signum = error "N/A"
  fromInteger = error "TODO"

instance PowerOp Double Int where
  (^) x y = x Prelude.^ y


#if __GLASGOW_HASKELL__ >= 703
{-# LANGUAGE Safe #-}
#endif
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.DeepSeq
-- Copyright   :  (c) The University of Glasgow 2001-2009
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  stable
-- Portability :  portable
--
-- This module provides an overloaded function, 'deepseq', for fully
-- evaluating data structures (that is, evaluating to \"Normal Form\").
--
-- A typical use is to prevent resource leaks in lazy IO programs, by
-- forcing all characters from a file to be read. For example:
--
-- > import System.IO
-- > import Control.DeepSeq
-- >
-- > main = do
-- >     h <- openFile "f" ReadMode
-- >     s <- hGetContents h
-- >     s `deepseq` hClose h
-- >     return s
--
-- 'deepseq' differs from 'seq' as it traverses data structures deeply,
-- for example, 'seq' will evaluate only to the first constructor in
-- the list:
--
-- > > [1,2,undefined] `seq` 3
-- > 3
--
-- While 'deepseq' will force evaluation of all the list elements:
--
-- > > [1,2,undefined] `deepseq` 3
-- > *** Exception: Prelude.undefined
--
-- Another common use is to ensure any exceptions hidden within lazy
-- fields of a data structure do not leak outside the scope of the
-- exception handler, or to force evaluation of a data structure in one
-- thread, before passing to another thread (preventing work moving to
-- the wrong threads).
--
module Control.DeepSeq (
     deepseq, ($!!), force,
     NFData(..),
  ) where

import Data.Int
import Data.Word
import Data.Ratio
import Data.Complex
import Data.Array
import Data.Fixed
import Data.Version

infixr 0 $!!

-- | 'deepseq': fully evaluates the first argument, before returning the
-- second.
--
-- The name 'deepseq' is used to illustrate the relationship to 'seq':
-- where 'seq' is shallow in the sense that it only evaluates the top
-- level of its argument, 'deepseq' traverses the entire data structure
-- evaluating it completely.
--
-- 'deepseq' can be useful for forcing pending exceptions,
-- eradicating space leaks, or forcing lazy I/O to happen.  It is
-- also useful in conjunction with parallel Strategies (see the
-- @parallel@ package).
--
-- There is no guarantee about the ordering of evaluation.  The
-- implementation may evaluate the components of the structure in
-- any order or in parallel.  To impose an actual order on
-- evaluation, use 'pseq' from "Control.Parallel" in the
-- @parallel@ package.
--
deepseq :: NFData a => a -> b -> b
deepseq a b = rnf a `seq` b

-- | the deep analogue of '$!'.  In the expression @f $!! x@, @x@ is
-- fully evaluated before the function @f@ is applied to it.
($!!) :: (NFData a) => (a -> b) -> a -> b
f $!! x = x `deepseq` f x

-- | a variant of 'deepseq' that is useful in some circumstances:
--
-- > force x = x `deepseq` x
--
-- @force x@ fully evaluates @x@, and then returns it.  Note that
-- @force x@ only performs evaluation when the value of @force x@
-- itself is demanded, so essentially it turns shallow evaluation into
-- deep evaluation.

force :: (NFData a) => a -> a
force x = x `deepseq` x

-- | A class of types that can be fully evaluated.
class NFData a where
    -- | rnf should reduce its argument to normal form (that is, fully
    -- evaluate all sub-components), and then return '()'.
    --
    -- The default implementation of 'rnf' is
    --
    -- > rnf a = a `seq` ()
    --
    -- which may be convenient when defining instances for data types with
    -- no unevaluated fields (e.g. enumerations).
    rnf :: a -> ()
    rnf a = a `seq` ()

instance NFData Int
instance NFData Word
instance NFData Integer
instance NFData Float
instance NFData Double

instance NFData Char
instance NFData Bool
instance NFData ()

instance NFData Int8
instance NFData Int16
instance NFData Int32
instance NFData Int64

instance NFData Word8
instance NFData Word16
instance NFData Word32
instance NFData Word64

instance NFData (Fixed a)

-- |This instance is for convenience and consistency with 'seq'.
-- This assumes that WHNF is equivalent to NF for functions.
instance NFData (a -> b)

--Rational and complex numbers.

instance (Integral a, NFData a) => NFData (Ratio a) where
  rnf x = rnf (numerator x, denominator x)

instance (RealFloat a, NFData a) => NFData (Complex a) where
  rnf (x:+y) = rnf x `seq`
               rnf y `seq`
               ()

instance NFData a => NFData (Maybe a) where
    rnf Nothing  = ()
    rnf (Just x) = rnf x

instance (NFData a, NFData b) => NFData (Either a b) where
    rnf (Left x)  = rnf x
    rnf (Right y) = rnf y

instance NFData Data.Version.Version where
    rnf (Data.Version.Version branch tags) = rnf branch `seq` rnf tags

instance NFData a => NFData [a] where
    rnf [] = ()
    rnf (x:xs) = rnf x `seq` rnf xs

instance (Ix a, NFData a, NFData b) => NFData (Array a b) where
    rnf x = rnf (bounds x, Data.Array.elems x)

instance (NFData a, NFData b) => NFData (a,b) where
  rnf (x,y) = rnf x `seq` rnf y

instance (NFData a, NFData b, NFData c) => NFData (a,b,c) where
  rnf (x,y,z) = rnf x `seq` rnf y `seq` rnf z

instance (NFData a, NFData b, NFData c, NFData d) => NFData (a,b,c,d) where
  rnf (x1,x2,x3,x4) = rnf x1 `seq`
		        rnf x2 `seq`
		        rnf x3 `seq`
		        rnf x4

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) =>
         NFData (a1, a2, a3, a4, a5) where
  rnf (x1, x2, x3, x4, x5) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) =>
         NFData (a1, a2, a3, a4, a5, a6) where
  rnf (x1, x2, x3, x4, x5, x6) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) =>
         NFData (a1, a2, a3, a4, a5, a6, a7) where
  rnf (x1, x2, x3, x4, x5, x6, x7) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8

instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9) =>
         NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
  rnf (x1, x2, x3, x4, x5, x6, x7, x8, x9) =
                  rnf x1 `seq`
                  rnf x2 `seq`
                  rnf x3 `seq`
                  rnf x4 `seq`
                  rnf x5 `seq`
                  rnf x6 `seq`
                  rnf x7 `seq`
                  rnf x8 `seq`
                  rnf x9


module SpaceState.Init(lostLife, initState, die)
where

import Data.List
import Control.Monad
import Control.Monad.State as State
import Prelude hiding (catch)

import Graphics.Rendering.OpenGL as OpenGL
import Graphics.UI.SDL as SDL
import qualified Data.Edison.Assoc.StandardMap as M

import OpenGLUtils
import Statistics
import Entity
import AObject
import TextScreen
import Mission

import SpaceState.Game
import SpaceState.City
import SpaceState.Common

lostLife :: String -> String -> StateT SpaceState IO Bool
lostLife s1 s2 = do
  modify $ modLives pred
  modify $ modPlCash $ const 0 -- so that no points are given for cash
  state <- State.get
  if lives state <= 0
    then do
      gameOver s1 gameoverText
    else do
      pressKeyScreen (liftIO $ makeTextScreen (30, 550) [(gamefont state,
                         Color4 1.0 0.2 0.2 1.0, s1 ++ "\n\n" ++ s2 ++ "\n\nPress ENTER to continue")]
                         (return ())) SDLK_RETURN
      initState
      return False

initState :: StateT SpaceState IO ()
initState = do
  modify $ modAObjects $ setupBarycenters
  lc <- getRandomPlanet
  modify $ modTri $ modifyPosition (const $ (getPosition lc *+* (glVector3UnitX *** (2 * AObject.size lc))))
  modify $ modPlCash $ const startCash
  modify $ modPlHoldspace $ const maxHold
  modify $ modPlCargo $ const M.empty
  modify $ modPlHealth $ const startPlHealth
  modify $ modPlMissions $ const emptyMissionMap
  modify $ modAvailMission $ const Nothing
  gotoCity lc
  releaseKeys

getRandomPlanet :: StateT SpaceState IO AObject
getRandomPlanet = do
  state <- State.get
  n <- liftIO $ chooseIO (aobjects state)
  if (aobjName n == "Star")
    then getRandomPlanet
    else return n

die :: StateT SpaceState IO (Maybe Int)
die = do
  state <- State.get
  return $ Just $ finalPoints state


{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Data.Fingerprint (
  Fingerprint (..)
, WithFingerprint (..)
, HasFingerprint (..)
, fp
, fromByteString
, toByteString
, fromByteString16
, toByteString16
, sinkFingerprint
) where

import           Control.DeepSeq (NFData(rnf), ($!!))
import           Crypto.Hash
import           Crypto.Hash.Conduit (sinkHash)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Unsafe as BS
import           Data.Int
import           Data.Word
import           Data.Complex
import           Data.Conduit (Consumer)
import           Data.Maybe (fromJust)
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote
import           Language.Haskell.TH.Syntax
import           System.IO.Unsafe
import           Foreign.Marshal.Utils (with)
import           Foreign.C.Types
import           Foreign.Ptr (castPtr)
import           Foreign.Storable (Storable, sizeOf)

newtype Fingerprint = FP { unFP :: Digest SHA256 }
  deriving (Eq, Ord, NFData)

instance Show Fingerprint where show = show . unFP

data WithFingerprint a = WithFingerprint Fingerprint a
  deriving (Eq, Ord, Show)

instance NFData a => NFData (WithFingerprint a) where
  rnf (WithFingerprint f a) = rnf f `seq` rnf a

fromByteString :: BS.ByteString -> Maybe Fingerprint
fromByteString = fmap FP . digestFromByteString

toByteString :: Fingerprint -> BS.ByteString
toByteString (FP h) = unsafeDupablePerformIO $
  BA.withByteArray h (BS.packCStringLen . (,BA.length h))

fromByteString16 :: BS.ByteString -> Maybe Fingerprint
fromByteString16 b16 =
  case B16.decode b16 of
    (bs,bad) | B.null bad -> fromByteString bs
    _                     -> Nothing

toByteString16 :: Fingerprint -> BS.ByteString
toByteString16 = B16.encode . toByteString

sinkFingerprint :: Monad m => Consumer BS.ByteString m Fingerprint
sinkFingerprint = fmap FP sinkHash

class HasFingerprint o where
  fingerprint :: o -> Fingerprint
  default fingerprint :: Storable o => o -> Fingerprint
  fingerprint o = unsafeDupablePerformIO $ with o $ \oPtr -> do
    x <- fingerprint <$> BS.unsafePackCStringLen (castPtr oPtr, sizeOf (undefined :: o))
    return $!! x
  {-# INLINE fingerprint #-}

instance Monoid Fingerprint where
  mempty = FP (hashFinalize hashInit)
  {-# INLINE mempty #-}
  mappend (FP a) (FP b) = FP . hashFinalize $ hashUpdates hashInit [a, b]
  {-# INLINE mappend #-}
  mconcat = FP . hashFinalize . hashUpdates hashInit . map unFP
  {-# INLINE mconcat #-}

instance {-# OVERLAPPABLE #-} (Foldable f, HasFingerprint o) => HasFingerprint (f o) where
  fingerprint = foldMap fingerprint
  {-# INLINE fingerprint #-}

fp ::QuasiQuoter
fp = QuasiQuoter
  { quoteExp = \s -> do
      loc <- location
      let h = fingerprint . BS.pack
            $ concatMap ($ loc) [loc_package, loc_module, show . loc_start, const s]
      [e|WithFingerprint h|]
  , quotePat = const (fail "Cannot apply fp quasiquoter in patterns")
  , quoteType = const (fail "Cannot apply fp quasiquoter in types")
  , quoteDec  = const (fail "Cannot apply fp quasiquoter in declarations")
  }

instance Lift Fingerprint where
  lift fp_ =
    return $ ConE 'FP
      `AppE` (VarE 'fromJust
      `AppE` (VarE 'digestFromByteString
      `AppE` (VarE 'unsafeDupablePerformIO
      `AppE` (VarE 'BS.unsafePackAddressLen
      `AppE` LitE (IntegerL $ fromIntegral $ BS.length bs)
      `AppE` LitE (StringPrimL (B.unpack bs))))))
    where bs = toByteString fp_

instance HasFingerprint (WithFingerprint a) where
  fingerprint (WithFingerprint f _) = f
  {-# INLINE fingerprint #-}

instance HasFingerprint Fingerprint where
  fingerprint = id
  {-# INLINE fingerprint #-}

instance HasFingerprint BS.ByteString where
  fingerprint = FP . hash
  {-# INLINE fingerprint #-}

instance HasFingerprint String where
  fingerprint = fingerprint . BS.pack
  {-# INLINE fingerprint #-}

instance HasFingerprint ()
instance HasFingerprint Word8
instance HasFingerprint Word16
instance HasFingerprint Word32
instance HasFingerprint Word64
instance HasFingerprint Int8
instance HasFingerprint Int16
instance HasFingerprint Int32
instance HasFingerprint Int64
instance HasFingerprint Int
instance HasFingerprint Float
instance HasFingerprint Double
instance HasFingerprint CInt
instance HasFingerprint CChar
instance HasFingerprint CShort
instance HasFingerprint CLong
instance HasFingerprint CLLong
instance HasFingerprint CUInt
instance HasFingerprint CUChar
instance HasFingerprint CUShort
instance HasFingerprint CULong
instance HasFingerprint CULLong
instance HasFingerprint CFloat
instance HasFingerprint CDouble
instance HasFingerprint (Complex Int)
instance HasFingerprint (Complex Int32)
instance HasFingerprint (Complex Int16)
instance HasFingerprint (Complex Float)
instance HasFingerprint (Complex Double)


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

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

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

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