-- | Data type for OSC datum.
module Sound.OSC.Datum where

import Data.Char {- base -}
import Data.Int {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import Data.Word {- base -}
import Numeric {- base -}
import Text.Printf {- base -}
import Text.Read {- base -}

import qualified Data.ByteString.Lazy as Lazy {- bytestring -}
import qualified Data.ByteString.Char8 as Char8 {- bytestring -}

import qualified Sound.OSC.Time as Time {- hosc -}

-- * Datum

-- | Type enumerating Datum categories.
type Datum_Type = Char

-- | Type for ASCII strings (strict 'Char'8 'Char8.ByteString').
type ASCII = Char8.ByteString

-- | Type-specialised 'Char8.pack'.
ascii :: String -> ASCII
ascii :: String -> ASCII
ascii = String -> ASCII
Char8.pack

-- | Type-specialised 'Char8.unpack'.
ascii_to_string :: ASCII -> String
ascii_to_string :: ASCII -> String
ascii_to_string = ASCII -> String
Char8.unpack

-- | Type for 'Word8' arrays, these are stored with an 'Int32' length prefix.
type BLOB = Lazy.ByteString

-- | Type-specialised 'Lazy.pack'.
blob_pack ::  [Word8] -> BLOB
blob_pack :: [Word8] -> BLOB
blob_pack = [Word8] -> BLOB
Lazy.pack

-- | Type-specialised 'Lazy.unpack'.
blob_unpack :: BLOB -> [Word8]
blob_unpack :: BLOB -> [Word8]
blob_unpack = BLOB -> [Word8]
Lazy.unpack

-- | Four-byte midi message: port-id, status-byte, data, data.
data MIDI = MIDI !Word8 !Word8 !Word8 !Word8
    deriving (MIDI -> MIDI -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MIDI -> MIDI -> Bool
$c/= :: MIDI -> MIDI -> Bool
== :: MIDI -> MIDI -> Bool
$c== :: MIDI -> MIDI -> Bool
Eq,Int -> MIDI -> ShowS
[MIDI] -> ShowS
MIDI -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MIDI] -> ShowS
$cshowList :: [MIDI] -> ShowS
show :: MIDI -> String
$cshow :: MIDI -> String
showsPrec :: Int -> MIDI -> ShowS
$cshowsPrec :: Int -> MIDI -> ShowS
Show,ReadPrec [MIDI]
ReadPrec MIDI
Int -> ReadS MIDI
ReadS [MIDI]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [MIDI]
$creadListPrec :: ReadPrec [MIDI]
readPrec :: ReadPrec MIDI
$creadPrec :: ReadPrec MIDI
readList :: ReadS [MIDI]
$creadList :: ReadS [MIDI]
readsPrec :: Int -> ReadS MIDI
$creadsPrec :: Int -> ReadS MIDI
Read)

-- | The basic elements of OSC messages.
data Datum = Int32 {Datum -> Int32
d_int32 :: !Int32}
           | Int64 {Datum -> Int64
d_int64 :: !Int64}
           | Float {Datum -> Float
d_float :: !Float}
           | Double {Datum -> Time
d_double :: !Double}
           | ASCII_String {Datum -> ASCII
d_ascii_string :: !ASCII}
           | Blob {Datum -> BLOB
d_blob :: !BLOB}
           | TimeStamp {Datum -> Time
d_timestamp :: !Time.Time} -- ie. NTPr
           | Midi {Datum -> MIDI
d_midi :: !MIDI}
             deriving (Datum -> Datum -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Datum -> Datum -> Bool
$c/= :: Datum -> Datum -> Bool
== :: Datum -> Datum -> Bool
$c== :: Datum -> Datum -> Bool
Eq,ReadPrec [Datum]
ReadPrec Datum
Int -> ReadS Datum
ReadS [Datum]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Datum]
$creadListPrec :: ReadPrec [Datum]
readPrec :: ReadPrec Datum
$creadPrec :: ReadPrec Datum
readList :: ReadS [Datum]
$creadList :: ReadS [Datum]
readsPrec :: Int -> ReadS Datum
$creadsPrec :: Int -> ReadS Datum
Read,Int -> Datum -> ShowS
[Datum] -> ShowS
Datum -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Datum] -> ShowS
$cshowList :: [Datum] -> ShowS
show :: Datum -> String
$cshow :: Datum -> String
showsPrec :: Int -> Datum -> ShowS
$cshowsPrec :: Int -> Datum -> ShowS
Show)

-- * Datum types

