{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      :  Pact.Repl.Lib
-- Copyright   :  (C) 2016 Stuart Popejoy
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Stuart Popejoy <stuart@kadena.io>
--
-- Built-ins for repl functionality. Not part of standard library
-- for blockchain execution, but instead for testing and dev.
--

module Pact.Repl.Lib where

import Control.Arrow ((&&&))
import Data.Default
import Data.Semigroup
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as M
import Control.Monad.Reader
import Control.Monad.Catch
import Control.Monad.State.Strict (get)
import Control.Lens
import qualified Data.Set as S
import qualified Data.ByteString.Lazy as BSL
import Control.Concurrent.MVar
import Data.Aeson (eitherDecode,toJSON)
import qualified Data.Text as Text
import Data.Text.Encoding
import Data.Maybe
#if !defined(ghcjs_HOST_OS)
import Criterion
import Criterion.Types
import Pact.Analyze.Check
#if MIN_VERSION_statistics(0,14,0)
import Statistics.Types (Estimate(..))
#else
import Statistics.Resampling.Bootstrap
#endif
#endif
import Pact.Typechecker
import Pact.Types.Typecheck
-- intentionally hidden unused functions to prevent lib functions from consuming gas
import Pact.Native.Internal hiding (defRNative,defGasRNative,defNative)
import qualified Pact.Native.Internal as Native
import Pact.Types.Runtime
import Pact.Eval
import Pact.Persist.Pure
import Pact.PersistPactDb
import Pact.Types.Logger
import Pact.Repl.Types

initLibState :: Loggers -> IO LibState
initLibState loggers = do
  m <- newMVar (DbEnv def persister
                (newLogger loggers "Repl")
                def def)
  createSchema m
  return (LibState m Noop def def)

-- | Native function with no gas consumption.
type ZNativeFun e = FunApp -> [Term Ref] -> Eval e (Term Name)

zeroGas :: Eval e a -> Eval e (Gas,a)
zeroGas = fmap (0,)

defZNative :: NativeDefName -> ZNativeFun e -> FunTypes (Term Name) -> Text -> NativeDef
defZNative name fun = Native.defNative name $ \fi as -> zeroGas $ fun fi as

defZRNative :: NativeDefName -> RNativeFun e -> FunTypes (Term Name) -> Text -> NativeDef
defZRNative name fun = Native.defNative name (reduced fun)
    where reduced f fi as = mapM reduce as >>= zeroGas . f fi

replDefs :: NativeModule
replDefs = ("Repl",
     [
      defZRNative "load" load (funType tTyString [("file",tTyString)] <>
                              funType tTyString [("file",tTyString),("reset",tTyBool)]) $
      "Load and evaluate FILE, resetting repl state beforehand if optional NO-RESET is true. " <>
      "`$(load \"accounts.repl\")`"
     ,defZRNative "env-keys" setsigs (funType tTyString [("keys",TyList tTyString)])
      "Set transaction signature KEYS. `(env-keys [\"my-key\" \"admin-key\"])`"
     ,defZRNative "env-data" setmsg (funType tTyString [("json",json)]) $
      "Set transaction JSON data, either as encoded string, or as pact types coerced to JSON. " <>
      "`(env-data { \"keyset\": { \"keys\": [\"my-key\" \"admin-key\"], \"pred\": \"keys-any\" } })`"
     ,defZRNative "env-step"
      setstep (funType tTyString [] <>
               funType tTyString [("step-idx",tTyInteger)] <>
               funType tTyString [("step-idx",tTyInteger),("rollback",tTyBool)] <>
               funType tTyString [("step-idx",tTyInteger),("rollback",tTyBool),("resume",TySchema TyObject (mkSchemaVar "y"))])
      ("Set pact step state. With no arguments, unset step. With STEP-IDX, set step index to execute. " <>
       "ROLLBACK instructs to execute rollback expression, if any. RESUME sets a value to be read via 'resume'." <>
       "Clears any previous pact execution state. `$(env-step 1)` `$(env-step 0 true)`")
     ,defZRNative "pact-state" pactState (funType (tTyObject TyAny) [])
      ("Inspect state from previous pact execution. Returns object with fields " <>
      "'yield': yield result or 'false' if none; 'step': executed step; " <>
      "'executed': indicates if step was skipped because entity did not match. `$(pact-state)`")
     ,defZRNative "env-entity" setentity
      (funType tTyString [] <> funType tTyString [("entity",tTyString)])
      ("Set environment confidential ENTITY id, or unset with no argument. " <>
      "Clears any previous pact execution state. `$(env-entity \"my-org\")` `$(env-entity)`")
     ,defZRNative "begin-tx" (tx Begin) (funType tTyString [] <>
                                        funType tTyString [("name",tTyString)])
       "Begin transaction with optional NAME. `$(begin-tx \"load module\")`"
     ,defZRNative "commit-tx" (tx Commit) (funType tTyString []) "Commit transaction. `$(commit-tx)`"
     ,defZRNative "rollback-tx" (tx Rollback) (funType tTyString []) "Rollback transaction. `$(rollback-tx)`"
     ,defZRNative "expect" expect (funType tTyString [("doc",tTyString),("expected",a),("actual",a)])
      "Evaluate ACTUAL and verify that it equals EXPECTED. `(expect \"Sanity prevails.\" 4 (+ 2 2))`"
     ,defZNative "expect-failure" expectFail (funType tTyString [("doc",tTyString),("exp",a)]) $
      "Evaluate EXP and succeed only if it throws an error. " <>
      "`(expect-failure \"Enforce fails on false\" (enforce false \"Expected error\"))`"
     ,defZNative "bench" bench' (funType tTyString [("exprs",TyAny)])
      "Benchmark execution of EXPRS. `$(bench (+ 1 2))`"
     ,defZRNative "typecheck" tc (funType tTyString [("module",tTyString)] <>
                                 funType tTyString [("module",tTyString),("debug",tTyBool)])
       "Typecheck MODULE, optionally enabling DEBUG output."
     ,defZRNative "env-gaslimit" setGasLimit (funType tTyString [("limit",tTyInteger)])
       "Set environment gas limit to LIMIT"
     ,defZRNative "env-gas" envGas (funType tTyInteger [] <> funType tTyString [("gas",tTyInteger)])
       "Query gas state, or set it to GAS"
     ,defZRNative "env-gasprice" setGasPrice (funType tTyString [("price",tTyDecimal)])
       "Set environment gas price to PRICE"
     ,defZRNative "env-gasrate" setGasRate (funType tTyString [("rate",tTyInteger)])
       "Update gas model to charge constant RATE"
#if !defined(ghcjs_HOST_OS)
     ,defZRNative "verify" verify (funType tTyString [("module",tTyString)]) "Verify MODULE, checking that all properties hold."
#endif

     ,defZRNative "json" json' (funType tTyValue [("exp",a)]) $
      "Encode pact expression EXP as a JSON value. " <>
      "This is only needed for tests, as Pact values are automatically represented as JSON in API output. " <>
      "`(json [{ \"name\": \"joe\", \"age\": 10 } {\"name\": \"mary\", \"age\": 25 }])`"
     ,defZRNative "sig-keyset" sigKeyset (funType tTyKeySet [])
     "Convenience to build a keyset from keys present in message signatures, using 'keys-all' as the predicate."
     ,defZRNative "print" print' (funType tTyString [("value",a)])
     "Print a string, mainly to format newlines correctly"
     ,defZRNative "env-hash" envHash (funType tTyString [("hash",tTyString)])
     "Set current transaction hash. HASH must be a valid BLAKE2b 512-bit hash. `(env-hash (hash \"hello\"))`"
     ])
     where
       json = mkTyVar "a" [tTyInteger,tTyString,tTyTime,tTyDecimal,tTyBool,
                         TyList (mkTyVar "l" []),TySchema TyObject (mkSchemaVar "o"),tTyKeySet,tTyValue]
       a = mkTyVar "a" []

invokeEnv :: (MVar (DbEnv PureDb) -> IO b) -> MVar LibState -> IO b
invokeEnv f e = withMVar e $ \ls -> f $! _rlsPure ls
{-# INLINE invokeEnv #-}

repldb :: PactDb LibState
repldb = PactDb {

    _readRow = \d k -> invokeEnv $ _readRow pactdb d k
  , _writeRow = \wt d k v -> invokeEnv $ _writeRow pactdb wt d k v
  , _keys = \t -> invokeEnv $ _keys pactdb t
  , _txids = \t tid -> invokeEnv $ _txids pactdb t tid
  , _createUserTable = \t m k -> invokeEnv $ _createUserTable pactdb t m k
  , _getUserTableInfo = \t -> invokeEnv $ _getUserTableInfo pactdb t
  , _beginTx = \tid -> invokeEnv $ _beginTx pactdb tid
  , _commitTx = invokeEnv $ _commitTx pactdb
  , _rollbackTx = invokeEnv $ _rollbackTx pactdb
  , _getTxLog = \d t -> invokeEnv $ _getTxLog pactdb d t

}

load :: RNativeFun LibState
load _ [TLitString fn] = setop (Load (unpack fn) False) >> return (tStr $ "Loading " <> fn <> "...")
load _ [TLitString fn, TLiteral (LBool r) _] = setop (Load (unpack fn) r) >> return (tStr $ "Loading " <> fn <> "...")
load i as = argsError i as

modifyLibState :: (LibState -> (LibState,a)) -> Eval LibState a
modifyLibState f = view eePactDbVar >>= \m -> liftIO $ modifyMVar m (return . f)

setLibState :: (LibState -> LibState) -> Eval LibState ()
setLibState f = modifyLibState (f &&& const ())

viewLibState :: (LibState -> a) -> Eval LibState a
viewLibState f = modifyLibState (id &&& f)

setop :: LibOp -> Eval LibState ()
setop v = setLibState $ set rlsOp v

setenv :: Show a => Setter' (EvalEnv LibState) a -> a -> Eval LibState ()
setenv l v = setop $ UpdateEnv $ Endo (set l v)

setsigs :: RNativeFun LibState
setsigs i [TList ts _ _] = do
  ks <- forM ts $ \t -> case t of
          (TLitString s) -> return s
          _ -> argsError i ts
  setenv eeMsgSigs (S.fromList (map (PublicKey . encodeUtf8) ks))
  return $ tStr "Setting transaction keys"
setsigs i as = argsError i as

setmsg :: RNativeFun LibState
setmsg i [TLitString j] =
  case eitherDecode (BSL.fromStrict $ encodeUtf8 j) of
    Left f -> evalError' i ("Invalid JSON: " ++ show f)
    Right v -> setenv eeMsgBody v >> return (tStr "Setting transaction data")
setmsg _ [a] = setenv eeMsgBody (toJSON a) >> return (tStr "Setting transaction data")
setmsg i as = argsError i as

setstep :: RNativeFun LibState
setstep i as = case as of
  [] -> setstep' Nothing >> return (tStr "Un-setting step")
  [TLitInteger j] -> do
    setstep' (Just $ PactStep (fromIntegral j) False def def)
    return $ tStr "Setting step"
  [TLitInteger j,TLiteral (LBool b) _] -> do
    setstep' (Just $ PactStep (fromIntegral j) b def def)
    return $ tStr "Setting step and rollback"
  [TLitInteger j,TLiteral (LBool b) _,o@TObject{}] -> do
    setstep' (Just $ PactStep (fromIntegral j) b def (Just o))
    return $ tStr "Setting step, rollback, and resume value"
  _ -> argsError i as
  where
    setstep' s = do
      setenv eePactStep s
      evalPactExec .= Nothing

setentity :: RNativeFun LibState
setentity i as = case as of
  [TLitString s] -> do
    setenv eeEntity $ Just (EntityName s)
    evalPactExec .= Nothing
    return (tStr $ "Set entity to " <> s)
  [] -> do
    setenv eeEntity Nothing
    evalPactExec .= Nothing
    return (tStr "Unset entity")
  _ -> argsError i as

pactState :: RNativeFun LibState
pactState i [] = do
  e <- use evalPactExec
  case e of
    Nothing -> evalError' i "pact-state: no pact exec in context"
    Just PactExec{..} -> return $ (\o -> TObject o TyAny def)
      [(tStr "yield",fromMaybe (toTerm False) _peYield)
      ,(tStr "executed",toTerm _peExecuted)
      ,(tStr "step",toTerm _peStep)]
pactState i as = argsError i as

txmsg :: Maybe Text -> Maybe TxId -> Text -> Term Name
txmsg n tid s = tStr $ s <> " Tx " <> pack (show tid) <> maybe "" (": " <>) n

tx :: Tx -> RNativeFun LibState
tx Begin i as = do
  tname <- case as of
             [TLitString n] -> return $ Just n
             [] -> return Nothing
             _ -> argsError i as
  setop $ Tx (_faInfo i) Begin tname
  setLibState $ set rlsTxName tname
  return (tStr "")
tx t i [] = do
  tname <- modifyLibState (set rlsTxName Nothing &&& view rlsTxName)
  setop (Tx (_faInfo i) t tname)
  return (tStr "")
tx _ i as = argsError i as

recordTest :: Text -> Maybe (FunApp,Text) -> Eval LibState ()
recordTest name failure = setLibState $ over rlsTests (++ [TestResult name failure])

testSuccess :: Text -> Text -> Eval LibState (Term Name)
testSuccess name msg = recordTest name Nothing >> return (tStr msg)

testFailure :: FunApp -> Text -> Text -> Eval LibState (Term Name)
testFailure i name msg = recordTest name (Just (i,msg)) >> return (tStr msg)

expect :: RNativeFun LibState
expect i [TLitString a,b,c] =
  if b `termEq` c
  then testSuccess a $ "Expect: success: " <> a
  else testFailure i a $ "FAILURE: " <> a <> ": expected " <> pack (show b) <> ", received " <> pack (show c)
expect i as = argsError i as

expectFail :: ZNativeFun LibState
expectFail i as@[a,b] = do
  a' <- reduce a
  case a' of
    TLitString msg -> do
      r <- catch (Right <$> reduce b) (\(_ :: SomeException) -> return $ Left ())
      case r of
        Right v -> testFailure i msg $ "FAILURE: " <> msg <> ": expected failure, got result = " <> pack (show v)
        Left _ -> testSuccess msg $ "Expect failure: success: " <> msg
    _ -> argsError' i as
expectFail i as = argsError' i as

bench' :: ZNativeFun LibState
#if !defined(ghcjs_HOST_OS)
bench' i as = do
  e <- ask
  s <- get
  (r :: Either SomeException Report) <-
      try $ liftIO $ benchmark' $ whnfIO $ runEval s e $ do
                !ts <- mapM reduce as
                return $! toTerm (length ts)
  case r of
    Left ex -> evalError' i (show ex)
    Right rpt -> do
           let mean = estPoint (anMean (reportAnalysis rpt))
               sd = estPoint (anStdDev (reportAnalysis rpt))
               (reg,_) = splitAt 1 $ anRegress (reportAnalysis rpt)
               val = case reg of
                       [] -> mean
                       (r':_) -> case M.lookup "iters" (regCoeffs r') of
                                  Nothing -> mean
                                  Just t -> estPoint t
               tps = 1/val
               tperr = (1/(val - (sd/2))) - (1/(val + (sd/2)))
           liftIO $ putStrLn $ show (round tps :: Integer) ++ "/s, +-" ++ show (round tperr :: Integer) ++ "/s"
           return (tStr "Done")
#else
bench' i _ = evalError' i "Benchmarking not supported in GHCJS"
#endif

tc :: RNativeFun LibState
tc i as = case as of
  [TLitString s] -> go s False
  [TLitString s,TLiteral (LBool d) _] -> go s d
  _ -> argsError i as
  where
    go modname dbg = do
      mdm <- HM.lookup (ModuleName modname) <$> view (eeRefStore . rsModules)
      case mdm of
        Nothing -> evalError' i $ "No such module: " ++ show modname
        Just md -> do
          r :: Either CheckerException ([TopLevel Node],[Failure]) <-
            try $ liftIO $ typecheckModule dbg md
          case r of
            Left (CheckerException ei e) -> evalError ei ("Typechecker Internal Error: " ++ e)
            Right (_,fails) -> case fails of
              [] -> return $ tStr $ "Typecheck " <> modname <> ": success"
              _ -> do
                setop $ TcErrors $ map (\(Failure ti s) -> renderInfo (_tiInfo ti) ++ ":Warning: " ++ s) fails
                return $ tStr $ "Typecheck " <> modname <> ": Unable to resolve all types"

#if !defined(ghcjs_HOST_OS)
verify :: RNativeFun LibState
verify i as = case as of
  [TLitString modName] -> do
    modules <- view (eeRefStore . rsModules)
    let mdm = HM.lookup (ModuleName modName) modules
    case mdm of
      Nothing -> evalError' i $ "No such module: " ++ show modName
      Just md -> do
        results <- liftIO $ verifyModule modules md
        setop $ TcErrors $ fmap (Text.unpack . describeCheckResult) $
          toListOf (traverse . each) results

        return (tStr "")

  _ -> argsError i as
#endif

json' :: RNativeFun LibState
json' _ [a] = return $ TValue (toJSON a) def
json' i as = argsError i as

sigKeyset :: RNativeFun LibState
sigKeyset _ _ = view eeMsgSigs >>= \ss -> return $ toTerm $ KeySet (S.toList ss) (Name (asString KeysAll) def)

print' :: RNativeFun LibState
print' _ [v] = setop (Print v) >> return (tStr "")
print' i as = argsError i as

envHash :: RNativeFun LibState
envHash i [TLitString s] = case fromText' s of
  Left err -> evalError' i $ "Bad hash value: " ++ show s ++ ": " ++ err
  Right h -> do
    setenv eeHash h
    return $ tStr $ "Set tx hash to " <> s
envHash i as = argsError i as

setGasLimit :: RNativeFun LibState
setGasLimit _ [TLitInteger l] = do
  setenv (eeGasEnv . geGasLimit) (fromIntegral l)
  return $ tStr $ "Set gas limit to " <> tShow l
setGasLimit i as = argsError i as

envGas :: RNativeFun LibState
envGas _ [] = use evalGas >>= \g -> return (tLit $ LInteger $ fromIntegral g)
envGas _ [TLitInteger g] = do
  evalGas .= fromIntegral g
  return $ tStr $ "Set gas to " <> tShow g
envGas i as = argsError i as

setGasPrice :: RNativeFun LibState
setGasPrice _ [TLiteral (LDecimal d) _] = do
  setenv (eeGasEnv . geGasPrice) (GasPrice d)
  return $ tStr $ "Set gas price to " <> tShow d
setGasPrice i as = argsError i as

setGasRate :: RNativeFun LibState
setGasRate _ [TLitInteger r] = do
    setenv (eeGasEnv . geGasModel) (constGasModel $ fromIntegral r)
    return $ tStr $ "Set gas rate to " <> tShow r

setGasRate i as = argsError i as


{-# LANGUAGE CPP #-}

{- |
Module      : Language.Scheme.Compiler.Types
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

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

This module contains data types used by the compiler.
-}

module Language.Scheme.Compiler.Types
    (
    -- * Data types
      CompOpts (..)
    , CompLibOpts (..)
    , defaultCompileOptions
    , HaskAST (..)
    -- * Utility functions
    , ast2Str
    , asts2Str
    , createAstFunc
    , createAstCont
    , joinL
    , moduleRuntimeVar
    , showValAST
    -- * Headers appended to output file
    , header
    , headerComment
    , headerModule
    , headerImports
    )
where
import qualified Language.Scheme.Core as LSC (version)
import Language.Scheme.Types
import qualified Language.Scheme.Util (escapeBackslashes)
import qualified Data.Array
import qualified Data.ByteString as BS
import qualified Data.Complex as DC
import qualified Data.List
import qualified Data.Map
import qualified Data.Ratio as DR

-- |A type to store options passed to compile.
--  Eventually all of this might be able to be
--  integrated into a Compile monad.
data CompOpts = CompileOptions {
    coptsThisFunc :: String,
    -- ^Immediate name to use when creating a compiled function.
    --  Presumably there is other code that is expecting
    --  to call into it.

    coptsThisFuncUseValue :: Bool,
    -- ^Whether to include the /value/ parameter in the current function

    coptsThisFuncUseArgs :: Bool,
    -- ^Whether to include the /args/ parameter in the current function

    coptsNextFunc :: Maybe String
    -- ^The name to use for the next function after the current
    --  compiler recursion is finished. For example, after compiling
    --  a block of code, the control flow would be expected to go
    --  to this function.
    }

-- |The default compiler options
defaultCompileOptions :: String -> CompOpts
defaultCompileOptions thisFunc = CompileOptions thisFunc False False Nothing

-- |Options passed to the compiler library module
data CompLibOpts = CompileLibraryOptions {
    compBlock :: String -> Maybe String -> Env
              -> [HaskAST] -> [LispVal] -> IOThrowsError [HaskAST],
    compLisp :: Env -> String -> String -> Maybe String
              -> IOThrowsError [HaskAST]
    }

-- |Runtime reference to module data structure
moduleRuntimeVar :: String
moduleRuntimeVar = " modules "

-- |Create code for a function
createAstFunc
  :: CompOpts  -- ^ Compilation options
  -> [HaskAST] -- ^ Body of the function
  -> HaskAST -- ^ Complete function code
createAstFunc (CompileOptions thisFunc useVal useArgs _) funcBody = do
  let val = if useVal then "value" else "_"
      args = if useArgs then "(Just args)" else "_"
  AstFunction thisFunc (" env cont " ++ val ++ " " ++ args ++ " ") funcBody

-- |Create code for a continutation
createAstCont
  :: CompOpts -- ^ Compilation options
  -> String -- ^ Value to send to the continuation
  -> String -- ^ Extra leading indentation (or blank string if none)
  -> HaskAST -- ^ Generated code
createAstCont (CompileOptions _ _ _ (Just nextFunc)) var indentation = do
  AstValue $ indentation ++ "  " ++ nextFunc ++ " env cont " ++ var ++ " (Just [])"
createAstCont (CompileOptions _ _ _ Nothing) var indentation = do
  AstValue $ indentation ++ "  continueEval env cont " ++ var ++ " Nothing"

--  FUTURE: is this even necessary? Would just a string be good enough?

-- |A very basic type to store a Haskell AST.
data HaskAST = AstAssignM String HaskAST
  | AstFunction {astfName :: String,
--                 astfType :: String,
                 astfArgs :: String,
                 astfCode :: [HaskAST]
                }
 | AstValue String
 | AstRef String
 | AstContinuation {astcNext :: String,
                    astcArgs :: String
                   }

-- |Generate code based on the given Haskell AST
showValAST :: HaskAST -> String
showValAST (AstAssignM var val) = "  " ++ var ++ " <- " ++ show val
showValAST (AstFunction name args code) = do
  let typeSig = "\n" ++ name ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal "
  let fheader = "\n" ++ name ++ args ++ " = do "
  let fbody = unwords . map (\x -> '\n' : x ) $ map showValAST code
#ifdef UseDebug
  let appendArg arg = do
        if Data.List.isInfixOf arg args
           then " ++ \" \" ++ " ++ (show arg) ++
                " ++ \" [\" ++ (show " ++ arg ++ ")" ++
                " ++ \"] \""
           else ""
  let fdebug = "\n  _ <- liftIO $ (trace (\"" ++
               name ++ "\"" ++
               (appendArg "value") ++
               (appendArg "args") ++
               ") getCPUTime)"
  typeSig ++ fheader ++ fdebug ++ fbody
#else
  typeSig ++ fheader ++ fbody
#endif
showValAST (AstValue v) = v
showValAST (AstRef v) = v
showValAST (AstContinuation nextFunc args) =
    "  continueEval env (makeCPSWArgs env cont " ++
       nextFunc ++ " " ++ args ++ ") (Nil \"\") Nothing "

instance Show HaskAST where show = showValAST

-- |A utility function to join list members together
joinL
  :: forall a. [[a]] -- ^ Original list-of-lists
  -> [a] -- ^ Separator
  -> [a] -- ^ Joined list
joinL ls sep = Data.List.intercalate sep ls

-- |Convert abstract syntax tree to a string
ast2Str :: LispVal -> String
ast2Str (String s) = "String " ++ show s
ast2Str (Char c) = "Char " ++ show c
ast2Str (Atom a) = "Atom " ++ show a
ast2Str (Number n) = "Number (" ++ show n ++ ")"
ast2Str (Complex c) = "Complex $ (" ++ (show $ DC.realPart c) ++ ") :+ (" ++ (show $ DC.imagPart c) ++ ")"
ast2Str (Rational r) = "Rational $ (" ++ (show $ DR.numerator r) ++ ") % (" ++ (show $ DR.denominator r) ++ ")"
ast2Str (Float f) = "Float (" ++ show f ++ ")"
ast2Str (Bool True) = "Bool True"
ast2Str (Bool False) = "Bool False"
ast2Str (HashTable ht) = do
 let ls = Data.Map.toList ht
     conv (a, b) = "(" ++ ast2Str a ++ "," ++ ast2Str b ++ ")"
 "HashTable $ Data.Map.fromList $ [" ++ joinL (map conv ls) "," ++ "]"
ast2Str (Vector v) = do
  let ls = Data.Array.elems v
      size = (length ls) - 1
  "Vector (listArray (0, " ++ show size ++ ")" ++ "[" ++ joinL (map ast2Str ls) "," ++ "])"
ast2Str (ByteVector bv) = do
  let ls = BS.unpack bv
  "ByteVector ( BS.pack " ++ "[" ++ joinL (map show ls) "," ++ "])"
ast2Str (List ls) = "List [" ++ joinL (map ast2Str ls) "," ++ "]"
ast2Str (DottedList ls l) =
  "DottedList [" ++ joinL (map ast2Str ls) "," ++ "] $ " ++ ast2Str l
ast2Str l = show l -- Error?

-- |Convert a list of abstract syntax trees to a list of strings
asts2Str :: [LispVal] -> String
asts2Str ls = do
    "[" ++ (joinL (map ast2Str ls) ",") ++ "]"

-- |Header comment used at the top of a Haskell program generated
--  by the compiler
headerComment:: [String]
headerComment = [
   "--"
 , "-- This file was automatically generated by the husk scheme compiler (huskc)"
 , "--"
 , "--  http://justinethier.github.io/husk-scheme "
 , "--  (c) 2010 Justin Ethier "
 , "--  Version " ++ LSC.version
 , "--"]

-- |Main module used in a compiled Haskell program
headerModule :: [String]
headerModule = ["module Main where "]

-- |Imports used for a compiled program
headerImports :: [String]
headerImports = [
   "Language.Scheme.Core "
 , "Language.Scheme.Numerical "
 , "Language.Scheme.Macro "
 , "Language.Scheme.Primitives "
 , "Language.Scheme.Types     -- Scheme data types "
 , "Language.Scheme.Variables -- Scheme variable operations "
 , "Control.Monad.Error "
 , "Data.Array "
 , " qualified Data.ByteString as BS "
 , "Data.Complex "
 , " qualified Data.Map "
 , "Data.Ratio "
 , "Data.Word "
 , "System.IO "
#ifdef UseDebug
 , "System.CPUTime "
 , "Debug.Trace "
#endif
 ]

-- |Block of code used in the header of a Haskell program
--  generated by the compiler.
header :: String -> Bool -> String -> [String]
header filepath useCompiledLibs langRev = do
  let env = if useCompiledLibs
            then "primitiveBindings"
            else case langRev of
                   "7" -> "r7rsEnv"
                   _ -> "r5rsEnv"
      initSrfi55 =
        case langRev of
          "7" -> []
          _ -> [ "exec55_3 env cont _ _ = do "
               , "  liftIO $ registerExtensions env getDataFileName' "
               , "  continueEval env (makeCPSWArgs env cont exec []) (Nil \"\") Nothing"]
  [ " "
    , " "
    , "-- |Get variable at runtime "
    , "getRTVar env var = do "
    , "  v <- getVar env var "
    , "  return $ case v of "
    , "    List _ -> Pointer var env "
    , "    DottedList _ _ -> Pointer var env "
    , "    String _ -> Pointer var env "
    , "    Vector _ -> Pointer var env "
    , "    ByteVector _ -> Pointer var env "
    , "    HashTable _ -> Pointer var env "
    , "    _ -> v "
    , " "
-- TODO:  this is just a temporary function until calls to continueEval can be purged from the compiler
    , "continueEval' env cont value = continueEval env cont value Nothing "
    , " "
    , "applyWrapper env cont (Nil _) (Just (a:as))  = do "
    , "  apply cont a as "
    , " "
    , "applyWrapper env cont value (Just (a:as))  = do "
    , "  apply cont a $ as ++ [value] "
    , " "
    , "getDataFileName' :: FilePath -> IO FilePath "
    , "getDataFileName' name = return $ \"" ++ (Language.Scheme.Util.escapeBackslashes filepath) ++ "\" ++ name "
    , " "]
    ++ initSrfi55 ++
    [ " "
    , "main :: IO () "
    , "main = do "
    , "  env <- " ++ env ++ " "
    , "  result <- (runIOThrows $ liftM show $ hsInit env (makeNullContinuation env) (Nil \"\") Nothing) "
    , "  case result of "
    , "    Just errMsg -> putStrLn errMsg "
    , "    _ -> return () "
    , " "
    , "hsInit env cont _ _ = do "
    , "  _ <- defineVar env \"" ++ moduleRuntimeVar ++ "\" $ HashTable $ Data.Map.fromList [] "
    , "  run env cont (Nil \"\") (Just [])"
    , " "]


{-# LANGUAGE CPP,OverloadedStrings,PatternGuards #-}
{-# OPTIONS_GHC -F -pgmF htfpp #-}
-- |
-- Module      : Language.Haskell.BuildWrapper.UsagesTests
-- Copyright   : (c) JP Moresmau 2013
-- License     : BSD3
--
-- Maintainer  : jpmoresmau@gmail.com
-- Stability   : beta
-- Portability : portable
--
-- Test usage generation
module Language.Haskell.BuildWrapper.UsagesTests where

import Language.Haskell.BuildWrapper.Base hiding (readFile,writeFile)

import Language.Haskell.BuildWrapper.CMDTests
import Test.Framework hiding (Success)
import Test.HUnit (Assertion)

import System.Directory
import System.FilePath

--import System.Time

import qualified Data.ByteString.Lazy as BS
-- import qualified Data.ByteString.Lazy.Char8 as BSC (putStrLn)
import qualified Data.ByteString as BSS
import Data.Aeson
import Data.Maybe

import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.HashMap.Lazy as HM
import qualified Data.Vector as V
import qualified Data.Aeson.Types (parse)

test_GenerateBWUsage :: Assertion
test_GenerateBWUsage = do
        let api=cabalAPI
        root<-createTestProject
        ((fps,dels),_)<-synchronize api root False
        assertBool (not $ null fps)
        assertBool (null dels)
        assertEqual (testProjectName <.> ".cabal") (head fps)
        let rel="src" </> "A.hs"
        assertBoolVerbose "no A" (rel `elem` fps)
        let bwI1=getUsageFile (root </> ".dist-buildwrapper" </>  rel)
        ef1<-doesFileExist bwI1
        assertBoolVerbose (bwI1 ++ "  file exists before build") (not ef1)
        (BuildResult bool1 fps1,nsErrors1)<-build api root False Source
        assertBool bool1
        assertBool (null nsErrors1)
        assertBool (rel `elem` fps1)
        assertBoolVerbose (bwI1 ++ "  file exists after build") (not ef1)
        (comps,_)<-getCabalComponents api root
        --c1<-getClockTime
        gar<-mapM (generateUsage api root False) comps
        let fs=concat $ mapMaybe fst gar
        assertBool (rel `elem` fs)
        --c2<-getClockTime
        -- putStrLn ("generateUsage: " ++ timeDiffToString (diffClockTimes c2 c1))
        ef2<-doesFileExist bwI1
        assertBoolVerbose (bwI1 ++ " file doesn't exist after generateAST") ef2
        gar2<-mapM (generateUsage api root  False) comps
        let fs2=concat $ mapMaybe fst gar2
        assertBool (rel `notElem` fs2)
        gar3<-mapM (generateUsage api root  True) comps
        let fs3=concat $ mapMaybe fst gar3
        assertBool (rel `elem` fs3)

test_GenerateReferencesSimple :: Assertion
test_GenerateReferencesSimple = do
        let api=cabalAPI
        root<-createTestProject
        let relMain="src"</>"Main.hs"
        writeFile (root</> relMain) $ unlines [
                  "module Main where",
                  "import A",
                  "main=print $ reset $ Cons2 1"
                  ]
        let rel="src" </> "A.hs"
        writeFile (root</> rel) $ unlines [
                  "module A where",
                  "data MyData=Cons1",
                  "      { mdS::MyString}",
                  "      | Cons2 Int",
                  "     deriving Show",
                  "",
                  "type MyString=String",
                  "",
                  "reset :: MyData -> MyData",
                  "reset (Cons1 _)=Cons1 \"\"",
                  "reset (Cons2 _)=Cons2 0",
                  "",
                  "resetAll=map reset",
                  "",
                  "getString :: MyData -> Maybe MyString",
                  "getString (Cons1 s)=Just s",
                  "getString _= Nothing"
                  ]
        _<-synchronize api root True
        (BuildResult bool1 _,nsErrors1)<-build api root False Source
        assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1)  bool1
        assertBool (null nsErrors1)
        (lib:exe:_,_)<-getCabalComponents api root
        --mapM_ (generateUsage api root False) comps
        generateUsage api root False lib
        let uf=getUsageFile $ root </> ".dist-buildwrapper" </> relMain
        euf1<-doesFileExist uf
        assertBool (not euf1)
        generateUsage api root False exe
        euf2<-doesFileExist uf
        assertBool euf2
        --sI<-fmap formatJSON (readFile  $ getInfoFile(root </> ".dist-buildwrapper" </>  rel))
        --putStrLn sI
        v<-readStoredUsage (root </> ".dist-buildwrapper" </>  rel)
        -- sU<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  rel))
        -- putStrLn sU

        assertPackageModule "BWTest-0.1" "A" [1,8,1,9] v

        assertVarUsage "BWTest-0.1" "A" "Cons1" [("MyData",True,[2,13,2,18]),("reset",False,[10,8,10,13]),("reset",False,[10,17,10,22]),("getString",False,[16,12,16,17])] v
        assertVarUsage "BWTest-0.1" "A" "Cons2" [("MyData",True,[4,9,4,14]),("reset",False,[11,8,11,13]),("reset",False,[11,17,11,22])] v
        assertVarUsage "BWTest-0.1" "A" "mdS" [("MyData",True,[3,9,3,12])] v
        assertVarUsage "BWTest-0.1" "A" "reset" [("reset",True,[9,1,9,6]),("reset",True,[10,1,10,25]),("reset",True,[11,1,11,24]),("resetAll",False,[13,14,13,19])] v
        assertVarUsage "BWTest-0.1" "A" "resetAll" [("resetAll",True,[13,1,13,19])] v
        assertVarUsage "BWTest-0.1" "A" "getString" [("getString",True,[15,1,15,10]),("getString",True,[16,1,16,27]),("getString",True,[17,1,17,21])] v
        assertVarUsage "base" "Data.Maybe" "Nothing" [("getString",False,[17,14,17,21])] v
        assertVarUsage "base" "Data.Maybe" "Just" [("getString",False,[16,21,16,25])] v
        assertVarUsage "base" "GHC.Base" "map" [("resetAll",False,[13,10,13,13])] v
        assertVarUsage "base" "GHC.Num" "fromInteger" [("reset",False,[11,23,11,24])] v

        assertTypeUsage "BWTest-0.1" "A" "MyData" [("MyData",True,[2,6,2,12]),("reset",False,[9,10,9,16]),("reset",False,[9,20,9,26]),("getString",False,[15,14,15,20])] v
        assertTypeUsage "BWTest-0.1" "A" "MyString" [("MyData",False,[3,14,3,22]),("MyString",True,[7,6,7,14]),("getString",False,[15,30,15,38])] v
        assertTypeUsage "base" "Data.Maybe" "Maybe" [("getString",False,[15,24,15,29])] v
        assertTypeUsage "base" "GHC.Base" "String" [("MyString",False,[7,15,7,21])] v
        assertTypeUsage "base" "GHC.Show" "Show" [("MyData",False,[5,15,5,19])] v
        assertTypeUsage "ghc-prim" "GHC.Types" "Int" [("MyData",False,[4,15,4,18])] v

        vMain<-readStoredUsage (root </> ".dist-buildwrapper" </>  relMain)
        --sUMain<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  relMain))
        --putStrLn sUMain
        assertPackageModule "BWTest-0.1" "Main" [1,8,1,12] vMain

        assertVarUsage "BWTest-0.1" "A" "" [("import",False,[2,8,2,9])] vMain
        assertVarUsage "BWTest-0.1" "A" "Cons2" [("main",False,[3,22,3,27])] vMain
        assertVarUsage "BWTest-0.1" "A" "reset" [("main",False,[3,14,3,19])] vMain
        assertVarUsage "BWTest-0.1" "Main" "main" [("main",True,[3,1,3,29])] vMain
        assertVarUsage "base" "System.IO" "print" [("main",False,[3,6,3,11])] vMain
        assertVarUsage "base" "GHC.Base" "$" [("main",False,[3,12,3,13]),("main",False,[3,20,3,21])] vMain
        return ()

