/Generics1.hs

  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