{-# 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
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"
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