test_GenerateReferencesImports :: Assertion
test_GenerateReferencesImports = do
        let api=cabalAPI
        root<-createTestProject
        let relMain="src"</>"Main.hs"
        writeFile (root</> relMain) $ unlines [
                  "module Main where",
                  "import Data.Ord",
                  "import Data.Maybe (Maybe(..))",
                  "import Data.Complex (Complex((:+)))",
                  "",
                  "main=undefined"
                  ]
        _<-synchronize api root True
        (BuildResult bool1 _,nsErrors1)<-build api root False Source
        assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1)  bool1
        assertBool (null nsErrors1)
        (comps,_)<-getCabalComponents api root
        mapM_ (generateUsage api root False) comps
        vMain<-readStoredUsage (root </> ".dist-buildwrapper" </>  relMain)
        -- sUMain<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  relMain))
        -- putStrLn sUMain
        assertVarUsage "base" "Data.Ord" "" [("import",False,[2,8,2,16])] vMain
        assertVarUsage "base" "Data.Maybe" "" [("import",False,[3,8,3,18])] vMain
        assertVarUsage "base" "Data.Complex" "" [("import",False,[4,8,4,20])] vMain
        assertTypeUsage "base" "Data.Maybe" "Maybe" [("import",False,[3,20,3,29])] vMain
        assertTypeUsage "base" "Data.Complex" "Complex" [("import",False,[4,22,4,35])] vMain
        assertVarUsage "base" "Data.Complex" ":+" [("import",False,[4,22,4,35])] vMain

