-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{- | Support for generating and parsing sysex files from a "spec" file.

    TODO I need to support disjoint subsections, e.g. the different effects
    blocks depending on the value of an enum.
-}
module Instrument.Sysex where
import qualified Control.Monad.Except as Except
import qualified Control.Monad.Writer.Strict as Writer
import qualified Data.Bits as Bits
import           Data.Bits ((.&.), (.|.))
import qualified Data.ByteString as B
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Serialize.Get as Get
import qualified Data.Text as Text
import           Data.Word (Word8)

import qualified Numeric
import qualified System.FilePath as FilePath

import qualified Util.FFI as FFI
import qualified Util.Files as Files
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Strings as Strings

import qualified Instrument.Common as Common
import qualified Instrument.Tag as Tag
import qualified Midi.Encode
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Patch as Patch

import           Global


-- * parse files

type Parser a = ByteString -> Either String a
type Patch = (Patch.Patch, Common.Common ())

-- | For every file below the directory ending with .syx, try all of the
-- given parsers on it.
parse_dir :: [Parser [Patch]] -> FilePath -> IO [Patch]
parse_dir :: [Parser [Patch]] -> [Char] -> IO [Patch]
parse_dir [Parser [Patch]]
parsers [Char]
dir = do
    [[Char]]
fns <- forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
==[Char]
".syx") forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
FilePath.takeExtension) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        ([Char] -> Bool) -> [Char] -> IO [[Char]]
Files.listRecursive (forall a b. a -> b -> a
const Bool
True) [Char]
dir
    [Either [Char] [Patch]]
results <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\[Char]
fn -> [Parser [Patch]] -> [Char] -> Parser [Patch]
parse_file [Parser [Patch]]
parsers [Char]
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
B.readFile [Char]
fn) [[Char]]
fns
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [forall (m :: * -> *). (Stack, LogMonad m) => EnumName -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ EnumName
"parsing " forall a. Semigroup a => a -> a -> a
<> [Char] -> EnumName
txt [Char]
fn forall a. Semigroup a => a -> a -> a
<> EnumName
": " forall a. Semigroup a => a -> a -> a
<> [Char] -> EnumName
txt [Char]
err
        | ([Char]
fn, Left [Char]
err) <- forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
fns [Either [Char] [Patch]]
results]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Patch]
patches | Right [Patch]
patches <- [Either [Char] [Patch]]
results]

parse_file :: [Parser [Patch]] -> FilePath -> ByteString
    -> Either String [Patch]
parse_file :: [Parser [Patch]] -> [Char] -> Parser [Patch]
parse_file [Parser [Patch]]
parsers [Char]
fn ByteString
bytes =
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ByteString -> Patch -> Patch
initialize ByteString
bytes) (forall a. [Char] -> Common a -> Common a
add_file [Char]
fn)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [Parser a] -> Parser a
try_parsers [Parser [Patch]]
parsers ByteString
bytes
    where
    -- Only add the sysex if the parser hasn't already added one.  This is
    -- because some parsers may parse things that aren't actually sysexes.
    initialize :: ByteString -> Patch -> Patch
initialize ByteString
bytes Patch
patch = case Patch :-> InitializePatch
Patch.initialize forall f a. Lens f a -> f -> a
#$ Patch
patch of
        InitializePatch
Patch.NoInitialization -> ByteString -> Patch -> Patch
initialize_sysex ByteString
bytes Patch
patch
        InitializePatch
_ -> Patch
patch

-- | Parse a file just like 'parse_file'.  But this file is expected to be
-- the dump of the patches currently loaded in the synthesizer, and will be
-- given ProgramChange msgs for initialization rather than sysex dumps.
parse_builtins :: Int -> Parser [Patch] -> FilePath -> IO [Patch]
parse_builtins :: Int -> Parser [Patch] -> [Char] -> IO [Patch]
parse_builtins Int
bank Parser [Patch]
parser [Char]
fn = do
    ByteString
bytes <- [Char] -> IO ByteString
B.readFile [Char]
fn
    case Parser [Patch]
parser ByteString
bytes of
        Left [Char]
err -> do
            forall (m :: * -> *). (Stack, LogMonad m) => EnumName -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ EnumName
"parsing " forall a. Semigroup a => a -> a -> a
<> [Char] -> EnumName
txt [Char]
fn forall a. Semigroup a => a -> a -> a
<> EnumName
": " forall a. Semigroup a => a -> a -> a
<> [Char] -> EnumName
txt [Char]
err
            forall (m :: * -> *) a. Monad m => a -> m a
return []
        Right [Patch]
patches ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Word8 -> Patch -> Patch
initialize_program Int
bank) [Word8
0..] [Patch]
patches

-- | Try each parser in turn, and fail only if they all fail.
try_parsers :: [Parser a] -> ByteString -> Either String a
try_parsers :: forall a. [Parser a] -> Parser a
try_parsers [Parser a]
parsers ByteString
bytes = case forall a b. [Either a b] -> [b]
Either.rights [Either [Char] a]
results of
    a
patches : [a]
_ -> forall a b. b -> Either a b
Right a
patches
    [a]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"didn't match any parsers: "
        forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => a -> [a] -> a
Lists.join [Char]
"; " (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
Strings.strip (forall a b. [Either a b] -> [a]
Either.lefts [Either [Char] a]
results))
    where results :: [Either [Char] a]
results = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> a -> b
$ByteString
bytes) [Parser a]
parsers

-- | Assume the sysex midi channel is 0.
initialize_program :: Int -> Midi.Program -> Patch -> Patch
initialize_program :: Int -> Word8 -> Patch -> Patch
initialize_program Int
bank Word8
n = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$
    Patch :-> InitializePatch
Patch.initialize forall f a. Lens f a -> a -> f -> f
#= [ChannelMessage] -> InitializePatch
Patch.initialize_midi (Int -> Word8 -> [ChannelMessage]
Midi.program_change Int
bank Word8
n)

initialize_sysex :: ByteString -> Patch.Patch -> Patch.Patch
initialize_sysex :: ByteString -> Patch -> Patch
initialize_sysex ByteString
bytes =
    Patch :-> InitializePatch
Patch.initialize forall f a. Lens f a -> a -> f -> f
#= [Message] -> InitializePatch
Patch.InitializeMidi [ByteString -> Message
Midi.Encode.decode ByteString
bytes]

add_file :: FilePath -> Common.Common a -> Common.Common a
add_file :: forall a. [Char] -> Common a -> Common a
add_file [Char]
fn = forall {code}. Common code :-> [Tag]
Common.tags forall f a. Lens f a -> (a -> a) -> f -> f
%= ((EnumName
Tag.file, [Char] -> EnumName
txt ([Char] -> [Char]
FilePath.takeFileName [Char]
fn)) :)

-- * record

type RMap = Map Name Record
data Record =
    -- | A List is represented as an RMap with numbered keys.
    RMap RMap
    -- | Which one this is is determined by an RStr elsewhere.
    | RUnion RMap
    | RNum Int | RStr Text
    | RUnparsed ByteString
    deriving (Record -> Record -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Record -> Record -> Bool
$c/= :: Record -> Record -> Bool
== :: Record -> Record -> Bool
$c== :: Record -> Record -> Bool
Eq, Int -> Record -> [Char] -> [Char]
[Record] -> [Char] -> [Char]
Record -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Record] -> [Char] -> [Char]
$cshowList :: [Record] -> [Char] -> [Char]
show :: Record -> [Char]
$cshow :: Record -> [Char]
showsPrec :: Int -> Record -> [Char] -> [Char]
$cshowsPrec :: Int -> Record -> [Char] -> [Char]
Show)
type Error = String
type EnumName = Text

