module Csound.Typed.Gui.Pretty (
  ppProc, ppMoOpc, ppVar, varPrefix, ppVarType, ppRate,

  intProp, getScale, getLabelType, getDefOrient, getOrient, getKnobType,
  getKnobCursorSize, getRollerType, getSliderType, getTextType, getBoxType,
  getFontSize, getIntFontSize, getFontType, getButtonType, getButtonBankType,
  getToggleType, appMaterial, getColor1, getColor2, getTextColor, genGetColor
) where

import Data.Char
import Data.Default
import Data.Colour.Names(white, gray, black)
import Data.Colour.SRGB

import Text.PrettyPrint.Leijen(Doc, int, hcat, hsep, punctuate, comma, text, char)
import qualified Text.PrettyPrint.Leijen as P((<+>), empty)

import Csound.Dynamic(Var(..), VarType(..), Rate(..))

import Csound.Typed.Gui.Types

-------------------------------------------------------------
-- pretty printers

ppProc :: String -> [Doc] -> Doc
ppProc :: String -> [Doc] -> Doc
ppProc String
name [Doc]
xs = String -> Doc
text String
name Doc -> Doc -> Doc
P.<+> ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma [Doc]
xs)

ppMoOpc :: [Doc] -> String -> [Doc] -> Doc
ppMoOpc :: [Doc] -> String -> [Doc] -> Doc
ppMoOpc [Doc]
outs String
name [Doc]
ins = [Doc] -> Doc
f [Doc]
outs Doc -> Doc -> Doc
P.<+> String -> Doc
text String
name Doc -> Doc -> Doc
P.<+> [Doc] -> Doc
f [Doc]
ins
    where f :: [Doc] -> Doc