test_GenerateReferencesExports :: Assertion
test_GenerateReferencesExports =  do
        let api=cabalAPI
        root<-createTestProject
        let rel="src" </> "A.hs"
        writeFile (root</> rel) $ unlines [
                  "module A (",
                  "    MyData,",
                  "    MyData2(..),",
                  "    MyData3(Cons31),",
                  "    reset,",
                  "    MyString,",
                  "    module Data.Ord) where",
                  "import Data.Ord",
                  "data MyData=Cons1",
                  "      { mdS::MyString}",
                  "      | Cons2 Int",
                  "     deriving Show",
                  "",
                  "type MyString=String",
                  "",
                  "reset :: MyData -> MyData",
                  "reset (Cons1 _)=Cons1 \"\"",
                  "reset (Cons2 _)=Cons2 0",
                  "",
                  "data MyData2=Cons21",
                  "      { mdS2::MyString}",
                  "      | Cons22 Int",
                  "     deriving Show",
                  "data MyData3=Cons31",
                  "      { mdS3::MyString}",
                  "      | Cons32 Int",
                  "     deriving Show"
                  ]
        _<-synchronize api root True
        (BuildResult bool1 _,nsErrors1)<-build api root False Source
        assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1)  bool1
        assertBool (null nsErrors1)
        (comps,_)<-getCabalComponents api root
        mapM_ (generateUsage api root False) comps
        v<-readStoredUsage (root </> ".dist-buildwrapper" </>  rel)
        --sU<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  rel))
        --putStrLn sU

        assertVarUsage "BWTest-0.1" "A" "Cons1" [("MyData",True,[9,13,9,18]),("reset",False,[17,8,17,13]),("reset",False,[17,17,17,22])] v
        assertVarUsage "BWTest-0.1" "A" "Cons2" [("MyData",True,[11,9,11,14]),("reset",False,[18,8,18,13]),("reset",False,[18,17,18,22])] v
        assertVarUsage "BWTest-0.1" "A" "Cons21" [("MyData2",True,[20,14,20,20])] v
        assertVarUsage "BWTest-0.1" "A" "Cons22" [("MyData2",True,[22,9,22,15])] v
        assertVarUsage "BWTest-0.1" "A" "Cons31" [("export",False,[4,5,4,20]),("MyData3",True,[24,14,24,20])] v
        assertVarUsage "BWTest-0.1" "A" "Cons32" [("MyData3",True,[26,9,26,15])] v
        assertVarUsage "BWTest-0.1" "A" "mdS" [("MyData",True,[10,9,10,12])] v
        assertVarUsage "BWTest-0.1" "A" "mdS2" [("MyData2",True,[21,9,21,13])] v
        assertVarUsage "BWTest-0.1" "A" "mdS3" [("MyData3",True,[25,9,25,13])] v
        assertVarUsage "BWTest-0.1" "A" "reset" [("export",False,[5,5,5,10]),("reset",True,[16,1,16,6]),("reset",True,[17,1,17,25]),("reset",True,[18,1,18,24])] v
        assertVarUsage "base" "GHC.Num" "fromInteger" [("reset",False,[18,23,18,24])] v

        assertVarUsage "base" "Data.Ord" "" [("export",False,[7,5,7,20]),("import",False,[8,8,8,16])] v

        assertTypeUsage "BWTest-0.1" "A" "MyData" [("export",False,[2,5,2,11]),("MyData",True,[9,6,9,12]),("reset",False,[16,10,16,16]),("reset",False,[16,20,16,26])] v
        assertTypeUsage "BWTest-0.1" "A" "MyString" [("export",False,[6,5,6,13]),("MyData",False,[10,14,10,22]),("MyString",True,[14,6,14,14]),("MyData2",False,[21,15,21,23]),("MyData3",False,[25,15,25,23])] v
        assertTypeUsage "base" "GHC.Base" "String" [("MyString",False,[14,15,14,21])] v
        assertTypeUsage "base" "GHC.Show" "Show" [("MyData",False,[12,15,12,19]),("MyData2",False,[23,15,23,19]),("MyData3",False,[27,15,27,19])] v
        assertTypeUsage "BWTest-0.1" "A" "MyData2" [("export",False,[3,5,3,16]),("MyData2",True,[20,6,20,13])] v
        assertTypeUsage "BWTest-0.1" "A" "MyData3" [("export",False,[4,5,4,20]),("MyData3",True,[24,6,24,13])] v
        assertTypeUsage "ghc-prim" "GHC.Types" "Int" [("MyData",False,[11,15,11,18]),("MyData2",False,[22,16,22,19]),("MyData3",False,[26,16,26,19])] v

