Polyparse.hs

module Sound.SC3.RW.HP.Polyparse where

import Data.Function
import Data.List
import Data.Maybe
import Text.ParserCombinators.Poly.State {- polyparse -}

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

-- | Only count parens in #().
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)

-- > runParser hp_hash_paren hp_st "r <- #(a)"
-- > runParser hp_hash_paren hp_st "#(a (b)) (c (d))"
-- > runParser hp_hash_paren hp_st "#(a (b) (c (d)))"
-- > runParser hp_hash_paren hp_st "#a"
-- > runParser hp_hash_paren hp_st "a"
-- > runParser hp_hash_paren hp_st "c <- f #(a) #(b c) d"
-- > runParser hp_hash_paren hp_st "c <- f #(a) #(b #(c)) d"
-- > runParser hp_hash_paren hp_st "c <- f #(a) #(b #(c #(d e) f) #(g)) #(h) i"
hp_hash_paren :: HP HP_String
hp_hash_paren = many1 hp_next

-- > hp_parse "c <- f #(a) #(b #(c #(d e) f) g) h"
hp_parse :: String -> HP_String
hp_parse s =
    case runParser hp_hash_paren hp_st s of
      (Right r,(0,[]),[]) -> r
      _ -> error "hp_parse"

-- | Left biased 'max' variant.
--
-- > max_by last "cat" "mouse" == "cat"
-- > max_by last "aa" "za" == "aa"
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 1 (-1) [-2,1,0,1] == [-2 .. 1]
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 "#(a)" == "a"
-- > un_hash_paren "b" == "b"
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