exference.hs

-- Main.hs
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternGuards #-}

module Main
  ( main
  )
where



import Language.Haskell.Exference.Core ( ExferenceChunkElement(..)
                                       , ExferenceHeuristicsConfig(..)
                                       , findExpressionsWithStats )
import Language.Haskell.Exference
import Language.Haskell.Exference.ExpressionToHaskellSrc
import Language.Haskell.Exference.BindingsFromHaskellSrc
import Language.Haskell.Exference.ClassEnvFromHaskellSrc
import Language.Haskell.Exference.TypeFromHaskellSrc
import Language.Haskell.Exference.TypeDeclsFromHaskellSrc
import Language.Haskell.Exference.Core.FunctionBinding
import Language.Haskell.Exference.EnvironmentParser

import Language.Haskell.Exference.SimpleDict
import Language.Haskell.Exference.Core.Types
import Language.Haskell.Exference.Core.TypeUtils
import Language.Haskell.Exference.Core.Expression
import Language.Haskell.Exference.Core.ExpressionSimplify
import Language.Haskell.Exference.Core.ExferenceStats
import Language.Haskell.Exference.Core.SearchTree

import Control.DeepSeq

import System.Process hiding ( env )

import Control.Applicative ( (<$>), (<*>) )
import Control.Arrow ( first, second, (***) )
import Control.Monad ( when, forM_, guard, forM, mplus, mzero )
import Data.List ( sortBy, find, intersect, intersperse, intercalate, nub )
import Data.Ord ( comparing )
import Text.Printf
import Data.Maybe ( listToMaybe, fromMaybe, maybeToList )
import Data.Either ( lefts, rights )
import Data.Functor.Identity ( runIdentity )
import Control.Monad.Writer.Strict
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.IntMap as IntMap

import Language.Haskell.Exts.Syntax ( Module(..), Decl(..), ModuleName(..) )
import Language.Haskell.Exts.Parser ( parseModuleWithMode
                                    , parseModule
                                    , ParseResult (..)
                                    , ParseMode (..)
                                    , defaultParseMode )
import Language.Haskell.Exts.Extension ( Language (..)
                                       , Extension (..)
                                       , KnownExtension (..) )
import Language.Haskell.Exts.Pretty

import Control.Monad.Trans.MultiRWS
import Control.Monad.Trans.Either

import Data.PPrint
import Data.Tree ( Tree(..) )


import MainConfig
import MainTest

import Paths_exference
import qualified Flags_exference

import System.Environment ( getArgs )
import System.Console.GetOpt
import Data.Version ( showVersion )
import System.IO ( hSetBuffering, BufferMode(..), stdout, stderr )

import Debug.Hood.Observe

import Debug.Trace



data Flag = Verbose Int
          | Version
          | Help
          | Tests
          | Examples
          | PrintEnv
          | EnvDir String
          | Input String
          | PrintAll
          | PrintTree -- TODO: more options to control core
          | EnvUsage -- TODO: option to specify dictionary to use
          | Serial
          | Parallel
          | Shortest
          | FirstSol
          | Best
          | Unused
          | PatternMatchMC
          | Qualification Int
          | Constraints
          | AllowFix
  deriving (Show, Eq)

options :: [OptDescr Flag]
options =
  [ Option []    ["version"]     (NoArg Version)       ""
  , Option []    ["help"]        (NoArg Help)          "prints basic program info"
  , Option ['t'] ["tests"]       (NoArg Tests)         "run the standard validity/performance tests"
  , Option ['x'] ["examples"]    (NoArg Examples)      "prints the first few results for the examples; useful for debugging"
  , Option ['p'] ["printenv"]    (NoArg PrintEnv)      "print the environment to be used for queries"
  , Option ['e'] ["envdir"]      (ReqArg EnvDir "PATH") "path to environment directory"
  , Option ['v'] ["verbose"]     (OptArg (Verbose . maybe 1 read) "INT") "verbosity"
  , Option ['i'] ["input"]       (ReqArg Input "HSTYPE") "the type for which to generate an expression"
  , Option ['a'] ["all"]         (NoArg PrintAll)      "print all solutions (up to search step limit)"
  , Option []    ["envUsage"]    (NoArg EnvUsage)      "print a list of functions that got inserted at some point (regardless if successful or not), and how often"
  , Option []    ["tree"]        (NoArg PrintTree)     "print tree of search space"
  , Option []    ["serial"]      (NoArg Serial)        "use the non-parallelized version of the algorithm (default)"
  , Option ['j'] ["parallel"]    (NoArg Parallel)      "use the parallelized version of the algorithm"
  , Option ['o'] ["short"]       (NoArg Shortest)      "prefer shorter solutions"
  , Option ['f'] ["first"]       (NoArg FirstSol)      "stop after finding the first solution"
  , Option []    ["fix"]         (NoArg AllowFix)      "allow the `fix` function in the environment"
  , Option ['b'] ["best"]        (NoArg Best)          "calculate all solutions, and print the best one"
  , Option ['u'] ["allowUnused"] (NoArg Unused)        "allow unused input variables"
  , Option ['c'] ["patternMatchMC"] (NoArg PatternMatchMC) "pattern match on multi-constructor data types (might lead to hang-ups at the moment)"
  , Option ['q'] ["fullqualification"] (NoArg $ Qualification 2) "fully qualify the identifiers in the output"
  , Option []    ["somequalification"] (NoArg $ Qualification 1) "fully qualify non-operator-identifiers in the output"
  , Option ['w'] ["allowConstraints"] (NoArg Constraints) "allow additional (unproven) constraints in solutions"
  ]

mainOpts :: [String] -> IO ([Flag], [String])
mainOpts argv =
  case getOpt Permute options argv of
    (o, n, []  )  | inputs <- [x | (Input x) <- o] ++ n
                  -> if null (intersect o [Version, Help, Tests, Examples, PrintEnv])
                     && null inputs
                    then return (Tests:o, inputs)
                    else return (o      , inputs)
    (_,  _, errs) -> ioError (userError (concat errs ++ fullUsageInfo))

fullUsageInfo :: String
fullUsageInfo = usageInfo header options
  where
    header = "Usage: exference [OPTION...]"

