{-# LANGUAGE BinaryLiterals        #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
module Language.GLSL.BitCode where

import           Data.Bits                   (shiftL, (.|.))
import qualified Data.Text.Lazy              as LT
import qualified Data.Text.Lazy.IO           as IO
import           Data.Word                   (Word64)
import           Debug.Trace                 (trace)
import           Language.GLSL.AST
import           Language.GLSL.ConstExpr     (ConstExprs)
import qualified Language.GLSL.ConstExpr     as ConstExpr
import           Language.GLSL.Internal.Bits (B (..), expand, flat, zero)
import           Language.GLSL.Parser        (parseShader)
import           Language.GLSL.PrettyPrint


assemble :: BitsStmt -> Word64
assemble :: BitsStmt -> Word64
assemble BitsStmt
bits = String -> Word64 -> Word64
forall a. String -> a -> a
trace (BitsStmt -> String
forall a. Show a => a -> String
show BitsStmt
bits) (Word64 -> Word64) -> Word64 -> Word64
forall a b. (a -> b) -> a -> b
$
  (B -> Word64 -> Word64) -> Word64 -> [B] -> Word64
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(B -> Word64
toInt -> Word64
a) Word64
b -> (Word64
a Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
1) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
b) Word64
0 ([B] -> Word64) -> [B] -> Word64
forall a b. (a -> b) -> a -> b
$ BitsStmt -> [B]
forall a. Bits a => a -> [B]
flat BitsStmt
bits

toInt :: B -> Word64
toInt :: B -> Word64
toInt B
O = Word64
0
toInt B
I = Word64
1

type BitsStmt = ((B,B), (BitsType, B, BitsExpr))
encodeStmt :: Maybe ConstExprs -> Stmt a -> [BitsStmt]
encodeStmt :: Maybe ConstExprs -> Stmt a -> [BitsStmt]
encodeStmt Maybe ConstExprs
ce = \case
  AssignStmt Name
_ Expr
e ->
    [((B, B)
bitsAssignStmt, (((B, B), (B, B))
forall a. Bits a => a
zero, B
forall a. Bits a => a
zero, Maybe ConstExprs -> Expr -> BitsExpr
encodeExpr Maybe ConstExprs
ce Expr
e))]
  DeclStmt LocalDecl
d ->
    [((B, B)
bitsDeclStmt, Maybe ConstExprs -> LocalDecl -> (((B, B), (B, B)), B, BitsExpr)
encodeLocalDecl Maybe ConstExprs
ce LocalDecl
d)]
  EmitStmt Emit
