-- Copyright 2020 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 loading mods in sexpr format, as written by mod_to_sexpr.c.
module Cmd.Load.ModSexpr (load) where
import qualified Data.Bits as Bits
import           Data.Bits ((.&.))
import qualified Data.Char as Char
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO

import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P

import qualified Util.Parse as Parse
import qualified Cmd.Load.ModT as ModT
import qualified Derive.ScoreT as ScoreT
import qualified Perform.Pitch as Pitch

import           Global


type Error = Text

load :: FilePath -> IO (Either Error ModT.Module)
load :: FilePath -> IO (Either Text Module)
load FilePath
fname = (Val -> Either Text Module
to_module forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> Either Text Val
parse) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
Text.IO.readFile FilePath
fname

to_module :: Val -> Either Error ModT.Module
to_module :: Val -> Either Text Module
to_module Val
val = do
    Map Text [Val]
mod <- Val -> Either Text (Map Text [Val])
to_map Val
val
    Map Text [Val]
meta <- Val -> Either Text (Map Text [Val])
to_map forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Val] -> Val
VList forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Text -> Map Text a -> Either Text a
get Text
"metadata" Map Text [Val]
mod
    Int
bpm <- Val -> Either Text Int
num forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Val] -> Either Text Val
one forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Text -> Map Text a -> Either Text a
get Text
"bpm" Map Text [Val]
meta
    Int
spd <- Val -> Either Text Int
num forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Val] -> Either Text Val
one forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Text -> Map Text a -> Either Text a
get Text
"spd" Map Text [Val]
meta

    [Val]
insts <- forall a. Text -> Map Text a -> Either Text a
get Text
"instruments" Map Text [Val]
mod
    [(Int, Instrument)]
insts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Val]
insts forall a b. (a -> b) -> a -> b
$ \case
        VList [VNum Int
n, VString Text
inst] -> forall a b. b -> Either a b
Right (Int
n, Text -> Instrument
mkinst Text
inst)
        Val
_ -> forall a b. a -> Either a b
Left Text
"expected (num inst) pair"

    [Val]
order <- forall a. Text -> Map Text a -> Either Text a
get Text
"order" Map Text [Val]
mod
    [Int]
order <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Val -> Either Text Int
num forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Text -> Val
VString Text
"+") forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Text -> Val
VString Text
"-") [Val]
order

    [Val]
patterns <- forall a. Text -> Map Text a -> Either Text a
get Text
"patterns" Map Text [Val]
mod
    [Block]
blocks <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Val]
patterns forall a b. (a -> b) -> a -> b
$ \Val
pattern -> do
        [Val]
tracks <- Val -> Either Text [Val]
list Val
pattern
        ([Int]
lens, [Track]
tracks) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Val] -> Either Text (Int, Track)
get_track forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Val -> Either Text [Val]
list) [Val]
tracks
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> [Track] -> Block
ModT.Block (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
0forall a. a -> [a] -> [a]
:[Int]
lens)) [Track]
tracks
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModT.Module
        { _instruments :: IntMap Instrument
_instruments = forall a. [(Int, a)] -> IntMap a
IntMap.fromList [(Int, Instrument)]
insts
        , _default_tempo :: Tempo
_default_tempo = Int -> Int -> Tempo
ModT.Tempo Int
bpm Int
spd
        , _block_order :: Map Text [Int]
_block_order = forall k a. k -> a -> Map k a
Map.singleton Text
"score" [Int]
order
        , _blocks :: [Block]
_blocks = [Block]
blocks
        }

    where
    mkinst :: Text -> Instrument
mkinst Text
n = Instrument -> Maybe Double -> Instrument
ModT.Instrument (Text -> Instrument
ScoreT.Instrument (Text -> Text
Text.strip Text
n)) forall a. Maybe a
Nothing

get_track :: [Val] -> Either Error (Int, ModT.Track)
get_track :: [Val] -> Either Text (Int, Track)
get_track (VSymbol Text
"track" : VNum Int
rows : [Val]
notes) = do
    [(Int, Line)]
lines <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Val] -> Either Text (Int, Line)
to_line forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Val -> Either Text [Val]
list) [Val]
notes
    forall (m :: * -> *) a. Monad m => a -> m a
return (Int
rows, [(Int, Line)] -> Track
ModT.make_track [(Int, Line)]
lines)
get_track [Val]
vals = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected track, got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a b. (a -> b) -> [a] -> [b]
map Val -> Text
val_type [Val]
vals)