data RecordType = TMap | TUnion | TNum | TStr | TUnparsed
    deriving (RecordType -> RecordType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RecordType -> RecordType -> Bool
$c/= :: RecordType -> RecordType -> Bool
== :: RecordType -> RecordType -> Bool
$c== :: RecordType -> RecordType -> Bool
Eq, Int -> RecordType -> [Char] -> [Char]
[RecordType] -> [Char] -> [Char]
RecordType -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [RecordType] -> [Char] -> [Char]
$cshowList :: [RecordType] -> [Char] -> [Char]
show :: RecordType -> [Char]
$cshow :: RecordType -> [Char]
showsPrec :: Int -> RecordType -> [Char] -> [Char]
$cshowsPrec :: Int -> RecordType -> [Char] -> [Char]
Show)

-- | Create a Record from a Spec, defaulting everything to 0, \"\", or the
-- first enum val.
spec_to_rmap :: Specs -> RMap
spec_to_rmap :: Specs -> RMap
spec_to_rmap = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RMap -> ([Char], Spec) -> RMap
add forall k a. Map k a
Map.empty
    where
    spec_to_record :: Specs -> Record
spec_to_record = RMap -> Record
RMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specs -> RMap
spec_to_rmap
    add :: RMap -> ([Char], Spec) -> RMap
add RMap
rec ([Char]
name, Spec
spec) = case Spec
spec of
        Num (Range {}) -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
name (Int -> Record
RNum Int
0) RMap
rec
        Num (Enum (EnumName
enum:[EnumName]
_)) -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
name (EnumName -> Record
RStr EnumName
enum) RMap
rec
        Num (Enum []) -> forall a. Stack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
" had an empty Enum"

        Bits [([Char], BitField)]
bits -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. RMap -> ([Char], (a, Range)) -> RMap
add_bit RMap
rec [([Char], BitField)]
bits
        Str Int
_ -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
name (EnumName -> Record
RStr EnumName
"") RMap
rec
        SubSpec Specs
specs -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
name (Specs -> Record
spec_to_record Specs
specs) RMap
rec
        List Int
elts Specs
specs -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
name
            (RMap -> Record
RMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
                forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Int
0..Int
eltsforall a. Num a => a -> a -> a
-Int
1]) (forall a. a -> [a]
repeat (Specs -> Record
spec_to_record Specs
specs)))
            RMap
rec
        Union [Char]
_enum_name Int
_bytes ((EnumName
_, Specs
specs) : [(EnumName, Specs)]
_) ->
            forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
name (RMap -> Record
RUnion (Specs -> RMap
spec_to_rmap Specs
specs)) RMap
rec
        Union [Char]
_enum_name Int
_bytes [] ->
            forall a. Stack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
" had an empty Union"
        Unparsed Int
nbytes
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
name -> RMap
rec
            | Bool
otherwise ->
                forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
name (ByteString -> Record
RUnparsed (Int -> Word8 -> ByteString
B.replicate Int
nbytes Word8
0)) RMap
rec
        Constant {} -> RMap
rec

    add_bit :: RMap -> ([Char], (a, Range)) -> RMap
add_bit RMap
rec ([Char]
name, (a
_, Range
range)) = case Range
range of
        Range {} -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
name (Int -> Record
RNum Int
0) RMap
rec
        Enum (EnumName
enum : [EnumName]
_) -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
name (EnumName -> Record
RStr EnumName
enum) RMap
rec
        Enum [] -> forall a. Stack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
" had an empty Enum"

instance Pretty Record where
    format :: Record -> Doc
format Record
rec = case Record
rec of
        RMap RMap
x -> forall a. Pretty a => a -> Doc
Pretty.format RMap
x
        RNum Int
x -> forall a. Pretty a => a -> Doc
Pretty.format Int
x
        RStr EnumName
x -> forall a. Pretty a => a -> Doc
Pretty.format EnumName
x
        RUnion RMap
x -> forall a. Pretty a => a -> Doc
Pretty.format RMap
x
        RUnparsed ByteString
x -> EnumName -> Doc
Pretty.text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> EnumName
showt (ByteString -> Int
B.length ByteString
x) forall a. Semigroup a => a -> a -> a
<> EnumName
" unparsed bytes"

-- | Show an RMap as a flat list of paths and values.
show_flat :: RMap -> [String]
show_flat :: RMap -> [[Char]]
show_flat = [[Char]] -> RMap -> [[Char]]
show_map []
    where
    show_map :: [[Char]] -> RMap -> [[Char]]
show_map [[Char]]
fields = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([[Char]] -> [Char] -> Record -> [[Char]]
show1 [[Char]]
fields)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toAscList
    show1 :: [[Char]] -> [Char] -> Record -> [[Char]]
show1 [[Char]]
fields [Char]
field Record
val = case Record
val of
            RMap RMap
rmap -> [[Char]] -> RMap -> [[Char]]
show_map ([Char]
field forall a. a -> [a] -> [a]
: [[Char]]
fields) RMap
rmap
            RUnion RMap
rmap -> [[Char]] -> RMap -> [[Char]]
show_map ([Char]
field forall a. a -> [a] -> [a]
: [[Char]]
fields) RMap
rmap
            RNum Int
n -> [[Char]
path forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
n]
            RStr EnumName
s -> [[Char]
path forall a. Semigroup a => a -> a -> a
<> EnumName -> [Char]
untxt EnumName
s]
            RUnparsed {} -> []
        where
        path :: [Char]
path = forall a. Monoid a => a -> [a] -> a
Lists.join [Char]
"." (forall a. [a] -> [a]
reverse ([Char]
field forall a. a -> [a] -> [a]
: [[Char]]
fields)) forall a. Semigroup a => a -> a -> a
<> [Char]
": "

class RecordVal a where
    from_val :: a -> Record
    to_val :: Record -> Maybe a

instance RecordVal Int where
    from_val :: Int -> Record
from_val = Int -> Record
RNum
    to_val :: Record -> Maybe Int
to_val (RNum Int
x) = forall a. a -> Maybe a
Just Int
x
    to_val Record
_ = forall a. Maybe a
Nothing

instance RecordVal Word8 where
    from_val :: Word8 -> Record
from_val = Int -> Record
RNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
    to_val :: Record -> Maybe Word8
to_val (RNum Int
x) = forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x)
    to_val Record
_ = forall a. Maybe a
Nothing

instance RecordVal Text where
    from_val :: EnumName -> Record
from_val = EnumName -> Record
RStr
    to_val :: Record -> Maybe EnumName
to_val (RStr EnumName
x) = forall a. a -> Maybe a
Just EnumName
x
    to_val Record
_ = forall a. Maybe a
Nothing

instance RecordVal ByteString where
    from_val :: ByteString -> Record
from_val = ByteString -> Record
RUnparsed
    to_val :: Record -> Maybe ByteString
to_val (RUnparsed ByteString
x) = forall a. a -> Maybe a
Just ByteString
x
    to_val Record
_ = forall a. Maybe a
Nothing

val_type :: (RecordVal a) => a -> RecordType
val_type :: forall a. RecordVal a => a -> RecordType
val_type = Record -> RecordType
record_type forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RecordVal a => a -> Record
from_val

record_type :: Record -> RecordType
record_type :: Record -> RecordType
record_type Record
r = case Record
r of
    RMap {} -> RecordType
TMap
    RUnion {} -> RecordType
TUnion
    RNum {} -> RecordType
TNum
    RStr {} -> RecordType
TStr
    RUnparsed {} -> RecordType
TUnparsed

get_rmap :: forall a. (RecordVal a) => String -> RMap -> Either String a
get_rmap :: forall a. RecordVal a => [Char] -> RMap -> Either [Char] a
get_rmap [Char]
path RMap
rmap = forall {b}.
RecordVal b =>
Either ([[Char]], [Char]) Record -> Either [Char] b
to_val_error forall a b. (a -> b) -> a -> b
$ forall {b}.
IsString b =>
[[Char]] -> RMap -> Either ([[Char]], b) Record
lookup1 (forall a. Eq a => NonNull a -> NonNull a -> NonNull (NonNull a)
Lists.split [Char]
"." [Char]
path) RMap
rmap
    where
    lookup1 :: [[Char]] -> RMap -> Either ([[Char]], b) Record
