-- 
-- (c) Susumu Katayama
--
{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-} 
-- Used by the Web version.
module MagicHaskeller.IOGenerator where
import System.Random
import MagicHaskeller.MyCheck
import Data.List(sort, group, sortBy, intersperse)
import Data.Function(on)
import Data.Char(isAlphaNum)
import Data.Ratio
import MagicHaskeller.LibTH(everythingF, pgfull, postprocess)
import MagicHaskeller.ExpToHtml(pprnn, annotateFree)
import Language.Haskell.TH(pprint, Exp)
import Data.Typeable

arbitraries :: Arbitrary a => [a]
arbitraries = arbs 4 (mkStdGen 1)
arbs :: Arbitrary a => Int -> StdGen -> [a]
arbs n stdgen  =  case split stdgen of
                    (g0,g1) -> f n g0 : arbs n g1
    where Gen f = arbitrary

--showIOPairs :: IOGenerator a => String -> String -> a -> String
--showIOPairs crlf funname fun = concat $ map ((crlf ++) . (funname++)) $ generate fun
showIOPairsHTML :: IOGenerator a => String -> a -> String
showIOPairsHTML = showIOPairsHTML' (const showIOPairHTML)
showIOPairsWithFormsHTML :: IOGenerator a =>
                            String                     -- ^ CGI.myPath, which is usually "/cgi-bin/MagicHaskeller.cgi"
                         -> String                     -- ^ predicate before escaping single quotes
                         -> String -> a -> String
showIOPairsWithFormsHTML mypath predicate
    = let beginForm = "<FORM ACTION='"++mypath++"' METHOD=GET> <INPUT TYPE=HIDDEN NAME='predicate' VALUE='"++concatMap escapeQuote predicate ++"'> <INPUT TYPE=HIDDEN NAME='inputs' VALUE='"
      in showIOPairsHTML' (showIOPairWithFormHTML beginForm)
showIOPairsHTML' shower funname fun = concat $ map (("<tr align=left cellspacing=20><td><font size=1 color='#888888'>&amp;&amp;</font>&nbsp;</td><td>"++) . (funname++) . shower boxSize) iopairs 
  where iopairs  =  generateIOPairs fun
        boxSize  = maximum $ 20 : map length (snd $ unzip iopairs)

type AnnShowS = (Exp->Exp) -- ^ annotater
                -> String -> String
showIOPairHTML (args,ret) = foldr (\arg str -> "&nbsp;</td><td>&nbsp;" ++ arg (annotateFree []) str) ("&nbsp;</td><td>&nbsp; == &nbsp;</td><td> &nbsp;"++ret++ " &nbsp;</td></tr>") args

showIOPairWithFormHTML begin boxSize pair@(args,ret) = showIOPairHTML (args, mkForm begin boxSize pair)
mkForm :: String
       -> Int
       -> ([AnnShowS],String)
       -> String
-- predicateとinputsとoutputがあればよい．CGI側では，  '(':predicate++") && f "++inputs++" == "++output  をpredicateとして実行
mkForm begin boxSize (args,ret)
    = begin ++ concatMap escapeQuote (showsInputs args "") ++ "'> <INPUT TYPE=TEXT NAME='output' VALUE='"++concatMap escapeQuote ret ++ "' SIZE="++show boxSize ++"> <INPUT TYPE=SUBMIT VALUE='Narrow search'> </FORM>"
showsInputs args = \s -> foldr (\arg str -> ' ' : arg id str) s args
escapeQuote '\'' = "&apos;"
escapeQuote c    = [c]

class IOGenerator a where
--    generate     :: a -> [String]
    generateIOPairs :: a -> [([AnnShowS],String)] -- list of pairs of shown arguments and shown return values
