module Sound.OpenSoundControl.Type where
import qualified Data.ByteString.Lazy as B
import Data.List
import Data.Maybe
import Data.Word
import Sound.OpenSoundControl.Time
type Datum_Type = Char
data Datum = Int Int
| Float Double
| Double Double
| String String
| Blob B.ByteString
| TimeStamp Time
| Midi (Word8,Word8,Word8,Word8)
deriving (Eq,Read,Show)
type Address_Pattern = String
data Message = Message {messageAddress :: Address_Pattern
,messageDatum :: [Datum]}
deriving (Eq,Read,Show)
data Bundle = Bundle {bundleTime :: Time
,bundleMessages :: [Message]}
deriving (Eq,Read,Show)
data Packet = Packet_Message {packetMessage :: Message}
| Packet_Bundle {packetBundle :: Bundle}
deriving (Eq,Read,Show)
instance Ord Bundle where
compare (Bundle a _) (Bundle b _) = compare a b
bundle :: Time -> [Message] -> Bundle
bundle t xs =
case xs of
[] -> error "bundle: empty?"
_ -> Bundle t xs
message :: Address_Pattern -> [Datum] -> Message
message a xs =
case a of
'/':_ -> Message a xs
_ -> error "message: ill-formed address pattern"
p_bundle :: Time -> [Message] -> Packet
p_bundle t = Packet_Bundle . bundle t
p_message :: Address_Pattern -> [Datum] -> Packet
p_message a = Packet_Message . message a
datum_tag :: Datum -> Datum_Type
datum_tag dt =
case dt of
Int _ -> 'i'
Float _ -> 'f'
Double _ -> 'd'
String _ -> 's'
Blob _ -> 'b'
TimeStamp _ -> 't'
Midi _ -> 'm'
readMaybe :: (Read a) => String -> Maybe a
readMaybe s =
case reads s of
[(x, "")] -> Just x
_ -> Nothing
parse_datum :: Datum_Type -> String -> Maybe Datum
parse_datum ty =
case ty of
'i' -> fmap Int . readMaybe
'f' -> fmap Float . readMaybe
'd' -> fmap Double . readMaybe
's' -> fmap String . readMaybe
'b' -> Just . Blob . B.pack . map (fromIntegral . fromEnum)
't' -> error "parse_datum: timestamp"
'm' -> fmap Midi . readMaybe
_ -> error "parse_datum: type"
datum_real :: Datum -> Maybe Double
datum_real d =
case d of
Double n -> Just n
Float n -> Just n
Int n -> Just (fromIntegral n)
_ -> Nothing
datum_real_err :: Datum -> Double
datum_real_err = fromJust . datum_real
datum_int :: Integral i => Datum -> Maybe i
datum_int d =
case d of
Int x -> Just (fromIntegral x)
Float x -> Just (floor x)
Double x -> Just (floor x)
_ -> Nothing
datum_int_err :: Integral i => Datum -> i
datum_int_err = fromJust . datum_int
datum_string :: Datum -> Maybe String
datum_string d =
case d of
Blob s -> Just (map (toEnum . fromIntegral) (B.unpack s))
String s -> Just s
_ -> Nothing
datum_string_err :: Datum -> String
datum_string_err = fromJust . datum_string
message_has_address :: Address_Pattern -> Message -> Bool
message_has_address x = (== x) . messageAddress
bundle_has_address :: Address_Pattern -> Bundle -> Bool
bundle_has_address x = any (message_has_address x) . bundleMessages
packet_has_address :: Address_Pattern -> Packet -> Bool
packet_has_address x =
at_packet (message_has_address x)
(bundle_has_address x)
packetTime :: Packet -> Time
packetTime = at_packet (const immediately) bundleTime
packetMessages :: Packet -> [Message]
packetMessages = at_packet return bundleMessages
packet_to_bundle :: Packet -> Bundle
packet_to_bundle = at_packet (\m -> Bundle immediately [m]) id
packet_to_message :: Packet -> Maybe Message
packet_to_message p =
case p of
Packet_Bundle b ->
case b of
Bundle t [m] -> if t == immediately then Just m else Nothing
_ -> Nothing
Packet_Message m -> Just m
packet_is_immediate :: Packet -> Bool
packet_is_immediate = (== immediately) . packetTime
at_packet :: (Message -> a) -> (Bundle -> a) -> Packet -> a
at_packet f g p =
case p of
Packet_Message m -> f m
Packet_Bundle b -> g b
timePP :: Time -> String
timePP = (:) 'N' . show
datumPP :: Datum -> String
datumPP d =
case d of
Int n -> show n
Float n -> show n
Double n -> show n
String s -> show s
Blob s -> show s
TimeStamp t -> timePP t
Midi (p,q,r,s) -> '<' : intercalate "," (map show [p,q,r,s]) ++ ">"
messagePP :: Message -> String
messagePP (Message a d) = unwords ("#message" : a : map datumPP d)
bundlePP :: Bundle -> String
bundlePP (Bundle t m) =
let m' = intersperse ";" (map messagePP m)
in unwords ("#bundle" : timePP t : m')
packetPP :: Packet -> String
packetPP p =
case p of
Packet_Message m -> messagePP m
Packet_Bundle b -> bundlePP b