instance hell

Makefile_happysrcs

@@ -5,7 +5,7 @@ ALEX = alex
 ALEX_OPTS = -g
 
 SRC = src
-CABAL_BUILD = $(shell clisp find-build.cl)
+CABAL_BUILD = $(shell ./find-build.cl)
 
 all: parsers lexers
 

rlp.cabal

@@ -76,6 +76,7 @@ library
                     , deriving-compat ^>=0.6.0
                     , these >=0.2 && <2.0
                     , free >=5.2
+                    , bifunctors >=5.2
 
     hs-source-dirs:   src
     default-language: GHC2021

src/Compiler/JustRun.hs

@@ -44,8 +44,9 @@ justLexCore s = lexCoreR (T.pack s)
 
 justParseCore :: String -> Either [MsgEnvelope RlpcError] Program'
 justParseCore s = parse (T.pack s)
+                & undefined
                 & rlpcToEither
-    where parse = lexCoreR >=> parseCoreProgR
+    where parse = lexCoreR @Identity >=> parseCoreProgR
 
 justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
 justTypeCheckCore s = typechk (T.pack s)

src/Core/Examples.hs

@@ -10,12 +10,9 @@ import Core.Syntax
 import Core.TH
 ----------------------------------------------------------------------------------
 
--- fac3 = undefined
+letRecExample = undefined
--- sumList = undefined
--- constDivZero = undefined
--- idCase = undefined
 
