Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 8a0eb586ec
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 136 lines (103 sloc) 3.65 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
{-# OPTIONS_GHC -XTypeSynonymInstances -XOverlappingInstances -XIncoherentInstances -XOverloadedStrings -XFlexibleInstances #-}

module Parse where

import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language ( haskellDef )
import Pattern
import Data.Ratio

import GHC.Exts( IsString(..) )

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

-- 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
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 catch (return $ p s)
                (\err -> do putStrLn (show err)
                            return orig
                )

parseRhythm :: Parser (Pattern a) -> String -> (Pattern a)
parseRhythm f input = either (const silence) id $ parse (pRhythm f') "" input
  where f' = f
             <|> do symbol "~" <?> "rest"
                    return silence


pRhythm :: Parser (Pattern a) -> GenParser Char () (Pattern a)
pRhythm f = do spaces
               pSequence f

pSequence :: Parser (Pattern a) -> GenParser Char () (Pattern a)
pSequence f = do x <-pReps
                 ps <- many $ pPart f
                 let p = Arc (cat ps) 0 1 x
                 return $ p

pPart :: Parser (Pattern a) -> Parser (Pattern a)
pPart f = do part <- parens (pSequence f) <|> f <|> pPoly f
             spaces
             return part

pPoly :: Parser (Pattern a) -> Parser (Pattern a)
pPoly f = do ps <- brackets (pRhythm f `sepBy` symbol ",")
             return $ combine ps

pString :: Parser (String)
pString = many1 (letter <|> oneOf "0123456789" <|> char '/') <?> "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 i <- natural <?> "integer"
          return $ Atom (fromIntegral i)

pRatio :: Parser (Rational)
pRatio = do n <- natural <?> "numerator"
            d <- do char '/'
                    natural <?> "denominator"
                 <|>
                 do return 1
            return $ n % d

pReps :: Parser (Rational)
pReps = angles (pRatio <?> "ratio")
        <|>
        do return (1 % 1)

Something went wrong with that request. Please try again.