module Homoiconic.Homogeneous
(
FAlgebra (..)
, Free (..)
, AST
, runAST
, View (..)
, Var
, mkExprVar
, var1
, var2
, var3
, mkFAlgebra
)
where
import Homoiconic.Homogeneous.TH
import Prelude
import Control.Monad
import Data.List
import Data.Foldable
import Data.Typeable
import Data.Kind
import GHC.Exts hiding (IsList(..))
class
( Functor (Sig alg)
, Foldable (Sig alg)
, Typeable alg
) => FAlgebra (alg :: Type -> Constraint)
where
type ParentClasses alg :: [Type -> Constraint]
data Sig alg a
runSig :: alg a => Sig alg a -> a
type AncestorClasses alg = Nub (AncestorClasses_ (ParentClasses alg))
type family AncestorClasses_ (xs::[Type -> Constraint]) :: [Type -> Constraint] where
AncestorClasses_ (x ': xs) = x ': (AncestorClasses_ (ParentClasses x) ++ AncestorClasses_ xs)
AncestorClasses_ '[] = '[]
type family (++) (xs1:: [x]) (xs2:: [x]) :: [x] where
'[] ++ '[] = '[]
'[] ++ xs2 = xs2
xs1 ++ '[] = xs1
(x ': xs1) ++ xs2 = x ': (xs1++xs2)
type family Nub xs where
Nub '[] = '[]
Nub (x ': xs) = x ': Nub (Remove x xs)
type family Remove x xs where
Remove x '[] = '[]
Remove x (x ': ys) = Remove x ys
Remove x (y ': ys) = y ': Remove x ys
data Free (f :: Type -> Type) (a :: Type) where
Free :: f (Free f a) -> Free f a
Pure :: a -> Free f a
deriving instance (Eq a, Eq (f (Free f a))) => Eq (Free f a)
instance (Show a, Show (f (Free f a))) => Show (Free f a) where
show (Pure a) = show a
show (Free f) = "("++show f++")"
instance Functor f => Functor (Free f) where
fmap g (Free f) = Free (fmap (fmap g) f)
fmap g (Pure a) = Pure (g a)
instance (Functor f, Foldable f) => Foldable (Free f) where
foldMap f (Free fa) = fold $ fmap (foldMap f) fa
foldMap f (Pure a) = f a
type AST (alg :: Type -> Constraint) a = Free (Sig alg) a
runAST :: (FAlgebra alg, alg a) => AST alg a -> a
runAST (Pure a) = a
runAST (Free f) = runSig (fmap runAST f)
class (FAlgebra alg1, FAlgebra alg2) => View alg1 alg2 where
embedSig :: Sig alg1 a -> Sig alg2 a
unsafeExtractSig :: Sig alg2 a -> Sig alg1 a
instance FAlgebra alg => View alg alg where
embedSig = id
unsafeExtractSig = id
embedHomAST :: View alg1 alg2 => AST alg1 a -> AST alg2 a
embedHomAST (Free f) = Free $ embedSig $ fmap embedHomAST f
embedHomAST (Pure a) = Pure a
newtype Var = Var String
deriving (Eq)
instance Show Var where
show (Var v) = v
mkExprVar :: String -> AST alg Var
mkExprVar str = Pure $ Var str
var1 :: AST alg Var
var1 = Pure $ Var "var1"
var2 :: AST alg Var
var2 = Pure $ Var "var2"
var3 :: AST alg Var
var3 = Pure $ Var "var3"
mkFAlgebra ''Num
mkFAlgebra ''Fractional
mkFAlgebra ''Floating
instance FAlgebra Eq
instance Functor (Sig Eq)
instance Foldable (Sig Eq)
instance Show (Sig Eq a)
instance Eq (Sig Eq a)
mkFAlgebra ''Ord
class (Floating a, Ord a) => FloatingOrd a
instance (Floating a, Ord a) => FloatingOrd a
mkFAlgebra ''FloatingOrd