module HSGen.Recompiler.Class where
import Control.Monad (ap, liftM2)
import Control.Spoon.Prim
import Data.Default.Aux
import Data.Fixable (Fix(..))
import Data.Wrapped (Wrapped(..), unwrapF, wrappedAp, defWrap)
infixl 1 $$
infixr 2 $$$
infixr 2 ###
class Resolvable a r | a -> r where
resolve :: a -> r
instance Resolvable (Wrapped a b) (Wrapped a b) where
resolve :: Wrapped a b -> Wrapped a b
resolve w = w
instance (Resolvable a r) => Resolvable (t -> a) r where
resolve :: (t -> a) -> r
resolve w = resolve $ w undefined
class Compilable a r b s | a -> r, b -> s, a s -> b, r b -> a where
($$$) :: (r -> s) -> a -> b
instance Compilable (Wrapped a b) (Wrapped a b) (Wrapped c d) (Wrapped c d) where
($$$) :: (Wrapped a b -> Wrapped c d) -> Wrapped a b -> Wrapped c d
($$$) f = f
instance (Compilable a r b s) => Compilable (t -> a) r (t -> b) s where
($$$) :: (r -> s) -> (t -> a) -> t -> b
(f $$$ w) x = f $$$ w x
($$) :: Compilable a1 (Wrapped (t -> a) b) t1 (Wrapped a b) => (t -> a1) -> t -> t1
($$) w x = flip wrappedAp x $$$ w $ x
class FixResolvable a r | a -> r where
fixResolve :: a -> r
instance FixResolvable (Wrapped a b) (Wrapped a b) where
fixResolve :: Wrapped a b -> Wrapped a b
fixResolve w = w
instance (FixResolvable a r) => FixResolvable (Fix t -> a) r where
fixResolve :: (Fix t -> a) -> r
fixResolve w = fixResolve $ w Unfixed
class FixCompilable a r b s | a -> r, b -> s, a s -> b, r b -> a where
(###) :: (r -> s) -> a -> b
instance FixCompilable (Wrapped a b) (Wrapped a b) (Wrapped c d) (Wrapped c d) where
(###) :: (Wrapped a b -> Wrapped c d) -> Wrapped a b -> Wrapped c d
(###) f = f
instance (FixCompilable a r b s) => FixCompilable (Fix t -> a) r (Fix t -> b) s where
(###) :: (r -> s) -> (Fix t -> a) -> Fix t -> b
(f ### w) x = f ### w x
(##) :: FixCompilable
a (Wrapped (r -> a1) b) (r -> r1) (Wrapped a1 b) =>
a -> r -> r1
(##) w x = flip wrappedAp x ### w $ x
apInOut :: Compilable a b b c => (b -> c) -> a -> c
apInOut = ap (.) ($$$)
fixApInOut :: FixCompilable a b b c => (b -> c) -> a -> c
fixApInOut = ap (.) (###)
flipC :: Compilable a1 (a -> b -> c) c (b -> a -> c) =>
(a -> b -> a1) -> b -> a -> c
flipC = apInOut flip
fixFlipC :: FixCompilable a (a1 -> b -> c) (a1 -> b -> c) (b -> a1 -> c) =>
a -> b -> a1 -> c
fixFlipC = fixApInOut flip
replaceFW :: a -> Wrapped a b -> Wrapped a b
replaceFW f (Wrap _ r) = Wrap f r
compile :: (Compilable a1 (Wrapped a b) r (Wrapped a b), Resolvable a1 (Wrapped a b1)) => a1 -> r
compile = liftM2 ($$$) (replaceFW . unwrapF . resolve) id
fixCompile :: (Compilable a1 (Wrapped a b) r (Wrapped a b), Resolvable a1 (Wrapped a b1)) => a1 -> r
fixCompile = liftM2 ($$$) (replaceFW . unwrapF . resolve) id