test_GenerateReferencesExportAlias :: Assertion
test_GenerateReferencesExportAlias =  do
        let api=cabalAPI
        root<-createTestProject
        let relMain="src"</>"Main.hs"
        writeFile (root</> relMain) $ unlines [
                  "module Main (module X,main) where",
                  "import Data.Ord as X",
                  "",
                  "main=undefined"
                  ]
        _<-synchronize api root True
        (BuildResult bool1 _,nsErrors1)<-build api root False Source
        assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1)  bool1
        assertBool (null nsErrors1)
        (comps,_)<-getCabalComponents api root
        mapM_ (generateUsage api root False) comps
        vMain<-readStoredUsage (root </> ".dist-buildwrapper" </>  relMain)
        -- sUMain<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  relMain))
        -- putStrLn sUMain
        assertVarUsage "base" "Data.Ord" "" [("export",False,[1,14,1,22]),("import",False,[2,8,2,16])] vMain

test_GenerateReferencesPattern :: Assertion
test_GenerateReferencesPattern =  do
        let api=cabalAPI
        root<-createTestProject
        let relMain="src"</>"Main.hs"
        writeFile (root</> relMain) $ unlines [
                  "module Main where",
                  "",
                  "main=undefined",
                  "f :: Maybe String -> String",
                  "f mf=case mf of",
                  "  Just x->x",
                  "  _->\"\""
                  ]
        _<-synchronize api root True
        (BuildResult bool1 _,nsErrors1)<-build api root False Source
        assertBoolVerbose ("returned false on bool1:" ++ show nsErrors1)  bool1
        assertBool (null nsErrors1)
        (comps,_)<-getCabalComponents api root
        mapM_ (generateUsage api root False) comps
        vMain<-readStoredUsage (root </> ".dist-buildwrapper" </>  relMain)
        -- sUMain<-fmap formatJSON (readFile  $ getUsageFile(root </> ".dist-buildwrapper" </>  relMain))
        -- putStrLn sUMain
        assertVarUsage "base" "Data.Maybe" "Just" [("f",False,[6,3,6,7])] vMain

