Eq1

src/Core/Syntax.hs

@@ -51,7 +51,7 @@ import Data.HashMap.Strict          qualified as H
 import Data.Hashable
 import Data.Foldable                (traverse_)
 import Data.Functor
-import Data.Functor.Classes         (Show1(..), showsPrec1, showsBinaryWith)
+import Data.Functor.Classes
 import Data.Text                    qualified as T
 import Data.Char
 import Data.These
@@ -85,6 +85,9 @@ data ExprF b a = VarF Name
 
 type Expr b = Fix (ExprF b)
 
+instance IsString (ExprF b a) where
+    fromString = VarF . fromString
+
 data Type = TyFun
           | TyVar Name
           | TyApp Type Type
@@ -235,29 +238,21 @@ type ScDef' = ScDef Name
 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 (AlterF b a) (AlterF b a') (ExprF b a) (ExprF b a') where
---     _rhs = lens
+    _rhs = lens
---         (\ (Alter _ _ e) -> e)
+        (\ (AlterF _ _ e) -> e)
---         (\ (Alter t as _) e' -> Alter t as e')
+        (\ (AlterF t as _) e' -> AlterF 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 (BindingF b a) (BindingF b' a') (ExprF b a) (ExprF b' a')
---     _rhs = lens
---         (\ (_ := e) -> 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
---     _lhs = lens
---         (\ (Alter a bs _) -> (a,bs))
---         (\ (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))
@@ -532,9 +527,28 @@ instance (HasBinders (f b (Fix (f b))) (f b' (Fix (f b'))) b b')
       => HasBinders (Fix (f b)) (Fix (f b')) b b' where
     binders k (Fix f) = Fix <$> binders k f
 
--- deriveEq1 ''ExprF
+liftEqExpr :: (Eq b)
+           => (a -> a' -> Bool)
+           -> ExprF b a -> ExprF b a' -> Bool
+liftEqExpr = $(makeLiftEq ''ExprF)
 
--- deriving instance Eq b => Eq (Alter b)
+instance (Eq b, Eq a) => Eq (BindingF b a) where
--- deriving instance Eq b => Eq (Binding b)
+    BindingF ka va == BindingF kb vb =
--- deriving instance (Eq a, Eq b) => Eq (ExprF b a)
+        ka == kb && va `eq` vb
+      where eq = liftEqExpr (==)
+
+instance (Eq b, Eq a) => Eq (AlterF b a) where
+    AlterF cona bsa ea == AlterF conb bsb eb =
+        cona == conb && bsa == bsb && ea `eq` eb
+      where eq = liftEqExpr (==)
+
+instance (Eq b) => Eq1 (AlterF b) where
+    liftEq f (AlterF cona bsa ea) (AlterF conb bsb eb) =
+        cona == conb && bsa == bsb && ea `eq` eb
+      where eq = liftEqExpr f
+
+instance (Eq b) => Eq1 (BindingF b) where
+    liftEq f (BindingF ka va) (BindingF kb vb) =
+        ka == kb && va `eq` vb
+      where eq = liftEqExpr f
 

src/Core/Utils.hs

@@ -28,25 +28,29 @@ isAtomic _        = False
 
 ----------------------------------------------------------------------------------
 
-freeVariables :: Expr' -> Set Name
+freeVariables :: Expr b -> Set b
-freeVariables = cata go
+freeVariables = undefined
-    where
-        go :: ExprF Name (Set Name) -> Set Name
-        go (VarF k)         = S.singleton k
-        -- TODO: collect free vars in rhss of bs
-        go (LetF _ bs e)    = (e `S.union` esFree) `S.difference` ns
-            where
-                es = bs ^.. each . _rhs :: [Expr']
-                ns = S.fromList $ bs ^.. each . _lhs
-                -- TODO: this feels a little wrong. maybe a different scheme is
-                -- appropriate
-                esFree = foldMap id $ freeVariables <$> es
 
-        go (CaseF e as)     = e `S.union` asFree
+-- freeVariables :: Expr' -> Set Name
-            where
+-- freeVariables = cata go
-                asFree = foldMap id $ freeVariables <$> (fmap altToLam as)
+--     where
-                -- we map alts to lambdas to avoid writing a 'freeVariablesAlt'
+--         go :: ExprF Name (Set Name) -> Set Name
-                altToLam (Alter _ ns e) = Lam ns e
+--         go (VarF k)         = S.singleton k
-        go (LamF bs e)      = e `S.difference` (S.fromList bs)
+--         -- TODO: collect free vars in rhss of bs
-        go e                = foldMap id e
+--         go (LetF _ bs e)    = (e `S.union` esFree) `S.difference` ns
+--             where
+--                 es = bs ^.. each . _rhs :: [Expr']
+--                 ns = S.fromList $ bs ^.. each . _lhs
+--                 -- TODO: this feels a little wrong. maybe a different scheme is
+--                 -- appropriate
+--                 esFree = foldMap id $ freeVariables <$> es
+
+--         go (CaseF e as)     = e `S.union` asFree
+--             where
+--                 -- asFree = foldMap id $ freeVariables <$> (fmap altToLam as)
+--                 asFree = foldMap (freeVariables . altToLam) as
+--                 -- we map alts to lambdas to avoid writing a 'freeVariablesAlt'
+--                 altToLam (Alter _ ns e) = Lam ns e
+--         go (LamF bs e)      = e `S.difference` (S.fromList bs)
+--         go e                = foldMap id e
 

src/Core2Core.hs

@@ -128,9 +128,7 @@ floatNonStrictCases g = goE
         -- extract the right-hand sides of a list of bindings, traverse each
         -- one, and return the original list of bindings
         travBs :: (Expr' -> Floater Expr') -> [Binding'] -> Floater [Binding']
-        travBs c bs = bs ^.. each . _rhs
+        travBs c bs = undefined
-                    & traverse goC
-                    & const (pure bs)
         -- ^ ??? what the fuck?
         -- ^ 24/02/22: what is this shit lol?