f = [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma

ppVar :: Var -> Doc
ppVar :: Var -> Doc
ppVar Var
v = case Var
v of
    Var VarType
ty Rate
rate String
name   -> [Doc] -> Doc
hcat [VarType -> Doc
ppVarType VarType
ty, Rate -> Doc
ppRate Rate
rate, String -> Doc
text (VarType -> Char
varPrefix VarType
ty Char -> String -> String
forall a. a -> [a] -> [a]
: String
name)]
    VarVerbatim Rate
_ String
name -> String -> Doc
text String
name

varPrefix :: VarType -> Char
varPrefix :: VarType -> Char
varPrefix VarType
x = case VarType
x of
    VarType
LocalVar  -> Char
'l'
    VarType
GlobalVar -> Char
'g'

ppVarType :: VarType -> Doc
ppVarType :: VarType -> Doc
ppVarType VarType
x = case VarType
x of
    VarType
LocalVar  -> Doc
P.empty
    VarType
GlobalVar -> Char -> Doc
char Char
'g'

ppRate :: Rate -> Doc
ppRate :: Rate -> Doc
ppRate Rate
x = case Rate
x of
    Rate
Sr -> Char -> Doc
char Char
'S'
    Rate
_  -> Rate -> Doc
phi Rate
x
    where phi :: Rate -> Doc
phi = String -> Doc
text (String -> Doc) -> (Rate -> String) -> Rate -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (Rate -> String) -> Rate -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rate -> String
forall a. Show a => a -> String
show

------------------------------------------------------------------
-- Converting readable properties to integer codes

maybeDef :: Default a => Maybe a -> a
maybeDef :: Maybe a -> a
maybeDef = a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
forall a. Default a => a
def a -> a
forall a. a -> a
id

intProp :: Default a => (PropCtx -> Maybe a) -> (a -> Int) -> (PropCtx -> Doc)
intProp :: (PropCtx -> Maybe a) -> (a -> Int) -> PropCtx -> Doc
intProp PropCtx -> Maybe a
select a -> Int
convert = Int -> Doc
int (Int -> Doc) -> (PropCtx -> Int) -> PropCtx -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
convert (a -> Int) -> (PropCtx -> a) -> PropCtx -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> a
forall a. Default a => Maybe a -> a
maybeDef (Maybe a -> a) -> (PropCtx -> Maybe a) -> PropCtx -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropCtx -> Maybe a
select

getScale :: ValScaleType -> Doc
getScale :: ValScaleType -> Doc
getScale ValScaleType
x = Int -> Doc
int (Int -> Doc) -> Int -> Doc
forall a b. (a -> b) -> a -> b
$ case ValScaleType
x of
    ValScaleType
Linear      -> Int
0
    ValScaleType
Exponential -> -Int
1

getLabelType :: PropCtx -> Doc
getLabelType :: PropCtx -> Doc
getLabelType = (PropCtx -> Maybe LabelType)
-> (LabelType -> Int) -> PropCtx -> Doc
forall a.
Default a =>
(PropCtx -> Maybe a) -> (a -> Int) -> PropCtx -> Doc
intProp PropCtx -> Maybe LabelType
ctxLabelType ((LabelType -> Int) -> PropCtx -> Doc)
-> (LabelType -> Int) -> PropCtx -> Doc
forall a b. (a -> b) -> a -> b
$ \LabelType
x -> case LabelType
x of
    LabelType
NormalLabel     -> Int
0
    LabelType
NoLabel         -> Int
1
    LabelType
SymbolLabel     -> Int
2
    LabelType
ShadowLabel     -> Int
3
    LabelType
EngravedLabel   -> Int
4
    LabelType
EmbossedLabel   -> Int
5

getDefOrient :: Rect -> Orient
getDefOrient :: Rect -> Orient
getDefOrient Rect
r
    | Rect -> Int
height Rect
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Rect -> Int
width Rect
r    = Orient
Hor
    | Bool
otherwise             = Orient
Ver

getOrient :: Orient -> PropCtx -> Orient
getOrient :: Orient -> PropCtx -> Orient
getOrient Orient
defOrient = Orient -> (Orient -> Orient) -> Maybe Orient -> Orient
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Orient
defOrient Orient -> Orient
forall a. a -> a
id (Maybe Orient -> Orient)
-> (PropCtx -> Maybe Orient) -> PropCtx -> Orient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropCtx -> Maybe Orient
ctxOrient

getKnobType :: PropCtx -> Doc
getKnobType :: PropCtx -> Doc
getKnobType = (PropCtx -> Maybe KnobType) -> (KnobType -> Int) -> PropCtx -> Doc
forall a.
Default a =>
(PropCtx -> Maybe a) -> (a -> Int) -> PropCtx -> Doc
intProp PropCtx -> Maybe KnobType
ctxKnobType ((KnobType -> Int) -> PropCtx -> Doc)
-> (KnobType -> Int) -> PropCtx -> Doc
forall a b. (a -> b) -> a -> b
$ \KnobType
x -> case KnobType
x of
    KnobType
Flat        -> Int
4
    KnobType
Pie         -> Int
2
    KnobType
Clock       -> Int
3
    ThreeD Maybe Int
_    -> Int
1

getKnobCursorSize :: PropCtx -> [Doc]
getKnobCursorSize :: PropCtx -> [Doc]
getKnobCursorSize PropCtx
ctx = case Maybe KnobType -> KnobType
forall a. Default a => Maybe a -> a
maybeDef (Maybe KnobType -> KnobType) -> Maybe KnobType -> KnobType
forall a b. (a -> b) -> a -> b
$ PropCtx -> Maybe KnobType
ctxKnobType PropCtx
ctx of
    ThreeD (Just Int
n) -> [Int -> Doc
int Int
n]
    KnobType
_               -> []

getRollerType :: Orient -> PropCtx -> Doc
getRollerType :: Orient -> PropCtx -> Doc
getRollerType Orient
defOrient PropCtx
ctx = Int -> Doc
int (Int -> Doc) -> Int -> Doc
forall a b. (a -> b) -> a -> b
$ case Orient -> PropCtx -> Orient
getOrient Orient
defOrient PropCtx
ctx of
    Orient
Hor -> Int
1
    Orient
Ver -> Int
2

getSliderType :: Orient -> PropCtx -> Doc
getSliderType :: Orient -> PropCtx -> Doc
getSliderType Orient
defOrient PropCtx
ctx = Int -> Doc
int (Int -> Doc) -> Int -> Doc
forall a b. (a -> b) -> a -> b
$ PropCtx -> Int -> Int
appMaterial PropCtx
ctx (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$
    case (Orient -> PropCtx -> Orient
getOrient Orient
defOrient PropCtx
ctx, Maybe SliderType -> SliderType
forall a. Default a => Maybe a -> a
maybeDef (Maybe SliderType -> SliderType) -> Maybe SliderType -> SliderType
forall a b. (a -> b) -> a -> b
$ PropCtx -> Maybe SliderType
ctxSliderType PropCtx
ctx) of
        (Orient
Hor, SliderType
Fill)         -> Int
1
        (Orient
Ver, SliderType
Fill)         -> Int
2
        (Orient
Hor, SliderType
Engraved)     -> Int
3
        (Orient
Ver, SliderType
Engraved)     -> Int
4
        (Orient
Hor, SliderType
Nice)         -> Int
5
        (Orient
Ver, SliderType
Nice)         -> Int
6

getTextType :: PropCtx -> Doc
getTextType :: PropCtx -> Doc
getTextType = (PropCtx -> Maybe TextType) -> (TextType -> Int) -> PropCtx -> Doc
forall a.
Default a =>
(PropCtx -> Maybe a) -> (a -> Int) -> PropCtx -> Doc
intProp PropCtx -> Maybe TextType
ctxTextType ((TextType -> Int) -> PropCtx -> Doc)
-> (TextType -> Int) -> PropCtx -> Doc
forall a b. (a -> b) -> a -> b
$ \TextType
x -> case TextType
x of
    TextType
NormalText  -> Int
1
    TextType
NoDrag      -> Int
2
    TextType
NoEdit      -> Int
3

getBoxType :: PropCtx -> Doc
getBoxType :: PropCtx -> Doc
getBoxType = (PropCtx -> Maybe BoxType) -> (BoxType -> Int) -> PropCtx -> Doc
forall a.
Default a =>
(PropCtx -> Maybe a) -> (a -> Int) -> PropCtx -> Doc
intProp PropCtx -> Maybe BoxType
ctxBoxType ((BoxType -> Int) -> PropCtx -> Doc)
-> (BoxType -> Int) -> PropCtx -> Doc
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> (BoxType -> Int) -> BoxType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoxType -> Int
forall a. Enum a => a -> Int
fromEnum

getFontSize :: PropCtx -> Doc
getFontSize :: PropCtx -> Doc
getFontSize  = Int -> Doc
int (Int -> Doc) -> (PropCtx -> Int) -> PropCtx -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropCtx -> Int
getIntFontSize

getIntFontSize :: PropCtx -> Int
getIntFontSize :: PropCtx -> Int
getIntFontSize PropCtx
ctx = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
defFontSize Int -> Int
forall a. a -> a
id (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ PropCtx -> Maybe Int
ctxFontSize PropCtx
ctx

getFontType :: PropCtx -> Doc
getFontType :: PropCtx -> Doc
getFontType PropCtx
ctx = Int -> Doc
int (Int -> Doc) -> Int -> Doc
forall a b. (a -> b) -> a -> b
$
    case (Maybe FontType -> FontType
forall a. Default a => Maybe a -> a
maybeDef (Maybe FontType -> FontType) -> Maybe FontType -> FontType
forall a b. (a -> b) -> a -> b
$ PropCtx -> Maybe FontType
ctxFontType PropCtx
ctx, Maybe Emphasis -> Emphasis
forall a. Default a => Maybe a -> a
maybeDef (Maybe Emphasis -> Emphasis) -> Maybe Emphasis -> Emphasis
forall a b. (a -> b) -> a -> b
$ PropCtx -> Maybe Emphasis
ctxEmphasis PropCtx
ctx) of
        (FontType
Helvetica, Emphasis
NoEmphasis)         -> Int
1
        (FontType
Helvetica, Emphasis
Bold)               -> Int
2
        (FontType
Helvetica, Emphasis
Italic)             -> Int
3
        (FontType
Helvetica, Emphasis
BoldItalic)         -> Int
4
        (FontType
Courier, Emphasis
NoEmphasis)           -> Int
5
        (FontType
Courier, Emphasis
Bold)                 -> Int
6
        (FontType
Courier, Emphasis
Italic)               -> Int
7
        (FontType
Courier, Emphasis
BoldItalic)           -> Int
8
        (FontType
Times, Emphasis
NoEmphasis)             -> Int
9
        (FontType
Times, Emphasis
Bold)                   -> Int
10
        (FontType
Times, Emphasis
Italic)                 -> Int
11
        (FontType
Times, Emphasis
BoldItalic)             -> Int
12
        (FontType
Symbol, Emphasis
_)                     -> Int
13
        (FontType
Screen, Emphasis
Bold)                  -> Int
15
        (FontType
Screen, Emphasis
_)                     -> Int
14
        (FontType
Dingbats, Emphasis
_)                   -> Int
16



getButtonType :: PropCtx -> Doc
getButtonType :: PropCtx -> Doc
getButtonType PropCtx
ctx = Int -> Doc
int (Int -> Doc) -> Int -> Doc
forall a b. (a -> b) -> a -> b
$ PropCtx -> Int -> Int
appMaterial PropCtx
ctx Int
1

getButtonBankType :: PropCtx -> Doc
getButtonBankType :: PropCtx -> Doc
getButtonBankType PropCtx
ctx = ((PropCtx -> Doc) -> PropCtx -> Doc
forall a b. (a -> b) -> a -> b
$ PropCtx
ctx) ((PropCtx -> Doc) -> Doc) -> (PropCtx -> Doc) -> Doc
forall a b. (a -> b) -> a -> b
$ (PropCtx -> Maybe ButtonType)
-> (ButtonType -> Int) -> PropCtx -> Doc
forall a.
Default a =>
(PropCtx -> Maybe a) -> (a -> Int) -> PropCtx -> Doc
intProp PropCtx -> Maybe ButtonType
ctxButtonType ((ButtonType -> Int) -> PropCtx -> Doc)
-> (ButtonType -> Int) -> PropCtx -> Doc
forall a b. (a -> b) -> a -> b
$ \ButtonType
x ->
    Int -> Int
reactOnNoPlasticForRoundBug (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PropCtx -> Int -> Int
appMaterial PropCtx
ctx (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ case ButtonType
x of
        ButtonType
NormalButton    -> Int
1
        ButtonType
LightButton     -> Int
2
        ButtonType
CheckButton     -> Int
3
        ButtonType
RoundButton     -> Int
4

getToggleType :: PropCtx -> Doc
getToggleType :: PropCtx -> Doc
getToggleType PropCtx
ctx = ((PropCtx -> Doc) -> PropCtx -> Doc
forall a b. (a -> b) -> a -> b
$ PropCtx
ctx) ((PropCtx -> Doc) -> Doc) -> (PropCtx -> Doc) -> Doc
forall a b. (a -> b) -> a -> b
$ (PropCtx -> Maybe ButtonType)
-> (ButtonType -> Int) -> PropCtx -> Doc
forall a.
Default a =>
(PropCtx -> Maybe a) -> (a -> Int) -> PropCtx -> Doc
intProp PropCtx -> Maybe ButtonType
ctxButtonType ((ButtonType -> Int) -> PropCtx -> Doc)
-> (ButtonType -> Int) -> PropCtx -> Doc
forall a b. (a -> b) -> a -> b
$ \ButtonType
x ->
    Int -> Int
reactOnNoPlasticForRoundBug (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ PropCtx -> Int -> Int
appMaterial PropCtx
ctx (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ case ButtonType
x of
        ButtonType
NormalButton    -> Int
2
        ButtonType
LightButton     -> Int
2
        ButtonType
CheckButton     -> Int
3
        ButtonType
RoundButton     -> Int
4

reactOnNoPlasticForRoundBug :: Int -> Int
reactOnNoPlasticForRoundBug :: Int -> Int
reactOnNoPlasticForRoundBug Int
x
  | Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
24 = Int
4
  | Bool
otherwise = Int
x

appMaterial :: PropCtx -> Int -> Int
appMaterial :: PropCtx -> Int -> Int
appMaterial PropCtx
ctx = case Maybe Material -> Material
forall a. Default a => Maybe a -> a
maybeDef (Maybe Material -> Material) -> Maybe Material -> Material
forall a b. (a -> b) -> a -> b
$ PropCtx -> Maybe Material
ctxMaterial PropCtx
ctx of
    Material
Plastic   -> (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
20)
    Material
NoPlastic -> Int -> Int
forall a. a -> a
id

getColor1 :: PropCtx -> Doc
getColor1 :: PropCtx -> Doc
getColor1       = Color -> (PropCtx -> Maybe Color) -> PropCtx -> Doc
genGetColor Color
forall a. (Ord a, Floating a) => Colour a
gray  PropCtx -> Maybe Color
ctxColor1

getColor2 :: PropCtx -> Doc
getColor2 :: PropCtx -> Doc
getColor2       = Color -> (PropCtx -> Maybe Color) -> PropCtx -> Doc
genGetColor Color
forall a. (Ord a, Floating a) => Colour a
white PropCtx -> Maybe Color
ctxColor2

getTextColor :: PropCtx -> Doc
getTextColor :: PropCtx -> Doc
getTextColor    = Color -> (PropCtx -> Maybe Color) -> PropCtx -> Doc
genGetColor Color
forall a. Num a => Colour a
black PropCtx -> Maybe Color
ctxTextColor

genGetColor :: Color -> (PropCtx -> Maybe Color) -> PropCtx -> Doc
genGetColor :: Color -> (PropCtx -> Maybe Color) -> PropCtx -> Doc
genGetColor Color
defColor PropCtx -> Maybe Color
select PropCtx
ctx = Color -> Doc
forall b. (RealFrac b, Floating b) => Colour b -> Doc
colorToDoc (Color -> Doc) -> Color -> Doc
forall a b. (a -> b) -> a -> b
$ Color -> (Color -> Color) -> Maybe Color -> Color
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Color
defColor Color -> Color
forall a. a -> a
id (Maybe Color -> Color) -> Maybe Color -> Color
forall a b. (a -> b) -> a -> b
$ PropCtx -> Maybe Color
select PropCtx
ctx
    where
      colorToDoc :: Colour b -> Doc
colorToDoc Colour b
col = [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma
            ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ((RGB Word8 -> Word8) -> Doc) -> [RGB Word8 -> Word8] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Colour b -> (RGB Word8 -> Word8) -> Doc
forall a b.
(Enum a, RealFrac b, Floating b) =>
Colour b -> (RGB Word8 -> a) -> Doc
channelToDoc Colour b
col) [RGB Word8 -> Word8
forall a. RGB a -> a
channelRed, RGB Word8 -> Word8
forall a. RGB a -> a
channelGreen, RGB Word8 -> Word8
forall a. RGB a -> a
channelBlue]

      channelToDoc :: Colour b -> (RGB Word8 -> a) -> Doc
channelToDoc Colour b
col RGB Word8 -> a
chn = Int -> Doc
int (Int -> Doc) -> Int -> Doc
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Enum a => a -> Int
fromEnum (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ RGB Word8 -> a
chn (RGB Word8 -> a) -> RGB Word8 -> a
forall a b. (a -> b) -> a -> b
$ Colour b -> RGB Word8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24 (Colour b -> RGB Word8) -> Colour b -> RGB Word8
forall a b. (a -> b) -> a -> b
$ Colour b
col