main :: IO ()
main = runO $ do
  hSetBuffering stdout LineBuffering
  hSetBuffering stderr LineBuffering
  argv <- getArgs
  defaultEnvPath <- getDataFileName "environment"
  (flags, inputs) <- mainOpts argv
  let verbosity = sum $ [x | Verbose x <- flags ]
  let qualification = head $ [x | Qualification x <- flags] ++ [0]
  let
    printVersion = do
      putStrLn $ "exference version " ++ showVersion version
  if | [Version] == flags   -> printVersion
     | Help    `elem` flags -> putStrLn fullUsageInfo >> putStrLn "TODO"
     | otherwise -> runMultiRWSTNil_ $ do
        par <- case (Parallel `elem` flags, Serial `elem` flags) of
          (False,False) -> return False
          (True, False) -> return True
          (False,True ) -> return False
          (True, True ) ->
            error "--serial and --parallel are in conflict! aborting"
        when (Version `elem` flags || verbosity>0) $ lift printVersion
        -- ((eSignatures, StaticClassEnv clss insts), messages) <- runWriter <$> parseExternal testBaseInput'
        let envDir = fromMaybe defaultEnvPath $ listToMaybe [d | EnvDir d <- flags]
        when (verbosity>0) $ lift $ do
          putStrLn $ "[Environment]"
          putStrLn $ "reading environment from " ++ envDir
        ( (eSignatures
          , eDeconss
          , sEnv@(StaticClassEnv clss insts)
          , validNames
          , tdeclMap )
         ,messages :: [String] ) <- withMultiWriterAW $ environmentFromPath envDir
        let
          env = (eSignatures, eDeconss, sEnv)
        when (verbosity>0 && not (null messages)) $ lift $
          forM_ messages $ \m -> putStrLn $ "environment warning: " ++ m
        when (PrintEnv `elem` flags) $ lift $ do
          when (verbosity>0) $ putStrLn "[Environment]"
          mapM_ print $ M.elems tdeclMap
          mapM_ print $ clss
          mapM_ print $ [(i,x)| (i,xs) <- M.toList insts, x <- xs]
          mapM_ print $ eSignatures
          mapM_ print $ eDeconss
        when (Examples `elem` flags) $ do
          when (verbosity>0) $ lift $ putStrLn "[Examples]"
          printAndStuff testHeuristicsConfig env
        when (Tests `elem` flags) $ do
          when (verbosity>0) $ lift $ putStrLn "[Tests]"
          withMultiReader tdeclMap $ printCheckExpectedResults
                                       testHeuristicsConfig { heuristics_solutionLength = 0.0 }
                                       env
        case inputs of
          []    -> return () -- probably impossible..
          (x:_) -> do
            when (verbosity>0) $ lift $ putStrLn "[Custom Input]"
            eParsedType <- runEitherT $ parseType (sClassEnv_tclasses sEnv)
                                                  Nothing
                                                  validNames
                                                  tdeclMap
                                                  (haskellSrcExtsParseMode "inputtype")
                                                  x
            case eParsedType of
              Left err -> lift $ do
                putStrLn $ "could not parse input type: " ++ err
              Right (parsedType, tVarIndex) -> do
                let typeStr = showHsType tVarIndex parsedType
                when (verbosity>0) $ lift $ putStrLn $ "input type parsed as: " ++ typeStr
                let unresolvedIdents = findInvalidNames validNames parsedType
                when (not $ null unresolvedIdents) $ lift $ do
                  putStrLn $ "warning: unresolved idents in input: "
                           ++ intercalate ", " (nub $ show <$> unresolvedIdents)
                  putStrLn $ "(this may be harmless, but no instances will be connected to these.)"
                let hidden = if AllowFix `elem` flags then [] else ["fix", "forever", "iterateM_"]
                let filteredBindings = filterBindingsSimple hidden eSignatures
                let input = ExferenceInput
                      parsedType
                      filteredBindings
                      eDeconss
                      sEnv
                      (Unused `elem` flags)
                      (Constraints `elem` flags)
                      8192
                      (PatternMatchMC `elem` flags)
                      65536
                      (Just 8192)
                      (if Shortest `elem` flags then
                         testHeuristicsConfig
                       else
                         testHeuristicsConfig { heuristics_solutionLength = 0.0 })
                when (verbosity>0) $ lift $ do
                  putStrLn $ "full input:"
                  doc <- pprint input
                  print doc
                if
                  | PrintAll `elem` flags -> do
                      when (verbosity>0) $ lift $ putStrLn "[running findExpressions ..]"
                      let rs = findExpressions input
                      if null rs
                        then lift $ putStrLn "[no results]"
                        else forM_ rs
                          $ \(e, constrs, ExferenceStats n d m) -> do
                            let hsE = convert qualification $ simplifyExpression e
                            lift $ putStrLn $ prettyPrint hsE
                            when (not $ null constrs) $ do
                              let constrStrs = map (showHsConstraint tVarIndex)
                                             $ S.toList
                                             $ S.fromList
                                             $ constrs
                              lift $ putStrLn $ "but only with additional contraints: " ++ intercalate ", " constrStrs
                            lift $ putStrLn $ replicate 40 ' ' ++ "(depth " ++ show d
                                        ++ ", " ++ show n ++ " steps, " ++ show m ++ " max pqueue size)"
                  | PrintTree `elem` flags ->
                      if not Flags_exference.buildSearchTree
                        then lift $ putStrLn "exference-core was not compiled with flag \"buildSearchTree\""
                        else do
#if BUILD_SEARCH_TREE
                          when (verbosity>0) $ lift $ putStrLn "[running findExpressionsWithStats ..]"
                          let tree = chunkSearchTree $ last $ findExpressionsWithStats
                                   $ input {input_maxSteps = 8192}
                          let showf (total,processed,expression)
                                = ( printf "%d (+%d):" processed (total-processed)
                                  , showExpressionPure qNameIndex $ simplifyExpression expression
                                  )
                          let
                            helper :: String -> Tree (String, String) -> [String]
                            helper indent (Node (n,m) ts) =
                              (printf "%-50s %s" (indent ++ n) m)
                              : concatMap (helper ("  "++indent)) ts
                          (lift . putStrLn) `mapM_` helper "" (showf <$> filterSearchTreeProcessedN 64 tree)
