module Language.Desugar (
tripBy
, revTripBy
, SplitFunction
, addParens
, addShortParens
, forwardInfix
, reverseInfix
) where
import Data.List
import Data.Hierarchy
import Data.Hexpr
type SplitFunction a b = ([a] -> b, [a] -> a -> [a] -> b)
tripBy :: (a -> Bool) -> SplitFunction a b -> [a] -> b
tripBy p (onNo, onYes) xs = case break p xs of
(before, []) -> onNo xs
(before, x:after) -> onYes before x after
revTripBy :: (a -> Bool) -> SplitFunction a b -> [a] -> b
revTripBy p (onNo, onYes) xs = case revBreak p xs of
(before, []) -> onNo xs
(before, after) -> onYes (init before) (last before) (after)
revBreak p xs = let (rAfter, rBefore) = break p (reverse xs)
in if null rBefore
then (reverse rAfter, [])
else (reverse rBefore, reverse rAfter)
addParens :: (Openable (h p), Hierarchy h p) => (h p a -> Bool) -> OpenAp (h p) a
addParens p = (id, tripBy p (id, onYes))
where
onYes before x after = before ++ [x `adjoinslPos` after]
addShortParens :: (Openable (h p), Hierarchy h p) => (h p a -> Bool) -> h p a -> h p a
addShortParens p = openAp (id, tripBy p (id, onYes))
where
onYes before x [] = before++[x]
onYes before x after' = case span p after' of
([], []) -> [x]
(cont, []) -> before++[deepen (last cont) (reverse (x:init cont))]
(cont, next:after) -> before ++ [deepen next (reverse (x:cont))] ++ after
where
deepen acc [] = acc
deepen acc (x:xs) = deepen (x `adjoinPos` acc) xs
forwardInfix :: (Openable (h p), Hierarchy h p) => (h p a -> Bool) -> OpenAp (h p) a
forwardInfix p = (id, tripBy p (id, onYes))
where
onYes [] x after = x:after
onYes before x [] = before++[x]
onYes before x after = [x, adjoinsPos before, adjoinsPos after]
reverseInfix :: (Openable (h p), Hierarchy h p, Show (h p a)) => (h p a -> Bool) -> OpenAp (h p) a
reverseInfix p = (id, revTripBy p (id, onYes))
where
onYes [] x after = x:after
onYes before x [] = before++[x]
onYes before x after = [x, adjoinsPos before, adjoinsPos after]