{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module LiveCoding.Debugger.StatePrint where

-- base
import Data.Data
import Data.Maybe (fromMaybe, fromJust)
import Data.Proxy
import Data.Typeable
import Unsafe.Coerce

-- transformers
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict

-- syb
import Data.Generics.Aliases
import Data.Generics.Text (gshow)

-- essence-of-live-coding
import LiveCoding.Cell
import LiveCoding.Cell.Feedback
import LiveCoding.Debugger
import LiveCoding.Forever
import LiveCoding.Exceptions

statePrint :: Debugger IO
statePrint :: Debugger IO
statePrint = (forall s. Data s => LiveProgram (StateT s IO)) -> Debugger IO
forall (m :: * -> *).
(forall s. Data s => LiveProgram (StateT s m)) -> Debugger m
Debugger ((forall s. Data s => LiveProgram (StateT s IO)) -> Debugger IO)
-> (forall s. Data s => LiveProgram (StateT s IO)) -> Debugger IO
forall a b. (a -> b) -> a -> b
$ Cell (StateT s IO) () () -> LiveProgram (StateT s IO)
forall (m :: * -> *). Monad m => Cell m () () -> LiveProgram m
liveCell (Cell (StateT s IO) () () -> LiveProgram (StateT s IO))
-> Cell (StateT s IO) () () -> LiveProgram (StateT s IO)
forall a b. (a -> b) -> a -> b
$ (() -> StateT s IO ()) -> Cell (StateT s IO) () ()
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM ((() -> StateT s IO ()) -> Cell (StateT s IO) () ())
-> (() -> StateT s IO ()) -> Cell (StateT s IO) () ()
forall a b. (a -> b) -> a -> b
$ StateT s IO () -> () -> StateT s IO ()
forall a b. a -> b -> a
const (StateT s IO () -> () -> StateT s IO ())
-> StateT s IO () -> () -> StateT s IO ()
forall a b. (a -> b) -> a -> b
$ do
  s
s <- StateT s IO s
forall (m :: * -> *) s. Monad m => StateT s m s
get
  IO () -> StateT s IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT s IO ()) -> IO () -> StateT s IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ s -> String
forall s. Data s => s -> String
stateShow s
s

stateShow :: Data s => s -> String
stateShow :: s -> String
stateShow
  =       s -> String
forall s. Data s => s -> String
gshow
  (s -> String)
-> (forall d1 d2.
    (Data d1, Data d2) =>
    Composition d1 d2 -> String)
-> s
-> String
forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
`ext2Q` forall d1 d2. (Data d1, Data d2) => Composition d1 d2 -> String
compositionShow
  (s -> String)
-> (forall d1 d2. (Data d1, Data d2) => ForeverE d1 d2 -> String)
-> s
-> String
forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
`ext2Q` forall d1 d2. (Data d1, Data d2) => ForeverE d1 d2 -> String
foreverEShow
  (s -> String)
-> (forall d1 d2. (Data d1, Data d2) => Feedback d1 d2 -> String)
-> s
-> String
forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
`ext2Q` forall d1 d2. (Data d1, Data d2) => Feedback d1 d2 -> String
feedbackShow
  (s -> String)
-> (forall d1 d2. (Data d1, Data d2) => Parallel d1 d2 -> String)
-> s
-> String
forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
`ext2Q` forall d1 d2. (Data d1, Data d2) => Parallel d1 d2 -> String
parallelShow
  (s -> String)
-> (forall d1 d2.
    (Data d1, Data d2) =>
    ExceptState d1 d2 -> String)
-> s
-> String
forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
`ext2Q` forall d1 d2. (Data d1, Data d2) => ExceptState d1 d2 -> String
exceptShow
  (s -> String)
-> (forall d1 d2. (Data d1, Data d2) => Choice d1 d2 -> String)
-> s
-> String
forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
`ext2Q` forall d1 d2. (Data d1, Data d2) => Choice d1 d2 -> String
choiceShow

isUnit :: Data s => s -> Bool
isUnit :: s -> Bool
isUnit = Bool -> (() -> Bool) -> s -> Bool
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ Bool
False
          (\() -> Bool
True)
  (s -> Bool)
-> (forall d1 d2. (Data d1, Data d2) => (d1, d2) -> Bool)
-> s
-> Bool
forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
`ext2Q` (\(a, b) -> d1 -> Bool
forall s. Data s => s -> Bool
isUnit d1
a Bool -> Bool -> Bool
&& d2 -> Bool
forall s. Data s => s -> Bool
isUnit d2
b)
  (s -> Bool)
-> (forall d1 d2. (Data d1, Data d2) => Composition d1 d2 -> Bool)
-> s
-> Bool
forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
`ext2Q` (\(Composition s1 s2) -> d1 -> Bool
forall s. Data s => s -> Bool
isUnit d1
s1 Bool -> Bool -> Bool
&& d2 -> Bool
forall s. Data s => s -> Bool
isUnit d2
s2)
  (s -> Bool)
