/Generics1.hs
Haskell | 143 lines | 107 code | 31 blank | 5 comment | 0 complexity | dc3eeb5428f4d5943b676f5f65a57300 MD5 | raw file
Possible License(s): BSD-3-Clause
1{-# LANGUAGE TypeFamilies, EmptyDataDecls, ScopedTypeVariables #-} 2 3import Data.Monoid 4 5 6type family Force a :: * 7 8data Forced (a :: *) 9type instance Force (Forced a) = a 10 11 12newtype VarF var term value = AVar { unVar :: String } 13 14data TermF var term value 15 = Var (Force var) 16 | App (Force term) (Force var) 17 | Value (Force value) 18 | Add (Force term) (Force term) 19 20data ValueF var term value 21 = Literal Int 22 | Lambda String (Force term) 23 24data SyntaxAlgebra var term value = SyntaxAlgebra { 25 varAlgebra :: VarF var term value -> Force var, 26 termAlgebra :: TermF var term value -> Force term, 27 valueAlgebra :: ValueF var term value -> Force value 28 } 29 30 31type Fix3_1 f g h = f (FixTag3_1 f g h) (FixTag3_2 f g h) (FixTag3_3 f g h) 32type Fix3_2 f g h = g (FixTag3_1 f g h) (FixTag3_2 f g h) (FixTag3_3 f g h) 33type Fix3_3 f g h = h (FixTag3_1 f g h) (FixTag3_2 f g h) (FixTag3_3 f g h) 34 35data FixTag3_1 f g h 36data FixTag3_2 f g h 37data FixTag3_3 f g h 38type instance Force (FixTag3_1 f g h) = Fix3_1 f g h 39type instance Force (FixTag3_2 f g h) = Fix3_2 f g h 40type instance Force (FixTag3_3 f g h) = Fix3_3 f g h 41 42 43type Var = Fix3_1 VarF TermF ValueF 44type Term = Fix3_2 VarF TermF ValueF 45type Value = Fix3_3 VarF TermF ValueF 46 47 48-- TODO: try doing this as a functor category? 49fmap3VarF :: (Force var -> Force var') 50 -> (Force term -> Force term') 51 -> (Force value -> Force value') 52 -> VarF var term value 53 -> VarF var' term' value' 54fmap3VarF _var _term _value x = case x of 55 AVar x -> AVar x 56 57fmap3TermF :: (Force var -> Force var') 58 -> (Force term -> Force term') 59 -> (Force value -> Force value') 60 -> TermF var term value 61 -> TermF var' term' value' 62fmap3TermF var term value e = case e of 63 Var x -> Var (var x) 64 App e x -> App (term e) (var x) 65 Value v -> Value (value v) 66 Add e1 e2 -> Add (term e1) (term e2) 67 68fmap3ValueF :: (Force var -> Force var') 69 -> (Force term -> Force term') 70 -> (Force value -> Force value') 71 -> ValueF var term value 72 -> ValueF var' term' value' 73fmap3ValueF _var term _value v = case v of 74 Literal l -> Literal l 75 Lambda x e -> Lambda x (term e) 76 77foldMap3VarF :: Monoid m 78 => (Force var -> m) 79 -> (Force term -> m) 80 -> (Force value -> m) 81 -> VarF var term value 82 -> m 83foldMap3VarF _var _term _value x = case x of 84 AVar _ -> mempty 85 86foldMap3TermF :: Monoid m 87 => (Force var -> m) 88 -> (Force term -> m) 89 -> (Force value -> m) 90 -> TermF var term value 91 -> m 92foldMap3TermF var term value e = case e of 93 Var x -> var x 94 App e x -> term e `mappend` var x 95 Value v -> value v 96 Add e1 e2 -> term e1 `mappend` term e2 97 98foldMap3ValueF :: Monoid m 99 => (Force var -> m) 100 -> (Force term -> m) 101 -> (Force value -> m) 102 -> ValueF var term value 103 -> m 104foldMap3ValueF _var term _value v = case v of 105 Literal _ -> mempty 106 Lambda _ e -> term e 107 108 109example :: Value 110example = Lambda "x" $ Add (Value (Literal 1)) (Var (AVar "x")) `App` AVar "x" 111 112 113-- fixAlgebra :: SyntaxAlgebra var term value -> SyntaxAlgebra (Fix3_1 var term value) (Fix3_2 var term value) (Fix3_3 var term value) 114-- fixAlgebra alg = undefined 115 116applyAlgebra :: forall var term value. 117 SyntaxAlgebra var term value 118 -> Term -> Force term 119 -- -> SyntaxAlgebra (FixTag3_1 VarF TermF ValueF) (FixTag3_2 VarF TermF ValueF) (FixTag3_3 VarF TermF ValueF) 120applyAlgebra alg = {- SyntaxAlgebra var term value -- -} term 121 where 122 var :: Var -> Force var 123 var = varAlgebra alg . fmap3VarF var term value 124 term :: Term -> Force term 125 term = termAlgebra alg . fmap3TermF var term value 126 value :: Value -> Force value 127 value = valueAlgebra alg . fmap3ValueF var term value 128 129 130instance Monoid Int where 131 mempty = 0 132 mappend = (+) 133 134main = print result 135 where 136 result = applyAlgebra alg (Value example) 137 138 alg :: SyntaxAlgebra (Forced Int) (Forced Int) (Forced Int) 139 alg = SyntaxAlgebra var term value 140 141 var x = 1 + foldMap3VarF id id id x 142 term e = 1 + foldMap3TermF id id id e 143 value v = 1 + foldMap3ValueF id id id v