{-# OPTIONS_GHC -Wno-orphans #-}

module Graphics.HaGL.Print (printGLExpr) where

import Prelude hiding (id)
import Control.Monad.State.Lazy (State, execState, gets, modify)
import qualified Data.Set as Set

import Graphics.HaGL.GLExpr
import Graphics.HaGL.ExprID
import Graphics.HaGL.GLAst


-- GLAst printers for debugging purposes

printGLExpr :: IsGLDomain d => GLExpr d t -> String
printGLExpr :: forall (d :: GLDomain) t. IsGLDomain d => GLExpr d t -> String
printGLExpr = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (d :: GLDomain) t. IsGLDomain d => GLExpr d t -> GLAst
toGLAst

instance Show GLAst where
    show :: GLAst -> String
show = Printer -> String
runPrinter forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLAst -> Printer
printGLAst

instance Show GLDomain where
    show :: GLDomain -> String
show GLDomain
ConstDomain = String
"const"
    show GLDomain
HostDomain = String
"host"
    show GLDomain
VertexDomain = String
"vert"
    show GLDomain
FragmentDomain = String
"frag"

-- set to 0 for no limit
maxDepth :: Int
maxDepth = Int
16

data PrintState = PrintState {
    PrintState -> Int
depth :: Int,
    PrintState -> Set ExprID
traversedIds :: Set.Set ExprID,
    PrintState -> String
buf :: String
}

type Printer = State PrintState ()

runPrinter :: Printer -> String
runPrinter :: Printer -> String
runPrinter Printer
pr = PrintState -> String
buf forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState Printer
pr 
    PrintState { depth :: Int
depth = Int
0, traversedIds :: Set ExprID
traversedIds = forall a. Set a
Set.empty, buf :: String
buf = String
"" }

printGLAst :: GLAst -> Printer
printGLAst :: GLAst -> Printer
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty (Const t
_)) =
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"const"
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty GLAtom d t
GenVar) =
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"genVar"
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty (Uniform GLExpr 'HostDomain t
x)) = do
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"uniform"
    ExprID -> Printer -> Printer
ifNotTraversed ExprID
id forall a b. (a -> b) -> a -> b
$
        Printer -> Printer
indented forall a b. (a -> b) -> a -> b
$ GLAst -> Printer
printGLAst forall a b. (a -> b) -> a -> b
$ forall (d :: GLDomain) t. IsGLDomain d => GLExpr d t -> GLAst
toGLAst GLExpr 'HostDomain t
x
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty (GenericUniform String
label)) = do
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty (String
"user-def.: " forall a. [a] -> [a] -> [a]
++ String
label)
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty (Inp [GLExpr 'ConstDomain t]
_)) =
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"inp"
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty (Frag InterpolationType
_ GLExpr 'VertexDomain t
x)) = do
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"frag"
    ExprID -> Printer -> Printer
ifNotTraversed ExprID
id forall a b. (a -> b) -> a -> b
$
        Printer -> Printer
indented forall a b. (a -> b) -> a -> b
$ GLAst -> Printer
printGLAst forall a b. (a -> b) -> a -> b
$ forall (d :: GLDomain) t. IsGLDomain d => GLExpr d t -> GLAst
toGLAst GLExpr 'VertexDomain t
x
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty (IOFloat String
_)) =
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"ioFloat"
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty (IODouble String
_)) =
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"ioDouble"
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty (IOInt String
_)) =
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"ioInt"
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty (IOUInt String
_)) =
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"ioUInt"
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty (IOBool String
_)) =
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"ioBool"
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty (IOPrec GLExpr 'HostDomain t
x0 GLExpr 'HostDomain t
x)) = do
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"ioPrec"
    ExprID -> Printer -> Printer
ifNotTraversed ExprID
id forall a b. (a -> b) -> a -> b
$ do
        Printer -> Printer
indented forall a b. (a -> b) -> a -> b
$ GLAst -> Printer
printGLAst forall a b. (a -> b) -> a -> b
$ forall (d :: GLDomain) t. IsGLDomain d => GLExpr d t -> GLAst
toGLAst GLExpr 'HostDomain t
x0
        Printer -> Printer