----
+{--
 
 letrecExample :: Program'
 letrecExample = [coreProg|

src/Core/Lex.x

@@ -78,7 +78,7 @@ rlp :-
     "{"                     { constTok TokenLBrace }
     "}"                     { constTok TokenRBrace }
     ";"                     { constTok TokenSemicolon }
-    "::"                    { constTok TokenHasType }
+    ":"                     { constTok TokenHasType }
     "@"                     { constTok TokenTypeApp }
     "{-#"                   { constTok TokenLPragma `andBegin` pragma }
 

src/Core/Parse.y

@@ -66,7 +66,7 @@ import Core.Parse.Types
       '{-#'           { Located _ TokenLPragma }
       '#-}'           { Located _ TokenRPragma }
       ';'             { Located _ TokenSemicolon }
-      '::'            { Located _ TokenHasType }
+      ':'             { Located _ TokenHasType }
       eof             { Located _ TokenEOF }
 
 %%
@@ -75,8 +75,8 @@ Eof             :: { () }
 Eof             : eof           { () }
                 | error         { () }
 
-StandaloneProgram :: { Program PsName }
+StandaloneProgram :: { Program Var }
-StandaloneProgram : Program eof                 { $1 }
+StandaloneProgram : Program eof                 {% finishTyping $1 }
 
 Program         :: { Program PsName }
 Program         : ScTypeSig ';' Program         { insTypeSig ($1 & _1 %~ Left) $3 }
@@ -98,7 +98,7 @@ OptSemi         : ';'                           { () }
                 | {- epsilon -}                 { () }
 
 ScTypeSig       :: { (Name, Type) }
-ScTypeSig       : Id '::' Type                  { ($1, $3 TyKindType) }
+ScTypeSig       : Id ':' Type                   { ($1, $3) }
 
 ScDefs          :: { [ScDef PsName] }
 ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
@@ -106,22 +106,19 @@ ScDefs          : ScDef ';' ScDefs              { $1 : $3 }
                 | ScDef                         { [$1] }
 
 ScDef           :: { ScDef PsName }
-ScDef           : Id ParList '=' Expr          { ScDef (Left $1) $2
+ScDef           : Id ParList '=' Expr   { ScDef (Left $1) $2
-                                                  ($4 & _binders %~ Right) }
+                                                ($4 & binders %~ Right) }
 
-Type            :: { Kind -> Type }
+Type            :: { Type }
-                : Type1 '->' Type   { \case
+                : Type1 '->' Type               { $1 :-> $3 }
-                                        TyKindType ->
-                                          $1 TyKindType :-> $3 TyKindType
-                                        _ -> error "kind mismatch" }
                 | Type1                         { $1 }
 
 -- do we want to allow symbolic names for tyvars and tycons?
 
-Type1           :: { Kind -> Type }
+Type1           :: { Type }
 Type1           : '(' Type ')'                  { $2 }
-                | varname                       { \k -> TyVar $1 }
+                | varname                       { TyVar $1 }
-                | conname                       { \k -> TyCon $ MkTyCon $1 k }
+                | conname                       { TyCon $1 }
 
 ParList         :: { [PsName] }
 ParList         : varname ParList               { Left $1 : $2 }
@@ -150,7 +147,7 @@ Application     : Application AppArg           { App $1 $2 }
                 | Expr1       AppArg           { App $1 $2 }
 
 AppArg          :: { Expr Var }
-                : '@' Type1                     { Type ($2 TyKindInferred) }
+                : '@' Type1                     { Type $2 }
                 | Expr1                         { $1 }
 
 CaseExpr        :: { Expr Var }
@@ -191,7 +188,7 @@ Id              :: { Name }
                 | conname                           { $1 }
 
 Var             :: { Var }
-Var             : '(' varname '::' Type ')'         { MkVar $2 ($4 TyKindType) }
+Var             : '(' varname ':' Type ')'          { MkVar $2 $4 }
 
 {
 
@@ -200,19 +197,13 @@ parseError (Located _ t : _) =
     error $ "<line>" <> ":" <> "<col>"
          <> ": parse error at token `" <> show t <> "'"
 
-{-# WARNING parseError "unimpl" #-}
-
 exprPragma :: [String] -> RLPC (Expr Var)
 exprPragma ("AST" : e) = undefined
 exprPragma _           = undefined
 
-{-# WARNING exprPragma "unimpl" #-}
-
 astPragma :: [String] -> RLPC (Expr Var)
 astPragma _ = undefined
 
-{-# WARNING astPragma "unimpl" #-}
-
 insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
 insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
 
@@ -234,9 +225,8 @@ parseCoreProgR s = do
     let p = runP (parseCoreProg s) def
     case p of
         (st, Just a) -> do
-            let a' = finishTyping st a
+            ddumpast a
-            ddumpast a'
+            pure a
-            pure a'
   where
     ddumpast :: Show a => Program a -> RLPCT m (Program a)
     ddumpast p = do

src/Core/Parse/Types.hs

@@ -53,6 +53,6 @@ type PsName = Either Name Var
 
 --------------------------------------------------------------------------------
 
-finishTyping :: PState -> Program PsName -> Program Var
+finishTyping :: Program PsName -> P (Program Var)
-finishTyping = undefined
+finishTyping = error . show
 

src/Core/Syntax.hs

@@ -8,33 +8,33 @@ Description : Core ASTs and the like
 -- for recursion-schemes
 {-# LANGUAGE DeriveTraversable, TypeFamilies #-}
 module Core.Syntax
-    (
+    -- (
-    -- * Core AST
+    -- -- * Core AST
-      ExprF(..), ExprF'
+    --   ExprF(..), ExprF'
-    , ScDef(..), ScDef'
+    -- , ScDef(..), ScDef'
-    , Program(..), Program'
+    -- , Program(..), Program'
-    , Type(..), Kind, pattern (:->), pattern TyInt
+    -- , Type(..), Kind, pattern (:->), pattern TyInt
-    , Alter(..), Alter', AltCon(..)
+    -- , Alter(..), Alter', AltCon(..)
-    , Rec(..), Lit(..)
+    -- , Rec(..), Lit(..)
-    , Pragma(..)
+    -- , Pragma(..)
-    -- ** Variables and identifiers
+    -- -- ** Variables and identifiers
-    , Name, Var(..), TyCon(..), Tag
+    -- , Name, Var(..), Tag
-    , Binding(..), pattern (:=), pattern (:$)
+    -- , Binding(..), pattern (:=), pattern (:$)
-    , type Binding'
+    -- , type Binding'
-    -- ** Working with the fixed point of ExprF
+    -- -- ** Working with the fixed point of ExprF
-    , Expr, Expr'
+    -- , Expr, Expr'
-    , pattern Con, pattern Var, pattern App, pattern Lam, pattern Let
+    -- , pattern Con, pattern Var, pattern App, pattern Lam, pattern Let
-    , pattern Case, pattern Type, pattern Lit
+    -- , pattern Case, pattern Type, pattern Lit
 
-    -- * Misc
+    -- -- * Misc
-    , Pretty(pretty)
+    -- , Pretty(pretty)
 
-    -- * Optics
+    -- -- * Optics
-    , programScDefs, programTypeSigs, programDataTags
+    -- , programScDefs, programTypeSigs, programDataTags
-    , formalising
+    -- , formalising
-    , HasRHS(_rhs), HasLHS(_lhs)
+    -- , HasRHS(_rhs), HasLHS(_lhs)
-    , HasBinders(_binders)
+    -- , HasBinders(binders)
-    )
+    -- )
     where
 ----------------------------------------------------------------------------------
 import Data.Coerce
@@ -45,6 +45,8 @@ import Data.String
 import Data.HashMap.Strict          (HashMap)
 import Data.HashMap.Strict          qualified as H
 import Data.Hashable
+import Data.Foldable                (traverse_)
+import Data.Functor.Classes         (Show1(..), showsPrec1, showsBinaryWith)
 import Data.Text                    qualified as T
 import Data.Char
 import Data.These
@@ -53,20 +55,24 @@ import Text.Show.Deriving
 import Data.Eq.Deriving
 
 import Data.Fix                     hiding (cata, ana)
-import Data.Bifoldable              (bifoldr)
+import Data.Bifunctor               (Bifunctor(..))
+import Data.Bifoldable              (bifoldr, Bifoldable(..))
+import Data.Bifunctor.TH
+import Data.Bitraversable
 import Data.Functor.Foldable
 import Data.Functor.Foldable.TH     (makeBaseFunctor)
 
 -- Lift instances for the Core quasiquoters
+import Misc
 import Misc.Lift1
 import Control.Lens
 ----------------------------------------------------------------------------------
 
 data ExprF b a = VarF Name
                | ConF Tag Int -- ^ Con Tag Arity
-               | CaseF a [Alter b]
+               | CaseF a [AlterF b a]
                | LamF [b] a
-               | LetF Rec [Binding b] a
+               | LetF Rec [BindingF b a] a
                | AppF a a
                | LitF Lit
                | TypeF Type
@@ -77,16 +83,15 @@ type Expr b = Fix (ExprF b)
 data Type = TyFun
           | TyVar Name
           | TyApp Type Type
-          | TyCon TyCon
+          | TyCon Name
           | TyForall Var Type
           | TyKindType
-          | TyKindInferred
           deriving (Show, Eq, Lift)
 
 type Kind = Type
 
-data TyCon = MkTyCon Name Kind
+-- data TyCon = MkTyCon Name Kind
-    deriving (Eq, Show, Lift)
+--     deriving (Eq, Show, Lift)
 
 data Var = MkVar Name Type
     deriving (Eq, Show, Lift)
@@ -94,51 +99,65 @@ data Var = MkVar Name Type
 instance Hashable Var where
     hashWithSalt s (MkVar n _) = hashWithSalt s n
 
-pattern Con :: Tag -> Int -> Expr b
+-- pattern Con :: Tag -> Int -> Expr b
-pattern Con t a = Fix (ConF t a)
+-- pattern Con t a = Fix (ConF t a)
 
-pattern Var :: Name -> Expr b
+-- pattern Var :: Name -> Expr b
-pattern Var b = Fix (VarF b)
+-- pattern Var b = Fix (VarF b)
 
-pattern App :: Expr b -> Expr b -> Expr b
+-- pattern App :: Expr b -> Expr b -> Expr b
-pattern App f x = Fix (AppF f x)
+-- pattern App f x = Fix (AppF f x)
 
-pattern Lam :: [b] -> Expr b -> Expr b
+-- pattern Lam :: [b] -> Expr b -> Expr b
-pattern Lam bs e = Fix (LamF bs e)
+-- pattern Lam bs e = Fix (LamF bs e)
 
-pattern Let :: Rec -> [Binding b] -> Expr b -> Expr b
+-- pattern Let :: Rec -> [Binding b] -> Expr b -> Expr b
-pattern Let r bs e = Fix (LetF r bs e)
+-- pattern Let r bs e = Fix (LetF r bs e)
 
-pattern Case :: Expr b -> [Alter b] -> Expr b
+-- pattern Case :: Expr b -> [Alter b] -> Expr b
-pattern Case e as = Fix (CaseF e as)
+-- pattern Case e as = Fix (CaseF e as)
 
-pattern Type :: Type -> Expr b
+-- pattern Type :: Type -> Expr b
-pattern Type t = Fix (TypeF t)
+-- pattern Type t = Fix (TypeF t)
 
-pattern Lit :: Lit -> Expr b
+-- pattern Lit :: Lit -> Expr b
-pattern Lit t = Fix (LitF t)
+-- pattern Lit t = Fix (LitF t)
 
-pattern TyInt :: Type
+-- pattern TyInt :: Type
-pattern TyInt = TyCon (MkTyCon "Int#" TyKindType)
+-- pattern TyInt = TyCon "Int#"
 
 infixr 1 :->
 pattern (:->) :: Type -> Type -> Type
 pattern a :-> b = TyApp (TyApp TyFun a) b
 
-{-# COMPLETE Binding :: Binding #-}
+-- {-# COMPLETE Binding :: Binding #-}
-{-# COMPLETE (:=) :: Binding #-}
+-- {-# COMPLETE (:=) :: Binding #-}
 
-data Binding b = Binding b (Expr b)
+data BindingF b a = BindingF b (ExprF b a)
+    deriving (Functor, Foldable, Traversable)
 
-infixl 1 :=
+-- type Binding b = Fix (BindingF b)
-pattern (:=) :: b -> Expr b -> Binding b
-pattern k := v = Binding k v
 
-infixl 2 :$
+-- collapse = foldFix embed
-pattern (:$) :: Expr b -> Expr b -> Expr b
-pattern f :$ x = App f x
 
-data Alter b = Alter AltCon [b] (Expr b)
+-- pattern Binding :: b -> Expr b -> Binding b
+-- pattern Binding k v <- Fix (BindingF k (undefined -> v))
+--     where Binding k v = Fix (BindingF k undefined)
+
+-- infixl 1 :=
+-- pattern (:=) :: b -> Expr b -> Binding b
+-- pattern k := v = Binding k v
+
+-- infixl 2 :$
+-- pattern (:$) :: Expr b -> Expr b -> Expr b
+-- pattern f :$ x = App f x
+
+data AlterF b a = AlterF AltCon [b] (ExprF b a)
+    deriving (Functor, Foldable, Traversable)
+
+-- pattern Alter :: AltCon -> [b] -> Expr b -> Alter b
+-- pattern Alter con bs e <- Fix (AlterF con bs (undefined -> e))
+--     where Alter con bs e = Fix (AlterF con bs undefined)
 
 newtype Pragma = Pragma [T.Text]
 
@@ -160,8 +179,8 @@ type Tag = Int
 
 data ScDef b = ScDef b [b] (Expr b)
 
-unliftScDef :: ScDef b -> Expr b
+-- unliftScDef :: ScDef b -> Expr b
-unliftScDef (ScDef _ as e) = Lam as e
+-- unliftScDef (ScDef _ as e) = Lam as e
 
 data Module b = Module (Maybe (Name, [Name])) (Program b)
 
@@ -190,57 +209,49 @@ type ExprF' = ExprF Name
 type Program' = Program Name
 type Expr' = Expr Name
 type ScDef' = ScDef Name
-type Alter' = Alter Name
+-- type Alter' = Alter Name
-type Binding' = Binding Name
+-- type Binding' = Binding Name
 
-instance IsString (Expr b) where
+-- instance IsString (Expr b) where
-    fromString = Var . fromString
+--     fromString = Var . fromString
 
 ----------------------------------------------------------------------------------
 
-class HasBinders s t a b | s -> a, t -> b, s b -> t, t a -> s where
-    _binders :: Traversal s t a b
-
-instance HasBinders (Expr b) (Expr b') b b' where
-    _binders k = cata go where
-        go :: Applicative f => ExprF b (f (Expr b')) -> f (Expr b')
-        go = undefined
-
 class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
     _rhs :: Lens s t a b
 
-instance HasRHS (Alter b) (Alter b) (Expr b) (Expr b) where
+-- instance HasRHS (Alter b) (Alter b) (Expr b) (Expr b) where
-    _rhs = lens
+--     _rhs = lens
-        (\ (Alter _ _ e) -> e)
+--         (\ (Alter _ _ e) -> e)
-        (\ (Alter t as _) e' -> Alter t as e')
+--         (\ (Alter t as _) e' -> Alter t as e')
 
 instance HasRHS (ScDef b) (ScDef b) (Expr b) (Expr b) where
     _rhs = lens
         (\ (ScDef _ _ e) -> e)
         (\ (ScDef n as _) e' -> ScDef n as e')
 
-instance HasRHS (Binding b) (Binding b) (Expr b) (Expr b) where
+-- instance HasRHS (Binding b) (Binding b) (Expr b) (Expr b) where
-    _rhs = lens
+--     _rhs = lens
-        (\ (_ := e) -> e)
+--         (\ (_ := e) -> e)
-        (\ (k := _) e' -> k := e')
+--         (\ (k := _) e' -> k := e')
 
 class HasLHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
     _lhs :: Lens s t a b
 
-instance HasLHS (Alter b) (Alter b) (AltCon, [b]) (AltCon, [b]) where
+-- instance HasLHS (Alter b) (Alter b) (AltCon, [b]) (AltCon, [b]) where
-    _lhs = lens
+--     _lhs = lens
-        (\ (Alter a bs _) -> (a,bs))
+--         (\ (Alter a bs _) -> (a,bs))
-        (\ (Alter _ _ e) (a',bs') -> Alter a' bs' e)
+--         (\ (Alter _ _ e) (a',bs') -> Alter a' bs' e)
 
 instance HasLHS (ScDef b) (ScDef b) (b, [b]) (b, [b]) where
     _lhs = lens
         (\ (ScDef n as _) -> (n,as))
         (\ (ScDef _ _ e) (n',as') -> ScDef n' as' e)
 
-instance HasLHS (Binding b) (Binding b) b b where
+-- instance HasLHS (Binding b) (Binding b) b b where
-    _lhs = lens
+    -- _lhs = lens
-        (\ (k := _) -> k)
+    --     (\ (k := _) -> k)
-        (\ (_ := e) k' -> k' := e)
+    --     (\ (_ := e) k' -> k' := e)
 
 -- | This is not a valid isomorphism for expressions containing lambdas whose
 -- bodies are themselves lambdas with multiple arguments:
@@ -253,18 +264,18 @@ instance HasLHS (Binding b) (Binding b) b b where
 -- For this reason, it's best to consider 'formalising' as if it were two
 -- unrelated unidirectional getters.
 
-formalising :: Iso (Expr a) (Expr b) (Expr a) (Expr b)
+-- formalising :: Iso (Expr a) (Expr b) (Expr a) (Expr b)
-formalising = iso sa bt where
+-- formalising = iso sa bt where
-    sa :: Expr a -> Expr a
+--     sa :: Expr a -> Expr a
-    sa = ana \case
+--     sa = ana \case
-        Lam [b] e    -> LamF [b] e
+--         Lam [b] e    -> LamF [b] e
-        Lam (b:bs) e -> LamF [b] (Lam bs e)
+--         Lam (b:bs) e -> LamF [b] (Lam bs e)
-        x            -> project x
+--         x            -> project x
 
-    bt :: Expr b -> Expr b
+--     bt :: Expr b -> Expr b
-    bt = cata \case
+--     bt = cata \case
-        LamF [b] (Lam bs e) -> Lam (b:bs) e
+--         LamF [b] (Lam bs e) -> Lam (b:bs) e
-        x                   -> embed x
+--         x                   -> embed x
 
 --------------------------------------------------------------------------------
 
@@ -320,22 +331,22 @@ instance (Pretty b) => Pretty (ScDef b) where
             e = pretty $ sc ^. _rhs
 
 instance (Pretty b) => Pretty (Expr b) where
-    prettyPrec _ (Var n)      = ttext n
+    -- prettyPrec _ (Var n)      = ttext n
-    prettyPrec _ (Con t a)    = "Pack{" <> (ttext t <+> ttext a) <> "}"
+    -- prettyPrec _ (Con t a)    = "Pack{" <> (ttext t <+> ttext a) <> "}"
-    prettyPrec _ (Lam bs e)   = hsep ["λ", hsep (prettyPrec 1 <$> bs), "->", pretty e]
+    -- prettyPrec _ (Lam bs e)   = hsep ["λ", hsep (prettyPrec 1 <$> bs), "->", pretty e]
-    prettyPrec _ (Let r bs e) = hsep [word, explicitLayout bs]
+    -- prettyPrec _ (Let r bs e) = hsep [word, explicitLayout bs]
-                            $+$ hsep ["in", pretty e]
+    --                         $+$ hsep ["in", pretty e]
-        where word = if r == Rec then "letrec" else "let"
+    --     where word = if r == Rec then "letrec" else "let"
-    prettyPrec p (App f x)    = maybeParens (p>0) $
+    -- prettyPrec p (App f x)    = maybeParens (p>0) $
-        prettyPrec 0 f <+> prettyPrec 1 x
+    --     prettyPrec 0 f <+> prettyPrec 1 x
-    prettyPrec _ (Lit l)      = pretty l
+    -- prettyPrec _ (Lit l)      = pretty l
-    prettyPrec p (Case e as)  = maybeParens (p>0) $
+    -- prettyPrec p (Case e as)  = maybeParens (p>0) $
-        "case" <+> pretty e <+> "of"
+    --     "case" <+> pretty e <+> "of"
-        $+$ nest 2 (explicitLayout as)
+    --     $+$ nest 2 (explicitLayout as)
 
-instance (Pretty b) => Pretty (Alter b) where
+instance (Pretty b, Pretty a) => Pretty (AlterF b a) where
-    pretty (Alter c as e) =
+    -- pretty (Alter c as e) =
-        hsep [pretty c, hsep (pretty <$> as), "->", pretty e]
+    --     hsep [pretty c, hsep (pretty <$> as), "->", pretty e]
 
 instance Pretty AltCon where
     pretty (AltData n) = ttext n
@@ -346,43 +357,127 @@ instance Pretty AltCon where
 instance Pretty Lit where
     pretty (IntL n) = ttext n
 
-instance (Pretty b) => Pretty (Binding b) where
+instance (Pretty b, Pretty a) => Pretty (BindingF b a) where
-    pretty (k := v) = hsep [pretty k, "=", pretty v]
+    -- pretty (k := v) = hsep [pretty k, "=", pretty v]
 
 explicitLayout :: (Pretty a) => [a] -> Doc
 explicitLayout as = vcat inner <+> "}" where
     inner = zipWith (<+>) delims (pretty <$> as)
     delims = "{" : repeat ";"
 
-instance Pretty TyCon
+-- instance Pretty TyCon
 instance Pretty Var
 
 --------------------------------------------------------------------------------
 
+-- instance Functor Alter where
+--     fmap f (Alter con bs e) = Alter con (f <$> bs) e'
+--         where
+--             e' = foldFix (embed . bimap' f id) e
+--             bimap' = $(makeBimap ''ExprF)
+
+-- instance Foldable Alter where
+-- instance Traversable Alter where
+-- instance Functor Binding where
+-- instance Foldable Binding where
+-- instance Traversable Binding where
+
+liftShowsPrecExpr :: (Show b)
+                  => (Int -> a -> ShowS)
+                  -> ([a] -> ShowS)
+                  -> Int -> ExprF b a -> ShowS
+liftShowsPrecExpr = $(makeLiftShowsPrec ''ExprF)
+
+instance (Show b) => Show1 (AlterF b) where
+    liftShowsPrec sp spl d (AlterF con bs e) =
+        showsTernaryWith showsPrec showsPrec (liftShowsPrecExpr sp spl)
+                         "AlterF" d con bs e
+
+instance (Show b) => Show1 (BindingF b) where
+    liftShowsPrec sp spl d (BindingF k v) =
+        showsBinaryWith showsPrec (liftShowsPrecExpr sp spl)
+                        "BindingF" d k v
+
+instance (Show b, Show a) => Show (BindingF b a) where
+    showsPrec p (BindingF k v) =
+        showString "BindingF" . showsPrec 11 k . fuckyou 11 v
+      where
+        fuckyou = liftShowsPrecExpr showsPrec showList
+
+instance (Show b, Show a) => Show (AlterF b a) where
+
 deriveShow1 ''ExprF
 
+-- instance Bifunctor ExprF where
+--     bimap = $(makeBimap ''ExprF)
+
+-- instance Bifoldable ExprF where
+--     bifoldr = $(makeBifoldr ''ExprF)
+
+-- instance Bitraversable ExprF where
+--     bitraverse = $(makeBitraverse ''ExprF)
+
+-- instance Functor Binding where
+-- instance Foldable Binding where
+-- instance Traversable Binding where
+
+-- instance Functor Alter where
+--     fmap f (Alter con bs e) = Alter con bs' e' where
+--         bs' = f <$> bs
+--         e' = first f `hoistFix` e
+
+-- instance Foldable Alter where
+--     foldr f z (Alter con bs e) = foldr f (foldrOf binders f z e) bs
+
+-- instance Traversable Alter where
+--     traverse k (Alter con bs e) = Alter con <$> traverse k bs <*> traverseOf binders k e
+
 instance Lift b => Lift1 (ExprF b) where
-    lift1 (VarF k)      = liftCon 'VarF (lift k)
+    -- lift1 (VarF k)      = liftCon 'VarF (lift k)
-    lift1 (AppF f x)    = liftCon2 'AppF (lift f) (lift x)
+    -- lift1 (AppF f x)    = liftCon2 'AppF (lift f) (lift x)
-    lift1 (LamF b e)    = liftCon2 'LamF (lift b) (lift e)
+    -- lift1 (LamF b e)    = liftCon2 'LamF (lift b) (lift e)
-    lift1 (LetF r bs e) = liftCon3 'LetF (lift r) (lift bs) (lift e)
+    -- lift1 (LetF r bs e) = liftCon3 'LetF (lift r) (lift bs) (lift e)
-    lift1 (CaseF e as)  = liftCon2 'CaseF (lift e) (lift as)
+    -- lift1 (CaseF e as)  = liftCon2 'CaseF (lift e) (lift as)
-    lift1 (TypeF t)     = liftCon 'TypeF (lift t)
+    -- lift1 (TypeF t)     = liftCon 'TypeF (lift t)
-    lift1 (LitF l)      = liftCon 'LitF (lift l)
+    -- lift1 (LitF l)      = liftCon 'LitF (lift l)
-    lift1 (ConF t a)    = liftCon2 'ConF (lift t) (lift a)
+    -- lift1 (ConF t a)    = liftCon2 'ConF (lift t) (lift a)
 
 deriving instance (Show b, Show a) => Show (ExprF b a)
-deriving instance Show b => Show (Binding b)
+-- deriving instance (Show b, Show a) => Show (BindingF b a)
-deriving instance Show b => Show (Alter b)
+-- deriving instance (Show b, Show a) => Show (AlterF b a)
 deriving instance Show b => Show (ScDef b)
 deriving instance Show b => Show (Program b)
 
-deriving instance Lift b => Lift (Binding b)
+deriving instance (Lift b, Lift a) => Lift (ExprF b a)
-deriving instance Lift b => Lift (Alter b)
+deriving instance (Lift b, Lift a) => Lift (BindingF b a)
+deriving instance (Lift b, Lift a) => Lift (AlterF b a)
+deriving instance Lift b => Lift (ScDef b)
+deriving instance Lift b => Lift (Program b)
 
-deriveEq1 ''ExprF
+--------------------------------------------------------------------------------
 
-deriving instance Eq b => Eq (Alter b)
+class HasBinders s t a b | s -> a, t -> b, s b -> t, t a -> s where
-deriving instance Eq b => Eq (Binding b)
+    binders :: Traversal s t a b
-deriving instance (Eq a, Eq b) => Eq (ExprF b a)
+
+-- instance HasBinders (Expr b) (Expr b') b b' where
+--     binders :: forall f b b'. (Applicative f)
+--              => LensLike f (Expr b) (Expr b') b b'
+--     binders k = cata go where
+--         go :: ExprF b (f (Expr b')) -> f (Expr b')
+--         go (LamF bs e) = traverse_ k bs *> e
+--         go (CaseF e as) = traverseOf_ (each . binders) k as *> e
+--         go (LetF _ bs e) = traverseOf_ (each . binders) k bs *> e
+--         go f = wrapFix <$> bitraverse k id f
+
+-- instance HasBinders (Alter b) (Alter b') b b' where
+--     binders = undefined
+
+-- instance HasBinders (Binding b) (Binding b') b b' where
+--     binders = undefined
+
+-- deriveEq1 ''ExprF
+
+-- deriving instance Eq b => Eq (Alter b)
+-- deriving instance Eq b => Eq (Binding b)
+-- deriving instance (Eq a, Eq b) => Eq (ExprF b a)
 

src/Core/TH.hs

@@ -5,8 +5,8 @@ Description : Core quasiquoters
 module Core.TH
     ( coreExpr
     , coreProg
-    , coreExprT
+    -- , coreExprT
-    , coreProgT
+    -- , coreProgT
     )
     where
 ----------------------------------------------------------------------------------
@@ -33,18 +33,18 @@ coreExpr :: QuasiQuoter
 coreExpr = mkqq $ lexCoreR >=> parseCoreExprR
 
 -- | Type-checked @coreProg@
-coreProgT :: QuasiQuoter
+-- coreProgT :: QuasiQuoter
-coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
+-- coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR
 
-coreExprT :: QuasiQuoter
+-- coreExprT :: QuasiQuoter
-coreExprT = mkqq $ lexCoreR >=> parseCoreExprR >=> checkCoreExprR g
+-- coreExprT = mkqq $ lexCoreR >=> parseCoreExprR >=> checkCoreExprR g
-    where
+--     where
-        g = [ ("+#", TyInt :-> TyInt :-> TyInt)
+--         g = [ ("+#", TyInt :-> TyInt :-> TyInt)
-            , ("id", TyForall (MkVar "a" TyKindType) $
+--             , ("id", TyForall (MkVar "a" TyKindType) $
-                    TyVar "a" :-> TyVar "a")
+--                     TyVar "a" :-> TyVar "a")
-            , ("fix", TyForall (MkVar "a" TyKindType) $
+--             , ("fix", TyForall (MkVar "a" TyKindType) $
-                    (TyVar "a" :-> TyVar "a") :-> TyVar "a")
+--                     (TyVar "a" :-> TyVar "a") :-> TyVar "a")
-            ]
+--             ]
 
 mkqq :: (Lift a) => (Text -> RLPCIO a) -> QuasiQuoter
 mkqq p = QuasiQuoter

src/Misc.hs

@@ -0,0 +1,17 @@
+module Misc where
+--------------------------------------------------------------------------------
+import Data.Functor.Classes
+--------------------------------------------------------------------------------
+
+
+showsTernaryWith :: (Int -> a -> ShowS)
+                 -> (Int -> b -> ShowS)
+                 -> (Int -> c -> ShowS)
+                 -> String -> Int -> a -> b -> c -> ShowS
+showsTernaryWith sp1 sp2 sp3 name d x y z
+    = showParen (d > 10)
+    $ showString name . showChar ' '
+    . sp1 11 x . showChar ' '
+    . sp2 11 y . showChar ' '
+    . sp3 11 z
+