-- | Hash parentheses.  A simple minded haskell pre-processor that
-- extends the haskell /do/ syntax by rewriting @#@ parenthesised
-- elements of a right hand side expression as monadic bindings.
-- The basic pre-processor is 'hp_rewrite'.
module Sound.SC3.RW.HP where

import Data.Char {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import qualified Data.List.Split as S {- split -}
import System.Environment {- base -}

import Sound.SC3.RW.HP.Parsec

-- * String

-- | Return indentation of line.
--
-- > indent_of "  a <- b" == "  "
indent_of :: String -> String
indent_of = takeWhile isSpace

-- | Delete indentation of line.
--
-- > remove_indent "  a <- b"  == "a <- b"
remove_indent :: String -> String
remove_indent = dropWhile isSpace

-- * List

-- | Variant of 'splitOn' requiring one match only.
--
-- > split_on_1 " <- " "  a <- f #(b) #(c)" == Just ("  a","f #(b) #(c)")
-- > split_on_1 " do " "  let a = do f #(b) #(c)" == Just ("  let a =","f #(b) #(c)")
split_on_1 :: Eq a => [a] -> [a] -> Maybe ([a],[a])
split_on_1 p q =
    case S.splitOn p q of
      [r,s] -> Just (r,s)
      _ -> Nothing

-- * Inline do

-- | Split inline /do/ line into separate lines.
--
-- > let r = ["  let a = do "
-- >         ,"             f #(b) #(c)"]
-- > in hp_remove_inline_do "  let a = do f #(b) #(c)" == r
hp_remove_inline_do :: String -> [String]
hp_remove_inline_do s =
    let q = " do "
    in case split_on_1 q s of
         Just (p,r) -> let s0 = p ++ q
                           s1 = replicate (length s0) ' ' ++ r
                       in [s0,s1]
         _ -> [s]

-- * Continuation lines

-- | Return indent of /s/ if it 'has_hash_paren'.
--
-- > hp_indent "  a <- f #(b) #(c)" == Just 2
hp_indent :: String -> Maybe Int
hp_indent s =
    if has_hash_paren s
    then Just (length (indent_of s))
    else Nothing

-- | Note which lines are /continued/ hash parenethsis lines.
--
-- > hp_non_inline ["f = do"
-- >               ,"  a #(b)"
-- >               ,"    #(c)"
-- >               ,"    #(d)"
-- >               ,"  p #(q) #(r)"] == [False,False,True,True,False]
hp_non_inline :: [String] -> [Bool]
hp_non_inline l =
    let f (o,n') n = case (n',n) of
                       (Just x',Just x) -> case compare x x' of
                                             LT -> ((False,n),False)
                                             EQ -> ((o,n),o)
                                             GT -> ((True,n),True)
                       _ -> ((False,n),False)
    in snd (mapAccumL f (False,Nothing) (map hp_indent l))

-- | Re-layout to put broken /hash parenthesis/ lines onto one line.
--
-- > let r = ["f = do"
-- >         ,"  a #(b) #(c) #(d)"
-- >         ,"  p #(q) #(r)"]
-- > in hp_uncontinue ["f = do"
-- >                  ,"  a #(b)"
-- >                  ,"    #(c)"
-- >                  ,"    #(d)"
-- >                  ,"  p #(q) #(r)"] == r
hp_uncontinue :: [String] -> [String]
hp_uncontinue l =
    let f st (e,c,k) = let e' = if c then ' ' : remove_indent e else e
                       in if k
                          then (st ++ e',Nothing)
                          else ("",Just (st ++ e'))
        i = hp_non_inline l
        (z,l') = mapAccumL f "" (zip3 l i (tail i ++ [False]))
        z' = if null z then [] else [z]
    in catMaybes l' ++ z'

-- * Hash Parentheses

-- | Name supply for introduced variables.
--
-- > hp_names !! 9 == "_hp_9"
hp_names :: Name_Supply
hp_names = map (\n -> "_hp_" ++ show n) [0::Integer ..]

-- | Does /s/ have a /hash parenthesis/ expression.
--
-- > has_hash_paren "  a <- f #(b) #(c)" == True
has_hash_paren :: String -> Bool
has_hash_paren = isInfixOf "#("

-- | Process one line of /hash-parenthesis/ re-writes.
hp_analyse :: Name_Supply -> String -> (Name_Supply,([Binding],HP))
hp_analyse nm =
    let rec n b s = case hp_do_next_binding n s of
                      Nothing -> (n,(reverse b,s))
                      Just (n',b',s') -> rec n' (b':b) s'
    in rec nm [] . hp_parse

-- | Variant of 'hp_analyse' for examining intermediate state.
--
-- > let r = ([("_hp_0","b"),("_hp_1","c (d e)")],"  a <- f _hp_0 _hp_1")
-- > in hp_analyse' hp_names "  a <- f #(b) #(c (d e))" == r
--
-- > let r = ([("_hp_0","a")],"  return (f _hp_0)")
-- > in hp_analyse' hp_names "  return (f #(a))" == r
--
-- > let r = ([("_hp_0","a"),("_hp_1","d e"),("_hp_2","c _hp_1 f"),("_hp_3","b _hp_2 g")]
-- >         ,"c <- f (_hp_0,_hp_3) h")
-- > in hp_analyse' hp_names "c <- f (#(a),#(b #(c #(d e) f) g)) h" == r
--
-- > let r = ([("_hp_0","v w")],"  return (h (_hp_0 * 2))")
-- > in hp_analyse' hp_names "  return (h (#(v w) * 2))" == r
hp_analyse' :: Name_Supply -> String -> ([Binding],String)
hp_analyse' nm s =
    let (_,(n,h)) = hp_analyse nm s
    in (n,hp_print h)

-- | Re-construct 'hp_analyse' output.
hp_build :: ([Binding],HP) -> [String]
hp_build (b,e) =
    let e' = hp_print e
        f (i,j) = concat [i," <- ",j]
        ind = indent_of e'
        b' = map ((ind ++) . f) b
    in b' ++ [e']

-- | Process a line for /hash parentheses/.
hp_process :: Name_Supply -> String -> (Name_Supply, [String])
hp_process n s =
    if has_hash_paren s
    then let (n',r) = hp_analyse n s
             r' = hp_build r
         in (n',r')
    else (n,[s])

-- | Run /hash parenthesis/ rewriter.
--
-- > let {i = ["main = do"
-- >          ,"  let a = f #(b) (#(c) * 2)"
-- >          ,"  d <- e"
-- >          ,"  p <- g #(q r)"
-- >          ,"         #(s #(t u))"
-- >          ,"  return (h (#(v w) * 2))"]
-- >     ;r = ["main = do"
-- >          ,"  _hp_0 <- b"
-- >          ,"  _hp_1 <- c"
-- >          ,"  let a = f _hp_0 (_hp_1 * 2)"
-- >          ,"  d <- e"
-- >          ,"  _hp_2 <- q r"
-- >          ,"  _hp_3 <- t u"
-- >          ,"  _hp_4 <- s _hp_3"
-- >          ,"  p <- g _hp_2 _hp_4"
-- >          ,"  _hp_5 <- v w"
-- >          ,"  return (h (_hp_5 * 2))"]}
-- > in hp_rewrite i == r
hp_rewrite :: [String] -> [String]
hp_rewrite =
    concat .
    snd .
    mapAccumL hp_process hp_names .
    concatMap hp_remove_inline_do .
    hp_uncontinue

-- | Arguments as required by @ghc -F -pgmF@.
hp_rewrite_ghcF :: IO ()
hp_rewrite_ghcF = do
  a <- getArgs
  case a of
    [_,i_fn,o_fn] -> do
           i <- readFile i_fn
           let f = unlines . hp_rewrite . lines
           writeFile o_fn (f i)
    _ -> error "initial-file input-file output-file"