-> (forall d1 d2. (Data d1, Data d2) => Parallel d1 d2 -> Bool)
-> s
-> Bool
forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
`ext2Q` (\(Parallel s1 s2) -> d1 -> Bool
forall s. Data s => s -> Bool
isUnit d1
s1 Bool -> Bool -> Bool
&& d2 -> Bool
forall s. Data s => s -> Bool
isUnit d2
s2)
  (s -> Bool)
-> (forall d1 d2. (Data d1, Data d2) => Choice d1 d2 -> Bool)
-> s
-> Bool
forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
`ext2Q` (\(Choice sL sR) -> d1 -> Bool
forall s. Data s => s -> Bool
isUnit d1
sL Bool -> Bool -> Bool
&& d2 -> Bool
forall s. Data s => s -> Bool
isUnit d2
sR)

compositionShow :: (Data s1, Data s2) => Composition s1 s2 -> String
compositionShow :: Composition s1 s2 -> String
compositionShow (Composition s1
s1 s2
s2)
  | s1 -> Bool
forall s. Data s => s -> Bool
isUnit s1
s1 = s2 -> String
forall s. Data s => s -> String
stateShow s2
s2
  | s2 -> Bool
forall s. Data s => s -> Bool
isUnit s2
s2 = s1 -> String
forall s. Data s => s -> String
stateShow s1
s1
  | Bool
otherwise = s1 -> String
forall s. Data s => s -> String
stateShow s1
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" >>> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ s2 -> String
forall s. Data s => s -> String
stateShow s2
s2

-- TODO Would be cooler if this was multiline
parallelShow :: (Data s1, Data s2) => Parallel s1 s2 -> String
parallelShow :: Parallel s1 s2 -> String
parallelShow (Parallel s1
s1 s2
s2)
  | s1 -> Bool
forall s. Data s => s -> Bool
isUnit s1
s1 = s2 -> String
forall s. Data s => s -> String
stateShow s2
s2
  | s2 -> Bool
forall s. Data s => s -> Bool
isUnit s2
s2 = s1 -> String
forall s. Data s => s -> String
stateShow s1
s1
  | Bool
otherwise = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ s1 -> String
forall s. Data s => s -> String
stateShow s1
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" *** " String -> String -> String
forall a. [a] -> [a] -> [a]
++ s2 -> String
forall s. Data s => s -> String
stateShow s2
s2 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

foreverEShow :: (Data e, Data s) => ForeverE e s -> String
foreverEShow :: ForeverE e s -> String
foreverEShow ForeverE { e
s
currentState :: forall e s. ForeverE e s -> s
initState :: forall e s. ForeverE e s -> s
lastException :: forall e s. ForeverE e s -> e
currentState :: s
initState :: s
lastException :: e
.. }
  =  String
"forever("
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if e -> Bool
forall s. Data s => s -> Bool
isUnit e
lastException then String
"" else e -> String
forall s. Data s => s -> String
gshow e
lastException String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", ")
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ s -> String
forall s. Data s => s -> String
stateShow s
initState String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ s -> String
forall s. Data s => s -> String
stateShow s
currentState

feedbackShow :: (Data state, Data s) => Feedback state s -> String
feedbackShow :: Feedback state s -> String
feedbackShow Feedback { state
s
sAdditional :: forall sPrevious sAdditional.
Feedback sPrevious sAdditional -> sAdditional
sPrevious :: forall sPrevious sAdditional.
Feedback sPrevious sAdditional -> sPrevious
sAdditional :: s
sPrevious :: state
.. } = String
"feedback " String -> String -> String
forall a. [a] -> [a] -> [a]
++ s -> String
forall s. Data s => s -> String
gshow s
sAdditional String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ state -> String
forall s. Data s => s -> String
stateShow state
sPrevious

exceptShow :: (Data s, Data e) => ExceptState s e -> String
exceptShow :: ExceptState s e -> String
exceptShow (NotThrown s
s) = String
"NotThrown: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ s -> String
forall s. Data s => s -> String
stateShow s
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
exceptShow (Exception e
e)
  =  String
"Exception"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if e -> Bool
forall s. Data s => s -> Bool
isUnit e
e then String
"" else String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall s. Data s => s -> String
gshow e
e)
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n"

choiceShow :: (Data stateL, Data stateR) => Choice stateL stateR -> String
choiceShow :: Choice stateL stateR -> String
choiceShow Choice { stateL
stateR
choiceRight :: forall stateL stateR. Choice stateL stateR -> stateR
choiceLeft :: forall stateL stateR. Choice stateL stateR -> stateL
choiceRight :: stateR
choiceLeft :: stateL
.. }
  | stateL -> Bool
forall s. Data s => s -> Bool
isUnit stateL
choiceLeft  = String
"+" String -> String -> String
forall a. [a] -> [a] -> [a]
++ stateR -> String
forall s. Data s => s -> String
stateShow stateR
choiceRight String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"+"
  | stateR -> Bool