test_IncorrectModuleFileName :: Assertion
test_IncorrectModuleFileName = do
        let api=cabalAPI
        root<-createTestProject
        let relMain="src"</>"Main.hs"
        let relMain2="src"</>"Main-exe.hs"
        renameFile (root </> relMain) (root </> relMain2)
        let cf=testCabalFile root
        writeFile cf $ unlines ["name: "++testProjectName,
                "version:0.1",
                "cabal-version:  >= 1.8",
                "build-type:     Simple",
                "",
                "library",
                "  hs-source-dirs:  src",
                "  exposed-modules: A",
                "  other-modules:  B.C",
                "  build-depends:  base",
                "",
                "executable BWTest",
                "  hs-source-dirs:  src",
                "  main-is:         Main-exe.hs",
                "  other-modules:  B.D",
                "  build-depends:  base",
                "",
                "test-suite BWTest-test",
                "  type:            exitcode-stdio-1.0",
                "  hs-source-dirs:  test",
                "  main-is:         Main.hs",
                "  other-modules:  TestA",
                "  build-depends:  base",
                ""
                ]
        synchronize api root False
        configure api root Target
        (comps,_)<-getCabalComponents api root
        gar<-mapM (generateUsage api root False) comps
        let fs=concat $ mapMaybe fst gar
        assertBool (relMain2 `elem` fs)