#endif
                          return ()
                          -- putStrLn . showf `mapM_` draw
                          --   -- $ filterSearchTreeProcessedN 2
                          --   tree
                  | EnvUsage `elem` flags -> lift $ do
                      when (verbosity>0) $ putStrLn "[running findExpressionsWithStats ..]"
                      let stats = chunkBindingUsages $ last $ findExpressionsWithStats input
                          highest = take 8 $ sortBy (flip $ comparing snd) $ M.toList stats
                      putStrLn $ show $ highest
                  | otherwise -> do
                      r <- if
                        | FirstSol `elem` flags -> if par
                          then lift $ do
                            putStrLn $ "WARNING: parallel version not implemented for given flags, falling back to serial!"
                            when (verbosity>0) $ putStrLn "[running findOneExpression ..]"
                            return $ maybeToList $ findOneExpression input
                          else lift $ do
                            when (verbosity>0) $ putStrLn "[running findOneExpression ..]"
                            return $ maybeToList $ findOneExpression input
                        | Best `elem` flags -> if par
                          then lift $ do
                            putStrLn $ "WARNING: parallel version not implemented for given flags, falling back to serial!"
                            when (verbosity>0) $ putStrLn "[running findBestNExpressions ..]"
                            return $ findBestNExpressions 999 input
                          else lift $ do
                            when (verbosity>0) $ putStrLn "[running findBestNExpressions ..]"
                            return $ findBestNExpressions 999 input
                        | otherwise -> if par
                          then lift $ do
                            putStrLn $ "WARNING: parallel version not implemented for given flags, falling back to serial!"
                            when (verbosity>0) $ putStrLn "[running findFirstBestExpressionsLookaheadPreferNoConstraints ..]"
                            return $ findFirstBestExpressionsLookaheadPreferNoConstraints 256 input
                          else lift $ do
                            if Constraints `elem` flags
                              then do
                                when (verbosity>0) $ putStrLn "[running findFirstBestExpressionsLookahead ..]"
                                return $ findFirstBestExpressionsLookahead 256 input
                              else do
                                when (verbosity>0) $ putStrLn "[running findFirstBestExpressionsLookaheadPreferNoConstraints ..]"
                                return $ findFirstBestExpressionsLookaheadPreferNoConstraints 256 input {input_allowConstraints = True}
                      case r :: [ExferenceOutputElement] of
                        [] -> lift $ putStrLn "[no results]"
                        rs -> rs `forM_` \(e, constrs, ExferenceStats n d m) -> do
                            let hsE = convert qualification $ simplifyExpression e
                            lift $ putStrLn $ prettyPrint hsE
                            when (not $ null constrs) $ do
                              let constrStrs = map (showHsConstraint tVarIndex)
                                             $ S.toList
                                             $ S.fromList
                                             $ constrs
                              lift $ putStrLn $ "but only with additional contraints: " ++ intercalate ", " constrStrs
                            lift $ putStrLn $ replicate 40 ' ' ++ "(depth " ++ show d
                                       ++ ", " ++ show n ++ " steps, " ++ show m ++ " max pqueue size)"

        -- printChecks     testHeuristicsConfig env
        -- printStatistics testHeuristicsConfig env

        -- print $ compileDict testDictRatings $ eSignatures
        -- print $ parseConstrainedType defaultClassEnv $ "(Show a) => [a] -> String"
        -- print $ inflateHsConstraints a b
        {-
        let t :: HsType
            t = read "m a->( ( a->m b)->( m b))"
        print $ t
        -}

_pointfree :: String -> IO String
_pointfree s = (!!1) <$> lines <$> readProcess "pointfree" ["--verbose", s] ""

_pointful :: String -> IO String
_pointful s = (!!0) <$> lines <$> readProcess "pointful" [s] ""

_tryParse :: Bool -> String -> IO ()
_tryParse shouldBangPattern s = do
  content <- readFile $ "/home/lsp/asd/prog/haskell/exference/BaseContext/preprocessed/"++s++".hs"
  let exts1 = (if shouldBangPattern then (BangPatterns:) else id)
              [ UnboxedTuples
              , TypeOperators
              , MagicHash
              , NPlusKPatterns
              , ExplicitForAll
              , ExistentialQuantification
              , TypeFamilies
              , PolyKinds
              , DataKinds ]
      exts2 = map EnableExtension exts1
  case parseModuleWithMode (ParseMode (s++".hs")
                                      Haskell2010
                                      exts2
                                      False
                                      False
                                      Nothing
                                      False
                           )
                           content of
    f@(ParseFailed _ _) -> do
      print f
    ParseOk _modul -> do
      putStrLn s
      --mapM_ putStrLn $ map (either id show)
      --               $ getBindings defaultClassEnv mod
      --mapM_ putStrLn $ map (either id show)
      --               $ getDataConss mod
      --mapM_ putStrLn $ map (either id show)
      --               $ getClassMethods defaultClassEnv mod

-- MainTest.hs
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MonadComprehensions #-}

module MainTest
  ( printAndStuff
  , printCheckExpectedResults
  , printStatistics
  , printMaxUsage
#if BUILD_SEARCH_TREE
  , printSearchTree
#endif
  , filterBindingsSimple -- TODO: refactor/move this
  )
where



import Language.Haskell.Exference.Core ( ExferenceHeuristicsConfig(..)
                                       , findExpressionsWithStats
                                       , ExferenceChunkElement(..)
                                       )
import Language.Haskell.Exference
import Language.Haskell.Exference.ExpressionToHaskellSrc
import Language.Haskell.Exference.BindingsFromHaskellSrc
import Language.Haskell.Exference.ClassEnvFromHaskellSrc
import Language.Haskell.Exference.TypeFromHaskellSrc
import Language.Haskell.Exference.TypeDeclsFromHaskellSrc
import Language.Haskell.Exference.Core.FunctionBinding

import Language.Haskell.Exference.Core.Types
import Language.Haskell.Exference.Core.TypeUtils
import Language.Haskell.Exference.Core.Expression
import Language.Haskell.Exference.Core.ExpressionSimplify
import Language.Haskell.Exference.Core.ExferenceStats
import Language.Haskell.Exference.Core.SearchTree

import Control.DeepSeq

import Control.Applicative ( (<$>), (<*>) )
import Control.Arrow ( second, (***) )
import Control.Monad ( when, forM_, guard, forM, mplus, mzero )
import Data.Functor.Identity ( Identity, runIdentity )
import Data.List ( sortBy, find, intercalate, maximumBy )
import Data.Ord ( comparing )
import Text.Printf
import Data.Maybe ( listToMaybe, fromMaybe, maybeToList, catMaybes )
import Data.Either ( lefts, rights )
import Control.Monad.Writer.Strict
import qualified Data.Map as M
import qualified Data.IntMap as IntMap
import Data.Tree ( drawTree )
import Control.Monad.Trans.Maybe ( MaybeT (..) )
import Data.Foldable ( asum )

import Control.Monad.Trans.MultiRWS
import Data.HList.ContainsType

import Language.Haskell.Exts.Syntax ( Module(..), Decl(..), ModuleName(..) )
import Language.Haskell.Exts.Parser ( parseModuleWithMode
                                    , parseModule
                                    , ParseResult (..)
                                    , ParseMode (..) )
import Language.Haskell.Exts.Extension ( Language (..)
                                       , Extension (..)
                                       , KnownExtension (..) )

-- import Data.PPrint

-- import Debug.Hood.Observe
import Debug.Trace



