module Sound.Tidal.Parse where
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language ( haskellDef )
import Data.Ratio
import Data.Colour
import Data.Colour.Names
import Data.Colour.SRGB
import GHC.Exts( IsString(..) )
import Data.Monoid
import Control.Exception as E
import Control.Applicative ((<$>), (<*>))
import Data.Maybe
import Sound.Tidal.Pattern
class Parseable a where
p :: String -> Pattern a
instance Parseable Double where
p = parseRhythm pDouble
instance Parseable String where
p = parseRhythm pVocable
instance Parseable Bool where
p = parseRhythm pBool
instance Parseable Int where
p = parseRhythm pInt
instance Parseable Rational where
p = parseRhythm pRational
type ColourD = Colour Double
instance Parseable ColourD where
p = parseRhythm pColour
instance (Parseable a) => IsString (Pattern a) where
fromString = p
lexer = P.makeTokenParser haskellDef
braces = P.braces lexer
brackets = P.brackets lexer
parens = P.parens lexer
angles = P.angles lexer
symbol = P.symbol lexer
natural = P.natural lexer
integer = P.integer lexer
float = P.float lexer
naturalOrFloat = P.naturalOrFloat lexer
data Sign = Positive | Negative
applySign :: Num a => Sign -> a -> a
applySign Positive = id
applySign Negative = negate
sign :: Parser Sign
sign = do char '-'
return Negative
<|> do char '+'
return Positive
<|> return Positive
intOrFloat :: Parser (Either Integer Double)
intOrFloat = do s <- sign
num <- naturalOrFloat
return (case num of
Right x -> Right (applySign s x)
Left x -> Left (applySign s x)
)
r :: Parseable a => String -> Pattern a -> IO (Pattern a)
r s orig = do E.handle
(\err -> do putStrLn (show (err :: E.SomeException))
return orig
)
(return $ p s)
parseRhythm :: Parser (Pattern a) -> String -> (Pattern a)
parseRhythm f input = either (const silence) id $ parse (pSequence f') "" input
where f' = f
<|> do symbol "~" <?> "rest"
return silence
pSequenceN :: Parser (Pattern a) -> GenParser Char () (Int, Pattern a)
pSequenceN f = do spaces
d <- pDensity
ps <- many $ pPart f
return $ (length ps, density d $ cat $ concat ps)
pSequence :: Parser (Pattern a) -> GenParser Char () (Pattern a)
pSequence f = do (_, p) <- pSequenceN f
return p
pSingle :: Parser (Pattern a) -> Parser (Pattern a)
pSingle f = f >>= pRand >>= pMult
pPart :: Parser (Pattern a) -> Parser ([Pattern a])
pPart f = do part <- parens (pSequence f) <|> pSingle f <|> pPolyIn f <|> pPolyOut f
part' <- pRand part
spaces
parts <- pReplicate part'
spaces
return $ parts
pPolyIn :: Parser (Pattern a) -> Parser (Pattern a)
pPolyIn f = do ps <- brackets (pSequence f `sepBy` symbol ",")
spaces
pMult $ mconcat ps
pPolyOut :: Parser (Pattern a) -> Parser (Pattern a)
pPolyOut f = do ps <- braces (pSequenceN f `sepBy` symbol ",")
spaces
base <- do char '%'
spaces
i <- integer <?> "integer"
return $ Just (fromIntegral i)
<|> return Nothing
pMult $ mconcat $ scale base ps
where scale _ [] = []
scale base (ps@((n,_):_)) = map (\(n',p) -> density (fromIntegral (fromMaybe n base)/ fromIntegral n') p) ps
pString :: Parser (String)
pString = many1 (letter <|> oneOf "0123456789:") <?> "string"
pVocable :: Parser (Pattern String)
pVocable = do v <- pString
return $ atom v
pDouble :: Parser (Pattern Double)
pDouble = do nf <- intOrFloat <?> "float"
let f = either fromIntegral id nf
return $ atom f
pBool :: Parser (Pattern Bool)
pBool = do oneOf "t1"
return $ atom True
<|>
do oneOf "f0"
return $ atom False
pInt :: Parser (Pattern Int)
pInt = do s <- sign
i <- integer <?> "integer"
return $ atom (applySign s $ fromIntegral i)
pColour :: Parser (Pattern ColourD)
pColour = do name <- many1 letter <?> "colour name"
colour <- readColourName name <?> "known colour"
return $ atom colour
pMult :: Pattern a -> Parser (Pattern a)
pMult thing = do char '*'
spaces
r <- pRatio
return $ density r thing
<|>
do char '/'
spaces
r <- pRatio
return $ slow r thing
<|>
return thing
pRand :: Pattern a -> Parser (Pattern a)
pRand thing = do char '?'
spaces
return $ degrade thing
<|> return thing
pReplicate :: Pattern a -> Parser ([Pattern a])
pReplicate thing = do extras <- many $ do char '!'
spaces
pRand thing
return (thing:extras)
pRatio :: Parser (Rational)
pRatio = do n <- natural <?> "numerator"
d <- do oneOf "/%"
natural <?> "denominator"
<|>
return 1
return $ n % d
pRational :: Parser (Pattern Rational)
pRational = do r <- pRatio
return $ atom r
pDensity :: Parser (Rational)
pDensity = angles (pRatio <?> "ratio")
<|>
return (1 % 1)