mida 0.4.3 → 0.4.4
raw patch · 16 files changed
+461/−392 lines, 16 filesdep +megaparsecdep +randomdep +tf-randomdep −mersenne-random-pure64dep −parsecdep ~midasetup-changed
Dependencies added: megaparsec, random, tf-random
Dependencies removed: mersenne-random-pure64, parsec
Dependency ranges changed: mida
Files
- CHANGELOG.md +102/−0
- README.md +3/−3
- Setup.hs +4/−0
- mida.cabal +33/−10
- src/Main.hs +48/−50
- src/Mida/Configuration.hs +25/−44
- src/Mida/Interaction.hs +0/−2
- src/Mida/Language/Element.hs +13/−16
- src/Mida/Language/Environment.hs +51/−53
- src/Mida/Language/Eval.hs +45/−46
- src/Mida/Language/SyntaxTree.hs +16/−16
- src/Mida/Midi.hs +0/−2
- src/Mida/Representation/Base.hs +14/−14
- src/Mida/Representation/Parser.hs +68/−95
- src/Mida/Representation/Show.hs +0/−2
- tests/Main.hs +39/−39
+ CHANGELOG.md view
@@ -0,0 +1,102 @@+# History of changes++## MIDA 0.4.4++* cosmetic corrections in source code;++* switch to better libraries libraries.++## MIDA 0.4.3++* various corrections and cosmetic changes;++* improved printing of syntax trees;++* allow more flexible looping expressions.++## MIDA 0.4.2++* introduced simplifications on the level of internal language;++* changed default values of some parameters;++* some characters have been replaced with pretty Unicode symbols;++* improved manual.++## MIDA 0.4.1++* dramatically improved efficiency, now very long compositions can be+ quickly rendered;++* lexer: changed style of comments, shell-like comments adopted;++* changed alias of notes: dièse is written now as `s` not as `#`, so middle+ octave is: `c5`, `cs5`, `d5`, `ds5`, `e5`, etc.;++* now there are alias for all supported (in MIDI) pitches from 0 to 127,+ that is: from `c0` to `g10` (alias `c10` -- `g10` added);++* changed alias of modulation signs, reason for such change is purely+ technical -- all alias now are predefined definitions, rather than+ syntactic sugar, so all alias must be valid identifiers;++* identifiers can contain underline sign (`_`);++* arbitrary number of files can be specified for loading (from command line,+ as well as from interactive REPL);++* many purely technical changes that are difficult to explain concisely, but+ they should be mentioned, most important being addition of test suite and+ ability to generate source files from syntax trees;++* added command line options: `--license` and `--version`.++## MIDA 0.4.0++* fixed bug in batch mode;++* added tab completion based on contents of current input line, including+ completion of file names for some commands;++* detection and rejection of recursive definitions;++* improved interface;++* wholly refactored (and sometimes rewritten) code (it's finally+ sufficiently elegant);++* more intuitive logic of evaluation in some corner cases;++* optional displaying of simplified principles (for debug and educational+ purposes);++* ability to set tempo and program for preview;++* improved documentation.++## MIDA 0.3.0++* improved interface and parsing;++* added `:prv` and `:load` special commands;++* added additional parameters: modulation, breath, aftertouch, and pitch+ bend;++* fixed minor bugs.++## MIDA 0.2.0++* better command line experience: history, auto-completion and more;++* fixed bug with infinite translation of scores that consist of elements+ which have zero duration;++* introduced conception of sections;++* all operations have become fully polymorphic.++## MIDA 0.1.0++Initial release.
README.md view
@@ -1,7 +1,7 @@ # MIDA [](http://www.gnu.org/licenses/gpl-3.0.txt)-+[](https://hackage.haskell.org/package/mida) [](https://travis-ci.org/mrkkrp/mida) MIDA is a minimalistic declarative language for algorithmic generation of@@ -29,7 +29,7 @@ 3. Download and untar git repository of MIDA, or clone it: ```- $ git clone https://github.com/mrkkrp/mida.git master+ $ git clone https://github.com/mrkkrp/mida.git ``` 4. Go to the root directory of the repository and execute:@@ -65,7 +65,7 @@ See [MIDA Manual](https://mrkkrp.github.io/mida/) for more information. -## How to control any parameter of any instrument / plugin?+## 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
Setup.hs view
@@ -1,2 +1,6 @@+module Main (main) where+ import Distribution.Simple++main :: IO () main = defaultMain
mida.cabal view
@@ -18,7 +18,7 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>. name: mida-version: 0.4.3+version: 0.4.4 synopsis: Language for algorithmic generation of MIDI files description: @@ -51,7 +51,7 @@ copyright: Copyright © 2014, 2015 Mark Karpov category: Language build-type: Simple-extra-source-files: README.md+extra-source-files: README.md, CHANGELOG.md cabal-version: >= 1.10 library@@ -61,11 +61,22 @@ build-depends: HCodecs >= 0.5 , base >= 4.8 && < 5 , containers >= 0.5.5.1- , mersenne-random-pure64 >= 0.2.0.4+ , megaparsec == 4.* , mtl >= 2.1.3.1- , parsec >= 3.1.8+ , 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@@ -91,15 +102,26 @@ , directory >= 1.2.1.0 , filepath >= 1.3.0.2 , haskeline >= 0.7.1.3- , mersenne-random-pure64 >= 0.2.0.4- , mida >= 0.4.2+ , megaparsec == 4.*+ , mida >= 0.4.3 , mtl >= 2.1.3.1 , optparse-applicative >= 0.11.0.2- , parsec >= 3.1.8 , 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 default-language: Haskell2010 test-suite tests@@ -112,13 +134,14 @@ , QuickCheck >= 2.4 && < 3 , base >= 4.8 && < 5 , containers >= 0.5.5.1- , mersenne-random-pure64 >= 0.2.0.4- , mida >= 0.4.2+ , megaparsec == 4.*+ , mida >= 0.4.3 , mtl >= 2.1.3.1- , parsec >= 3.1.8+ , 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
src/Main.hs view
@@ -17,8 +17,6 @@ -- 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 OverloadedStrings #-}- module Main (main) where import Control.Monad@@ -34,69 +32,69 @@ import Mida.Interaction data Opts = Opts- { opInterac :: Bool- , opSeed :: Int- , opQuarter :: Int- , opBeats :: Int- , opOutput :: String- , opLicense :: Bool- , opVersion :: Bool- , opFiles :: [String] }+ { opInterac :: Bool+ , opSeed :: Int+ , opQuarter :: Int+ , opBeats :: Int+ , opOutput :: String+ , opLicense :: Bool+ , opVersion :: Bool+ , opFiles :: [String] } main :: IO () main = execParser opts >>= f- where f Opts { opLicense = True } = T.putStr license- f Opts { opVersion = True } = F.print "MIDA {}\n" (F.Only version)- f Opts { opFiles = [] } = g $ interaction version- f Opts { opInterac = True- , opFiles = ns } = g $ cmdLoad ns >> interaction version- 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- version = "0.4.3"+ where f Opts { opLicense = True } = T.putStr license+ f Opts { opVersion = True } = F.print "MIDA {}\n" (F.Only version)+ f Opts { opFiles = [] } = g $ interaction version+ f Opts { opInterac = True+ , opFiles = ns } = g $ cmdLoad ns >> interaction version+ 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+ version = "0.4.4" notice :: T.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"+ "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 license =- "MIDA — realization of MIDA, language for generation of MIDI files.\n\- \Copyright © 2014, 2015 Mark Karpov\n\- \\n\- \MIDA is free software: you can redistribute it and/or modify it under the\n\- \terms of the GNU General Public License as published by the Free Software\n\- \Foundation, either version 3 of the License, or (at your option) any\n\- \later version.\n\- \\n\- \MIDA is distributed in the hope that it will be useful, but WITHOUT ANY\n\- \WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS\n\- \FOR A PARTICULAR PURPOSE. See the GNU General Public License for more\n\- \details.\n\- \\n\- \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"+ "MIDA — realization of MIDA, language for generation of MIDI files.\n\+ \Copyright © 2014, 2015 Mark Karpov\n\+ \\n\+ \MIDA is free software: you can redistribute it and/or modify it under the\n\+ \terms of the GNU General Public License as published by the Free Software\n\+ \Foundation, either version 3 of the License, or (at your option) any\n\+ \later version.\n\+ \\n\+ \MIDA is distributed in the hope that it will be useful, but WITHOUT ANY\n\+ \WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS\n\+ \FOR A PARTICULAR PURPOSE. See the GNU General Public License for more\n\+ \details.\n\+ \\n\+ \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 params <- loadConfig wdir <- getCurrentDirectory void $ runMidaInt e- MidaSt { stPrevLen = lookupCfg params "prvlen" 18- , stSrcFile = lookupCfg params "src" wdir </> "foo.da"- , stProg = lookupCfg params "prog" 0- , stTempo = lookupCfg params "tempo" 120 }- MidaCfg { cfgPrompt = lookupCfg params "prompt" "> "- , cfgVerbose = lookupCfg params "verbose" True- , cfgPrvCmd = lookupCfg params "prvcmd" "timidity"- , cfgProgOp = lookupCfg params "progop" "--force-program"- , cfgTempoOp = lookupCfg params "tempop" "--adjust-tempo" }+ MidaSt { stPrevLen = lookupCfg params "prvlen" 18+ , stSrcFile = lookupCfg params "src" wdir </> "foo.da"+ , stProg = lookupCfg params "prog" 0+ , stTempo = lookupCfg params "tempo" 120 }+ MidaCfg { cfgPrompt = lookupCfg params "prompt" "> "+ , cfgVerbose = lookupCfg params "verbose" True+ , cfgPrvCmd = lookupCfg params "prvcmd" "timidity"+ , cfgProgOp = lookupCfg params "progop" "--force-program"+ , cfgTempoOp = lookupCfg params "tempop" "--adjust-tempo" } loadConfig :: IO Params loadConfig = do
src/Mida/Configuration.hs view
@@ -17,25 +17,21 @@ -- 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 , lookupCfg ) where -import Data.Char (isSpace)-import Data.Functor.Identity+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 Text.Parsec-import Text.Parsec.Language-import Text.Parsec.Text.Lazy-import qualified Text.Parsec.Token as Token+import Text.Megaparsec+import Text.Megaparsec.Text.Lazy+import qualified Text.Megaparsec.Lexer as L type Params = M.Map String String @@ -53,52 +49,37 @@ parseValue "false" = Just False parseValue _ = Nothing +lookupCfg :: Parsable a => Params -> String -> a -> a+lookupCfg cfg v d = fromMaybe d $ M.lookup v cfg >>= parseValue++parseNum :: (Num a, Read a) => String -> Maybe a+parseNum = fmap fst . listToMaybe . reads+ parseConfig :: String -> T.Text -> Either String Params parseConfig file = either (Left . show) Right . parse pConfig file pConfig :: Parser Params-pConfig = M.fromList <$> (whiteSpace *> many pItem <* eof)+pConfig = M.fromList <$> (sc *> many pItem <* eof) pItem :: Parser (String, String)-pItem = (,) <$> identifier <* reservedOp "=" <*> (pString <|> pThing)--pThing :: Parser String-pThing = lexeme $ many (satisfy $ not . isSpace)--lookupCfg :: Parsable a => Params -> String -> a -> a-lookupCfg cfg v d = fromMaybe d $ M.lookup v cfg >>= parseValue--lang :: GenLanguageDef T.Text () Identity-lang = Token.LanguageDef- { Token.commentStart = ""- , Token.commentEnd = ""- , Token.commentLine = "#"- , Token.nestedComments = True- , Token.identStart = letter <|> char '_'- , Token.identLetter = alphaNum <|> char '_'- , Token.opStart = Token.opLetter lang- , Token.opLetter = oneOf "="- , Token.reservedNames = ["true", "false"]- , Token.reservedOpNames = ["="]- , Token.caseSensitive = True }+pItem = (,) <$> pIdentifier <* pOperator "=" <*> (pString <|> pThing) -lexer :: Token.GenTokenParser T.Text () Identity-lexer = Token.makeTokenParser lang+pIdentifier :: Parser String+pIdentifier = lexeme $ (:) <$> first <*> many other+ where first = letterChar <|> char '_'+ other = alphaNumChar <|> char '_' -identifier :: Parser String-identifier = Token.identifier lexer+pOperator :: String -> Parser String+pOperator = lexeme . string pString :: Parser String-pString = Token.stringLiteral lexer+pString = lexeme $ char '"' >> manyTill L.charLiteral (char '"') -reservedOp :: String -> Parser ()-reservedOp = Token.reservedOp lexer+pThing :: Parser String+pThing = lexeme $ some alphaNumChar lexeme :: Parser a -> Parser a-lexeme = Token.lexeme lexer--whiteSpace :: Parser ()-whiteSpace = Token.whiteSpace lexer+lexeme = L.lexeme sc -parseNum :: (Num a, Read a) => String -> Maybe a-parseNum = fmap fst . listToMaybe . reads+sc :: Parser ()+sc = L.space (void spaceChar) (L.skipLineComment "#") empty
src/Mida/Interaction.hs view
@@ -18,8 +18,6 @@ -- 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 OverloadedStrings #-}- module Mida.Interaction ( MidaIO , MidaInt
src/Mida/Language/Element.hs view
@@ -18,13 +18,10 @@ -- 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 DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}- module Mida.Language.Element- ( Principle- , Elt- , Element (..) )+ ( Principle+ , Elt+ , Element (..) ) where import Control.Arrow ((***))@@ -33,15 +30,15 @@ type Elt = Element Int data Element a- = Val a- | Sec [Element a]- | Mul [Element a]- | CMul [([Element a], [Element a])]- deriving (Eq, Show, Functor, Foldable)+ = Val a+ | Sec [Element a]+ | Mul [Element a]+ | CMul [([Element a], [Element a])]+ deriving (Eq, Show, Functor, Foldable) instance Applicative Element where- pure = Val- (Val f) <*> x = f <$> x- (Sec f) <*> x = Sec $ (<*> x) <$> f- (Mul f) <*> x = Mul $ (<*> x) <$> f- (CMul f) <*> x = CMul $ (((<*> x) <$>) *** ((<*> x) <$>)) <$> f+ pure = Val+ (Val f) <*> x = f <$> x+ (Sec f) <*> x = Sec $ (<*> x) <$> f+ (Mul f) <*> x = Mul $ (<*> x) <$> f+ (CMul f) <*> x = CMul $ (((<*> x) <$>) *** ((<*> x) <$>)) <$> f
src/Mida/Language/Environment.hs view
@@ -18,65 +18,63 @@ -- 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 #-}-{-# LANGUAGE TupleSections #-}- module Mida.Language.Environment- ( MidaEnv (..)- , runMidaEnv- , addDef- , remDef- , clearDefs- , getPrin- , getSrc- , fullSrc- , getRefs- , purgeEnv- , checkRecur- , setRandGen- , newRandGen )+ ( MidaEnv (..)+ , runMidaEnv+ , addDef+ , remDef+ , clearDefs+ , getPrin+ , getSrc+ , fullSrc+ , getRefs+ , purgeEnv+ , checkRecur+ , setRandGen+ , newRandGen ) where import Control.Arrow ((***), (>>>)) import Control.Monad.State.Strict 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.Mersenne.Pure64+import System.Random.TF (TFGen, mkTFGen) import Mida.Language.SyntaxTree import Mida.Representation.Base (noteAlias, modifiers) import Mida.Representation.Show (showDefinition) data MidaEnvSt = MidaEnvSt- { stDefs :: Defs- , stRandGen :: PureMT }+ { stDefs :: Defs+ , stRandGen :: TFGen } type Defs = M.Map String SyntaxTree newtype MidaEnv m a = MidaEnv- { unMidaEnv :: StateT MidaEnvSt m a }- deriving ( Functor- , Applicative- , Monad- , MonadState MidaEnvSt- , MonadTrans- , MonadIO )+ { unMidaEnv :: StateT MidaEnvSt m a }+ deriving ( Functor+ , Applicative+ , Monad+ , MonadState MidaEnvSt+ , MonadTrans+ , MonadIO ) runMidaEnv :: Monad m => MidaEnv m a -> m a runMidaEnv e = evalStateT (unMidaEnv e) MidaEnvSt { stDefs = defaultDefs- , stRandGen = pureMT 0 }+ , stRandGen = mkTFGen 0 } defaultDefs :: Defs defaultDefs = M.fromList $ zip noteAlias (f <$> [0..])- <> zip modifiers (f <$> [128,256..])- where f = return . Value+ <> zip modifiers (f <$> [128,256..])+ where f = return . Value getDefs :: Monad m => MidaEnv m Defs-getDefs = stDefs <$> get+getDefs = gets stDefs setDefs :: Monad m => Defs -> MidaEnv m () setDefs x = modify $ \e -> e { stDefs = x }@@ -104,39 +102,39 @@ tDefs :: String -> Defs -> [String] tDefs name defs = maybe mzero cm $ name `M.lookup` defs- where cm = (>>= f)- f (Value _) = mempty- f (Section x) = cm x- f (Multi x) = cm x- f (CMulti x) = x >>= (cm *** cm >>> uncurry (<>))- f (Reference x) = return x <> tDefs x defs- f (Range _ _) = mempty- f (Product x y) = f x <> f y- f (Division x y) = f x <> f y- f (Sum x y) = f x <> f y- f (Diff x y) = f x <> f y- f (Loop x y) = f x <> f y- f (Rotation x y) = f x <> f y- f (Reverse x) = f x+ where cm = (>>= f)+ f (Value _) = mempty+ f (Section x) = cm x+ f (Multi x) = cm x+ f (CMulti x) = x >>= (cm *** cm >>> uncurry (<>))+ f (Reference x) = return x <> tDefs x defs+ f (Range _ _) = mempty+ f (Product x y) = f x <> f y+ f (Division x y) = f x <> f y+ f (Sum x y) = f x <> f y+ f (Diff x y) = f x <> f y+ f (Loop x y) = f x <> f y+ 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]- ms = M.unions . fmap toDefs . zipWith tDefs tops . repeat- ts = toDefs tops+ 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 checkRecur name tree = check <$> getDefs- where check = elem name . tDefs name . M.insert name tree+ where check = elem name . tDefs name . M.insert name tree setRandGen :: Monad m => Int -> MidaEnv m ()-setRandGen x = modify $ \e -> e { stRandGen = pureMT (fromIntegral x) }+setRandGen x = modify $ \e -> e { stRandGen = mkTFGen x } -newRandGen :: Monad m => MidaEnv m PureMT+newRandGen :: Monad m => MidaEnv m TFGen newRandGen = do- (n, g) <- (randomWord64 . stRandGen) <$> get- modify $ \e -> e { stRandGen = pureMT n }- return . pureMT . fst . randomWord64 $ g+ (g, g') <- split <$> gets stRandGen+ modify $ \e -> e { stRandGen = g' }+ return g toDefs :: [String] -> Defs toDefs = M.fromList . fmap (, [])
src/Mida/Language/Eval.hs view
@@ -19,12 +19,10 @@ -- 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.Eval- ( evalDef- , eval- , toPrin )+ ( evalDef+ , eval+ , toPrin ) where import Control.Arrow ((***))@@ -32,41 +30,42 @@ import Data.List (tails) import Data.Maybe (listToMaybe) import Data.Monoid ((<>))+import System.Random (next) -import System.Random.Mersenne.Pure64+import System.Random.TF (TFGen) import Mida.Language.SyntaxTree import Mida.Language.Element import Mida.Language.Environment data CalcSt = CalcSt- { clcHistory :: [Int]- , clcRandGen :: PureMT }+ { clcHistory :: [Int]+ , clcRandGen :: TFGen } newtype Calc a = Calc- { unCalc :: State CalcSt a }- deriving ( Functor- , Applicative- , Monad- , MonadState CalcSt )+ { unCalc :: State CalcSt a }+ deriving ( Functor+ , Applicative+ , Monad+ , MonadState CalcSt ) evalDef :: Monad m => String -> MidaEnv m [Int] evalDef name = getPrin name >>= eval eval :: Monad m => SyntaxTree -> MidaEnv m [Int] eval tree = liftM2 runCalc (resolve . cycle' <$> toPrin tree) newRandGen- where cycle' p = if null $ foldMap (:[]) (Sec p) then [] else cycle p+ where cycle' p = if null $ foldMap (:[]) (Sec p) then [] else cycle p resolve :: Principle -> Calc [Int] 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)+ 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) -runCalc :: Calc a -> PureMT -> a+runCalc :: Calc a -> TFGen -> a runCalc clc gen = evalState (unCalc clc) CalcSt { clcHistory = mempty , clcRandGen = gen }@@ -74,7 +73,7 @@ choice :: [a] -> Calc (Maybe a) choice [] = return Nothing choice xs = do- (n, g) <- randomInt . clcRandGen <$> get+ (n, g) <- next <$> gets clcRandGen modify $ \c -> c { clcRandGen = g } return . Just $ xs !! (abs n `rem` length xs) @@ -90,7 +89,7 @@ matchHistory :: [Elt] -> Calc Bool matchHistory x = do- hs <- clcHistory <$> get+ hs <- gets clcHistory return . or $ condMatch hs <$> x addHistory :: Int -> Calc ()@@ -101,8 +100,8 @@ simplifySec :: Principle -> Principle simplifySec = (>>= f)- where f (Sec xs) = simplifySec xs- f x = simplifyElt x+ where f (Sec xs) = simplifySec xs+ f x = simplifyElt x simplify :: Principle -> Principle simplify = (>>= simplifyElt)@@ -118,26 +117,26 @@ toPrin' :: Monad m => SyntaxTree -> MidaEnv m Principle toPrin' = fmap concat . mapM f- where- fPair (c, x) = (,) <$> toPrin' c <*> toPrin' x- f (Value x) = return . Val <$> return x- f (Section xs) = return . Sec <$> toPrin' xs- f (Multi xs) = return . Mul <$> toPrin' xs- f (CMulti xs) = return . CMul <$> mapM fPair xs- f (Reference x) = getPrin x >>= toPrin'- f (Range x y) = return $ Val <$> if x > y then [x,x-1..y] else [x..y]- f (Product x y) = adb (\a b -> [(*) <$> a <*> b]) <$> f x <*> f y- f (Division x y) = adb (\a b -> [sdiv <$> a <*> b]) <$> f x <*> f y- f (Sum x y) = adb (\a b -> [(+) <$> a <*> b]) <$> f x <*> f y- f (Diff x y) = adb (\a b -> [sdif <$> a <*> b]) <$> f x <*> f y- f (Loop x y) = adb loop <$> f x <*> f y- f (Rotation x y) = adb (\a b -> [rotate a b]) <$> f x <*> f y- f (Reverse x) = adu reverse' <$> f x- adb _ [] _ = []- adb _ xs [] = xs- adb g xs (y:ys) = init xs ++ g (last xs) y ++ ys- adu _ [] = []- adu g (x:xs) = g x : xs+ where+ fPair (c, x) = (,) <$> toPrin' c <*> toPrin' x+ f (Value x) = return . Val <$> return x+ f (Section xs) = return . Sec <$> toPrin' xs+ f (Multi xs) = return . Mul <$> toPrin' xs+ f (CMulti xs) = return . CMul <$> mapM fPair xs+ f (Reference x) = getPrin x >>= toPrin'+ f (Range x y) = return $ Val <$> if x > y then [x,x-1..y] else [x..y]+ f (Product x y) = adb (\a b -> [(*) <$> a <*> b]) <$> f x <*> f y+ f (Division x y) = adb (\a b -> [sdiv <$> a <*> b]) <$> f x <*> f y+ f (Sum x y) = adb (\a b -> [(+) <$> a <*> b]) <$> f x <*> f y+ f (Diff x y) = adb (\a b -> [sdif <$> a <*> b]) <$> f x <*> f y+ f (Loop x y) = adb loop <$> f x <*> f y+ f (Rotation x y) = adb (\a b -> [rotate a b]) <$> f x <*> f y+ f (Reverse x) = adu reverse' <$> f x+ adb _ [] _ = []+ adb _ xs [] = xs+ adb g xs (y:ys) = init xs ++ g (last xs) y ++ ys+ adu _ [] = []+ adu g (x:xs) = g x : xs sdiv :: Int -> Int -> Int sdiv x 0 = x@@ -145,8 +144,8 @@ sdif :: Int -> Int -> Int sdif x y- | x < y = 0- | otherwise = x - y+ | x < y = 0+ | otherwise = x - y loop :: Elt -> Elt -> Principle loop x (Val y) = replicate y x
src/Mida/Language/SyntaxTree.hs view
@@ -18,24 +18,24 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>. module Mida.Language.SyntaxTree- ( SyntaxTree- , Sel (..) )+ ( SyntaxTree+ , Sel (..) ) where 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- deriving (Eq, Show)+ = 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+ deriving (Eq, Show)
src/Mida/Midi.hs view
@@ -17,8 +17,6 @@ -- 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 #-}- module Mida.Midi ( genMidi , topDefs )
src/Mida/Representation/Base.hs view
@@ -18,24 +18,24 @@ -- with this program. If not, see <http://www.gnu.org/licenses/>. module Mida.Representation.Base- ( noteAlias- , commentLine- , productOp- , divisionOp- , sumOp- , diffOp- , loopOp- , rotationOp- , reverseOp- , rangeOp- , defOp- , modifiers )+ ( noteAlias+ , commentLine+ , productOp+ , divisionOp+ , sumOp+ , diffOp+ , loopOp+ , rotationOp+ , reverseOp+ , rangeOp+ , defOp+ , modifiers ) where noteAlias :: [String] noteAlias = zipWith f names ([0..127] :: [Int])- where names = cycle ["c","cs","d","ds","e","f","fs","g","gs","a","as","b"]- f n i = n ++ show (i `div` 12)+ where names = cycle ["c","cs","d","ds","e","f","fs","g","gs","a","as","b"]+ f n i = n ++ show (i `div` 12) commentLine :: String commentLine = "#"
src/Mida/Representation/Parser.hs view
@@ -18,78 +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/>. -{-# LANGUAGE OverloadedStrings #-}- module Mida.Representation.Parser- ( Statement (..)- , probeMida- , parseMida )+ ( Statement (..)+ , probeMida+ , parseMida ) where +import Control.Applicative import Control.Monad (void)-import Data.Functor.Identity-import Data.List (nub) import qualified Data.Text.Lazy as T -import Text.Parsec-import Text.Parsec.Expr-import Text.Parsec.Language-import Text.Parsec.Text.Lazy-import qualified Text.Parsec.Token as Token+import Text.Megaparsec+import Text.Megaparsec.Expr+import Text.Megaparsec.Text.Lazy+import qualified Text.Megaparsec.Lexer as L import Mida.Language.SyntaxTree (SyntaxTree, Sel (..)) import qualified Mida.Representation.Base as B data Statement- = Definition String SyntaxTree- | Exposition SyntaxTree- deriving (Eq, Show)+ = Definition String SyntaxTree+ | Exposition SyntaxTree+ deriving (Eq, Show) probeMida :: T.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+ , f ("[", "]")+ , f ("{", "}")+ , f ("<", ">")+ , f ("(", ")") ]+ where stripped = T.strip txt+ f (x, y) = (&&) <$> (> 0) <*> (/= g y) $ g x+ g x = T.count x stripped parseMida :: String -> T.Text -> Either String [Statement] 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- where parser = if T.pack B.defOp `T.isInfixOf` txt- then pSource- else return <$> pExposition+ 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+ where parser = if T.pack B.defOp `T.isInfixOf` txt+ then pSource+ else return <$> pExposition pSource :: Parser [Statement]-pSource = whiteSpace *> many pDefinition <* eof+pSource = sc *> many pDefinition <* eof pDefinition :: Parser Statement-pDefinition = Definition <$> identifier <* reservedOp B.defOp <*> pPrinciple+pDefinition = Definition <$> pIdentifier <* pOperator B.defOp <*> pPrinciple pExposition :: Parser Statement-pExposition = Exposition <$> (whiteSpace *> pPrinciple <* eof)+pExposition = Exposition <$> (sc *> pPrinciple <* eof) +pIdentifier :: Parser String+pIdentifier = lexeme $ (:) <$> first <*> many other+ where first = letterChar <|> char '_'+ other = alphaNumChar <|> char '_'++pOperator :: String -> Parser String+pOperator = lexeme . string+ pPrinciple :: Parser SyntaxTree 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 <* reservedOp B.rangeOp <*> pNatural+pRange = Range <$> pNatural <* pOperator B.rangeOp <*> pNatural pValue :: Parser Sel pValue = Value <$> pNatural@@ -98,7 +101,7 @@ pNatural = fromIntegral <$> natural <?> "literal value" pReference :: Parser Sel-pReference = Reference <$> identifier <* notFollowedBy (reservedOp B.defOp)+pReference = Reference <$> pIdentifier <* notFollowedBy (pOperator B.defOp) pSection :: Parser Sel pSection = Section <$> brackets pPrinciple@@ -110,71 +113,41 @@ pCMulti = CMulti <$> braces (many $ (,) <$> angles pPrinciple <*> pPrinciple) pExpression :: Parser Sel-pExpression = buildExpressionParser optTable (parens pExpression <|> pElement)- <?> "expression"+pExpression = makeExprParser (parens pExpression <|> pElement) optTable -optTable :: [[Operator T.Text () Identity Sel]]+optTable :: [[Operator Parser Sel]] optTable =- [[ Prefix (reservedOp B.reverseOp *> pure Reverse ) ]- , [ Infix (reservedOp B.productOp *> pure Product ) AssocLeft- , Infix (reservedOp B.divisionOp *> pure Division) AssocLeft- , Infix (reservedOp B.sumOp *> pure Sum ) AssocLeft- , Infix (reservedOp B.diffOp *> pure Diff ) AssocLeft- , Infix (reservedOp B.loopOp *> pure Loop ) AssocLeft- , Infix (reservedOp B.rotationOp *> pure Rotation) AssocLeft ]]--lang :: GenLanguageDef T.Text () Identity-lang = Token.LanguageDef- { Token.commentStart = ""- , Token.commentEnd = ""- , Token.commentLine = B.commentLine- , Token.nestedComments = True- , Token.identStart = letter <|> char '_'- , Token.identLetter = alphaNum <|> char '_'- , Token.opStart = Token.opLetter lang- , Token.opLetter = oneOf . nub . concat $ langOps- , Token.reservedOpNames = langOps- , Token.reservedNames = []- , Token.caseSensitive = True }--langOps :: [String]-langOps =- [ B.productOp- , B.divisionOp- , B.sumOp- , B.diffOp- , B.loopOp- , B.rotationOp- , B.reverseOp- , B.rangeOp- , B.defOp ]--lexer :: Token.GenTokenParser T.Text () Identity-lexer = Token.makeTokenParser lang+ [[ Prefix (pOperator B.reverseOp *> pure Reverse ) ]+ , [ InfixL (pOperator B.productOp *> pure Product )+ , InfixL (pOperator B.divisionOp *> pure Division)+ , InfixL (pOperator B.sumOp *> pure Sum )+ , InfixL (pOperator B.diffOp *> pure Diff )+ , InfixL (pOperator B.loopOp *> pure Loop )+ , InfixL (pOperator B.rotationOp *> pure Rotation) ]] angles :: Parser a -> Parser a-angles = Token.angles lexer+angles = between (symbol "<") (symbol ">") braces :: Parser a -> Parser a-braces = Token.braces lexer+braces = between (symbol "{") (symbol "}") brackets :: Parser a -> Parser a-brackets = Token.brackets lexer+brackets = between (symbol "[") (symbol "]") comma :: Parser ()-comma = void $ Token.comma lexer--identifier :: Parser String-identifier = Token.identifier lexer+comma = void $ symbol "," natural :: Parser Integer-natural = Token.natural lexer+natural = lexeme L.integer parens :: Parser a -> Parser a-parens = Token.parens lexer+parens = between (symbol "(") (symbol ")") -reservedOp :: String -> Parser ()-reservedOp = Token.reservedOp lexer+symbol :: String -> Parser String+symbol = L.symbol sc -whiteSpace :: Parser ()-whiteSpace = Token.whiteSpace lexer+lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++sc :: Parser ()+sc = L.space (void spaceChar) (L.skipLineComment "#") empty
src/Mida/Representation/Show.hs view
@@ -18,8 +18,6 @@ -- 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 OverloadedStrings #-}- module Mida.Representation.Show ( showStatement , showDefinition
tests/Main.hs view
@@ -38,63 +38,63 @@ import Mida.Language (Sel (..)) import Mida.Representation- ( Statement (..)- , probeMida- , parseMida- , showStatement )+ ( Statement (..)+ , probeMida+ , parseMida+ , showStatement ) main :: IO () main = defaultMain tests tests :: [Test] tests =- [ testGroup "Printer and Parser"- [ testProperty "Valid MIDA Probe" prop_valid_probe- , testProperty "Printer and Parser Consistency" prop_pp_consistency ] ]+ [ testGroup "Printer and Parser"+ [ testProperty "Valid MIDA Probe" prop_valid_probe+ , testProperty "Printer and Parser Consistency" prop_pp_consistency ] ] prop_valid_probe :: Statement -> Bool prop_valid_probe = probeMida . showStatement prop_pp_consistency :: Statement -> Bool prop_pp_consistency = id &&& (parseMida "" . showStatement) >>> check- where check (x, Right [y]) = x == y- check _ = False+ where check (x, Right [y]) = x == y+ check _ = False instance Arbitrary Statement where- arbitrary =- oneof [ Definition <$> alphaNumIdentifier <*> arbitrary- , Exposition <$> arbitrary ]+ arbitrary =+ oneof [ Definition <$> identifier <*> arbitrary+ , Exposition <$> arbitrary ] instance Arbitrary Sel where- arbitrary = sized arbitrarySel+ arbitrary = sized arbitrarySel arbitrarySel :: Int -> Gen Sel arbitrarySel 0 =- oneof [ Value <$> positive- , Reference <$> alphaNumIdentifier- , Range <$> positive <*> positive ]- where positive = arbitrary `suchThat` (>= 0)+ oneof [ Value <$> nonNegative+ , Reference <$> identifier+ , Range <$> nonNegative <*> nonNegative ]+ where nonNegative = getNonNegative <$> arbitrary arbitrarySel n =- oneof [ Section <$> listSel- , Multi <$> listSel- , CMulti <$> listCnd- , Product <$> leafSel <*> leafSel- , Division <$> leafSel <*> leafSel- , Sum <$> leafSel <*> leafSel- , Diff <$> leafSel <*> leafSel- , Loop <$> leafSel <*> leafSel- , Rotation <$> leafSel <*> leafSel- , Reverse <$> leafSel ]- where cnSel d = arbitrarySel (n `div` d)- vcSel d = arbitrarySizedIntegral `suchThat` (>= 0)- >>= \s -> vectorOf s (cnSel $ d * s)- leafSel = cnSel 2- listSel = vcSel 1- listCnd = arbitrarySizedIntegral `suchThat` (>= 1)- >>= \s -> vectorOf s $ (,) <$> vcSel s <*> vcSel s+ oneof [ Section <$> listSel+ , Multi <$> listSel+ , CMulti <$> listCnd+ , Product <$> leafSel <*> leafSel+ , Division <$> leafSel <*> leafSel+ , Sum <$> leafSel <*> leafSel+ , Diff <$> leafSel <*> leafSel+ , Loop <$> leafSel <*> leafSel+ , Rotation <$> leafSel <*> leafSel+ , Reverse <$> leafSel ]+ where cnSel d = arbitrarySel (n `div` d)+ vcSel d = (getNonNegative <$> arbitrary)+ >>= \s -> vectorOf s (cnSel $ d * s)+ leafSel = cnSel 2+ listSel = vcSel 1+ listCnd = (getPositive <$> arbitrary)+ >>= \s -> vectorOf s $ (,) <$> vcSel s <*> vcSel s -alphaNumIdentifier :: Gen String-alphaNumIdentifier = (:) <$> ch0 <*> chN- where ch0 = arbitrary `suchThat` underscoreOr isLetter- chN = arbitrary `suchThat` all (underscoreOr isAlphaNum)- underscoreOr f x = x == '_' || f x+identifier :: Gen String+identifier = (:) <$> ch0 <*> chN+ where ch0 = u isLetter+ chN = listOf $ u isAlphaNum+ u f = frequency [(1, return '_'), (74, arbitrary `suchThat` f)]