checkData :: [(String, Bool, Bool, String, [String], [String])]
checkData =
  [ (,,,,,) "showmap"    False False "(Text.Show.Show b) => (a -> b) -> [a] -> [String]"
                                     ["\\f1 -> Data.Functor.fmap (\\g -> Text.Show.show (f1 g))"
                                     ,"\\f1 -> Data.Functor.fmap (((.) Text.Show.show) f1)"
                                     ,"\\f1 -> (\\c -> ((Control.Monad.>>=) c) (\\g -> Control.Applicative.pure (Text.Show.show (f1 g))))"]
                                     []
  , (,,,,,) "ffbind"     False False "(a -> t -> b) -> (t -> a) -> (t -> b)"
                                     ["\\f1 -> (\\f2 -> (\\c -> (f1 (f2 c)) c))"]
                                     []
  , (,,,,,) "join"       False False "(Monad m) => m (m a) -> m a"
                                     ["\\a -> ((Control.Monad.>>=) a) (\\f -> f)"
                                     ,"\\a -> ((Control.Monad.>>=) a) id"
                                     ]
                                     ["join"]
  , (,,,,,) "fjoin"      False False "(t -> (t -> a)) -> t -> a"
                                     ["\\f1 -> (\\b -> (f1 b) b)"]
                                     []
  , (,,,,,) "zipThingy"  False False "[a] -> b -> [(a, b)]"
                                     ["\\as -> (\\b -> ((Data.Functor.fmap (\\g -> ((,) g) b)) as)"
                                     ,"\\as -> (\\b -> (Data.List.zip as) (Control.Applicative.pure b))"
                                     ,"\\as -> ((.) (Data.List.zip as)) Control.Applicative.pure"
                                     ]
                                     []
  , (,,,,,) "pmatch"     False True  "Data.Maybe.Maybe a -> a -> a"
                                     ["\\m1 -> (\\b -> ((Data.Maybe.maybe b) (\\h -> h)) m1)"
                                     ,"\\m1 -> (\\b -> case m1 of { Data.Maybe.Just d -> d; Data.Maybe.Nothing  -> b })"]
                                     []
  --, (,,,,,) "pmatch2"    False True  "Tuple2 (Either a b) c -> Tuple2 (Maybe (Tuple2 a c)) (Maybe (Tuple2 b c))"
  --                                  []
  --                                   []
  , (,,,,,) "stateRun"   True  False "Control.Monad.State.State a b -> a -> b"
                                     ["\\s1 -> (\\b -> let (Control.Monad.State.State f4) = s1 in let ((,) g h) = f4 b in g)"]
                                     []
  , (,,,,,) "fst"        True  False "(a, b) -> a"
                                     ["\\a -> let ((,) c d) = a in c"]
                                     []
  --, (,,,,,) "ffst"       True False  "(a -> Tuple b c) -> a -> b"
  , (,,,,,) "snd"        True  False "(a, b) -> b"
                                     ["\\a -> let ((,) c d) = a in d"]
                                     []
  , (,,,,,) "quad"       False False "a -> ((a, a), (a, a))"
                                     ["\\a -> ((,) (((,) a) a)) (((,) a) a)"]
                                     []
  -- , (,,,,,) "fswap"     False False  "(a -> Tuple b c) -> a -> Tuple c b"
  , (,,,,,) "liftBlub"   False False "Monad m => m a -> m b -> (a -> b -> m c) -> m c"
                                     ["\\a -> (\\b -> (\\f3 -> ((Control.Monad.>>=) a) (\\g -> ((Control.Monad.>>=) b) (f3 g))))"
                                     ,"\\a -> (\\b -> (\\f3 -> ((Control.Monad.>>=) b) (\\g -> ((Control.Monad.>>=) a) (\\k -> (f3 k) g))))"]
                                     []
  , (,,,,,) "stateBind"  False False "Control.Monad.State.State s a -> (a -> Control.Monad.State.State s b) -> Control.Monad.State.State s b"
                                     ["\\s1 -> (\\f2 -> let (Control.Monad.State.State f4) = s1 in Control.Monad.State.State (\\f -> let ((,) j k) = f4 f in let (Control.Monad.State.State f14) = f2 j in f14 k))"]
                                     []
  , (,,,,,) "dbMaybe"    False False "Data.Maybe.Maybe a -> Data.Maybe.Maybe (a, a)"
                                     ["Data.Functor.fmap (\\e -> ((,) e) e)"
                                     ,"\\b -> ((Control.Applicative.liftA2 (\\g -> (\\h -> ((,) h) g))) b) b"
                                     ,"\\b -> ((Control.Monad.>>=) b) (\\f -> Control.Applicative.pure (((,) f) f))"]
                                     []
  , (,,,,,) "tupleShow"  False False "(Text.Show.Show a, Text.Show.Show b) => (a, b) -> String"
                                     ["Text.Show.show"
                                     ,"\\a -> let ((,) c d) = a in Text.Show.show (((,) c) d)"]
                                     []
  , (,,,,,) "FloatToInt" False False "Float -> Int"
                                     [ "Prelude.round"
                                     , "Prelude.floor"
                                     , "Prelude.truncate"
                                     , "Prelude.ceiling"
                                     ]
                                     []
  , (,,,,,) "FloatToIntL" False False "[Float] -> [Int]"
                                     ["Data.Functor.fmap Prelude.round"
                                     ,"Data.Functor.fmap Prelude.floor"
                                     ,"Data.Functor.fmap Prelude.ceiling"
                                     ,"Data.Functor.fmap Prelude.truncate"
                                     ,"\\b -> ((>>=) b) (\\f -> Control.Applicative.pure (Prelude.truncate f))" -- this is kind of ugly
                                     ,"((.) (Data.Functor.fmap Data.Char.ord)) Text.Show.show" -- this is not the solution we really want .. :/
                                     ]
                                     []
  , (,,,,,) "longApp"    False False "a -> b -> c -> (a -> b -> d) -> (a -> c -> e) -> (b -> c -> f) -> (d -> e -> f -> g) -> g"
                                     ["\\a -> (\\b -> (\\c -> (\\f4 -> (\\f5 -> (\\f6 -> (\\f7 -> ((f7 ((f4 a) b)) ((f5 a) c)) ((f6 b) c)))))))"]
                                     []
  , (,,,,,) "liftSBlub"  False False "(Monad m, Monad n) => ([a] -> b -> c) -> m [n a] -> m (n b) -> m (n c)"
                                     ["\\f1 -> Control.Applicative.liftA2 (\\i -> (\\j -> ((Control.Monad.>>=) (Data.Traversable.sequenceA i)) (\\o -> ((Control.Monad.>>=) j) (\\s -> Control.Applicative.pure ((f1 o) s)))))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Applicative.liftA2 (\\i -> (\\j -> ((Control.Monad.>>=) (Data.Traversable.sequenceA j)) (\\o -> ((Control.Monad.>>=) i) (\\s -> Control.Applicative.pure ((f1 o) s)))))) c) b))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> (Data.Functor.fmap (\\k -> ((Control.Monad.>>=) (Data.Traversable.sequenceA gs)) (\\p -> (Data.Functor.fmap (f1 p)) k))) c)))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\g -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) (Data.Traversable.sequenceA ks)) (\\p -> (Data.Functor.fmap (f1 p)) g))) b)))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\g -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) g) (\\p -> (Data.Functor.fmap (\\t -> (f1 t) p)) ((Data.Traversable.mapM (\\z -> z)) ks)))) b)))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\g -> ((Control.Monad.>>=) b) (\\ks -> Control.Applicative.pure (((Control.Monad.>>=) g) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) ((Data.Traversable.mapM (\\t0 -> t0)) ks)))))))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> ((Control.Monad.>>=) c) (\\k -> Control.Applicative.pure (((Control.Monad.>>=) k) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) ((Data.Traversable.mapM (\\t0 -> t0)) gs)))))))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> ((Control.Monad.>>=) c) (\\k -> Control.Applicative.pure (((Control.Monad.>>=) k) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) (sequence gs)))))))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\g -> ((Control.Monad.>>=) b) (\\ks -> Control.Applicative.pure (((Control.Monad.>>=) g) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) (sequence ks)))))))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\g -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) ((Data.Traversable.mapM (\\t -> t)) ks)) (\\r -> (Data.Functor.fmap (f1 r)) g))) b)))"]
                                     []
  , (,,,,,) "liftSBlubS" False False "Monad m => ([a] -> b -> c) -> m [Data.Maybe.Maybe a] -> m (Data.Maybe.Maybe b) -> m (Data.Maybe.Maybe c)"
                                     ["\\f1 -> Control.Applicative.liftA2 (\\i -> (\\j -> ((Control.Monad.>>=) j) (\\n -> (Data.Functor.fmap (\\r -> (f1 r) n)) (Data.Traversable.sequenceA i))))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Applicative.liftA2 (\\i -> (\\j -> ((Control.Monad.>>=) i) (\\n -> (Data.Functor.fmap (\\r -> (f1 r) n)) (Data.Traversable.sequenceA j))))) c) b))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> (Data.Functor.fmap (\\m11 -> ((Control.Monad.>>=) (Data.Traversable.sequenceA gs)) (\\p -> (Data.Functor.fmap (f1 p)) m11))) c)))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\m7 -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) (Data.Traversable.sequenceA ks)) (\\p -> (Data.Functor.fmap (f1 p)) m7))) b)))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> (Data.Functor.fmap (\\m11 -> ((Control.Monad.>>=) (Prelude.sequence gs)) (\\p -> (Data.Functor.fmap (f1 p)) m11))) c)))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\m7 -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) m7) (\\p -> (Data.Functor.fmap (\\t -> (f1 t) p)) ((Data.Traversable.mapM (\\z -> z)) ks)))) b)))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\m7 -> ((Control.Monad.>>=) b) (\\ks -> Control.Applicative.pure (((Control.Monad.>>=) m7) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) ((Data.Traversable.mapM (\\t0 -> t0)) ks)))))))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> ((Control.Monad.>>=) c) (\\m11 -> Control.Applicative.pure (((Control.Monad.>>=) m11) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) ((Data.Traversable.mapM (\\t0 -> t0)) gs)))))))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) b) (\\gs -> ((Control.Monad.>>=) c) (\\m11 -> Control.Applicative.pure (((Control.Monad.>>=) m11) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) (sequence gs)))))))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\m7 -> ((Control.Monad.>>=) b) (\\ks -> Control.Applicative.pure (((Control.Monad.>>=) m7) (\\p -> (Data.Functor.fmap (\\u -> (f1 u) p)) (sequence ks)))))))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (\\m7 -> (Data.Functor.fmap (\\ks -> ((Control.Monad.>>=) ((Data.Traversable.mapM (\\t -> t)) ks)) (\\r -> (Data.Functor.fmap (f1 r)) m7))) b)))"
                                     ,"\\f1 -> (\\b -> (\\c -> ((Control.Monad.>>=) c) (Data.Traversable.mapM (\\ks -> (Data.Functor.fmap (\\p -> (f1 (fold ((Data.Traversable.mapM (\\w -> w)) p))) ks)) b))))"]
                                     []
  , (,,,,,) "joinBlub"   False False "Monad m => [Decl] -> (Decl -> m [FunctionBinding]) -> m [FunctionBinding]"
                                     ["\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.traverse f2) as)) (\\i -> Control.Applicative.pure (Control.Monad.join i)))"
                                     ,"\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.traverse f2) as)) (((.) Control.Applicative.pure) Control.Monad.join))"
                                     ,"\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.mapM f2) as)) (\\i -> Control.Applicative.pure (((Control.Monad.>>=) i) (\\p -> p))))"
                                     ,"\\as -> (\\f2 -> (Data.Functor.fmap (\\g -> ((Control.Monad.>>=) g) (\\k -> k))) ((Data.Traversable.mapM f2) as))"
                                     ,"\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.mapM f2) as)) (\\l -> Control.Applicative.pure (((Control.Monad.>>=) l) (\\p -> p))))"
                                     ,"\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.mapM f2) as)) (\\l -> Control.Applicative.pure (concat l)))"
                                     ,"\\as -> (\\f2 -> ((Control.Monad.>>=) ((Data.Traversable.mapM f2) as)) (\\i -> (Data.Traversable.mapM (\\p -> p)) (((Control.Monad.>>=) i) (Data.Functor.fmap Control.Applicative.pure))))"]
                                     []
  , (,,,,,) "liftA2"     False False "Applicative f => (a -> b -> c) -> f a -> f b -> f c"
                                     ["\\f1 -> (\\f2 -> (Control.Applicative.<*>) (((Control.Applicative.<*>) (Control.Applicative.pure f1)) f2))"
                                     ,"\\f1 -> (\\f2 -> (\\d -> ((Control.Applicative.<*>) ((Data.Functor.fmap (\\j -> (\\k -> (f1 k) j))) d)) f2))"
                                     ,"\\f1 -> (\\f2 -> (Control.Applicative.<*>) ((Data.Functor.fmap f1) f2))"
                                     ,"\\f1 -> ((.) (Control.Applicative.<*>)) (Data.Functor.fmap f1)"
                                     ]
                                     ["liftA2", "liftA3"]
  , (,,,,,) "runEitherT" False False "Monad m => [D] -> (D -> Control.Monad.Trans.Either.EitherT e m [FB]) -> ([FB] -> [FB]) -> m [Data.Either.Either e [FB]]"
                                     ["\\as -> (\\f2 -> (\\f3 -> (Data.Traversable.traverse (\\h -> Control.Monad.Trans.Either.runEitherT (((Control.Monad.>>=) (f2 h)) (\\n -> Control.Applicative.pure (f3 n))))) as))"
                                     ,"\\as -> (\\f2 -> (\\f3 -> (Data.Traversable.traverse (((.) Control.Monad.Trans.Either.runEitherT) (((.) (Data.Functor.fmap f3)) f2))) as))"
                                     ,"\\as -> (\\f2 -> (\\f3 -> (Data.Traversable.traverse (\\h -> Control.Monad.Trans.Either.runEitherT ((Data.Functor.fmap f3) (f2 h)))) as))"
                                     ,"\\as -> (\\f2 -> (\\f3 -> (Data.Traversable.mapM (\\h -> Control.Monad.Trans.Either.runEitherT ((Data.Functor.fmap f3) (f2 h)))) as))"]
                                     []
  , (,,,,,) "constr"     False False "(Monad m, Ord e) => ((e -> Data.Either.Either e TC) -> A -> Control.Monad.Trans.Either.EitherT e m C) -> Data.Either.Either e TC -> Data.Map.Map e (Data.Either.Either e TC) -> [A] -> Control.Monad.Trans.Either.EitherT e m [C]"
                                     ["\\f1 -> (\\e2 -> (\\m3 -> Data.Traversable.traverse (f1 (\\l -> (Data.Maybe.fromMaybe e2) ((Data.Map.lookup l) m3)))))"
                                     ,"\\f1 -> (\\e2 -> (\\m3 -> Data.Traversable.mapM (f1 (\\l -> (Data.Maybe.fromMaybe e2) ((Data.Map.lookup l) m3)))))"
                                     ,"\\f1 -> (\\e2 -> (\\m3 -> Data.Traversable.mapM (f1 (\\l -> ((Data.Maybe.maybe e2) (\\q -> q)) ((Data.Map.lookup l) m3)))))"]
                                     []
  , (,,,,,) "fmapmap"    False False "Monad m => T -> [N] -> (CT -> N -> FB) -> (SC -> T -> m CT) -> SC -> m [FB]"
                                     ["\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> ((Control.Monad.>>=) ((f4 s5) t1)) (\\c11 -> (Data.Traversable.traverse (((.) Control.Applicative.pure) (f3 c11))) bs)))))"
                                     ,"\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> ((Control.Monad.>>=) ((f4 s5) t1)) (\\c11 -> (Data.Traversable.traverse (\\p -> Control.Applicative.pure ((f3 c11) p))) bs)))))"
                                     ,"\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> ((Control.Monad.>>=) ((f4 s5) t1)) (\\c11 -> (Data.Traversable.traverse (((.) Control.Applicative.pure) (f3 c11))) bs)))))"
                                     ,"\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> ((>>=) ((f4 s5) t1)) (\\c11 -> (Data.Traversable.traverse (\\p -> pure ((f3 c11) p))) bs)))))"
                                     ,"\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> ((Control.Monad.>>=) ((f4 s5) t1)) (\\c11 -> (Data.Traversable.mapM (\\p -> Control.Applicative.pure ((f3 c11) p))) bs)))))"
                                     ,"\\t1 -> (\\bs -> (\\f3 -> (\\f4 -> (\\s5 -> (Data.Traversable.mapM (\\j -> (Data.Functor.fmap (\\n -> (f3 n) j)) ((f4 s5) t1))) bs))))"
                                     ]
                                     []
  , (,,,,,) "fmapmap2"   False False "Monad m => T -> SC -> (T -> m [FB] -> m [FB]) -> [N] -> (SC -> T -> m CT) -> (CT -> N -> FB) -> m [FB]"
                                     ["\\t1 -> (\\s2 -> (\\f3 -> (\\ds -> (\\f5 -> (\\f6 -> (f3 t1) ((Data.Traversable.traverse (\\n12 -> ((Control.Monad.>>=) ((f5 s2) t1)) (\\s -> Control.Applicative.pure ((f6 s) n12)))) ds))))))"
                                     ,"\\t1 -> (\\s2 -> (\\f3 -> (\\ds -> (\\f5 -> (\\f6 -> (f3 t1) ((Data.Traversable.traverse (\\n12 -> (Data.Functor.fmap (\\c16 -> (f6 c16) n12)) ((f5 s2) t1))) ds))))))"
                                     ,"\\t1 -> (\\s2 -> (\\f3 -> (\\ds -> (\\f5 -> (\\f6 -> (f3 t1) ((Data.Traversable.mapM (\\n12 -> (Data.Functor.fmap (\\s -> (f6 s) n12)) ((f5 s2) t1))) ds))))))"
                                     ,"\\t1 -> (\\s2 -> (\\f3 -> (\\ds -> (\\f5 -> (\\f6 -> (f3 t1) ((Data.Traversable.mapM (\\n12 -> (Data.Functor.fmap (\\c16 -> (f6 c16) n12)) ((f5 s2) t1))) ds))))))"
                                     ,"\\t1 -> (\\s2 -> (\\f3 -> (\\ds -> (\\f5 -> (\\f6 -> (f3 t1) ((Data.Traversable.mapM (\\n12 -> ((Control.Monad.>>=) ((f5 s2) t1)) (\\s -> Control.Applicative.pure ((f6 s) n12)))) ds))))))"]
                                     []
  , (,,,,,) "contRet"    False False "a -> Control.Monad.Trans.Cont.Cont r a"
                                     ["\\a -> Control.Monad.Trans.Cont.Cont (\\f4 -> f4 a)"]
                                     []
  , (,,,,,) "contBind"   False False "Control.Monad.Trans.Cont.Cont r a -> (a -> Control.Monad.Trans.Cont.Cont r b) -> Control.Monad.Trans.Cont.Cont r b"
                                     ["\\c1 -> (\\f2 -> let (Control.Monad.Trans.Cont.Cont f4) = c1 in Control.Monad.Trans.Cont.Cont (\\f6 -> f4 (\\i -> let (Control.Monad.Trans.Cont.Cont f13) = f2 i in f13 f6)))"]
                                     []
  , (,,,,,) "ap"         False False "Monad m => m (a->b) -> m a -> m b"
                                     ["(Control.Applicative.<*>)"]
                                     []
  ]

