Some non-working code lolhashable-gadt

3 files changed, 52 insertions, 2 deletions

diff --git a/chad-fast.cabal b/chad-fast.cabal
index 737ff62..721c77c 100644
--- a/chad-fast.cabal
+++ b/chad-fast.cabal
@@ -40,6 +40,7 @@ library
     Interpreter.Rep
     Language
     Language.AST
+    -- Language.Haskell.TH.HashableGADT
     Lemmas
     -- PreludeCu
     Simplify
@@ -49,8 +50,9 @@ library
     base >= 4.19 && < 4.21,
     containers,
     deepseq,
-    -- template-haskell,
+    -- hashable,
     prettyprinter,
+    -- template-haskell,
     transformers,
     vector,
 
diff --git a/src/Compile.hs b/src/Compile.hs
index 8d5fd13..d0e3d58 100644
--- a/src/Compile.hs
+++ b/src/Compile.hs
@@ -3,7 +3,9 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeApplications #-}
-module Compile where
+module Compile (
+  compile,
+) where
 
 import Control.Monad.Trans.State.Strict
 import Data.Bifunctor (first, second)
diff --git a/src/Language/Haskell/TH/HashableGADT.hs b/src/Language/Haskell/TH/HashableGADT.hs
new file mode 100644
index 0000000..6d638d0
--- /dev/null
+++ b/src/Language/Haskell/TH/HashableGADT.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module Language.Haskell.TH.HashableGADT (
+  deriveHashable,
+) where
+
+import Control.Category ((>>>))
+import Control.Monad (forM)
+import Data.Hashable
+import Language.Haskell.TH
+
+
+-- | The predicate indicates whether a particular field is to be included. If
+-- all fields are to be hashed, return @True@. It gets passed the name of the
+-- constructor, the index of the field, and the type of the field.
+deriveHashable :: (Name -> Int -> Type -> Bool) -> Name -> Q [Dec]
+deriveHashable includepred dataname = do
+  info <- reify dataname
+  (params, cons) <- case info of
+    TyConI (DataD [] _ params _ cons _) -> return (params, cons)
+    _ -> fail "deriveHashable: only data types supported"
+
+  saltVar <- newName "s"
+  clauses <- concat <$> mapM (processCon saltVar includepred) cons
+
+  let paramVars = map (VarT . bndrName) params
+      headType = foldl' AppT (ConT dataname) paramVars
+  return [InstanceD Nothing [] (ConT ''Hashable `AppT` headType)
+            [FunD 'hashWithSalt clauses]]
+
+processCon :: Name -> (Name -> Int -> Type -> Bool) -> Con -> Q [Clause]
+processCon saltVar includepred constr = do
+  let thd (_,_,c) = c
+  let getFields (NormalC name fields) = return [(name, map snd fields)]
+      getFields (RecC name fields) = return [(name, map thd fields)]
+      getFields (InfixC t1 name t2) = return [(name, [snd t1, snd t2])]
+      getFields (GadtC names fields _) = return [(name, map snd fields) | name <- names]
+      getFields (RecGadtC names fields _) = return [(name, map thd fields) | name <- names]
+      getFields (ForallC _ _ con) = getFields con
+
+  actualcons <- getFields constr
+  forM actualcons $ \(name, fields) -> do
+    _
+
+bndrName :: TyVarBndr flag -> Name
+bndrName (PlainTV n _) = n
+bndrName (KindedTV n _ _) = n