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

stateShow :: Data s => s -> String
stateShow :: forall s. Data s => s -> String
stateShow =
  forall s. Data s => s -> String
gshow
    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 s1 s2. (Data s1, Data s2) => Composition s1 s2 -> String
compositionShow
    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 e s. (Data e, Data s) => ForeverE e s -> String
foreverEShow
    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 state s. (Data state, Data s) => Feedback state s -> String
feedbackShow
    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 s1 s2. (Data s1, Data s2) => Parallel s1 s2 -> String
parallelShow
    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 s e. (Data s, Data e) => ExceptState s e -> String
exceptShow
    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 stateL stateR.
(Data stateL, Data stateR) =>
Choice stateL stateR -> String
choiceShow

isUnit :: Data s => s -> Bool
isUnit :: forall s. Data s => s -> Bool
isUnit =
  forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ
    Bool
False
    (\() -> Bool
True)
    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) -> forall s. Data s => s -> Bool
isUnit d1
a Bool -> Bool -> Bool
&& forall s. Data s => s -> Bool
isUnit d2
b)
    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) -> forall s. Data s => s -> Bool
isUnit d1
s1 Bool -> Bool -> Bool
&& forall s. Data s => s -> Bool
isUnit d2
s2)
    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) -> forall s. Data s => s -> Bool
isUnit d1
s1 Bool -> Bool -> Bool
&& forall s. Data s => s -> Bool
isUnit d2
s2)
    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) -> forall s. Data s => s -> Bool
isUnit d1
sL Bool -> Bool -> Bool
&& forall s. Data s => s -> Bool
isUnit d2
sR)

compositionShow :: (Data s1, Data s2) => Composition s1 s2 -> String
compositionShow :: forall s1 s2. (Data s1, Data s2) => Composition s1 s2 -> String
compositionShow (Composition s1
s1 s2
s2)
  | forall s. Data s => s -> Bool
isUnit s1
s1 = forall s. Data s => s -> String
stateShow s2
s2
  | forall s. Data s => s -> Bool
isUnit s2
s2 = forall s. Data s => s -> String
stateShow s1
s1
  | Bool
otherwise = forall s. Data s => s -> String
stateShow s1
s1 forall a. [a] -> [a] -> [a]
++ String
" >>> " forall a. [a] -> [a] -> [a]
++ 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 s1 s2. (Data s1, Data s2) => Parallel s1 s2 -> String
parallelShow (Parallel s1
s1 s2
s2)
  | forall s. Data s => s -> Bool
isUnit s1
s1 = forall s. Data s => s -> String
stateShow s2
s2
  | forall s. Data s => s -> Bool
isUnit s2
s2 = forall s. Data s => s -> String
stateShow s1
s1
  | Bool
otherwise = String
"(" forall a. [a] -> [a] -> [a]
++ forall s. Data s => s -> String
stateShow s1
s1 forall a. [a] -> [a] -> [a]
++ String
" *** " forall a. [a] -> [a] -> [a]
++ forall s. Data s => s -> String
stateShow s2
s2 forall a. [a] -> [a] -> [a]
++ String
")"

foreverEShow :: (Data e, Data s) => ForeverE e s -> String
foreverEShow :: forall e s. (Data e, Data s) => 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("
    forall a. [a] -> [a] -> [a]
++ (if forall s. Data s => s -> Bool
isUnit e
lastException then String
"" else forall s. Data s => s -> String
gshow e
lastException forall a. [a] -> [a] -> [a]
++ String
", ")
    forall a. [a] -> [a] -> [a]
++ forall s. Data s => s -> String
stateShow s
initState
    forall a. [a] -> [a] -> [a]
++ String
"): "
    forall a. [a] -> [a] -> [a]
++ forall s. Data s => s -> String
stateShow s
currentState

feedbackShow :: (Data state, Data s) => Feedback state s -> String
feedbackShow :: forall state s. (Data state, Data s) => 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 " forall a. [a] -> [a] -> [a]
++ forall s. Data s => s -> String
gshow s
sAdditional forall a. [a] -> [a] -> [a]
++ String
" $ " forall a. [a] -> [a] -> [a]
++ forall s. Data s => s -> String
stateShow state
sPrevious

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

choiceShow :: (Data stateL, Data stateR) => Choice stateL stateR -> String
choiceShow :: forall stateL stateR.
(Data stateL, Data stateR) =>
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
..}
  | forall s. Data s => s -> Bool
isUnit stateL
choiceLeft = String
"+" forall a. [a] -> [a] -> [a]
++ forall s. Data s => s -> String
stateShow stateR
choiceRight forall a. [a] -> [a] -> [a]
++ String
"+"
  | forall s. Data s => s -> Bool
isUnit stateR
choiceRight = String
"+" forall a. [a] -> [a] -> [a]
++ forall s. Data s => s -> String
stateShow stateL
choiceLeft forall a. [a] -> [a] -> [a]
++ String
"+"
  | Bool
otherwise = String
"+" forall a. [a] -> [a] -> [a]
++ forall s. Data s => s -> String
stateShow stateL
choiceLeft forall a. [a] -> [a] -> [a]
++ String
" +++ " forall a. [a] -> [a] -> [a]
++ forall s. Data s => s -> String
stateShow stateR
choiceRight 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\t :~: t'
Refl -> f (t a b c)
x) (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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe f a
def forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ 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 = forall q x. Q q x -> x -> q
unQ ((forall q x. (x -> q) -> Q q x
Q a -> q
def) 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` (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}