{-
  , (,) "liftBlub"
    (ExpLambda 1
      (ExpLambda 2
        (ExpLambda 3
          (ExpApply
            (ExpApply (ExpLit "(>>=)") (ExpVar 1))
            (ExpLambda 7
              (ExpApply
                (ExpApply (ExpLit "(>>=)") (ExpVar 2))
                (ExpLambda 11
                  (ExpApply
                    (ExpApply (ExpVar 3) (ExpVar 7))
                    (ExpVar 11)))))))))
-}

exampleInput :: [(String, Bool, Bool, String)]
exampleInput =
  [ (,,,) "State"      False False "(s -> (a, s)) -> State s a"
  , (,,,) "showmap"    False False "(Show b) => (a -> b) -> [a] -> [String]"
  , (,,,) "ffbind"     False False "(a -> t -> b) -> (t -> a) -> (t -> b)"
  , (,,,) "join"       False False "(Monad m) => m (m a) -> m a"
  , (,,,) "fjoin"      False False "(t -> (t -> a)) -> t -> a"
  , (,,,) "zipThingy"  False False "[a] -> b -> [(a, b)]"
  , (,,,) "stateRun"   True  False "State a b -> a -> b"
  , (,,,) "fst"        True  False "(a, b) -> a"
  , (,,,) "ffst"       True  False "(a -> (b, c)) -> a -> b"
  , (,,,) "snd"        True  False "(a, b) -> b"
  , (,,,) "quad"       False False "a -> ((a, a), (a, a))"
  , (,,,) "fswap"      False False "(a -> (b, c)) -> a -> (c, b)"
  , (,,,) "liftBlub"   False False "Monad m => m a -> m b -> (a -> b -> m c) -> m c"
  , (,,,) "stateBind"  False False "State s a -> (a -> State s b) -> State s b"
  , (,,,) "dbMaybe"    False False "Maybe a -> Maybe (a, a)"
  , (,,,) "tupleShow"  False False "Show a, Show b => (a, b) -> String"
  , (,,,) "FloatToInt" False False "Float -> Int"
  , (,,,) "FloatToIntL" False False "[Float] -> [Int]"
  , (,,,) "longApp"    False False "a -> b -> c -> (a -> b -> d) -> (a -> c -> e) -> (b -> c -> f) -> (d -> e -> f -> g) -> g"
  , (,,,) "liftSBlub"  False False "Monad m, Monad n => ([a] -> b -> c) -> m ([n a]) -> m (n b) -> m (n c)"
  , (,,,) "liftSBlubS" False False "Monad m => (List a -> b -> c) -> m ([Maybe a]) -> m (Maybe b) -> m (Maybe c)"
  , (,,,) "joinBlub"   False False "Monad m => [Decl] -> (Decl -> m [FunctionBinding] -> m [FunctionBinding]"
  , (,,,) "liftA2"     False False "Applicative f => (a -> b -> c) -> f a -> f b -> f c"
  ]