lookup1 [] RMap
_ = forall a b. a -> Either a b
Left ([], b
"can't lookup empty field")
    lookup1 ([Char]
field : [[Char]]
fields) RMap
rmap = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
field RMap
rmap of
        Maybe Record
Nothing -> forall a b. a -> Either a b
Left ([[Char]
field], b
"not found")
        Just Record
record
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
fields -> forall a b. b -> Either a b
Right Record
record
            | Bool
otherwise -> case Record
record of
                RMap RMap
submap -> case [[Char]] -> RMap -> Either ([[Char]], b) Record
lookup1 [[Char]]
fields RMap
submap of
                    Left ([[Char]]
children, b
msg) -> forall a b. a -> Either a b
Left ([Char]
field forall a. a -> [a] -> [a]
: [[Char]]
children, b
msg)
                    Right Record
val -> forall a b. b -> Either a b
Right Record
val
                RUnion RMap
submap -> [[Char]] -> RMap -> Either ([[Char]], b) Record
lookup1 ([Char]
fieldforall a. a -> [a] -> [a]
:[[Char]]
fields) RMap
submap
                Record
_ -> forall a b. a -> Either a b
Left ([[Char]
field], b
"can't lookup field in non-map")
    to_val_error :: Either ([[Char]], [Char]) Record -> Either [Char] b
to_val_error (Left ([[Char]]
fields, [Char]
msg)) =
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> [a] -> a
Lists.join [Char]
"." [[Char]]
fields forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<> [Char]
msg
    to_val_error (Right Record
v) = case forall a. RecordVal a => Record -> Maybe a
to_val Record
v of
        Maybe b
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
path forall a. Semigroup a => a -> a -> a
<> [Char]
": expected a "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall a. RecordVal a => a -> RecordType
val_type a
rtype) forall a. Semigroup a => a -> a -> a
<> [Char]
" but got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Record
v
        Just b
val -> forall a b. b -> Either a b
Right b
val
    rtype :: a
    rtype :: a
rtype = forall a. Stack => [Char] -> a
error [Char]
"unevaluated"

-- | Put the given val into the rmap at a certain path.  This only modifies
-- existing fields, it won't create new ones, and you can't change the type
-- of a field.
put_rmap :: (Show a, RecordVal a) => String -> a -> RMap -> Either String RMap
put_rmap :: forall a.
(Show a, RecordVal a) =>
[Char] -> a -> RMap -> Either [Char] RMap
put_rmap [Char]
path a
val RMap
rmap = forall {a} {b}.
(Monoid a, IsString a) =>
Either ([a], a) b -> Either a b
format_err forall a b. (a -> b) -> a -> b
$ forall {a}.
(RecordVal a, Show a) =>
[[Char]] -> a -> RMap -> Either ([[Char]], [Char]) RMap
put (forall a. Eq a => NonNull a -> NonNull a -> NonNull (NonNull a)
Lists.split [Char]
"." [Char]
path) a
val RMap
rmap
    where
    put :: [[Char]] -> a -> RMap -> Either ([[Char]], [Char]) RMap
put [] a
_ RMap
_ = forall a b. a -> Either a b
Left ([], [Char]
"can't put empty field")
    put ([Char]
field : [[Char]]
fields) a
val RMap
rmap = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
field RMap
rmap of
        Maybe Record
Nothing -> forall a b. a -> Either a b
Left ([[Char]
field], [Char]
"not found")
        Just Record
record
            | [Char]
next_field : [[Char]]
_ <- [[Char]]
fields -> case Record
record of
                RMap RMap
submap -> case [[Char]] -> a -> RMap -> Either ([[Char]], [Char]) RMap
put [[Char]]
fields a
val RMap
submap of
                    Left ([[Char]]
children, [Char]
msg) -> forall a b. a -> Either a b
Left ([Char]
fieldforall a. a -> [a] -> [a]
:[[Char]]
children, [Char]
msg)
                    Right RMap
submap -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
field (RMap -> Record
RMap RMap
submap) RMap
rmap
                RUnion RMap
submap -> [[Char]] -> a -> RMap -> Either ([[Char]], [Char]) RMap
put ([Char]
fieldforall a. a -> [a] -> [a]
:[[Char]]
fields) a
val RMap
submap
                Record
_ -> forall a b. a -> Either a b
Left ([[Char]
field], [Char]
"can't lookup field " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show [Char]
next_field
                    forall a. Semigroup a => a -> a -> a
<> [Char]
" in non-map")
            | Record -> RecordType
record_type Record
record forall a. Eq a => a -> a -> Bool
/= Record -> RecordType
record_type (forall a. RecordVal a => a -> Record
from_val a
val) ->
                forall a b. a -> Either a b
Left ([[Char]
field], [Char]
"old val " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Record
record
                    forall a. Semigroup a => a -> a -> a
<> [Char]
" is a different type than " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show a
val)
            | Bool
otherwise -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Char]
field (forall a. RecordVal a => a -> Record
from_val a
val) RMap
rmap
    format_err :: Either ([a], a) b -> Either a b
format_err (Left ([a]
fields, a
msg)) =
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => a -> [a] -> a
Lists.join a
"." [a]
fields forall a. Semigroup a => a -> a -> a
<> a
": " forall a. Semigroup a => a -> a -> a
<> a
msg
    format_err (Right b
val) = forall a b. b -> Either a b
Right b
val

-- * util

expect_bytes :: ByteString -> ByteString -> Either String ByteString
expect_bytes :: ByteString -> ByteString -> Either [Char] ByteString
expect_bytes ByteString
bytes ByteString
prefix
    | ByteString
pre forall a. Eq a => a -> a -> Bool
== ByteString
prefix = forall a b. b -> Either a b
Right ByteString
post
    | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"expected " forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
hex ByteString
prefix forall a. Semigroup a => a -> a -> a
<> [Char]
" but got " forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
hex ByteString
pre
    where (ByteString
pre, ByteString
post) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt (ByteString -> Int
B.length ByteString
prefix) ByteString
bytes

hex :: ByteString -> String
hex :: ByteString -> [Char]
hex = [[Char]] -> [Char]
unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Word8
b -> forall a. (Integral a, Show a) => a -> [Char] -> [Char]
Numeric.showHex Word8
b [Char]
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
B.unpack

-- | Extract substrings delimited by sox_byte and eox_byte.  Bytes not within
-- the delimeters are stripped.
extract_sysex :: ByteString -> [ByteString]
extract_sysex :: ByteString -> [ByteString]
extract_sysex ByteString
bytes
    | ByteString -> Bool
B.null ByteString
bytes = []
    | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString
B.singleton Word8
Midi.Encode.eox_byte ByteString -> ByteString -> Bool
`B.isSuffixOf` ByteString
sysex = []
    | ByteString -> Bool
B.null ByteString
sysex = ByteString -> [ByteString]
extract_sysex ByteString
post
    | Bool
otherwise = ByteString
sysex forall a. a -> [a] -> [a]
: ByteString -> [ByteString]
extract_sysex ByteString
post
    where
    (ByteString
sysex, ByteString
post) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
break_after (forall a. Eq a => a -> a -> Bool
==Word8
Midi.Encode.eox_byte) forall a b. (a -> b) -> a -> b
$
        (Word8 -> Bool) -> ByteString -> ByteString
B.dropWhile (forall a. Eq a => a -> a -> Bool
/=Word8
Midi.Encode.sox_byte) ByteString
bytes

