Text.hs

module DirectX9.D3D.Shader.Text
where
import DirectX9.D3D.Shader.Assembly

showRegister :: Bool -> Register -> ShowS
showRegister isps (Register rt n) = case rt of
    Input       -> showChar 'v' . shows n
    Temp        -> showChar 'r' . shows n
    Const       -> showChar 'c' . shows n
    ConstInt    -> showChar 'i' . shows n
    ConstBool   -> showChar 'b' . shows n
    Predicate   -> showChar 'p' . shows n
    Sampler     -> showChar 's' . shows n
    Misc
        | n==0  -> showString "vPos"
        | n==1  -> showString "vFace"
        | otherwise -> showString "misc" . shows n
    LoopReg     -> showString "aL"
    Output | not isps -> showString "o" . shows n
    Color | isps    -> showString "oC" . shows n
    Depth           -> showString "ODepth"
    Address
        | isps      -> showChar 't' . shows n
        | not isps  -> showChar 'a' . shows n
    Rasteriser      -> showString "oPos"
    Attribute       -> showString "oD" . shows n
    -- syntax for these is not known
    {- Rasteriser  -> showString "rasteriser" . shows n
    Attribute   -> showString "attribute" . shows n
    TempFloat16 -> showString "tempfloat16_" . shows n
    LabelReg    -> showString "label" . shows n -}
    
    _           -> shows rt . shows n

showSwizzle :: (SwizzleSource -> ShowS) -> Swizzle -> ShowS
showSwizzle ss swi = case swi of
    (Swizzle ComponentX ComponentY ComponentZ ComponentW) -> id
    (Swizzle x y z w)   -> showChar '.' . ss x . ss y . ss z . ss w

s_xyzw :: SwizzleSource -> ShowS
s_xyzw s = showChar $ case s of
    ComponentX -> 'x'; ComponentY -> 'y'; ComponentZ -> 'z'; ComponentW -> 'w'

s_rgba::SwizzleSource -> ShowS
s_rgba s = showChar $ case s of
    ComponentX -> 'r'; ComponentY -> 'g'; ComponentZ -> 'b'; ComponentW -> 'a'


showSourceMod :: ShowS -> SourceModifier -> ShowS
showSourceMod reg mod = case mod of
    ModNone n   -> neg n . reg
    ModBias n   -> neg n . reg . showString "_bias"
    ModSign n   -> neg n . reg . showString "_bx2"
    ModComplement -> showString "1-".reg
    ModX2 n     -> neg n . reg . showString "_x2"
    where
        neg True = showChar '-'
        neg False = id
    {-
    | ModDz
    | ModDw
    | ModAbs    Bool
    | ModNot -}


showSourceReg :: Bool -> SourceReg -> ShowS
showSourceReg isps (SourceReg reg mod swi) =
    showSourceMod (showRegister isps reg) mod . showSwizzle s_xyzw swi


showSource :: Bool -> Source -> ShowS
showSource isps (Source reg ra) = showSourceReg isps reg . case ra of
    Nothing -> id
    Just ra -> showChar '[' . showSourceReg isps ra . showChar ']'

showWriteMask :: WriteMask -> ShowS
showWriteMask (WriteMask x y z w)
    | x && y && z && w  = id
    | otherwise         = showChar '.' . m x 'x' . m y 'y' . m z 'z' . m w 'w'
    where
        m cond c
            | cond      = showChar c
            | otherwise = id

-- dunno syntax
--showDestMod :: DestinationModifiers -> ShowS

showDestinationReg :: Bool -> DestinationReg -> ShowS
showDestinationReg isps (DestinationReg reg wm _) =
    showRegister isps reg . showWriteMask wm

showDestination :: Bool -> Destination -> ShowS
showDestination isps (Destination reg ra) = showDestinationReg isps reg . case ra of
    Nothing -> id
    Just ra -> showChar '[' . showDestinationReg isps ra . showChar ']'


showInstruction :: Bool -> Instruction -> ShowS
showInstruction isps (Instruction op _ _ _ d ss) =
    shows op . dest . sources
    where
        dest = case d of
            Nothing -> id
            Just x  -> showChar ' ' . showDestination isps x
        sources = foldl (\x y -> x.showString ", ".showSource isps y) id ss


showDeclUsageTypeDcl :: DeclUsageType -> ShowS
showDeclUsageTypeDcl t = showString $ case t of
    DuPosition      -> "dcl_position"
    DuBlendWeight   -> "dcl_blendweight"
    DuBlenIndices   -> "dcl_blendindices"
    DuNormal        -> "dcl_normal"
    DuPSize         -> "dcl_psize"
    DuTexCoord      -> "dcl_texcoord"
    DuTangent       -> "dcl_tangent"
    DuBiNormal      -> "dcl_binormal"
    DuTessFactor    -> "dcl_tessfactor"
    DuPositionT     -> "dcl_positiont"
    DuColor         -> "dcl_color"
    DuFog           -> "dcl_fog"
    DuDepth         -> "dcl_depth"
    DuSample        -> "dcl_sample"

showDeclUsageDcl :: DeclUsage -> ShowS
showDeclUsageDcl (DeclUsage t n) = showDeclUsageTypeDcl t . shows n

showSamplerTypeDcl :: SamplerType -> ShowS
showSamplerTypeDcl t = showString $ case t of
    St2D    -> "dcl_2d"
    StCube  -> "dcl_cube"
    StVolume -> "dcl_volume"

showDeclarePs :: DeclarePs -> ShowS
showDeclarePs (DeclarePs t d) =
    (.showChar ' ' . showDestinationReg True d) $ case t of
    PsSampler t' -> showSamplerTypeDcl t'
    _            -> showString "dcl"


showDeclareVs :: DeclareVs -> ShowS
showDeclareVs (DeclareVs u d) =
    showDeclUsageDcl u . showChar ' ' . showDestinationReg False d


showVersion :: Version -> ShowS
showVersion v = case v of
    PsVersion major minor   -> showString "ps_" . shows major . showChar '_' . shows minor
    VsVersion major minor   -> showString "vs_" . shows major . showChar '_' . shows minor

showShaderAssembly :: ShaderAssembly -> ShowS
showShaderAssembly a = case a of
    PixelShader v d i   -> outs True (ins1 (showVersion v) d) i
    VertexShader v d i  -> outs False (ins2 (showVersion v) d) i
    where
        outs isps = foldl (\x y -> x.showChar '\n'.showInstruction isps y)
        ins1 = foldl (\x y -> x.showChar '\n'.showDeclarePs y)
        ins2 = foldl (\x y -> x.showChar '\n'.showDeclareVs y)