a = LamAbs (Var a) (Ast a) -- \x. e | App (Ast a) (Ast a) -- e e' | FreeVar (Var a) -- x type Var a = AnnotT VarR a data VarR a = Var Int data AnnotT f a = AnnotT (f a) a unAnnot :: AnnotT f a -> a unAnnot (AnnotT _ x) = x ΞϊςʔγϣϯใΛڞ௨ͷܕίϯετϥΫλͰཧɽ 3 / 18
r) a unAnnot :: AnnotT f a r -> a unAnnot (AnnotT _ x) = x newtype Fix f = Fix (f (Fix f)) type Ast a = Fix (AnnotT AstF a) data AstF r = LamAbs Var r | App r r | FreeVar Var newtype Var = Var Int recursion base ΛΞϊςʔγϣϯใΛ࣋ͭΑ͏มɽ 4 / 18
= a :< f (Cofree f a) https://www.stackage.org/haddock/lts-12.17/free-5.0.2/ Control-Comonad-Cofree.html#t:Cofree • ଟ͘ͷσʔλܕͷجૅʹͳΔɽ • Cofree Maybe a ≃ NonEmpty a ≃ (a, [a]) • Cofree (Const b) a ≃ (a, b) • Cofree [] a ≃ Tree a • Free ͷର: ҙͷ Functor f ͔Β Comonad ͕ಋग़Մೳɽ • Fix (AnnotT f a) ͱಉܕ: ͜ͷ༻ํ๏͕ cofree annotation ͱݺΕΔख๏ʹͳΔɽ 5 / 18
extract type Ast = Cofree AstF data AstF r = LamAbs Var r | App r r | FreeVar Var newtype Var = Var Int • cofree ͷڞ௨ϢʔςΟϦςΟΛྲྀ༻Ͱ͖Δɽ • hoistCofree :: Functor f => (forall x. f x -> g x) -> Cofree f a -> Cofree g a ͰɼΞϊςʔγϣϯใ Λͦͷ··ʹมΛ࣮Ͱ͖Δɽ(࣮ࡍ (ry) 6 / 18
ͱಉ͡Α͏ʹ base ͷΛ࡞ͬͯ fix ͨ͠ޙࣹӨ type Expr a = AnnotT ExprR a data ExprR a = Let [Decl a] (Expr a) | NumLit Int | FreeVar Var type Decl a = AnnotT DeclR a data DeclR a = Decl Var (Expr a) data Var = Var Int 7 / 18
HCofree (f (HCofree f a) i) a unAnnot :: HCofree f a i -> a unAnnot (HCofree _ x) = x type Ast = HCofree AstF • HCofree f :: (j -> Type) -> (j -> Type) ্ͷԋࢉ ࢠ 1(Cofree f :: Type -> Type ্ͷԋࢉࢠ)ɽ • Maybe [] ͷ higher order ൛Λߟ͑ΕɼHCofree Λͬͯ ܕ҆શͳ tree ͕࡞ΕͨΓ͢Δɽ • HCofree (Compose f) a i ≃ Const (Cofree f a) i • HCofree (Sum f) a i ≃ Cofree (Either (f i)) a 1ཁؔखݍ্Ͱ initial algebra Λ୳ͭ͢ɽ 9 / 18
equality ΛแؚͰ͖Δɽ • Haskell քͰ͜ͷ໊લͰఆணͯ͠Δ͚Ͳɼ[SP08] ͰΘΕͯ Δ equality quantified types ͷํ͕ػೳ͕૾͍͔͢͠ɽ type equality: data TypeEq a b = TypeEq (forall f. f a -> f b) typeEq :: a ~ b => TypeEq a b typeEq = TypeEq id data CTEq a b = forall c. (c ~ a, c ~ b) => CTEq fromTypeEq :: TypeEq a b -> (a ~ b => r) -> r fromTypeEq (TypeEq f) r = case f CTEq of CTEq -> r 10 / 18
Int | D2 data D a where D1 :: a -> Int -> D a D2 :: D a GADTs ͷ߹ɼҎԼͷΑ͏ͳσʔλܕఆٛՄೳɽ data D a where D :: Int -> D Int -- :: forall a. (a ~ Int) => a -> D a 11 / 18
TagLit data ExprF r where Let :: [r 'TagDecl] -> r 'TagExpr -> ExprF r VarExpr :: r 'TagVar -> ExprF r LitExpr :: r 'TagLit -> ExprF r data DeclF r where Decl :: r 'TagVar -> r 'TagExpr -> DeclF r data VarF r where Var :: Int -> VarF r data LitF r where BoolLit :: Bool -> LitF r 12 / 18
-> AstF r 'TagExpr AstDeclF :: DeclF r -> AstF r 'TagDecl AstVarF :: VarF r -> AstF r 'TagVar AstLitF :: LitF r -> AstF r 'TagLit • HCofree ͷͨΊʹɼͦΕͧΕΛ 1 ͭͷ recursion base ʹ౷߹ ͢Δɽ • higher order open union ͱ͔Λ࡞Εɼ͜͏͍͏ͷΛҰʑ࡞Δ ඞཁͳ͍ɽ • ܕλάΛ۩ମతʹࢦఆͨ͠߹ɼύλʔϯϚονͷཏੑ νΣοΫͰܕߟྀʹೖΕΒΕΔͨΊɼܕ҆શੑΛอࣹͬͨ ӨΛఆٛͰ͖Δɽ 13 / 18
{ unNat :: forall i. a i -> b i } instance Category (:~>) where id = Nat id Nat f . Nat g = Nat (f . g) -- | A higher order functor -- -- > hfmap id == id -- > hfmap (f . g) == hfmap f . hfmap g -- class HFunctor f where hfmap :: a :~> b -> f a :~> f b Cofree ʹ͓͚Δ Functor ͷϢʔςΟϦςΟɼHCofree ʹ͓͍ͯ ͜ͷ HFunctor ΛͬͯఆٛՄೳɽ 14 / 18
(f (HCofree f a) i) (a i) hunwrap :: HCofree f a :~> f (HCofree f a) hunwrap = Nat \(HCofree r _) -> r hextract :: HCofree f a :~> a hextract = Nat \(HCofree _ x) -> x hextend :: HFunctor f => (HCofree f a :~> b) -> HCofree f a :~> HCofree f b hextend (Nat f) = go where go = Nat \w -> HCofree (unNat (hfmap go . hunwrap) w) (f w) 15 / 18
ʹૉʹରԠͰ͖ɼ៉ ྷͳߏΛ͍࣋ͬͯΔ͕ɼͦΕ͚ͩͰͳ࣮͘༻తʹ༗ӹɽ • ΞϊςʔγϣϯΛܕλάʹΑͬͯྨͰ͖Δɽ • higher order ͳੈքͰ݁Ͱ͖Δ (௨ৗͷɼConst ʹΑͬ ͯ higher order ͳੈքʹ࣋ͬͯ͜ΕΔ) ۩ମతͳΞϊςʔγϣϯྫ: type family HasTyp (tag :: TagAst) :: Bool where HasTyp 'TagDecl = 'False HasTyp _ = 'True data TypAnn i where TypAnn :: HasTyp i ~ 'True => TypInfo -> TypAnn i NoTypAnn :: HasTyp i ~ 'False => TypAnn i 16 / 18