indented forall a b. (a -> b) -> a -> b
$ GLAst -> Printer
printGLAst forall a b. (a -> b) -> a -> b
$ forall (d :: GLDomain) t. IsGLDomain d => GLExpr d t -> GLAst
toGLAst GLExpr 'HostDomain t
x
printGLAst (GLAstAtom ExprID
id GLTypeInfo
ty GLAtom d t
_) =
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"glLift"
printGLAst (GLAstFunc ExprID
id GLTypeInfo
ty GLAst
r [GLAst]
params) = do
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"glFunc"
    ExprID -> Printer -> Printer
ifNotTraversed ExprID
id forall a b. (a -> b) -> a -> b
$ do
        Printer -> Printer
indented forall a b. (a -> b) -> a -> b
$ GLAst -> Printer
printGLAst GLAst
r
        Printer -> Printer
indented forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GLAst -> Printer
printGLAst [GLAst]
params
printGLAst (GLAstFuncApp ExprID
id GLTypeInfo
ty GLAst
fn [GLAst]
args) = do
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
"glFunc app"
    ExprID -> Printer -> Printer
ifNotTraversed ExprID
id forall a b. (a -> b) -> a -> b
$ do
        Printer -> Printer
indented forall a b. (a -> b) -> a -> b
$ GLAst -> Printer
printGLAst GLAst
fn
        Printer -> Printer
indented forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GLAst -> Printer
printGLAst [GLAst]
args
printGLAst (GLAstExpr ExprID
id GLTypeInfo
ty String
op [GLAst]
xs) = do
    ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
op
    ExprID -> Printer -> Printer
ifNotTraversed ExprID
id forall a b. (a -> b) -> a -> b
$
        Printer -> Printer
indented forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ GLAst -> Printer
printGLAst [GLAst]
xs

printNode :: ExprID -> GLTypeInfo -> String -> Printer
printNode :: ExprID -> GLTypeInfo -> String -> Printer
printNode ExprID
id GLTypeInfo
ty String
str = do
    String -> Printer
printLine forall a b. (a -> b) -> a -> b
$ String
str forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ ExprID -> String
idLabel ExprID
id forall a. [a] -> [a] -> [a]
++ String
" : " forall a. [a] -> [a] -> [a]
++ 
        forall a. Show a => a -> String
show (GLTypeInfo -> GLDomain
shaderType GLTypeInfo
ty) forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ GLTypeInfo -> String
exprType GLTypeInfo
ty

printStr :: String -> Printer
printStr :: String -> Printer
printStr String
s = do
    Int
depth <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrintState -> Int
depth
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PrintState
ps -> PrintState
ps { buf :: String
buf = PrintState -> String
buf PrintState
ps forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
2 forall a. Num a => a -> a -> a
* Int
depth) Char
' ' forall a. [a] -> [a] -> [a]
++ String
s })

printLine :: String -> Printer
printLine :: String -> Printer
printLine = String -> Printer
printStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ String
"\n")

indented :: Printer -> Printer
indented :: Printer -> Printer
indented Printer
printer = do
    Int
d <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrintState -> Int
depth
    if Int
maxDepth forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
d forall a. Ord a => a -> a -> Bool
> Int
maxDepth then String -> Printer
printLine String
"  ..." else do
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PrintState
ps -> PrintState
ps { depth :: Int
depth = PrintState -> Int
depth PrintState
ps forall a. Num a => a -> a -> a
+ Int
1 })
        Printer
printer
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PrintState
ps -> PrintState
ps { depth :: Int
depth = PrintState -> Int
depth PrintState
ps forall a. Num a => a -> a -> a
- Int
1 })

ifNotTraversed :: ExprID -> Printer -> Printer
ifNotTraversed :: ExprID -> Printer -> Printer
ifNotTraversed ExprID
id Printer
printAction = do
    Set ExprID
ids <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PrintState -> Set ExprID
traversedIds
    if ExprID
id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set ExprID
ids then
        String -> Printer
printLine String
"  ..."
    else do
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\PrintState
ps -> PrintState
ps { traversedIds :: Set ExprID
traversedIds = forall a. Ord a => a -> Set a -> Set a
Set.insert ExprID
id (PrintState -> Set ExprID
traversedIds PrintState
ps) })
        Printer
printAction