-- (row pitch inst vol (fx1 fx1param) (fx2 fx2param))
to_line :: [Val] -> Either Error (Int, ModT.Line)
to_line :: [Val] -> Either Text (Int, Line)
to_line [Val
idx, Val
pitch, Val
inst, Val
vol, Val
fx1, Val
fx2] = do
    Int
idx <- Val -> Either Text Int
num Val
idx
    Int
pitch <- Val -> Either Text Int
num Val
pitch
    Int
inst <- Val -> Either Text Int
num Val
inst
    Int
vol <- Val -> Either Text Int
num Val
vol
    [Command]
fxs <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM Val -> Either Text (Maybe Command)
to_cmd [Val
fx1, Val
fx2]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Int
idx,) forall a b. (a -> b) -> a -> b
$ ModT.Line
        { _pitch :: Maybe NoteNumber
_pitch = if Int
0 forall a. Ord a => a -> a -> Bool
< Int
pitch Bool -> Bool -> Bool
&& Int
pitch forall a. Ord a => a -> a -> Bool
< Int
128
            -- c4 in schism tracker shows up as 49, instead of 60.
            then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> NoteNumber
Pitch.nn forall a b. (a -> b) -> a -> b
$ Int
pitch forall a. Num a => a -> a -> a
+ Int
11
            else forall a. Maybe a
Nothing
        , _instrument :: Int
_instrument = Int
inst
        , _commands :: [Command]
_commands = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ [Double -> Command
ModT.Volume forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
vol forall a. Num a => a -> a -> a
- Int
1) forall a. Fractional a => a -> a -> a
/ Double
64 | Int
vol forall a. Ord a => a -> a -> Bool
> Int
0]
            , [Command]
fxs
            -- In IT 130 is ^^^, which is CutNote.
            , [Command
ModT.CutNote | Int
pitch forall a. Eq a => a -> a -> Bool
== Int
130]
            ]
        }
to_line [Val]
val = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected note, got " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a b. (a -> b) -> [a] -> [b]
map Val -> Text
val_type [Val]
val)

to_cmd :: Val -> Either Error (Maybe ModT.Command)
to_cmd :: Val -> Either Text (Maybe Command)
to_cmd (VList [VString Text
fx, VNum Int
arg])
    | Text
fx forall a. Eq a => a -> a -> Bool
== Text
"" = forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
    | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Text -> Int -> Command
fx_to_cmd Text
fx Int
arg)
to_cmd Val
val = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected fx, got " forall a. Semigroup a => a -> a -> a
<> Val -> Text
val_type Val
val

fx_to_cmd :: Text -> Int -> ModT.Command
fx_to_cmd :: Text -> Int -> Command
fx_to_cmd Text
fx Int
arg = case Text
fx of
    Text
"volslide" -> case Int -> (Int, Int)
split4 Int
arg of
        (Int
0xf, Int
n) -> Double -> Command
ModT.VolumeSlide forall a b. (a -> b) -> a -> b
$ - forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n forall a. Fractional a => a -> a -> a
/ Double
10
        (Int
n, Int
0xf) -> Double -> Command
ModT.VolumeSlide forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n forall a. Fractional a => a -> a -> a
/ Double
10
        (Int
0, Int
n) -> Double -> Command
ModT.VolumeSlide forall a b. (a -> b) -> a -> b
$ - forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
        (Int
n, Int
0) -> Double -> Command
ModT.VolumeSlide forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
        (Int, Int)
_ -> Command
unknown
    Text
"it_break" -> Command
ModT.CutBlock
    Text
_ -> Command
unknown
    where
    unknown :: Command
unknown = Text -> Word8 -> Command
ModT.Command Text
fx (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
arg)

split4 :: Int -> (Int, Int)
split4 :: Int -> (Int, Int)
split4 Int
word = (forall a. Bits a => a -> Int -> a
Bits.shiftR Int
word Int
4 forall a. Bits a => a -> a -> a
.&. Int
0xf, Int
word forall a. Bits a => a -> a -> a
.&. Int
0xf)

to_map :: Val -> Either Error (Map Text [Val])
to_map :: Val -> Either Text (Map Text [Val])
to_map Val
xs = do
    [Val]
xs <- Val -> Either Text [Val]
list Val
xs
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Val]
xs forall a b. (a -> b) -> a -> b
$ \case
        VList (VSymbol Text
sym : [Val]
rest) -> forall a b. b -> Either a b
Right (Text
sym, [Val]
rest)
        Val
