-- |
-- Module    : Main
-- Copyright : (c) 2011 Jason Knight
-- License   : BSD3
--
-- Maintainer  : jason@jasonknight.us
-- Stability   : experimental
-- Portability : portable
--
-- See the help information by executing the generated executable with no
-- parameters.
--

module Main where

import GRN.Parse
import GRN.StateTransition
import GRN.Render
import GRN.Types
import GRN.Density
import GRN.Sparse
import GRN.EM
import GRN.Uncertainty
import GRN.DataFlow
import GRN.Utils

import qualified Data.Map as M
import Data.List
import Data.Ord
import Control.Monad
import Text.Printf
import System.Environment
import System.Cmd
import System.Console.ParseArgs
import System.FilePath
import System.Directory

import Data.Graph.Analysis

import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.Vector.Generic as G
import Statistics.Sample.KernelDensity
import Statistics.Sample
import Graphics.Gnuplot.Simple

argList :: [Arg String]
argList =
 [ Arg "output" (Just 'o') (Just "output")
    (argDataDefaulted "FILE" ArgtypeString "out.svg") "Output file."
 , Arg "extra" (Just 'e') (Just "extra")
    (argDataDefaulted "PW_ARGS" ArgtypeString "")
    "Extra Pathway arguments; space delimited."
 , Arg "extra2" (Just 'f') (Just "extra2")
    (argDataDefaulted "PW_ARGS" ArgtypeString "")
    "Extra Pathway arguments; space delimited For SM runs."
 , Arg "reduce" (Just 'r') (Just "reduce") Nothing
    "Reduce output graph to attractor cycles."
 , Arg "generate" (Just 'g') (Just "generate") Nothing
    "Generate an image"
 , Arg "open" (Just 'x') (Just "open") Nothing
    "Open generated image automatically"
 , Arg "avg" Nothing (Just "avg")
    (argDataDefaulted "INT" ArgtypeInt 8)
    "Averaging sums to perform"
 , Arg "n1" Nothing (Just "n1")
    (argDataDefaulted "INT" ArgtypeInt 15)
    "First elimination (reduction) pass amount"
 , Arg "n2" Nothing (Just "n2")
    (argDataDefaulted "INT" ArgtypeInt 150)
    "Second pass (only simulation) amount. "
 , Arg "n3" Nothing (Just "n3")
    (argDataDefaulted "INT" ArgtypeInt 140)
    "Runs for Density estimation ignored if m!=d"
 , Arg "n4" Nothing (Just "n4")
    (argDataDefaulted "INT" ArgtypeInt 0)
    ("If mode=d, then this is the seed, otherwise 0:deterministic equal valued "++
    "outgoing edge probabilities. Also number of samples in \
    \sampling dataflow mode.")
 , Arg "mode" (Just 'm') (Just "mode")
    (argDataRequired "MODE" ArgtypeString)
    ("s:state transition graph, ss:state transition matrix, p:pathway diagram, \
    \sm:modified stg, d:density estimation, em:expectation maximization, \
    \m:Mohammad output, df: DataFlow, c: Control")
 , Arg "submode" Nothing (Just "submode")
    (argDataDefaulted "SUBMODE" ArgtypeString "m")
    "m: Matrix multiplication, g: graph, \
    \When control: e: exact, s: sampling."
 , Arg "prog" (Nothing) (Just "prog")
    (argDataDefaulted "PROG" ArgtypeString "dot")
    "Graphviz Draw Program to generate output"
 , Arg "knock" (Just 'k') (Just "knock")
    (argDataDefaulted "KNOCK" ArgtypeString "stoch")
    "Knockouts in Dataflow mode: det(erministic), stoch(astic)"
 , Arg "gamma" Nothing (Just "gamma")
    (argDataDefaulted "DOUBLE" ArgtypeDouble 0.1)
    "Amount to modify edges in dataflow mode."
 , Arg "perturb" (Just 'p') (Just "perturb")
    (argDataDefaulted "DOUBLE" ArgtypeDouble 0.0)
    "In Mohammad output, set the perturbation probability."
 , Arg "input" Nothing Nothing
    (argDataRequired "FILE" ArgtypeString) "Input File."
 ]

main = do
    args <- parseArgsIO ArgsComplete argList
    let inFile = getRequiredArg args "input"
        n1 = getRequiredArg args "n1" :: Int
        n2 = getRequiredArg args "n2" :: Int
        mode = getRequiredArg args "mode"
        gen = gotArg args "generate"
        modes = ["s","p","sm","d","ss","em","m","df","c"]
    if (length (modes\\[mode]) == length mode)
        then error $ usageError args ("Choose a valid mode.")
        else return ()
    con <- readFile inFile
    let start = parsePW $ (unlines.words $ getRequiredArg args "extra2") ++ con
        p = parsePW $ (unlines.words $ getRequiredArg args "extra") ++ con

    when (mode == "s") $ do
        let initg = kmapToStateGraph.buildKmaps $ p
            finalGraph = simulate args initg
        if (n1+n2 < 50) then print "WARNING: Number of simulation iterations \
        \less than 50. Please consider increasing n1 or n2. Also consider \
        \using the far superior 'ss' method for simulation." else return ()
        mapM_ (printf "%7s") (M.keys p)
        putStrLn ""
        printSSA $ genSSA finalGraph
        when gen $ drawStateGraph finalGraph args
        return ()

    when (mode == "ss") $ do
        let initm = (kmapToDOK.buildKmaps $ p)  0
            finalSSD = simulateDOKUnif args initm
            (DOK (n,_) m) = initm
        mapM_ (printf "%7s") (M.keys p)
        putStrLn ""
        --print $ maximum $ map (snd) $ M.keys m
        --print $ G.length $ colIndices $ dokToCSC initm
        --print $ G.length $ rowIndices $ dokToCSC initm
        --print $ G.length $ cscValues $ dokToCSC initm
        printSSA $ ssdToSSA finalSSD
        --Cant draw a graph when we have a matrix... well we could, but we'd
        --have to convert:
        --when gen $ drawStateGraph finalGraph args
        return ()

    when (mode == "df") $ do
        let initm = parseToDataFlow args p
            finalSSD = simulateDOKUnif args initm
            graph = convertProbsVG finalSSD $ dataFlowToGraph initm
            (DOK (n,_) m) = initm
        mapM_ (printf "%7s") (M.keys p)
        putStrLn ""
        printSSA $ ssdToSSA finalSSD
        when gen $ drawDataFlow graph args
        return ()

    when (mode == "c") $ do
        let pcon = parseControl con
        simControl args p pcon
        return ()

    when (mode == "d") $ do
        simRuns args p
        return ()

    when (mode == "m") $ do
        uncertaintyPrint args p
        return ()

    when (mode == "sm") $ do
        let initm = (kmapToDOK.buildKmaps $ start)  0
            secm = (kmapToDOK.buildKmaps $ p) 0
            interSSD = simulateDOKUnif args initm
            (DOK (n,_) m) = initm
            finalSSD = simulateDOK args secm interSSD
        mapM_ (printf "%7s") (M.keys p)
        putStrLn ""
        printSSA $ ssdToSSA finalSSD
        return ()

    when (mode == "p") $ do
        let finalGraph = mkSimple $ buildGeneGraph p
        when gen $ drawGeneGraph finalGraph args
        return ()

defArgs :: Args String
defArgs = parseArgs ArgsComplete argList "./grnsim" ["-m","df","pws/doesntmatter.pw"]


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module LispVals (
    Frame,
    Env,
    ThrowsError,
    EnvThrowsError,
    IOThrowsError,
    LispVal(..),
    LispError(..),
    LispEval
  ) where

import Data.Ratio (Ratio, numerator, denominator)
import Data.Complex (Complex((:+)))
import qualified Data.Vector as V (toList, Vector)
import qualified Data.Map.Strict as M (Map)
import Text.ParserCombinators.Parsec (ParseError)
import Control.Monad.Error (ErrorT, Error, noMsg, strMsg, MonadError, throwError, catchError)
import Control.Monad.State (State, StateT)
import Control.Monad.Cont (ContT(..), runContT)
import Control.Monad.Trans (lift)
import System.IO (Handle)
import Data.IORef (IORef)

type Frame = M.Map String LispVal
type Env = [IORef Frame]
type ThrowsError = Either LispError
-- ErrorT e m a ~ m (Either e a)
-- State s a ~ s -> (a, s)
-- ErrorT e (State s a) ~ s -> (Either e a, s)
type EnvThrowsError = ErrorT LispError (State Env)
-- StateT s m a ~ s -> m (a, s)
-- ErrorT e (StateT s m) a ~ s -> m (Either e a, s)
-- StateT s (ErrorT e m) a ~ s -> m (Either e (a, s))
type IOThrowsError = ErrorT LispError (StateT Env IO)

type LispEval = ContT LispVal IOThrowsError LispVal
-- mtl doesn't define a MonadError instances for ContT
-- http://stackoverflow.com/questions/10742151/why-cant-contt-be-made-an-instance-of-monaderror
instance MonadError e m => MonadError e (ContT r m) where
  throwError = lift . throwError
  catchError op h = ContT $ \k -> catchError (runContT op k) (\e -> runContT (h e) k)

data LispVal = Void
        | Atom String
        | List [LispVal]
        | Vector (V.Vector LispVal)
        | DottedList [LispVal] LispVal
        | Number Integer
        | String String
        | Bool Bool
        | Char Char
        | Float Float
        | Complex (Complex Float)
        | Ratio (Ratio Integer)
        | Port Handle
        | Continuation (LispVal -> LispEval)
        | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
        | IOFunc ([LispVal] -> IOThrowsError LispVal)
        | SpecialFormFunc ([LispVal] -> LispEval)
        | Func
            { params :: [String]
            , vararg :: Maybe String
            , body :: [LispVal], closure :: Env}

instance Show LispVal where show = showVal
showVal :: LispVal -> String
showVal Void = "<void>"
showVal (Continuation _) = "<continuation>"
showVal (String contents) = "\"" ++ unescapeString contents ++ "\""
showVal (Atom name) = name
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (Char contents) = "#\\" ++ case contents of
                            '\n' -> "newline"
                            ' ' -> "space"
                            _ -> [contents]
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")"
showVal (Vector contents) =
    "#(" ++ (unwordsList . V.toList) contents ++ ")"
showVal (Float contents) = show contents
showVal (Complex (r :+ i))
    | i > 0 = show r ++ "+" ++ show i ++ "i"
    | i < 0 = show r ++ show i ++ "i"
    | otherwise = show r
showVal (Ratio contents) = show (numerator contents) ++ "/" ++ show (denominator contents)
showVal (Port _) = "<port>"
showVal (PrimitiveFunc _) = "<primitive>"
showVal (SpecialFormFunc _) = "<special form primitive>"
showVal (IOFunc _) = "<io primitive>"
showVal (Func {params = args, vararg = varargs}) =
  "(lambda (" ++ unwords (map show args) ++
     (case varargs of
        Nothing -> ""
        Just arg -> " . " ++ arg) ++ ") ...)"

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

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

instance Show LispError where show = showError

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

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

unescapeString :: String -> String
unescapeString [] = []
unescapeString (x:xs)
    | x == '\n' = "\\n" ++ unescapeString xs
    | x == '\t' = "\\t" ++ unescapeString xs
    | x == '\r' = "\\r" ++ unescapeString xs
    | x == '\"' = "\\\"" ++ unescapeString xs
    | x == '\\' = "\\\\" ++ unescapeString xs
    | otherwise = x : unescapeString xs