filterBindings :: (QualifiedName -> Bool)
               -> [FunctionBinding]
               -> [FunctionBinding]
filterBindings p = filter $ \(_, qn, _, _, _) -> p qn

filterBindingsSimple :: [String]
                     -> [FunctionBinding]
                     -> [FunctionBinding]
filterBindingsSimple es = filterBindings $ \n -> case n of
  QualifiedName _ name -> name `notElem` es
  _                    -> True

checkInput :: ( m ~ MultiRWST r w s m0
              , Monad m0
              , Functor m0
              , ContainsType TypeDeclMap r
              )
           => ExferenceHeuristicsConfig
           -> EnvDictionary
           -> String
           -> Bool
           -> Bool
           -> [String]
           -> m ExferenceInput
checkInput heuristics (bindings, deconss, sEnv) typeStr allowUnused patternM hidden = do
  tDeclMap <- mAsk
  ty <- unsafeReadType (sClassEnv_tclasses sEnv) exampleDataTypes tDeclMap typeStr
  let filteredBindings = filterBindingsSimple ("fix":"forever":"iterateM_":hidden) bindings
  return $ ExferenceInput
    ty
    filteredBindings
    deconss
    sEnv
    allowUnused
    False
    8192
    patternM
    20000
    (Just 8192)
    heuristics