break_after :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
break_after :: (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
break_after Word8 -> Bool
f ByteString
bytes = case (Word8 -> Bool) -> ByteString -> Maybe Int
B.findIndex Word8 -> Bool
f ByteString
bytes of
    Maybe Int
Nothing -> (ByteString
bytes, forall a. Monoid a => a
mempty)
    Just Int
i -> Int -> ByteString -> (ByteString, ByteString)
B.splitAt (Int
iforall a. Num a => a -> a -> a
+Int
1) ByteString
bytes

-- * config

data Config = Config {
    Config -> (Int, Int) -> ByteString -> Int
decode_num :: NumRange -> ByteString -> Int
    , Config -> (Int, Int) -> Int -> ByteString
encode_num :: NumRange -> Int -> ByteString
    -- | The number of bytes needd to encode a number in the given range.
    -- This should agree with 'decode_num', since it will be given that many
    -- bytes to decode.
    , Config -> (Int, Int) -> Int
range_bytes :: NumRange -> Int
    }

-- | Encode for 8bit bytes, where numbers are never more than 1 byte.
config_8bit :: Config
config_8bit :: Config
config_8bit = ((Int, Int) -> ByteString -> Int)
-> ((Int, Int) -> Int -> ByteString)
-> ((Int, Int) -> Int)
-> Config
Config (Int, Int) -> ByteString -> Int
decode_8bit_num (Int, Int) -> Int -> ByteString
encode_8bit_num (forall a b. a -> b -> a
const Int
1)
    where
    decode_8bit_num :: NumRange -> ByteString -> Int
    decode_8bit_num :: (Int, Int) -> ByteString -> Int
decode_8bit_num (Int
low, Int
_) ByteString
bytes = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bytes of
        Maybe (Word8, ByteString)
Nothing -> Int
0
        Just (Word8
b, ByteString
_)
            | Int
low forall a. Ord a => a -> a -> Bool
< Int
0 -> forall a. (Integral a, Bits a) => Int -> a -> Int
to_signed Int
8 Word8
b
            | Bool
otherwise -> forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b
    encode_8bit_num :: NumRange -> Int -> ByteString
    encode_8bit_num :: (Int, Int) -> Int -> ByteString
encode_8bit_num (Int
low, Int
_) Int
num
        | Int
low forall a. Ord a => a -> a -> Bool
< Int
0 = Word8 -> ByteString
B.singleton forall a b. (a -> b) -> a -> b
$ Int -> Int -> Word8
from_signed Int
8 Int
num
        | Bool
otherwise = Word8 -> ByteString
B.singleton (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num)

-- * encode

type EncodeM a = Except.ExceptT Error (Writer.Writer Builder.Builder) a

encode :: Config -> Specs -> RMap -> Either Error ByteString
encode :: Config -> Specs -> RMap -> Either [Char] ByteString
encode Config
config Specs
specs RMap
rmap = EncodeM () -> Either [Char] ByteString
run_encode (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Config -> [[Char]] -> RMap -> ([Char], Spec) -> EncodeM ()
encode_spec Config
config [] RMap
rmap) Specs
specs)

run_encode :: EncodeM () -> Either Error ByteString
run_encode :: EncodeM () -> Either [Char] ByteString
run_encode EncodeM ()
m = case forall w a. Writer w a -> (a, w)
Writer.runWriter (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT EncodeM ()
m) of
    (Left [Char]
err, Builder
_) -> forall a b. a -> Either a b
Left [Char]
err
    (Right (), Builder
builder) ->
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Lazy.toStrict forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toLazyByteString Builder
builder

encode_spec :: Config -> [String] -> RMap -> (Name, Spec) -> EncodeM ()
encode_spec :: Config -> [[Char]] -> RMap -> ([Char], Spec) -> EncodeM ()
encode_spec Config
config [[Char]]
path RMap
rmap ([Char]
name, Spec
spec) = case Spec
spec of
    Num Range
range -> do
        Int
num <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Record -> Either [Char] Int
encode_range Range
range
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {m :: * -> *}. MonadError [Char] m => [Char] -> m Record
lookup_field [Char]
name
        forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
Builder.byteString forall a b. (a -> b) -> a -> b
$
            Config -> (Int, Int) -> Int -> ByteString
encode_num Config
config (Range -> (Int, Int)
num_range Range
range) Int
num
    Bits [([Char], BitField)]
bits -> do
        Word8
b <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {m :: * -> *} {a}.
MonadError [Char] m =>
[Char] -> [Char] -> m a
throw_with) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ RMap -> [([Char], BitField)] -> Either ([Char], [Char]) Word8
encode_byte RMap
rmap [([Char], BitField)]
bits
        forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell (Word8 -> Builder
Builder.word8 Word8
b)
    Str Int
chars -> do
        EnumName
str <- forall {m :: * -> *}. MonadError [Char] m => [Char] -> m Record
lookup_field [Char]
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            RStr EnumName
str -> forall (m :: * -> *) a. Monad m => a -> m a
return EnumName
str
            Record
val -> forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"expected RStr, but got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Record
val
        let diff :: Int
diff = Int
chars forall a. Num a => a -> a -> a
- EnumName -> Int
Text.length EnumName
str
        EnumName
padded <- if Int
diff forall a. Ord a => a -> a -> Bool
>= Int
0
            then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ EnumName
str forall a. Semigroup a => a -> a -> a
<> Int -> EnumName -> EnumName
Text.replicate Int
diff EnumName
" "
            else forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"too many characters, expected " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
chars
                forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show EnumName
str
        forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell ([Char] -> Builder
Builder.string7 forall a b. (a -> b) -> a -> b
$ EnumName -> [Char]
untxt EnumName
padded)
    SubSpec Specs
specs -> do
        RMap
sub_record <- forall {m :: * -> *}. MonadError [Char] m => [Char] -> m Record
lookup_field [Char]
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            RMap RMap
rmap -> forall (m :: * -> *) a. Monad m => a -> m a
return RMap
rmap
            Record
rec -> forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"non-RMap child of a SubSpec: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> [Char]
prettys Record
rec
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Config -> [[Char]] -> RMap -> ([Char], Spec) -> EncodeM ()
encode_spec Config
config ([Char]
nameforall a. a -> [a] -> [a]
:[[Char]]
path) RMap
sub_record) Specs
specs
    List Int
elts Specs
specs -> do
        [Record]
records <- forall {m :: * -> *}. MonadError [Char] m => [Char] -> m Record
lookup_field [Char]
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            RMap RMap
rmap
                | forall k a. Map k a -> Int
Map.size RMap
rmap forall a. Eq a => a -> a -> Bool
== Int
elts ->
                    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
k -> forall {m :: * -> *} {a}.
MonadError [Char] m =>
[Char] -> Map [Char] a -> m a
lookup_map (forall a. Show a => a -> [Char]
show Int
k) RMap
rmap) [Int
0..Int
eltsforall a. Num a => a -> a -> a
-Int
1]
                | Bool
otherwise -> forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"expected RMap list of length "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
elts forall a. Semigroup a => a -> a -> a
<> [Char]
" but got length "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall k a. Map k a -> Int
Map.size RMap
rmap)
            Record
val -> forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"expected RMap list, but got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> [Char]
prettys Record
val
        [RMap]
rmaps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Record]
records forall a b. (a -> b) -> a -> b
$ \case
            RMap RMap
rmap -> forall (m :: * -> *) a. Monad m => a -> m a
return RMap
rmap
            Record
rec -> forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"non-RMap child of an RMap list: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> [Char]
prettys Record
rec
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [RMap]
rmaps) forall a b. (a -> b) -> a -> b
$ \(Integer
i, RMap
rmap) ->
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Config -> [[Char]] -> RMap -> ([Char], Spec) -> EncodeM ()
encode_spec Config
config ([Char]
name forall a. a -> [a] -> [a]
: forall a. Show a => a -> [Char]
show Integer
i forall a. a -> [a] -> [a]
: [[Char]]
path) RMap
rmap) Specs
specs
    Union [Char]