e ->
    [((B, B)
bitsEmitStmt, (B -> BitsExpr -> (((B, B), (B, B)), B, BitsExpr))
-> (B, BitsExpr) -> (((B, B), (B, B)), B, BitsExpr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (((B, B), (B, B))
forall a. Bits a => a
zero,,) ((B, BitsExpr) -> (((B, B), (B, B)), B, BitsExpr))
-> (B, BitsExpr) -> (((B, B), (B, B)), B, BitsExpr)
forall a b. (a -> b) -> a -> b
$ Maybe ConstExprs -> Emit -> (B, BitsExpr)
encodeEmit Maybe ConstExprs
ce Emit
e)]
  IfStmt NameId
_ [StmtAnnot a]
t [StmtAnnot a]
e -> do
    [((B, B)
bitsIfStmt, (((B, B)
bitsThenStmt, (B, B)
forall a. Bits a => a
zero), B
forall a. Bits a => a
zero, BitsExpr
forall a. Bits a => a
zero))]
    [BitsStmt] -> [BitsStmt] -> [BitsStmt]
forall a. [a] -> [a] -> [a]
++ (StmtAnnot a -> [BitsStmt]) -> [StmtAnnot a] -> [BitsStmt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe ConstExprs -> Stmt a -> [BitsStmt]
forall a. Maybe ConstExprs -> Stmt a -> [BitsStmt]
encodeStmt Maybe ConstExprs
ce (Stmt a -> [BitsStmt])
-> (StmtAnnot a -> Stmt a) -> StmtAnnot a -> [BitsStmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StmtAnnot a -> Stmt a
forall a. StmtAnnot a -> Stmt a
unAnnot) [StmtAnnot a]
t
    [BitsStmt] -> [BitsStmt] -> [BitsStmt]
forall a. [a] -> [a] -> [a]
++ [((B, B)
bitsIfStmt, (((B, B)
bitsElseStmt, (B, B)
forall a. Bits a => a
zero), B
forall a. Bits a => a
zero, BitsExpr
forall a. Bits a => a
zero))]
    [BitsStmt] -> [BitsStmt] -> [BitsStmt]
forall a. [a] -> [a] -> [a]
++ (StmtAnnot a -> [BitsStmt]) -> [StmtAnnot a] -> [BitsStmt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe ConstExprs -> Stmt a -> [BitsStmt]
forall a. Maybe ConstExprs -> Stmt a -> [BitsStmt]
encodeStmt Maybe ConstExprs
ce (Stmt a -> [BitsStmt])
-> (StmtAnnot a -> Stmt a) -> StmtAnnot a -> [BitsStmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StmtAnnot a -> Stmt a
forall a. StmtAnnot a -> Stmt a
unAnnot) [StmtAnnot a]
e
    [BitsStmt] -> [BitsStmt] -> [BitsStmt]
forall a. [a] -> [a] -> [a]
++ [((B, B)
bitsIfStmt, (((B, B)
bitsEndifStmt, (B, B)
forall a. Bits a => a
zero), B
forall a. Bits a => a
zero, BitsExpr
forall a. Bits a => a
zero))]
  where
    -- 2 bits encode which statement this is.
    bitsAssignStmt :: (B, B)
bitsAssignStmt     = (B
O,B
O)
    bitsDeclStmt :: (B, B)
bitsDeclStmt       = (B
O,B
I)
    bitsEmitStmt :: (B, B)
bitsEmitStmt       = (B
I,B
O)
    bitsIfStmt :: (B, B)
bitsIfStmt         = (B
I,B
I)

    -- For IfStmt, we need to know when "else" branch starts and when it's over.
    -- We encode that in the next 2 bits for the IfStmt encoding.
    bitsThenStmt :: (B, B)
bitsThenStmt       = (B
O,B
O)
    bitsElseStmt :: (B, B)
bitsElseStmt       = (B
O,B
I)
    bitsEndifStmt :: (B, B)
bitsEndifStmt      = (B
I,B
O)

encodeLocalDecl :: Maybe ConstExprs -> LocalDecl -> (BitsType, B, BitsExpr)
encodeLocalDecl :: Maybe ConstExprs -> LocalDecl -> (((B, B), (B, B)), B, BitsExpr)
encodeLocalDecl Maybe ConstExprs
_ (LDecl Type
ty NameId
_ Maybe Expr
Nothing) =
  -- 1 bit encodes whether the declaration has an initialiser.
  (Type -> ((B, B), (B, B))
encodeType Type
ty, B
O, BitsExpr
forall a. Bits a => a
zero)
encodeLocalDecl Maybe ConstExprs
ce (LDecl Type
ty NameId
_ (Just Expr
e)) =
  (Type -> ((B, B), (B, B))
encodeType Type
ty, B
I, Maybe ConstExprs -> Expr -> BitsExpr
encodeExpr Maybe ConstExprs
ce Expr
e)

-- | 2 bits encode the type, then 2 bits encode the vec/mat size.
type BitsType = ((B,B), (B,B))
encodeType :: Type -> BitsType
encodeType :: Type -> ((B, B), (B, B))
encodeType = \case
  Type
TyBool      -> ((B, B)
bitsTyBool, (B
O,B
O))
  Type
TyFloat     -> ((B, B)
bitsTyFloat, (B
O,B
O))
  TyVec Int
i     -> ((B, B)
bitsTyVec, Int -> Int -> (B, B)
encodeVecSize Int
i Int
i)
  TyMat Int
i Int
j   -> ((B, B)
bitsTyMat, Int -> Int -> (B, B)
encodeVecSize Int
i Int
j)
  Type
TySampler2D -> String -> ((B, B), (B, B))
forall a. HasCallStack => String -> a
error String
"no encoding for local sampler declarations"
  TyStruct{}  -> String -> ((B, B), (B, B))
forall a. HasCallStack => String -> a
error String
"no encoding for local struct declarations"
  where
    -- 2 bits encode the type of a LocalDecl.
    bitsTyBool :: (B, B)
bitsTyBool         = (B
O,B
O)
    bitsTyFloat :: (B, B)
bitsTyFloat        = (B
O,B
I)
    bitsTyVec :: (B, B)
bitsTyVec          = (B
I,B
O)
    bitsTyMat :: (B, B)
bitsTyMat          = (B
I,B
I)

encodeVecSize :: Int -> Int -> (B,B)
encodeVecSize :: Int -> Int -> (B, B)
encodeVecSize Int
i Int
j | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j = String -> (B, B)
forall a. HasCallStack => String -> a
error String
"no encoding for non-square matrices"
encodeVecSize Int
i Int
_ = case Int
i of
  Int
2 -> (B, B)
bitsVecSize2
  Int
3 -> (B, B)
bitsVecSize3
  Int
4 -> (B, B)
bitsVecSize4
  Int
_ -> String -> (B, B)
forall a. HasCallStack => String -> a
error (String -> (B, B)) -> String -> (B, B)
forall a b. (a -> b) -> a -> b
$ String
"no encoding for vec/mat size: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i
  where
    -- 2 bits encode the size of TyVec/TyMat. We only allow square matrices, so
    -- the size of mat2x2 has the same encoding as the size of vec2.
    bitsVecSize2 :: (B, B)
bitsVecSize2       = (B
O,B
O)
    bitsVecSize3 :: (B, B)
bitsVecSize3       = (B
O,B
I)
    bitsVecSize4 :: (B, B)
bitsVecSize4       = (B
I,B
O)

encodeEmit :: Maybe ConstExprs -> Emit -> (B, BitsExpr)
encodeEmit :: Maybe ConstExprs -> Emit -> (B, BitsExpr)
encodeEmit Maybe ConstExprs
_ Emit
EmitFragDepth     = (B
O,BitsExpr
forall a. Bits a => a
zero)
encodeEmit Maybe ConstExprs
ce (EmitPosition Expr
e) = (B
I,Maybe ConstExprs -> Expr -> BitsExpr
encodeExpr Maybe ConstExprs
ce Expr
e)

type BitsExpr = ((B,B), BitsFunName, BitsExprAtom, BitsExprAtom)
encodeExpr :: Maybe ConstExprs -> Expr -> BitsExpr
encodeExpr :: Maybe ConstExprs -> Expr -> BitsExpr
encodeExpr (Just ConstExprs
ce) Expr
e | ConstExprs -> Expr -> Bool
ConstExpr.isConstExpr ConstExprs
ce Expr
e =
  -- Constant expressions are encoded as atom expressions with the "constant
  -- expression" operator 0b11.
  ((B
O,B
O), (B, B) -> BitsFunName
forall a b. Expandable a b => a -> b
expand (B
I,B
I), ((B, B, B), ((B, B), (B, B)))
forall a. Bits a => a
zero, ((B, B, B), ((B, B), (B, B)))
forall a. Bits a => a
zero)
encodeExpr Maybe ConstExprs
_ Expr
expr = case Expr
expr of
  UnaryExpr UnaryOp
o ExprAtom
e -> ((B, B)
bitsUnaryExpr, (B, B) -> BitsFunName
forall a b. Expandable a b => a -> b
expand ((B, B) -> BitsFunName) -> (B, B) -> BitsFunName
forall a b. (a -> b) -> a -> b
$ UnaryOp -> (B, B)
encodeUnaryOp UnaryOp
o, ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
e, ((B, B, B), ((B, B), (B, B)))
forall a. Bits a => a
zero)
  BinaryExpr ExprAtom
l BinaryOp
o ExprAtom
r -> ((B, B)
bitsBinaryExpr, BitsBinaryOp -> BitsFunName
forall a b. Expandable a b => a -> b
expand (BitsBinaryOp -> BitsFunName) -> BitsBinaryOp -> BitsFunName
forall a b. (a -> b) -> a -> b
$ BinaryOp -> BitsBinaryOp
encodeBinaryOp BinaryOp
o, ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
l, ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
r)
  TextureExpr ExprAtom
t ExprAtom
x ExprAtom
y -> ((B, B)
bitsTextureExpr, BitsFunName
forall a. Bits a => a
zero, ((B, B, B), ((B, B), (B, B)))
forall a. Bits a => a
zero, ((B, B, B), ((B, B), (B, B)))
forall a. Bits a => a
zero)
  FunCallExpr FunName
f [ExprAtom]
args -> (((B, B, B), ((B, B), (B, B)))
 -> ((B, B, B), ((B, B), (B, B))) -> BitsExpr)
-> (((B, B, B), ((B, B), (B, B))), ((B, B, B), ((B, B), (B, B))))
-> BitsExpr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((B, B)
bitsFunCallExpr, FunName -> BitsFunName
encodeFunName FunName
f,,) ((((B, B, B), ((B, B), (B, B))), ((B, B, B), ((B, B), (B, B))))
 -> BitsExpr)
-> (((B, B, B), ((B, B), (B, B))), ((B, B, B), ((B, B), (B, B))))
-> BitsExpr
forall a b. (a -> b) -> a -> b
$ FunName
-> [ExprAtom]
-> (((B, B, B), ((B, B), (B, B))), ((B, B, B), ((B, B), (B, B))))
encodeArgs FunName
f [ExprAtom]
args
  AtomExpr ExprAtom
e -> ((B, B)
bitsAtomExpr, (B, B) -> BitsFunName
forall a b. Expandable a b => a -> b
expand (B, B)
bitsUOpIdentity, ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
e, ((B, B, B), ((B, B), (B, B)))
forall a. Bits a => a
zero)
  where
    -- 2 bits encode the expression type.
    bitsUnaryExpr :: (B, B)
bitsUnaryExpr      = (B
O,B
O)
    bitsBinaryExpr :: (B, B)
bitsBinaryExpr     = (B
O,B
I)
    bitsFunCallExpr :: (B, B)
bitsFunCallExpr    = (B
I,B
O)
    bitsTextureExpr :: (B, B)
bitsTextureExpr    = (B
I,B
I)
    -- AtomExpr is a encoded as UnaryExpr with a zero operator.
    bitsAtomExpr :: (B, B)
bitsAtomExpr       = (B, B)
bitsUnaryExpr
    bitsUOpIdentity :: (B, B)
bitsUOpIdentity    = (B
O,B
O)

-- | Implements special encodings for functions with more than 2 args.

-- Because we can't encode all the args individually, we take shortcuts where we
-- know something about how a function tends to be called.
encodeArgs :: FunName -> [ExprAtom] -> (BitsExprAtom, BitsExprAtom)
encodeArgs :: FunName
-> [ExprAtom]
-> (((B, B, B), ((B, B), (B, B))), ((B, B, B), ((B, B), (B, B))))
encodeArgs FunName
PrimSmoothstep [ExprAtom
a,ExprAtom
b,ExprAtom
c] | ExprAtom -> Bool
isLitExpr ExprAtom
a Bool -> Bool -> Bool
&& ExprAtom -> Bool
isLitExpr ExprAtom
b =
  (ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
c, ((B, B, B), ((B, B), (B, B)))
forall a. Bits a => a
zero)
encodeArgs FunName
PrimVec4 args :: [ExprAtom]
args@[ExprAtom
a,ExprAtom
_,ExprAtom
_,ExprAtom
d] | (ExprAtom -> Bool) -> [ExprAtom] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ExprAtom -> Bool
isLitExpr [ExprAtom]
args =
  (ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
a, ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
d)
encodeArgs FunName
PrimVec4 [ExprAtom
a,ExprAtom
b,ExprAtom
c,ExprAtom
d] | (ExprAtom -> Bool) -> [ExprAtom] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ExprAtom -> Bool
isIdentifierExpr [ExprAtom
a,ExprAtom
b,ExprAtom
c] Bool -> Bool -> Bool
&& ExprAtom -> Bool
isLitExpr ExprAtom
d =
  (ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
a, ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
d)
encodeArgs FunName
PrimVec4 args :: [ExprAtom]
args@[ExprAtom
a,ExprAtom
_,ExprAtom
_,ExprAtom
d] | (ExprAtom -> Bool) -> [ExprAtom] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ExprAtom -> Bool
isIdentifierExpr [ExprAtom]
args =
  (ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
a, ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
d)
encodeArgs FunName
PrimMat4x4 args :: [ExprAtom]
args@[ExprAtom
a,ExprAtom
_,ExprAtom
_,ExprAtom
d] | (ExprAtom -> Bool) -> [ExprAtom] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ExprAtom -> Bool
isIdentifierExpr [ExprAtom]
args =
  (ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
a, ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
d)

encodeArgs FunName
_ [] = (((B, B, B), ((B, B), (B, B)))
forall a. Bits a => a
zero, ((B, B, B), ((B, B), (B, B)))
forall a. Bits a => a
zero)
encodeArgs FunName
_ [ExprAtom
a] = (ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
a, ((B, B, B), ((B, B), (B, B)))
forall a. Bits a => a
zero)
encodeArgs FunName
_ [ExprAtom
a,ExprAtom
b] = (ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
a, ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
b)
encodeArgs FunName
f [ExprAtom]
args =
  String
-> (((B, B, B), ((B, B), (B, B))), ((B, B, B), ((B, B), (B, B))))
forall a. HasCallStack => String -> a
error (String
 -> (((B, B, B), ((B, B), (B, B))), ((B, B, B), ((B, B), (B, B)))))
-> String
-> (((B, B, B), ((B, B), (B, B))), ((B, B, B), ((B, B), (B, B))))
forall a b. (a -> b) -> a -> b
$ String
"unsupported argument list for '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (FunName -> Builder) -> FunName -> String
forall a. (a -> Builder) -> a -> String
pp FunName -> Builder
ppFunName FunName
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"': "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Builder -> (ExprAtom -> Builder) -> [ExprAtom] -> String
forall a. Builder -> (a -> Builder) -> [a] -> String
pps Builder
", " ExprAtom -> Builder
ppExprAtom [ExprAtom]
args

encodeUnaryOp :: UnaryOp -> (B,B)
encodeUnaryOp :: UnaryOp -> (B, B)
encodeUnaryOp = \case
  UnaryOp
UOpMinus -> (B, B)
bitsUOpMinus
  UnaryOp
UOpNot   -> (B, B)
bitsUOpNot
  where
    -- 2 bits encode encode the unary operator. 0 is AtomExpr (no operator or
    -- unary "+", i.e. the identity operator).
    bitsUOpMinus :: (B, B)
bitsUOpMinus       = (B
O,B
I)
    bitsUOpNot :: (B, B)
bitsUOpNot         = (B
I,B
O)

-- | 4 bits encode the binary operator.
type BitsBinaryOp = (B,B,B,B)
encodeBinaryOp :: BinaryOp -> BitsBinaryOp
encodeBinaryOp :: BinaryOp -> BitsBinaryOp
encodeBinaryOp = \case
  BinaryOp
BOpPlus  -> BitsBinaryOp
bitsBOpPlus
  BinaryOp
BOpMinus -> BitsBinaryOp
bitsBOpMinus
  BinaryOp
BOpMul   -> BitsBinaryOp
bitsBOpMul
  BinaryOp
BOpDiv   -> BitsBinaryOp
bitsBOpDiv
  BinaryOp
BOpGE    -> BitsBinaryOp
bitsBOpGE
  BinaryOp
BOpGT    -> BitsBinaryOp
bitsBOpGT
  BinaryOp
BOpLE    -> BitsBinaryOp
bitsBOpLE
  BinaryOp
BOpLT    -> BitsBinaryOp
bitsBOpLT
  BinaryOp
BOpAnd   -> BitsBinaryOp
bitsBOpAnd
  BinaryOp
BOpOr    -> BitsBinaryOp
bitsBOpOr
  where
    bitsBOpPlus :: BitsBinaryOp
bitsBOpPlus        = (B
O,B
O,B
O,B
O)
    bitsBOpMinus :: BitsBinaryOp
bitsBOpMinus       = (B
O,B
O,B
O,B
I)
    bitsBOpMul :: BitsBinaryOp
bitsBOpMul         = (B
O,B
O,B
I,B
O)
    bitsBOpDiv :: BitsBinaryOp
bitsBOpDiv         = (B
O,B
O,B
I,B
I)
    bitsBOpGE :: BitsBinaryOp
bitsBOpGE          = (B
O,B
I,B
O,B
O)
    bitsBOpGT :: BitsBinaryOp
bitsBOpGT          = (B
O,B
I,B
O,B
I)
    bitsBOpLE :: BitsBinaryOp
bitsBOpLE          = (B
O,B
I,B
I,B
O)
    bitsBOpLT :: BitsBinaryOp
bitsBOpLT          = (B
O,B
I,B
I,B
I)
    bitsBOpAnd :: BitsBinaryOp
bitsBOpAnd         = (B
I,B
O,B
O,B
O)
    bitsBOpOr :: BitsBinaryOp
bitsBOpOr          = (B
I,B
O,B
O,B
I)

-- | 5 bits encode the function name for FunCallExpr.
type BitsFunName = (B,B,B,B,B)
encodeFunName :: FunName -> BitsFunName
encodeFunName :: FunName -> BitsFunName
encodeFunName = \case
  FunName
PrimAbs        -> BitsFunName
bitsPrimAbs
  FunName
PrimAsin       -> BitsFunName
bitsPrimAsin
  FunName
PrimAtan       -> BitsFunName
bitsPrimAtan
  FunName
PrimCos        -> BitsFunName
bitsPrimCos
  FunName
PrimCross      -> BitsFunName
bitsPrimCross
  FunName
PrimDot        -> BitsFunName
bitsPrimDot
  FunName
PrimFloor      -> BitsFunName
bitsPrimFloor
  FunName
PrimFract      -> BitsFunName
bitsPrimFract
  FunName
PrimLength     -> BitsFunName
bitsPrimLength
  FunName
PrimMat3x3     -> BitsFunName
bitsPrimMat3x3
  FunName
PrimMat4x4     -> BitsFunName
bitsPrimMat4x4
  FunName
PrimMod        -> BitsFunName
bitsPrimMod
  FunName
PrimNormalize  -> BitsFunName
bitsPrimNormalize
  FunName
PrimPow        -> BitsFunName
bitsPrimPow
  FunName
PrimSin        -> BitsFunName
bitsPrimSin
  FunName
PrimSmoothstep -> BitsFunName
bitsPrimSmoothstep
  FunName
PrimSqrt       -> BitsFunName
bitsPrimSqrt
  FunName
PrimStep       -> BitsFunName
bitsPrimStep
  FunName
PrimTan        -> BitsFunName
bitsPrimTan
  FunName
PrimVec2       -> BitsFunName
bitsPrimVec2
  FunName
PrimVec3       -> BitsFunName
bitsPrimVec3
  FunName
PrimVec4       -> BitsFunName
bitsPrimVec4
  where
    bitsPrimAbs :: BitsFunName
bitsPrimAbs        = (B
O,B
O,B
O,B
O,B
O)
    bitsPrimAsin :: BitsFunName
bitsPrimAsin       = (B
O,B
O,B
O,B
O,B
I)
    bitsPrimAtan :: BitsFunName
bitsPrimAtan       = (B
O,B
O,B
O,B
I,B
O)
    bitsPrimCos :: BitsFunName
bitsPrimCos        = (B
O,B
O,B
O,B
I,B
I)
    bitsPrimCross :: BitsFunName
bitsPrimCross      = (B
O,B
O,B
I,B
O,B
O)
    bitsPrimDot :: BitsFunName
bitsPrimDot        = (B
O,B
O,B
I,B
O,B
I)
    bitsPrimFloor :: BitsFunName
bitsPrimFloor      = (B
O,B
O,B
I,B
I,B
O)
    bitsPrimFract :: BitsFunName
bitsPrimFract      = (B
O,B
O,B
I,B
I,B
I)
    bitsPrimLength :: BitsFunName
bitsPrimLength     = (B
O,B
I,B
O,B
O,B
O)
    bitsPrimMat3x3 :: BitsFunName
bitsPrimMat3x3     = (B
O,B
I,B
O,B
O,B
I)
    bitsPrimMat4x4 :: BitsFunName
bitsPrimMat4x4     = (B
O,B
I,B
O,B
I,B
O)
    bitsPrimMod :: BitsFunName
bitsPrimMod        = (B
O,B
I,B
O,B
I,B
I)
    bitsPrimNormalize :: BitsFunName
bitsPrimNormalize  = (B
O,B
I,B
I,B
O,B
O)
    bitsPrimPow :: BitsFunName
bitsPrimPow        = (B
O,B
I,B
I,B
O,B
I)
    bitsPrimSin :: BitsFunName
bitsPrimSin        = (B
O,B
I,B
I,B
I,B
O)
    bitsPrimSmoothstep :: BitsFunName
bitsPrimSmoothstep = (B
O,B
I,B
I,B
I,B
I)
    bitsPrimSqrt :: BitsFunName
bitsPrimSqrt       = (B
I,B
O,B
O,B
O,B
O)
    bitsPrimStep :: BitsFunName
bitsPrimStep       = (B
I,B
O,B
O,B
O,B
I)
    bitsPrimTan :: BitsFunName
bitsPrimTan        = (B
I,B
O,B
O,B
I,B
O)
    bitsPrimVec2 :: BitsFunName
bitsPrimVec2       = (B
I,B
O,B
O,B
I,B
I)
    bitsPrimVec3 :: BitsFunName
bitsPrimVec3       = (B
I,B
O,B
I,B
O,B
O)
    bitsPrimVec4 :: BitsFunName
bitsPrimVec4       = (B
I,B
O,B
I,B
O,B
I)

-- | ExprAtom type is encoded in 3 bits.
encodeExprAtomType :: ExprAtom -> (B,B,B)
encodeExprAtomType :: ExprAtom -> (B, B, B)
encodeExprAtomType = \case
  LitIntExpr{}     -> (B, B, B)
bitsLitExpr
  LitFloatExpr{}   -> (B, B, B)
bitsLitExpr
  IdentifierExpr{} -> (B, B, B)
bitsIdentifierExpr
  SwizzleExpr{}    -> (B, B, B)
bitsSwizzleExpr
  VecIndexExpr{}   -> (B, B, B)
bitsVecIndexExpr
  MatIndexExpr{}   -> (B, B, B)
bitsMatIndexExpr
  where
    -- Literals are encoded the same.
    bitsLitExpr :: (B, B, B)
bitsLitExpr        = (B
O,B
O,B
O)
    bitsIdentifierExpr :: (B, B, B)
bitsIdentifierExpr = (B
O,B
O,B
I)
    bitsSwizzleExpr :: (B, B, B)
bitsSwizzleExpr    = (B
O,B
I,B
O)
    bitsVecIndexExpr :: (B, B, B)
bitsVecIndexExpr   = (B
O,B
I,B
I)
    bitsMatIndexExpr :: (B, B, B)
bitsMatIndexExpr   = (B
I,B
O,B
O)

-- ExprAtom is encoded in 7 bits: 3 bits for type and 4 bits for arguments.
--
-- We only need the full 4 bits for MatIndexExpr arguments which can be any of
-- the 16 positions in the matrix indexing operation.
type BitsExprAtom = ((B,B,B), ((B,B), (B,B)))
encodeExprAtom :: ExprAtom -> BitsExprAtom
encodeExprAtom :: ExprAtom -> ((B, B, B), ((B, B), (B, B)))
encodeExprAtom ExprAtom
e = (ExprAtom -> (B, B, B)
encodeExprAtomType ExprAtom
e, ExprAtom -> ((B, B), (B, B))
encodeOperand ExprAtom
e)
  where
    encodeOperand :: ExprAtom -> ((B, B), (B, B))
encodeOperand (SwizzleExpr NameId
_ Swizzle
i)    = (Swizzle -> (B, B)
encodeSwizzle Swizzle
i, (B
O,B
O))
    encodeOperand (VecIndexExpr NameExpr
_ Swizzle
i)   = (Swizzle -> (B, B)
encodeSwizzle Swizzle
i, (B
O,B
O))
    encodeOperand (MatIndexExpr NameExpr
_ Swizzle
i Swizzle
j) = (Swizzle -> (B, B)
encodeSwizzle Swizzle
i, Swizzle -> (B, B)
encodeSwizzle Swizzle
j)
    encodeOperand ExprAtom
_                    = ((B
O,B
O),(B
O,B
O))

-- Swizzle/VecIndex is encoded in 2 bits.
encodeSwizzle :: Swizzle -> (B,B)
encodeSwizzle :: Swizzle -> (B, B)
encodeSwizzle = \case
  Swizzle
X -> (B, B)
bitsSwizzleX
  Swizzle
Y -> (B, B)
bitsSwizzleY
  Swizzle
Z -> (B, B)
bitsSwizzleZ
  Swizzle
W -> (B, B)
bitsSwizzleW
  where
    bitsSwizzleX :: (B, B)
bitsSwizzleX       = (B
O,B
O)
    bitsSwizzleY :: (B, B)
bitsSwizzleY       = (B
O,B
I)
    bitsSwizzleZ :: (B, B)
bitsSwizzleZ       = (B
I,B
O)
    bitsSwizzleW :: (B, B)
bitsSwizzleW       = (B
I,B
I)


parse :: LT.Text -> Either String (GLSL ())
parse :: Text -> Either String (GLSL ())
parse = Text -> Either String (GLSL ())
forall a. Annot a => Text -> Either String (GLSL a)
parseShader

main :: IO ()
main :: IO ()
main = do
  String -> IO ()
putStrLn String
"Loading shader source..."
  -- inText <- IO.readFile "../large-shaders/lambdacnc.frag"
  -- inText <- IO.readFile "../large-shaders/lambdacnc.vert"
  -- inText <- IO.readFile "../large-shaders/lambdaray.frag"
  -- inText <- IO.readFile "../large-shaders/xax.frag"
  -- inText <- IO.readFile "../large-shaders/xax.vert"
  Text
inText <- String -> IO Text
IO.readFile String
"../large-shaders/small.vert"
  String -> IO ()
putStrLn String
"Parsing shader source..."
  case Text -> Either String (GLSL ())
parse Text
inText of
    Left String
err -> String -> String -> IO ()
writeFile String
"../opt.glsl" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"// Error\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
    Right (GLSL Version
_ ([TopDecl ()] -> [TopDecl ()]
forall a. [a] -> [a]
reverse -> (ProcDecl ProcName
_ [ParamDecl]
_ [StmtAnnot ()]
ss):[TopDecl ()]
_)) ->
      (StmtAnnot () -> IO ()) -> [StmtAnnot ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([BitsStmt] -> IO ()
forall a. Show a => a -> IO ()
print ([BitsStmt] -> IO ())
-> (StmtAnnot () -> [BitsStmt]) -> StmtAnnot () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ConstExprs -> Stmt () -> [BitsStmt]
forall a. Maybe ConstExprs -> Stmt a -> [BitsStmt]
encodeStmt Maybe ConstExprs
forall a. Maybe a
Nothing (Stmt () -> [BitsStmt])
-> (StmtAnnot () -> Stmt ()) -> StmtAnnot () -> [BitsStmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StmtAnnot () -> Stmt ()
forall a. StmtAnnot a -> Stmt a
unAnnot) [StmtAnnot ()]
ss
    Right GLSL ()
_ ->
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()