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

import System.SimpleTimeout.Limits
import System.IO.Parallel (manyParallel)
import Control.Exception.Pure (catchPureErrors)

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 (ConstructorName -> ConstructorName -> Bool
(ConstructorName -> ConstructorName -> Bool)
-> (ConstructorName -> ConstructorName -> Bool)
-> Eq ConstructorName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstructorName -> ConstructorName -> Bool
$c/= :: ConstructorName -> ConstructorName -> Bool
== :: ConstructorName -> ConstructorName -> Bool
$c== :: ConstructorName -> ConstructorName -> Bool
Eq, Int -> ConstructorName -> ShowS
[ConstructorName] -> ShowS
ConstructorName -> String
(Int -> ConstructorName -> ShowS)
-> (ConstructorName -> String)
-> ([ConstructorName] -> ShowS)
-> Show ConstructorName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConstructorName] -> ShowS
$cshowList :: [ConstructorName] -> ShowS
show :: ConstructorName -> String
$cshow :: ConstructorName -> String
showsPrec :: Int -> ConstructorName -> ShowS
$cshowsPrec :: Int -> ConstructorName -> ShowS
Show, Typeable)

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


-- |Arity of the toplevel constructor.
arity :: Data a => a -> Int
arity :: a -> Int
arity = [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([()] -> Int) -> (a -> [()]) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall d. Data d => d -> ()) -> a -> [()]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ (() -> d -> ()
forall a b. a -> b -> a
const ())

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

    c :: Constr
c = a -> Constr
forall a. Data a => a -> Constr
D.toConstr a
x
    n :: String
n = Constr -> String
D.showConstr Constr
c
    t :: String
t = DataType -> String
D.dataTypeName (DataType -> String) -> DataType -> String
forall a b. (a -> b) -> a -> b
$ Constr -> DataType
D.constrType Constr
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 :: Int -> String -> (Int, String)
limitString Int
v String
s = String -> (Int, String)
forall (t :: * -> *) a. Foldable t => t a -> (Int, t a)
f (String -> (Int, String)) -> String -> (Int, String)
forall a b. (a -> b) -> a -> b
$ case Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i String
s of
    (String
_, []) -> String
s
    (String
a, String
b) -> case Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse String
b of
        (String
_, []) -> String
s
        (String
c, String
_)  -> String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"…" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. [a] -> [a]
reverse (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
j String
c)
 where
    f :: t a -> (Int, t a)
f t a
ss = (Int
vInt -> Int -> Int
forall a. Num a => a -> a -> a
-t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
ss, t a
ss)

    i :: Int
i = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
4 (Int
v Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
    j :: Int
j = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
3 (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2)


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

-- |Representation of 'Data' values.
data GenericData
    = Constructor ConstructorName [GenericData]
    | Error String          -- ^ exception error message
    | NestedError GenericData  -- ^ error message which may contain further errors
    | 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 (Int -> GenericData -> ShowS
[GenericData] -> ShowS
GenericData -> String
(Int -> GenericData -> ShowS)
-> (GenericData -> String)
-> ([GenericData] -> ShowS)
-> Show GenericData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenericData] -> ShowS
$cshowList :: [GenericData] -> ShowS
show :: GenericData -> String
$cshow :: GenericData -> String
showsPrec :: Int -> GenericData -> ShowS
$cshowsPrec :: Int -> GenericData -> ShowS
Show, Typeable)


instance NFData GenericData where
    rnf :: GenericData -> ()
rnf GenericData
x = case GenericData
x of
        Constructor ConstructorName
p [GenericData]
s   -> ConstructorName -> ()
forall a. NFData a => a -> ()
rnf ConstructorName
p () -> () -> ()
`seq` [GenericData] -> ()
forall a. NFData a => a -> ()
rnf [GenericData]
s
        Error String
e         -> String -> ()
forall a. NFData a => a -> ()
rnf String
e
        NestedError GenericData
e   -> GenericData -> ()
forall a. NFData a => a -> ()
rnf GenericData
e
        Detail GenericData
s        -> GenericData -> ()
forall a. NFData a => a -> ()
rnf GenericData
s
        Timeout Double
d       -> Double -> ()
forall a. NFData a => a -> ()
rnf Double
d
        GenericData
_   -> ()