enum_name Int
nbytes [(EnumName, Specs)]
enum_specs -> do
        RMap
union_rmap <- forall {m :: * -> *}. MonadError [Char] m => [Char] -> m Record
lookup_field [Char]
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            RUnion RMap
union_rmap -> forall (m :: * -> *) a. Monad m => a -> m a
return RMap
union_rmap
            Record
val -> forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"expected RUnion RMap, but got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> [Char]
prettys Record
val
        EnumName
enum <- forall {m :: * -> *}. MonadError [Char] m => [Char] -> m Record
lookup_field [Char]
enum_name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            RStr EnumName
enum -> forall (m :: * -> *) a. Monad m => a -> m a
return EnumName
enum
            Record
val -> forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"expeted RStr, but got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> [Char]
prettys Record
val
        Specs
specs <- case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup EnumName
enum [(EnumName, Specs)]
enum_specs of
            Just Specs
specs -> forall (m :: * -> *) a. Monad m => a -> m a
return Specs
specs
            Maybe Specs
Nothing -> forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"not found in union "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(EnumName, Specs)]
enum_specs) forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<> EnumName -> [Char]
untxt EnumName
enum
        ByteString
bytes <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight forall a b. (a -> b) -> a -> b
$ EncodeM () -> Either [Char] ByteString
run_encode forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Config -> [[Char]] -> RMap -> ([Char], Spec) -> EncodeM ()
encode_spec Config
config ([Char]
nameforall a. a -> [a] -> [a]
:[[Char]]
path) RMap
union_rmap) Specs
specs
        forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
Builder.byteString forall a b. (a -> b) -> a -> b
$ ByteString
bytes
            forall a. Semigroup a => a -> a -> a
<> Int -> Word8 -> ByteString
B.replicate (Int
nbytes forall a. Num a => a -> a -> a
- ByteString -> Int
B.length ByteString
bytes) Word8
0
    Unparsed Int
nbytes
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
name -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
Builder.byteString forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
B.replicate Int
nbytes Word8
0
        | Bool
otherwise -> do
            ByteString
bytes <- forall {m :: * -> *}. MonadError [Char] m => [Char] -> m Record
lookup_field [Char]
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                RUnparsed ByteString
bytes
                    | ByteString -> Int
B.length ByteString
bytes forall a. Eq a => a -> a -> Bool
/= Int
nbytes -> forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall a b. (a -> b) -> a -> b
$
                        [Char]
"Unparsed expected " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
nbytes
                        forall a. Semigroup a => a -> a -> a
<> [Char]
" bytes but got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (ByteString -> Int
B.length ByteString
bytes)
                    | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bytes
                Record
val -> forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"expected RUnparsed, but got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> [Char]
prettys Record
val
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell (ByteString -> Builder
Builder.byteString ByteString
bytes)
    Constant ByteString
bytes -> forall w (m :: * -> *). MonadWriter w m => w -> m ()
Writer.tell (ByteString -> Builder
Builder.byteString ByteString
bytes)
    where
    lookup_map :: [Char] -> Map [Char] a -> m a
lookup_map [Char]
k Map [Char] a
rmap = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {m :: * -> *} {a}. MonadError [Char] m => [Char] -> m a
throw ([Char]
k forall a. Semigroup a => a -> a -> a
<> [Char]
" not found")) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
k Map [Char] a
rmap
    lookup_field :: [Char] -> m Record
lookup_field [Char]
field = case RMap -> [Char] -> Either [Char] Record
rmap_lookup RMap
rmap [Char]
field of
            Left [Char]
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall a b. (a -> b) -> a -> b
$ [Char]
prefix forall a. Semigroup a => a -> a -> a
<> [Char]
err
            Right Record
val -> forall (m :: * -> *) a. Monad m => a -> m a
return Record
val
        where
        prefix :: [Char]
prefix
            | [Char]
field forall a. Eq a => a -> a -> Bool
== [Char]
name = [[Char]] -> [Char]
show_path ([Char]
name forall a. a -> [a] -> [a]
: [[Char]]
path)
            | Bool
otherwise = [[Char]] -> [Char]
show_path ([Char]
field forall a. a -> [a] -> [a]
: [Char]
name forall a. a -> [a] -> [a]
: [[Char]]
path)
    throw :: [Char] -> m a
throw [Char]
msg = forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
show_path ([Char]
nameforall a. a -> [a] -> [a]
:[[Char]]
path) forall a. Semigroup a => a -> a -> a
<> [Char]
msg
    throw_with :: [Char] -> [Char] -> m a
throw_with [Char]
field [Char]
msg = forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
show_path ([Char]
fieldforall a. a -> [a] -> [a]
:[[Char]]
path) forall a. Semigroup a => a -> a -> a
<> [Char]
msg

encode_byte :: RMap -> [(Name, BitField)] -> Either (Name, Error) Word8
encode_byte :: RMap -> [([Char], BitField)] -> Either ([Char], [Char]) Word8
encode_byte RMap
rmap [([Char], BitField)]
bits = do
    let ([[Char]]
names, [BitField]
fields) = forall a b. [(a, b)] -> ([a], [b])
unzip [([Char], BitField)]
bits
    [Record]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\[Char]
name -> forall {p :: * -> * -> *} {a} {a} {c}.
Bifunctor p =>
a -> p a c -> p (a, a) c
add_name [Char]
name forall a b. (a -> b) -> a -> b
$ RMap -> [Char] -> Either [Char] Record
rmap_lookup RMap
rmap [Char]
name) [[Char]]
names
    [Word8]
bs <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall {a}. (a, BitField) -> Record -> Either (a, [Char]) Word8
encode1 (forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
names [BitField]
fields) [Record]
vals
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Int] -> [Word8] -> Word8
encode_bits (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [BitField]
fields) [Word8]
bs
    where
    add_name :: a -> p a c -> p (a, a) c
add_name a
name = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((,) a
name)
    encode1 :: (a, BitField) -> Record -> Either (a, [Char]) Word8
encode1 (a
name, (Int
width, Range
range)) Record
rec = forall {p :: * -> * -> *} {a} {a} {c}.
Bifunctor p =>
a -> p a c -> p (a, a) c
add_name a
name forall a b. (a -> b) -> a -> b
$ do
        Int
num <- Range -> Record -> Either [Char] Int
encode_range Range
range Record
rec
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Range -> Bool
range_signed Range
range then Int -> Int -> Word8
from_signed Int
width Int
num
            -- encode_range should have already checked the range of 'num'.
            else forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num

encode_range :: Range -> Record -> Either String Int
encode_range :: Range -> Record -> Either [Char] Int
encode_range (Range Int
low Int
high) (RNum Int
num)
    | Int
low forall a. Ord a => a -> a -> Bool
<= Int
num Bool -> Bool -> Bool
&& Int
num forall a. Ord a => a -> a -> Bool
<= Int
high = forall a b. b -> Either a b
Right Int
num
    | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"num out of range " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (Int
low, Int
high) forall a. Semigroup a => a -> a -> a
<> [Char]
": "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
num
encode_range (Enum [EnumName]
enums) (RStr EnumName
enum)
    | Just Int
i <- forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex EnumName
enum [EnumName]
enums = forall a b. b -> Either a b
Right Int
i
    | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"unknown enum: " forall a. Semigroup a => a -> a -> a
<> EnumName -> [Char]
untxt EnumName
enum
encode_range Range
_ Record
record =
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"expected a num or str, but got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Record
record

rmap_lookup :: RMap -> Name -> Either Error Record
rmap_lookup :: RMap -> [Char] -> Either [Char] Record
rmap_lookup RMap
rmap [Char]
name = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
name RMap
rmap of
    Maybe Record
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"not found in: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> [Char]
prettys (forall k a. Map k a -> [k]
Map.keys RMap
rmap)
    Just Record
