diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,11 @@
# History of changes
+## MIDA 0.4.6
+
+* support for Stack and other maintenance stuff;
+
+* refactoring, more type-safe code and better libraries used.
+
## MIDA 0.4.5
* various cosmetic changes;
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -71,15 +71,23 @@
```
#
# Example of MIDA program
-# Recommended tempo is 60
+# Tempo ≈ 50
#
-dur0 = 12 6 6
-dur1 = @[dur0]
-pch0 = {0 5 7} + [c5 {e5 d5} c6 {f5 g5}]
-pch1 = pch0
-vel0 = {7..11} * 10
-vel1 = vel0
+dur0 = 6
+dur1 = dur0
+dur2 = dur0
+dur3 = {96 $ 2, 24}
+pch0 = c5 {e5 d5 [a5 a5]} $ 2, g5
+pch1 = pch0
+pch2 = {c2 c3}
+pch3 = {c6 d6 e6 f6 g6 a6 b6 c7 e7}
+quiet = {40..80}
+normal = quiet + 30
+vel0 = quiet
+vel1 = quiet
+vel2 = 0, normal $ 2, 0
+vel3 = normal
```
See [MIDA Manual](https://mrkkrp.github.io/mida/) for more information.
@@ -87,8 +95,8 @@
## How to control other things?
If you're into this sort of thing, you may like my another project, called
-[ALGA](https://github.com/mrkkrp/alga). It allows to control automation in
-various DAWs.
+[ALGA](https://github.com/mrkkrp/alga). It allows to control automation
+natively in various DAWs.
## License
diff --git a/mida.cabal b/mida.cabal
--- a/mida.cabal
+++ b/mida.cabal
@@ -18,7 +18,7 @@
-- with this program. If not, see .
name: mida
-version: 0.4.5
+version: 0.4.6
synopsis: Language for algorithmic generation of MIDI files
description:
@@ -43,110 +43,115 @@
See MIDA Manual for more information.
-homepage: https://github.com/mrkkrp/mida
-license: GPL-3
-license-file: LICENSE.md
-author: Mark Karpov
-maintainer: Mark Karpov
-copyright: Copyright © 2014, 2015 Mark Karpov
-category: Language
-build-type: Simple
-extra-source-files: README.md, CHANGELOG.md
-cabal-version: >= 1.10
+homepage: https://github.com/mrkkrp/mida
+license: GPL-3
+license-file: LICENSE.md
+author: Mark Karpov
+maintainer: Mark Karpov
+copyright: Copyright © 2014, 2015 Mark Karpov
+category: Language
+build-type: Simple
+extra-source-files: README.md, CHANGELOG.md
+cabal-version: >= 1.10
library
- hs-source-dirs: src
- ghc-options: -O2 -Wall
- ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts
- build-depends: HCodecs >= 0.5
- , base >= 4.8 && < 5
- , containers >= 0.5.5.1
- , megaparsec == 4.*
- , mtl >= 2.1.3.1
- , random
- , text >= 1.2.0.4
- , tf-random >= 0.5
- , transformers >= 0.2.0.0 && < 0.5
- default-extensions:
- BangPatterns
- , DeriveFoldable
- , DeriveFunctor
- , FlexibleInstances
- , GeneralizedNewtypeDeriving
- , OverloadedStrings
- , StandaloneDeriving
- , TupleSections
- , TypeSynonymInstances
- exposed-modules: Mida.Configuration
- , Mida.Language
- , Mida.Language.Element
- , Mida.Language.Environment
- , Mida.Language.Eval
- , Mida.Language.SyntaxTree
- , Mida.Midi
- , Mida.Representation
- , Mida.Representation.Parser
- , Mida.Representation.Show
- other-modules: Mida.Representation.Base
- default-language: Haskell2010
+ hs-source-dirs: src
+ ghc-options: -O2 -Wall
+ ghc-prof-options: -O2 -Wall -prof -fprof-cafs -rtsopts
+ build-depends: HCodecs >= 0.5
+ , base >= 4.8 && < 5
+ , containers >= 0.5.5.1
+ , exceptions >= 0.8
+ , haskeline >= 0.7.1.3
+ , megaparsec >= 4.2
+ , mtl >= 2.1.3.1
+ , random
+ , text >= 1.2.0.4
+ , tf-random >= 0.5
+ , transformers >= 0.2.0.0 && < 0.5
+ default-extensions: FlexibleContexts
+ , FlexibleInstances
+ , OverloadedStrings
+ , TupleSections
+ exposed-modules: Mida.Configuration
+ , Mida.Language
+ , Mida.Language.Element
+ , Mida.Language.Environment
+ , Mida.Language.Eval
+ , Mida.Language.SyntaxTree
+ , Mida.Midi
+ , Mida.Representation
+ , Mida.Representation.Parser
+ , Mida.Representation.Show
+ other-modules: Mida.Representation.Base
+ default-language: Haskell2010
executable mida
- main-is: Main.hs
- hs-source-dirs: src
- other-modules: Mida.Interaction
- ghc-options: -O2 -Wall
- ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts
- build-depends: HCodecs >= 0.5
- , base >= 4.8 && < 5
- , containers >= 0.5.5.1
- , directory >= 1.2.1.0
- , filepath >= 1.3.0.2
- , haskeline >= 0.7.1.3
- , megaparsec == 4.*
- , mida >= 0.4.3
- , mtl >= 2.1.3.1
- , optparse-applicative >= 0.11.0.2
- , process >= 1.2.0.0
- , random
- , text >= 1.2.0.4
- , text-format >= 0.3.1.1
- , tf-random >= 0.5
- , transformers >= 0.2.0.0 && < 0.5
- default-extensions:
- BangPatterns
- , DeriveFoldable
- , DeriveFunctor
- , FlexibleInstances
- , GeneralizedNewtypeDeriving
- , OverloadedStrings
- , StandaloneDeriving
- , TupleSections
- , TypeSynonymInstances
- other-modules: Mida.Interaction
- , Mida.Interaction.Base
- , Mida.Interaction.Commands
- default-language: Haskell2010
+ main-is: Main.hs
+ hs-source-dirs: src
+ other-modules: Mida.Interaction
+ ghc-options: -O2 -Wall
+ ghc-prof-options: -O2 -Wall -prof -fprof-cafs -rtsopts
+ build-depends: HCodecs >= 0.5
+ , base >= 4.8 && < 5
+ , containers >= 0.5.5.1
+ , directory >= 1.2.1.0
+ , exceptions >= 0.8
+ , filepath >= 1.3.0.2
+ , formatting >= 6.2
+ , haskeline >= 0.7.1.3
+ , megaparsec >= 4.2
+ , mida >= 0.4.6
+ , mtl >= 2.1.3.1
+ , optparse-applicative >= 0.11.0.2
+ , path >= 0.5.3
+ , process >= 1.2.0.0
+ , random
+ , temporary >= 1.2
+ , text >= 1.2.0.4
+ , tf-random >= 0.5
+ , transformers >= 0.2.0.0 && < 0.5
+ default-extensions: FlexibleContexts
+ , FlexibleInstances
+ , OverloadedStrings
+ , TupleSections
+ other-modules: Mida.Configuration
+ , Mida.Interaction
+ , Mida.Interaction.Base
+ , Mida.Interaction.Commands
+ , Mida.Language
+ , Mida.Language.Element
+ , Mida.Language.Environment
+ , Mida.Language.Eval
+ , Mida.Language.SyntaxTree
+ , Mida.Midi
+ , Mida.Representation
+ , Mida.Representation.Base
+ , Mida.Representation.Parser
+ , Mida.Representation.Show
+ , Paths_mida
+ default-language: Haskell2010
test-suite tests
- main-is: Main.hs
- hs-source-dirs: tests
- type: exitcode-stdio-1.0
- ghc-options: -O2 -Wall -rtsopts
- default-language: Haskell2010
- build-depends: HCodecs >= 0.5
- , QuickCheck >= 2.4 && < 3
- , base >= 4.8 && < 5
- , containers >= 0.5.5.1
- , megaparsec == 4.*
- , mida >= 0.4.3
- , mtl >= 2.1.3.1
- , random
- , test-framework >= 0.4 && < 1
- , test-framework-quickcheck2 >= 0.3 && < 0.4
- , text >= 1.2.0.4
- , tf-random >= 0.5
- , transformers >= 0.2.0.0 && < 0.5
+ main-is: Main.hs
+ hs-source-dirs: tests
+ type: exitcode-stdio-1.0
+ ghc-options: -O2 -Wall -rtsopts
+ default-language: Haskell2010
+ build-depends: HCodecs >= 0.5
+ , QuickCheck >= 2.4 && < 3
+ , base >= 4.8 && < 5
+ , containers >= 0.5.5.1
+ , megaparsec >= 4.2
+ , mida >= 0.4.6
+ , mtl >= 2.1.3.1
+ , random
+ , test-framework >= 0.4 && < 1
+ , test-framework-quickcheck2 >= 0.3 && < 0.4
+ , text >= 1.2.0.4
+ , tf-random >= 0.5
+ , transformers >= 0.2.0.0 && < 0.5
source-repository head
- type: git
- location: git://github.com/mrkkrp/mida.git
+ type: git
+ location: git://github.com/mrkkrp/mida.git
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -20,52 +20,61 @@
module Main (main) where
import Control.Monad
+import Data.Text.Lazy (Text)
import Data.Version (showVersion)
+import Formatting
+import Mida.Configuration
+import Mida.Interaction
+import Numeric.Natural
import Options.Applicative
+import Path
import Paths_mida (version)
import System.Directory (getHomeDirectory, doesFileExist, getCurrentDirectory)
-import System.FilePath
import qualified Data.Map as M
-import qualified Data.Text.Format as F
-import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as T
-import Mida.Configuration
-import Mida.Interaction
+-- | MIDA application command line options.
data Opts = Opts
- { opInterac :: Bool
- , opSeed :: Int
- , opQuarter :: Int
- , opBeats :: Int
- , opOutput :: String
- , opLicense :: Bool
- , opVersion :: Bool
- , opFiles :: [String] }
+ { opInterac :: Bool -- ^ Do we run in interactive mode?
+ , opSeed :: Natural -- ^ Seed for random number generator
+ , opQuarter :: Natural -- ^ Number of ticks per quarter note
+ , opBeats :: Natural -- ^ Duration as number of quarter notes
+ , opOutput :: FilePath -- ^ Where to save generate MIDI file
+ , opLicense :: Bool -- ^ Whether to show license
+ , opVersion :: Bool -- ^ Whether to show program's version
+ , opFiles :: [FilePath] -- ^ Source files to load
+ }
+-- | Entry point for the whole thing.
+
main :: IO ()
main = execParser opts >>= f
where f Opts { opLicense = True } = T.putStr license
- f Opts { opVersion = True } = F.print "MIDA {}\n" (F.Only ver)
- f Opts { opFiles = [] } = g $ interaction ver
+ f Opts { opVersion = True } = fprint ("MIDA " % string % "\n") ver
+ f Opts { opFiles = [] } = g interaction
f Opts { opInterac = True
- , opFiles = ns } = g $ cmdLoad ns >> interaction ver
+ , opFiles = ns } = g $ cmdLoad ns >> interaction
f Opts { opSeed = s
, opQuarter = q
, opBeats = b
, opOutput = out
, opFiles = ns } = g $ cmdLoad ns >> cmdMake s q b out
- g x = T.putStrLn notice >> runMida x
+ g x = T.putStrLn notice >> runMida' x
ver = showVersion version
-notice :: T.Text
+-- | Shortish copyright notice.
+
+notice :: Text
notice =
"MIDA Copyright © 2014, 2015 Mark Karpov\n\n\
\This program comes with ABSOLUTELY NO WARRANTY. This is free software,\n\
\and you are welcome to redistribute it under certain conditions; see\n\
\GNU General Public License for details.\n"
-license :: T.Text
+-- | Longer copyright notice.
+
+license :: Text
license =
"MIDA — realization of MIDA, language for generation of MIDI files.\n\
\Copyright © 2014, 2015 Mark Karpov\n\
@@ -83,13 +92,18 @@
\You should have received a copy of the GNU General Public License along\n\
\with this program. If not, see .\n"
-runMida :: MidaIO () -> IO ()
-runMida e = do
+-- | Read configuration file if present and run MIDA monad.
+
+runMida' :: Mida () -> IO ()
+runMida' e = do
params <- loadConfig
- wdir <- getCurrentDirectory
- void $ runMidaInt e
+ wdir <- getCurrentDirectory >>= parseAbsDir
+ dfname <- parseRelFile "foo.da"
+ let dfltSrcFile = fromAbsFile (wdir dfname)
+ srcFile <- parseAbsFile (lookupCfg params "src" dfltSrcFile)
+ void $ runMida e
MidaSt { stPrevLen = lookupCfg params "prvlen" 18
- , stSrcFile = lookupCfg params "src" wdir "foo.da"
+ , stSrcFile = srcFile
, stProg = lookupCfg params "prog" 0
, stTempo = lookupCfg params "tempo" 120 }
MidaCfg { cfgPrompt = lookupCfg params "prompt" "> "
@@ -98,10 +112,13 @@
, cfgProgOp = lookupCfg params "progop" "--force-program"
, cfgTempoOp = lookupCfg params "tempop" "--adjust-tempo" }
+-- | Read configuration file.
+
loadConfig :: IO Params
loadConfig = do
- home <- getHomeDirectory
- let file = home ".mida"
+ home <- getHomeDirectory >>= parseAbsDir
+ cfn <- parseRelFile ".mida"
+ let file = fromAbsFile (home cfn)
exist <- doesFileExist file
if exist
then do params <- parseConfig file <$> T.readFile file
@@ -110,12 +127,16 @@
Left _ -> return M.empty
else return M.empty
+-- | Some information about the program.
+
opts :: ParserInfo Opts
opts = info (helper <*> options)
( fullDesc
<> progDesc "starts MIDA interpreter or translates source into MIDI file"
<> header "mida — interpreter for MIDA language" )
+-- | Description of command line options.
+
options :: Parser Opts
options = Opts
<$> switch
@@ -126,20 +147,20 @@
( long "seed"
<> short 's'
<> metavar "SEED"
- <> value dfltSeed
- <> help ("Set seed for MIDI generation, default is " ++ show dfltSeed) )
+ <> value defaultSeed
+ <> help ("Set seed for MIDI generation, default is " ++ show defaultSeed) )
<*> option auto
( long "quarter"
<> short 'q'
<> metavar "TICKS"
- <> value dfltQuarter
- <> help ("Set ticks per quarter note, default is " ++ show dfltQuarter) )
+ <> value defaultQuarter
+ <> help ("Set ticks per quarter note, default is " ++ show defaultQuarter) )
<*> option auto
( long "beats"
<> short 'b'
<> metavar "BEATS"
- <> value dfltBeats
- <> help ("Set total time in quarter notes, default is " ++ show dfltBeats) )
+ <> value defaultBeats
+ <> help ("Set total time in quarter notes, default is " ++ show defaultBeats) )
<*> strOption
( long "output"
<> short 'o'
diff --git a/src/Mida/Configuration.hs b/src/Mida/Configuration.hs
--- a/src/Mida/Configuration.hs
+++ b/src/Mida/Configuration.hs
@@ -17,6 +17,9 @@
-- You should have received a copy of the GNU General Public License along
-- with this program. If not, see .
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
module Mida.Configuration
( Params
, parseConfig
@@ -26,36 +29,46 @@
import Control.Applicative
import Control.Monad
import Data.Maybe (fromMaybe, listToMaybe)
-import qualified Data.Map as M
-import qualified Data.Text.Lazy as T
-
+import Data.Text.Lazy (Text)
+import Data.Map (Map)
+import Numeric.Natural
import Text.Megaparsec
import Text.Megaparsec.Text.Lazy
+import qualified Data.Map as M
import qualified Text.Megaparsec.Lexer as L
-type Params = M.Map String String
+-- | Collection of configuration parameters. They are kept as 'String's and
+-- then converted on request.
+type Params = Map String String
+
class Parsable a where
parseValue :: String -> Maybe a
instance Parsable String where
parseValue = Just
-instance Parsable Int where
- parseValue = parseNum
+instance Parsable Natural where
+ parseValue = fmap fst . listToMaybe . reads
instance Parsable Bool where
parseValue "true" = Just True
parseValue "false" = Just False
parseValue _ = Nothing
-lookupCfg :: Parsable a => Params -> String -> a -> a
+-- | Lookup a value from configuration parameters. Type of result determines
+-- how value will be interpreted.
+
+lookupCfg :: Parsable a
+ => Params -- ^ Collection of configuration parameters
+ -> String -- ^ Name of parameter to lookup
+ -> a -- ^ Fallback value
+ -> a -- ^ Result
lookupCfg cfg v d = fromMaybe d $ M.lookup v cfg >>= parseValue
-parseNum :: (Num a, Read a) => String -> Maybe a
-parseNum = fmap fst . listToMaybe . reads
+-- | Parse configuration file.
-parseConfig :: String -> T.Text -> Either String Params
+parseConfig :: String -> Text -> Either String Params
parseConfig file = either (Left . show) Right . parse pConfig file
pConfig :: Parser Params
@@ -76,7 +89,7 @@
pString = lexeme $ char '"' >> manyTill L.charLiteral (char '"')
pThing :: Parser String
-pThing = lexeme $ some alphaNumChar
+pThing = lexeme (some alphaNumChar)
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
diff --git a/src/Mida/Interaction.hs b/src/Mida/Interaction.hs
--- a/src/Mida/Interaction.hs
+++ b/src/Mida/Interaction.hs
@@ -19,52 +19,62 @@
-- with this program. If not, see .
module Mida.Interaction
- ( MidaIO
- , MidaInt
- , runMidaInt
- , MidaSt (..)
+ ( MidaSt (..)
, MidaCfg (..)
+ , Mida
+ , runMida
, cmdLoad
, cmdMake
, interaction
- , dfltSeed
- , dfltQuarter
- , dfltBeats )
+ , defaultSeed
+ , defaultQuarter
+ , defaultBeats )
where
import Control.Monad.Reader
-import Prelude hiding (mapM_)
+import Control.Monad.State.Strict
+import Data.Text.Lazy (Text)
+import Data.Version (showVersion)
+import Formatting
+import Mida.Interaction.Base
+import Mida.Interaction.Commands
+import Mida.Language
+import Mida.Representation
+import Numeric.Natural
+import Path
+import Paths_mida (version)
import System.IO
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as T
-
-import qualified Data.Text.Format as F
import qualified System.Console.Haskeline as L
-import Mida.Interaction.Base
-import Mida.Interaction.Commands
-import Mida.Language
-import Mida.Representation
+-- | Entry point for REPL interaction.
-interaction :: String -> MidaIO ()
-interaction version = do
+interaction :: Mida ()
+interaction = do
liftIO $ hSetBuffering stdin LineBuffering
- liftIO $ F.print "MIDA Interactive Environment {}\n" (F.Only version)
+ liftIO $ fprint
+ ("MIDA Interactive Environment " % string % "\n") (showVersion version)
L.runInputT (L.setComplete completionFunc L.defaultSettings) midaRepl
-midaRepl :: L.InputT MidaIO ()
+-- | Infinite REPL loop inside Haskeline's 'InputT' monad transformer.
+
+midaRepl :: L.InputT Mida ()
midaRepl = do
input <- getMultiline ""
case input of
- Just x -> do if T.pack cmdPrefix `T.isPrefixOf` T.strip x
- then lift $ processCmd x
- else lift $ processExpr x
- midaRepl
+ Just x -> do
+ if T.pack cmdPrefix `T.isPrefixOf` T.strip x
+ then lift $ processCmd x
+ else lift $ processExpr x
+ midaRepl
Nothing -> return ()
-getMultiline :: T.Text -> L.InputT MidaIO (Maybe T.Text)
+-- | Read multi-line.
+
+getMultiline :: Text -> L.InputT Mida (Maybe Text)
getMultiline prv = do
- prompt <- lift getPrompt
+ prompt <- lift (asks cfgPrompt)
input <- L.getInputLine $
if T.null prv then prompt else replicate (length prompt) ' '
case input of
@@ -74,22 +84,27 @@
else getMultiline r
Nothing -> return Nothing
-processExpr :: T.Text -> MidaIO ()
+-- | Process expression.
+
+processExpr :: Text -> Mida ()
processExpr expr = do
- file <- getSrcFile
- case parseMida file expr of
+ file <- gets stSrcFile
+ case parseMida (fromAbsFile file) expr of
Right x -> mapM_ f x
- Left x -> liftIO $ F.print "Parse error in {}.\n" (F.Only x)
+ Left x -> liftIO $ fprint (string % "\n") x
where f (Definition n t) = processDef n t
- f (Exposition t) =
- do len <- getPrevLen
- verbose <- getVerbose
- result <- liftEnv $ eval t
- prin <- liftEnv $ toPrin t
- liftIO $ when verbose
- (F.print "≡ {}" (F.Only $ showPrinciple prin))
- spitList $ take len result
+ f (Exposition t) = do
+ len <- gets stPrevLen
+ verbose <- asks cfgVerbose
+ result <- eval t
+ prin <- toPrin t
+ liftIO . when verbose $
+ fprint ("≡ " % text) (showPrinciple prin)
+ spitList $ take (fromIntegral len) result
-spitList :: [Int] -> MidaIO ()
+-- | Pretty-print stream of naturals.
+
+spitList :: [Natural] -> Mida ()
spitList [] = liftIO $ T.putStrLn "⇒ ⊥"
-spitList xs = liftIO $ F.print "⇒ {}…\n" (F.Only $ unwords (show <$> xs))
+spitList xs = liftIO $ fprint ("⇒ " % string % "…\n") l
+ where l = unwords $ show <$> xs
diff --git a/src/Mida/Interaction/Base.hs b/src/Mida/Interaction/Base.hs
--- a/src/Mida/Interaction/Base.hs
+++ b/src/Mida/Interaction/Base.hs
@@ -18,130 +18,81 @@
-- You should have received a copy of the GNU General Public License along
-- with this program. If not, see .
-{-# OPTIONS -fno-warn-orphans #-}
-
module Mida.Interaction.Base
- ( MidaIO
- , MidaInt
- , runMidaInt
- , MidaSt (..)
+ ( MidaSt (..)
, MidaCfg (..)
- , lift
- , liftEnv
- , getPrevLen
- , setPrevLen
- , getSrcFile
- , setSrcFile
- , getProg
- , setProg
- , getTempo
- , setTempo
- , getPrompt
- , getVerbose
- , getPrvCmd
- , getProgOp
- , getTempoOp
- , dfltSeed
- , dfltQuarter
- , dfltBeats
+ , Mida
+ , runMida
+ , defaultSeed
+ , defaultQuarter
+ , defaultBeats
, processDef )
where
import Control.Monad.Reader
import Control.Monad.State.Strict
-
-import qualified Data.Text.Format as F
-import qualified System.Console.Haskeline as L
-
+import Formatting
import Mida.Language
-
-type MidaIO = MidaInt IO
-
-newtype MidaInt m a = MidaInt
- { unMidaInt :: StateT MidaSt (ReaderT MidaCfg (MidaEnv m)) a }
- deriving ( Functor
- , Applicative
- , Monad
- , MonadState MidaSt
- , MonadReader MidaCfg
- , MonadIO )
-
-instance MonadTrans MidaInt where
- lift = MidaInt . lift . lift . lift
-
-liftEnv :: (Monad m) => MidaEnv m a -> MidaInt m a
-liftEnv = MidaInt . lift . lift
+import Numeric.Natural
+import Path
-deriving instance L.MonadException m => L.MonadException (MidaEnv m)
-deriving instance L.MonadException m => L.MonadException (MidaInt m)
+-- | MIDA REPL state.
data MidaSt = MidaSt
- { stPrevLen :: Int
- , stSrcFile :: String
- , stProg :: Int
- , stTempo :: Int }
-
-data MidaCfg = MidaCfg
- { cfgPrompt :: String
- , cfgVerbose :: Bool
- , cfgPrvCmd :: String
- , cfgProgOp :: String
- , cfgTempoOp :: String }
-
-runMidaInt :: Monad m => MidaInt m a -> MidaSt -> MidaCfg -> m a
-runMidaInt m st cfg = runMidaEnv (runReaderT (evalStateT (unMidaInt m) st) cfg)
-
-getPrevLen :: MidaIO Int
-getPrevLen = gets stPrevLen
-
-setPrevLen :: Int -> MidaIO ()
-setPrevLen x = modify $ \e -> e { stPrevLen = x }
-
-getSrcFile :: MidaIO String
-getSrcFile = gets stSrcFile
+ { stPrevLen :: Natural -- ^ Length of preview principles
+ , stSrcFile :: Path Abs File -- ^ Name of current source file
+ , stProg :: Natural -- ^ Program to use for preview
+ , stTempo :: Natural -- ^ Tempo to use for preview
+ }
-setSrcFile :: String -> MidaIO ()
-setSrcFile x = modify $ \e -> e { stSrcFile = x }
+-- | MIDA REPL configuration.
-getProg :: MidaIO Int
-getProg = gets stProg
+data MidaCfg = MidaCfg
+ { cfgPrompt :: String -- ^ REPL prompt
+ , cfgVerbose :: Bool -- ^ Verbose mode?
+ , cfgPrvCmd :: String -- ^ Command to use for preview
+ , cfgProgOp :: String -- ^ Option to set program for preview
+ , cfgTempoOp :: String -- ^ Option to set tempo for preview
+ }
-setProg :: Int -> MidaIO ()
-setProg x = modify $ \e -> e { stProg = x }
+-- | A synonym for MIDA monad stack.
-getTempo :: MidaIO Int
-getTempo = gets stTempo
+type Mida = StateT MidaSt (ReaderT MidaCfg (MidaEnv IO))
-setTempo :: Int -> MidaIO ()
-setTempo x = modify $ \e -> e { stTempo = x }
+-- | Run MIDA monad stack.
-getPrompt :: MidaIO String
-getPrompt = asks cfgPrompt
+runMida
+ :: Mida a -- ^ MIDA monad stack
+ -> MidaSt -- ^ Initial state
+ -> MidaCfg -- ^ Configuration
+ -> IO a
+runMida m st cfg = runMidaEnv (runReaderT (evalStateT m st) cfg)
-getVerbose :: MidaIO Bool
-getVerbose = asks cfgVerbose
+-- | Default seed for random number generator.
-getPrvCmd :: MidaIO String
-getPrvCmd = asks cfgPrvCmd
+defaultSeed :: Natural
+defaultSeed = 0
-getProgOp :: MidaIO String
-getProgOp = asks cfgProgOp
+-- | Default number of ticks in quarter.
-getTempoOp :: MidaIO String
-getTempoOp = asks cfgTempoOp
+defaultQuarter :: Natural
+defaultQuarter = 24
-dfltSeed :: Int
-dfltSeed = 0
+-- | Default duration of MIDI file to render, in quarter notes.
-dfltQuarter :: Int
-dfltQuarter = 24
+defaultBeats :: Natural
+defaultBeats = 16
-dfltBeats :: Int
-dfltBeats = 16
+-- | Process a principle definition.
-processDef :: String -> SyntaxTree -> MidaIO ()
+processDef :: (HasEnv m, MonadIO m)
+ => String -- ^ Definition name
+ -> SyntaxTree -- ^ AST for that definition
+ -> m ()
processDef n t = do
- recursive <- liftEnv $ checkRecur n t
+ recursive <- checkRecur n t
if recursive
- then liftIO $ F.print "Rejected recursive definition for «{}».\n" (F.Only n)
- else liftEnv (addDef n t) >> liftIO (F.print "• «{}»\n" (F.Only n))
+ then liftIO $
+ fprint ("Rejected recursive definition for «" % string % "».\n") n
+ else do addDef n t
+ liftIO $ fprint ("• «" % string % "»\n") n
diff --git a/src/Mida/Interaction/Commands.hs b/src/Mida/Interaction/Commands.hs
--- a/src/Mida/Interaction/Commands.hs
+++ b/src/Mida/Interaction/Commands.hs
@@ -18,6 +18,8 @@
-- You should have received a copy of the GNU General Public License along
-- with this program. If not, see .
+{-# LANGUAGE RecordWildCards #-}
+
module Mida.Interaction.Commands
( processCmd
, completionFunc
@@ -26,56 +28,65 @@
, cmdPrefix )
where
-import Control.Exception (SomeException, try)
-import Control.Monad (void)
+import Control.Exception (SomeException)
+import Control.Monad.Catch (try, MonadThrow, MonadMask, fromException, throwM)
import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Control.Monad.State.Class
import Data.Char (isSpace)
import Data.Foldable (find)
import Data.List (elemIndex, isPrefixOf)
import Data.Maybe (fromMaybe, listToMaybe)
+import Data.Text.Lazy (Text)
+import Formatting
+import Mida.Interaction.Base
+import Mida.Language
+import Mida.Midi
+import Mida.Representation
+import Numeric.Natural
+import Path
import System.Directory
- ( canonicalizePath
- , doesDirectoryExist
+ ( doesDirectoryExist
, doesFileExist
, getCurrentDirectory
, getHomeDirectory
- , getTemporaryDirectory
+ , makeAbsolute
, setCurrentDirectory )
-import System.Exit (exitSuccess)
-import System.FilePath
- ( addTrailingPathSeparator
- , joinPath
- , replaceExtension
- , splitDirectories
- , takeFileName
- , () )
+import System.Exit (exitSuccess, ExitCode)
+import System.IO.Temp (withSystemTempDirectory)
import System.Process
( shell
, createProcess
, waitForProcess
, delegate_ctlc )
+import qualified Codec.Midi as Midi
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as T
-
-import qualified Codec.Midi as Midi
-import qualified Data.Text.Format as F
import qualified System.Console.Haskeline as L
+import qualified System.FilePath as FP
-import Mida.Interaction.Base
-import Mida.Language
-import Mida.Midi
-import Mida.Representation
+-- | Description of REPL command.
data Cmd = Cmd
- { cmdName :: String
- , cmdFunc :: String -> MidaIO ()
- , cmdDesc :: T.Text
- , cmdComp :: CompletionScheme }
+ { cmdName :: String -- ^ Name of command
+ , cmdFunc :: String -> Mida () -- ^ Action it performs
+ , cmdDesc :: Text -- ^ Description of command
+ , cmdComp :: CompletionScheme -- ^ How to complete arguments of the command
+ }
-data CompletionScheme = None | Files | Names deriving (Eq, Show)
+-- | How to complete arguments of command.
+data CompletionScheme
+ = None -- ^ Don't complete at all
+ | Files -- ^ Complete as file names
+ | Names -- ^ Complete as definition names
+ deriving (Eq, Show)
+
+-- | All defined REPL commands.
+
commands :: [Cmd]
commands =
+ -- name action description completion
[ Cmd "cd" cmdCd "Change working directory" Files
, Cmd "clear" cmdClear "Restore default state of environment" None
, Cmd "def" cmdDef "Print definition of given symbol" Names
@@ -92,179 +103,289 @@
, Cmd "tempo" cmdTempo "Set tempo for preview" None
, Cmd "udef" cmdUdef "Remove definition of given symbol" Names ]
-processCmd :: T.Text -> MidaIO ()
+-- | Process command (with its arguments).
+
+processCmd :: Text -> Mida ()
processCmd txt =
case find g commands of
- Just Cmd { cmdFunc = f } -> f . T.unpack . T.strip $ args
- Nothing -> liftIO $ F.print "Unknown command, try {}help.\n"
- (F.Only cmdPrefix)
+ Just Cmd { cmdFunc = f } -> do
+ result <- try . f . T.unpack . T.strip $ args
+ :: Mida (Either SomeException ())
+ case result of
+ Left e ->
+ case fromException e :: Maybe ExitCode of
+ Just _ -> throwM e
+ Nothing -> spitExc e
+ Right _ -> return ()
+ Nothing -> liftIO $
+ fprint ("Unknown command, try " % string % "help.\n") cmdPrefix
where g Cmd { cmdName = c } = c == dropCmdPrefix (T.unpack cmd)
(cmd, args) = T.break isSpace (T.strip txt)
-completionFunc :: L.CompletionFunc MidaIO
+-- | Completion function to work with Haskeline.
+
+completionFunc
+ :: (HasEnv m, MonadIO m, MonadReader MidaCfg m, MonadState MidaSt m)
+ => L.CompletionFunc m
completionFunc = L.completeWordWithPrev Nothing " " getCompletions
-getCompletions :: String -> String -> MidaIO [L.Completion]
+-- | Generate completions.
+
+getCompletions
+ :: (HasEnv m, MonadIO m, MonadReader MidaCfg m, MonadState MidaSt m)
+ => String -- ^ Contents of line before cursor, reversed
+ -> String -- ^ Contents of line after cursor
+ -> m [L.Completion] -- ^ List of completions
getCompletions prev word = do
- names <- liftEnv getRefs
+ names <- getRefs
files <- L.listFiles word
let cmds = (cmdPrefix ++) . cmdName <$> commands
+ f = fmap L.simpleCompletion . filter (word `isPrefixOf`)
g None = []
g Files = files
g Names = f names
- return $ case words . reverse $ prev of
- [] -> f $ cmds ++ names
- (c:_) -> case c `elemIndex` cmds of
- Just i -> g . cmdComp $ commands !! i
- Nothing -> f names
- where f = fmap L.simpleCompletion . filter (word `isPrefixOf`)
+ return $
+ case words . reverse $ prev of
+ [] -> f $ cmds ++ names
+ (c:_) ->
+ case c `elemIndex` cmds of
+ Just i -> g . cmdComp $ commands !! i
+ Nothing -> f names
-cmdCd :: String -> MidaIO ()
-cmdCd path = liftIO $ do
- new <- addTrailingPathSeparator . ( path) <$> getCurrentDirectory
- present <- doesDirectoryExist new
+-- | Change working directory.
+
+cmdCd :: MonadIO m => String -> m ()
+cmdCd next' = liftIO $ do
+ next <- fixPath next' >>= parseAbsDir
+ let npath = fromAbsDir next
+ present <- doesDirectoryExist npath
if present
- then do corrected <- canonicalizePath new
- setCurrentDirectory corrected
- F.print "Changed to \"{}\".\n" (F.Only corrected)
- else F.print "Cannot cd to \"{}\".\n" (F.Only new)
+ then do setCurrentDirectory npath
+ fprint ("Changed to \"" % string % "\".\n") npath
+ else fprint ("Cannot cd to \"" % string % "\".\n") npath
-cmdClear :: String -> MidaIO ()
-cmdClear _ = liftEnv clearDefs >> liftIO (T.putStrLn "Environment cleared.")
+-- | Restore default state of environment.
-cmdDef :: String -> MidaIO ()
+cmdClear :: (HasEnv m, MonadIO m) => String -> m ()
+cmdClear _ = do
+ clearDefs
+ liftIO (T.putStrLn "Environment cleared.")
+
+-- | Print definition of given symbol.
+
+cmdDef :: (HasEnv m, MonadIO m) => String -> m ()
cmdDef arg = mapM_ f (words arg)
- where f name = liftEnv (getSrc name) >>= liftIO . T.putStr
+ where f name = getSrc name >>= liftIO . T.putStr
-cmdHelp :: String -> MidaIO ()
-cmdHelp _ = liftIO (T.putStrLn "Available commands:") >> mapM_ f commands
- where f Cmd { cmdName = c, cmdDesc = d } =
- liftIO $ F.print " {}{}{}\n" (cmdPrefix, F.right 24 ' ' c, d)
+-- | Show help with list of all available commands.
-cmdLoad' :: String -> MidaIO ()
+cmdHelp :: MonadIO m => String -> m ()
+cmdHelp _ = liftIO $ do
+ T.putStrLn "Available commands:"
+ mapM_ f commands
+ where f Cmd {..} = fprint fmt cmdPrefix cmdName cmdDesc
+ fmt = " " % string % (right 24 ' ' %. string) % text % "\n"
+
+-- | Load definitions from given file. Note that this version of the command
+-- is used in REPL, not 'cmdLoad'.
+
+cmdLoad' :: (HasEnv m, MonadIO m, MonadState MidaSt m, MonadThrow m)
+ => String -> m ()
cmdLoad' = cmdLoad . words
-cmdLoad :: [String] -> MidaIO()
+-- | Alternative interface to loading functionality. This one is used in
+-- main module.
+
+cmdLoad :: (HasEnv m, MonadIO m, MonadState MidaSt m, MonadThrow m)
+ => [FilePath] -> m ()
cmdLoad = mapM_ loadOne
-loadOne :: String -> MidaIO ()
+-- | Load single source file.
+
+loadOne :: (HasEnv m, MonadIO m, MonadState MidaSt m, MonadThrow m)
+ => FilePath -> m ()
loadOne given = do
file <- output given ""
- b <- liftIO $ doesFileExist file
+ let fpath = fromAbsFile file
+ b <- liftIO $ doesFileExist fpath
if b
- then do contents <- liftIO $ T.readFile file
- case parseMida (takeFileName file) contents of
- Right x -> do mapM_ f x
- setFileName file
- liftIO $ F.print "\"{}\" loaded successfully.\n"
- (F.Only file)
- Left x -> liftIO $ F.print "Parse error in {}.\n" (F.Only x)
- else liftIO $ F.print "Could not find \"{}\".\n" (F.Only file)
+ then do contents <- liftIO $ T.readFile fpath
+ case parseMida fpath contents of
+ Right x -> do
+ mapM_ f x
+ setFileName file
+ liftIO $ fprint
+ ("\"" % string % "\" loaded successfully.\n")
+ fpath
+ Left x -> liftIO $ fprint (string % "\n") x
+ else liftIO $ fprint ("Could not find \"" % string % "\".\n") fpath
where f (Definition n t) = processDef n t
f (Exposition _) = return ()
-cmdMake' :: String -> MidaIO ()
+-- | Version of 'cmdMake' used by REPL.
+
+cmdMake' :: (HasEnv m, MonadIO m, MonadState MidaSt m, MonadThrow m)
+ => String -> m ()
cmdMake' arg =
let (s:q:b:f:_) = words arg ++ repeat ""
- in cmdMake (parseNum s dfltSeed)
- (parseNum q dfltQuarter)
- (parseNum b dfltBeats)
+ in cmdMake (parseNum s defaultSeed)
+ (parseNum q defaultQuarter)
+ (parseNum b defaultBeats)
f
-cmdMake :: Int -> Int -> Int -> String -> MidaIO ()
+-- | Generate and save MIDI file.
+
+cmdMake :: (HasEnv m, MonadIO m, MonadState MidaSt m, MonadThrow m)
+ => Natural -- ^ Seed for random number generator
+ -> Natural -- ^ Q value: number of ticks per quarter note
+ -> Natural -- ^ Desired duration in number of quarter notes
+ -> FilePath -- ^ Where to save MIDI file
+ -> m ()
cmdMake s q b f = do
file <- output f "mid"
- midi <- liftEnv $ genMidi s q b
- result <- liftIO $ try (Midi.exportFile file midi)
- case result of
- Right _ -> liftIO $ F.print "MIDI file saved as \"{}\".\n" (F.Only file)
- Left e -> spitExc e
+ let fpath = fromAbsFile file
+ midi <- genMidi s q b
+ liftIO $ Midi.exportFile fpath midi
+ liftIO $ fprint ("MIDI file saved as \"" % string % "\".\n") fpath
-cmdProg :: String -> MidaIO ()
+-- | Set program for preview.
+
+cmdProg :: MonadState MidaSt m => String -> m ()
cmdProg arg = do
- prog <- getProg
- setProg $ parseNum (trim arg) prog
+ prog <- gets stProg
+ modify $ \st -> st { stProg = parseNum (trim arg) prog }
-cmdPrv :: String -> MidaIO ()
+-- | Preview with help of external program.
+
+cmdPrv :: ( HasEnv m
+ , MonadIO m
+ , MonadReader MidaCfg m
+ , MonadState MidaSt m
+ , MonadThrow m
+ , MonadMask m )
+ => String -> m ()
cmdPrv arg = do
- prvcmd <- getPrvCmd
- progOp <- getProgOp
- prog <- show <$> getProg
- tempoOp <- getTempoOp
- tempo <- show <$> getTempo
- temp <- liftIO getTemporaryDirectory
- f <- output "" "mid"
- let (s:q:b:_) = words arg ++ repeat ""
- file = temp takeFileName f
- cmd = unwords [prvcmd, progOp, prog, tempoOp, tempo, file]
- cmdMake (parseNum s dfltSeed)
- (parseNum q dfltQuarter)
- (parseNum b dfltBeats)
- file
- (_, _, _, ph) <- liftIO $ createProcess (shell cmd) { delegate_ctlc = True }
- liftIO . void $ waitForProcess ph
+ prvcmd <- asks cfgPrvCmd
+ progOp <- asks cfgProgOp
+ prog <- show <$> gets stProg
+ tempoOp <- asks cfgTempoOp
+ tempo <- show <$> gets stTempo
+ withSystemTempDirectory "mida" $ \tdir -> do
+ tpath <- parseAbsDir tdir
+ f <- filename <$> output "" "mid"
+ let (s:q:b:_) = words arg ++ repeat ""
+ file = fromAbsFile (tpath f)
+ cmd = unwords [prvcmd, progOp, prog, tempoOp, tempo, file]
+ cmdMake (parseNum s defaultSeed)
+ (parseNum q defaultQuarter)
+ (parseNum b defaultBeats)
+ file
+ (_, _, _, ph) <- liftIO $ createProcess (shell cmd) { delegate_ctlc = True }
+ liftIO . void . waitForProcess $ ph
-cmdLength :: String -> MidaIO ()
-cmdLength x = getPrevLen >>= setPrevLen . parseNum x
+-- | Set length of displayed results.
-cmdPurge :: String -> MidaIO ()
+cmdLength :: MonadState MidaSt m => String -> m ()
+cmdLength arg = do
+ len <- gets stPrevLen
+ modify $ \st -> st { stPrevLen = parseNum (trim arg) len }
+
+-- | Remove redundant definitions.
+
+cmdPurge :: (HasEnv m, MonadIO m) => String -> m ()
cmdPurge _ = do
- liftEnv $ purgeEnv topDefs
+ purgeEnv topDefs
liftIO $ T.putStrLn "Environment purged."
-cmdPwd :: String -> MidaIO ()
+-- | Print working directory.
+
+cmdPwd :: MonadIO m => String -> m ()
cmdPwd _ = liftIO (getCurrentDirectory >>= putStrLn)
-cmdQuit :: String -> MidaIO ()
+-- | Quit the interactive environment.
+
+cmdQuit :: MonadIO m => String -> m ()
cmdQuit _ = liftIO exitSuccess
-cmdSave :: String -> MidaIO ()
+-- | Save current environment in file.
+
+cmdSave :: (HasEnv m, MonadIO m, MonadState MidaSt m, MonadThrow m)
+ => String -> m ()
cmdSave given = do
file <- output given ""
- src <- liftEnv fullSrc
- result <- liftIO (try (T.writeFile file src) :: IO (Either SomeException ()))
- case result of
- Right _ -> setFileName file >>
- liftIO (F.print "Environment saved as \"{}\".\n" (F.Only file))
- Left e -> spitExc e
+ let fpath = fromAbsFile file
+ src <- fullSrc
+ liftIO $ T.writeFile fpath src
+ setFileName file
+ liftIO $ fprint ("Environment saved as \"" % string % "\".\n") fpath
-cmdTempo :: String -> MidaIO ()
+-- | Set tempo for preview.
+
+cmdTempo :: MonadState MidaSt m => String -> m ()
cmdTempo arg = do
- tempo <- getTempo
- setTempo $ parseNum (trim arg) tempo
+ tempo <- gets stTempo
+ modify $ \st -> st { stTempo = parseNum (trim arg) tempo }
-cmdUdef :: String -> MidaIO ()
+-- | Undefine definitions.
+
+cmdUdef :: (HasEnv m, MonadIO m) => String -> m ()
cmdUdef arg = mapM_ f (words arg)
where f name = do
- liftEnv (remDef name)
- liftIO (F.print "Definition for '{}' removed.\n" (F.Only name))
+ remDef name
+ liftIO $ fprint ("Definition for «" % string % "» removed.\n") name
-parseNum :: (Num a, Read a) => String -> a -> a
+-- | Parse a number defaulting to given value.
+
+parseNum :: (Num a, Read a)
+ => String -- ^ String to parse
+ -> a -- ^ Default value
+ -> a -- ^ Result
parseNum s x = fromMaybe x $ fst <$> listToMaybe (reads s)
-output :: String -> String -> MidaIO String
-output given ext = do
- actual <- getSrcFile
- home <- liftIO getHomeDirectory
- let a = if null ext then actual else replaceExtension actual ext
- g = joinPath . fmap f . splitDirectories $ given
- f x = if x == "~" then home else x
- return $ if null given then a else g
+-- | Generate file name from given base name and extension.
-setFileName :: FilePath -> MidaIO ()
-setFileName path = ( path) <$> liftIO getCurrentDirectory >>= setSrcFile
+output :: (MonadIO m, MonadThrow m, MonadState MidaSt m)
+ => FilePath -- ^ Given file name
+ -> String -- ^ Extension
+ -> m (Path Abs File) -- ^ Absolute path to output file
+output given' ext = do
+ given <- liftIO (fixPath given')
+ actual <- fromAbsFile <$> gets stSrcFile
+ let a = if null ext then actual else FP.replaceExtension actual ext
+ parseAbsFile (if null given' then a else given)
+-- | Make path absolute resolving tilde (that's actually shell-functionality,
+-- but we do it for convenience).
+
+fixPath :: FilePath -> IO FilePath
+fixPath path = do
+ home <- getHomeDirectory
+ let f x = if x == "~" then home else x
+ makeAbsolute . FP.joinPath . fmap f . FP.splitDirectories $ path
+
+-- | Change current file name.
+
+setFileName :: MonadState MidaSt m => Path Abs File -> m ()
+setFileName fpath = modify $ \st -> st { stSrcFile = fpath }
+
+-- | Drop command prefix if it's present.
+
dropCmdPrefix :: String -> String
dropCmdPrefix arg
| cmdPrefix `isPrefixOf` arg = drop (length cmdPrefix) arg
| otherwise = arg
+-- | All REPL commands are prefixed with this.
+
cmdPrefix :: String
cmdPrefix = ":"
-spitExc :: SomeException -> MidaIO ()
-spitExc = liftIO . F.print "× {}.\n" . F.Only . show
+-- | Print out an exception.
+spitExc :: MonadIO m => SomeException -> m ()
+spitExc = liftIO . fprint ("× " % string % ".\n") . show
+
+-- | Stupid trimming for strings.
+
trim :: String -> String
-trim = f . f
- where f = reverse . dropWhile isSpace
+trim = let f = reverse . dropWhile isSpace in f . f
diff --git a/src/Mida/Language.hs b/src/Mida/Language.hs
--- a/src/Mida/Language.hs
+++ b/src/Mida/Language.hs
@@ -19,11 +19,11 @@
module Mida.Language
( SyntaxTree
- , Sel (..)
+ , Sel (..)
, Principle
- , Elt
, Element (..)
- , MidaEnv (..)
+ , MidaEnv
+ , HasEnv (..)
, runMidaEnv
, addDef
, remDef
@@ -34,14 +34,12 @@
, getRefs
, purgeEnv
, checkRecur
- , setRandGen
- , newRandGen
, evalDef
, eval
, toPrin )
where
import Mida.Language.SyntaxTree (SyntaxTree, Sel (..))
-import Mida.Language.Element (Principle, Elt, Element (..))
+import Mida.Language.Element (Principle, Element (..))
import Mida.Language.Environment
import Mida.Language.Eval (evalDef, eval, toPrin)
diff --git a/src/Mida/Language/Element.hs b/src/Mida/Language/Element.hs
--- a/src/Mida/Language/Element.hs
+++ b/src/Mida/Language/Element.hs
@@ -18,22 +18,29 @@
-- You should have received a copy of the GNU General Public License along
-- with this program. If not, see .
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+
module Mida.Language.Element
( Principle
- , Elt
, Element (..) )
where
import Control.Arrow ((***))
+import Numeric.Natural
-type Principle = [Elt]
-type Elt = Element Int
+-- | Collection of elements for evaluation, representation of some aspect of
+-- voice.
+type Principle = [Element Natural]
+
+-- | Fundamental type representing an atom for evaluation.
+
data Element a
- = Val a
- | Sec [Element a]
- | Mul [Element a]
- | CMul [([Element a], [Element a])]
+ = Val a -- ^ Single value, evaluates to itself
+ | Sec [Element a] -- ^ Universal container for other values
+ | Mul [Element a] -- ^ Multivalue, the way to introduce varying elements
+ | CMul [([Element a], [Element a])] -- ^ Conditional multivalue
deriving (Eq, Show, Functor, Foldable)
instance Applicative Element where
diff --git a/src/Mida/Language/Environment.hs b/src/Mida/Language/Environment.hs
--- a/src/Mida/Language/Environment.hs
+++ b/src/Mida/Language/Environment.hs
@@ -18,8 +18,11 @@
-- You should have received a copy of the GNU General Public License along
-- with this program. If not, see .
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module Mida.Language.Environment
- ( MidaEnv (..)
+ ( MidaEnv
+ , HasEnv (..)
, runMidaEnv
, addDef
, remDef
@@ -29,79 +32,155 @@
, fullSrc
, getRefs
, purgeEnv
- , checkRecur
- , setRandGen
- , newRandGen )
+ , checkRecur )
where
+import Control.Applicative (empty)
import Control.Arrow ((***), (>>>))
+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
+import Control.Monad.Reader
+import Control.Monad.State.Class
import Control.Monad.State.Strict
+import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
-import System.Random (split)
-import qualified Data.Map.Strict as M
-import qualified Data.Text.Lazy as T
-
-import System.Random.TF (TFGen, mkTFGen)
-
+import Data.Text.Lazy (Text)
import Mida.Language.SyntaxTree
import Mida.Representation.Base (noteAlias, modifiers)
import Mida.Representation.Show (showDefinition)
+import Numeric.Natural
+import System.Console.Haskeline.MonadException -- FIXME
+import System.Random (split)
+import System.Random.TF (TFGen, mkTFGen)
+import qualified Data.Map.Strict as M
+-- | MIDA environment state. Basically this amounts to collection of
+-- definitions and random number generator.
+
data MidaEnvSt = MidaEnvSt
- { stDefs :: Defs
- , stRandGen :: TFGen }
+ { meDefs :: Defs -- ^ Collection of definitions
+ , meRandGen :: TFGen -- ^ Random generator
+ } deriving Show
-type Defs = M.Map String SyntaxTree
+-- | Type synonym for collection of definitions, where a definition is a
+-- pair of variable name and corresponding AST.
+type Defs = Map String SyntaxTree
+
+-- | Monad that implements MIDA environment.
+
newtype MidaEnv m a = MidaEnv
{ unMidaEnv :: StateT MidaEnvSt m a }
deriving ( Functor
, Applicative
, Monad
+ , MonadIO
, MonadState MidaEnvSt
- , MonadTrans
- , MonadIO )
+ , MonadException
+ , MonadThrow
+ , MonadCatch
+ , MonadMask )
+-- | Type class for things that can be considered MIDA environment.
+
+class Monad m => HasEnv m where
+ -- | Get collection of all definitions.
+ getDefs :: m Defs
+ -- | Update definitions with given ones.
+ setDefs :: Defs -> m ()
+ -- | Set random generator seed.
+ setRandGen :: Natural -> m ()
+ -- | Split current random generator, update it, and return new one.
+ newRandGen :: m TFGen
+
+instance Monad m => HasEnv (MidaEnv m) where
+ getDefs = gets meDefs
+ setDefs defs = modify $ \env -> env { meDefs = defs }
+ setRandGen gen = modify $ \e -> e { meRandGen = mkTFGen (fromIntegral gen) }
+ newRandGen = do
+ (g, g') <- split <$> gets meRandGen
+ modify $ \e -> e { meRandGen = g' }
+ return g
+
+instance HasEnv m => HasEnv (StateT e m) where
+ getDefs = lift getDefs
+ setDefs = lift . setDefs
+ setRandGen = lift . setRandGen
+ newRandGen = lift newRandGen
+
+instance HasEnv m => HasEnv (ReaderT e m) where
+ getDefs = lift getDefs
+ setDefs = lift . setDefs
+ setRandGen = lift . setRandGen
+ newRandGen = lift newRandGen
+
+-- | Run state monad with MIDA environment.
+
runMidaEnv :: Monad m => MidaEnv m a -> m a
-runMidaEnv e = evalStateT (unMidaEnv e) MidaEnvSt
- { stDefs = defaultDefs
- , stRandGen = mkTFGen 0 }
+runMidaEnv m = evalStateT (unMidaEnv m) MidaEnvSt
+ { meDefs = defaultDefs
+ , meRandGen = mkTFGen 0 }
+-- | Default definitions in MIDA environment.
+
defaultDefs :: Defs
-defaultDefs = M.fromList $ zip noteAlias (f <$> [0..])
- <> zip modifiers (f <$> [128,256..])
- where f = return . Value
+defaultDefs = M.fromList $
+ zip noteAlias (f <$> [0..]) <>
+ zip modifiers (f <$> [128,256..])
+ where f = pure . Value
-getDefs :: Monad m => MidaEnv m Defs
-getDefs = gets stDefs
+-- | Add a new definition to the environment.
-setDefs :: Monad m => Defs -> MidaEnv m ()
-setDefs x = modify $ \e -> e { stDefs = x }
+addDef :: HasEnv m
+ => String -- ^ Reference name
+ -> SyntaxTree -- ^ AST of its principle
+ -> m ()
+addDef name tree = getDefs >>= setDefs . M.insert name tree
-addDef :: Monad m => String -> SyntaxTree -> MidaEnv m ()
-addDef name tree = M.insert name tree <$> getDefs >>= setDefs
+-- | Remove definition given its name.
-remDef :: Monad m => String -> MidaEnv m ()
-remDef name = M.delete name <$> getDefs >>= setDefs
+remDef :: HasEnv m
+ => String -- ^ Reference name
+ -> m ()
+remDef name = getDefs >>= setDefs . M.delete name
-clearDefs :: Monad m => MidaEnv m ()
+-- | Remove all definitions, restoring default state of environment.
+
+clearDefs :: HasEnv m => m ()
clearDefs = setDefs defaultDefs
-getPrin :: Monad m => String -> MidaEnv m SyntaxTree
+-- | Get principle corresponding to given variable name.
+
+getPrin :: HasEnv m
+ => String -- ^ Reference name
+ -> m SyntaxTree -- ^ Syntax tree
getPrin name = (fromMaybe [] . M.lookup name) <$> getDefs
-getSrc :: Monad m => String -> MidaEnv m T.Text
+-- | Get source code of definition given its name.
+
+getSrc :: HasEnv m
+ => String -- ^ Reference name
+ -> m Text -- ^ Textual representation of source code
getSrc name = showDefinition name <$> getPrin name
-fullSrc :: Monad m => MidaEnv m T.Text
+-- | Reconstruct source code for all existing definitions.
+
+fullSrc :: HasEnv m => m Text
fullSrc = (M.foldMapWithKey showDefinition . (M.\\ defaultDefs)) <$> getDefs
-getRefs :: Monad m => MidaEnv m [String]
+-- | Get all reference names defined at the moment.
+
+getRefs :: HasEnv m => m [String]
getRefs = M.keys <$> getDefs
-tDefs :: String -> Defs -> [String]
-tDefs name defs = maybe mzero cm $ name `M.lookup` defs
+-- | This performs “definition traversal” and returns collection of
+-- definition names that given reference name depends on.
+
+tDefs
+ :: String -- ^ Reference name
+ -> Defs -- ^ Definitions
+ -> [String] -- ^ Collection of definition names
+tDefs name defs = maybe empty cm (name `M.lookup` defs)
where cm = (>>= f)
f (Value _) = mempty
f (Section x) = cm x
@@ -117,24 +196,28 @@
f (Rotation x y) = f x <> f y
f (Reverse x) = f x
-purgeEnv :: Monad m => [String] -> MidaEnv m ()
-purgeEnv tops = f <$> getDefs >>= setDefs
- where f defs = M.intersection defs $ M.unions [ts, ms defs, defaultDefs]
+-- | Purge environment removing definitions that are not used in
+-- construction of “top-level” definitions.
+
+purgeEnv :: HasEnv m
+ => [String] -- ^ Top-level definitions
+ -> m ()
+purgeEnv tops = getDefs >>= setDefs . f
+ where f defs = M.intersection defs (M.unions [ts, ms defs, defaultDefs])
ms = M.unions . fmap toDefs . zipWith tDefs tops . repeat
ts = toDefs tops
-checkRecur :: Monad m => String -> SyntaxTree -> MidaEnv m Bool
+-- | Check if definition with given name is depends on itself.
+
+checkRecur :: HasEnv m
+ => String -- ^ Reference name
+ -> SyntaxTree -- ^ Its syntax tree
+ -> m Bool
checkRecur name tree = check <$> getDefs
where check = elem name . tDefs name . M.insert name tree
-setRandGen :: Monad m => Int -> MidaEnv m ()
-setRandGen x = modify $ \e -> e { stRandGen = mkTFGen x }
-
-newRandGen :: Monad m => MidaEnv m TFGen
-newRandGen = do
- (g, g') <- split <$> gets stRandGen
- modify $ \e -> e { stRandGen = g' }
- return g
+-- | Turn collection of definition names into collection of empty
+-- definitions.
toDefs :: [String] -> Defs
toDefs = M.fromList . fmap (, [])
diff --git a/src/Mida/Language/Eval.hs b/src/Mida/Language/Eval.hs
--- a/src/Mida/Language/Eval.hs
+++ b/src/Mida/Language/Eval.hs
@@ -1,8 +1,8 @@
-- -*- Mode: Haskell; -*-
--
-- This module describes process of evaluation of definitions and arbitrary
--- principles. Result of evaluation is infinite list of integers or empty
--- list.
+-- principles. Result of evaluation is infinite list of natural numbers or
+-- empty list.
--
-- Copyright © 2014, 2015 Mark Karpov
--
@@ -25,88 +25,137 @@
, toPrin )
where
+import Control.Applicative (empty)
import Control.Arrow ((***))
+import Control.Monad.State.Class
import Control.Monad.State.Lazy
import Data.List (tails)
import Data.Maybe (listToMaybe)
import Data.Monoid ((<>))
+import Mida.Language.Element
+import Mida.Language.Environment
+import Mida.Language.SyntaxTree
+import Numeric.Natural
import System.Random (next)
-
import System.Random.TF (TFGen)
-import Mida.Language.SyntaxTree
-import Mida.Language.Element
-import Mida.Language.Environment
+-- | State record used for calculation\/evaluation of principles.
data CalcSt = CalcSt
- { clcHistory :: [Int]
- , clcRandGen :: TFGen }
+ { clHistory :: [Natural] -- ^ Recently evaluated values
+ , clRandGen :: TFGen -- ^ Local random generator
+ } deriving Show
-newtype Calc a = Calc
- { unCalc :: State CalcSt a }
- deriving ( Functor
- , Applicative
- , Monad
- , MonadState CalcSt )
+-- | Evaluate definition given its name.
-evalDef :: Monad m => String -> MidaEnv m [Int]
+evalDef :: HasEnv m
+ => String -- ^ Reference name
+ -> m [Natural] -- ^ Infinite stream of naturals or empty list
evalDef name = getPrin name >>= eval
-eval :: Monad m => SyntaxTree -> MidaEnv m [Int]
+-- | Evaluate given syntax tree.
+
+eval :: HasEnv m
+ => SyntaxTree -- ^ Syntax tree
+ -> m [Natural] -- ^ Infinite stream of naturals or empty list
eval tree = liftM2 runCalc (resolve . cycle' <$> toPrin tree) newRandGen
where cycle' p = if null $ foldMap (:[]) (Sec p) then [] else cycle p
-resolve :: Principle -> Calc [Int]
+-- | Resolve principle into stream of naturals.
+
+resolve :: MonadState CalcSt m
+ => Principle -- ^ Principle in question
+ -> m [Natural] -- ^ Stream of naturals
resolve [] = return []
resolve xs = concat <$> mapM f xs
where f (Val x) = addHistory x >> return [x]
f (Sec x) = resolve x
f (Mul x) = choice x >>= maybe (return []) f
f (CMul x) = listToMaybe <$> filterM (matchHistory . fst) x >>=
- maybe (f . toMul $ x) (f . Mul . snd)
+ maybe (f . toMul $ x) (f . Mul . snd)
-runCalc :: Calc a -> TFGen -> a
-runCalc clc gen = evalState (unCalc clc)
- CalcSt { clcHistory = mempty
- , clcRandGen = gen }
+-- | Run lazy state monad with 'CalcSt' state.
-choice :: [a] -> Calc (Maybe a)
+runCalc
+ :: State CalcSt a -- ^ Monad to run
+ -> TFGen -- ^ Initial random generator
+ -> a -- ^ Result
+runCalc m gen = evalState m CalcSt
+ { clHistory = empty
+ , clRandGen = gen }
+
+-- | Random choice between given options.
+
+choice :: MonadState CalcSt m
+ => [a] -- ^ Options to choose from
+ -> m (Maybe a) -- ^ Result
choice [] = return Nothing
choice xs = do
- (n, g) <- next <$> gets clcRandGen
- modify $ \c -> c { clcRandGen = g }
+ (n, g) <- next <$> gets clRandGen
+ modify $ \c -> c { clRandGen = g }
return . Just $ xs !! (abs n `rem` length xs)
-condMatch :: [Int] -> Elt -> Bool
+-- | Check if given elements “matches” history of generated values. This
+-- is for conditional multivalues, see manual for more information.
+--
+-- Note: head of history is the most recently evaluated element.
+
+condMatch
+ :: [Natural] -- ^ History of already evaluated values
+ -> Element Natural -- ^ Element to test
+ -> Bool -- ^ Does it match the history?
condMatch [] _ = False
condMatch (h:_) (Val x) = h == x
condMatch hs (Sec x) = and $ zipWith condMatch (tails hs) (reverse x)
condMatch hs (Mul x) = or $ condMatch hs <$> x
condMatch hs (CMul x) = condMatch hs (toMul x)
-toMul :: [([Elt], [Elt])] -> Elt
+-- | Convert internals of conditional multivalue into plain multivalue.
+
+toMul
+ :: [([Element Natural], [Element Natural])] -- ^ Pattern\/result pairs
+ -> Element Natural -- ^ Internals of plain multivalue
toMul xs = Mul (xs >>= snd)
-matchHistory :: [Elt] -> Calc Bool
-matchHistory x = do
- hs <- gets clcHistory
- return . or $ condMatch hs <$> x
+-- | A monadic wrapper around 'condMatch'.
-addHistory :: Int -> Calc ()
-addHistory x = modify $ \c -> c { clcHistory = return x <> clcHistory c }
+matchHistory :: MonadState CalcSt m
+ => [Element Natural] -- ^ Stream of elements to test
+ -> m Bool -- ^ Do they match history?
+matchHistory xs = do
+ hs <- gets clHistory
+ return $ or (condMatch hs <$> xs)
-toPrin :: Monad m => SyntaxTree -> MidaEnv m Principle
+-- | Add evaluated value to history.
+
+addHistory :: MonadState CalcSt m => Natural -> m ()
+addHistory x = modify $ \c -> c { clHistory = return x <> clHistory c }
+
+-- | Transform 'SyntaxTree' into 'Principle' applying all necessary
+-- transformations and resolving references.
+
+toPrin :: HasEnv m
+ => SyntaxTree -- ^ Syntax tree to transform
+ -> m Principle -- ^ Resulting principle
toPrin = fmap simplifySec . toPrin'
+-- | Simplify section. There are several simple transformations that are
+-- proven to preserve the same resulting stream of naturals.
+
simplifySec :: Principle -> Principle
simplifySec = (>>= f)
where f (Sec xs) = simplifySec xs
f x = simplifyElt x
+-- | Basic simplification of principles.
+
simplify :: Principle -> Principle
simplify = (>>= simplifyElt)
-simplifyElt :: Elt -> Principle
+-- | Simplification of single element. Note that single element can produce
+-- several elements after simplification.
+
+simplifyElt :: Element Natural -> Principle
simplifyElt x@(Val _) = [x]
simplifyElt (Sec [x]) = simplify [x]
simplifyElt (Mul [x]) = simplify [x]
@@ -115,7 +164,11 @@
simplifyElt (Mul xs) = [Mul (simplify xs)]
simplifyElt (CMul xs) = [CMul ((simplify *** simplify) <$> xs)]
-toPrin' :: Monad m => SyntaxTree -> MidaEnv m Principle
+-- | The meat of the algorithm that transforms 'SyntaxTree' into 'Principle'.
+
+toPrin' :: HasEnv m
+ => SyntaxTree -- ^ Syntax tree to transform
+ -> m Principle -- ^ Resulting principle
toPrin' = fmap concat . mapM f
where
fPair (c, x) = (,) <$> toPrin' c <*> toPrin' x
@@ -138,29 +191,40 @@
adu _ [] = []
adu g (x:xs) = g x : xs
-sdiv :: Int -> Int -> Int
+-- | Saturated division.
+
+sdiv :: Natural -> Natural -> Natural
sdiv x 0 = x
sdiv x y = x `div` y
-sdif :: Int -> Int -> Int
+-- | Saturated subtraction.
+
+sdif :: Natural -> Natural -> Natural
sdif x y
| x < y = 0
| otherwise = x - y
-loop :: Elt -> Elt -> Principle
-loop x (Val y) = replicate y x
+-- | Concept of looping.
+
+loop :: Element Natural -> Element Natural -> Principle
+loop x (Val y) = replicate (fromIntegral y) x
loop x (Mul y) = [Mul $ Sec . loop x <$> y]
loop (Sec x) (Sec y) = [Sec . concat $ zipWith loop x (cycle y)]
loop (Mul x) (Sec y) = [Mul . concat $ zipWith loop x (cycle y)]
loop x _ = [x]
-rotate :: Elt -> Elt -> Elt
-rotate (Sec x) (Val y) = Sec $ zipWith const (drop y (cycle x)) x
+-- | Concept of rotation.
+
+rotate :: Element Natural -> Element Natural -> Element Natural
+rotate (Sec x) (Val y) =
+ Sec $ zipWith const (drop (fromIntegral y) (cycle x)) x
rotate x@(Sec _) (Mul y) = Mul $ rotate x <$> y
rotate (Sec x) (Sec y) = Sec $ zipWith rotate x (cycle y)
rotate x _ = x
-reverse' :: Elt -> Elt
+-- | Concept of reversion for elements.
+
+reverse' :: Element Natural -> Element Natural
reverse' x@(Val _) = x
reverse' (Mul x) = Mul $ reverse' <$> x
reverse' (Sec x) = Sec $ reverse $ reverse' <$> x
diff --git a/src/Mida/Language/SyntaxTree.hs b/src/Mida/Language/SyntaxTree.hs
--- a/src/Mida/Language/SyntaxTree.hs
+++ b/src/Mida/Language/SyntaxTree.hs
@@ -22,20 +22,28 @@
, Sel (..) )
where
+import Numeric.Natural
+
+-- | Syntax tree in our case is just a collection of syntactic elements.
+
type SyntaxTree = [Sel]
-data Sel -- syntactic element
- = Value Int
- | Section [Sel]
- | Multi [Sel]
- | CMulti [([Sel], [Sel])]
- | Reference String
- | Range Int Int
- | Product Sel Sel
- | Division Sel Sel
- | Sum Sel Sel
- | Diff Sel Sel
- | Loop Sel Sel
- | Rotation Sel Sel
- | Reverse Sel
+-- | Syntactic element corresponds to language features. Some of them have
+-- direct corresponding constructor in 'Mida.Language.Element.Element',
+-- others have to be simplified first.
+
+data Sel
+ = Value Natural -- ^ Literal value
+ | Section [Sel] -- ^ Section
+ | Multi [Sel] -- ^ Multivalue
+ | CMulti [([Sel], [Sel])] -- ^ Conditional multivalue
+ | Reference String -- ^ Reference (name of variable)
+ | Range Natural Natural -- ^ Range of values
+ | Product Sel Sel -- ^ Product of principles
+ | Division Sel Sel -- ^ Division of principles
+ | Sum Sel Sel -- ^ Sum of principles
+ | Diff Sel Sel -- ^ Subtraction of principles
+ | Loop Sel Sel -- ^ Loop
+ | Rotation Sel Sel -- ^ Rotation
+ | Reverse Sel -- ^ Reversed principle
deriving (Eq, Show)
diff --git a/src/Mida/Midi.hs b/src/Mida/Midi.hs
--- a/src/Mida/Midi.hs
+++ b/src/Mida/Midi.hs
@@ -17,6 +17,9 @@
-- You should have received a copy of the GNU General Public License along
-- with this program. If not, see .
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+
module Mida.Midi
( genMidi
, topDefs )
@@ -25,70 +28,111 @@
import Control.Monad.State.Strict
import Data.Foldable (foldl')
import Data.List (zipWith7)
-import Data.Maybe (listToMaybe)
+import Mida.Language (HasEnv, setRandGen, evalDef)
+import Numeric.Natural
import Prelude hiding (mod)
-
-import qualified Codec.Midi as M
+import qualified Codec.Midi as Midi
-import Mida.Language (MidaEnv, setRandGen, evalDef)
+-- | 'Batch' is collection of all parameters needed to generate complete
+-- MIDI track.
data Batch = Batch
- { btDur :: [Int]
- , btVel :: [Int]
- , btPch :: [Int]
- , _btMod :: Maybe [Int]
- , _btBth :: Maybe [Int]
- , _btAft :: Maybe [Int]
- , _btBnd :: Maybe [Int] }
+ { btDur :: [Int] -- ^ Duration stream
+ , btVel :: [Int] -- ^ Velocity stream
+ , btPch :: [Int] -- ^ Pitch stream
+ , _btMod :: Maybe [Int] -- ^ Optional modulation stream
+ , _btBth :: Maybe [Int] -- ^ Optional breath stream
+ , _btAft :: Maybe [Int] -- ^ Optional aftertouch stream
+ , _btBnd :: Maybe [Int] -- ^ Optional pitch bend stream
+ }
+-- | Apply transformation on all streams in 'Batch'.
+
infixl 4
() :: ([Int] -> [Int]) -> Batch -> Batch
f (Batch d v p m t a b) =
Batch (f d) (f v) (f p) (f <$> m) (f <$> t) (f <$> a) (f <$> b)
+-- | Modulation parameters. This defines how sound will be modulated (if at
+-- all).
+
data ModParams = ModParams
- { mpValue :: Int
- , mpFigure :: Int
- , mpDuration :: Int
- , mpChannel :: Int
- , mpProducer :: Int -> Int -> M.Message
- , mpUpBounds :: (Int, Int)
- , mpDnBounds :: (Int, Int) }
+ { mpValue :: !Int -- ^ Value or amplitude of modulation
+ , mpFigure :: !(Maybe Figure) -- ^ Figure or shape of modulation
+ , mpDuration :: !Int -- ^ Duration in ticks
+ , mpChannel :: !Int -- ^ Channel index
+ , mpProducer :: !(Int -> Int -> Midi.Message) -- ^ Producer function
+ , mpUpBounds :: !(Int, Int) -- ^ Boundaries for ascending modulation
+ , mpDnBounds :: !(Int, Int) -- ^ Boundaries for descending modulation
+ }
+-- | Modulation figures.
+
+data Figure
+ = FigStatic -- ^ Static: no modulation
+ | FigUpDown -- ^ First ascending and then descending
+ | FigDownUp -- ^ First descending and then ascending
+ | FigUp -- ^ Ascending for the whole duration
+ | FigDown -- ^ Descending for the whole duration
+ deriving (Eq, Show, Bounded, Enum)
+
+-- | Default modulation parameters.
+
modP :: ModParams
modP = ModParams
- { mpValue = 0
- , mpFigure = 0
- , mpDuration = 0
- , mpChannel = 0
- , mpProducer = flip M.ControlChange 1
- , mpUpBounds = (0x0000, 0x007f)
- , mpDnBounds = (0x007f, 0x0000) }
+ { mpValue = 0
+ , mpFigure = Just FigStatic
+ , mpDuration = 0
+ , mpChannel = 0
+ , mpProducer = flip Midi.ControlChange 1
+ , mpUpBounds = (0x0000, 0x007f)
+ , mpDnBounds = (0x007f, 0x0000) }
+-- | Default modulation parameters for breath modulation.
+
bthP :: ModParams
-bthP = modP { mpProducer = flip M.ControlChange 2 }
+bthP = modP
+ { mpProducer = flip Midi.ControlChange 2 }
+-- | Default modulation parameters for aftertouch modulation.
+
aftP :: ModParams
-aftP = modP { mpProducer = M.ChannelPressure }
+aftP = modP
+ { mpProducer = Midi.ChannelPressure }
+-- | Default modulation parameters for pitch bend modulation.
+
bndP :: ModParams
bndP = modP
- { mpProducer = M.PitchWheel
- , mpUpBounds = (0x2000, 0x3fff)
- , mpDnBounds = (0x2000, 0x0000) }
+ { mpProducer = Midi.PitchWheel
+ , mpUpBounds = (0x2000, 0x3fff)
+ , mpDnBounds = (0x2000, 0x0000) }
-type Track = M.Track Int
+-- | A synonym for what we use as track definition.
-genMidi :: Monad m => Int -> Int -> Int -> MidaEnv m M.Midi
-genMidi s q b = do
- setRandGen s
+type Track = Midi.Track Int
+
+-- | Generate MIDI file from MIDA environment.
+
+genMidi :: HasEnv m
+ => Natural -- ^ Seed for random generator
+ -> Natural -- ^ Q value: number of ticks per quarter note
+ -> Natural -- ^ Duration in number of quarter notes
+ -> m Midi.Midi -- ^ MIDI file
+genMidi seed q b = do
+ setRandGen seed
voices <- filter defined <$> mapM request [0..mvIndex]
- return M.Midi { M.fileType = M.MultiTrack
- , M.timeDiv = M.TicksPerBeat q
- , M.tracks = zipWith (toTrack . slice (b * q)) voices [0..] }
+ return Midi.Midi
+ { Midi.fileType = Midi.MultiTrack
+ , Midi.timeDiv = Midi.TicksPerBeat (fromIntegral q)
+ , Midi.tracks = zipWith (toTrack . slice (b * q)) voices [0..] }
-request :: Monad m => Int -> MidaEnv m Batch
+-- | Generate MIDI track given its index.
+
+request :: HasEnv m
+ => Natural -- ^ Track index
+ -> m Batch -- ^ 'Batch' for this track
request n = do
dur <- eval' defDur
vel <- eval' defVel
@@ -98,83 +142,142 @@
aft <- eval' defAft
bnd <- eval' defBnd
return $ Batch dur vel pch (f mod) (f bth) (f aft) (f bnd)
- where eval' name = evalDef $ name ++ show n
- f x = if null x then Nothing else Just x
+ where eval' name = fmap fromIntegral <$> evalDef (name ++ show n)
+ f x = if null x then Nothing else Just x
+-- | Check if all necessary components in a 'Batch' are defined.
+
defined :: Batch -> Bool
-defined Batch { btDur = d, btVel = v, btPch = p } = all (not . null) [d,v,p]
+defined Batch {..} = all (not . null) [btDur, btVel, btPch]
-slice :: Int -> Batch -> Batch
-slice t batch@Batch { btDur = dur } = take (f 0 0 dur) batch
- where f !i _ [] = i
+-- | Take some part (determined by number of ticks) of every
+-- infinite stream in 'Batch' making it finite.
+
+slice
+ :: Natural -- ^ Requested duration in ticks
+ -> Batch -- ^ 'Batch' of infinite streams
+ -> Batch -- ^ 'Batch' of finite streams
+slice t' batch@Batch {..} = take (f 0 0 btDur) batch
+ where t = fromIntegral t'
+ f !i _ [] = i
f !i !a (x:xs) = if x + a >= t then succ i else f (succ i) (x + a) xs
-toTrack :: Batch -> Int -> Track
+-- | Generate MIDI 'Track' from 'Batch'.
+
+toTrack
+ :: Batch -- ^ Batch
+ -> Int -- ^ Channel number
+ -> Track -- ^ Result track
toTrack (Batch d v p m t a b) i =
- concat (zipWith7 f d v p (r m) (r t) (r a) (r b)) ++ [(0, M.TrackEnd)]
- where r = maybe (repeat Nothing) (Just <$>)
+ concat (zipWith7 f d v p (r m) (r t) (r a) (r b)) ++ [(0, Midi.TrackEnd)]
+ where r = maybe (repeat Nothing) (fmap Just)
f d' v' p' m' t' a' b' =
- mixEvents
- [ figure m' d' i modP
- , figure t' d' i bthP
- , figure a' d' i aftP
- , figure b' d' i bndP
- , [(0, M.NoteOn i p' v'), (d', M.NoteOn i p' 0)] ]
+ mixEvents
+ [ figure m' d' i modP
+ , figure t' d' i bthP
+ , figure a' d' i aftP
+ , figure b' d' i bndP
+ , [ (0, Midi.NoteOn i p' v')
+ , (d', Midi.NoteOn i p' 0)] ]
+-- | Merge several tracks together. There is 'Codec.Midi.merge' thing, but
+-- I'm not sure it does it right, moreover it's not documented.
+
mixEvents :: [Track] -> Track
mixEvents = foldl' mixPair mempty
+-- | Merge just two tracks.
+
mixPair :: Track -> Track -> Track
mixPair [] xs = xs
mixPair xs [] = xs
mixPair (x:xs) (y:ys) = r : mixPair xs' ys'
where (r, xs', ys')
- | fst x <= fst y = (x, xs, f y (fst x) : ys)
- | otherwise = (y, f x (fst y) : xs, ys)
+ | fst x <= fst y = (x, xs, f y (fst x) : ys)
+ | otherwise = (y, f x (fst y) : xs, ys)
f (i, msg) c = (i - c, msg)
-figure :: Maybe Int -> Int -> Int -> ModParams -> Track
+-- | Generate track fragment representing modulation of one parameter.
+
+figure
+ :: Maybe Int -- ^ Raw modulation value, if present
+ -> Int -- ^ Duration in ticks of entire fragment
+ -> Int -- ^ Channel index
+ -> ModParams -- ^ Default modulation parameters
+ -> Track -- ^ Result fragment
figure Nothing _ _ _ = []
figure (Just raw) d ch p =
fig p { mpValue = v
, mpFigure = f
, mpDuration = d
, mpChannel = ch }
- where (f, v) = quotRem raw 128
+ where (fi, v) = quotRem raw 128
+ f | fi <= fromEnum (maxBound :: Figure) = Just (toEnum fi)
+ | otherwise = Nothing
+-- | Transform modulation parameters into fragment of 'Track'.
+
fig :: ModParams -> Track
fig ModParams { mpDuration = 0 } = []
fig (ModParams v f d ch p ub db) =
- maybe [] (zip (0 : repeat 1) . fmap (p ch)) (gen <*> return v)
- where gen = listToMaybe $ drop f -- generators:
- [ figStc ub -- static
- , figRtn ub d -- up & down
- , figRtn db d -- down & up
- , figLin ub d -- up
- , figLin db d ] -- down
+ let getGen x = case x of
+ FigStatic -> figStc ub
+ FigUpDown -> figRtn ub d
+ FigDownUp -> figRtn db d
+ FigUp -> figLin ub d
+ FigDown -> figLin db d
+ in maybe [] (zip (0 : repeat 1) . fmap (p ch)) (getGen <$> f <*> pure v)
-figStc :: (Int, Int) -> Int -> [Int]
+-- | Generate static stream of values.
+
+figStc
+ :: (Int, Int) -- ^ Beginning and end values
+ -> Int -- ^ Amplitude (from 0 to 127)
+ -> [Int] -- ^ Resulting stream
figStc be x = [draw be x 1]
-figRtn :: (Int, Int) -> Int -> Int -> [Int]
+-- | Generate “up-down” or “down-up” stream of values (i.e. “returning
+-- stream”).
+
+figRtn
+ :: (Int, Int) -- ^ Beginning and end values
+ -> Int -- ^ Total number of elements in stream
+ -> Int -- ^ Amplitude (from 0 to 127)
+ -> [Int] -- ^ Resulting stream
figRtn be q x = f <$> [0..l] ++ reverse [0..(q - l - 1)]
where f c = draw be (x * c) l
l = q `div` 2
-figLin :: (Int, Int) -> Int -> Int -> [Int]
+-- | Generate linear stream of values.
+
+figLin
+ :: (Int, Int) -- ^ Beginning and end values
+ -> Int -- ^ Total number of elements in stream
+ -> Int -- ^ Amplitude (from 0 to 127)
+ -> [Int] -- ^ Resulting stream
figLin be q x = f <$> [0..q]
where f c = draw be (x * c) q
-draw :: (Int, Int) -> Int -> Int -> Int
+-- | Calculate one point from stream of integer values.
+
+draw
+ :: (Int, Int) -- ^ Beginning and end values
+ -> Int -- ^ Numerator
+ -> Int -- ^ Denominator
+ -> Int -- ^ Value of this point
draw (b, e) n d = b + (n * (e - b)) `gdiv` (127 * d)
where x `gdiv` y = round (fromIntegral x / fromIntegral y :: Double)
+-- | Collection of “top-level” definitions.
+
topDefs :: [String]
-topDefs = [x ++ show n |
- x <- [defDur,defVel,defPch,defMod,defBth,defAft,defBnd],
- n <- [0..mvIndex]]
+topDefs =
+ [ x ++ show n | x <- [defDur,defVel,defPch,defMod,defBth,defAft,defBnd]
+ , n <- [0..mvIndex] ]
-mvIndex :: Int
+-- | Maximal voice index. @15@ means that we can have 16 voices total.
+
+mvIndex :: Natural
mvIndex = 15
defDur :: String
diff --git a/src/Mida/Representation/Base.hs b/src/Mida/Representation/Base.hs
--- a/src/Mida/Representation/Base.hs
+++ b/src/Mida/Representation/Base.hs
@@ -32,6 +32,8 @@
, modifiers )
where
+-- | All recognized note alias in ascending order.
+
noteAlias :: [String]
noteAlias = zipWith f names ([0..127] :: [Int])
where names = cycle ["c","cs","d","ds","e","f","fs","g","gs","a","as","b"]
@@ -66,6 +68,8 @@
defOp :: String
defOp = "="
+
+-- | Modifiers specifying how to modulate some parameters.
modifiers :: [String]
modifiers = ["_ud","_du","_u","_d"]
diff --git a/src/Mida/Representation/Parser.hs b/src/Mida/Representation/Parser.hs
--- a/src/Mida/Representation/Parser.hs
+++ b/src/Mida/Representation/Parser.hs
@@ -24,43 +24,54 @@
, parseMida )
where
-import Control.Applicative
+import Control.Applicative (empty)
import Control.Monad (void)
-import qualified Data.Text.Lazy as T
-
+import Data.Text.Lazy (Text)
+import Mida.Language.SyntaxTree (SyntaxTree, Sel (..))
+import Numeric.Natural
import Text.Megaparsec
import Text.Megaparsec.Expr
import Text.Megaparsec.Text.Lazy
+import qualified Data.Text.Lazy as T
+import qualified Mida.Representation.Base as B
import qualified Text.Megaparsec.Lexer as L
-import Mida.Language.SyntaxTree (SyntaxTree, Sel (..))
-import qualified Mida.Representation.Base as B
+-- | Statement can be either definition or exposition. Expositions are only
+-- used in REPL.
data Statement
= Definition String SyntaxTree
| Exposition SyntaxTree
deriving (Eq, Show)
-probeMida :: T.Text -> Bool
-probeMida txt = not $ or ["," `T.isSuffixOf` stripped
- , f ("[", "]")
- , f ("{", "}")
- , f ("<", ">")
- , f ("(", ")") ]
+-- | Test if given fragment of MIDA code is finished and self-contained.
+
+probeMida :: Text -> Bool
+probeMida txt = not $ or
+ ["," `T.isSuffixOf` stripped
+ , f ("[", "]")
+ , f ("{", "}")
+ , f ("<", ">")
+ , f ("(", ")") ]
where stripped = T.strip txt
f (x, y) = (&&) <$> (> 0) <*> (/= g y) $ g x
- g x = T.count x stripped
+ g x = T.count x stripped
-parseMida :: String -> T.Text -> Either String [Statement]
+-- | Entry point for MIDA parsing.
+
+parseMida
+ :: String -- ^ Name of file
+ -> Text -- ^ Text to parse
+ -> Either String [Statement] -- ^ Error message or parsed statements
parseMida file txt =
case parse parser file txt of
Right x -> if null x
- then Left $ '\"' : file ++ "\":\ninvalid definition syntax"
- else Right x
- Left x -> Left . show $ x
+ then Left ('\"' : file ++ "\":\ninvalid definition syntax")
+ else Right x
+ Left e -> Left (show e)
where parser = if T.pack B.defOp `T.isInfixOf` txt
- then pSource
- else return <$> pExposition
+ then pSource
+ else pure <$> pExposition
pSource :: Parser [Statement]
pSource = sc *> many pDefinition <* eof
@@ -83,13 +94,14 @@
pPrinciple = sepBy (pExpression <|> pElement) (optional comma)
pElement :: Parser Sel
-pElement = try pRange
- <|> pValue
- <|> try pReference
- <|> pSection
- <|> try pMulti
- <|> pCMulti
- "element"
+pElement
+ = try pRange
+ <|> pValue
+ <|> try pReference
+ <|> pSection
+ <|> try pMulti
+ <|> pCMulti
+ "element"
pRange :: Parser Sel
pRange = Range <$> pNatural <* pOperator B.rangeOp <*> pNatural
@@ -97,7 +109,7 @@
pValue :: Parser Sel
pValue = Value <$> pNatural
-pNatural :: Parser Int
+pNatural :: Parser Natural
pNatural = fromIntegral <$> natural "literal value"
pReference :: Parser Sel
@@ -135,7 +147,7 @@
brackets = between (symbol "[") (symbol "]")
comma :: Parser ()
-comma = void $ symbol ","
+comma = void . hidden . symbol $ ","
natural :: Parser Integer
natural = lexeme L.integer
diff --git a/src/Mida/Representation/Show.hs b/src/Mida/Representation/Show.hs
--- a/src/Mida/Representation/Show.hs
+++ b/src/Mida/Representation/Show.hs
@@ -28,31 +28,51 @@
import Control.Arrow ((***), (>>>))
import Data.List (intersperse)
import Data.Monoid ((<>))
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.Builder as T (Builder, fromString, toLazyText)
-import qualified Data.Text.Lazy.Builder.Int as T (decimal)
-
+import Data.Text.Lazy (Text)
import Mida.Language.Element
import Mida.Language.SyntaxTree
import Mida.Representation.Parser (Statement (..))
+import qualified Data.Text.Lazy.Builder as T (Builder, fromString, toLazyText)
+import qualified Data.Text.Lazy.Builder.Int as T (decimal)
import qualified Mida.Representation.Base as B
-showStatement :: Statement -> T.Text
+-- | Render a statement. This handles definitions and expositions.
+
+showStatement :: Statement -> Text
showStatement (Definition n t) = showDefinition n t
showStatement (Exposition t) = showSyntaxTree t
-showDefinition :: String -> SyntaxTree -> T.Text
+-- | Render definition.
+
+showDefinition
+ :: String -- ^ Reference name
+ -> SyntaxTree -- ^ Syntax tree
+ -> Text -- ^ Textual representation of definition
showDefinition n = T.toLazyText . showDefinition' n
-showSyntaxTree :: SyntaxTree -> T.Text
+-- | Render syntax tree.
+
+showSyntaxTree :: SyntaxTree -> Text
showSyntaxTree = T.toLazyText . showSyntaxTree'
-showPrinciple :: Principle -> T.Text
+-- | Show principle. This is useful for printing of simplified principles
+-- back to user. We can use the same pretty-printing algorithm as for syntax
+-- trees, but this requires us to perform transformation from 'Principle' to
+-- 'SyntaxTree', which is trivial.
+
+showPrinciple :: Principle -> Text
showPrinciple = showSyntaxTree . toSyntaxTree
-showDefinition' :: String -> SyntaxTree -> T.Builder
+-- | This is used by 'showDefinition'. It just creates lazy text builder.
+
+showDefinition'
+ :: String -- ^ Reference name
+ -> SyntaxTree -- ^ Syntax tree
+ -> T.Builder -- ^ Lazy text builder for this definition
showDefinition' n t = T.fromString n <> pad B.defOp <> showSyntaxTree' t
+-- | Convert syntax tree into lazy text builder.
+
showSyntaxTree' :: SyntaxTree -> T.Builder
showSyntaxTree' t = cm f t <> "\n"
where
@@ -79,12 +99,16 @@
f (Reverse x) = T.fromString B.reverseOp <> p x
c xs = "<" <> cm f xs <> "> "
+-- | Convert principle to syntax tree to show it.
+
toSyntaxTree :: Principle -> SyntaxTree
-toSyntaxTree = (f <$>)
+toSyntaxTree = fmap f
where f (Val x) = Value x
f (Sec x) = Section $ f <$> x
f (Mul x) = Multi $ f <$> x
f (CMul x) = CMulti $ (toSyntaxTree *** toSyntaxTree) <$> x
+
+-- | Pad given string with single space on both sides.
pad :: String -> T.Builder
pad op = " " <> T.fromString op <> " "