forall s. Data s => s -> Bool
isUnit stateR
choiceRight = String
"+" String -> String -> String
forall a. [a] -> [a] -> [a]
++ stateL -> String
forall s. Data s => s -> String
stateShow stateL
choiceLeft  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"+"
  | Bool
otherwise     = String
"+" String -> String -> String
forall a. [a] -> [a] -> [a]
++ stateL -> String
forall s. Data s => s -> String
stateShow stateL
choiceLeft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" +++ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ stateR -> String
forall s. Data s => s -> String
stateShow stateR
choiceRight String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"+"

{-
-- TODO  Leave out for now from the examples and open bug when public
liveBindShow :: (Data e, Data s1, Data s2) => LiveBindState e s1 s2 -> String
liveBindShow (NotYetThrown s1 s2) = "[NotYet " ++ stateShow s1 ++ "; " ++ stateShow s2 ++ "]"
liveBindShow (Thrown e s2) = "[Thrown " ++ gshow e ++ ". " ++ stateShow s2 ++ "]"
-}

{-
gcast2 :: forall c t t' a b. (Typeable t, Typeable t')
       => c (t a b) -> Maybe (c (t' a b))
gcast2 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t'))
-}
gcast3
  :: forall f t t' a b c. (Typeable t, Typeable t')
  => f (t a b c) -> Maybe (f (t' a b c))
gcast3 :: f (t a b c) -> Maybe (f (t' a b c))
gcast3 f (t a b c)
x = ((t :~: t') -> f (t' a b c))
-> Maybe (t :~: t') -> Maybe (f (t' a b c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\t :~: t'
Refl -> f (t a b c)
f (t' a b c)
x) (Maybe (t :~: t')
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (t :~: t'))

-- from https://stackoverflow.com/questions/14447050/how-to-define-syb-functions-for-type-extension-for-tertiary-type-constructors-e?rq=1
-- sclv said to just give all the things in the where clause explicit types.
-- I guess one also needs to extend typeOf3' to include all the arguments. (Same for x/typeOf3)
-- Another possibility might be kind-heterogeneous type equality
{-
dataCast3
  :: (Typeable t, Data a)
  => (forall b c d. (Data b, Data c, Data d) => f (t b c d))
  -> Maybe (f a)
dataCast3 x = let proxy = Proxy in dropMaybe proxy $ if typeRep x == typeRep proxy
      then Just $ unsafeCoerce x
      else Nothing
dropMaybe :: Proxy a -> Maybe (f a) -> Maybe (f a)
dropMaybe _ = id
-}

--thing :: (Typeable t) => (forall b c d . (Data b, Data c, Data d) => f (t b c d)) -> TypeRep
--thing = typeRep
{-
dataCast3
  :: (Typeable t, Data a)
  => (forall b c d. (Data b, Data c, Data d) => f (t b c d))
  -> Maybe (f a)
dataCast3 x =   r
  where
    r = if typeRepFingerprint (typeOf (getArg x)) == typeRepFingerprint (typeOf (getArg (fromJust r)))
       then Just $ unsafeCoerce x
       else Nothing
    getArg :: c x -> x
    getArg = undefined
-}
{-
ext3
  :: (Data a, Typeable t)
  => f a
  -> (forall b c d. (Data b, Data c, Data d) => f (t b c d))
  -> f a
--ext3 def ext = fromMaybe def $ gcast3 ext
--ext3 def ext = fromMaybe def $ gcast3' ext
--ext3 def ext = maybe def id $ dataCast3 ext
-}
ext3
  :: (Data a, Data b, Data c, Data d, Typeable t, Typeable f)
  => f a
  -> f (t b c d)
  -> f a
ext3 :: f a -> f (t b c d) -> f a
ext3 f a
def f (t b c d)
ext = f a -> (f a -> f a) -> Maybe (f a) -> f a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe f a
def f a -> f a
forall a. a -> a
id (Maybe (f a) -> f a) -> Maybe (f a) -> f a
forall a b. (a -> b) -> a -> b
$ f (t b c d) -> Maybe (f a)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast f (t b c d)
ext

ext3Q
  :: (Data a, Data b, Data c, Data d, Typeable t, Typeable q)
  => (a -> q)
  -> (t b c d -> q)
  -> a -> q
ext3Q :: (a -> q) -> (t b c d -> q) -> a -> q
ext3Q a -> q
def t b c d -> q
ext = Q q a -> a -> q
forall q x. Q q x -> x -> q
unQ (((a -> q) -> Q q a
forall q x. (x -> q) -> Q q x
Q a -> q
def) Q q a -> Q q (t b c d) -> Q q a
forall a b c d (t :: * -> * -> * -> *) (f :: * -> *).
(Data a, Data b, Data c, Data d, Typeable t, Typeable f) =>
f a -> f (t b c d) -> f a
`ext3` ((t b c d -> q) -> Q q (t b c d)
forall q x. (x -> q) -> Q q x
Q t b c d -> q
ext))


newtype Q q x = Q { Q q x -> x -> q
unQ :: x -> q }