{-# Language DeriveDataTypeable, StandaloneDeriving #-} -- for GHC <= 7.8
-- |
-- Module      : Test.Speculate.Expr.Instance
-- Copyright   : (c) 2016-2019 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- This module is part of Speculate.
--
-- Typeclass instance information.
module Test.Speculate.Expr.Instance
  ( Instances

  -- * reifying instances
  , reifyInstances
  , reifyInstances1
  , reifyListable, mkListable

  -- * checking instances
  , isListable, isListableT

  -- * finding functions
  , lookupTiers
  , lookupTiersT
  , holeOfTy, maybeHoleOfTy

  -- * the preludeInstances definition
  , preludeInstances

  -- * module re-export
  , module Data.Express.Instances
  )
where

import Data.Express.Instances
import Test.Speculate.Expr.Core
import Test.Speculate.Utils
import Test.LeanCheck
import Test.LeanCheck.Utils
import Data.Maybe

type Instances = [Expr] -- TODO: remove?

reifyInstances1 :: (Typeable a, Listable a, Show a, Eq a, Ord a, Name a) => a -> Instances
reifyInstances1 :: a -> Instances
reifyInstances1 a
a  =  [Instances] -> Instances
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [a -> Instances
forall a. (Typeable a, Show a, Listable a) => a -> Instances
reifyListable a
a, a -> Instances
forall a. (Typeable a, Ord a) => a -> Instances
reifyEqOrd a
a, a -> Instances
forall a. (Typeable a, Name a) => a -> Instances
reifyName a
a]

reifyInstances :: (Typeable a, Listable a, Show a, Eq a, Ord a, Name a) => a -> Instances
reifyInstances :: a -> Instances
reifyInstances a
a  =  [Instances] -> Instances
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ a -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r1 a
a
  , [a] -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r1 [a
a]
--, r1 [[a]]
  , (a, a) -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r1 (a
a,a
a)
--, r1 (a,a,a)
--, r1 [(a,a)]
  , Maybe a -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r1 (a -> Maybe a
forall a. a -> Maybe a
mayb a
a)
--, r1 (eith a a)
  ]
  where
  r1 :: (Typeable a, Listable a, Show a, Eq a, Ord a, Name a)
     => a -> Instances
  r1 :: a -> Instances
r1 = a -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
reifyInstances1

reifyListable :: (Typeable a, Show a, Listable a) => a -> Instances
reifyListable :: a -> Instances
reifyListable a
a  =  [[a]] -> Instances
forall a. (Typeable a, Show a) => [[a]] -> Instances
mkListable ([[a]]
forall a. Listable a => [[a]]
tiers [[a]] -> [[a]] -> [[a]]
forall a. a -> a -> a
-: [[a
a]])

mkListable :: (Typeable a, Show a) => [[a]] -> [Expr]
mkListable :: [[a]] -> Instances
mkListable [[a]]
xss
  | [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
xss)  =  Instances
forall a. a
err
  | Bool
otherwise          =  [String -> [Instances] -> Expr
forall a. Typeable a => String -> a -> Expr
value String
"tiers" ([Instances] -> Expr) -> [Instances] -> Expr
forall a b. (a -> b) -> a -> b
$ (a -> Expr) -> [[a]] -> [Instances]
forall a b. (a -> b) -> [[a]] -> [[b]]
mapT a -> Expr
forall a. (Typeable a, Show a) => a -> Expr
val [[a]]
xss]
  where
  err :: a
err  =  String -> a
forall a. HasCallStack => String -> a
error
       (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$  String
"Speculate does not allow an empty tiers enumeration"
       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", offending type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (a -> TypeRep) -> ([a] -> a) -> [a] -> TypeRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> a
forall a. [a] -> a
head ([a] -> TypeRep) -> [a] -> TypeRep
forall a b. (a -> b) -> a -> b
$ [[a]] -> [a]
forall a. [a] -> a
head [[a]]
xss)
-- TODO: reify an "undefined" value of a type to be able to holeOfTy and lift
--       the above restriction of no empty tiers?

isListable :: Instances -> Expr -> Bool
isListable :: Instances -> Expr -> Bool
isListable Instances
is  =  Instances -> TypeRep -> Bool
isListableT Instances
is (TypeRep -> Bool) -> (Expr -> TypeRep) -> Expr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> TypeRep
typ

isListableT :: Instances -> TypeRep -> Bool
isListableT :: Instances -> TypeRep -> Bool
isListableT Instances
is  =  Bool -> Bool
not (Bool -> Bool) -> (TypeRep -> Bool) -> TypeRep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Instances] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Instances] -> Bool)
-> (TypeRep -> [Instances]) -> TypeRep -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Instances -> TypeRep -> [Instances]
lookupTiersT Instances
is

lookupTiers :: Instances -> Expr -> [[Expr]]
lookupTiers :: Instances -> Expr -> [Instances]
lookupTiers Instances
is  =  Instances -> TypeRep -> [Instances]
lookupTiersT Instances
is (TypeRep -> [Instances])
-> (Expr -> TypeRep) -> Expr -> [Instances]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> TypeRep
typ

