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
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
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