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

module LiveCoding.Debugger.StatePrint where

-- base
import Data.Data
import Data.Maybe (fromJust, fromMaybe)
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.Exceptions
import LiveCoding.Forever

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 (m :: * -> *) a. Monad m => m a -> StateT s m a
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 :: forall s. Data s => 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` Composition d1 d2 -> String
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` ForeverE d1 d2 -> String
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` Feedback d1 d2 -> String
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` Parallel d1 d2 -> String
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` ExceptState d1 d2 -> String
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` Choice d1 d2 -> String
forall d1 d2. (Data d1, Data d2) => Choice d1 d2 -> String
choiceShow

isUnit :: (Data s) => s -> Bool
isUnit :: forall s. Data s => 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` (\(d1
a, d2
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 d1
s1 d2
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 d1
s1 d2
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 d1
sL d2
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 :: forall d1 d2. (Data d1, Data d2) => Composition d1 d2 -> 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 :: forall d1 d2. (Data d1, Data d2) => Parallel d1 d2 -> 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 :: forall d1 d2. (Data d1, Data d2) => ForeverE d1 d2 -> String
foreverEShow ForeverE {e
s
lastException :: e
initState :: s
currentState :: s
lastException :: forall e s. ForeverE e s -> e
initState :: forall e s. ForeverE e s -> s
currentState :: forall e s. ForeverE e s -> s
..} =
  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 :: forall d1 d2. (Data d1, Data d2) => Feedback d1 d2 -> String
feedbackShow Feedback {state
s
sPrevious :: state
sAdditional :: s
sPrevious :: forall sPrevious sAdditional.
Feedback sPrevious sAdditional -> sPrevious
sAdditional :: forall sPrevious sAdditional.
Feedback sPrevious sAdditional -> sAdditional
..} = 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 :: forall d1 d2. (Data d1, Data d2) => ExceptState d1 d2 -> 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 :: forall d1 d2. (Data d1, Data d2) => Choice d1 d2 -> String
choiceShow Choice {stateL
stateR
choiceLeft :: stateL
choiceRight :: stateR
choiceLeft :: forall stateL stateR. Choice stateL stateR -> stateL
choiceRight :: forall stateL stateR. Choice stateL stateR -> stateR
..}
  | 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 :: 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)
x = ((t :~: t') -> f (t' a b c))
-> Maybe (t :~: t') -> Maybe (f (t' a b c))
forall a b. (a -> b) -> Maybe a -> Maybe b
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 :: 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 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 :: forall a b c d (t :: * -> * -> * -> *) q.
(Data a, Data b, Data c, Data d, Typeable t, Typeable q) =>
(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 {forall q x. Q q x -> x -> q
unQ :: x -> q}