val -> forall a b. b -> Either a b
Right Record
val

-- * decode

decode :: Config -> Specs -> ByteString -> Either Error (RMap, ByteString)
decode :: Config -> Specs -> ByteString -> Either [Char] (RMap, ByteString)
decode Config
config = [[Char]] -> Specs -> ByteString -> Either [Char] (RMap, ByteString)
decode_from []
    where
    decode_from :: [[Char]] -> Specs -> ByteString -> Either [Char] (RMap, ByteString)
decode_from [[Char]]
path Specs
specs ByteString
bytes = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Char] -> [Char]
Strings.strip forall a b. (a -> b) -> a -> b
$
        forall a.
Get a -> ByteString -> Int -> Either [Char] (a, ByteString)
Get.runGetState ([[Char]] -> [([Char], Record)] -> Specs -> Get RMap
rmap [[Char]]
path [] Specs
specs) ByteString
bytes Int
0
    rmap :: [[Char]] -> [([Char], Record)] -> Specs -> Get RMap
rmap [[Char]]
_ [([Char], Record)]
collect [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [([Char], Record)]
collect)
    rmap [[Char]]
path [([Char], Record)]
collect (([Char], Spec)
spec:Specs
specs) = do
        [([Char], Record)]
vals <- [[Char]]
-> [([Char], Record)] -> ([Char], Spec) -> Get [([Char], Record)]
field [[Char]]
path [([Char], Record)]
collect ([Char], Spec)
spec
        [[Char]] -> [([Char], Record)] -> Specs -> Get RMap
rmap [[Char]]
path ([([Char], Record)]
vals forall a. [a] -> [a] -> [a]
++ [([Char], Record)]
collect) Specs
specs

    field :: [Name] -> [(Name, Record)] -> (Name, Spec)
        -> Get.Get [(String, Record)]
    field :: [[Char]]
-> [([Char], Record)] -> ([Char], Spec) -> Get [([Char], Record)]
field [[Char]]
path [([Char], Record)]
prev_record ([Char]
name, Spec
spec) = case Spec
spec of
        Bits [([Char], BitField)]
bits ->
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]]
-> [([Char], BitField)]
-> Word8
-> Either [Char] [([Char], Record)]
decode_byte [[Char]]
path [([Char], BitField)]
bits forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Word8
Get.getWord8
        Num Range
range -> do
            ByteString
bytes <- Int -> Get ByteString
Get.getBytes forall a b. (a -> b) -> a -> b
$ Config -> (Int, Int) -> Int
range_bytes Config
config (Range -> (Int, Int)
num_range Range
range)
            let num :: Int
num = Config -> (Int, Int) -> ByteString -> Int
decode_num Config
config (Range -> (Int, Int)
num_range Range
range) ByteString
bytes
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {a}. [Char] -> Get a
throw (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) [Char]
name) forall a b. (a -> b) -> a -> b
$ Int -> Range -> Either [Char] Record
decode_range Int
num Range
range
        Str Int
chars -> do
            ByteString
str <- Int -> Get ByteString
Get.getByteString Int
chars
            forall (m :: * -> *) a. Monad m => a -> m a
return [([Char]
name, EnumName -> Record
RStr forall a b. (a -> b) -> a -> b
$ EnumName -> EnumName
Text.strip forall a b. (a -> b) -> a -> b
$ ByteString -> EnumName
FFI.decodeUtf8 ByteString
str)]
        SubSpec Specs
specs -> do
            RMap
subs <- [[Char]] -> [([Char], Record)] -> Specs -> Get RMap
rmap ([Char]
name forall a. a -> [a] -> [a]
: [[Char]]
path) [] Specs
specs
            forall (m :: * -> *) a. Monad m => a -> m a
return [([Char]
name, RMap -> Record
RMap RMap
subs)]
        List Int
elts Specs
specs -> do
            [Record]
subs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. Int
eltsforall a. Num a => a -> a -> a
-Int
1] forall a b. (a -> b) -> a -> b
$ \Int
i ->
                RMap -> Record
RMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]] -> [([Char], Record)] -> Specs -> Get RMap
rmap (forall a. Show a => a -> [Char]
show Int
i forall a. a -> [a] -> [a]
: [Char]
name forall a. a -> [a] -> [a]
: [[Char]]
path) [] Specs
specs
            forall (m :: * -> *) a. Monad m => a -> m a
return [([Char]
name, RMap -> Record
RMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$
                forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Int
0..Int
eltsforall a. Num a => a -> a -> a
-Int
1]) [Record]
subs)]
        Union [Char]
enum_name Int
bytes [(EnumName, Specs)]
enum_specs -> do
            [[Char]]
path <- forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
name forall a. a -> [a] -> [a]
: [[Char]]
path)
            EnumName
enum <- case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
enum_name [([Char], Record)]
prev_record of
                Just (RStr EnumName
enum) -> forall (m :: * -> *) a. Monad m => a -> m a
return EnumName
enum
                Maybe Record
_ -> forall {a}. [Char] -> Get a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"previous enum not found: " forall a. Semigroup a => a -> a -> a
<> [Char]
enum_name
            Specs
specs <- case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup EnumName
enum [(EnumName, Specs)]
enum_specs of
                Just Specs
specs -> forall (m :: * -> *) a. Monad m => a -> m a
return Specs
specs
                Maybe Specs
Nothing -> forall {a}. [Char] -> Get a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"union doesn't contain enum: " forall a. Semigroup a => a -> a -> a
<> EnumName -> [Char]
untxt EnumName
enum
            ByteString
bytes <- Int -> Get ByteString
Get.getByteString Int
bytes
            RMap
record <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ [[Char]] -> Specs -> ByteString -> Either [Char] (RMap, ByteString)
decode_from [[Char]]
path Specs
specs ByteString
bytes
            forall (m :: * -> *) a. Monad m => a -> m a
return [([Char]
name, RMap -> Record
RUnion RMap
record)]
        Unparsed Int
nbytes
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
name -> Int -> Get ()
Get.skip Int
nbytes forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
            | Bool
otherwise -> do
                ByteString
bytes <- Int -> Get ByteString
Get.getByteString Int
nbytes
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
bytes forall a. Ord a => a -> a -> Bool
< Int
nbytes) forall a b. (a -> b) -> a -> b
$
                    forall {a}. [Char] -> Get a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"expected " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
nbytes forall a. Semigroup a => a -> a -> a
<> [Char]
" bytes, but got "
                        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (ByteString -> Int
B.length ByteString
bytes)
                forall (m :: * -> *) a. Monad m => a -> m a
return [([Char]
name, ByteString -> Record
RUnparsed ByteString
bytes)]
        Constant ByteString
expected -> do
            ByteString
bytes <- Int -> Get ByteString
Get.getByteString (ByteString -> Int
B.length ByteString
expected)
            if ByteString
bytes forall a. Eq a => a -> a -> Bool
== ByteString
expected then forall (m :: * -> *) a. Monad m => a -> m a
return []
                else forall {a}. [Char] -> Get a
throw forall a b. (a -> b) -> a -> b
$ [Char]
"expected " forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
hex ByteString
expected forall a. Semigroup a => a -> a -> a
<> [Char]
" but got "
                    forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
hex ByteString
bytes
        where
        throw :: [Char] -> Get a
throw = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[Char]] -> [Char]
show_path ([Char]
nameforall a. a -> [a] -> [a]
:[[Char]]
path) <>)

decode_range :: Int -> Range -> Either String Record
decode_range :: Int -> Range -> Either [Char] Record
decode_range Int
num (Range Int
low Int
high)
    | Int