val -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"key, got " forall a. Semigroup a => a -> a -> a
<> Val -> Text
val_type Val
val

get :: Text -> Map Text a -> Either Error a
get :: forall a. Text -> Map Text a -> Either Text a
get Text
k = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"no key: " forall a. Semigroup a => a -> a -> a
<> Text
k) forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
k

one :: [Val] -> Either Error Val
one :: [Val] -> Either Text Val
one [Val
x] = forall a b. b -> Either a b
Right Val
x
one [Val]
xs = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected one val, got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Val]
xs)

list :: Val -> Either Error [Val]
list :: Val -> Either Text [Val]
list = forall a. Text -> (Val -> Maybe a) -> Val -> Either Text a
expect Text
"list" forall a b. (a -> b) -> a -> b
$ \case
    VList [Val]
a -> forall a. a -> Maybe a
Just [Val]
a
    Val
_ -> forall a. Maybe a
Nothing

num :: Val -> Either Error Int
num :: Val -> Either Text Int
num = forall a. Text -> (Val -> Maybe a) -> Val -> Either Text a
expect Text
"num" forall a b. (a -> b) -> a -> b
$ \case
    VNum Int
a -> forall a. a -> Maybe a
Just Int
a
    Val
_ -> forall a. Maybe a
Nothing

expect :: Text -> (Val -> Maybe a) -> Val -> Either Error a
expect :: forall a. Text -> (Val -> Maybe a) -> Val -> Either Text a
expect Text
name Val -> Maybe a
get Val
val =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"expected " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
", got " forall a. Semigroup a => a -> a -> a
<> Val -> Text
val_type Val
val) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
        Val -> Maybe a
get Val
val

-- * parse

data Val = VList [Val] | VSymbol !Text | VString !Text | VNum !Int
    deriving (Val -> Val -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Val -> Val -> Bool
$c/= :: Val -> Val -> Bool
== :: Val -> Val -> Bool
$c== :: Val -> Val -> Bool
Eq, Int -> Val -> ShowS
[Val] -> ShowS
Val -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Val] -> ShowS
$cshowList :: [Val] -> ShowS
show :: Val -> FilePath
$cshow :: Val -> FilePath
showsPrec :: Int -> Val -> ShowS
$cshowsPrec :: Int -> Val -> ShowS
Show)

val_type :: Val -> Text
val_type :: Val -> Text
val_type = \case
    VList {} -> Text
"list"
    VSymbol {} -> Text
"symbol"
    VString {} -> Text
"string"
    VNum {} -> Text
"num"

type Parser a = Parse.Parser a

parse :: Text -> Either Error Val
parse :: Text -> Either Text Val
parse = forall a. Parser a -> Text -> Either Text a
Parse.parse Parser Val
p_val

p_val :: Parser Val
p_val :: Parser Val
p_val = forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ Parser Val
p_list forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Val
p_num forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Val
p_string forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Val
p_symbol

p_list :: Parser Val
p_list :: Parser Val
p_list = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Val] -> Val
VList forall a b. (a -> b) -> a -> b
$
    forall a. Parser a -> Parser a
lexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'(') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.many Parser Val
p_val forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall a. Parser a -> Parser a
lexeme (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
')')

p_symbol :: Parser Val
p_symbol :: Parser Val
p_symbol = Text -> Val
VSymbol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P forall a. Maybe a
Nothing (\Token Text
c -> Char
'a' forall a. Ord a => a -> a -> Bool
<= Token Text
c Bool -> Bool -> Bool
&& Token Text
c forall a. Ord a => a -> a -> Bool
<= Char
'z')

p_num :: Parser Val
p_num :: Parser Val
p_num = Int -> Val
VNum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). ParserT m Int
Parse.p_int

p_string :: Parser Val
p_string :: Parser Val
p_string = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Val
VString forall a b. (a -> b) -> a -> b
$
    forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
P.takeWhileP forall a. Maybe a
Nothing (\Token Text
c -> Token Text
c forall a. Eq a => a -> a -> Bool
/= Char
'"') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'"'

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme Parser a
p = Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
space

space :: Parser ()
space :: Parser ()
space = forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
P.takeWhileP forall a. Maybe a
Nothing Char -> Bool
Char.isSpace
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. Alternative m => a -> m a -> m a
P.option () (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
';' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe FilePath -> (Token s -> Bool) -> m (Tokens s)
P.takeWhileP forall a. Maybe a
Nothing (forall a. Eq a => a -> a -> Bool
/=Char
'\n') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
space)