module Sound.SC3.RW.HP.Parsec where
import Text.ParserCombinators.Parsec
data HP = S String | H HP | J HP HP deriving (Eq,Show)
type Binding = (String,String)
type Name_Supply = [String]
hp_cons :: HP -> HP -> HP
hp_cons p q =
case (p,q) of
(S s1,S s2) -> S (s1 ++ s2)
(S s1,J (S s2) r) -> S (s1 ++ s2) `hp_cons` r
(J l r,_) -> l `hp_cons` (r `hp_cons` q)
_ -> J p q
from_list1 :: [HP] -> HP
from_list1 l =
case l of
[] -> error "from_list1: []"
[h] -> h
p:l' -> p `hp_cons` (from_list1 l')
hp_parser :: Parser HP
hp_parser =
let p_node l = from_list1 [S "(",from_list1 l,S ")"]
in_paren = between (char '(') (char ')')
s = fmap S (many1 (noneOf "#()"))
p = fmap p_node (in_paren (many1 hp_parser))
h = char '#' >> fmap (H . from_list1) (in_paren (many1 hp_parser))
in fmap from_list1 (many1 (choice [h,p,s]))
hp_parse :: String -> HP
hp_parse s =
case parse hp_parser "" s of
Right t -> hp_simplify t
Left e -> error (show e)
hp_print :: HP -> String
hp_print h =
case h of
S s -> s
H h' -> "#(" ++ hp_print h' ++ ")"
J p q -> hp_print p ++ hp_print q
hp_simplify :: HP -> HP
hp_simplify h =
case h of
S s -> S s
H (S s) -> H (S s)
J (S _) (S _) -> error "J S S"
J (S _) (J (S _) _) -> error "J S (J S ..)"
J (J _ _) _ -> error "J (J .. ..) .."
J p q -> let (p',q') = (hp_simplify p,hp_simplify q)
in if p /= p' || q /= q'
then hp_simplify (p' `hp_cons` q')
else p `hp_cons` q
H h' -> let h'' = hp_simplify h'
in if h' /= h'' then hp_simplify (H h'') else H h'
next_nm :: Name_Supply -> (String,Name_Supply)
next_nm nm =
case nm of
n:nm' -> (n,nm')
_ -> error "next_nm"
hp_find_next_binding :: Name_Supply -> HP -> Maybe (Name_Supply,Binding)
hp_find_next_binding nm h =
let (n,nm') = next_nm nm
in case h of
S _ -> Nothing
H (S s) -> Just (nm',(n,s))
H h' -> hp_find_next_binding nm h'
J l r -> maybe
(hp_find_next_binding nm r)
Just
(hp_find_next_binding nm l)
hp_replace :: Binding -> HP -> HP
hp_replace (p,q) h =
case h of
S _ -> h
H (S s) -> if s == q then S p else h
H h' -> H (hp_replace (p,q) h')
J l r -> let l' = hp_replace (p,q) l
in if l /= l'
then l' `hp_cons` r
else l `hp_cons` hp_replace (p,q) r
hp_do_next_binding :: Name_Supply -> HP -> Maybe (Name_Supply,Binding,HP)
hp_do_next_binding nm h =
let f (nm',b) = (nm',b,hp_simplify (hp_replace b h))
in fmap f (hp_find_next_binding nm h)