module Main (main) -- TEST
where {
import Fast2haskell;
import Data.Complex;--1.3
import Data.Array;--1.3

    c_eps=(5.00000e-06 :: Double);
    c_t=True;
    c_f=False;
    c_input=(0 :: Int);
    f_main a_n=
        let {
            r_x=[(a_tf,(++) (show a_i) ((++) "\t" a_str))|(a_i,(a_tf,a_str))<-f_zip2 (enumFrom (1 :: Int)) c_testlist];
            r_noks=[(++) a_str "\n"|(a_tf,a_str)<-r_x,not a_tf];
            r_oks=[(++) a_str "\n"|(a_tf,a_str)<-r_x,a_tf]
         } in
            if (((>) :: (Int -> Int -> Bool)) a_n (0 :: Int))
            then (f_onetest ((!!) c_testlist (((-) :: (Int -> Int -> Int)) a_n (1 :: Int))))
            else
                ((++) (show (length r_oks)) ((++) " tests passed and " ((++) (show
                (length r_noks)) ((++) " failed\n" (c_concat r_noks)))));
    f_onetest (True,a_str)=(++) "true:  " ((++) a_str "\n");
    f_onetest (False,a_str)=(++) "false: " ((++) a_str "\n");
    f_booltest a_name True a_try=
        if a_try
        then (True,"")
        else
            (False,(++) a_name "\tok: true is: false");
    f_booltest a_name False a_try=
        if (not a_try)
        then (True,"")
        else
            (False,(++) a_name "\tok: false is: true");
    f_inttest a_name a_ok a_try=
        if (((==) :: (Int -> Int -> Bool)) a_ok a_try)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) (show a_ok) ((++) "\tis: "
            (show a_try)))));
    f_chartest a_name a_ok a_try=
        if (((==) :: (Int -> Int -> Bool)) (fromEnum a_ok) (fromEnum a_try))
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) ((:) a_ok []) ((++) "\tis: "
            ((:) a_try [])))));
    f_strtest a_name a_ok a_try=
        if (strcmp a_ok a_try)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) a_ok ((++) "\tis: " a_try))));
    f_linttest a_name a_ok a_try=
        if (f_lintcmp a_ok a_try)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) (f_showlint a_ok) ((++) "\tis: "
            (f_showlint a_try)))));
    f_doubtest a_name a_ok a_try=
        if (((<=) :: (Double -> Double -> Bool)) (f_abs (((-) :: (Double -> Double -> Double)) a_ok a_try)) c_eps)
        then (True,"")
        else
            (False,(++) a_name ((++) "\tok: " ((++) (show a_ok) ((++) "\tis: "
            ((++) (show a_try) ((++) "\tok-is: " (show (((-) :: (Double -> Double -> Double)) a_ok a_try))))))));
    f_alternating a_l=(:) (0 :: Int) ((:) (1 :: Int) a_l);
    f_showlint []=[];
    f_showlint a_xs=tail (c_concat [(++) "," (show a_x)|a_x<-a_xs]);
    f_lintcmp [] []=True;
    f_lintcmp [] a_ys=False;
    f_lintcmp a_xs []=False;
    f_lintcmp (a_x:a_xs) (a_y:a_ys)=
        if (((==) :: (Int -> Int -> Bool)) a_x a_y)
        then (f_lintcmp a_xs a_ys)
        else
            False;
    c_testlist=(:) (f_inttest "array" (10 :: Int) ((!) (array (descr (1 :: Int) (3 :: Int)) ((:)
        ((,) (3 :: Int) (30 :: Int)) ((:) ((,) (1 :: Int) (10 :: Int)) ((:) ((,) (2 :: Int) (20 :: Int)) [])))) (1 :: Int))) ((:) (f_inttest "array" (20 :: Int)
        ((!) (array (descr (1 :: Int) (3 :: Int)) ((:) ((,) (3 :: Int) (30 :: Int)) ((:) ((,) (1 :: Int) (10 :: Int))
        ((:) ((,) (2 :: Int) (20 :: Int)) [])))) (2 :: Int))) ((:) (f_inttest "array" (30 :: Int) ((!) (array (descr (1 :: Int) (3 :: Int))
        ((:) ((,) (3 :: Int) (30 :: Int)) [])) (3 :: Int))) ((:) (f_inttest "assoc" (0 :: Int) (indassoc ((,) (0 :: Int) (1 :: Int)))) ((:)
        (f_inttest "assoc" (1 :: Int) (valassoc ((,) (0 :: Int) (1 :: Int)))) ((:) (f_inttest "bounds" (1 :: Int) (lowbound (bounds
        (listArray (descr (1 :: Int) (3 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))))))) ((:) (f_inttest "bounds" (3 :: Int)
        (upbound (bounds (listArray (descr (1 :: Int) (3 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))))))
        ((:) (f_inttest "descr" (0 :: Int) (lowbound (descr (0 :: Int) (1 :: Int)))) ((:) (f_inttest "descr" (1 :: Int) (upbound
        (descr (0 :: Int) (1 :: Int)))) ((:) (f_linttest "destr_update" ((:) (1 :: Int) ((:) (0 :: Int) ((:) (3 :: Int) []))) (elems
        (destr_update (listArray (descr (0 :: Int) (2 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (1 :: Int) (0 :: Int)))) ((:)
        (f_linttest "destr_update" ((:) (0 :: Int) []) (elems (destr_update (listArray (descr (0 :: Int) (0 :: Int)) ((:) (1 :: Int)
        ((:) (2 :: Int) ((:) (3 :: Int) [])))) (0 :: Int) (0 :: Int)))) ((:) (f_linttest "elems" ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))
        (elems (listArray (descr (0 :: Int) (2 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))))) ((:)
        (f_linttest "elems" ((:) (1 :: Int) []) (elems (listArray (descr (0 :: Int) (0 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int)
        ((:) (3 :: Int) [])))))) ((:) (f_inttest "indassoc" (0 :: Int) (indassoc ((,) (0 :: Int) (1 :: Int)))) ((:) (f_linttest "listarray"
        ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))) (elems (listArray (descr (0 :: Int) (2 :: Int)) ((:) (1 :: Int)
        ((:) (2 :: Int) ((:) (3 :: Int) [])))))) ((:) (f_linttest "listarray" ((:) (1 :: Int) []) (elems (listArray
        (descr (0 :: Int) (0 :: Int)) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))))) ((:) (f_inttest "lowbound" (0 :: Int) (lowbound
        (descr (0 :: Int) (1 :: Int)))) ((:) (f_inttest "subscript" (1 :: Int) ((!) (tabulate ((!!) ((:) (1 :: Int)
        ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))) (0 :: Int))) ((:) (f_inttest "subscript" (2 :: Int) ((!) (tabulate
        ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))) (1 :: Int))) ((:) (f_inttest "subscript" (3 :: Int)
        ((!) (tabulate ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))) (2 :: Int)))
        ((:) (f_linttest "tabulate" ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))) (elems (tabulate
        ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) [])))) (descr (0 :: Int) (2 :: Int))))) ((:) (f_linttest "tabulate"
        ((:) (1 :: Int) []) (elems (tabulate ((!!) ((:) (1 :: Int) ((:) (2 :: Int) ((:) (3 :: Int) []))))
        (descr (0 :: Int) (0 :: Int))))) ((:) (f_inttest "upbound" (1 :: Int) (upbound (descr (0 :: Int) (1 :: Int)))) ((:) (f_inttest "valassoc" (1 :: Int)
        (valassoc ((,) (0 :: Int) (1 :: Int)))) ((:) (f_doubtest "add_x" (0.00000 :: Double) (realPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double))
        ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:) (f_doubtest "add_x" (0.00000 :: Double) (imagPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double)))))
        ((:) (f_doubtest "add_x" (4.00000 :: Double) (realPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:)
        (f_doubtest "add_x" (6.00000 :: Double) (imagPart (((+) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_doubtest "complex" (1.00000 :: Double)
        (realPart ((:+) (1.00000 :: Double) (0.00000 :: Double)))) ((:) (f_doubtest "complex" (1.00000 :: Double) (imagPart ((:+) (0.00000 :: Double) (1.00000 :: Double)))) ((:)
        (f_doubtest "complex_im" (0.00000 :: Double) (imagPart ((:+) (1.00000 :: Double) (0.00000 :: Double)))) ((:) (f_doubtest "complex_im" (1.00000 :: Double) (imagPart ((:+) (0.00000 :: Double) (1.00000 :: Double))))
        ((:) (f_doubtest "complex_re" (0.00000 :: Double) (realPart ((:+) (0.00000 :: Double) (1.00000 :: Double)))) ((:) (f_doubtest "complex_re" (1.00000 :: Double) (realPart
        ((:+) (1.00000 :: Double) (0.00000 :: Double)))) ((:) (f_doubtest "mul_x" (0.00000 :: Double) (realPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double)))))
        ((:) (f_doubtest "mul_x" (0.00000 :: Double) (imagPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:)
        (f_doubtest "mul_x" (((negate) :: (Double -> Double)) (5.00000 :: Double)) (realPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:)
        (f_doubtest "mul_x" (10.0000 :: Double) (imagPart (((*) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_doubtest "sub_x" (0.00000 :: Double)
        (realPart (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:) (f_doubtest "sub_x" (0.00000 :: Double) (imagPart
        (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (0.00000 :: Double) (0.00000 :: Double)) ((:+) (0.00000 :: Double) (0.00000 :: Double))))) ((:) (f_doubtest "sub_x" (((negate) :: (Double -> Double)) (2.00000 :: Double)) (realPart
        (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_doubtest "sub_x" (((negate) :: (Double -> Double)) (2.00000 :: Double)) (imagPart
        (((-) :: (Complex_type -> Complex_type -> Complex_type)) ((:+) (1.00000 :: Double) (2.00000 :: Double)) ((:+) (3.00000 :: Double) (4.00000 :: Double))))) ((:) (f_inttest "seq" (2 :: Int) (seq (enumFrom (1 :: Int)) (2 :: Int)))
        ((:) (f_strtest "**" "this one" "should fail") [])))))))))))))))))))))))))))))))))))))))))));
    f_abs a_x=
        if (((<=) :: (Double -> Double -> Bool)) a_x (0.00000 :: Double))
        then (((negate) :: (Double -> Double)) a_x)
        else
            a_x;
    c_and=f_foldr (&&) True;
    f_cjustify a_n a_s=
        let {
            r_margin=((-) :: (Int -> Int -> Int)) a_n (length a_s);
            r_lmargin=((div) :: (Int -> Int -> Int)) r_margin (2 :: Int);
            r_rmargin=((-) :: (Int -> Int -> Int)) r_margin r_lmargin
         } in  (++) (f_spaces r_lmargin) ((++) a_s (f_spaces r_rmargin));
    c_concat=f_foldr (++) [];
    f_const a_x a_y=a_x;
    f_digit a_x=
        if (((<=) :: (Int -> Int -> Bool)) (fromEnum '0') (fromEnum a_x))
        then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_x) (fromEnum '9'))
        else
            False;
    f_drop 0 a_x=a_x;
    f_drop a_n (a_a:a_x)=f_drop (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x;
    f_drop a_n a_x=[];
    f_dropwhile a_f []=[];
    f_dropwhile a_f (a_a:a_x)=
        if (a_f a_a)
        then (f_dropwhile a_f a_x)
        else
            ((:) a_a a_x);
    c_e=((exp) :: (Double -> Double)) (1.00000 :: Double);
    f_filter a_f a_x=[a_a|a_a<-a_x,a_f a_a];
    f_foldl a_op a_r []=a_r;
    f_foldl a_op a_r (a_a:a_x)=
        let {
            f_strict a_f a_x=seq a_x (a_f a_x)
         } in  f_foldl a_op (f_strict a_op a_r a_a) a_x;
    f_foldl1 a_op (a_a:a_x)=f_foldl a_op a_a a_x;
    f_foldr a_op a_r []=a_r;
    f_foldr a_op a_r (a_a:a_x)=a_op a_a (f_foldr a_op a_r a_x);
    f_foldr1 a_op (a_a:[])=a_a;
    f_foldr1 a_op (a_a:a_b:a_x)=a_op a_a (f_foldr1 a_op ((:) a_b a_x));
    f_fst (a_a,a_b)=a_a;
    f_id a_x=a_x;
    f_index a_x=
        let {
            f_f a_n []=[];
            f_f a_n (a_a:a_x)=(:) a_n (f_f (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x)
         } in  f_f (0 :: Int) a_x;
    f_init (a_a:a_x)=
        if (null a_x)
        then []
        else
            ((:) a_a (f_init a_x));
    f_iterate a_f a_x=(:) a_x (f_iterate a_f (a_f a_x));
    f_last a_x=(!!) a_x (((-) :: (Int -> Int -> Int)) (length a_x) (1 :: Int));
    f_lay []=[];
    f_lay (a_a:a_x)=(++) a_a ((++) "\n" (f_lay a_x));
    f_layn a_x=
        let {
            f_f a_n []=[];
            f_f a_n (a_a:a_x)=(++) (f_rjustify (4 :: Int) (show a_n)) ((++) ") " ((++) a_a ((++) "\n"
                (f_f (((+) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x))))
         } in  f_f (1 :: Int) a_x;
    f_letter a_c=
        if (
            if (((<=) :: (Int -> Int -> Bool)) (fromEnum 'a') (fromEnum a_c))
            then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_c) (fromEnum 'z'))
            else
                False)
        then True
        else
        if (((<=) :: (Int -> Int -> Bool)) (fromEnum 'A') (fromEnum a_c))
        then (((<=) :: (Int -> Int -> Bool)) (fromEnum a_c) (fromEnum 'Z'))
        else
            False;
    f_limit (a_a:a_b:a_x)=
        if (((==) :: (Double -> Double -> Bool)) a_a a_b)
        then a_a
        else
            (f_limit ((:) a_b a_x));
    f_lines []=[];
    f_lines (a_a:a_x)=
        let {
            r_xs=
                if (pair a_x)
                then (f_lines a_x)
                else
                    ((:) [] [])
         } in
            if (((==) :: (Int -> Int -> Bool)) (fromEnum a_a) (fromEnum '\o012'))
            then ((:) [] (f_lines a_x))
            else
                ((:) ((:) a_a (head r_xs)) (tail r_xs));
    f_ljustify a_n a_s=(++) a_s (f_spaces (((-) :: (Int -> Int -> Int)) a_n (length a_s)));
    f_map a_f a_x=[a_f a_a|a_a<-a_x];
    f_map2 a_f a_x a_y=[a_f a_a a_b|(a_a,a_b)<-f_zip2 a_x a_y];
    f_max a_xs=f_foldl1 f_max2 a_xs;
    f_max2 a_a a_b=
        if (((>=) :: (Int -> Int -> Bool)) a_a a_b)
        then a_a
        else
            a_b;
    f_member a_x a_a=c_or (f_map (flip ((==) :: (Int -> Int -> Bool)) a_a) a_x);
    f_merge [] a_y=a_y;
    f_merge (a_a:a_x) []=(:) a_a a_x;
    f_merge (a_a:a_x) (a_b:a_y)=
        if (((<=) :: (Int -> Int -> Bool)) a_a a_b)
        then ((:) a_a (f_merge a_x ((:) a_b a_y)))
        else
            ((:) a_b (f_merge ((:) a_a a_x) a_y));
    f_min a_xs=f_foldl1 f_min2 a_xs;
    f_min2 a_a a_b=
        if (((>) :: (Int -> Int -> Bool)) a_a a_b)
        then a_b
        else
            a_a;
    f_mkset []=[];
    f_mkset (a_a:a_x)=(:) a_a (f_filter (flip ((/=) :: (Int -> Int -> Bool)) a_a) (f_mkset a_x));
    c_or=f_foldr (||) False;
    c_pi=((*) :: (Double -> Double -> Double)) (4.00000 :: Double) (((atan) :: (Double -> Double)) (1.00000 :: Double));
    f_postfix a_a a_x=(++) a_x ((:) a_a []);
    c_product=f_foldl ((*) :: (Int -> Int -> Int)) (1 :: Int);
    f_rep a_n a_x=f_take a_n (f_repeat a_x);
    f_repeat a_x=(:) a_x (f_repeat a_x);
    c_reverse=f_foldl (flip (:)) [];
    f_rjustify a_n a_s=(++) (f_spaces (((-) :: (Int -> Int -> Int)) a_n (length a_s))) a_s;
    f_scan a_op=
        let {
            f_g a_r []=(:) a_r [];
            f_g a_r (a_a:a_x)=(:) a_r (f_g (a_op a_r a_a) a_x)
         } in  f_g;
    f_snd (a_a,a_b)=a_b;
    f_sort a_x=
        let {
            r_n=length a_x;
            r_n2=((div) :: (Int -> Int -> Int)) r_n (2 :: Int)
         } in
            if (((<=) :: (Int -> Int -> Bool)) r_n (1 :: Int))
            then a_x
            else
                (f_merge (f_sort (f_take r_n2 a_x)) (f_sort (f_drop r_n2 a_x)));
    f_spaces a_n=f_rep a_n ' ';
    f_subtract a_x a_y=((-) :: (Int -> Int -> Int)) a_y a_x;
    c_sum=f_foldl ((+) :: (Int -> Int -> Int)) (0 :: Int);
data
    T_sys_message=F_Stdout [Char] | F_Stderr [Char] | F_Tofile [Char] [Char] | F_Closefile [Char] | F_Appendfile [Char] | F_System [Char] | F_Exit Int;
    f_take 0 a_x=[];
    f_take a_n (a_a:a_x)=(:) a_a (f_take (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)) a_x);
    f_take a_n a_x=[];
    f_takewhile a_f []=[];
    f_takewhile a_f (a_a:a_x)=
        if (a_f a_a)
        then ((:) a_a (f_takewhile a_f a_x))
        else
            [];
    f_transpose a_x=
        let {
            r_x'=f_takewhile pair a_x
         } in
            if (null r_x')
            then []
            else
                ((:) (f_map head r_x') (f_transpose (f_map tail r_x')));
    f_until a_f a_g a_x=
        if (a_f a_x)
        then a_x
        else
            (f_until a_f a_g (a_g a_x));
    f_zip2 (a_a:a_x) (a_b:a_y)=(:) (a_a,a_b) (f_zip2 a_x a_y);
    f_zip2 a_x a_y=[];
    f_zip3 (a_a:a_x) (a_b:a_y) (a_c:a_z)=(:) (a_a,a_b,a_c) (f_zip3 a_x a_y a_z);
    f_zip3 a_x a_y a_z=[];
    f_zip4 (a_a:a_w) (a_b:a_x) (a_c:a_y) (a_d:a_z)=(:) (a_a,a_b,a_c,a_d) (f_zip4 a_w a_x a_y a_z);
    f_zip4 a_w a_x a_y a_z=[];
    f_zip5 (a_a:a_v) (a_b:a_w) (a_c:a_x) (a_d:a_y) (a_e:a_z)=(:) (a_a,a_b,a_c,a_d,a_e) (f_zip5 a_v a_w a_x a_y a_z);
    f_zip5 a_v a_w a_x a_y a_z=[];
    f_zip6 (a_a:a_u) (a_b:a_v) (a_c:a_w) (a_d:a_x) (a_e:a_y) (a_f:a_z)=(:) (a_a,a_b,a_c,a_d,a_e,a_f) (f_zip6 a_u a_v a_w a_x a_y a_z);
    f_zip6 a_u a_v a_w a_x a_y a_z=[];
    f_zip (a_x,a_y)=f_zip2 a_x a_y;
    main = putStr (f_main c_input)
}


