Unparse.hs

module Support.Unparse(Unparse(), Unparsable(..), unparse, unparse', Side(..), atom, atomize, bop, pop, fixitize) where

import Doc.DocLike

data Unparse a = Atom a | Pre a (Unparse a) | Fix (Unparse a) a (Unparse a) !Side !Int | Atomized (Unparse a) | Fixitized  !Side !Int (Unparse a)

data Side = R | L | N
    deriving(Eq)

atom :: a -> Unparse a
atom s = Atom s

atomize :: Unparse a -> Unparse a
atomize (Atomized x) = Atomized x
atomize (Atom a) = Atom a
atomize x = Atomized x

fixitize :: (Side,Int) -> Unparse a -> Unparse a
fixitize (s,i) a = Fixitized s i a

pop :: a -> Unparse a -> Unparse a
pop = Pre

bop :: (Side,Int) -> a -> Unparse a -> Unparse a -> Unparse a
bop (s,i) op a b = Fix a op b s i

data Unparsable a = Unparsable {
    unparseGroup :: a -> a,
    unparseCat :: a -> a -> a
    }

data Fix = FAtom | FPre | FFix !Side !Int

unparse :: DocLike a => Unparse a -> a
unparse up = unparse' Unparsable { unparseGroup = parens, unparseCat = (<>) } up

unparse' :: Unparsable a -> Unparse a -> a
unparse' Unparsable { unparseGroup = upg, unparseCat = (<>) } up = fst $ f up where
    f (Atom a) = atom a
    f (Atomized a) = (fst $ f a, FAtom)
    f (Fixitized s i a) = (fst $ f a, FFix s i)
    f (Pre a up) = pop a (f up)
    f (Fix a op b s i) = bop (s,i) op (f a) (f b)

    bop (f1,f2) s (a,FAtom) (b,FAtom)  = (sop s a b, FFix f1 f2)
    bop f@(f1,f2) s (a,af) (b,bf) | lts L f af  && lts R f bf  = (sop s a b, FFix f1 f2)
    bop f s (a,af) b | not (lts L f af) = bop f s (mkatom (a,af)) b
    bop f s a (b,bf) | not (lts R f bf)  = bop f s a (mkatom (b,bf))
    bop _ _ _ _ = error "bop"

    pop s (x, FAtom) = ( s <> x, FPre)
    pop s x = pop s $ mkatom x

    atom a = (a,FAtom)
    mkatom (a,FAtom) = (a,FAtom)
    mkatom (a,_) = ( upg a , FAtom)

    sop op a b = a <> (op <> b)

    lts :: Side -> (Side,Int) -> Fix -> Bool
    lts _ _ FAtom = True
    lts _ _ FPre = True
    lts _ (_,n') (FFix  _ n ) | n' /= n = n' < n
    lts R (R,_) (FFix  R _ ) = True
    lts L (L,_) (FFix  L _ ) = True
    lts _ _ _ = False

--lts _ (N,_) (Fix (N,_)) = False

--type Unparse a = (a, Fix)

{-

bop :: Unparsable a => (Side,Int) -> a -> Unparse a -> Unparse a -> Unparse a
--bop f "" a b@(_,Pre) = bop f "" a (mkatom b)
bop (f1,f2) s (a,Atom) (b,Atom)  = (sopns s a b, Fix f1 f2)
bop f@(f1,f2) s (a,af) (b,bf) | lts L f af  && lts R f bf  = (sop s a b, Fix f1 f2)
bop f s (a,af) b | not (lts L f af) = bop f s (mkatom (a,af)) b
bop f s a (b,bf) | not (lts R f bf)  = bop f s a (mkatom (b,bf))

pop :: Unparsable a => a -> Unparse a -> Unparse a
pop s (x, Atom) = (unparseCat s  x, Pre)
pop s x = pop s $ mkatom x

--sop "" a b = a ++ " " ++ b
sop op a b = unparseSpace a $ unparseSpace op b
--sopns "" a b = a ++ " " ++ b
sopns op a b = unparseCat a $ unparseCat op b

mkatom (a,Atom) = (a,Atom)
mkatom (a,_) = ( unparseGroup a , Atom)
--sop "" a b = a ++ " " ++ b
sop op a b = unparseSpace a $ unparseSpace op b
--sopns "" a b = a ++ " " ++ b
sopns op a b = unparseCat a $ unparseCat op b

mkatom (a,Atom) = (a,Atom)
mkatom (a,_) = ( unparseGroup a , Atom)

instance Unparsable Doc where
    unparseCat  =  (<>)
    unparseSpace  =  (<>)
    unparseGroup  = parens
class Unparsable a where
    unparseGroup :: a -> a
    unparseCat :: a -> a -> a
    unparseSpace :: a -> a -> a
    unparseConcat :: [a] -> a
    unparseConcat = foldl1 unparseCat

instance Unparsable String where
    unparseGroup x = "(" ++ x ++ ")"
    unparseCat x y =  x ++ y
    unparseSpace x y = x ++ " " ++ y
    unparseConcat xs = concat xs

instance Unparsable () where
    unparseGroup _ = ()
    unparseCat _ _ = ()
    unparseSpace _ _ = ()
infixr 9  .
infixr 8  ^, ^^, **
infixl 7  *, /, `quot`, `rem`, `div`, `mod`
infixl 6  +, -

-- The (:) operator is built-in syntax, and cannot legally be given
-- a fixity declaration; but its fixity is given by:
--   infixr 5  :

infix  4  ==, /=, <, <=, >=, >
infixr 3  &&
infixr 2  ||
infixl 1  >>, >>=
infixr 1  =<<
infixr 0  $, $!, `seq`

a + b * c
a + (b * c)

d + a * b + c * d

plus = bop ((L,6)) "+"
minus = bop ((L,6)) "-"
times = bop ((L,7)) "*"
pow = bop ((L,8)) "^"
eq = bop ((N,4)) "=="

a,b,c,d,x,y, abcdr, abcdl, eql :: (String, Fix)

a = text "a"
b = text "b"
c = text "c"
d = text "d"
x = text "x"
y = text "y"

abcdr = foldl1 plus [a,b,c,d]
abcdl = foldr1 plus [a,b,c,d]
eql = foldl1 eq [a,b,c]

z = eq (plus a b) (pow (times b c) abcdl) `eq` eql

g = minus (plus (times (plus a b) (plus b c)) abcdr) abcdl

main = putStrLn $ fst $ foldl1 plus [g,eql, z ]
-}