{-# LANGUAGE ViewPatterns, PatternGuards #-}
module Smart
    ( module Simple
    , startGHCiServer
    , restart
    , TaskChan (..)
    , interp
    , compareClearGen
    , compareMistGen
    , wrap2
    ) where

import HoogleCustom
import Specialize
import Lang
import Result
import Logger
import Simple hiding (TaskChan, startGHCiServer)
import qualified Simple
import Hash

import ActiveHs.Base (WrapData2 (..), WrapData(..))
import Graphics.Diagrams (Diagram)
import Graphics.Diagrams.SVG (render)
import Graphics.Diagrams.FunctionGraphs (displayFun, displayDiscreteFun, displayArc)

import qualified Data.Data.Eval as C
import qualified Data.Data.Compare as C
import Data.Data.GenRep hiding (Error)
import Data.Data.GenRep.Functions (mistify, numberErrors)
import Data.Data.GenRep.Doc (toDoc)

import Data.Dynamic hiding (typeOf)
import qualified Data.Data as D
import Control.DeepSeq (force)
import Control.Monad (void)
import Control.Monad.Trans (liftIO)
import Data.Char (isAlpha)
import Data.Maybe (catMaybes, maybe)

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

data TaskChan 
    = TC 
        { logger    :: Logger
        , hoogledb  :: Maybe FilePath   -- for Hoogle searches
        , chan      :: Simple.TaskChan
        }

startGHCiServer :: [FilePath] -> Logger -> Maybe FilePath -> IO TaskChan
startGHCiServer searchpaths log dbname = do
    ch <- Simple.startGHCiServer searchpaths log
    return $ TC
            { logger    = log
            , hoogledb  = dbname
            , chan      = ch
            }

restart :: TaskChan -> IO ()
restart ch = do
    Simple.restartGHCiServer (chan ch)

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

showErr :: Language -> InterpreterError -> String
showErr lang (WontCompile l)   = unlines $ map errMsg l
showErr lang (UnknownError s)  = translate lang "Unknown error: " ++ s
showErr lang (NotAllowed s)    = translate lang "Not allowed: " ++ s
showErr lang (GhcException s)  = translate lang "GHC exception: " ++ s

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

getCommand :: String -> (String, String)
getCommand (':':'?': (dropSpace -> Just x)) 
    = ("?", x)
getCommand (':': (span isAlpha -> (c@(_:_), dropSpace -> Just x)))
    = (c, x)
getCommand s
    = ("", s)

dropSpace :: String -> Maybe String
dropSpace (' ':y) = Just $ dropWhile (==' ') y
dropSpace "" = Just ""
dropSpace _ = Nothing


interp :: Bool -> Hash -> Language -> TaskChan -> FilePath -> String 
    -> Maybe (String -> Interpreter Result) -> IO Result
interp  verboseinterpreter (show -> idi) lang ch fn s@(getCommand -> (cmd, arg)) extraStep
    = force <$> case cmd of

        "?" -> maybe (return $ noInfo arg) (\db -> query db arg) (hoogledb ch)

        "i" -> maybe (return $ noInfo arg) (\db -> queryInfo lang db arg) (hoogledb ch)

        c | c `elem` ["t","k",""]
           -> fmap (either (Error True . showErr lang) id)
          $ sendToServer (chan ch) fn
          $ case cmd of
              "t" ->
                do
                  xx <- typeOf arg
                  return $ ExprType False arg xx []
                `catchE`
                  (return . Error True . showErr lang)
              "k" ->
                do 
                  xx <- kindOf arg
                  return $ TypeKind arg xx []
                `catchE`
                  (return . Error True . showErr lang)
              "" ->
                do
                  (typ, pprData, ppr) <- do
                      ty <- typeOf s
                      case specialize ty of
                        Left err -> return (Error True err, Nothing, Nothing)
                        Right (ty',ty'') -> do
                          pprData <- do
                              wd <- interpret ("wrapData (" ++ parens s ++ " :: " ++ ty'' ++")") (as :: WrapData)
                              liftIO (pprintData idi ty'' wd)
                            `catchE`
                              (return . Just . Error False . showErr lang)
                          ppr <- do
                              dyn <- interpret ("toDyn (" ++ parens s ++ " :: " ++ ty' ++")") (as :: Dynamic)
                              liftIO (pprint idi dyn)
                            `catchE`
                              (return . Just . Error False . showErr lang)
                          return (ExprType True s ty [], pprData, ppr)
                    `catchE`
                      (\e -> return (Error False (showErr lang e), Nothing, Nothing))
                  kind <- do
                      k <- kindOf s
                      return $ TypeKind s k []
                    `catchE`
                      (return . Error False . showErr lang)
                  mExtraRes <- case extraStep of
                      Nothing   -> return Nothing
                      Just step -> do
                        extraRes <- step arg `catchE` (return . Error True . showErr lang)
                        return $ Just extraRes
                  mHooInfo <- case (hoogledb ch) of
                                Nothing -> return Nothing
                                Just db -> do
                                  hoo <- liftIO $ query db s
                                  hooInfo <- liftIO $ queryInfo lang db s
                                  return $ Just [hoo, hooInfo]
                  let everyResult = catMaybes [mExtraRes, pprData, ppr] ++ maybe [] id mHooInfo ++ [typ, kind]
                  case filterResults everyResult of
                    [] -> return typ
                    (res:_) -> return res
        _   ->  return $ force $ Error True $ 
                   translate lang "The" ++ " :" ++ cmd ++ " " ++ translate lang "command is not supported" ++ "."

 where
    catchE :: Interpreter a -> (InterpreterError -> Interpreter a) -> Interpreter a
    catchE = Simple.catchError_fixed

    noInfo :: String -> Result
    noInfo query = Message (translate lang "No info for " ++ query) Nothing

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


pprintData :: String -> String -> WrapData -> IO (Maybe Result)
pprintData idi y (WrapData x)
  | D.dataTypeName (D.dataTypeOf x) == "Diagram" =
      return Nothing
  | otherwise = do
      a <- C.eval 1 700 x
      let ([p], es) = numberErrors [a]
      return . Just $ ExprType False (show $ toDoc p) y es


pprint :: String -> Dynamic -> IO (Maybe Result)
pprint idi d
    | Just x <- fromDynamic d = ff x
    | Just x <- fromDynamic d = ff $ showFunc (x :: Double -> Double)
    | Just x <- fromDynamic d = ff $ showFunc (x :: Double -> Integer)
    | Just x <- fromDynamic d = ff $ showFunc $ fromIntegral . fromEnum . (x :: Double -> Bool)
    | Just x <- fromDynamic d = ff $ showFunc $ fromIntegral . fromEnum . (x :: Double -> Ordering)
    | Just x <- fromDynamic d = ff $ showFunc_ (x :: Integer -> Double)
    | Just x <- fromDynamic d = ff $ showFunc_ (x :: Integer -> Integer)
    | Just x <- fromDynamic d = ff $ showFunc_ $ fromIntegral . fromEnum . (x :: Integer -> Bool)
    | Just x <- fromDynamic d = ff $ showFunc_ $ fromIntegral . fromEnum . (x :: Integer -> Ordering)
    | Just x <- fromDynamic d = ff $ displayArc' (x :: Double -> (Double, Double))
    | Just (f,g) <- fromDynamic d = ff $ displayArc' ((\x -> (f x, g x)) :: Double -> (Double, Double))
    | otherwise = return Nothing
 where
    ff = fmap g . render 10 (-16, -10) (16, 10) 5 2048 idi
    g (htm, err) = Just (Dia htm err)
    showFunc :: (RealFrac a, Real b) => (a -> b) -> Diagram
    showFunc = displayFun (-16,-10) (16,10)
    showFunc_ :: (Real b, Integral a) => (a -> b) -> Diagram
    showFunc_ = displayDiscreteFun (-16,-10) (16,10)
    displayArc' = displayArc (-16,-10) (16,10) (0,1) 

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

wrap2 :: String -> String -> String
wrap2 a b = "WrapData2 " ++ parens a ++ " " ++ parens b

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

compareMistGen :: Language -> String -> WrapData2 -> String -> IO Result
compareMistGen lang idi (WrapData2 x y) goodsol
    | D.dataTypeName (D.dataTypeOf x) == "Diagram" 
    = return $ Message (translate lang "Can't decide the equality of diagrams (yet).") Nothing
compareMistGen lang idi (WrapData2 x y) goodsol = do
    (ans, a', b') <- C.compareData 0.8 0.2 700 x y
    return $ case ans of
        C.Yes -> Message (translate lang "Good solution! Another good solution:")
                          $ Just $ ExprType False goodsol "" []
        _ ->
            let x = case ans of
                    C.Maybe _  -> "I cannot decide whether this is a good solution:"
                    C.No       -> "Wrong solution:"
            in Message (translate lang x) $ Just $ showPair ans (a', mistify b')


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

compareClearGen :: Language -> String -> WrapData2 -> IO Result
compareClearGen lang idi (WrapData2 x y)
    | D.dataTypeName (D.dataTypeOf x) == "Diagram"
    = return $ Message (translate lang "Can't decide the equality of diagrams (yet).") Nothing
compareClearGen lang idi (WrapData2 x y) = do
    (ans, a', b') <- C.compareData 0.8 0.2 700 x y
    return $ case ans of
--        C.Yes -> []
        _ -> showPair ans (a', b')


showPair :: C.Answer -> (GenericData, GenericData) -> Result
showPair x (a, b) = Comparison (show (toDoc a')) x (show (toDoc b')) es
  where ([a', b'], es) = numberErrors [a, b]