{-# language GADTs #-}
{-# language QuasiQuotes #-}
{-# language ScopedTypeVariables #-}
{-# language FlexibleContexts #-}

module Feldspar.Software.Primitive.Backend where

import Feldspar.Software.Primitive

import Data.Complex (Complex (..))
import Data.Constraint (Dict (..))
import Data.Proxy

-- syntactic.
import Language.Syntactic

-- language-c-quote.
import Language.C.Quote.C
import qualified Language.C.Syntax as C

--imperative-edsl.
import Language.C.Monad
import Language.Embedded.Backend.C

--------------------------------------------------------------------------------
-- * Compilation of software primitives.
--------------------------------------------------------------------------------

viewLitPrim :: ASTF SoftwarePrimDomain a -> Maybe a
viewLitPrim (Sym (Lit a :&: _)) = Just a
viewLitPrim _                   = Nothing

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

instance CompTypeClass SoftwarePrimType
  where
    compType _ (_ :: proxy a) = case softwareRep :: SoftwarePrimTypeRep a of
      BoolST   -> addInclude "<stdbool.h>" >> return [cty| typename bool |]
      Int8ST   -> addInclude "<stdint.h>"  >> return [cty| typename int8_t |]
      Int16ST  -> addInclude "<stdint.h>"  >> return [cty| typename int16_t |]
      Int32ST  -> addInclude "<stdint.h>"  >> return [cty| typename int32_t |]
      Int64ST  -> addInclude "<stdint.h>"  >> return [cty| typename int64_t |]
      Word8ST  -> addInclude "<stdint.h>"  >> return [cty| typename uint8_t |]
      Word16ST -> addInclude "<stdint.h>"  >> return [cty| typename uint16_t |]
      Word32ST -> addInclude "<stdint.h>"  >> return [cty| typename uint32_t |]
      Word64ST -> addInclude "<stdint.h>"  >> return [cty| typename uint64_t |]
      FloatST  -> return [cty| float |]
      DoubleST -> return [cty| double |]
      ComplexFloatST  ->
        addInclude "<tgmath.h>" >> return [cty| float  _Complex |]
      ComplexDoubleST ->
        addInclude "<tgmath.h>" >> return [cty| double _Complex |]

    compLit _ a = case softwarePrimTypeOf a of
      BoolST  ->
        do addInclude "<stdbool.h>"
           return $ if a then [cexp| true |] else [cexp| false |]
      Int8ST   -> return [cexp| $a |]
      Int16ST  -> return [cexp| $a |]
      Int32ST  -> return [cexp| $a |]
      Int64ST  -> return [cexp| $a |]
      Word8ST  -> return [cexp| $a |]
      Word16ST -> return [cexp| $a |]
      Word32ST -> return [cexp| $a |]
      Word64ST -> return [cexp| $a |]
      FloatST  -> return [cexp| $a |]
      DoubleST -> return [cexp| $a |]
      ComplexFloatST  -> return $ compComplexLit a
      ComplexDoubleST -> return $ compComplexLit a

instance CompExp Prim
  where
    compExp = compPrim

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

compUnOp
  :: MonadC m
  => C.UnOp
  -> ASTF SoftwarePrimDomain a
  -> m C.Exp
compUnOp op a = do
  a' <- compPrim $ Prim a
  return $ C.UnOp op a' mempty

compBinOp
  :: MonadC m
  => C.BinOp
  -> ASTF SoftwarePrimDomain a
  -> ASTF SoftwarePrimDomain b
  -> m C.Exp
compBinOp op a b = do
  a' <- compPrim $ Prim a
  b' <- compPrim $ Prim b
  return $ C.BinOp op a' b' mempty

compCast
  :: MonadC m
  => SoftwarePrimTypeRep a
  -> ASTF SoftwarePrimDomain b
  -> m C.Exp
compCast t a = do
  p <- compPrim $ Prim a
  compCastExp t p

compCastExp
  :: MonadC m
  => SoftwarePrimTypeRep a
  -> C.Exp
  -> m C.Exp
compCastExp t p = case softwarePrimWitType t of
  Dict -> do
    typ <- compType (Proxy :: Proxy SoftwarePrimType) t
    return [cexp|($ty:typ) $p|]

compFun
  :: MonadC m
  => String
  -> Args (AST SoftwarePrimDomain) sig
  -> m C.Exp
compFun fun args = do
  as <- sequence $ listArgs (compPrim . Prim) args
  return [cexp| $id:fun($args:as) |]

compRotateL_def = [cedecl|
unsigned int feld_rotl(const unsigned int value, int shift) {
    if ((shift &= sizeof(value)*8 - 1) == 0)
      return value;
    return (value << shift) | (value >> (sizeof(value)*8 - shift));
} |]

compRotateR_def = [cedecl|
unsigned int feld_rotr(const unsigned int value, int shift) {
    if ((shift &= sizeof(value)*8 - 1) == 0)
      return value;
    return (value >> shift) | (value << (sizeof(value)*8 - shift));
} |]

compComplexLit :: (Eq a, Num a, ToExp a) => Complex a -> C.Exp
compComplexLit (r :+ 0) = [cexp| $r |]
compComplexLit (0 :+ i) = [cexp| $i * I |]
compComplexLit (r :+ i) = [cexp| $r + $i * I |]

compAbs
  :: MonadC m
  => SoftwarePrimTypeRep a
  -> ASTF SoftwarePrimDomain a
  -> m C.Exp
compAbs t a
 | boolType t    = error "compAbs: type BoolT not supported"
 | integerType t = addInclude "<stdlib.h>" >> compFun "abs" (a :* Nil)
 | wordType t    = compPrim $ Prim a
 | otherwise     = addInclude "<tgmath.h>" >> compFun "fabs" (a :* Nil)

compSign
  :: MonadC m
  => SoftwarePrimTypeRep a
  -> ASTF SoftwarePrimDomain a
  -> m C.Exp
compSign t a | boolType t = do
  error "compSign: type BoolST not supported"
compSign t a | integerType t = do
  addTagMacro
  a' <- compPrim $ Prim a
  return [cexp| TAG("signum", ($a' > 0) - ($a' < 0)) |]
compSign t a | wordType t = do
  addTagMacro
  a' <- compPrim $ Prim a
  return [cexp| TAG("signum", $a' > 0) |]
compSign FloatST a = do
  addTagMacro
  a' <- compPrim $ Prim a
  return [cexp| TAG("signum", (float) (($a' > 0) - ($a' < 0))) |]
compSign DoubleST a = do
  addTagMacro
  a' <- compPrim $ Prim a
  return [cexp| TAG("signum", (double) (($a' > 0) - ($a' < 0))) |]
compSign ComplexFloatST a = do
  addInclude "<complex.h>"
  addGlobal complexSignf_def
  a' <- compPrim $ Prim a
  return [cexp| feld_complexSignf($a') |]
compSign ComplexDoubleST a = do
  addInclude "<tgmath.h>"
  addGlobal complexSign_def
  a' <- compPrim $ Prim a
  return [cexp| feld_complexSign($a') |]
  -- todo: The floating point cases give `sign (-0.0) = 0.0`, which is (slightly)
  -- wrong. They should return -0.0. I don't know whether it's correct for other
  -- strange values.

complexSignf_def = [cedecl|
float _Complex feld_complexSignf(float _Complex c) {
    float z = cabsf(c);
    if (z == 0)
      return 0;
    else
      return (crealf(c)/z + I*(cimagf(c)/z));
} |]

complexSign_def = [cedecl|
double _Complex feld_complexSign(double _Complex c) {
    double z = cabs(c);
    if (z == 0)
      return 0;
    else
      return (creal(c)/z + I*(cimag(c)/z));
} |]

compDiv
  :: MonadC m
  => SoftwarePrimTypeRep a
  -> ASTF SoftwarePrimDomain a
  -> ASTF SoftwarePrimDomain b
  -> m C.Exp
compDiv Int64ST a b = do
  addGlobal ldiv_def
  compFun "feld_ldiv" (a :* b :* Nil)
compDiv t a b | integerType t = do
  addGlobal div_def
  compFun "feld_div" (a :* b :* Nil)
compDiv t a b | wordType t = compBinOp C.Div a b
compDiv t a b = error $ "compDiv: type " ++ show t ++ " not supported"

ldiv_def = [cedecl|
long int feld_ldiv(long int x, long int y) {
    int q = x/y;
    int r = x%y;
    if ((r!=0) && ((r<0) != (y<0))) --q;
    return q;
} |]

div_def = [cedecl|
int feld_div(int x, int y) {
    int q = x/y;
    int r = x%y;
    if ((r!=0) && ((r<0) != (y<0))) --q;
    return q;
} |]

compMod
  :: MonadC m
  => SoftwarePrimTypeRep a
  -> ASTF SoftwarePrimDomain a
  -> ASTF SoftwarePrimDomain b
  -> m C.Exp
compMod Int64ST a b = do
  addGlobal lmod_def
  compFun "feld_lmod" (a :* b :* Nil)
compMod t a b | integerType t = do
  addGlobal div_def
  compFun "feld_mod" (a :* b :* Nil)
compMod t a b | wordType t = compBinOp C.Mod a b
compMod t a b = error $ "compMod: type " ++ show t ++ " not supported"

lmod_def = [cedecl|
long int feld_lmod(long int x, long int y) {
    int r = x%y;
    if ((r!=0) && ((r<0) != (y<0))) { r += y; }
    return r;
} |]

mod_def = [cedecl|
int feld_mod(int x, int y) {
    int r = x%y;
    if ((r!=0) && ((r<0) != (y<0))) { r += y; }
    return r;
} |]

compRound :: (SoftwarePrimType a, Num a, RealFrac b, MonadC m)
  => SoftwarePrimTypeRep a
  -> ASTF SoftwarePrimDomain b
  -> m C.Exp
compRound t a | integerType t || wordType t = do
  addInclude "<tgmath.h>"
  p <- compFun "lround" (a :* Nil)
  compCastExp t p
compRound t a | floatingType t || complexType t = do
  addInclude "<tgmath.h>"
  p <- compFun "round"  (a :* Nil)
  compCastExp t p
compRound t a = do
  error $ "compSign: type " ++ show t ++ " not supported"

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

compPrim :: MonadC m => Prim a -> m C.Exp
compPrim = simpleMatch (\(s :&: t) -> go t s) . unPrim
  where
    go :: forall m sig
       .  MonadC m
       => SoftwarePrimTypeRep (DenResult sig)
       -> SoftwarePrimConstructs sig
       -> Args (AST SoftwarePrimDomain) sig
       -> m C.Exp
    go _ (FreeVar v) Nil = touchVar v >> return [cexp| $id:v |]
    go t (Lit a)     Nil | Dict <- softwarePrimWitType t
                         = compLit (Proxy :: Proxy SoftwarePrimType) a

    go _ Neg  (a :* Nil)      = compUnOp  C.Negate a
    go _ Add  (a :* b :* Nil) = compBinOp C.Add a b
    go _ Sub  (a :* b :* Nil) = compBinOp C.Sub a b
    go _ Mul  (a :* b :* Nil) = compBinOp C.Mul a b
    go t Div  (a :* b :* Nil) = compDiv t a b
    go _ Quot (a :* b :* Nil) = compBinOp C.Div a b
    go _ Rem  (a :* b :* Nil) = compBinOp C.Mod a b
    go t Mod  (a :* b :* Nil) = compMod t a b
    go t Abs  (a :* Nil)      = compAbs t a
    go t Sign (a :* Nil)      = compSign t a
    go _ FDiv (a :* b :* Nil) = compBinOp C.Div a b

    go _ Exp   args = addInclude "<tgmath.h>" >> compFun "exp" args
    go _ Log   args = addInclude "<tgmath.h>" >> compFun "log" args
    go _ Sqrt  args = addInclude "<tgmath.h>" >> compFun "sqrt" args
    go _ Pow   args = addInclude "<tgmath.h>" >> compFun "pow" args

    go _ Sin   args = addInclude "<tgmath.h>" >> compFun "sin" args
    go _ Cos   args = addInclude "<tgmath.h>" >> compFun "cos" args
    go _ Tan   args = addInclude "<tgmath.h>" >> compFun "tan" args
    go _ Asin  args = addInclude "<tgmath.h>" >> compFun "asin" args
    go _ Acos  args = addInclude "<tgmath.h>" >> compFun "acos" args
    go _ Atan  args = addInclude "<tgmath.h>" >> compFun "atan" args
    go _ Sinh  args = addInclude "<tgmath.h>" >> compFun "sinh" args
    go _ Cosh  args = addInclude "<tgmath.h>" >> compFun "cosh" args
    go _ Tanh  args = addInclude "<tgmath.h>" >> compFun "tanh" args
    go _ Asinh args = addInclude "<tgmath.h>" >> compFun "asinh" args
    go _ Acosh args = addInclude "<tgmath.h>" >> compFun "acosh" args
    go _ Atanh args = addInclude "<tgmath.h>" >> compFun "atanh" args

    go t I2N   (a :* Nil) = compCast t a
    go t I2B   (a :* Nil) = compCast t a
    go t B2I   (a :* Nil) = compCast t a
    go t Round (a :* Nil) = compRound t a

    go _ Complex (a :* b :* Nil) = do
        addInclude "<tgmath.h>"
        a' <- compPrim $ Prim a
        b' <- compPrim $ Prim b
        return $ case (viewLitPrim a, viewLitPrim b) of
          (Just 0, _) -> [cexp| I*$b'       |]
          (_, Just 0) -> [cexp| $a'         |]
          _           -> [cexp| $a' + I*$b' |]

    go _ Polar (m :* p :* Nil)
        | Just 0 <- viewLitPrim m = do
            return [cexp| 0 |]
        | Just 0 <- viewLitPrim p = do
            m' <- compPrim $ Prim m
            return [cexp| $m' |]
        | Just 1 <- viewLitPrim m = do
            p' <- compPrim $ Prim p
            return [cexp| exp(I*$p') |]
        | otherwise = do
            m' <- compPrim $ Prim m
            p' <- compPrim $ Prim p
            return [cexp| $m' * exp(I*$p') |]

    go _ Real      args = addInclude "<tgmath.h>" >> compFun "creal" args
    go _ Imag      args = addInclude "<tgmath.h>" >> compFun "cimag" args
    go _ Magnitude args = addInclude "<tgmath.h>" >> compFun "cabs"  args
    go _ Phase     args = addInclude "<tgmath.h>" >> compFun "carg"  args
    go _ Conjugate args = addInclude "<tgmath.h>" >> compFun "conj"  args

    go _ Not (a :* Nil)      = compUnOp  C.Lnot a
    go _ And (a :* b :* Nil) = compBinOp C.Land a b
    go _ Or  (a :* b :* Nil) = compBinOp C.Lor  a b
    go _ Eq  (a :* b :* Nil) = compBinOp C.Eq   a b
    go _ Neq (a :* b :* Nil) = compBinOp C.Ne   a b
    go _ Lt  (a :* b :* Nil) = compBinOp C.Lt   a b
    go _ Lte (a :* b :* Nil) = compBinOp C.Le   a b
    go _ Gt  (a :* b :* Nil) = compBinOp C.Gt   a b
    go _ Gte (a :* b :* Nil) = compBinOp C.Ge   a b

    go _ Pi Nil = addGlobal pi_def >> return [cexp| FELD_PI |]
      where pi_def = [cedecl|$esc:("#define FELD_PI 3.141592653589793")|]

    go _ BitAnd   (a :* b :* Nil) = compBinOp C.And a b
    go _ BitOr    (a :* b :* Nil) = compBinOp C.Or  a b
    go _ BitXor   (a :* b :* Nil) = compBinOp C.Xor a b
    go _ BitCompl (a :* Nil)      = compUnOp  C.Not a
    go _ ShiftL   (a :* b :* Nil) = compBinOp C.Lsh a b
    go _ ShiftR   (a :* b :* Nil) = compBinOp C.Rsh a b

    go _ RotateL  (a :* b :* Nil) = do
      addGlobal compRotateL_def
      a' <- compPrim $ Prim a
      b' <- compPrim $ Prim b
      return [cexp| feld_rotl($a', $b') |]
    go _ RotateR  (a :* b :* Nil) = do
      addGlobal compRotateR_def
      a' <- compPrim $ Prim a
      b' <- compPrim $ Prim b
      return [cexp| feld_rotr($a', $b') |]

    go _ (ArrIx arr) (i :* Nil) = do
      i' <- compPrim $ Prim i
      touchVar arr
      return [cexp| $id:arr[$i'] |]

    go _ Cond (c :* t :* f :* Nil) = do
      c' <- compPrim $ Prim c
      t' <- compPrim $ Prim t
      f' <- compPrim $ Prim f
      return $ C.Cond c' t' f' mempty

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

addTagMacro :: MonadC m => m ()
addTagMacro = addGlobal [cedecl| $esc:("#define TAG(tag,exp) (exp)") |]

boolType :: SoftwarePrimTypeRep a -> Bool
boolType BoolST     = True
boolType _          = False

integerType :: SoftwarePrimTypeRep a -> Bool
integerType Int8ST  = True
integerType Int16ST = True
integerType Int32ST = True
integerType Int64ST = True
integerType _       = False

wordType :: SoftwarePrimTypeRep a -> Bool
wordType Word8ST    = True
wordType Word16ST   = True
wordType Word32ST   = True
wordType Word64ST   = True
wordType _          = False

floatingType :: SoftwarePrimTypeRep a -> Bool
floatingType FloatST  = True
floatingType DoubleST = True
floatingType _        = False

complexType :: SoftwarePrimTypeRep a -> Bool
complexType ComplexFloatST  = True
complexType ComplexDoubleST = True
complexType _               = False

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


{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# language TemplateHaskell #-}
{-# language DataKinds #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Generics.Linear.Instances.Base (
  -- Instances only
  ) where

import Control.Applicative
import Data.Complex (Complex)
import Data.Functor.Identity (Identity)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Semigroup as S
import qualified Data.Monoid as M
import Data.Proxy (Proxy)
import Data.Version (Version)
import System.Exit (ExitCode)
import Data.Ord (Down)
import Control.Arrow (Kleisli)
import qualified GHC.Generics as GHCG
import qualified Data.Functor.Sum as FSum
import qualified Data.Functor.Product as FProd
import Data.Functor.Compose
import Foreign.Ptr (Ptr)
import Generics.Linear.TH
import GHC.Tuple (Solo)
import Data.Void (Void)

-- GHC.Tuple
$(deriveGenericAnd1 ''Solo)
$(deriveGenericAnd1 ''(,))
$(deriveGenericAnd1 ''(,,))
$(deriveGenericAnd1 ''(,,,))
$(deriveGenericAnd1 ''(,,,,))
$(deriveGenericAnd1 ''(,,,,,))
$(deriveGenericAnd1 ''(,,,,,,))
$(deriveGenericAnd1 ''(,,,,,,,))
$(deriveGenericAnd1 ''(,,,,,,,,))
$(deriveGenericAnd1 ''(,,,,,,,,,))
$(deriveGenericAnd1 ''(,,,,,,,,,,))
$(deriveGenericAnd1 ''(,,,,,,,,,,,))
$(deriveGenericAnd1 ''(,,,,,,,,,,,,))
$(deriveGenericAnd1 ''(,,,,,,,,,,,,,))
$(deriveGenericAnd1 ''(,,,,,,,,,,,,,,))

-- Data.Functor.Compose
$(deriveGeneric1 ''Compose)

-- Data.Functor.Identity
$(deriveGenericAnd1 ''Identity)

-- Control.Category
$(deriveGenericAnd1 ''Kleisli)

-- Data.Ord
$(deriveGenericAnd1 ''Down)
$(deriveGeneric ''Ordering)

-- System.Exit
$(deriveGeneric ''ExitCode)

-- Data.Version
$(deriveGeneric ''Version)

-- GHC.Generics
$(deriveGenericAnd1 ''(GHCG.:+:))
$(deriveGenericAnd1 ''(GHCG.:*:))
$(deriveGenericAnd1 ''GHCG.K1)
$(deriveGenericAnd1 ''GHCG.M1)
$(deriveGenericAnd1 ''GHCG.Par1)
$(deriveGenericAnd1 ''GHCG.U1)
$(deriveGenericAnd1 ''GHCG.V1)
$(deriveGenericAnd1 ''(GHCG.:.:))
$(deriveGenericAnd1 ''GHCG.Rec1)
$(deriveGeneric ''GHCG.Fixity)
$(deriveGeneric ''GHCG.Associativity)
$(deriveGeneric ''GHCG.DecidedStrictness)
$(deriveGeneric ''GHCG.SourceStrictness)
$(deriveGeneric ''GHCG.SourceUnpackedness)

--   These ones use data constructor names
$(deriveGenericAnd1 'GHCG.UAddr)
$(deriveGenericAnd1 'GHCG.UChar)
$(deriveGenericAnd1 'GHCG.UDouble)
$(deriveGenericAnd1 'GHCG.UFloat)
$(deriveGenericAnd1 'GHCG.UInt)
$(deriveGenericAnd1 'GHCG.UWord)

-- Data.Complex
$(deriveGenericAnd1 ''Complex)

-- Data.Proxy
$(deriveGenericAnd1 ''Proxy)

-- Data.Semigroup
$(deriveGeneric ''S.All)
$(deriveGeneric ''S.Any)

$(deriveGenericAnd1 ''S.Min)
$(deriveGenericAnd1 ''S.Max)
$(deriveGenericAnd1 ''S.Arg)
$(deriveGenericAnd1 ''S.Dual)
$(deriveGeneric ''S.Endo)
$(deriveGenericAnd1 ''S.First)
$(deriveGenericAnd1 ''S.Last)
$(deriveGenericAnd1 ''S.Product)
$(deriveGenericAnd1 ''S.Sum)
$(deriveGenericAnd1 ''S.WrappedMonoid)

-- Data.Monoid
$(deriveGenericAnd1 ''M.Alt)
$(deriveGenericAnd1 ''M.Ap)
$(deriveGenericAnd1 ''M.First)
$(deriveGenericAnd1 ''M.Last)

-- Control.Applicative

$(deriveGenericAnd1 ''WrappedArrow)

$(deriveGenericAnd1 ''WrappedMonad)

$(deriveGenericAnd1 ''ZipList)

$(deriveGenericAnd1 ''Const)

-- Prelude
$(deriveGenericAnd1 ''[])
$(deriveGenericAnd1 ''Either)
$(deriveGenericAnd1 ''Maybe)
$(deriveGeneric ''Bool)
$(deriveGeneric ''())
$(deriveGeneric ''Char)
$(deriveGeneric ''Double)
$(deriveGeneric ''Int)
$(deriveGeneric ''Float)
$(deriveGeneric ''Word)

-- Data.List.NonEmpty
$(deriveGenericAnd1 ''NonEmpty)

-- Data.Functor.Sum
$(deriveGenericAnd1 ''FSum.Sum)

-- Data.Functor.Product
$(deriveGenericAnd1 ''FProd.Product)

-- Data.Void
$(deriveGeneric ''Void)

-- Foreign.Ptr
$(deriveGeneric ''Ptr)


{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{- |
Module      : Language.Scheme.Parser
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

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

This module implements parsing of Scheme code.
-}

module Language.Scheme.Parser
    (
      lispDef
    -- *Higher level parsing
    , mainParser
    , readOrThrow
    , readExpr
    , readExprList
    -- *Low level parsing
    , parseExpr
    , parseAtom
    , parseBool
    , parseChar
    , parseOctalNumber
    , parseBinaryNumber
    , parseHexNumber
    , parseDecimalNumber
    , parseNumber
    , parseRealNumber
    , parseRationalNumber
    , parseComplexNumber
    , parseEscapedChar
    , parseString
    , parseVector
    , parseByteVector
    , parseHashTable
    , parseList
    , parseDottedList
    , parseQuoted
    , parseQuasiQuoted
    , parseUnquoted
    , parseUnquoteSpliced
    ) where
import Language.Scheme.Types
import Control.Monad.Except
import Control.Monad.Fail
import Data.Array
import qualified Data.ByteString as BS
import qualified Data.Char as DC
import Data.Complex
import qualified Data.Map
import Data.Ratio
import Data.Word
import Numeric
import Text.ParserCombinators.Parsec hiding (spaces)
import Text.Parsec.Language
import qualified Text.Parsec.Token as P
#if __GLASGOW_HASKELL__ >= 702
import Data.Functor.Identity (Identity)
import Text.Parsec.Prim (ParsecT)
#endif

-- This was added by pull request #63 as part of a series of fixes
-- to get husk to build on ghc 7.2.2
--
-- For now this has been removed to allow husk to support the older
-- GHC 6.x.x series.
--
--import Data.Functor.Identity (Identity)

-- |Language definition for Scheme
lispDef :: LanguageDef ()
lispDef
  = emptyDef
  { P.commentStart   = "#|"
  , P.commentEnd     = "|#"
  , P.commentLine    = ";"
  , P.nestedComments = True
  , P.identStart     = letter <|> symbol
  , P.identLetter    = letter <|> digit <|> symbol
  , P.reservedNames  = []
  , P.caseSensitive  = True
  }

#if __GLASGOW_HASKELL__ >= 702
lexer :: P.GenTokenParser String () Data.Functor.Identity.Identity
#endif
lexer = P.makeTokenParser lispDef

#if __GLASGOW_HASKELL__ >= 702
dot :: ParsecT String () Identity String
#endif
dot = P.dot lexer

#if __GLASGOW_HASKELL__ >= 702
parens :: ParsecT String () Identity a -> ParsecT String () Identity a
#endif
parens = P.parens lexer

#if __GLASGOW_HASKELL__ >= 702
brackets :: ParsecT String () Identity a -> ParsecT String () Identity a
#endif
brackets = P.brackets lexer

#if __GLASGOW_HASKELL__ >= 702
identifier :: ParsecT String () Identity String
#endif
identifier = P.identifier lexer

#if __GLASGOW_HASKELL__ >= 702
whiteSpace :: ParsecT String () Identity ()
#endif
whiteSpace = P.whiteSpace lexer

#if __GLASGOW_HASKELL__ >= 702
lexeme :: ParsecT String () Identity a -> ParsecT String () Identity a
#endif
lexeme = P.lexeme lexer

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

-- |Parse an atom (scheme symbol)
parseAtom :: Parser LispVal
parseAtom = do
  atom <- identifier
  if atom == "."
     then pzero -- Do not match this form
     else return $ Atom atom

-- |Parse a boolean
parseBool :: Parser LispVal
parseBool = do _ <- string "#"
               x <- oneOf "tf"
               return $ case x of
                          't' -> Bool True
                          'f' -> Bool False
                          _ -> Bool False

-- |Parse a character
parseChar :: Parser LispVal
parseChar = do
  _ <- try (string "#\\")
  c <- anyChar
  r <- many (letter <|> digit)
  let pchr = c : r
  case pchr of
    "space"     -> return $ Char ' '
    "newline"   -> return $ Char '\n'
    "alarm"     -> return $ Char '\a'
    "backspace" -> return $ Char '\b'
    "delete"    -> return $ Char '\DEL'
    "escape"    -> return $ Char '\ESC'
    "null"      -> return $ Char '\0'
    "return"    -> return $ Char '\n'
    "tab"       -> return $ Char '\t'
    _ -> case (c : r) of
        [ch] -> return $ Char ch
        ('x' : hexs) -> do
            rv <- parseHexScalar hexs
            return $ Char rv
        _ -> pzero

-- |Parse an integer in octal notation, base 8
parseOctalNumber :: Parser LispVal
parseOctalNumber = do
  _ <- try (string "#o")
  sign <- many (oneOf "-")
  num <- many1 (oneOf "01234567")
  case (length sign) of
     0 -> return $ Number $ fst $ head (Numeric.readOct num)
     1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ head (Numeric.readOct num)
     _ -> pzero

-- |Parse an integer in binary notation, base 2
parseBinaryNumber :: Parser LispVal
parseBinaryNumber = do
  _ <- try (string "#b")
  sign <- many (oneOf "-")
  num <- many1 (oneOf "01")
  case (length sign) of
     0 -> return $ Number $ fst $ head (Numeric.readInt 2 (`elem` "01") DC.digitToInt num)
     1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ head (Numeric.readInt 2 (`elem` "01") DC.digitToInt num)
     _ -> pzero

-- |Parse an integer in hexadecimal notation, base 16
parseHexNumber :: Parser LispVal
parseHexNumber = do
  _ <- try (string "#x")
  sign <- many (oneOf "-")
  num <- many1 (digit <|> oneOf "abcdefABCDEF")
  case (length sign) of
     0 -> return $ Number $ fst $ head (Numeric.readHex num)
     1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ head (Numeric.readHex num)
     _ -> pzero

-- |Parser for Integer, base 10
parseDecimalNumber :: Parser LispVal
parseDecimalNumber = do
  _ <- try (many (string "#d"))
  sign <- many (oneOf "-")
  num <- many1 digit
  if (length sign) > 1
     then pzero
     else return $ (Number . read) $ sign ++ num

-- |Parser for a base 10 Integer that will also
--  check to see if the number is followed by
--  an exponent (scientific notation). If so,
--  the integer is converted to a float of the
--  given magnitude.
parseDecimalNumberMaybeExponent :: Parser LispVal
parseDecimalNumberMaybeExponent = do
  num <- parseDecimalNumber
  parseNumberExponent num

-- |Parse an integer in any base
parseNumber :: Parser LispVal
parseNumber = parseDecimalNumberMaybeExponent <|>
              parseHexNumber <|>
              parseBinaryNumber <|>
              parseOctalNumber <?>
              "Unable to parse number"

-- |Parse a floating point number
parseRealNumber :: Parser LispVal
parseRealNumber = do
  sign <- many (oneOf "-+")
  num <- many digit
  _ <- char '.'
  frac <- many1 digit
  let dec = if not (null num)
               then num ++ "." ++ frac
               else "0." ++ frac
  f <- case (length sign) of
     0 -> return $ Float $ fst $ head (Numeric.readFloat dec)
          -- Bit of a hack, but need to support the + sign as well as the minus.
     1 -> if sign == "-"
             then return $ Float $ (*) (-1.0) $ fst $ head (Numeric.readFloat dec)
             else return $ Float $ fst $ head (Numeric.readFloat dec)
     _ -> pzero
  parseNumberExponent f

-- | Parse the exponent section of a floating point number
--   in scientific notation. Eg "e10" from "1.0e10"
parseNumberExponent :: LispVal -> Parser LispVal
parseNumberExponent n = do
  expnt <- many $ oneOf "Ee"
  case (length expnt) of
    0 -> return n
    1 -> do
      num <- try parseDecimalNumber
      case num of
        Number nexp -> buildResult n nexp
        _ -> pzero
    _ -> pzero
 where
  buildResult (Number num) nexp = return $ Float $ (fromIntegral num) * (10 ** (fromIntegral nexp))
  buildResult (Float num) nexp = return $ Float $ num * (10 ** (fromIntegral nexp))
  buildResult _ _ = pzero

-- |Parse a rational number
parseRationalNumber :: Parser LispVal
parseRationalNumber = do
  pnumerator <- parseDecimalNumber
  case pnumerator of
    Number n -> do
      _ <- char '/'
      sign <- many (oneOf "-")
      num <- many1 digit
      if (length sign) > 1
         then pzero
         else do
             let pdenominator = read $ sign ++ num
             if pdenominator == 0
                then return $ Number 0 -- TODO: Prevents a div-by-zero error, but not really correct either
                else return $ Rational $ n % pdenominator
    _ -> pzero

-- |Parse a complex number
parseComplexNumber :: Parser LispVal
parseComplexNumber = do
  lispreal <- (try parseRealNumber <|> try parseRationalNumber <|> parseDecimalNumber)
  let real = case lispreal of
                  Number n -> fromInteger n
                  Rational r -> fromRational r
                  Float f -> f
                  _ -> 0
  _ <- char '+'
  lispimag <- (try parseRealNumber <|> try parseRationalNumber <|> parseDecimalNumber)
  let imag = case lispimag of
                  Number n -> fromInteger n
                  Rational r -> fromRational r
                  Float f -> f
                  _ -> 0 -- Case should never be reached
  _ <- char 'i'
  return $ Complex $ real :+ imag

-- |Parse an escaped character
parseEscapedChar :: forall st .
                    GenParser Char st Char
parseEscapedChar = do
  _ <- char '\\'
  c <- anyChar
  case c of
    'a' -> return '\a'
    'b' -> return '\b'
    'n' -> return '\n'
    't' -> return '\t'
    'r' -> return '\r'
    'x' -> do
        num <- many $ letter <|> digit
        _ <- char ';'
        parseHexScalar num
    _ -> return c

-- |Parse a hexidecimal scalar
parseHexScalar :: MonadFail m => String -> m Char
parseHexScalar num = do
    let ns = Numeric.readHex num
    case ns of
        [] -> fail $ "Unable to parse hex value " ++ show num
        _ -> return $ DC.chr $ fst $ head ns

-- |Parse a string
parseString :: Parser LispVal
parseString = do
  _ <- char '"'
  x <- many (parseEscapedChar <|> noneOf "\"")
  _ <- char '"'
  return $ String x

-- |Parse a vector
parseVector :: Parser LispVal
parseVector = do
  vals <- sepBy parseExpr whiteSpace
  return $ Vector (listArray (0, (length vals - 1)) vals)

-- |Parse a bytevector
parseByteVector :: Parser LispVal
parseByteVector = do
  ns <- sepBy parseNumber whiteSpace
  return $ ByteVector $ BS.pack $ map conv ns
 where
   conv (Number n) = fromInteger n :: Word8
   conv _ = 0 :: Word8

-- |Parse a hash table. The table is either empty or is made up of
--  an alist (associative list)
parseHashTable :: Parser LispVal
parseHashTable = do
  -- This function uses explicit recursion to loop over the parsed list:
  -- As long as it is an alist, the members are appended to an accumulator
  -- so they can be added to the hash table. However, if the input list is
  -- determined not to be an alist, Nothing is returned, letting the parser
  -- know that a valid hashtable was not read.
  let f :: [(LispVal, LispVal)] -> [LispVal] -> Maybe [(LispVal, LispVal)]
      f acc [] = Just acc
      f acc (List [a, b] :ls) = f (acc ++ [(a, b)]) ls
      f acc (DottedList [a] b :ls) = f (acc ++ [(a, b)]) ls
      f _ (_:_) = Nothing
  vals <- sepBy parseExpr whiteSpace
  let mvals = f [] vals
  case mvals of
    Just m -> return $ HashTable $ Data.Map.fromList m
    Nothing -> pzero

-- |Parse a list
parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr whiteSpace
-- TODO: wanted to use endBy (or a variant) above, but it causes an error such that dotted lists are not parsed

-- |Parse a dotted list (scheme pair)
parseDottedList :: Parser LispVal
parseDottedList = do
  phead <- endBy parseExpr whiteSpace
  case phead of
    [] -> pzero -- car is required; no match
    _ -> do
      ptail <- dot >> parseExpr
      case ptail of
        DottedList ls l -> return $ DottedList (phead ++ ls) l
        -- Issue #41
        -- Improper lists are tricky because if an improper list ends in a
        -- proper list, then it becomes proper as well. The following cases
        -- handle that, as well as preserving necessary functionality when
        -- appropriate, such as for unquoting.
        --
        -- FUTURE: I am not sure if this is complete, in fact the "unquote"
        -- seems like it could either be incorrect or one special case among
        -- others. Anyway, for the 3.3 release this is good enough to pass all
        -- test cases. It will be revisited later if necessary.
        --
        List (Atom "unquote" : _) -> return $ DottedList phead ptail
        List ls -> return $ List $ phead ++ ls
        {- Regarding above, see
           http://community.schemewiki.org/?scheme-faq-language#dottedapp

           Note, however, that most Schemes expand literal lists occurring in
           function applications, e.g. (foo bar . (1 2 3)) is expanded into
           (foo bar 1 2 3) by the reader. It is not entirely clear whether this
           is a consequence of the standard - the notation is not part of the
           R5RS grammar but there is strong evidence to suggest a Scheme
           implementation cannot comply with all of R5RS without performing this
           transformation. -}
        _ -> return $ DottedList phead ptail

-- |Parse a quoted expression
parseQuoted :: Parser LispVal
parseQuoted = do
  _ <- lexeme $ char '\''
  x <- parseExpr
  return $ List [Atom "quote", x]

-- |Parse a quasi-quoted expression
parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted = do
  _ <- lexeme $ char '`'
  x <- parseExpr
  return $ List [Atom "quasiquote", x]

-- |Parse an unquoted expression (a quasiquotated expression preceded
--  by a comma)
parseUnquoted :: Parser LispVal
parseUnquoted = do
  _ <- try (lexeme $ char ',')
  x <- parseExpr
  return $ List [Atom "unquote", x]

-- |Parse an unquote-spliced expression
parseUnquoteSpliced :: Parser LispVal
parseUnquoteSpliced = do
  _ <- try (lexeme $ string ",@")
  x <- parseExpr
  return $ List [Atom "unquote-splicing", x]

-- FUTURE: should be able to use the grammar from R5RS
-- to make parsing more efficient (mostly by minimizing
-- or eliminating the number of try's below)

-- |Parse an expression
parseExpr :: Parser LispVal
parseExpr =
      try (lexeme parseComplexNumber)
  <|> try (lexeme parseRationalNumber)
  <|> try (lexeme parseRealNumber)
  <|> try (lexeme parseNumber)
  <|> lexeme parseChar
  <|> parseUnquoteSpliced
  <|> do _ <- try (lexeme $ string "#(")
         x <- parseVector
         _ <- lexeme $ char ')'
         return x
  <|> do _ <- try (lexeme $ string "#u8(")
         x <- parseByteVector
         _ <- lexeme $ char ')'
         return x
--  <|> do _ <- try (lexeme $ string "#hash(")
--         x <- parseHashTable
--         _ <- lexeme $ char ')'
--         return x
  <|> try parseAtom
  <|> lexeme parseString
  <|> lexeme parseBool
  <|> parseQuoted
  <|> parseQuasiQuoted
  <|> parseUnquoted
  <|> try (parens parseList)
  <|> parens parseDottedList
  <|> try (brackets parseList)
  <|> brackets parseDottedList
  <?> "Expression"

-- |Initial parser used by the high-level parse functions
mainParser :: Parser LispVal
mainParser = do
    _ <- whiteSpace
    parseExpr

-- |Use a parser to parse the given text, throwing an error
--  if there is a problem parsing the text.
readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
  Left err -> throwError $ Parser err
  Right val -> return val

-- |Parse an expression from a string of text
readExpr :: String -> ThrowsError LispVal
readExpr = readOrThrow mainParser

-- |Parse many expressions from a string of text
readExprList :: String -> ThrowsError [LispVal]
readExprList = readOrThrow (endBy mainParser whiteSpace)


{-# LANGUAGE CPP #-}
-- |
-- Module      : Test.LeanCheck.Basic
-- Copyright   : (c) 2015-2020 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- This module is part of LeanCheck,
-- a simple enumerative property-based testing library.
--
-- This module exports "Test.LeanCheck.Core" along with:
--
--   * support for 'Listable' 6-tuples up to 12-tuples;
--   * 'tiers' constructors (@consN@) with arities from 6 up to 12;
--   * a 'Listable' 'Word' instance;
--   * a 'Listable' 'Ratio' instance (consequently 'Listable' 'Rational');
--   * a 'Listable' 'Complex' instance;
--   * 'Listable' 'Int8/16/32/64' instances;
--   * 'Listable' 'Word8/16/32/64' instances;
--   * 'Listable' instances for "Foreign.C" types;
--   * a 'Listable' 'ExitCode' instance;
--   * a 'Listable' 'GeneralCategory' instance;
--   * 'Listable' 'Buffer/IO/SeekMode' instances;
--   * the operators 'addWeight' and 'ofWeight'.
--
-- The above includes all types defined in the Haskell 2010 Report
-- with the exception of Array, IO, Handle, HandlePosn, IOErrorType.
--
-- "Test.LeanCheck" already exports everything from this module.
-- You are probably better off importing it.
--
-- You should /only/ import "Test.LeanCheck.Basic"
-- if you /only/ want the above basic functionality.
module Test.LeanCheck.Basic
  ( module Test.LeanCheck.Core

  , cons6
  , cons7
  , cons8
  , cons9
  , cons10
  , cons11
  , cons12

  , ofWeight
  , addWeight
  )
where

import Test.LeanCheck.Core
import Data.Ratio
import Data.Complex
import Data.Int
import Data.Word
import Data.Char (GeneralCategory)
import System.IO (IOMode (..), BufferMode (..), SeekMode (..))
import Foreign.C
import System.Exit

instance (Listable a, Listable b, Listable c,
          Listable d, Listable e, Listable f) =>
         Listable (a,b,c,d,e,f) where
  tiers  =  productWith (\x (y,z,w,v,u) -> (x,y,z,w,v,u)) tiers tiers

instance (Listable a, Listable b, Listable c, Listable d,
          Listable e, Listable f, Listable g) =>
         Listable (a,b,c,d,e,f,g) where
  tiers  =  productWith (\x (y,z,w,v,u,r) -> (x,y,z,w,v,u,r)) tiers tiers

instance (Listable a, Listable b, Listable c, Listable d,
          Listable e, Listable f, Listable g, Listable h) =>
         Listable (a,b,c,d,e,f,g,h) where
  tiers  =  productWith (\x (y,z,w,v,u,r,s) -> (x,y,z,w,v,u,r,s)) tiers tiers

instance (Listable a, Listable b, Listable c, Listable d, Listable e,
          Listable f, Listable g, Listable h, Listable i) =>
         Listable (a,b,c,d,e,f,g,h,i) where
  tiers  =  productWith (\x (y,z,w,v,u,r,s,t) -> (x,y,z,w,v,u,r,s,t))
                        tiers tiers

instance (Listable a, Listable b, Listable c, Listable d, Listable e,
          Listable f, Listable g, Listable h, Listable i, Listable j) =>
         Listable (a,b,c,d,e,f,g,h,i,j) where
  tiers  =  productWith (\x (y,z,w,v,u,r,s,t,o) -> (x,y,z,w,v,u,r,s,t,o))
                        tiers tiers

instance (Listable a, Listable b, Listable c, Listable d,
          Listable e, Listable f, Listable g, Listable h,
          Listable i, Listable j, Listable k) =>
         Listable (a,b,c,d,e,f,g,h,i,j,k) where
  tiers  =  productWith (\x (y,z,w,v,u,r,s,t,o,p) -> (x,y,z,w,v,u,r,s,t,o,p))
                        tiers tiers

instance (Listable a, Listable b, Listable c, Listable d,
          Listable e, Listable f, Listable g, Listable h,
          Listable i, Listable j, Listable k, Listable l) =>
         Listable (a,b,c,d,e,f,g,h,i,j,k,l) where
  tiers  =  productWith (\x (y,z,w,v,u,r,s,t,o,p,q) ->
                          (x,y,z,w,v,u,r,s,t,o,p,q))
                        tiers tiers

-- | Returns tiers of applications of a 6-argument constructor.
cons6 :: (Listable a, Listable b, Listable c, Listable d, Listable e, Listable f)
      => (a -> b -> c -> d -> e -> f -> g) -> [[g]]
cons6 f  =  delay $ mapT (uncurry6 f) tiers

-- | Returns tiers of applications of a 7-argument constructor.
cons7 :: (Listable a, Listable b, Listable c, Listable d,
          Listable e, Listable f, Listable g)
      => (a -> b -> c -> d -> e -> f -> g -> h) -> [[h]]
cons7 f  =  delay $ mapT (uncurry7 f) tiers

-- | Returns tiers of applications of a 8-argument constructor.
cons8 :: (Listable a, Listable b, Listable c, Listable d,
          Listable e, Listable f, Listable g, Listable h)
      => (a -> b -> c -> d -> e -> f -> g -> h -> i) -> [[i]]
cons8 f  =  delay $ mapT (uncurry8 f) tiers

-- | Returns tiers of applications of a 9-argument constructor.
cons9 :: (Listable a, Listable b, Listable c, Listable d, Listable e,
          Listable f, Listable g, Listable h, Listable i)
      => (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> [[j]]
cons9 f  =  delay $ mapT (uncurry9 f) tiers

-- | Returns tiers of applications of a 10-argument constructor.
cons10 :: (Listable a, Listable b, Listable c, Listable d, Listable e,
           Listable f, Listable g, Listable h, Listable i, Listable j)
       => (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> [[k]]
cons10 f  =  delay $ mapT (uncurry10 f) tiers

-- | Returns tiers of applications of a 11-argument constructor.
cons11 :: (Listable a, Listable b, Listable c, Listable d,
           Listable e, Listable f, Listable g, Listable h,
           Listable i, Listable j, Listable k)
       => (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l) -> [[l]]
cons11 f  =  delay $ mapT (uncurry11 f) tiers

-- | Returns tiers of applications of a 12-argument constructor.
cons12 :: (Listable a, Listable b, Listable c, Listable d,
           Listable e, Listable f, Listable g, Listable h,
           Listable i, Listable j, Listable k, Listable l)
       => (a->b->c->d->e->f->g->h->i->j->k->l->m) -> [[m]]
cons12 f  =  delay $ mapT (uncurry12 f) tiers

uncurry6 :: (a->b->c->d->e->f->g) -> (a,b,c,d,e,f) -> g
uncurry6 f (x,y,z,w,v,u)  =  f x y z w v u

uncurry7 :: (a->b->c->d->e->f->g->h) -> (a,b,c,d,e,f,g) -> h
uncurry7 f (x,y,z,w,v,u,r)  =  f x y z w v u r

uncurry8 :: (a->b->c->d->e->f->g->h->i) -> (a,b,c,d,e,f,g,h) -> i
uncurry8 f (x,y,z,w,v,u,r,s)  =  f x y z w v u r s

uncurry9 :: (a->b->c->d->e->f->g->h->i->j) -> (a,b,c,d,e,f,g,h,i) -> j
uncurry9 f (x,y,z,w,v,u,r,s,t)  =  f x y z w v u r s t

uncurry10 :: (a->b->c->d->e->f->g->h->i->j->k) -> (a,b,c,d,e,f,g,h,i,j) -> k
uncurry10 f (x,y,z,w,v,u,r,s,t,o)  =  f x y z w v u r s t o

uncurry11 :: (a->b->c->d->e->f->g->h->i->j->k->l)
          -> (a,b,c,d,e,f,g,h,i,j,k) -> l
uncurry11 f (x,y,z,w,v,u,r,s,t,o,p)  =  f x y z w v u r s t o p

uncurry12 :: (a->b->c->d->e->f->g->h->i->j->k->l->m)
          -> (a,b,c,d,e,f,g,h,i,j,k,l) -> m
uncurry12 f (x,y,z,w,v,u,r,s,t,o,p,q)  =  f x y z w v u r s t o p q

-- | > list :: [Rational]  =
--   >   [   0  % 1
--   >   ,   1  % 1
--   >   , (-1) % 1
--   >   ,   1  % 2,   2  % 1
--   >   , (-1) % 2, (-2) % 1
--   >   ,   1  % 3,   3  % 1
--   >   , (-1) % 3, (-3) % 1
--   >   ,   1  % 4,   2  % 3,   3  % 2,   4  % 1
--   >   , (-1) % 4, (-2) % 3, (-3) % 2, (-4) % 1
--   >   ,   1  % 5,   5  % 1
--   >   , (-1) % 5, (-5) % 1
--   >   , ...
--   >   ]
instance (Integral a, Listable a) => Listable (Ratio a) where
  tiers  =  mapT (uncurry (%)) . reset
        $ tiers `suchThat` (\(n,d) -> d > 0 && n `gcd` d == 1)

instance (RealFloat a, Listable a) => Listable (Complex a) where
  tiers  =  cons2 (:+)

-- | > list :: [Word]  =  [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, ...]
instance Listable Word where
  list  =  listIntegral

-- | > list :: [Word8]  =  [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, ..., 255]
instance Listable Word8 where
  list  =  listIntegral

-- | > list :: [Word16]  =  [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, ..., 65535]
instance Listable Word16 where
  list  =  listIntegral

-- | > list :: [Word32]  =  [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, ...]
instance Listable Word32 where
  list  =  listIntegral

-- | > list :: [Word64]  =  [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, ...]
instance Listable Word64 where
  list  =  listIntegral

-- | > list :: [Int8]  =  [0, 1, -1, 2, -2, 3, -3, ..., 127, -127, -128]
instance Listable Int8 where
  list  =  listIntegral

-- | > list :: [Int16]  =  [0, 1, -1, 2, -2, ..., 32767, -32767, -32768]
instance Listable Int16 where
  list  =  listIntegral

-- | > list :: [Int32]  =  [0, 1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, ...]
instance Listable Int32 where
  list  =  listIntegral

-- | > list :: [Int64]  =  [0, 1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, ...]
instance Listable Int64 where
  list  =  listIntegral

instance Listable CChar      where  list  =  listIntegral
instance Listable CSChar     where  list  =  listIntegral
instance Listable CUChar     where  list  =  listIntegral
instance Listable CShort     where  list  =  listIntegral
instance Listable CUShort    where  list  =  listIntegral
instance Listable CInt       where  list  =  listIntegral
instance Listable CUInt      where  list  =  listIntegral
instance Listable CLong      where  list  =  listIntegral
instance Listable CULong     where  list  =  listIntegral
instance Listable CPtrdiff   where  list  =  listIntegral
instance Listable CSize      where  list  =  listIntegral
instance Listable CWchar     where  list  =  listIntegral
instance Listable CSigAtomic where  list  =  listIntegral
instance Listable CLLong     where  list  =  listIntegral
instance Listable CULLong    where  list  =  listIntegral
instance Listable CIntPtr    where  list  =  listIntegral
instance Listable CUIntPtr   where  list  =  listIntegral
instance Listable CIntMax    where  list  =  listIntegral
instance Listable CUIntMax   where  list  =  listIntegral
instance Listable CClock     where  list  =  listIntegral
instance Listable CTime      where  list  =  listIntegral
instance Listable CFloat     where  tiers  =  tiersFloating
instance Listable CDouble    where  tiers  =  tiersFloating
#if __GLASGOW_HASKELL__ >= 802
instance Listable CBool      where  list  =  listIntegral
#endif
#if __GLASGOW_HASKELL__
instance Listable CUSeconds  where  list  =  listIntegral
instance Listable CSUSeconds where  list  =  listIntegral
#endif

-- | Only includes valid POSIX exit codes
--
-- > > list :: [ExitCode]
-- > [ExitSuccess, ExitFailure 1, ExitFailure 2, ..., ExitFailure 255]
instance Listable ExitCode where  list  =  ExitSuccess : map ExitFailure [1..255]

instance Listable GeneralCategory where  list  =  [minBound..maxBound]

instance Listable IOMode where
  tiers  =  cons0 ReadMode
         \/ cons0 WriteMode
         \/ cons0 AppendMode
         \/ cons0 ReadWriteMode

instance Listable BufferMode where
  tiers  =  cons0 NoBuffering
         \/ cons0 LineBuffering
         \/ cons1 BlockBuffering

instance Listable SeekMode where
  tiers  =  cons0 AbsoluteSeek
         \/ cons0 RelativeSeek
         \/ cons0 SeekFromEnd

-- | Resets the weight of a constructor or tiers.
--
-- > > [ [], [], ..., xs, ys, zs, ... ] `ofWeight` 1
-- > [ [], xs, ys, zs, ... ]
--
-- > > [ xs, ys, zs, ... ] `ofWeight` 2
-- > [ [], [], xs, ys, zs, ... ]
--
-- > > [ [], xs, ys, zs, ... ] `ofWeight` 3
-- > [ [], [], [], xs, ys, zs, ... ]
--
-- Typically used as an infix operator when defining 'Listable' instances:
--
-- > instance Listable <Type> where
-- >   tiers  =  ...
-- >          \/ cons<N> <Cons>  `ofWeight`  <W>
-- >          \/ ...
--
-- /Warning:/ do not apply @ \`ofWeight\` 0 @ to recursive data structure
-- constructors.  In general this will make the list of size 0 infinite,
-- breaking the tier invariant (each tier must be finite).
--
-- @ \`ofWeight\` /n/ @ is equivalent to 'reset' followed
-- by @/n/@ applications of 'delay'.
ofWeight :: [[a]] -> Int -> [[a]]
ofWeight xss w  =  dropWhile null xss `addWeight` w

-- | Adds to the weight of a constructor or tiers.
--
-- > instance Listable <Type> where
-- >   tiers  =  ...
-- >          \/ cons<N> <Cons>  `addWeight`  <W>
-- >          \/ ...
--
-- Typically used as an infix operator when defining 'Listable' instances:
--
-- > > [ xs, ys, zs, ... ] `addWeight` 1
-- > [ [], xs, ys, zs, ... ]
--
-- > > [ xs, ys, zs, ... ] `addWeight` 2
-- > [ [], [], xs, ys, zs, ... ]
--
-- > > [ [], xs, ys, zs, ... ] `addWeight` 3
-- > [ [], [], [], [], xs, ys, zs, ... ]
--
-- @ \`addWeight\` /n/ @ is equivalent to @/n/@ applications of 'delay'.
addWeight :: [[a]] -> Int -> [[a]]
addWeight xss w  =  replicate w [] ++ xss


-- Copyright (c) Facebook, Inc. and its affiliates.

{-# LANGUAGE CPP #-}
module UnitTests (main) where

import Test.HUnit
import TestRunner

import Util.ByteString
import Util.Aeson
import qualified Util.Text as UT
import Data.Aeson.Types
import Data.Aeson (decode)
import Data.ByteString (packCString, packCStringLen, ByteString)
import Data.Complex
import qualified Data.Vector as V
import Numeric.FFT.Vector.Unitary as FFTW

import Foreign.Storable
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Array (advancePtr)
import Foreign.Ptr (nullPtr, Ptr)

import TextShow

intToByteStringTest :: Test
intToByteStringTest = TestCase $ do
  assertEqual "min int" (intToByteString minBound) "-9223372036854775808"
  assertEqual "max int" (intToByteString maxBound) "9223372036854775807"
  assertEqual "zero" (intToByteString 0) "0"

parseValueStrictTest :: Test
parseValueStrictTest = TestCase $ do
  assertEqual "false" (Right $ Bool False) $ parseValueStrict' "false"
  assertEqual "0.1" (Right $ Number 0.1) $ parseValueStrict' "0.1"
  assertEqual "consume all input" (Left "endOfInput") $
    parseValueStrict' "falsee"

#ifdef FACEBOOK
-- | We've patched the official aeson library to handle NaN. See #5183005
-- This test ensures that we notice if we forget to patch on upgrade.
parseNaN :: Test
parseNaN = TestCase $
  case decode "[NaN]" of
    Just [a :: Double] ->
      assertBool "NaN" $ isNaN a
    _ -> assertFailure "couldn't parse NaN"
#endif

-- | Check that we can still call vector-fftw after T22849884
useFFTW :: Test
useFFTW = TestCase $
  assertEqual "useFFTW" [17,5,2,1,1,1,1,1,2,5] $
    applyFFT [1..10]
  where
    applyFFT :: [Int] -> [Int]
    applyFFT series =
      map (floor . magnitude)
      . V.toList
      . FFTW.execute (FFTW.plan FFTW.dft $ length series)
      . V.fromList
      $ map (doubleToComplex . fromIntegral) series
      where
        doubleToComplex :: Double -> Complex Double
        doubleToComplex d = d :+ 0.0

withCStringLenTest :: Test
withCStringLenTest = TestCase $
  UT.withCStringLen "Hello World" $ \(ptr, _) -> do
    val <- peek ptr
    assertEqual "first character" val (castCharToCChar 'H')

useByteStringsAsCStringsTest :: Test
useByteStringsAsCStringsTest = TestCase $
  useByteStringsAsCStrings ["hello", "world"] $ \ptr -> do
    hello <- packCString =<< peek ptr
    world <- packCString =<< peek (advancePtr ptr 1)
    term <- peek $ advancePtr ptr 2
    assertEqual "first word" hello "hello"
    assertEqual "second word" world "world"
    assertEqual "terminator" term nullPtr

-- This should probably be a QuickCheck Property
bsListAsCStrLenArrTest :: [ByteString] -> Test
bsListAsCStrLenArrTest bs = TestCase $
  bsListAsCStrLenArr bs $ \strPtr lenPtr len -> do
    let packBS :: CSize -> IO ByteString
        packBS i = packCStringLen =<< (,)
                   <$> peek (getPtr strPtr)
                   <*> (fromIntegral <$> peek (getPtr lenPtr))
            where getPtr :: Storable a => Ptr a -> Ptr a
                  getPtr = (`advancePtr` fromIntegral i)
    got <- mapM packBS [0..len - 1]
    assertEqual "same list" got bs

data MyEnum = MyA | MyB
  deriving (Bounded, Enum, Eq, Show)

instance UT.TextRead MyEnum
instance TextShow MyEnum where
  showb MyA = "MyA"
  showb MyB = "MyB"

readTextTest :: Test
readTextTest = TestCase $ do
  assertEqual "myA" (Just MyA) (UT.readText "MyA")
  assertEqual "Nothing" (Nothing :: Maybe MyEnum) (UT.readText "MyC")

insertCommasAndAndTest :: Test
insertCommasAndAndTest = TestCase $ do
  assertEqual "null" "" $ UT.insertCommasAndAnd []
  assertEqual "singleton" "foo" $ UT.insertCommasAndAnd ["foo"]
  assertEqual "pair" "foo and bar" $ UT.insertCommasAndAnd ["foo", "bar"]
  assertEqual "triple" "foo, bar, and baz" $
    UT.insertCommasAndAnd ["foo", "bar", "baz"]
  assertEqual "quad" "foo, bar, baz, and quux" $
    UT.insertCommasAndAnd ["foo", "bar", "baz", "quux"]
  assertEqual "10" "1, 2, 3, 4, 5, 6, 7, 8, 9, and 10" $
    UT.insertCommasAndAnd [ showt (i::Int) | i <- [1..10] ]

main :: IO ()
main = testRunner $ TestList
  [ TestLabel "intToByteString" intToByteStringTest
  , TestLabel "parseValueStrictTest" parseValueStrictTest
#ifdef FACEBOOK
  , TestLabel "parseNaN" parseNaN
#endif
  , TestLabel "useFFTW" useFFTW
  , TestLabel "withCStringLen" withCStringLenTest
  , TestLabel "useByteStringsAsCStrings" useByteStringsAsCStringsTest
  , TestLabel "bsListAsCStrLenArr" (bsListAsCStrLenArrTest ["hello", "world"])
  , TestLabel "readText" readTextTest
  , TestLabel "insertCommasAndAnd" insertCommasAndAndTest
  ]


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}

module Spec.FDBStreaming.AggrTable
  ( tableProps,
  )
where

import Control.Monad (forM_, when)
import Data.ByteString (ByteString)
import Data.Data (Data)
import Data.Either (fromRight)
import Data.Int
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Monoid (All, Any, Sum)
import Data.Persist (Persist)
import qualified Data.Persist as Persist
import Data.Semigroup (Max (Max), Min (Min))
import Data.Text (Text)
import Data.Word
import FDBStreaming.AggrTable as AT
import FDBStreaming.Message (Message (fromMessage, toMessage))
import FoundationDB (Database, runTransaction)
import qualified FoundationDB as FDB
import FoundationDB.Layer.Subspace (Subspace, extend)
import qualified FoundationDB.Layer.Tuple as FDB
import GHC.Generics (Generic)
import Numeric.Sum (KBNSum (..))
import Spec.FDBStreaming.Util (extendRand)
import Statistics.Monoid (CalcMean, MeanKBN, StatMonoid (..))
import Test.QuickCheck ((===), Arbitrary, Property, property)
import Test.QuickCheck.Instances.ByteString ()
import Test.QuickCheck.Instances.Text ()
import Test.QuickCheck.Instances.UUID ()
import Test.QuickCheck.Monadic as Monadic
import Test.Tasty
import qualified Test.Tasty.QuickCheck as QC

deriving via Double instance Arbitrary (Max Double)

deriving via Float instance Arbitrary (Min Float)

deriving via Int32 instance Arbitrary (Max Int32)

deriving via Int32 instance Arbitrary (Min Int32)

deriving via Int64 instance Arbitrary (Max Int64)

deriving via Int64 instance Arbitrary (Min Int64)

deriving via Word32 instance Arbitrary (Max Word32)

deriving via Word32 instance Arbitrary (Min Word32)

binaryProperty :: (Show a, Arbitrary a, Show b, Arbitrary b) => (a -> b -> Property) -> Property
binaryProperty x = property $ property x

ternaryProperty ::
  ( Show a,
    Arbitrary a,
    Show b,
    Arbitrary b,
    Show c,
    Arbitrary c
  ) =>
  (a -> b -> c -> Property) ->
  Property
ternaryProperty x = property $ property $ property x

propOrdTableKey :: (OrdTableKey k) => k -> k -> Property
propOrdTableKey k l =
  compare k l === compare (toKeyBytes k) (toKeyBytes l)

ordTableKeyProps :: TestTree
ordTableKeyProps =
  testGroup
    "OrdTableKey"
    [ QC.testProperty "works for ByteString" $ binaryProperty $ propOrdTableKey @ByteString,
      QC.testProperty "works for Text" $ binaryProperty $ propOrdTableKey @Text,
      QC.testProperty "works for Integer" $ binaryProperty $ propOrdTableKey @Integer,
      QC.testProperty "works for Float" $ binaryProperty $ propOrdTableKey @Float,
      QC.testProperty "works for Double" $ binaryProperty $ propOrdTableKey @Double,
      QC.testProperty "works for Bool" $ binaryProperty $ propOrdTableKey @Bool,
      QC.testProperty "works for 2-tuples" $ binaryProperty $ propOrdTableKey @(Bool, Double)
    ]

propMappendTable ::
  forall v.
  (Eq v, TableSemigroup v) =>
  Subspace ->
  Database ->
  ByteString ->
  v ->
  v ->
  Property
propMappendTable ss db tableName v1 v2 = monadicIO $ do
  ss' <- run $ extendRand ss
  let table = AggrTable (extend ss' [FDB.Bytes tableName]) 2 :: AggrTable Bool v
  let k = True
  run $ runTransaction db $ AT.set table 0 k v1
  run $ runTransaction db $ mappendBatch table 0 [(k, v2)]
  (Just v3) <- run $ runTransaction db $ AT.get table 0 k >>= FDB.await
  Monadic.assert (v3 == v1 <> v2)
  -- Test that we combine across partitions correctly when reading. TODO:
  -- refactor into separate test.
  run $ runTransaction db $ mappendBatch table 1 [(k, v1)]
  (Just v4) <- run $ runTransaction db $ AT.getRow table k
  Monadic.assert (v4 == v1 <> v2 <> v1)

mappendTableProps :: Subspace -> Database -> TestTree
mappendTableProps testSS db =
  testGroup
    "mappendTable"
    [ QC.testProperty "Works for (Sum Word32)" $ ternaryProperty (propMappendTable testSS db :: ByteString -> Sum Word32 -> Sum Word32 -> Property),
      QC.testProperty "Works for (Sum Int64)" $ ternaryProperty (propMappendTable testSS db :: ByteString -> Sum Int64 -> Sum Int64 -> Property),
      QC.testProperty "Works for (Max Double)" $ ternaryProperty (propMappendTable testSS db :: ByteString -> Max Double -> Max Double -> Property),
      QC.testProperty "Works for (Max Int32)" $ ternaryProperty (propMappendTable testSS db :: ByteString -> Max Int32 -> Max Int32 -> Property),
      QC.testProperty "Works for (Max Int64)" $ ternaryProperty (propMappendTable testSS db :: ByteString -> Max Int64 -> Max Int64 -> Property),
      QC.testProperty "Works for (Max Word32)" $ ternaryProperty (propMappendTable testSS db :: ByteString -> Max Word32 -> Max Word32 -> Property),
      QC.testProperty "Works for (Min Float)" $ ternaryProperty (propMappendTable testSS db :: ByteString -> Min Float -> Min Float -> Property),
      QC.testProperty "Works for (Min Int32)" $ ternaryProperty (propMappendTable testSS db :: ByteString -> Min Int32 -> Min Int32 -> Property),
      QC.testProperty "Works for (Min Word32)" $ ternaryProperty (propMappendTable testSS db :: ByteString -> Min Word32 -> Min Word32 -> Property),
      QC.testProperty "Works for Any" $ ternaryProperty (propMappendTable testSS db :: ByteString -> Any -> Any -> Property),
      QC.testProperty "Works for All" $ ternaryProperty (propMappendTable testSS db :: ByteString -> All -> All -> Property)
    ]

propTableRange ::
  forall v.
  (TableSemigroup v, RangeAccessibleTable v, Eq v) =>
  Subspace ->
  Database ->
  ByteString ->
  v ->
  Property
propTableRange ss db tableName v = monadicIO $ do
  ss' <- run $ extendRand ss
  let table = AggrTable (extend ss' [FDB.Bytes tableName]) 2 :: AggrTable Integer v
  forM_ [0 .. 10] $ \i -> run $ runTransaction db $ AT.set table 0 i v
  result <- run $ runTransaction db $ AT.getTableRange table 0 0 10
  let expected = Map.fromList [(i, v) | i <- [0 .. 10]]
  Monadic.assert (result == expected)
  -- Test that we combine across partitions correctly when reading. TODO:
  -- refactor into separate test.
  forM_ [0 .. 10] $ \i -> run $ runTransaction db $ AT.mappendBatch table 1 [(i, v)]
  result2 <- run $ runTransaction db $ AT.getRowRange table 0 10
  let expected2 = Map.fromList [(i, v <> v) | i <- [0 .. 10]]
  Monadic.assert (result2 == expected2)

tableRangeProps :: Subspace -> Database -> TestTree
tableRangeProps testSS db =
  testGroup
    "getTableRange"
    [ QC.testProperty "Works for (Sum Word32)" $ binaryProperty (propTableRange testSS db :: ByteString -> Sum Word32 -> Property),
      QC.testProperty "Works for (Sum Int32)" $ binaryProperty (propTableRange testSS db :: ByteString -> Sum Int32 -> Property),
      QC.testProperty "Works for Any" $ binaryProperty (propTableRange testSS db :: ByteString -> Any -> Property),
      QC.testProperty "Works for All" $ binaryProperty (propTableRange testSS db :: ByteString -> All -> Property),
      QC.testProperty "Works for (Max Double)" $ binaryProperty (propTableRange testSS db :: ByteString -> Max Double -> Property),
      QC.testProperty "Works for (Min Int64)" $ binaryProperty (propTableRange testSS db :: ByteString -> Min Int64 -> Property)
    ]

newtype Mean = Mean {unMean :: MeanKBN}
  deriving (Eq, Data, Show, Generic)
  deriving (Semigroup) via MeanKBN
  deriving (Monoid) via MeanKBN
  deriving (CalcMean) via MeanKBN

deriving instance Generic KBNSum

deriving instance Persist KBNSum

deriving instance Persist MeanKBN

deriving instance Persist Mean

instance Real a => StatMonoid Mean a where

  addValue (Mean m) a = Mean (addValue m a)

  singletonMonoid a = Mean (singletonMonoid a)

instance Message Mean where

  toMessage = Persist.encode

  fromMessage = fromRight (error "Failed to decode Mean") . Persist.decode

instance TableSemigroup Mean where

  mappendBatch = mappendMessageBatch

  set = setMessage

  get = getMessage

propNonAtomicSemigroup :: Real v => Subspace -> Database -> ByteString -> [v] -> Property
propNonAtomicSemigroup ss db tableName vs = monadicIO $ do
  ss' <- run $ extendRand ss
  let table = AggrTable (extend ss' [FDB.Bytes tableName]) 2 :: AggrTable () Mean
  let kvs = map (\v -> ((), singletonMonoid v)) vs
  run $ runTransaction db $ mappendBatch table 0 kvs
  run $ runTransaction db $ mappendBatch table 1 kvs
  let expectedResult = foldMap singletonMonoid (vs <> vs)
  result <- fromMaybe mempty <$> run (runTransaction db $ AT.getRow table ())
  when (expectedResult /= result) $ do
    run $ putStrLn $ "expected: " ++ show expectedResult
    run $ putStrLn $ "got: " ++ show result
  Monadic.assert (expectedResult == (result :: Mean))

nonAtomicSemigroupProps :: Subspace -> Database -> TestTree
nonAtomicSemigroupProps testSS db =
  testGroup
    "non-atomic table helper functions"
    [ QC.testProperty "Works for Kahan Mean" $ binaryProperty (propNonAtomicSemigroup testSS db :: ByteString -> [Integer] -> Property)
    ]

tableProps :: Subspace -> Database -> TestTree
tableProps testSS db =
  testGroup
    "AggrTable"
    [ nonAtomicSemigroupProps testSS db,
      ordTableKeyProps,
      mappendTableProps testSS db,
      tableRangeProps testSS db
    ]