hsc3-rw-0.14: Sound/SC3/RW/HP.hs
-- | 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"