-- | A simple and unambigous text encoding for Osc.
module Sound.Osc.Text where

import Control.Monad {- base -}
import Data.Char {- base -}
import Numeric {- base -}
import Text.Printf {- base -}

import qualified Text.ParserCombinators.Parsec as P {- parsec -}

import Sound.Osc.Datum {- hosc -}
import Sound.Osc.Packet  {- hosc3 -}
import Sound.Osc.Time  {- hosc3 -}

-- | Precision value for floating point numbers.
type FpPrecision = Maybe Int

{- | Variant of 'showFFloat' that deletes trailing zeros.

> map (showFloatWithPrecision (Just 4)) [1, 2.0, pi] == ["1.0", "2.0", "3.1416"]
-}
showFloatWithPrecision :: RealFloat n => FpPrecision -> n -> String
showFloatWithPrecision :: forall n. RealFloat n => FpPrecision -> n -> [Char]
showFloatWithPrecision FpPrecision
p n
n =
    let s :: [Char]
s = forall a. RealFloat a => FpPrecision -> a -> ShowS
showFFloat FpPrecision
p n
n [Char]
""
        s' :: [Char]
s' = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'0') (forall a. [a] -> [a]
reverse [Char]
s)
    in case [Char]
s' of
         Char
'.':[Char]
_ -> forall a. [a] -> [a]
reverse (Char
'0' forall a. a -> [a] -> [a]
: [Char]
s')
         [Char]
_ -> forall a. [a] -> [a]
reverse [Char]
s'

{- | Hex encoded byte sequence.

> showBytes [0, 15, 16, 144, 255] == "000f1090ff"
-}
showBytes :: [Int] -> String
showBytes :: [Int] -> [Char]
showBytes = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall r. PrintfType r => [Char] -> r
printf [Char]
"%02x")

{- | Escape whites space (space, tab, newline) and the escape character (backslash).

> mapM_ (putStrLn .  escapeString) ["str", "str ", "st r", "s\tr", "s\\tr", "\nstr"]
-}
escapeString :: String -> String
escapeString :: ShowS
escapeString [Char]
txt =
  case [Char]
txt of
    [] -> []
    Char
c:[Char]
txt' -> if Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"\\\t\n " then Char
'\\'  forall a. a -> [a] -> [a]
: Char
c forall a. a -> [a] -> [a]
: ShowS
escapeString [Char]
txt' else Char
c forall a. a -> [a] -> [a]
: ShowS
escapeString [Char]
txt'

{- | Printer for Datum.

> aDatumSeq = [Int32 1,Float 1.2,string "str",midi (0,0x90,0x40,0x60),blob [12,16], TimeStamp 100.0]
> map (showDatum (Just 5)) aDatumSeq == ["1","1.2","str","00904060","0c10","429496729600"]
-}
showDatum :: FpPrecision -> Datum -> String
showDatum :: FpPrecision -> Datum -> [Char]
showDatum FpPrecision
p Datum
d =
    case Datum
d of
      Int32 Int32
n -> forall a. Show a => a -> [Char]
show Int32
n
      Int64 Int64
n -> forall a. Show a => a -> [Char]
show Int64
n
      Float Float
n -> forall n. RealFloat n => FpPrecision -> n -> [Char]
showFloatWithPrecision FpPrecision
p Float
n
      Double Double
n -> forall n. RealFloat n => FpPrecision -> n -> [Char]
showFloatWithPrecision FpPrecision
p Double
n
      AsciiString Ascii
s -> ShowS
escapeString (Ascii -> [Char]
ascii_to_string Ascii
s)
      Blob Blob
s -> [Int] -> [Char]
showBytes (Blob -> [Int]
blob_unpack_int Blob
s)
      TimeStamp Double
t -> forall a. Show a => a -> [Char]
show (Double -> Ntp64
ntpr_to_ntpi Double
t)
      Midi MidiData
m -> [Int] -> [Char]
showBytes (MidiData -> [Int]
midi_unpack_int MidiData
m)