getUsageFile :: FilePath -- ^ the source file
        -> FilePath
getUsageFile fp= let
        (dir,file)=splitFileName fp
        in combine dir ('.' : addExtension file ".bwusage")

readStoredUsage :: FilePath  -- ^ the source file
        -> IO Value
readStoredUsage =readJSONFile . getUsageFile

readJSONFile :: FilePath -> IO Value
readJSONFile f= do
       ex<-doesFileExist f
       mv<-if ex
                then do
                       bs<-BSS.readFile f
                       return $ decode' $ BS.fromChunks [bs]
                else return Nothing
       return $ fromMaybe (object []) mv

getInfoFile :: FilePath -- ^ the source file
        -> FilePath
getInfoFile fp= let
        (dir,file)=splitFileName fp
        in combine dir ('.' : addExtension file ".bwinfo")

-- | read the top JSON value containing all the information
readStoredInfo :: FilePath  -- ^ the source file
        -> IO Value
readStoredInfo =readJSONFile . getInfoFile

extractNameValue :: Value -> T.Text
extractNameValue (Object m) |Just (String s)<-HM.lookup "Name" m=s
extractNameValue _ = error "no name in value"

assertVarUsage :: T.Text -> T.Text -> T.Text -> [(T.Text,Bool,[Int])] -> Value -> IO()
assertVarUsage = assertUsage "vars"