lookupTiersT :: Instances -> TypeRep -> [[Expr]]
lookupTiersT :: Instances -> TypeRep -> [Instances]
lookupTiersT Instances
is TypeRep
t  =  [Instances] -> Maybe [Instances] -> [Instances]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Instances] -> [Instances])
-> Maybe [Instances] -> [Instances]
forall a b. (a -> b) -> a -> b
$ Instances -> TypeRep -> Maybe [Instances]
maybeTiersE Instances
is TypeRep
t
  where
  maybeTiersE :: Instances -> TypeRep -> Maybe [[Expr]]
  maybeTiersE :: Instances -> TypeRep -> Maybe [Instances]
maybeTiersE Instances
is TypeRep
t  =  case [[Instances]]
i of
    [] -> Maybe [Instances]
forall a. Maybe a
Nothing
    ([Instances]
tiers:[[Instances]]
_) -> [Instances] -> Maybe [Instances]
forall a. a -> Maybe a
Just [Instances]
tiers
    where
    i :: [[Instances]]
i = [[Instances]
tiers | e :: Expr
e@(Value String
"tiers" Dynamic
_) <- Instances
is
               , let tiers :: [Instances]
tiers = [Instances] -> Expr -> [Instances]
forall a. Typeable a => a -> Expr -> a
eval ([Instances]
forall a. HasCallStack => a
undefined :: [[Expr]]) Expr
e
               , Expr -> TypeRep
typ (Instances -> Expr
forall a. [a] -> a
head (Instances -> Expr)
-> ([Instances] -> Instances) -> [Instances] -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Instances] -> Instances
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Instances] -> Expr) -> [Instances] -> Expr
forall a b. (a -> b) -> a -> b
$ [Instances]
tiers) TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep
t]
  -- TODO: make the above work on empty tiers

holeOfTy :: Instances -> TypeRep -> Expr
holeOfTy :: Instances -> TypeRep -> Expr
holeOfTy Instances
is TypeRep
t = Expr -> Maybe Expr -> Expr
forall a. a -> Maybe a -> a
fromMaybe Expr
forall a. a
err (Maybe Expr -> Expr) -> Maybe Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Instances -> TypeRep -> Maybe Expr
maybeHoleOfTy Instances
is TypeRep
t
  where
  err :: a
err  =  String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"holeOfTy: could not find tiers with type `[[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show TypeRep
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]]'."

maybeHoleOfTy :: Instances -> TypeRep -> Maybe Expr
maybeHoleOfTy :: Instances -> TypeRep -> Maybe Expr
maybeHoleOfTy Instances
is TypeRep
t = case [Instances] -> Instances
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Instances] -> Instances) -> [Instances] -> Instances
forall a b. (a -> b) -> a -> b
$ Instances -> TypeRep -> [Instances]
lookupTiersT Instances
is TypeRep
t of
                     (Expr
e:Instances
_) -> Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ String
"" String -> Expr -> Expr
`varAsTypeOf` Expr
e
                     Instances
_     -> Maybe Expr
forall a. Maybe a
Nothing

-- despite the name, this _does not_ include most types from the prelude.
preludeInstances :: Instances
preludeInstances :: Instances
preludeInstances  =  [Instances] -> Instances
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ () -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r1 (()
forall a. a
u :: ())
  , [()] -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r1 ([()]
forall a. a
u :: [()])

  , Bool -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r (Bool
forall a. a
u :: Bool)

  , Int -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r (Int
forall a. a
u :: Int)
--, r (u :: Word)
  , Integer -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r (Integer
forall a. a
u :: Integer)

  , Ordering -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r (Ordering
forall a. a
u :: Ordering)
  , Char -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r (Char
forall a. a
u :: Char)

  , Rational -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r (Rational
forall a. a
u :: Rational)
  , Float -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r (Float
forall a. a
u :: Float)
  , Double -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
r (Double
forall a. a
u :: Double)

-- TODO: uncomment the following and investigate why compilation takes so long
--, r (u :: Int1)
--, r (u :: Int2)
--, r (u :: Int3)
--, r (u :: Int4)
--, r (u :: Word1)
--, r (u :: Word2)
--, r (u :: Word3)
--, r (u :: Word4)
--, r (u :: Nat1)
--, r (u :: Nat2)
--, r (u :: Nat3)
--, r (u :: Nat4)
--, r (u :: Nat5)
--, r (u :: Nat6)
--, r (u :: Nat7)
  ]
  where
  u :: a
  u :: a
u  =  a
forall a. HasCallStack => a
undefined
  r, r1 :: (Typeable a, Listable a, Show a, Eq a, Ord a, Name a)
        => a -> Instances
  r :: a -> Instances
r = a -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
reifyInstances
  r1 :: a -> Instances
r1 = a -> Instances
forall a.
(Typeable a, Listable a, Show a, Eq a, Ord a, Name a) =>
a -> Instances
reifyInstances1
-- WHOA!  Have I discovered a "bug" in GHC?  adding to many type compositions
-- on ins and types on preludeInstances makes compilation of this module
-- *really* slow: it takes a whopping 2 minutes!
-- (the above report is using -O2, I have not tested without optimizations).