{- | Printer for Message.

> aMessage = Message "/addr" [Int32 1, Int64 2, Float 3, Double 4, string "five", blob [6, 7], midi (8, 9, 10, 11)]
> showMessage (Just 4) aMessage

> aMessageSeq = [Message "/c_set" [Int32 1, Float 2.3], Message "/s_new" [string "sine", Int32 (-1), Int32 1, Int32 1]]
> map (showMessage (Just 4)) aMessageSeq
-}
showMessage :: FpPrecision -> Message -> String
showMessage :: FpPrecision -> Message -> [Char]
showMessage FpPrecision
precision Message
aMessage =
  [[Char]] -> [Char]
unwords
  [Message -> [Char]
messageAddress Message
aMessage
  ,Message -> [Char]
messageSignature Message
aMessage
  ,[[Char]] -> [Char]
unwords (forall a b. (a -> b) -> [a] -> [b]
map (FpPrecision -> Datum -> [Char]
showDatum FpPrecision
precision) (Message -> [Datum]
messageDatum Message
aMessage))]

{- | Printer for Bundle

> aBundle = Bundle 1 [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]]
> showBundle (Just 4) aBundle
-}
showBundle :: FpPrecision -> Bundle -> String
showBundle :: FpPrecision -> Bundle -> [Char]
showBundle FpPrecision
precision Bundle
aBundle =
  let messages :: [Message]
messages = Bundle -> [Message]
bundleMessages Bundle
aBundle
  in [[Char]] -> [Char]
unwords
     [[Char]
"#bundle"
     ,forall a. Show a => a -> [Char]
show (Double -> Ntp64
ntpr_to_ntpi (Bundle -> Double
bundleTime Bundle
aBundle))
     ,forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Message]
messages)
     ,[[Char]] -> [Char]
unwords (forall a b. (a -> b) -> [a] -> [b]
map (FpPrecision -> Message -> [Char]
showMessage FpPrecision
precision) [Message]
messages)]

-- | Printer for Packet.
showPacket :: FpPrecision -> Packet -> String
showPacket :: FpPrecision -> Packet -> [Char]
showPacket FpPrecision
precision = forall a. (Message -> a) -> (Bundle -> a) -> Packet -> a
at_packet (FpPrecision -> Message -> [Char]
showMessage FpPrecision
precision) (FpPrecision -> Bundle -> [Char]
showBundle FpPrecision
precision)

-- * Parser

-- | A character parser with no user state.
type P a = P.GenParser Char () a

-- | Run p then q, returning result of p.
(>>~) :: Monad m => m t -> m u -> m t
m t
p >>~ :: forall (m :: * -> *) t u. Monad m => m t -> m u -> m t
>>~ m u
q = m t
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \t
x -> m u
q forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return t
x

-- | /p/ as lexeme, i.e. consuming any trailing white space.
lexemeP :: P t -> P t
lexemeP :: forall t. P t -> P t
lexemeP P t
p = P t
p forall (m :: * -> *) t u. Monad m => m t -> m u -> m t
>>~ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.space

-- | Any non-space character.  Allow escaped space.
stringCharP :: P Char
stringCharP :: P Char
stringCharP = (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'\\' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
P.space) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
P.<|> forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
P.satisfy (\Char
c -> Bool -> Bool
not (Char -> Bool
isSpace Char
c))

-- | Parser for string.
stringP :: P String
stringP :: P [Char]
stringP = forall t. P t -> P t
lexemeP (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 P Char
stringCharP)

-- | Parser for Osc address.
oscAddressP :: P String
oscAddressP :: P [Char]
oscAddressP = do
  Char
forwardSlash <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'/'
  [Char]
address <- P [Char]
stringP
  forall (m :: * -> *) a. Monad m => a -> m a
return (Char
forwardSlash forall a. a -> [a] -> [a]
: [Char]
address)