low forall a. Ord a => a -> a -> Bool
<= Int
num Bool -> Bool -> Bool
&& Int
num forall a. Ord a => a -> a -> Bool
<= Int
high = forall a b. b -> Either a b
Right (Int -> Record
RNum Int
num)
    | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"out of range " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (Int
low, Int
high) forall a. Semigroup a => a -> a -> a
<> [Char]
": "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
num
decode_range Int
num (Enum [EnumName]
enums)
    | Just EnumName
enum <- forall a. [a] -> Int -> Maybe a
Lists.at [EnumName]
enums Int
num = forall a b. b -> Either a b
Right (EnumName -> Record
RStr EnumName
enum)
    | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Char]
"out of range for enum: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
num

decode_byte :: [Name] -> [(Name, BitField)] -> Word8
    -> Either String [(String, Record)]
decode_byte :: [[Char]]
-> [([Char], BitField)]
-> Word8
-> Either [Char] [([Char], Record)]
decode_byte [[Char]]
path [([Char], BitField)]
bits Word8
byte =
    -- Null names are reserved bytes.
    forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall {a}.
([Char], (a, Range)) -> Int -> Either [Char] ([Char], Record)
extract [([Char], BitField)]
bits [Int]
signed
    where
    vals :: [Word8]
vals = [Int] -> Word8 -> [Word8]
decode_bits [Int
width | ([Char]
_, (Int
width, Range
_)) <- [([Char], BitField)]
bits] Word8
byte
    signed :: [Int]
signed = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith BitField -> Word8 -> Int
convert_signs (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [([Char], BitField)]
bits) [Word8]
vals
    extract :: ([Char], (a, Range)) -> Int -> Either [Char] ([Char], Record)
extract ([Char]
name, (a
_, Range
field)) Int
val = case Range
field of
        Range Int
low Int
high
            | Int
low forall a. Ord a => a -> a -> Bool
<= Int
val Bool -> Bool -> Bool
&& Int
val forall a. Ord a => a -> a -> Bool
<= Int
high -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
name, Int -> Record
RNum Int
val)
            | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                [[Char]] -> [Char]
show_path ([Char]
nameforall a. a -> [a] -> [a]
:[[Char]]
path) forall a. Semigroup a => a -> a -> a
<> [Char]
"out of range: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
val
        Enum [EnumName]
enums
            | Just EnumName
enum <- forall a. [a] -> Int -> Maybe a
Lists.at [EnumName]
enums Int
val -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
name, EnumName -> Record
RStr EnumName
enum)
            | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                [[Char]] -> [Char]
show_path ([Char]
nameforall a. a -> [a] -> [a]
:[[Char]]
path) forall a. Semigroup a => a -> a -> a
<> [Char]
"bit of byte " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Word8
byte
                    forall a. Semigroup a => a -> a -> a
<> [Char]
": not a valid enum index: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
val
    convert_signs :: BitField -> Word8 -> Int
    convert_signs :: BitField -> Word8 -> Int
convert_signs (Int
width, Range
range) Word8
val
        | Range -> Bool
range_signed Range
range = forall a. (Integral a, Bits a) => Int -> a -> Int
to_signed Int
width Word8
val
        | Bool
otherwise = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
val

show_path :: [Name] -> String
show_path :: [[Char]] -> [Char]
show_path = (forall a. Semigroup a => a -> a -> a
<>[Char]
": ") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> [a] -> a
Lists.join [Char]
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

-- ** bit fiddling

encode_bits :: [Int] -> [Word8] -> Word8
encode_bits :: [Int] -> [Word8] -> Word8
encode_bits [Int]
widths [Word8]
vals = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Bits a => a -> a -> a
(.|.) Word8
0 forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Bits a => a -> Int -> a
Bits.shiftL [Word8]
vals [Int]
offsets
    where offsets :: [Int]
offsets = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) Int
0 [Int]
widths

decode_bits :: [Int] -> Word8 -> [Word8]
decode_bits :: [Int] -> Word8 -> [Word8]
decode_bits [Int]
widths Word8
byte = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Word8
extract [Int]
bs (forall a. Int -> [a] -> [a]
drop Int
1 [Int]
bs)
    where
    bs :: [Int]
bs = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) Int
0 [Int]
widths
    extract :: Int -> Int -> Word8
extract Int
start Int
end = forall a. Bits a => a -> Int -> a
Bits.shiftR (forall {b}. (Bits b, Num b) => Int -> Int -> b
set Int
start Int
end forall a. Bits a => a -> a -> a
.&. Word8
byte) Int
start
    set :: Int -> Int -> b
set Int
start Int
end = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Bits a => a -> Int -> a
Bits.setBit b
0 [Int
start .. Int
endforall a. Num a => a -> a -> a
-Int
1]

-- | Convert an n bit 2s complement word to a signed integer.
to_signed :: (Integral a, Bits.Bits a) => Int -> a -> Int
to_signed :: forall a. (Integral a, Bits a) => Int -> a -> Int
to_signed Int
bits a
b
    | forall a. Bits a => a -> Int -> Bool
Bits.testBit a
b (Int
bitsforall a. Num a => a -> a -> a
-Int
1) = forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$
        forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ (forall a. Bits a => a -> a
Bits.complement a
b forall a. Bits a => a -> a -> a
.&. (a
2forall a b. (Num a, Integral b) => a -> b -> a
^Int
bits forall a. Num a => a -> a -> a
- a
1)) forall a. Num a => a -> a -> a
+ a
1
    | Bool
otherwise = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b

-- | Convert a signed integer to an n bit 2s complement word.
from_signed :: Int -> Int -> Word8
from_signed :: Int -> Int -> Word8
from_signed Int
bits Int
num
    | Int
clamped forall a. Ord a => a -> a -> Bool
< Int
0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
2forall a b. (Num a, Integral b) => a -> b -> a
^Int
bits forall a. Num a => a -> a -> a
+ Int
clamped)
    | Bool
otherwise = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
clamped
    where clamped :: Int
clamped = forall a. Ord a => a -> a -> a -> a
Num.clamp (-Int
2forall a b. (Num a, Integral b) => a -> b -> a
^(Int
bitsforall a. Num a => a -> a -> a
-Int
1)) (Int
2forall a b. (Num a, Integral b) => a -> b -> a
^(Int
bitsforall a. Num a => a -> a -> a
-Int
1) forall a. Num a => a -> a -> a
- Int
1) Int
num


-- * spec

