/
Scoped.hs
117 lines (94 loc) · 3.42 KB
/
Scoped.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Free.Scoped where
import Control.Monad (ap)
import Data.Bifoldable
import Data.Bifunctor
import Data.Bifunctor.TH
import Data.Bitraversable
import Data.Function (on)
import qualified GHC.Generics as GHC
data Inc var = Z | S var
deriving (Eq, Show, Functor, Foldable, Traversable)
type Scope term var = term (Inc var)
instantiate :: Monad f => f a -> f (Inc a) -> f a
instantiate e f = f >>= g
where
g Z = e
g (S x) = return x
data FS t a
= Pure a
| Free (t (Scope (FS t) a) (FS t a))
deriving instance (Eq a, forall x y. (Eq x, Eq y) => Eq (t x y)) => Eq (FS t a)
instance Bifunctor t => Functor (FS t) where
fmap f (Pure x) = Pure (f x)
fmap f (Free t) = Free
(bimap (fmap (fmap f)) (fmap f) t)
instance Bifoldable t => Foldable (FS t) where
foldMap f (Pure x) = f x
foldMap f (Free t) = bifoldMap (foldMap (foldMap f)) (foldMap f) t
instance Bitraversable t => Traversable (FS t) where
traverse f (Pure x) = Pure <$> f x
traverse f (Free t) = Free <$>
bitraverse (traverse (traverse f)) (traverse f) t
instance Bifunctor t => Applicative (FS t) where
pure = Pure
(<*>) = ap
instance Bifunctor t => Monad (FS t) where
return = pure
Pure x >>= f = f x
Free t >>= f = Free
(bimap ((>>= traverse f)) (>>= f) t)
data Sum f g scope term
= InL (f scope term)
| InR (g scope term)
deriving (Functor, Foldable, Traversable, GHC.Generic)
deriveBifunctor ''Sum
deriveBifoldable ''Sum
deriveBitraversable ''Sum
type (:+:) = Sum
data Empty scope term
deriving (Functor, Foldable, Traversable)
deriveBifunctor ''Empty
deriveBifoldable ''Empty
deriveBitraversable ''Empty
data AnnF ann term scope typedTerm = AnnF
{ annF :: ann typedTerm
, termF :: term scope typedTerm
} deriving (Show, Functor)
-- | Important: does not compare the `annF` component!
instance Eq (term scope typedTerm) => Eq (AnnF ann term scope typedTerm) where
(==) = (==) `on` termF
instance (Functor ann, Bifunctor term) => Bifunctor (AnnF ann term) where
bimap f g (AnnF t x) = AnnF (fmap g t) (bimap f g x)
-- | Important: does not fold over the 'annF' component!
instance Bifoldable term => Bifoldable (AnnF ann term) where
bifoldMap f g (AnnF _ty x) = {- g ty <> -} bifoldMap f g x
instance (Traversable ann, Bitraversable term) => Bitraversable (AnnF ann term) where
bitraverse f g (AnnF t x) = AnnF <$> traverse g t <*> bitraverse f g x
transFS
:: (Bifunctor term)
=> (forall s t. term s t -> term' s t)
-> FS term a -> FS term' a
transFS phi = \case
Pure x -> Pure x
Free t -> Free (phi (bimap (transFS phi) (transFS phi) t))
untyped :: (Functor ann, Bifunctor term) => FS (AnnF ann term) a -> FS term a
untyped = transFS termF
pattern ExtE :: ext (Scope (FS (t :+: ext)) a) (FS (t :+: ext) a) -> FS (t :+: ext) a
pattern ExtE t = Free (InR t)
substitute :: Bifunctor t => FS t a -> Scope (FS t) a -> FS t a
substitute t = (>>= f)
where
f Z = t
f (S y) = Pure y