-- | Parser for Osc signature.
oscSignatureP :: P String
oscSignatureP :: P [Char]
oscSignatureP = forall t. P t -> P t
lexemeP (do
  Char
comma <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
','
  [Char]
types <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
P.oneOf [Char]
"ifsbhtdm") -- 1.0 = ifsb 2.0 = htdm
  forall (m :: * -> *) a. Monad m => a -> m a
return (Char
comma forall a. a -> [a] -> [a]
: [Char]
types))

-- | Parser for decimal digit.
digitP :: P Char
digitP :: P Char
digitP = forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
P.oneOf [Char]
"0123456789"

allowNegativeP :: Num n => P n -> P n
allowNegativeP :: forall n. Num n => P n -> P n
allowNegativeP P n
p = do
  let optionMaybe :: ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe ParsecT s u m a
x = forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
P.option forall a. Maybe a
Nothing (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just ParsecT s u m a
x) -- hugs...
  Maybe Char
maybeNegative <- forall {s} {m :: * -> *} {t} {u} {a}.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'-')
  n
number <- P n
p
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall b a. b -> (a -> b) -> Maybe a -> b
maybe n
number (forall a b. a -> b -> a
const (forall a. Num a => a -> a
negate n
number)) Maybe Char
maybeNegative)

-- | Parser for non-negative integer.
nonNegativeIntegerP :: (Integral n, Read n) => P n
nonNegativeIntegerP :: forall n. (Integral n, Read n) => P n
nonNegativeIntegerP = forall t. P t -> P t
lexemeP (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Read a => [Char] -> a
read (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 P Char
digitP))

-- | Parser for integer.
integerP :: (Integral n, Read n) => P n
integerP :: forall n. (Integral n, Read n) => P n
integerP = forall n. Num n => P n -> P n
allowNegativeP forall n. (Integral n, Read n) => P n
nonNegativeIntegerP

-- | Parser for non-negative float.
nonNegativeFloatP :: (Fractional n, Read n) => P n
nonNegativeFloatP :: forall n. (Fractional n, Read n) => P n
nonNegativeFloatP = forall t. P t -> P t
lexemeP (do
  [Char]
integerPart <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 P Char
digitP
  Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
P.char Char
'.'
  [Char]
fractionalPart <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 P Char
digitP
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Read a => [Char] -> a
read (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]
integerPart, [Char]
".", [Char]
fractionalPart])))

-- | Parser for non-negative float.
floatP :: (Fractional n, Read n) => P n
floatP :: forall n. (Fractional n, Read n) => P n
floatP = forall n. Num n => P n -> P n
allowNegativeP forall n. (Fractional n, Read n) => P n
nonNegativeFloatP

-- | Parser for hexadecimal digit.
hexdigitP :: P Char
hexdigitP :: P Char
hexdigitP = forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
P.oneOf [Char]
"0123456789abcdef"

-- | Byte parser.
byteP :: (Integral n, Read n) => P n
byteP :: forall n. (Integral n, Read n) => P n
byteP = do
  Char
c1 <- P Char
hexdigitP
  Char
c2 <- P Char
hexdigitP
  case forall a. (Eq a, Num a) => ReadS a
readHex [Char
c1, Char
c2] of
    [(n
r,[Char]
"")] -> forall (m :: * -> *) a. Monad m => a -> m a
return n
r
    [(n, [Char])]
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"byteP?"

-- | Byte sequence parser.
byteSeqP :: (Integral n, Read n) => P [n]
byteSeqP :: forall n. (Integral n, Read n) => P [n]
byteSeqP = forall t. P t -> P t
lexemeP (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 forall n. (Integral n, Read n) => P n
byteP)

-- | Datum parser.
datumP :: Char -> P Datum
datumP :: Char -> P Datum
datumP Char
typeChar = do
  case Char
typeChar of
    Char
'i' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int32 -> Datum
Int32 forall n. (Integral n, Read n) => P n
integerP
    Char
'f' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Float -> Datum
Float forall n. (Fractional n, Read n) => P n
floatP
    Char
's' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Datum
string P [Char]
stringP
    Char
'b' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word8] -> Datum
blob forall n. (Integral n, Read n) => P [n]
byteSeqP
    Char
'h' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> Datum
Int64 forall n. (Integral n, Read n) => P n
integerP
    Char
'd' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Datum
Double forall n. (Fractional n, Read n) => P n
floatP
    Char
'm' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MidiData -> Datum
Midi forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> MidiData
midi_pack) (forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 forall n. (Integral n, Read n) => P n
byteP)
    Char
't' -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Datum
TimeStamp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ntp64 -> Double
ntpi_to_ntpr) forall n. (Integral n, Read n) => P n
integerP
    Char
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"datumP: type?"

-- | Message parser.
messageP :: P Message
messageP :: P Message
messageP = do
  [Char]
address <- P [Char]
oscAddressP
  [Char]
typeSignature <- P [Char]
oscSignatureP
  [Datum]
datum <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Char -> P Datum
datumP (forall a. [a] -> [a]
tail [Char]
typeSignature)
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> [Datum] -> Message
Message [Char]
address [Datum]
datum)

-- | Bundle tag parser.
bundleTagP :: P String
bundleTagP :: P [Char]
bundleTagP = forall t. P t -> P t
lexemeP (forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
P.string [Char]
"#bundle")

-- | Bundle parser.
bundleP :: P Bundle
bundleP :: P Bundle
bundleP = do
  [Char]
_ <- P [Char]
bundleTagP
  Double
timestamp <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ntp64 -> Double
ntpi_to_ntpr forall n. (Integral n, Read n) => P n
integerP
  Int
messageCount <- forall n. (Integral n, Read n) => P n
integerP
  [Message]
messages <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
messageCount P Message
messageP
  forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> [Message] -> Bundle
Bundle Double
timestamp [Message]
messages)

-- | Packet parser.
packetP :: P Packet
packetP :: P Packet
packetP = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bundle -> Packet
Packet_Bundle P Bundle
bundleP) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
P.<|> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Message -> Packet
Packet_Message P Message
messageP)

-- | Run parser.
runP :: P t -> String -> t
runP :: forall t. P t -> [Char] -> t
runP P t
p [Char]
txt =
  case forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
P.parse P t
p [Char]
"" [Char]
txt of
    Left ParseError
err -> forall a. HasCallStack => [Char] -> a
error (forall a. Show a => a -> [Char]
show ParseError
err)
    Right t
r -> t
r

{- | Run datum parser.

> parseDatum 'i' "-1" == Int32 (-1)
> parseDatum 'f' "-2.3" == Float (-2.3)
-}
parseDatum :: Char -> String -> Datum
parseDatum :: Char -> [Char] -> Datum
parseDatum Char
typ = forall t. P t -> [Char] -> t
runP (Char -> P Datum
datumP Char
typ)

{- | Run message parser.

> aMessageSeq = [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]]
> map (parseMessage . showMessage (Just 4)) aMessageSeq  == aMessageSeq
-}
parseMessage :: String -> Message
parseMessage :: [Char] -> Message
parseMessage = forall t. P t -> [Char] -> t
runP P Message
messageP

{- | Run bundle parser.

> aBundle = Bundle 1 [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]]
> parseBundle (showBundle (Just 4) aBundle) == aBundle
-}
parseBundle :: String -> Bundle
parseBundle :: [Char] -> Bundle
parseBundle = forall t. P t -> [Char] -> t
runP P Bundle
bundleP

{- | Run packet parser.

> aPacket = Packet_Bundle (Bundle 1 [Message "/c_set" [Int32 1, Float 2.3, Int64 4, Double 5.6], Message "/memset" [string "addr", blob [7, 8]]])
> parsePacket (showPacket (Just 4) aPacket) == aPacket
-}
parsePacket :: String -> Packet
parsePacket :: [Char] -> Packet
parsePacket = forall t. P t -> [Char] -> t
runP P Packet
packetP