type Specs = [(Name, Spec)]
data Spec =
    -- | A set of bitfields encoded in a single byte.  The BitField widths must
    -- add up to 8.  They start at the least significant end of the byte, so
    -- given @[(\"a\", (1, Range 0 1)), (\"b\", (7, Range 0 1))]@, @a@ is from
    -- the least significant bit.
    Bits [(Name, BitField)]
    | Num Range | Str Bytes | SubSpec Specs
    | List Int Specs
    -- | The content of this section depends on a previous enum value.
    -- The Name is the name of the enum to reference
    | Union Name Bytes [(EnumName, Specs)]
    -- | A chunk of unparsed bytes.  If the name is \"\", then its considered
    -- unused padding.  On input it will be ignored, and on output will become
    -- zeros.
    | Unparsed Bytes
    -- | Assert that these bytes are set literally.  This is useful for
    -- failing quickly when the required header isn't found.
    | Constant ByteString
    deriving (Int -> Spec -> [Char] -> [Char]
[Spec] -> [Char] -> [Char]
Spec -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Spec] -> [Char] -> [Char]
$cshowList :: [Spec] -> [Char] -> [Char]
show :: Spec -> [Char]
$cshow :: Spec -> [Char]
showsPrec :: Int -> Spec -> [Char] -> [Char]
$cshowsPrec :: Int -> Spec -> [Char] -> [Char]
Show)

data Range = Range Int Int | Enum [EnumName]
    deriving (Int -> Range -> [Char] -> [Char]
[Range] -> [Char] -> [Char]
Range -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [Range] -> [Char] -> [Char]
$cshowList :: [Range] -> [Char] -> [Char]
show :: Range -> [Char]
$cshow :: Range -> [Char]
showsPrec :: Int -> Range -> [Char] -> [Char]
$cshowsPrec :: Int -> Range -> [Char] -> [Char]
Show)
type NumRange = (Int, Int)

num_range :: Range -> NumRange
num_range :: Range -> (Int, Int)
num_range (Range Int
low Int
high) = (Int
low, Int
high)
num_range (Enum [EnumName]
enums) = (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length [EnumName]
enums forall a. Num a => a -> a -> a
- Int
1)

range_signed :: Range -> Bool
range_signed :: Range -> Bool
range_signed (Range Int
low Int
_) = Int
low forall a. Ord a => a -> a -> Bool
< Int
0
range_signed Range
_ = Bool
False

type BitField = (Bits, Range)
type Name = String
type Bits = Int
type Bytes = Int

spec_bytes :: Config -> Specs -> Int
spec_bytes :: Config -> Specs -> Int
spec_bytes Config
config = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Spec -> Int
bytes_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
    where
    bytes_of :: Spec -> Int
bytes_of (Bits {}) = Int
1
    bytes_of (Num Range
range) = Config -> (Int, Int) -> Int
range_bytes Config
config (Range -> (Int, Int)
num_range Range
range)
    bytes_of (Str Int
n) = Int
n
    bytes_of (SubSpec Specs
specs) = Config -> Specs -> Int
spec_bytes Config
config Specs
specs
    bytes_of (List Int
n Specs
specs) = Config -> Specs -> Int
spec_bytes Config
config Specs
specs forall a. Num a => a -> a -> a
* Int
n
    bytes_of (Union [Char]
_ Int
n [(EnumName, Specs)]
_) = Int
n
    bytes_of (Unparsed Int
n) = Int
n
    bytes_of (Constant ByteString
bytes) = ByteString -> Int
B.length ByteString
bytes

validate :: Specs -> Maybe String
validate :: Specs -> Maybe [Char]
validate Specs
specs = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a b. (a -> b) -> [a] -> [b]
map ([Char], Spec) -> Maybe [Char]
check Specs
specs)
    where
    -- TODO assert each name is unique
    -- names can't have dots
    check :: ([Char], Spec) -> Maybe [Char]
check ([Char]
_, Bits [([Char], BitField)]
bits)
        | Int
total forall a. Eq a => a -> a -> Bool
/= Int
8 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            forall a. Show a => a -> [Char]
show (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([Char], BitField)]
bits) forall a. Semigroup a => a -> a -> a
<> [Char]
" - bits should sum to 8: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
total
        | Bool
otherwise = forall a. Maybe a
Nothing
        where total :: Int
total = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [Int
n | ([Char]
_, (Int
n, Range
_)) <- [([Char], BitField)]
bits]
    check ([Char]
name, Union [Char]
enum_name Int
_bytes [(EnumName, Specs)]
fields) = case [Char] -> Maybe (Either BitField Spec)
lookup_spec [Char]
enum_name of
        Just (Left (Int
_, Enum [EnumName]
enums))
            | forall a. Ord a => [a] -> [a]
List.sort [EnumName]
enums forall a. Eq a => a -> a -> Bool
/= forall a. Ord a => [a] -> [a]
List.sort (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(EnumName, Specs)]
fields) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                [Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
": enums not equal: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show ([EnumName]
enums, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(EnumName, Specs)]
fields)
            -- TODO fields sum up to < bytes
            -- check recursively on specs
        Maybe (Either BitField Spec)
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
": enum not found"
    check ([Char], Spec)
_ = forall a. Maybe a
Nothing
    lookup_spec :: [Char] -> Maybe (Either BitField Spec)
lookup_spec [Char]
wanted = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a b. (a -> b) -> [a] -> [b]
map ([Char], Spec) -> Maybe (Either BitField Spec)
find Specs
specs)
        where
        find :: ([Char], Spec) -> Maybe (Either BitField Spec)
find ([Char]
name, Spec
spec)
            | Bits [([Char], BitField)]
bits <- Spec
spec = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b}. ([Char], a) -> Maybe (Either a b)
find_bit [([Char], BitField)]
bits)
            | [Char]
name forall a. Eq a => a -> a -> Bool
== [Char]
wanted = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Spec
spec
            | Bool
otherwise = forall a. Maybe a
Nothing
        find_bit :: ([Char], a) -> Maybe (Either a b)
find_bit ([Char]
name, a
field)
            | [Char]
name forall a. Eq a => a -> a -> Bool
== [Char]
wanted = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left a
field
            | Bool
otherwise = forall a. Maybe a
Nothing

-- | Hokey runtime check to make sure the Specs is valid and has the expected
-- size.
assert_valid :: Config -> String -> Int -> Specs -> Specs
assert_valid :: Config -> [Char] -> Int -> Specs -> Specs
assert_valid Config
config [Char]
name Int
size Specs
specs
    | Just [Char]
err <- Specs -> Maybe [Char]
validate Specs
specs = forall {a}. [Char] -> a
crash [Char]
err
    | Int
actual_size forall a. Eq a => a -> a -> Bool
/= Int
size = forall {a}. [Char] -> a
crash forall a b. (a -> b) -> a -> b
$ [Char]
"expected " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
size
        forall a. Semigroup a => a -> a -> a
<> [Char]
" bytes, but was " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
actual_size
    | Bool
otherwise = Specs
specs
    where
    actual_size :: Int
actual_size = Config -> Specs -> Int
spec_bytes Config
config Specs
specs
    crash :: [Char] -> a
crash [Char]
msg = forall a. Stack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
": " forall a. Semigroup a => a -> a -> a
<> [Char]
msg

-- * convenience

-- ** num

unsigned :: Int -> Spec
unsigned :: Int -> Spec
unsigned Int
max = Range -> Spec
Num (Int -> Int -> Range
Range Int
0 Int
max)

ranged :: Int -> Int -> Spec
ranged :: Int -> Int -> Spec
ranged Int
low Int
high = Range -> Spec
Num (Int -> Int -> Range
Range Int
low Int
high)

signed :: Int -> Spec
signed :: Int -> Spec
signed Int
high = Int -> Int -> Spec
ranged (-Int
high) Int
high

enum :: [EnumName] -> Spec
enum :: [EnumName] -> Spec
enum [EnumName]
enums = Range -> Spec
Num ([EnumName] -> Range
Enum [EnumName]
enums)

bool :: Spec
bool :: Spec
bool = [EnumName] -> Spec
enum [EnumName
"off", EnumName
"on"]

-- ** bits

bits :: Int -> BitField
bits :: Int -> BitField
bits Int
n = (Int
n, Int -> Int -> Range
Range Int
0 (Int
2forall a b. (Num a, Integral b) => a -> b -> a
^Int
n))

ranged_bits :: Int -> (Int, Int) -> BitField
ranged_bits :: Int -> (Int, Int) -> BitField
ranged_bits Int
n (Int
low, Int
high) = (Int
n, Int -> Int -> Range
Range Int
low Int
high)

enum_bits :: Int -> [EnumName] -> BitField
enum_bits :: Int -> [EnumName] -> BitField
enum_bits Int
n [EnumName]
vals = (Int
n, [EnumName] -> Range
Enum [EnumName]
vals)

bool_bit :: BitField
bool_bit :: BitField
bool_bit = (Int
1, [EnumName] -> Range
Enum [EnumName
"off", EnumName
"on"])

unparsed_bits :: Int -> (String, BitField)
unparsed_bits :: Int -> ([Char], BitField)
unparsed_bits Int
n = ([Char]
"", Int -> BitField
bits Int
n)