module Sound.SC3.RW.HP.Parsec where

import Text.ParserCombinators.Parsec {- parsec -}

data HP = S String | H HP | J HP HP deriving (Eq,Show)

type Binding = (String,String)
type Name_Supply = [String]

-- | Simplifying constructor (do not use 'J' directly).
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 "a"
-- > hp_parse "a b"
-- > hp_parse "a (b c)"
-- > hp_parse "a #(b (#(c d) e))"
-- > hp_parse "c <- f (#(a),#(b #(c #(d e) f) g)) h"
-- > let r = hp_parse "c <- f (#(a),#(b #(c #(d e) f) g)) h"
-- > hp_print r
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

-- > let r = hp_parse "c <- f (a,#(b #(c de f) g)) h"
-- > in hp_simplify r
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"

-- > let r = hp_parse "c <- f (#(a),#(b #(c #(d e) f) g)) h"
-- > in hp_find_next_binding ["_hp_0"] r
--
-- > let r = hp_parse "c <- f (_hp_0,#(b #(c _hp_1 f) g)) h"
-- > in hp_find_next_binding ["_hp_2"] r
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)

-- > let r = hp_parse "c <- f (#(a),#(b #(c #(d e) f) g)) h"
-- > in hp_print (hp_simplify (hp_replace ("_hp_0","a") r))
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)