-- | List of required data types (tag,name).
osc_types_required :: [(Datum_Type,String)]
osc_types_required :: [(Datum_Type, String)]
osc_types_required =
    [(Datum_Type
'i',String
"Int32")
    ,(Datum_Type
'f',String
"Float")
    ,(Datum_Type
's',String
"ASCII_String") -- ASCII
    ,(Datum_Type
'b',String
"ByteArray") -- Blob
    ]

-- | List of optional data types (tag,name).
osc_types_optional :: [(Datum_Type,String)]
osc_types_optional :: [(Datum_Type, String)]
osc_types_optional =
    [(Datum_Type
'h',String
"Int64")
    ,(Datum_Type
't',String
"TimeStamp")
    ,(Datum_Type
'd',String
"Double")
    -- ,('S',"Symbol")
    -- ,('c',"ASCII_Character")
    -- ,('r',"RGBA")
    ,(Datum_Type
'm',String
"MIDI")
    -- ,('T',"True")
    -- ,('F',"False")
    -- ,('N',"Nil")
    -- ,('I',"Infinitum")
    -- ,('[',"Array_Begin")
    -- ,(']',"Array_End")
    ]

-- | List of all data types (tag,name).
osc_types :: [(Datum_Type,String)]
osc_types :: [(Datum_Type, String)]
osc_types = [(Datum_Type, String)]
osc_types_required forall a. [a] -> [a] -> [a]
++ [(Datum_Type, String)]
osc_types_optional

-- | Lookup name of type.
osc_type_name :: Datum_Type -> Maybe String
osc_type_name :: Datum_Type -> Maybe String
osc_type_name Datum_Type
c = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Datum_Type
c [(Datum_Type, String)]
osc_types

-- | Erroring variant.
osc_type_name_err :: Datum_Type -> String
osc_type_name_err :: Datum_Type -> String
osc_type_name_err = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"osc_type_name") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Datum_Type -> Maybe String
osc_type_name

-- | Single character identifier of an OSC datum.
datum_tag :: Datum -> Datum_Type
datum_tag :: Datum -> Datum_Type
datum_tag Datum
d =
    case Datum
d of
      Int32 Int32
_ -> Datum_Type
'i'
      Int64 Int64
_ -> Datum_Type
'h'
      Float Float
_ -> Datum_Type
'f'
      Double Time
_ -> Datum_Type
'd'
      ASCII_String ASCII
_ -> Datum_Type
's'
      Blob BLOB
_ -> Datum_Type
'b'
      TimeStamp Time
_ -> Datum_Type
't'
      Midi MIDI
_ -> Datum_Type
'm'

-- | Type and name of 'Datum'.
datum_type_name :: Datum -> (Datum_Type,String)
datum_type_name :: Datum -> (Datum_Type, String)
datum_type_name Datum
d = let c :: Datum_Type
c = Datum -> Datum_Type
datum_tag Datum
d in (Datum_Type
c,Datum_Type -> String
osc_type_name_err Datum_Type
c)

-- * Generalised element access

-- | 'Datum' as 'Integral' if Int32 or Int64.
--
-- > let d = [Int32 5,Int64 5,Float 5.5,Double 5.5]
-- > map datum_integral d == [Just (5::Int),Just 5,Nothing,Nothing]
datum_integral :: Integral i => Datum -> Maybe i
datum_integral :: forall i. Integral i => Datum -> Maybe i
datum_integral Datum
d =
    case Datum
d of
      Int32 Int32
x -> forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
x)
      Int64 Int64
x -> forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
x)
      Datum
_ -> forall a. Maybe a
Nothing

-- | 'Datum' as 'Floating' if Int32, Int64, Float, Double or TimeStamp.
--
-- > let d = [Int32 5,Int64 5,Float 5,Double 5,TimeStamp 5]
-- > mapMaybe datum_floating d == replicate 5 (5::Double)
datum_floating :: Floating n => Datum -> Maybe n
datum_floating :: forall n. Floating n => Datum -> Maybe n
datum_floating Datum
d =
    case Datum
d of
      Int32 Int32
n -> forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n)
      Int64 Int64
n -> forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)
      Float Float
n -> forall a. a -> Maybe a
Just (forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
n)
      Double Time
n -> forall a. a -> Maybe a
Just (forall a b. (Real a, Fractional b) => a -> b
realToFrac Time
n)
      TimeStamp Time
n -> forall a. a -> Maybe a
Just (forall a b. (Real a, Fractional b) => a -> b
realToFrac Time
n)
      Datum
_ -> forall a. Maybe a
Nothing

-- * Constructors

