Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 138 lines (104 sloc) 3.885 kB
12deabc initial version
alex authored
1 {-# OPTIONS_GHC -XTypeSynonymInstances -XOverlappingInstances -XIncoherentInstances -XOverloadedStrings -XFlexibleInstances #-}
2
3 module Parse where
4
5 import Text.ParserCombinators.Parsec
6 import qualified Text.ParserCombinators.Parsec.Token as P
7 import Text.ParserCombinators.Parsec.Language ( haskellDef )
8 import Pattern
9
10 import GHC.Exts( IsString(..) )
11 -- import Data.List
12 -- import Data.Maybe
13 -- --import Text.Regex
14 -- import Data.Colour
15 -- import Data.Colour.Names
16 -- import Data.Colour.SRGB
17
18 class Parseable a where
19 p :: String -> Pattern a
20
21 instance Parseable Double where
22 p = parseRhythm pDouble
23
24 instance Parseable String where
25 p = parseRhythm pVocable
26
27 instance Parseable Bool where
28 p = parseRhythm pBool
29
30 instance Parseable Int where
31 p = parseRhythm pInt
32
33 -- type ColourD = Colour Double
34
35 -- instance Parseable ColourD where
36 -- p = parseRhythm pColour
37
38 instance (Parseable a) => IsString (Pattern a) where
39 fromString = p
40
41 lexer = P.makeTokenParser haskellDef
42 braces = P.braces lexer
43 brackets = P.brackets lexer
44 parens = P.parens lexer
45 symbol = P.symbol lexer
46 natural = P.natural lexer
47 float = P.float lexer
48 naturalOrFloat = P.naturalOrFloat lexer
49
50 data Sign = Positive | Negative
51
52 applySign :: Num a => Sign -> a -> a
53 applySign Positive = id
54 applySign Negative = negate
55
56 sign :: Parser Sign
57 sign = do char '-'
58 return Negative
59 <|> do char '+'
60 return Positive
61 <|> return Positive
62
63 intOrFloat :: Parser (Either Integer Double)
64 intOrFloat = do s <- sign
65 num <- naturalOrFloat
66 return (case num of
67 Right x -> Right (applySign s x)
68 Left x -> Left (applySign s x)
69 )
70
71
72 r :: Parseable a => String -> Pattern a -> IO (Pattern a)
73 r s orig = do catch (return $ p s)
74 (\err -> do putStrLn (show err)
75 return orig
76 )
77
78 --playRhythm :: (Monad m, Show a) => Parser (Pattern a) -> String -> m [Char]
79 --playRhythm f s = do let parsed = parseRhythm f s
80 -- return $ either (\e -> "Error" ++ show e) show parsed
81
82 parseRhythm :: Parser (Pattern a) -> String -> (Pattern a)
83 parseRhythm f input = either (const silence) id $ parse (pRhythm f') "" input
84 where f' = f
85 <|> do symbol "~" <?> "rest"
86 return silence
87
88
89 pRhythm :: Parser (Pattern a) -> GenParser Char () (Pattern a)
90 pRhythm f = do spaces
91 pSequence f
92
93 pSequence :: Parser (Pattern a) -> GenParser Char () (Pattern a)
94 pSequence f = do ps <- many $ pPart f
95 return $ cat ps
96
97 pPart :: Parser (Pattern a) -> Parser (Pattern a)
98 pPart f = do part <- parens (pSequence f) <|> f <|> pPoly f
99 spaces
100 return part
101
102 pPoly :: Parser (Pattern a) -> Parser (Pattern a)
103 pPoly f = do ps <- brackets (pRhythm f `sepBy` symbol ",")
104 return $ combine ps
105
106 pString :: Parser (String)
107 pString = many1 (letter <|> oneOf "0123456789" <|> char '/') <?> "string"
108
109 pVocable :: Parser (Pattern String)
110 pVocable = do v <- pString
111 return $ Atom v
112
113 pDouble :: Parser (Pattern Double)
114 pDouble = do nf <- intOrFloat <?> "float"
115 let f = either fromIntegral id nf
116 return $ Atom f
117
118 pBool :: Parser (Pattern Bool)
119 pBool = do oneOf "t1"
120 return $ Atom True
121 <|>
122 do oneOf "f0"
123 return $ Atom False
124
125 -- pColour :: Parser (Pattern ColourD)
126 -- pColour = do name <- many1 letter <?> "colour name"
127 -- colour <- readColourName name <?> "known colour"
128 -- return $ Atom colour
129
130 pInt :: Parser (Pattern Int)
131 pInt = do i <- natural <?> "integer"
132 return $ Atom (fromIntegral i)
133
134 -- doubleToGray :: Double -> ColourD
135 -- doubleToGray n = let shade = n in
136 -- sRGB shade shade shade
137
Something went wrong with that request. Please try again.