module Sound.SC3.RW.HP.Polyparse where
import Data.Function
import Data.List
import Data.Maybe
import Text.ParserCombinators.Poly.State
type Binding = (String,String)
type Name_Supply = [String]
type HP_Char = (Char,Maybe Int)
type HP_String = [HP_Char]
type ST = (Int,[Int])
type HP = Parser ST Char
hp_st :: ST
hp_st = (0,[])
safe_head :: [a] -> Maybe a
safe_head l =
case l of
[] -> Nothing
e:_ -> Just e
hp_next :: HP (Char,Maybe Int)
hp_next = do
let stPut st = stUpdate (const st)
c <- next
(n,h) <- stGet
case c of
'#' -> stPut (n,n : h) >> return (c,Just n)
'(' -> stPut (if null h then (n,h) else (n + 1,h)) >> return (c,safe_head h)
')' -> let n' = n 1
(st',e) = case h of
[] -> ((n,[]),Nothing)
x:h' -> if x == n'
then ((n',h'),Just x)
else ((n',h),safe_head h)
in stPut st' >> return (c,e)
_ -> return (c,safe_head h)
hp_hash_paren :: HP HP_String
hp_hash_paren = many1 hp_next
hp_parse :: String -> HP_String
hp_parse s =
case runParser hp_hash_paren hp_st s of
(Right r,(0,[]),[]) -> r
_ -> error "hp_parse"
max_by :: Ord a => (t -> a) -> t -> t -> t
max_by f p q = if f q > f p then q else p
replace_first :: Eq a => a -> a -> [a] -> [a]
replace_first p q =
let rec r l = case l of
[] -> reverse r
e:l' -> if e == p then reverse (q : r) ++ l' else rec (e : r) l'
in rec []
un_hash_paren :: String -> String
un_hash_paren s =
let f = reverse . drop 1 . reverse
in case s of
'#' : '(' : s' -> f s'
_ -> s
hp_next_binding :: Name_Supply -> HP_String -> Maybe (Name_Supply,Binding,HP_String)
hp_next_binding n s =
if null s || all ((== Nothing) . snd) s
then Nothing
else let nm:n' = n
s' = groupBy ((==) `on` snd) s
e = foldl1 (max_by (fromMaybe (1) . snd . head)) s'
x = fromJust (snd (head e)) 1
x' = if x >= 0 then Just x else Nothing
s'' = replace_first e (map (\c -> (c,x')) nm) s'
in Just (n',(nm,un_hash_paren (map fst e)),concat s'')
hp_print :: HP_String -> String
hp_print = map fst