-- | Type generalised 'Int32'.
--
-- > int32 (1::Int32) == int32 (1::Integer)
-- > d_int32 (int32 (maxBound::Int32)) == maxBound
-- > int32 (((2::Int) ^ (64::Int))::Int) == Int32 0
int32 :: Integral n => n -> Datum
int32 :: forall n. Integral n => n -> Datum
int32 = Int32 -> Datum
Int32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Type generalised Int64.
--
-- > int64 (1::Int32) == int64 (1::Integer)
-- > d_int64 (int64 (maxBound::Int64)) == maxBound
int64 :: Integral n => n -> Datum
int64 :: forall n. Integral n => n -> Datum
int64 = Int64 -> Datum
Int64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Type generalised Float.
--
-- > float (1::Int) == float (1::Double)
-- > floatRange (undefined::Float) == (-125,128)
-- > isInfinite (d_float (float (encodeFloat 1 256 :: Double))) == True
float :: Real n => n -> Datum
float :: forall n. Real n => n -> Datum
float = Float -> Datum
Float forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac

-- | Type generalised Double.
--
-- > double (1::Int) == double (1::Double)
-- > double (encodeFloat 1 256 :: Double) == Double 1.157920892373162e77
double :: Real n => n -> Datum
double :: forall n. Real n => n -> Datum
double = Time -> Datum
Double forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac

-- | 'ASCII_String' of 'Char8.pack'.
--
-- > string "string" == ASCII_String (Char8.pack "string")
string :: String -> Datum
string :: String -> Datum
string = ASCII -> Datum
ASCII_String forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ASCII
Char8.pack

-- | Four-tuple variant of 'Midi' '.' 'MIDI'.
--
-- > midi (0,0,0,0) == Midi (MIDI 0 0 0 0)
midi :: (Word8,Word8,Word8,Word8) -> Datum
midi :: (Word8, Word8, Word8, Word8) -> Datum
midi (Word8
p,Word8
q,Word8
r,Word8
s) = MIDI -> Datum
Midi (Word8 -> Word8 -> Word8 -> Word8 -> MIDI
MIDI Word8
p Word8
q Word8
r Word8
s)

-- | 'Blob' of 'blob_pack'.
blob :: [Word8] -> Datum
blob :: [Word8] -> Datum
blob = BLOB -> Datum
Blob forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> BLOB
blob_pack

-- * Descriptor

-- | Message argument types are given by a descriptor.
--
-- > descriptor [Int32 1,Float 1,string "1"] == ascii ",ifs"
descriptor :: [Datum] -> ASCII
descriptor :: [Datum] -> ASCII
descriptor [Datum]
l = String -> ASCII
Char8.pack (Datum_Type
',' forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Datum -> Datum_Type
datum_tag [Datum]
l)

-- | Descriptor tags are @comma@ prefixed.
descriptor_tags :: ASCII -> ASCII
descriptor_tags :: ASCII -> ASCII
descriptor_tags = Int -> ASCII -> ASCII
Char8.drop Int
1

-- * Pretty printing

-- | Perhaps a precision value for floating point numbers.
type FP_Precision = Maybe Int

-- | Variant of 'showFFloat' that deletes trailing zeros.
--
-- > map (floatPP (Just 4)) [1,pi] == ["1.0","3.1416"]
floatPP :: RealFloat n => FP_Precision -> n -> String
floatPP :: forall n. RealFloat n => FP_Precision -> n -> String
floatPP FP_Precision
p n
n =
    let s :: String
s = forall a. RealFloat a => FP_Precision -> a -> ShowS
showFFloat FP_Precision
p n
n String
""
        s' :: String
s' = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Datum_Type
'0') (forall a. [a] -> [a]
reverse String
s)
    in case String
s' of
         Datum_Type
'.':String
_ -> forall a. [a] -> [a]
reverse (Datum_Type
'0' forall a. a -> [a] -> [a]
: String
s')
         String
_ -> forall a. [a] -> [a]
reverse String
s'

-- | Pretty printer for 'Time'.
--
-- > timePP (Just 4) (1/3) == "0.3333"
timePP :: FP_Precision -> Time.Time -> String
timePP :: FP_Precision -> Time -> String
timePP = forall n. RealFloat n => FP_Precision -> n -> String
floatPP

-- | Pretty printer for vectors.
--
-- > vecPP show [1::Int,2,3] == "<1,2,3>"
vecPP :: (a -> String) -> [a] -> String
vecPP :: forall a. (a -> String) -> [a] -> String
vecPP a -> String
f [a]
v = Datum_Type
'<' forall a. a -> [a] -> [a]
: forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map a -> String
f [a]
v) forall a. [a] -> [a] -> [a]
++ String
">"

