{-# LANGUAGE ViewPatterns, PatternGuards, OverloadedStrings #-}
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 Hoogle (Database, loadDatabase)

import Control.Monad (join)
import Data.Dynamic hiding (typeOf)
import qualified Data.Data as D
import Data.List (nub)
import Data.Char (isAlpha)
--import Prelude hiding (catch)


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

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

startGHCiServer :: [FilePath] -> Logger -> FilePath -> IO TaskChan
startGHCiServer searchpaths log dbname = do
    db <- if (dbname == "") then return Nothing else fmap Just $ loadDatabase dbname
    ch <- Simple.startGHCiServer searchpaths log
    return $ TC
            { logger    = log
            , database  = db
            , chan      = ch
            }

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

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

showErr :: Language -> InterpreterError -> [String]
showErr lang (WontCompile l)   = nub{-miért?? -} . 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 
    -> (String -> Interpreter (IO [Result])) -> IO [Result]
interp  verboseinterpreter (show -> idi) lang ch fn s@(getCommand -> (c, a)) xy 
    = case c of

    "?" ->  return $ query True (database ch) a

    "i" ->  return $ queryInfo lang True (database ch) a

    c | c `elem` ["t","k",""]
       -> join 
        $ fmap (either (return . map (Error True) . showErr lang) id)
        $ sendToServer (chan ch) fn
        $ case c of
            "t" -> catchE True $ do
                xx <- typeOf a
                return $ return [ExprType False a xx []]
            "k" -> catchE True $ do
                xx <- kindOf a
                return $ return [TypeKind a xx []]
            "" -> fmap (fmap ((if verboseinterpreter then id else filterResults) . concat) . sequence) $ sequence
                [ catchE False $ do
                    ty <- typeOf s
                    case specialize ty of
                      Left err -> return $ return [Error True err]
                      Right (ty',ty'') -> fmap (fmap concat . sequence) $ sequence
                        [ catchE False $ fmap (pprintData idi ty'') $
                            interpret ("wrapData (" ++ parens s ++ " :: " ++ ty'' ++")") (as :: WrapData)

                        , catchE False $ fmap (pprint idi) $
                            interpret ("toDyn (" ++ parens s ++ " :: " ++ ty' ++")") (as :: Dynamic)

                        , return $ return [ExprType True s ty []]
                        ]

                , catchE False $ do
                    k<- kindOf s
                    return $ return [TypeKind s k []]
                , catchE True $ xy a
                , return $ return $ query False (database ch) s
                , return $ return $ queryInfo lang False (database ch) s
                ]

    _   ->  return [Error True $ 
               translate lang "The" ++ " :" ++ c ++ " " ++ translate lang "command is not supported" ++ "."]

 where

    catchE b m 
        = m `Simple.catchError_fixed` \e -> 
            return $ return $ map (Error b) $ showErr lang e

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


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


pprint :: String -> Dynamic -> IO [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 []
 where
    ff = fmap g . render 10 (-16, -10) (16, 10) 0.5 1000 idi
    g (htm, err) = [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]