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.Default
import Data.Colour.Names(white, gray, black)
import Data.Colour.SRGB
import Data.Text (Text)
import Data.Text qualified as Text

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

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

import Csound.Typed.Gui.Types

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

ppProc :: Text -> [Doc] -> Doc
ppProc :: Text -> [Doc] -> Doc
ppProc Text
name [Doc]
xs = Text -> Doc
textStrict Text
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] -> Text -> [Doc] -> Doc
ppMoOpc :: [Doc] -> Text -> [Doc] -> Doc
ppMoOpc [Doc]
outs Text
name [Doc]
ins = [Doc] -> Doc
f [Doc]
outs Doc -> Doc -> Doc
P.<+> Text -> Doc
textStrict Text
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 Text
name   -> [Doc] -> Doc
hcat [VarType -> Doc
ppVarType VarType
ty, Rate -> Doc
ppRate Rate
rate, Text -> Doc
textStrict (Char -> Text -> Text
Text.cons (VarType -> Char
varPrefix VarType
ty) Text
name)]
    VarVerbatim Rate
_ Text
name -> Text -> Doc
textStrict Text
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 = Text -> Doc
textStrict (Text -> Doc) -> (Rate -> Text) -> Rate -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.toLower (Text -> Text) -> (Rate -> Text) -> Rate -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (Rate -> String) -> Rate -> Text
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 :: forall a. Default a => 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 :: forall a.
Default a =>
(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 a b. (a -> b) -> [a] -> [b]
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