exampleDataTypes :: [QualifiedName]
exampleDataTypes
  = parseQualifiedName <$> [ "Data.String.String"
                           , "Prelude.Float"
                           , "Data.Int.Int"
                           , "Data.Bool.Bool"
                           ]

checkExpectedResults :: forall m m0 r w s
                      . ( m ~ MultiRWST r w s m0
                        , Monad m0
                        , Functor m0
                        , ContainsType TypeDeclMap r
                        )
                     => ExferenceHeuristicsConfig
                     -> EnvDictionary
                     -> m [ ( String -- ^ name
                            , [String] -- ^ expected
                            , Maybe ( (Expression, ExferenceStats)
                                      -- ^ first
                                    , Maybe (Int, ExferenceStats)
                                    ) -- ^ index and stats of expected
                            )]
checkExpectedResults heuristics env = mapMultiRWST (return . runIdentity)
                                      -- for lazyness, we drop the IO
                                    $ sequence
  [ [ (name, expected, r)
    | input <- checkInput heuristics env typeStr allowUnused patternM hidden
    , let getExp :: (Expression, [HsConstraint], ExferenceStats)
                 -> MaybeT (MultiRWST r w s Identity) ExferenceStats
          getExp (e, _, s) =
            [ s
            | showExpression (simplifyExpression e) `elem` expected
            ]
    , let xs = findExpressions input
    , r <- runMaybeT
        [ ((simplifyExpression e, stats), rs)
        | let ((e, _, stats):_) = xs
        , rs <- lift $ runMaybeT $ asum $ zipWith (fmap . (,)) [0..] $ map getExp xs
        ]
    ]
  | (name, allowUnused, patternM, typeStr, expected, hidden) <- checkData
  ]


{-
checkBestResults :: ExferenceHeuristicsConfig
                 -> EnvDictionary
                 -> [ ( String
                      , [String]
                      , Maybe ( (Expression, ExferenceStats)
                                  -- ^ first result
                              , (Int, Expression, ExferenceStats)
                                  -- ^ best result
                              , Maybe (Int, ExferenceStats)
                                  -- ^ expected
                              )
                      )]
checkBestResults heuristics env = do
  (name, allowUnused, typeStr, expected) <- checkData
  let input = checkInput heuristics env typeStr allowUnused
  let getBest :: [(Expression, ExferenceStats)]
              -> (Int, Expression, ExferenceStats)
      getBest = maximumBy (comparing g) . zipWith (\a (b,c) -> (a,b,c)) [0..]
        where
          g (_,_,ExferenceStats _ f) = f
  let getExp :: Int
             -> [(Expression, ExferenceStats)]
             -> Maybe (Int, ExferenceStats)
      getExp _ [] = Nothing
      getExp n ((e,s):r) | show e `elem` expected = Just (n,s)
                         | otherwise              = getExp (n+1) r
  return $
    ( name
    , expected
    , case findExpressions input of
        [] -> Nothing
        xs@(x:_) -> Just (x, getBest xs, getExp 0 xs)
    )
-}

{-
checkBestResultsPar :: ExferenceHeuristicsConfig
                    -> EnvDictionary
                    -> [ IO ( String
                            , [String]
                            , Maybe ( (Expression, ExferenceStats)
                                        -- ^ first result
                                    , (Int, Expression, ExferenceStats)
                                        -- ^ best result
                                    , Maybe (Int, ExferenceStats)
                                        -- ^ expected
                                    )
                            )]
-}

{-
checkResults :: ExferenceHeuristicsConfig
             -> EnvDictionary
             -> [IO ( String -- name
                    , [String] -- expected
                    , Maybe Expression -- first
                    , Maybe Expression -- best
                    , Maybe (Int, ExferenceStats) -- expected was nth solution
                                                  -- and had these stats
                    , [(Expression, ExferenceStats)]
                    )]
checkResults heuristics (bindings, sEnv) = do
  (name, allowUnused, typeStr, expected) <- checkData
  let input = ExferenceInput
                (readConstrainedType sEnv typeStr)
                (filter (\(x,_,_) -> x/="join" && x/="liftA2") bindings)
                sEnv
                allowUnused
                131072
                (Just 131072)
                heuristics
  let r = findExpressionsPar input
  let finder :: Int
             -> [(Expression, ExferenceStats)]
             -> Maybe (Int, ExferenceStats)
      finder n [] = Nothing
      finder n ((e, s):r) | show e `elem` expected = Just (n, s)
                          | otherwise = finder (n+1) r
      bestFound = findSortNExpressions 100 input
  return $ (,,,,,)
         <$> return name
         <*> return expected
         <*> fmap fst <$> findOneExpressionPar input
         -- <*> return (fst <$> findOneExpression input)
         <*> return (fst <$> listToMaybe bestFound)
         <*> (finder 0 <$> r)
         <*> r
-}

