{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module ConCat.Graphics.GLSL
( genHtml,runHtml, Widgets
, unitW, timeW, sliderW, pairW
) where
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import Text.Printf (printf)
import System.Directory (createDirectoryIfMissing)
import qualified System.Info as SI
import qualified Data.Aeson as J
import Data.Aeson (ToJSON(..),object,(.=))
import Data.Aeson.Encode.Pretty (encodePretty',Config(..),defConfig,keyOrder)
import qualified Data.Text as T
import qualified Data.ByteString.Lazy.Char8 as BS
import Text.ParserCombinators.Parsec (runParser,ParseError)
import Text.PrettyPrint.HughesPJClass
import Language.GLSL.Syntax
import Language.GLSL.Pretty ()
import Language.GLSL.Parser
import ConCat.Misc ((:*),R)
import qualified ConCat.AltCat as A
import ConCat.Circuit
(Bus(..),GenBuses,busTy,(:>),simpleComp,mkGraph,CompS(..),systemSuccess)
import qualified ConCat.Circuit as C
import ConCat.Graphics.Image (ImageC)
effectHtml :: GenBuses a => Widgets a -> (a :> ImageC) -> String
effectHtml :: forall a. GenBuses a => Widgets a -> (a :> ImageC) -> String
effectHtml Widgets a
widgets a :> ImageC
effect = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
[ String
"<!DOCTYPE html>" , String
"<html>" , String
"<head>"
, String
"<meta charset='utf-8'/>"
, String
"<link rel=stylesheet href=https://code.jquery.com/ui/1.12.1/themes/ui-lightness/jquery-ui.css>"
, String
"<script src=https://code.jquery.com/jquery-1.12.4.js></script>"
, String
"<script src=https://code.jquery.com/ui/1.12.1/jquery-ui.js></script>"
, String
"<script src=script.js></script>"
, String
"<link rel=stylesheet href=style.css>"
, String
"</head>"
, String
"<body onload='go(uniforms,effect)'>"
, String
"<div id=ui></div>"
, String
"<canvas id=effect></canvas>"
, String
"</body>" , String
"</html>"
, String
"<script>"
, Shader a -> String
forall a. Shader a -> String
shaderDefs (Widgets a -> (a :> ImageC) -> Shader a
forall a. GenBuses a => Widgets a -> (a :> ImageC) -> Shader a
glsl Widgets a
widgets a :> ImageC
effect)
, String
"</script>" ]
shaderDefs :: Shader a -> String
shaderDefs :: forall a. Shader a -> String
shaderDefs (Shader [UVar]
uniforms ExternalDeclaration
def) =
String
"var uniforms = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BS.unpack (Config -> [UVar] -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
prettyConfig [UVar]
uniforms) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"var effect = `\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExternalDeclaration -> String
forall a. Pretty a => a -> String
prettyShow ExternalDeclaration
def String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"`;"
genHtml :: GenBuses a => String -> Widgets a -> (a :> ImageC) -> IO ()
genHtml :: forall a.
GenBuses a =>
String -> Widgets a -> (a :> ImageC) -> IO ()
genHtml String
name Widgets a
widgets a :> ImageC
effect =
do Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
outDir
let o :: String
o = String -> String
outFile String
name
String -> String -> IO ()
writeFile String
o (Widgets a -> (a :> ImageC) -> String
forall a. GenBuses a => Widgets a -> (a :> ImageC) -> String
effectHtml Widgets a
widgets a :> ImageC
effect)
String -> IO ()
putStrLn (String
"Wrote " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o)
runHtml :: GenBuses a => String -> Widgets a -> (a :> ImageC) -> IO ()
runHtml :: forall a.
GenBuses a =>
String -> Widgets a -> (a :> ImageC) -> IO ()
runHtml String
name Widgets a
widgets a :> ImageC
effect =
do String -> Widgets a -> (a :> ImageC) -> IO ()
forall a.
GenBuses a =>
String -> Widgets a -> (a :> ImageC) -> IO ()
genHtml String
name Widgets a
widgets a :> ImageC
effect
String -> IO ()
systemSuccess (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s %s" String
open (String -> String
outFile String
name)
outDir :: String
outDir :: String
outDir = String
"out/shaders"
outFile :: String -> String
outFile :: String -> String
outFile String
name = String
outDirString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"/"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
".html"
open :: String
open :: String
open = case String
SI.os of
String
"darwin" -> String
"open"
String
"linux" -> String
"display"
String
_ -> String -> String
forall a. HasCallStack => String -> a
error String
"unknown open for OS"
glsl :: GenBuses a => Widgets a -> (a :> ImageC) -> Shader a
glsl :: forall a. GenBuses a => Widgets a -> (a :> ImageC) -> Shader a
glsl Widgets a
widgets = Widgets a -> [CompS] -> Shader a
forall a. Widgets a -> [CompS] -> Shader a
compsShader Widgets a
widgets
([CompS] -> Shader a)
-> ((a :> ImageC) -> [CompS]) -> (a :> ImageC) -> Shader a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comp -> CompS) -> [Comp] -> [CompS]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Comp -> CompS
simpleComp
([Comp] -> [CompS])
-> ((a :> ImageC) -> [Comp]) -> (a :> ImageC) -> [CompS]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Prod (:>) a (R, R) :> Color) -> [Comp]
forall a b. Ok2 (:>) a b => (a :> b) -> [Comp]
mkGraph
((Prod (:>) a (R, R) :> Color) -> [Comp])
-> ((a :> ImageC) -> Prod (:>) a (R, R) :> Color)
-> (a :> ImageC)
-> [Comp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a :> ImageC) -> Prod (:>) a (R, R) :> Color
forall (k :: * -> * -> *) a b c.
(ClosedCat k, Ok3 k a b c) =>
k a (Exp k b c) -> k (Prod k a b) c
A.uncurry
compsShader :: Widgets a -> [CompS] -> Shader a
compsShader :: forall a. Widgets a -> [CompS] -> Shader a
compsShader Widgets a
widgets [CompS]
comps
| (CompS Int
_ String
"In" [] [Bus]
inputs,[CompS]
mid, (CompS Int
_ String
"Out" [Bus]
rgba [Bus]
_)) <- [CompS] -> (CompS, [CompS], CompS)
splitComps [CompS]
comps
, let (Map Bus Expr
bindings, [(Bus, Expr)]
assignments) = Map Bus Int -> [CompS] -> (Map Bus Expr, [(Bus, Expr)])
accumComps ([CompS] -> Map Bus Int
uses [CompS]
comps) [CompS]
mid
([Bus]
uniforms,[Bus]
varyings) = Int -> [Bus] -> ([Bus], [Bus])
forall a. Int -> [a] -> ([a], [a])
splitAt' Int
2 [Bus]
inputs
= [UVar] -> ExternalDeclaration -> Shader a
forall a. [UVar] -> ExternalDeclaration -> Shader a
Shader ((Bus -> Widget -> UVar) -> [Bus] -> [Widget] -> [UVar]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bus -> Widget -> UVar
busUVar [Bus]
uniforms (Widgets a -> [Widget]
forall a. Widgets a -> [Widget]
flattenWidgets Widgets a
widgets))
(TypeSpecifierNonArray
-> String
-> [ParameterDeclaration]
-> [Statement]
-> ExternalDeclaration
funDef TypeSpecifierNonArray
Vec4 String
"effect" (Bus -> ParameterDeclaration
paramDecl (Bus -> ParameterDeclaration) -> [Bus] -> [ParameterDeclaration]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Bus]
varyings)
(((Bus, Expr) -> Statement) -> [(Bus, Expr)] -> [Statement]
forall a b. (a -> b) -> [a] -> [b]
map ((Bus -> Expr -> Statement) -> (Bus, Expr) -> Statement
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bus -> Expr -> Statement
initBus) [(Bus, Expr)]
assignments
[Statement] -> [Statement] -> [Statement]
forall a. [a] -> [a] -> [a]
++ [Maybe Expr -> Statement
Return (Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Ty -> String -> [Expr] -> Expr
app (String -> Ty
forall a. HasCallStack => String -> a
error String
"compsShader: app ty oops") String
"vec4" (Map Bus Expr -> Bus -> Expr
simpleE Map Bus Expr
bindings (Bus -> Expr) -> [Bus] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Bus]
rgba)))]))
compsShader Widgets a
_ [CompS]
comps =
String -> Shader a
forall a. HasCallStack => String -> a
error (String
"ConCat.GLSL.compsShader: unexpected subgraph comp " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [CompS] -> String
forall a. Show a => a -> String
show [CompS]
comps)
simpleE :: M.Map Bus Expr -> Bus -> Expr
simpleE :: Map Bus Expr -> Bus -> Expr
simpleE Map Bus Expr
bindings Bus
b = Expr -> Maybe Expr -> Expr
forall a. a -> Maybe a -> a
fromMaybe (Bus -> Expr
bToE Bus
b) (Bus -> Map Bus Expr -> Maybe Expr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Bus
b Map Bus Expr
bindings)
uses :: [CompS] -> M.Map Bus Int
uses :: [CompS] -> Map Bus Int
uses = (Int -> Int -> Int) -> [Map Bus Int] -> Map Bus Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ([Map Bus Int] -> Map Bus Int)
-> ([CompS] -> [Map Bus Int]) -> [CompS] -> Map Bus Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompS -> Map Bus Int) -> [CompS] -> [Map Bus Int]
forall a b. (a -> b) -> [a] -> [b]
map CompS -> Map Bus Int
uses1
uses1 :: CompS -> M.Map Bus Int
uses1 :: CompS -> Map Bus Int
uses1 (CompS Int
_ String
_ [Bus]
ins [Bus]
_) = (Int -> Int -> Int) -> [Map Bus Int] -> Map Bus Int
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ((Bus -> Int -> Map Bus Int) -> Int -> Bus -> Map Bus Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bus -> Int -> Map Bus Int
forall k a. k -> a -> Map k a
M.singleton Int
1 (Bus -> Map Bus Int) -> [Bus] -> [Map Bus Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Bus]
ins)
nestExpressions :: Bool
nestExpressions :: Bool
nestExpressions = Bool
True
accumComps :: M.Map Bus Int -> [CompS] -> (M.Map Bus Expr, [(Bus,Expr)])
accumComps :: Map Bus Int -> [CompS] -> (Map Bus Expr, [(Bus, Expr)])
accumComps Map Bus Int
counts = Map Bus Expr -> [CompS] -> (Map Bus Expr, [(Bus, Expr)])
go Map Bus Expr
forall k a. Map k a
M.empty
where
go :: M.Map Bus Expr -> [CompS] -> (M.Map Bus Expr, [(Bus,Expr)])
go :: Map Bus Expr -> [CompS] -> (Map Bus Expr, [(Bus, Expr)])
go Map Bus Expr
saved [] = (Map Bus Expr
saved, [])
go Map Bus Expr
saved (c :: CompS
c@(CompS Int
_ String
_ [Bus]
_ [Bus
o]) : [CompS]
comps)
| Just Int
n <- Bus -> Map Bus Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Bus
o Map Bus Int
counts, (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
nestExpressions) =
let (Map Bus Expr
saved',[(Bus, Expr)]
assignments') = Map Bus Expr -> [CompS] -> (Map Bus Expr, [(Bus, Expr)])
go Map Bus Expr
saved [CompS]
comps in
(Map Bus Expr
saved', (Bus
o,Expr
e) (Bus, Expr) -> [(Bus, Expr)] -> [(Bus, Expr)]
forall a. a -> [a] -> [a]
: [(Bus, Expr)]
assignments')
| Bool
otherwise = Map Bus Expr -> [CompS] -> (Map Bus Expr, [(Bus, Expr)])
go (Bus -> Expr -> Map Bus Expr -> Map Bus Expr
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Bus
o Expr
e Map Bus Expr
saved) [CompS]
comps
where
e :: Expr
e = Map Bus Expr -> CompS -> Expr
compExpr Map Bus Expr
saved CompS
c
go Map Bus Expr
_saved [CompS Int
_ String
"Out" [Bus]
_ [Bus]
_ ] = String -> (Map Bus Expr, [(Bus, Expr)])
forall a. HasCallStack => String -> a
error String
"accumComps: Out"
go Map Bus Expr
_ [CompS]
c = String -> (Map Bus Expr, [(Bus, Expr)])
forall a. HasCallStack => String -> a
error (String
"ConCat.GLSL.accumComps: oops: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [CompS] -> String
forall a. Show a => a -> String
show [CompS]
c)
compExpr :: M.Map Bus Expr -> CompS -> Expr
compExpr :: Map Bus Expr -> CompS -> Expr
compExpr Map Bus Expr
_ (CompS Int
_ String
str [] [Bus Int
_ Int
_ Ty
ty]) = Ty -> String -> Expr
constExpr Ty
ty String
str
compExpr Map Bus Expr
saved (CompS Int
_ String
prim [Bus]
ins [Bus Int
_ Int
_ Ty
ty]) = Ty -> String -> [Expr] -> Expr
app Ty
ty String
prim (Bus -> Expr
inExpr (Bus -> Expr) -> [Bus] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Bus]
ins)
where
inExpr :: Bus -> Expr
inExpr :: Bus -> Expr
inExpr Bus
b | Just Expr
e <- Bus -> Map Bus Expr -> Maybe Expr
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Bus
b Map Bus Expr
saved = Expr
e
| Bool
otherwise = Bus -> Expr
bToE Bus
b
compExpr Map Bus Expr
_ CompS
comp = String -> Expr
forall a. HasCallStack => String -> a
error (String
"ConCat.GLSL.compExpr: unexpected subgraph comp " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CompS -> String
forall a. Show a => a -> String
show CompS
comp)
constExpr :: C.Ty -> String -> Expr
constExpr :: Ty -> String -> Expr
constExpr Ty
C.Bool = Bool -> Expr
BoolConstant (Bool -> Expr) -> (String -> Bool) -> String -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. Read a => String -> a
read
constExpr Ty
C.Int = IntConstantKind -> Integer -> Expr
IntConstant IntConstantKind
Decimal (Integer -> Expr) -> (String -> Integer) -> String -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer
forall a. Read a => String -> a
read
constExpr Ty
C.Integer = Integer -> Expr
integerConstant (Integer -> Expr) -> (String -> Integer) -> String -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer
forall a. Read a => String -> a
read
constExpr Ty
C.Float = Float -> Expr
FloatConstant (Float -> Expr) -> (String -> Float) -> String -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Float
forall a. Read a => String -> a
read
constExpr Ty
C.Double = Float -> Expr
FloatConstant (Float -> Expr) -> (String -> Float) -> String -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Float
forall a. Read a => String -> a
read
constExpr Ty
ty = String -> String -> Expr
forall a. HasCallStack => String -> a
error (String
"ConCat.GLSL.constExpr: unexpected literal type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ty -> String
forall a. Show a => a -> String
show Ty
ty)
integerConstant :: Integer -> Expr
integerConstant :: Integer -> Expr
integerConstant = IntConstantKind -> Integer -> Expr
IntConstant IntConstantKind
Decimal (Integer -> Expr) -> (Integer -> Integer) -> Integer -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Num a => Integer -> a
fromInteger
busType :: Bus -> TypeSpecifierNonArray
busType :: Bus -> TypeSpecifierNonArray
busType = Ty -> TypeSpecifierNonArray
glslTy (Ty -> TypeSpecifierNonArray)
-> (Bus -> Ty) -> Bus -> TypeSpecifierNonArray
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bus -> Ty
busTy
initBus :: Bus -> Expr -> Statement
initBus :: Bus -> Expr -> Statement
initBus Bus
b Expr
e = Declaration -> Statement
DeclarationStatement (Maybe TypeQualifier
-> TypeSpecifierNonArray -> String -> Maybe Expr -> Declaration
decl Maybe TypeQualifier
forall a. Maybe a
Nothing (Bus -> TypeSpecifierNonArray
busType Bus
b) (Bus -> String
varName Bus
b) (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
e))
glslTy :: C.Ty -> TypeSpecifierNonArray
glslTy :: Ty -> TypeSpecifierNonArray
glslTy Ty
C.Int = TypeSpecifierNonArray
Int
glslTy Ty
C.Bool = TypeSpecifierNonArray
Bool
glslTy Ty
C.Float = TypeSpecifierNonArray
Float
glslTy Ty
C.Double = TypeSpecifierNonArray
Float
glslTy Ty
ty = String -> TypeSpecifierNonArray
forall a. HasCallStack => String -> a
error (String
"ConCat.GLSL.glslTy: unsupported type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ty -> String
forall a. Show a => a -> String
show Ty
ty)
varName :: Bus -> String
varName :: Bus -> String
varName (Bus Int
0 Int
n Ty
_) = String
"in" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
varName (Bus Int
c Int
0 Ty
_) = String
"v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
c
varName Bus
b = String -> String
forall a. HasCallStack => String -> a
error (String
"ConCat.GLSL.varName unexpected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bus -> String
forall a. Show a => a -> String
show Bus
b)
app :: C.Ty -> String -> [Expr] -> Expr
app :: Ty -> String -> [Expr] -> Expr
app Ty
ty String
nm [Expr]
es =
case String
nm of
String
"not" -> (Expr -> Expr) -> Expr
app1 Expr -> Expr
UnaryNot
String
"&&" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
And
String
"||" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Or
String
"<" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Lt
String
">" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Gt
String
"<=" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Lte
String
">=" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Gte
String
"==" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Equ
String
"/=" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Neq
String
"negate" -> (Expr -> Expr) -> Expr
app1 Expr -> Expr
UnaryNegate
String
"+" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Add
String
"-" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Sub
String
"−" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Sub
String
"*" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Mul
String
"/" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Div
String
"mod" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Mod
String
"xor" -> (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
Neq
String
"if" -> (Expr -> Expr -> Expr -> Expr) -> Expr
app3 Expr -> Expr -> Expr -> Expr
Selection
String
"fromIntegral" -> String -> [Expr] -> Expr
funcall (TypeSpecifierNonArray -> String
forall {a}. IsString a => TypeSpecifierNonArray -> a
castFun (Ty -> TypeSpecifierNonArray
glslTy Ty
ty)) [Expr]
es
String
_ | Just String
fun <- String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
nm Map String String
knownFuncs -> String -> [Expr] -> Expr
funcall String
fun [Expr]
es
| Bool
otherwise -> String -> Expr
forall a. HasCallStack => String -> a
error (String
"ConCat.GLSL.app: not supported: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String, [Expr]) -> String
forall a. Show a => a -> String
show (String
nm,[Expr]
es))
where
err :: String -> Expr
err String
str = String -> Expr
forall a. HasCallStack => String -> a
error (String
"app " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": expecting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Expr] -> String
forall a. Show a => a -> String
show [Expr]
es)
app1 :: (Expr -> Expr) -> Expr
app1 Expr -> Expr
op | [Expr
e] <- [Expr]
es = Expr -> Expr
op Expr
e
| Bool
otherwise = String -> Expr
err String
"one argument"
app2 :: (Expr -> Expr -> Expr) -> Expr
app2 Expr -> Expr -> Expr
op | [Expr
e1,Expr
e2] <- [Expr]
es = Expr -> Expr -> Expr
op Expr
e1 Expr
e2
| Bool
otherwise = String -> Expr
err String
"two arguments"
app3 :: (Expr -> Expr -> Expr -> Expr) -> Expr
app3 Expr -> Expr -> Expr -> Expr
op | [Expr
e1,Expr
e2,Expr
e3] <- [Expr]
es = Expr -> Expr -> Expr -> Expr
op Expr
e1 Expr
e2 Expr
e3
| Bool
otherwise = String -> Expr
err String
"three arguments"
castFun :: TypeSpecifierNonArray -> a
castFun TypeSpecifierNonArray
Float = a
"float"
castFun TypeSpecifierNonArray
t = String -> a
forall a. HasCallStack => String -> a
error (String
"ConCat.GLSL.app: fromIntegral on type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeSpecifierNonArray -> String
forall a. Show a => a -> String
show TypeSpecifierNonArray
t)
knownFuncs :: M.Map String String
knownFuncs :: Map String String
knownFuncs = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, String)] -> Map String String)
-> [(String, String)] -> Map String String
forall a b. (a -> b) -> a -> b
$
[(String
"ceiling",String
"ceil")]
[(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ ((\ String
s -> (String
s,String
s)) (String -> (String, String)) -> [String] -> [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String
"exp",String
"log",String
"cos",String
"sin",String
"floor",String
"vec4"])
bToE :: Bus -> Expr
bToE :: Bus -> Expr
bToE = String -> Expr
Variable (String -> Expr) -> (Bus -> String) -> Bus -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bus -> String
varName
splitComps :: [CompS] -> (CompS,[CompS],CompS)
splitComps :: [CompS] -> (CompS, [CompS], CompS)
splitComps (i :: CompS
i@(CompS Int
_ String
"In" [] [Bus]
_)
: ([CompS] -> ([CompS], CompS)
forall a. [a] -> ([a], a)
unsnoc -> ([CompS]
mid,o :: CompS
o@(CompS Int
_ String
"Out" [Bus]
_ [])))) = (CompS
i,[CompS]
mid,CompS
o)
splitComps [CompS]
comps = String -> (CompS, [CompS], CompS)
forall a. HasCallStack => String -> a
error (String
"ConCat.GLSL.splitComps: Oops: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [CompS] -> String
forall a. Show a => a -> String
show [CompS]
comps)
unsnoc :: [a] -> ([a],a)
unsnoc :: forall a. [a] -> ([a], a)
unsnoc [a]
as = ([a]
mid,a
o) where ([a]
mid,[a
o]) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt' Int
1 [a]
as
splitAt' :: Int -> [a] -> ([a], [a])
splitAt' :: forall a. Int -> [a] -> ([a], [a])
splitAt' Int
n [a]
as = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
as Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) [a]
as
_parse :: P a -> String -> Either ParseError a
_parse :: forall a. P a -> String -> Either ParseError a
_parse P a
p = P a -> S -> String -> String -> Either ParseError a
forall tok st a.
GenParser tok st a -> st -> String -> [tok] -> Either ParseError a
runParser P a
p S
S String
"GLSL"
decl :: Maybe TypeQualifier -> TypeSpecifierNonArray -> String -> Maybe Expr -> Declaration
decl :: Maybe TypeQualifier
-> TypeSpecifierNonArray -> String -> Maybe Expr -> Declaration
decl Maybe TypeQualifier
mbTq TypeSpecifierNonArray
ty String
var Maybe Expr
mbe =
InvariantOrType -> [InitDeclarator] -> Declaration
InitDeclaration (
FullType -> InvariantOrType
TypeDeclarator (
Maybe TypeQualifier -> TypeSpecifier -> FullType
FullType Maybe TypeQualifier
mbTq (Maybe PrecisionQualifier
-> TypeSpecifierNoPrecision -> TypeSpecifier
TypeSpec Maybe PrecisionQualifier
forall a. Maybe a
Nothing (TypeSpecifierNonArray
-> Maybe (Maybe Expr) -> TypeSpecifierNoPrecision
TypeSpecNoPrecision TypeSpecifierNonArray
ty Maybe (Maybe Expr)
forall a. Maybe a
Nothing))))
[String -> Maybe (Maybe Expr) -> Maybe Expr -> InitDeclarator
InitDecl String
var Maybe (Maybe Expr)
forall a. Maybe a
Nothing Maybe Expr
mbe]
paramDecl :: Bus -> ParameterDeclaration
paramDecl :: Bus -> ParameterDeclaration
paramDecl Bus
b =
Maybe ParameterTypeQualifier
-> Maybe ParameterQualifier
-> TypeSpecifier
-> Maybe (String, Maybe Expr)
-> ParameterDeclaration
ParameterDeclaration Maybe ParameterTypeQualifier
forall a. Maybe a
Nothing Maybe ParameterQualifier
forall a. Maybe a
Nothing
(Maybe PrecisionQualifier
-> TypeSpecifierNoPrecision -> TypeSpecifier
TypeSpec Maybe PrecisionQualifier
forall a. Maybe a
Nothing (TypeSpecifierNonArray
-> Maybe (Maybe Expr) -> TypeSpecifierNoPrecision
TypeSpecNoPrecision (Bus -> TypeSpecifierNonArray
busType Bus
b) Maybe (Maybe Expr)
forall a. Maybe a
Nothing))
((String, Maybe Expr) -> Maybe (String, Maybe Expr)
forall a. a -> Maybe a
Just (Bus -> String
varName Bus
b,Maybe Expr
forall a. Maybe a
Nothing))
funDef :: TypeSpecifierNonArray -> String -> [ParameterDeclaration]
-> [Statement] -> ExternalDeclaration
funDef :: TypeSpecifierNonArray
-> String
-> [ParameterDeclaration]
-> [Statement]
-> ExternalDeclaration
funDef TypeSpecifierNonArray
resultTy String
name [ParameterDeclaration]
params [Statement]
statements =
FunctionPrototype -> Compound -> ExternalDeclaration
FunctionDefinition (
FullType -> String -> [ParameterDeclaration] -> FunctionPrototype
FuncProt (Maybe TypeQualifier -> TypeSpecifier -> FullType
FullType Maybe TypeQualifier
forall a. Maybe a
Nothing
(Maybe PrecisionQualifier
-> TypeSpecifierNoPrecision -> TypeSpecifier
TypeSpec Maybe PrecisionQualifier
forall a. Maybe a
Nothing (TypeSpecifierNonArray
-> Maybe (Maybe Expr) -> TypeSpecifierNoPrecision
TypeSpecNoPrecision TypeSpecifierNonArray
resultTy Maybe (Maybe Expr)
forall a. Maybe a
Nothing)))
String
name [ParameterDeclaration]
params)
([Statement] -> Compound
Compound [Statement]
statements)
funcall :: String -> [Expr] -> Expr
funcall :: String -> [Expr] -> Expr
funcall String
fun [Expr]
args = FunctionIdentifier -> Parameters -> Expr
FunctionCall (String -> FunctionIdentifier
FuncId String
fun) ([Expr] -> Parameters
Params [Expr]
args)
data Widget = Time | Slider String (R,R) R
instance Show Widget where
show :: Widget -> String
show Widget
Time = String
"Time"
show (Slider String
lab (R, R)
bounds R
start) =
String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Slider %s %s %s" String
lab ((R, R) -> String
forall a. Show a => a -> String
show (R, R)
bounds) (R -> String
forall a. Show a => a -> String
show R
start)
instance ToJSON Widget where
toJSON :: Widget -> Value
toJSON Widget
Time = [Pair] -> Value
object [Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Text
T.pack String
"time"]
toJSON (Slider String
label (R
lo,R
hi) R
start) =
[Pair] -> Value
object [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String -> Text
T.pack String
"slider"
, Key
"label" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String
label
, Key
"min" Key -> R -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= R
lo
, Key
"max" Key -> R -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= R
hi
, Key
"value" Key -> R -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= R
start
]
prettyConfig :: Config
prettyConfig :: Config
prettyConfig = Config
defConfig { confCompare :: Text -> Text -> Ordering
confCompare = [Text] -> Text -> Text -> Ordering
keyOrder [Text]
keys }
where
keys :: [Text]
keys = [Text
"uniforms",Text
"definition",Text
"type",Text
"name",Text
"widget",Text
"label",Text
"min",Text
"max",Text
"value"]
data UVar = UVar TypeSpecifierNonArray String Widget deriving Int -> UVar -> String -> String
[UVar] -> String -> String
UVar -> String
(Int -> UVar -> String -> String)
-> (UVar -> String) -> ([UVar] -> String -> String) -> Show UVar
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UVar -> String -> String
showsPrec :: Int -> UVar -> String -> String
$cshow :: UVar -> String
show :: UVar -> String
$cshowList :: [UVar] -> String -> String
showList :: [UVar] -> String -> String
Show
busUVar :: Bus -> Widget -> UVar
busUVar :: Bus -> Widget -> UVar
busUVar Bus
b = TypeSpecifierNonArray -> String -> Widget -> UVar
UVar (Bus -> TypeSpecifierNonArray
busType Bus
b) (Bus -> String
varName Bus
b)
data Shader a = Shader [UVar] ExternalDeclaration deriving Int -> Shader a -> String -> String
[Shader a] -> String -> String
Shader a -> String
(Int -> Shader a -> String -> String)
-> (Shader a -> String)
-> ([Shader a] -> String -> String)
-> Show (Shader a)
forall a. Int -> Shader a -> String -> String
forall a. [Shader a] -> String -> String
forall a. Shader a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall a. Int -> Shader a -> String -> String
showsPrec :: Int -> Shader a -> String -> String
$cshow :: forall a. Shader a -> String
show :: Shader a -> String
$cshowList :: forall a. [Shader a] -> String -> String
showList :: [Shader a] -> String -> String
Show
instance ToJSON C.Ty where toJSON :: Ty -> Value
toJSON = Ty -> Value
forall a. Show a => a -> Value
showJSON
showJSON :: Show a => a -> J.Value
showJSON :: forall a. Show a => a -> Value
showJSON = Text -> Value
J.String (Text -> Value) -> (a -> Text) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
prettyJSON :: Pretty a => a -> J.Value
prettyJSON :: forall a. Pretty a => a -> Value
prettyJSON = Text -> Value
J.String (Text -> Value) -> (a -> Text) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Pretty a => a -> String
prettyShow
instance ToJSON TypeSpecifierNonArray where toJSON :: TypeSpecifierNonArray -> Value
toJSON = TypeSpecifierNonArray -> Value
forall a. Pretty a => a -> Value
prettyJSON
instance ToJSON ExternalDeclaration where toJSON :: ExternalDeclaration -> Value
toJSON = ExternalDeclaration -> Value
forall a. Pretty a => a -> Value
prettyJSON
instance ToJSON UVar where
toJSON :: UVar -> Value
toJSON (UVar TypeSpecifierNonArray
ty String
name Widget
widget) =
[Pair] -> Value
object [Key
"type" Key -> TypeSpecifierNonArray -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= TypeSpecifierNonArray
ty, Key
"name" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= String
name, Key
"widget" Key -> Widget -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Widget
widget]
instance ToJSON (Shader a) where
toJSON :: Shader a -> Value
toJSON (Shader [UVar]
vars ExternalDeclaration
def) = [Pair] -> Value
object [Key
"uniforms" Key -> [UVar] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= [UVar]
vars, Key
"definition" Key -> ExternalDeclaration -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= ExternalDeclaration
def]
data Widgets :: * -> * where
UnitW :: Widgets ()
PrimW :: Widget -> Widgets a
PairW :: Widgets a -> Widgets b -> Widgets (a :* b)
deriving instance Show (Widgets a)
unitW :: Widgets ()
unitW :: Widgets ()
unitW = Widgets ()
UnitW
timeW :: Widgets R
timeW :: Widgets R
timeW = Widget -> Widgets R
forall a. Widget -> Widgets a
PrimW Widget
Time
sliderW :: String -> (R,R) -> R -> Widgets R
sliderW :: String -> (R, R) -> R -> Widgets R
sliderW = ((((R, R) -> R -> Widget) -> (R, R) -> R -> Widgets R)
-> (String -> (R, R) -> R -> Widget)
-> String
-> (R, R)
-> R
-> Widgets R
forall a b. (a -> b) -> (String -> a) -> String -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap((((R, R) -> R -> Widget) -> (R, R) -> R -> Widgets R)
-> (String -> (R, R) -> R -> Widget)
-> String
-> (R, R)
-> R
-> Widgets R)
-> ((Widget -> Widgets R)
-> ((R, R) -> R -> Widget) -> (R, R) -> R -> Widgets R)
-> (Widget -> Widgets R)
-> (String -> (R, R) -> R -> Widget)
-> String
-> (R, R)
-> R
-> Widgets R
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((R -> Widget) -> R -> Widgets R)
-> ((R, R) -> R -> Widget) -> (R, R) -> R -> Widgets R
forall a b. (a -> b) -> ((R, R) -> a) -> (R, R) -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap(((R -> Widget) -> R -> Widgets R)
-> ((R, R) -> R -> Widget) -> (R, R) -> R -> Widgets R)
-> ((Widget -> Widgets R) -> (R -> Widget) -> R -> Widgets R)
-> (Widget -> Widgets R)
-> ((R, R) -> R -> Widget)
-> (R, R)
-> R
-> Widgets R
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Widget -> Widgets R) -> (R -> Widget) -> R -> Widgets R
forall a b. (a -> b) -> (R -> a) -> R -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Widget -> Widgets R
forall a. Widget -> Widgets a
PrimW String -> (R, R) -> R -> Widget
Slider
pairW :: Widgets a -> Widgets b -> Widgets (a :* b)
pairW :: forall a b. Widgets a -> Widgets b -> Widgets (a :* b)
pairW = Widgets a -> Widgets b -> Widgets (a :* b)
forall a b. Widgets a -> Widgets b -> Widgets (a :* b)
PairW
flattenWidgets :: Widgets a -> [Widget]
flattenWidgets :: forall a. Widgets a -> [Widget]
flattenWidgets Widgets a
UnitW = []
flattenWidgets (PrimW Widget
wid) = [Widget
wid]
flattenWidgets (PairW Widgets a
a Widgets b
b) = Widgets a -> [Widget]
forall a. Widgets a -> [Widget]
flattenWidgets Widgets a
a [Widget] -> [Widget] -> [Widget]
forall a. [a] -> [a] -> [a]
++ Widgets b -> [Widget]
forall a. Widgets a -> [Widget]
flattenWidgets Widgets b
b