-- | Pretty printer for blobs, two-digit zero-padded hexadecimal.
blobPP :: BLOB -> String
blobPP :: BLOB -> String
blobPP = (Datum_Type
'B'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> String) -> [a] -> String
vecPP (forall r. PrintfType r => String -> r
printf String
"%02X") forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLOB -> [Word8]
Lazy.unpack

-- | Print strings in double quotes iff they contain white space.
stringPP :: String -> String
stringPP :: ShowS
stringPP String
x = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Datum_Type -> Bool
isSpace String
x then forall a. Show a => a -> String
show String
x else String
x

{- | Pretty printer for 'Datum'.

> let d = [Int32 1,Float 1.2,string "str",midi (0,0x90,0x40,0x60),blob [12,16]]
> map (datumPP (Just 5)) d==  ["1","1.2","str","M<0,144,64,96>","B<0C,10>"]

-}
datumPP :: FP_Precision -> Datum -> String
datumPP :: FP_Precision -> Datum -> String
datumPP FP_Precision
p Datum
d =
    case Datum
d of
      Int32 Int32
n -> forall a. Show a => a -> String
show Int32
n
      Int64 Int64
n -> forall a. Show a => a -> String
show Int64
n
      Float Float
n -> forall n. RealFloat n => FP_Precision -> n -> String
floatPP FP_Precision
p Float
n
      Double Time
n -> forall n. RealFloat n => FP_Precision -> n -> String
floatPP FP_Precision
p Time
n
      ASCII_String ASCII
s -> ShowS
stringPP (ASCII -> String
Char8.unpack ASCII
s)
      Blob BLOB
s -> BLOB -> String
blobPP BLOB
s
      TimeStamp Time
t -> FP_Precision -> Time -> String
timePP FP_Precision
p Time
t
      Midi (MIDI Word8
b1 Word8
b2 Word8
b3 Word8
b4) -> Datum_Type
'M'forall a. a -> [a] -> [a]
: forall a. (a -> String) -> [a] -> String
vecPP forall a. Show a => a -> String
show [Word8
b1,Word8
b2,Word8
b3,Word8
b4]

-- | Variant of 'datumPP' that appends the 'datum_type_name'.
datum_pp_typed :: FP_Precision -> Datum -> String
datum_pp_typed :: FP_Precision -> Datum -> String
datum_pp_typed FP_Precision
fp Datum
d = FP_Precision -> Datum -> String
datumPP FP_Precision
fp Datum
d forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a b. (a, b) -> b
snd (Datum -> (Datum_Type, String)
datum_type_name Datum
d)

-- * Parser

-- | Given 'Datum_Type' attempt to parse 'Datum' at 'String'.
--
-- > parse_datum 'i' "42" == Just (Int32 42)
-- > parse_datum 'h' "42" == Just (Int64 42)
-- > parse_datum 'f' "3.14159" == Just (Float 3.14159)
-- > parse_datum 'd' "3.14159" == Just (Double 3.14159)
-- > parse_datum 's' "\"pi\"" == Just (string "pi")
-- > parse_datum 'b' "[112,105]" == Just (Blob (blob_pack [112,105]))
-- > parse_datum 'm' "(0,144,60,90)" == Just (midi (0,144,60,90))
parse_datum :: Datum_Type -> String -> Maybe Datum
parse_datum :: Datum_Type -> String -> Maybe Datum
parse_datum Datum_Type
ty =
    case Datum_Type
ty of
      Datum_Type
'i' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> Datum
Int32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe
      Datum_Type
'h' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> Datum
Int64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe
      Datum_Type
'f' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Float -> Datum
Float forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe
      Datum_Type
'd' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Time -> Datum
Double forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe
      Datum_Type
's' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ASCII -> Datum
ASCII_String forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ASCII
Char8.pack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe
      Datum_Type
'b' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BLOB -> Datum
Blob forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> BLOB
blob_pack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe
      Datum_Type
't' -> forall a. HasCallStack => String -> a
error String
"parse_datum: timestamp not implemented"
      Datum_Type
'm' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word8, Word8, Word8, Word8) -> Datum
midi forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe
      Datum_Type
_ -> forall a. HasCallStack => String -> a
error String
"parse_datum: unknown type"

-- | Erroring variant of 'parse_datum'.
parse_datum_err :: Datum_Type -> String -> Datum
parse_datum_err :: Datum_Type -> String -> Datum
parse_datum_err Datum_Type
ty = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"parse_datum") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Datum_Type -> String -> Maybe Datum
parse_datum Datum_Type
ty