mida 0.4.5 → 0.4.6

raw patch · 17 files changed

+1090/−647 lines, 17 filesdep +exceptionsdep +formattingdep +pathdep −text-formatdep ~megaparsecdep ~midaPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: exceptions, formatting, path, temporary

Dependencies removed: text-format

Dependency ranges changed: megaparsec, mida

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +17/−9
• mida.cabal +105/−100
• src/Main.hs +53/−32
• src/Mida/Configuration.hs +24/−11
• src/Mida/Interaction.hs +53/−38
• src/Mida/Interaction/Base.hs +51/−100
• src/Mida/Interaction/Commands.hs +251/−130
• src/Mida/Language.hs +4/−6
• src/Mida/Language/Element.hs +14/−7
• src/Mida/Language/Environment.hs +131/−48
• src/Mida/Language/Eval.hs +107/−43
• src/Mida/Language/SyntaxTree.hs +22/−14
• src/Mida/Midi.hs +175/−72
• src/Mida/Representation/Base.hs +4/−0
• src/Mida/Representation/Parser.hs +39/−27
• src/Mida/Representation/Show.hs +34/−10

@@ -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;

@@ -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 

@@ -18,7 +18,7 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>.  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

@@ -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 <http://www.gnu.org/licenses/>.\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'

@@ -17,6 +17,9 @@ -- You should have received a copy of the GNU General Public License along -- with this program. If not, see <http://www.gnu.org/licenses/>. +{-# 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

@@ -19,52 +19,62 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>.  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

@@ -18,130 +18,81 @@ -- You should have received a copy of the GNU General Public License along -- with this program. If not, see <http://www.gnu.org/licenses/>. -{-# 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

@@ -18,6 +18,8 @@ -- You should have received a copy of the GNU General Public License along -- with this program. If not, see <http://www.gnu.org/licenses/>. +{-# 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

@@ -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)

@@ -18,22 +18,29 @@ -- You should have received a copy of the GNU General Public License along -- with this program. If not, see <http://www.gnu.org/licenses/>. +{-# 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

@@ -18,8 +18,11 @@ -- You should have received a copy of the GNU General Public License along -- with this program. If not, see <http://www.gnu.org/licenses/>. +{-# 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 (, [])

@@ -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

@@ -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)

@@ -17,6 +17,9 @@ -- You should have received a copy of the GNU General Public License along -- with this program. If not, see <http://www.gnu.org/licenses/>. +{-# 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

@@ -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"]

@@ -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

@@ -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 <> " "