From 174af2ba568de66e0d890825b8bda930b8e7bb96 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Mon, 10 Nov 2025 21:49:45 +0100
Subject: Move module hierarchy under CHAD.

---
 src/Simplify/TH.hs | 80 ------------------------------------------------------
 1 file changed, 80 deletions(-)
 delete mode 100644 src/Simplify/TH.hs

(limited to 'src/Simplify/TH.hs')

diff --git a/src/Simplify/TH.hs b/src/Simplify/TH.hs
deleted file mode 100644
index 03a74de..0000000
--- a/src/Simplify/TH.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-{-# LANGUAGE TemplateHaskellQuotes #-}
-module Simplify.TH (simprec) where
-
-import Data.Bifunctor (first)
-import Data.Char
-import Data.List (foldl', foldl1')
-import Language.Haskell.TH
-import Language.Haskell.TH.Quote
-import Text.ParserCombinators.ReadP
-
-
--- [simprec| EPair ext *a *b |]
--- ~>
--- do a' <- within (\a' -> EPair ext a' b) (simplify' a)
---    b' <- within (\b' -> EPair ext a' b') (simplify' b)
---    pure (EPair ext a' b')
-
-simprec :: QuasiQuoter
-simprec = QuasiQuoter
-  { quoteDec = \_ -> fail "simprec used outside of expression context"
-  , quoteType = \_ -> fail "simprec used outside of expression context"
-  , quoteExp = handler
-  , quotePat = \_ -> fail "simprec used outside of expression context"
-  }
-
-handler :: String -> Q Exp
-handler str =
-  case readP_to_S pTemplate str of
-    [(template, "")] -> generate template
-    _:_:_ -> fail "simprec: template grammar ambiguous"
-    _ -> fail "simprec: could not parse template"
-
-generate :: Template -> Q Exp
-generate (Template topitems) =
-  let takePrefix (Plain x : xs) = first (x:) (takePrefix xs)
-      takePrefix xs = ([], xs)
-
-      itemVar "" = error "simprec: empty item name?"
-      itemVar name@(c:_) | isLower c = VarE (mkName name)
-                         | isUpper c = ConE (mkName name)
-                         | otherwise = error "simprec: non-letter item name?"
-
-      loop :: Exp -> [Item] -> Q [Stmt]
-      loop yet [] = return [NoBindS (VarE 'pure `AppE` yet)]
-      loop yet (Plain x : xs) = loop (yet `AppE` itemVar x) xs
-      loop yet (Recurse x : xs) = do
-        primeName <- newName (x ++ "'")
-        let appPrePrime e (Plain y) = e `AppE` itemVar y
-            appPrePrime e (Recurse y) = e `AppE` itemVar y
-        let stmt = BindS (VarP primeName) $
-                     VarE (mkName "within")
-                     `AppE` LamE [VarP primeName] (foldl' appPrePrime (yet `AppE` VarE primeName) xs)
-                     `AppE` (VarE (mkName "simplify'") `AppE` VarE (mkName x))
-        stmts <- loop (yet `AppE` VarE primeName) xs
-        return (stmt : stmts)
-
-      (prefix, items') = takePrefix topitems
-  in DoE Nothing <$> loop (foldl1' AppE (map itemVar prefix)) items'
-
-data Template = Template [Item]
-  deriving (Show)
-
-data Item = Plain String | Recurse String
-  deriving (Show)
-
-pTemplate :: ReadP Template
-pTemplate = do
-  items <- many (skipSpaces >> pItem)
-  skipSpaces
-  eof
-  return (Template items)
-
-pItem :: ReadP Item
-pItem = (char '*' >> Recurse <$> pName) +++ (Plain <$> pName)
-
-pName :: ReadP String
-pName = do
-  c1 <- satisfy (\c -> isAlpha c || c == '_')
-  cs <- munch (\c -> isAlphaNum c || c `elem` "_'")
-  return (c1:cs)
-- 
cgit v1.2.3-70-g09d2