-- |Intended for internal use: Generic representation of 'Data' vales.
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
module Data.Data.GenRep 
    ( ConstructorName (..)
    , GenericData (..)
    , constructor
    , arity
    ) where

import System.SimpleTimeout.Limits

import Control.Exception
import Control.DeepSeq (NFData, rnf)
import qualified Data.Data as D
import Data.Data (gmapQ, Data, Typeable)

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

-- |Name and precedence of constructors.
data ConstructorName
    = Prefix String     -- ^ used also for literals except characters
    | Char Char         -- ^ character literal
    | Infix Int String
    | Infixr Int String
    | Infixl Int String
    | Tuple Int         -- ^ tuple with n elements
    | Cons              -- ^ nonempty list constructor
    | Nil               -- ^ empty list constructor
        deriving (Eq, Show, Typeable)

instance NFData ConstructorName where
    rnf x = case x of
        Prefix s    -> rnf s
        Infix i s   -> rnf i `seq` rnf s
        Infixr i s  -> rnf i `seq` rnf s
        Infixl i s  -> rnf i `seq` rnf s
        Tuple i     -> rnf i
        Char c      -> rnf c
        _ -> ()


-- |Arity of the toplevel constructor.
arity :: Data a => a -> Int
arity = length . gmapQ (const ())

-- | Extract the name and precedence of a 'Data' value.
precedence :: D.Data a => a -> SizeLimit -> (SizeLimit, ConstructorName)
precedence x v = case D.constrRep c of
    D.CharConstr char  -> (v-1, Char char)
    D.FloatConstr r 
        | t == "Prelude.Double" -> prefix (realToFrac r :: Double)
        | t == "Prelude.Float"  -> prefix (realToFrac r :: Float)
        | otherwise             -> prefix (realToFrac r :: Rational)
    D.IntConstr i   -> prefix i
    D.AlgConstr _   -> case n of
        "[]"  -> (v-2, Nil)
        "(:)" -> (v-1, Cons)
        '(':l | all (==',') (init l) && last l == ')' 
              -> (v-length l-1, Tuple (length l))
        _     -> case D.constrFixity c of
            D.Prefix    -> (v - length n, Prefix n)
            D.Infix     -> (v - length n, Infix 9 n)         -- sorry we can't do better
  where
    prefix :: Show a => a -> (Int, ConstructorName)
    prefix a = (v', Prefix s') where (v', s') = limitString v (show a)

    c = D.toConstr x
    n = D.showConstr c
    t = D.dataTypeName $ D.constrType c


-- |Limit the length of a string by replacing the middle of
-- the string by an ellipsis.
-- The function returns the limit reduced by the final length of the string.
limitString :: SizeLimit -> String -> (SizeLimit, String)
limitString v s = f $ case splitAt i s of
    (_, []) -> s
    (a, b) -> case splitAt (j+1) $ reverse b of
        (_, []) -> s
        (c, _)  -> a ++ "…" ++ reverse (take j c)
 where
    f ss = (v-length ss, ss)

    i = max 4 (v `div` 2)
    j = max 3 (i-2)


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

-- |Representation of 'Data' values.
data GenericData
    = Constructor ConstructorName [GenericData]
    | Error String          -- ^ shown exception
    | Timeout Double        -- ^ timeout, the @Double@ is between 0 and 1. 
                            -- 
                            --      * 0: evaluation of subexpression started at the beginning
                            -- 
                            --      * towards 1: evaluation of subexpression started near the end of time limit
                            -- 
                            --      * 1: evaluation of subexpression started after time limit (rare)
    | Hole                  -- ^ this is caused space shortage, shown as three dots
    | Detail GenericData    -- ^ also caused by space shortage but this omission a relevant part
    | ListHole              -- ^ used during show
        deriving (Show, Typeable)

instance NFData GenericData where
    rnf x = case x of
        Constructor p s   -> rnf p `seq` rnf s
        Error e     -> rnf e
        Detail s    -> rnf s
        Timeout d   -> rnf d
        _   -> ()



-- |Convert a 'Data' value to 'GenericData' given the
-- 'GenericData' representation of the value's children.
constructor :: Data a => Budget -> a -> IO [GenericData] -> IO GenericData
constructor b x m = do
    y <- checkBudget b 1 (return . Just . Timeout) (return $ Just Hole) (catchMany x)
    case y of
        Just a -> return a
        _ -> do 
            p <- decSizeBudget b (precedence x)
            fmap (Constructor p) m 

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

-- |Try to catch many type of exceptions while
-- evaluation the weak head normal form of the parameter.
catchMany :: a -> IO (Maybe GenericData)
catchMany a 
    = fmap (const Nothing) (evaluate a)
      `catches` 
        [ Handler (\(e :: ErrorCall)        -> f e)
        , Handler (\(e :: ArithException)   -> f e)
        , Handler (\(e :: NonTermination)   -> f e)
        , Handler (\(e :: AssertionFailed)  -> f e)
        , Handler (\(e :: PatternMatchFail) -> f e)
        , Handler (\(e :: NoMethodError)    -> f e)
        , Handler (\(e :: AssertionFailed)  -> f e)
        , Handler (\(e :: ArrayException)   -> f e)
        , Handler (\(e :: RecConError)      -> f e)
        , Handler (\(e :: RecSelError)      -> f e)
        , Handler (\(e :: RecUpdError)      -> f e)
        ]
 where
    f :: Show x => x -> IO (Maybe GenericData)
    f = return . Just . Error . show