instance (IOGenerator r) => IOGenerator (Int->r) where
  -- generate      f = [ ' ' : showParen (a<0) (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ]
  generateIOPairs = generateIOPairsLitNum integrals
instance (IOGenerator r) => IOGenerator (Integer->r) where
  -- generate      f = [ ' ' : showParen (a<0) (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ]
  generateIOPairs = generateIOPairsLitNum integrals
instance (IOGenerator r) => IOGenerator (Float->r) where
  -- generate      f = [ ' ' : showParen (a<0) (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ]
  generateIOPairs = generateIOPairsLitNum arbitraries
instance (IOGenerator r) => IOGenerator (Double->r) where
  -- generate      f = [ ' ' : showParen (a<0) (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ]
  generateIOPairs = generateIOPairsLitNum arbitraries

-- Can be used for Integer, Double, and Float, but not for Ratio and Complex.
generateIOPairsLitNum rs f = [ (const (showParen (a<0) (shows a)) : args, ret) | a <- uniqSort $ take 4 rs, (args,ret) <- generateIOPairs (f a) ]

integrals :: Integral i => [i]
integrals = concat $ zipWith (\a b -> [a,b]) [0,-1..] [1..]

instance (IOGenerator r) => IOGenerator (()->r) where
--    generate     f = generateFun False f
    generateIOPairs f = generateIOPairsFun False f
instance (IOGenerator r) => IOGenerator (Bool->r) where
--    generate     f = generateFun False f
    generateIOPairs f = generateIOPairsFun False f
instance (IOGenerator r) => IOGenerator (Ordering->r) where
--    generate     f = generateFun False f
    generateIOPairs f = generateIOPairsFun False f
instance (IOGenerator r) => IOGenerator (Char->r) where
--    generate     f = generateFun False f
    generateIOPairs f = [ (const (shows a) : args, ret) | a <- " \nAb."{- ++ take 0 arbitraries -}, (args,ret) <- generateIOPairs (f a) ]

instance (IOGenerator r) => IOGenerator (String->r) where
--    generate     f = generateFun False f
    generateIOPairs f = [ (const (shows a) : args, ret) | a <- sortBy (compare `on` length) $ uniqSort $ "" : "12345" : "Abc\nd Ef" : take 2 arbitraries,
                                                  (args, ret) <- generateIOPairs (f a) ]
{----------------------------------------------------------------------- Do not use these in order to deal with types like [Int->Int]->Int.
    -- ただ、コメントアウトすると、[Int]とかでもeverythingFを使うため簡約されていない形で表示されてしまうので，分かりにくくなってしまう．両方のバージョンを用意してエラーになったらもう一方ってのがよさそう。
instance (Arbitrary a, Show a, Ord a, IOGenerator r) => IOGenerator ([a]->r) where
--    generate     f = generateFun False f
    generateIOPairs f = [ (shows a : args, ret) | a <- sortBy (compare `on` length) $ uniqSort $ [] : take 4 arbitraries,
                                                  (args, ret) <- generateIOPairs (f a) ]

instance (Arbitrary a, Show a, Ord a, IOGenerator r) => IOGenerator (Maybe a -> r) where
--    generate     f = generateFun False f
    generateIOPairs f = generateIOPairsFun True f
instance (Arbitrary a, Show a, Ord a, Integral a, Random a, IOGenerator r) => IOGenerator (Ratio a -> r) where
--    generate     f = generateFun False f
    generateIOPairs f = generateIOPairsFun True f
instance (Arbitrary a, Show a, Ord a, Arbitrary b, Show b, Ord b, IOGenerator r) => IOGenerator ((a,b)->r) where
--    generate     f = generateFun False f
    generateIOPairs f = generateIOPairsFun False f
instance (Arbitrary a, Show a, Ord a, Arbitrary b, Show b, Ord b, Arbitrary c, Show c, Ord c, IOGenerator r) => IOGenerator ((a,b,c)->r) where
--    generate     f = generateFun False f
    generateIOPairs f = generateIOPairsFun False f
instance (Arbitrary a, Show a, Ord a, Arbitrary b, Show b, Ord b, IOGenerator r) => IOGenerator ((Either a b)->r) where
--    generate     f = generateFun False f
    generateIOPairs f = generateIOPairsFun True f
---------------------------------------------------------------------}
instance (ShowArbitrary a, IOGenerator r) => IOGenerator (a->r) where
--    generate     f = generateFun True f
    generateIOPairs = mhGenerateIOPairs

mhGenerateIOPairs f = [ (astr : args, ret)
                                | (astr, a) <- take 5 showArbitraries,
                                  (args, ret) <- generateIOPairs (f a) ]

-- | 'ShowArbitrary' is a variant of 'Arbitrary' for presenting I/O example pairs. It uses everythingF for generating printable functions.
--   Here `good presentation' is more important than `good randomness'.
class ShowArbitrary a where
      showArbitraries :: [(AnnShowS, a)]
sas      :: (Show a) => (a->Bool) -> [a] -> [(AnnShowS, a)]
sas cond xs = [ (const $ showParen (cond x) (shows x), x) | x <- xs ]
sasNum   :: (Show a, Arbitrary a, Num a, Ord a) => [(AnnShowS, a)]
sasNum   = sas (<0) arbitraries
sasFalse :: (Show a) => [a] -> [(AnnShowS, a)]
sasFalse = sas (const False)
sasIntegral :: (Show a, Arbitrary a, Integral a, Ord a) => [(AnnShowS, a)]
sasIntegral = sas (<0) [0,1] ++ -- interleave [2..] [-1,-2..]
	      	  drop 2 sasNum
-- interleave xs ys = concat $ transpose [xs, ys]
instance ShowArbitrary () where
      showArbitraries = repeat (const ("()"++),())
instance ShowArbitrary Bool where
      showArbitraries = sasFalse $ [False, True] ++ arbitraries
instance ShowArbitrary Int where
      showArbitraries = sasIntegral
instance ShowArbitrary Integer where
      showArbitraries = sasIntegral
instance ShowArbitrary Float where
      showArbitraries = sasNum
instance ShowArbitrary Double where
      showArbitraries = sasNum
instance ShowArbitrary Char where
      showArbitraries = sasFalse $ " \nAb."++ drop 5 arbitraries
instance ShowArbitrary Ordering where
      showArbitraries = sasFalse $ [LT,EQ,GT] ++ arbitraries
instance (Integral i, Random i, Show i) => ShowArbitrary (Ratio i) where
      showArbitraries = sas (const True) arbitraries
instance ShowArbitrary a => ShowArbitrary (Maybe a) where
      showArbitraries = (const ("Nothing"++), Nothing) : map (mapSA "Just " Just) showArbitraries
instance (ShowArbitrary a, ShowArbitrary b) => ShowArbitrary (Either a b) where
      showArbitraries = zipWith3 (\b l r -> if b then mapSA "Left " Left l else mapSA "Right " Right r) arbitraries showArbitraries showArbitraries
-- ほんとはもっとランダムにすべきではある．2本Eitherがある場合，同じarbitraries::[Bool]を共有するので，同じ箇所でLeftやRightになる．
mapSA str fun (f,x) =  (\annotater -> showParen True ((str++) . f annotater), fun x)
instance (ShowArbitrary a, ShowArbitrary b) => ShowArbitrary (a, b) where
      showArbitraries = zipWith (\(f1,x1) (f2,x2) -> (\annotater -> ('(':) . f1 annotater . (',':) . f2 annotater . (')':), (x1,x2))) 
                                (skip 1 showArbitraries) 
                                (skip 1 $ drop 1 showArbitraries)
instance (ShowArbitrary a, ShowArbitrary b, ShowArbitrary c) => ShowArbitrary (a, b, c) where
      showArbitraries = zipWith3 (\(f1,x1) (f2,x2) (f3,x3) -> (\annotater -> ('(':) . f1 annotater . (',':) . f2 annotater . (',':) . f3 annotater . (')':), (x1,x2,x3))) 
                                 (skip 2 showArbitraries) 
                                 (skip 2 $ drop 1 showArbitraries) 
                                 (skip 2 $ drop 2 showArbitraries)
-- leap frog
skip n (x:xs) = x : skip n (drop n xs)
instance ShowArbitrary a => ShowArbitrary [a] where
      showArbitraries = map cvt $ chopBy arbitraries showArbitraries
-- ほんとはもっとランダムにすべきではある．2本[a]がある場合，同じarbitraries::[Int]を共有するので，同じ箇所で同じ長さになる．
chopBy :: [Int] -> [a] -> [[a]]
chopBy _      [] = []         -- everythingFを使ってある点で切る限り，有限の可能性も必ず残る．空リストであることもありえるので，cycleしてもダメ．
chopBy (i:is) xs | i < 0     = chopBy is xs
       	 | otherwise = case splitAt i xs of (tk,dr) -> tk : chopBy is dr
cvt :: [(AnnShowS,a)] -> (AnnShowS, [a])
cvt ts = case unzip ts of (fs, xs) -> (showsList fs, xs)

showsList fs@(f:_) | head (f id "") == '\'' -- The String case is dealt with here. I use overlapping instances only conservatively. The drawback is that "" is still printed as []. 
                       = const $ shows (map (\fun -> read $ fun id "") fs :: String)
showsList fs       = \annotater -> ('[':) . foldr (.) (']':) (intersperse (',':) $ map ($ annotater) fs)

instance (Typeable a, Typeable b) => ShowArbitrary (a->b) where
      showArbitraries = map (\(e,a) -> (\annotater -> (pprnn (annotater (postprocess e)) ++) , a)) $ concat $ take 3 $ everythingF pgfull


-- generateFun     b f = [ ' ' : showParen b (shows a) s | a <- uniqSort $ take 5 arbitraries, s <- generate (f a) ]
generateIOPairsFun b f = [ (const (showParen b (shows a)) : args, ret) 
                         | a <- uniqSort $ take 5 arbitraries
                         , (args, ret) <- generateIOPairs (f a) ]

instance Show a => IOGenerator a where
--    generate     x = [" = "++show x]
    generateIOPairs x = [([], show x)]

uniqSort :: Ord a => [a] -> [a]
uniqSort = map head . group . sort