exampleOutput :: ( m ~ MultiRWST r w s m0
                 , Monad m0
                 , Functor m0
                 )
              => ExferenceHeuristicsConfig
              -> EnvDictionary
              -> m [[(Expression, [HsConstraint], ExferenceStats)]]
exampleOutput heuristics (bindings, deconss, sEnv) =
  exampleInput `forM` \(_, allowUnused, patternM, s) -> do
    ty <- unsafeReadType (sClassEnv_tclasses sEnv) exampleDataTypes (M.empty) s
    let filteredBindings = filterBindingsSimple ["join", "liftA2"] bindings
    return $ takeFindSortNExpressions 10 10 $ ExferenceInput
                ty
                filteredBindings
                deconss
                sEnv
                allowUnused
                False
                8192
                patternM
                32768
                (Just 32768)
                heuristics

exampleInOut :: ( m ~ MultiRWST r w s m0
                , Monad m0
                , Functor m0
                )
             => ExferenceHeuristicsConfig
             -> EnvDictionary
             -> m [( (String, Bool, Bool, String)
                   , [(Expression, [HsConstraint], ExferenceStats)]
                   )]
exampleInOut h env =
  zip exampleInput <$> exampleOutput h env

printAndStuff :: ExferenceHeuristicsConfig
              -> EnvDictionary
              -> MultiRWST r w s IO ()
printAndStuff h env = exampleInOut h env >>= mapM_ f
  where
    f ((name, _, _, _), []) = lift $ putStrLn $ "no results for "++name++"!"
    f ((name, _, _, _), results) = mapM_ g results
      where
        g (expr, _, ExferenceStats n d m) = do
          {-
          if doPf then do
            pf <- pointfree $ str
            putStrLn $ name ++ " = " ++ pf
                       ++ "    FROM    " ++ name ++ " = " ++ str
                       ++ " (depth " ++ show d ++ ", " ++ show n ++ " steps)"
           else
          -}
          lift $ putStrLn $ name ++ " = " ++ showExpression expr
                            ++ " (depth "
                            ++ show d
                            ++ ", "
                            ++ show n
                            ++ " steps, "
                            ++ show m
                            ++ " max pqueue size)"

printStatistics :: ExferenceHeuristicsConfig
                -> EnvDictionary
                -> MultiRWST r w s IO ()
printStatistics h env = exampleInOut h env >>= mapM_ f
  where
    f ((name, _, _, _), [])      = lift $ putStrLn $ printf "%10s: ---" name
    f ((name, _, _, _), results) =
      let (hd, avg, minV, maxV, n) = getStats results
      in lift $ putStrLn
              $ printf "%12s: head=%6d avg=%6d min=%6d max=%6d %s" name hd avg minV maxV
                                     (if n==6 then "" else " n = " ++ show n)
    getStats results =
      let steps = map (\(_, _, stats) -> exference_steps stats) results
      in ( head steps
         , sum steps `div` length steps
         , minimum steps
         , maximum steps
         , length steps
         )

printCheckExpectedResults :: forall r w s
                           . ( ContainsType TypeDeclMap r
                             )
                          => ExferenceHeuristicsConfig
                          -> EnvDictionary
                          -> MultiRWST r w s IO ()
printCheckExpectedResults h env = do
    xs <- checkExpectedResults h env
    case () of { () -> do
    stats <- mapM helper xs
    lift $ putStrLn $ "total:     " ++ show (length stats)
    lift $ putStrLn $ "solutions: " ++ (show
                                       $ length
                                       $ catMaybes
                                       $ fst <$> stats)
    lift $ putStrLn $ "success:   " ++ ( show
                                       $ length
                                       $ filter id
                                       $ catMaybes
                                       $ uncurry (liftM2 (==)) <$> stats)
    lift $ putStrLn $ "rating any solutions: "
             ++ ( show
                $ foldr g (0, 0.0)
                $ fromMaybe (ExferenceStats 1000000 1000000 0) . fst <$> stats)
    lift $ putStrLn $ "rating good solutions: "
             ++ ( show
                $ foldr g (0, 0.0)
                $ fromMaybe (ExferenceStats 1000000 1000000 0) . snd <$> stats)
  where
    helper :: ( String -- ^ name
              , [String] -- ^ expected
              , Maybe ( (Expression, ExferenceStats) -- ^ first
                      , Maybe (Int, ExferenceStats)
                      ) -- ^ index and stats of expected
              )
           -> MultiRWST r w s IO (Maybe ExferenceStats, Maybe ExferenceStats)
    helper (name, _, Nothing) = do
      lift $ putStrLn $ printf "%-12s: no solutions found at all!" name
      return (Nothing, Nothing)
    helper (name, e, Just ((first,stats), Nothing)) = do
      lift $ putStrLn $ printf "%-12s: expected solution not found!" name
      let firstStr = showExpression first
      lift $ putStrLn $ "  first solution:       " ++ firstStr
      lift $ putStrLn $ "  first solution stats: " ++ show stats
      lift $ putStrLn $ "  expected solutions:   " ++ intercalate
                     "\n                      or " e
      lift $ putStrLn $ "  " ++ show firstStr
      return (Just stats, Nothing)
    helper (name, _, Just (_, Just (0, stats))) = do
      lift $ putStrLn $ printf "%-12s: %s" name (show stats)
      return (Just stats, Just stats)
    helper (name, e, Just ((first, fstats), Just (n, stats))) = do
      lift $ putStrLn $ printf "%-12s: expected solution not first, but %d!" name n
      lift $ putStrLn $ "  first solution:     " ++ showExpression first
      lift $ putStrLn $ "  expected solutions:   " ++ intercalate
                      "\n                     or " e
      lift $ putStrLn $ "  first solution stats:    " ++ show fstats
      lift $ putStrLn $ "  expected solution stats: " ++ show stats
      lift $ putStrLn $ "  " ++ show (showExpression first)
      return (Just fstats, Just stats)
    g :: ExferenceStats -> (Int,Float) -> (Int,Float)
    g (ExferenceStats a b _) (d,e) = (a+d,b+e)
  }

printMaxUsage :: ExferenceHeuristicsConfig
              -> EnvDictionary
              -> MultiRWST r w s IO ()
printMaxUsage h (bindings, deconss, sEnv) = sequence_ $ do
  (name, allowUnused, patternM, typeStr, _expected, hidden) <- checkData
  return $ do
    ty <- unsafeReadType (sClassEnv_tclasses sEnv) exampleDataTypes (M.empty) typeStr
    let filteredBindings = filterBindingsSimple hidden bindings
    let input = ExferenceInput
                  ty
                  filteredBindings
                  deconss
                  sEnv
                  allowUnused
                  False
                  8192
                  patternM
                  16384
                  (Just 16384)
                  h
    let stats = chunkBindingUsages $ last $ findExpressionsWithStats input
        highest = take 5 $ sortBy (flip $ comparing snd) $ M.toList stats
    lift $ putStrLn $ printf "%-12s: %s" name (show highest)