-- |Convert a 'Data' value to 'GenericData' given the
-- 'GenericData' representations of the value's children.
constructor :: Data a => Budget -> a -> IO [GenericData] -> IO GenericData
constructor :: Budget -> a -> IO [GenericData] -> IO GenericData
constructor Budget
b a
x IO [GenericData]
m = do
    Either GenericData (Either String a)
y <- Budget
-> Int
-> (Double -> IO (Either GenericData (Either String a)))
-> IO (Either GenericData (Either String a))
-> IO (Either GenericData (Either String a))
-> IO (Either GenericData (Either String a))
forall a. Budget -> Int -> (Double -> IO a) -> IO a -> IO a -> IO a
checkBudget Budget
b Int
1 (Either GenericData (Either String a)
-> IO (Either GenericData (Either String a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GenericData (Either String a)
 -> IO (Either GenericData (Either String a)))
-> (Double -> Either GenericData (Either String a))
-> Double
-> IO (Either GenericData (Either String a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericData -> Either GenericData (Either String a)
forall a b. a -> Either a b
Left (GenericData -> Either GenericData (Either String a))
-> (Double -> GenericData)
-> Double
-> Either GenericData (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> GenericData
Timeout) (Either GenericData (Either String a)
-> IO (Either GenericData (Either String a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GenericData (Either String a)
 -> IO (Either GenericData (Either String a)))
-> Either GenericData (Either String a)
-> IO (Either GenericData (Either String a))
forall a b. (a -> b) -> a -> b
$ GenericData -> Either GenericData (Either String a)
forall a b. a -> Either a b
Left GenericData
Hole) 
            (IO (Either GenericData (Either String a))
 -> IO (Either GenericData (Either String a)))
-> IO (Either GenericData (Either String a))
-> IO (Either GenericData (Either String a))
forall a b. (a -> b) -> a -> b
$ (Either String a -> Either GenericData (Either String a))
-> IO (Either String a)
-> IO (Either GenericData (Either String a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either String a -> Either GenericData (Either String a)
forall a b. b -> Either a b
Right (IO (Either String a) -> IO (Either GenericData (Either String a)))
-> IO (Either String a)
-> IO (Either GenericData (Either String a))
forall a b. (a -> b) -> a -> b
$ a -> IO (Either String a)
forall a. a -> IO (Either String a)
catchPureErrors a
x
    case Either GenericData (Either String a)
y of
        Left GenericData
x -> GenericData -> IO GenericData
forall (m :: * -> *) a. Monad m => a -> m a
return GenericData
x
        Right (Left String
x) -> do 
            (GenericData -> GenericData) -> IO GenericData -> IO GenericData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenericData -> GenericData
NestedError (IO GenericData -> IO GenericData)
-> IO GenericData -> IO GenericData
forall a b. (a -> b) -> a -> b
$ Budget -> String -> IO GenericData
forall a. Data a => Budget -> a -> IO GenericData
evalWithBudget Budget
b String
x
        Right (Right a
x) -> do 
            ConstructorName
p <- Budget -> (Int -> (Int, ConstructorName)) -> IO ConstructorName
forall a. Budget -> (Int -> (Int, a)) -> IO a
decSizeBudget Budget
b (a -> Int -> (Int, ConstructorName)
forall a. Data a => a -> Int -> (Int, ConstructorName)
precedence a
x)
            ([GenericData] -> GenericData)
-> IO [GenericData] -> IO GenericData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ConstructorName -> [GenericData] -> GenericData
Constructor ConstructorName
p) IO [GenericData]
m 

evalWithBudget :: Data a => Budget -> a -> IO GenericData
evalWithBudget :: Budget -> a -> IO GenericData
evalWithBudget Budget
b a
x
    = Budget -> a -> IO [GenericData] -> IO GenericData
forall a.
Data a =>
Budget -> a -> IO [GenericData] -> IO GenericData
constructor Budget
b a
x
    (IO [GenericData] -> IO GenericData)
-> IO [GenericData] -> IO GenericData
forall a b. (a -> b) -> a -> b
$ [IO GenericData] -> IO [GenericData]
forall a. [IO a] -> IO [a]
manyParallel
    ([IO GenericData] -> IO [GenericData])
-> [IO GenericData] -> IO [GenericData]
forall a b. (a -> b) -> a -> b
$ (forall d. Data d => d -> IO GenericData) -> a -> [IO GenericData]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ (Budget -> d -> IO GenericData
forall a. Data a => Budget -> a -> IO GenericData
evalWithBudget Budget
b) a
x