module Shady.Language.GLSL
(
Program(..), Shader(..), Declaration(..), Definition(..)
, VectorT(..), ScalarT(..), Param(..), Id, Bind(..)
, Statement(..), Qualifier(..)
, BindO, (=::), closeB
, (=:)
, glPosition, glFragColor, vTrans, nTrans, mainDef
)
where
import Data.Monoid (Monoid(..))
import Data.Char (toLower)
import Data.VectorSpace (normalized)
import Text.PrettyPrint.Leijen
import Text.PrettyPrint.Leijen.PrettyPrec (showsPretty)
import Text.PrettyPrint.Leijen.DocExpr (expr)
import Control.Compose (result)
import Shady.Language.Operator (Op(Pair,Lit))
import Shady.Language.Exp hiding ((<+>),get)
import Shady.Language.Glom
import Shady.Misc (padTo)
import Shady.Language.Cse (cse)
data Bind = forall a. B (Pat a) (E a)
data Statement
= Assign Bind
| LetS Bind Statement
| SkipS
| ThenS Statement Statement
data Qualifier = Uniform | Attribute | Varying deriving (Show, Eq)
data Declaration = forall a. D [Qualifier] (Pat a)
data Param = forall n a. M (VectorT n a) Id
data Definition = forall n a. F (Maybe (VectorT n a)) Id [Param] Statement
data Shader = Sh [Declaration] [Definition]
data Program = P { pVertex :: Shader, pFragment :: Shader }
instance Monoid Statement where { mempty = SkipS ; mappend = ThenS }
glPosition :: Pat R4
glPosition = pat "gl_Position"
glFragColor :: Pat R4
glFragColor = pat "gl_FragColor"
trans :: IsNat n => String -> VecE n R -> VecE n R
trans vname p = Var (var vname) * p
transNz :: IsNat n => String -> VecE n R -> VecE n R
transNz = (result.result) normalized trans
vTrans :: E R4 -> E R4
vTrans = trans "gl_ModelViewProjectionMatrix"
nTrans :: E R3 -> E R3
nTrans = transNz "gl_NormalMatrix"
mainDef :: Statement -> Definition
mainDef = F Nothing "main" []
infix 0 =:
(=:) :: HasType a => Pat a -> E a -> Statement
p =: e = p <-- cse e
(<--) :: Pat a -> E a -> Statement
p <-- (Lam v b :^ a) = letS v a (p <-- b)
p <-- e = Assign (B p e)
letS :: V a -> E a -> Statement -> Statement
letS v e = LetS (B (BaseG v) e)
instance Pretty Bind where
pretty = prettyB True
prettyB :: Bool -> Bind -> Doc
prettyB withTypes = pret
where
pret :: Bind -> Doc
pret (B UnitG _) = empty
pret (B (p :* q) e) = pret (B p a) <$> pret (B q b)
where (a,b) = unPair' e
pret (B (BaseG (V name ty)) e) =
mbty ty <> text name <+> equals <+> pretty e <> semi
mbty :: Type t -> Doc
mbty ty | withTypes = prettyTy ty <> space
| otherwise = empty
prettyTy :: Type t -> Doc
prettyTy = text . padTo (length "float") . show
unPair' :: (Show a, Show b) => E (a,b) -> (E a, E b)
unPair' (Op (Lit (a,b))) = (Op (Lit a), Op (Lit b))
unPair' (Op Pair :^ a :^ b) = (a,b)
unPair' p = error $ "unPair': " ++ show (expr p)
instance Pretty Statement where
pretty (Assign bind) = prettyB False bind
pretty (LetS bind stat) = pretty bind <$> pretty stat
pretty SkipS = empty
pretty (s `ThenS` t) = pretty s <$> pretty t
instance Pretty Qualifier where pretty = lshowPad qMax
qMax :: Int
qMax = length "attribute"
instance Pretty Declaration where
pretty (D quals patt) = prettyD patt
where
prettyD :: Pat t -> Doc
prettyD UnitG = empty
prettyD (p :* q) = prettyD p <$> prettyD q
prettyD (BaseG (V name ty)) = vcat' quals <+> pretty ty <+> text name <> semi
instance Pretty Param where
pretty (M ty name) = pretty ty <+> pretty name
instance Pretty Definition where
pretty (F mbty name params body) =
maybe (text "void") pretty mbty <+> text name <+>
tupled' params <+> scoped (pretty body)
instance Pretty Shader where
pretty (Sh decls funs) = vcat' decls <$> vcat' funs
instance Pretty Program where
pretty (P v f) = line <> announce "vertex " v <$> announce "fragment" f
where
announce l sh = text (l ++ ": ") <+> align (pretty sh)
data BindO a = BindO (Pat a) (E a)
(=::) :: HasType a => V a -> E a -> BindO a
v =:: e = BindO (BaseG v) e
instance PairF BindO where
BindO p u # BindO q v = BindO (p # q) (u # v)
closeB :: HasType a => BindO a -> Statement
closeB (BindO p e) = p =: e
instance Show Bind where showsPrec = showsPretty
instance Show Statement where showsPrec = showsPretty
instance Show Declaration where showsPrec = showsPretty
instance Show Param where showsPrec = showsPretty
instance Show Definition where showsPrec = showsPretty
instance Show Shader where showsPrec = showsPretty
instance Show Program where showsPrec = showsPretty
lshowPad :: Show a => Int -> a -> Doc
lshowPad n = text . onHead toLower . padTo n . show
vcat', tupled' :: Pretty a => [a] -> Doc
vcat' = vcat . map pretty
tupled' = tupled . map pretty
scoped :: Doc -> Doc
scoped d = braces (nest 4 (line <> d) <> line)
onHead :: (a -> a) -> [a] -> [a]
onHead f (a:as) = f a : as
onHead _ _ = error "onHead: empty list"