qq

src/Gyehoek/Scheme/Syntax.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE OrPatterns #-}
@@ -17,6 +19,11 @@ module Gyehoek.Scheme.Syntax
   , CommandOrDef(..)
   , primSexpIso
   , pattern Void
+  , free
+  , qexp
+  , qprog
+  , subst
+  , freeVariables
   )
   where
 
@@ -37,11 +44,17 @@ import Control.Lens
 import Data.String (IsString)
 import Data.Hashable (Hashable)
 import Control.Lens.Unsound (prismSum)
+import Data.Data (Data)
+import Data.Functor.Foldable.TH (makeBaseFunctor)
+import Data.Functor.Foldable hiding (fold)
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HS
+import Data.Foldable (fold)
 
 
 newtype Name = MkName { getName :: Text }
   deriving newtype (Show, Eq, IsString, Gen, Hashable)
-  deriving stock (Generic)
+  deriving stock (Generic, Data)
 
 data Prim e
   = PrimAdd e e
@@ -57,7 +70,7 @@ data Prim e
   | PrimWrite e
   | PrimZeroP e
   | PrimNewline
-  deriving (Show, Generic, Functor, Foldable, Traversable)
+  deriving (Show, Generic, Functor, Foldable, Traversable, Data)
 
 instance Each (Prim e) (Prim e') e e'
 
@@ -67,7 +80,7 @@ data Lit
   | LitBool Bool
   | LitString Text
   | LitQuote Sexp
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 pattern Void :: Lit
 pattern Void = LitNil
@@ -75,7 +88,7 @@ pattern Void = LitNil
 data Def
   = DefConstant Name Exp
   | DefProcedure Name (List Name) (List Exp)
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Exp
   = ExpLet (NonEmpty (Name, Exp)) Exp
@@ -86,24 +99,24 @@ data Exp
   | ExpLambda (List Name) Exp
   | ExpVar Name
   | ExpApply Exp (List Exp)
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Sexp
   = SexpCons Sexp Sexp
   | SexpSymbol Text
   | SexpLit Lit
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data CommandOrDef
   = Command Exp
   | Definition Def
   | Begin (List CommandOrDef)
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 data Program = MkProgram
   { commandsAndDefs :: List CommandOrDef
   }
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 instance Each Program Program (Either Exp Def) (Either Exp Def) where
   each = #commandsAndDefs . each . go
@@ -116,6 +129,8 @@ instance Each Program Program (Either Exp Def) (Either Exp Def) where
       go k (Definition d) = inj <$> k (Right d)
       go k (Begin xs) = Begin <$> traverse (go k) xs
 
+makeBaseFunctor ''Exp
+
 
 
 instance SexpIso Name where
@@ -211,3 +226,41 @@ instance SexpIso CommandOrDef where
     $ End
     where
       bgn = list $ el (sym "begin") >>> rest sexpIso
+
+
+-- utilities
+
+qexp = Gyehoek.Sexp.makeSx $ sexpIso @Exp
+qprog = Gyehoek.Sexp.makeSxs (sexpIso @CommandOrDef) MkProgram
+
+free :: Exp -> HashSet Name
+free = cata \case
+  ExpVarF x -> HS.singleton x
+  ExpLetF bs e -> error "todo lol"
+  ExpLambdaF binders vs -> deleteFrom binders vs
+  e -> fold e
+
+deleteFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
+deleteFrom = flip $ foldr HS.delete
+
+insertFrom :: (Foldable f, Hashable a) => f a -> HashSet a -> HashSet a
+insertFrom = flip $ foldr HS.insert
+
+subst :: (Name -> Maybe Exp) -> Exp -> Exp
+subst f = \e -> cata go e mempty where
+  go (ExpVarF x) bound
+    | not (x `HS.member` bound), Just e' <- f x = e'
+    | otherwise                         = ExpVar x
+  go (ExpLetF _ _) _ = error "todo lol"
+  go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
+  go e bound = embed $ fmap ($ bound) e
+
+-- | Unlawful!
+freeVariables :: Traversal Exp Exp Name Exp
+freeVariables k = \e -> cataA go e mempty where
+  go (ExpVarF x) bound
+    | not (x `HS.member` bound) = k x
+    | otherwise                 = pure $ ExpVar x
+  go (ExpLetF _ _) _ = error "todo lol"
+  go (ExpLambdaF bs e) bound = e $ insertFrom bs bound
+  go e bound = embed <$> traverse ($ bound) e