assertTypeUsage :: T.Text -> T.Text -> T.Text -> [(T.Text,Bool,[Int])] -> Value -> IO()
assertTypeUsage = assertUsage "types"

assertUsage :: T.Text -> T.Text -> T.Text -> T.Text -> [(T.Text,Bool,[Int])] -> Value -> IO()
assertUsage tp pkg modu name lins (Array v) |
        V.length v==5,
        (Object m) <-v V.! 3,
        Just (Object m2)<-HM.lookup pkg m,
        Just (Object m3)<-HM.lookup modu m2,
        Just (Object m4)<-HM.lookup tp m3,
        Just (Array arr)<-HM.lookup name m4=   do
                let expected=S.fromList $ map (\(section,def,[sl,sc,el,ec])->(section,def,InFileSpan (InFileLoc sl sc) (InFileLoc el ec))) lins
                let actual=S.fromList $ map (\v2->
                        let (Success r)=Data.Aeson.Types.parse (\(Object o) ->do
                                --Success (Object o)<-fromJSON v
                                (String section)<-o .: "s"
                                (Bool def)<-o .: "d"
                                arr2<-o .: "l"
                                let (Success ifl)=fromJSON arr2
                                return (section,def,ifl::InFileSpan)) v2
                        in r) $ V.toList arr
                assertEqualVerbose (T.unpack modu ++ "." ++ T.unpack name ++ ": " ++ show lins) expected actual
        --V.elem (Number (I line)) arr=return ()
assertUsage _ _ modu name line _=assertFailure (T.unpack modu ++ "." ++ T.unpack name ++ ": " ++ show line)

assertPackageModule :: T.Text -> T.Text -> [Int] -> Value -> IO()
assertPackageModule pkg modu [sl,sc,el,ec] (Array v) |
         V.length v==5,
        (String s0) <-v V.! 0,
        (String s1) <-v V.! 1,
        arr<- v V.! 2= do
                assertEqualVerbose (T.unpack pkg) pkg s0
                assertEqualVerbose (T.unpack modu) modu s1
                let (Success ifs)=fromJSON arr
                assertEqualVerbose (show ifs) (InFileSpan (InFileLoc sl sc) (InFileLoc el ec)) ifs
assertPackageModule pkg modu _ _=  assertFailure (T.unpack pkg ++ "." ++ T.unpack modu)


module ML.Gym.Util
    ( python
    ) where

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

onException :: Py.Exception -> IO a
onException exc = Py.print (Py.exceptionValue exc) stdout >> exitFailure

python :: IO a -> IO a
python = E.handle onException