From d3bcbf9624da65439bcf6c4b530ed338929ad246 Mon Sep 17 00:00:00 2001
From: crumbtoo <crumb@disroot.org>
Date: Thu, 22 Feb 2024 14:05:29 -0700
Subject: [PATCH] things

---
 rlp.cabal            |  5 +++--
 src/Compiler/RLPC.hs |  5 ++++-
 src/Core/Utils.hs    | 11 -----------
 src/Core2Core.hs     |  3 ++-
 src/Misc/Lift1.hs    | 41 +++++++++++++++++++++++++++++++++++++++++
 5 files changed, 50 insertions(+), 15 deletions(-)
 create mode 100644 src/Misc/Lift1.hs

diff --git a/rlp.cabal b/rlp.cabal
index 7b67721..d427738 100644
--- a/rlp.cabal
+++ b/rlp.cabal
@@ -62,7 +62,7 @@ library
                     , data-default-class >= 0.1.2 && < 0.2
                     , hashable >= 1.4.3 && < 1.5
                     , mtl >= 2.3.1 && < 2.4
-                    , text >= 2.0.2 && < 2.1
+                    , text >= 2.0.2 && < 2.2
                     , unordered-containers >= 0.2.20 && < 0.3
                     , recursion-schemes >= 5.2.2 && < 5.3
                     , data-fix >= 0.3.2 && < 0.4
@@ -89,6 +89,7 @@ library
         DerivingVia
         StandaloneDeriving
         DerivingStrategies
+        BlockArguments
 
 executable rlpc
     import:           warnings
@@ -102,7 +103,7 @@ executable rlpc
                  , mtl >= 2.3.1 && < 2.4
                  , unordered-containers >= 0.2.20 && < 0.3
                  , lens >=5.2.3 && <6.0
-                 , text >= 2.0.2 && < 2.1
+                 , text >= 2.0.2 && < 2.2
 
     hs-source-dirs:   app
     default-language: GHC2021
diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs
index 1ea0ddd..7068e5d 100644
--- a/src/Compiler/RLPC.hs
+++ b/src/Compiler/RLPC.hs
@@ -27,7 +27,7 @@ module Compiler.RLPC
     -- ** Lenses
     , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
     -- * Misc. MTL-style functions
-    , liftErrorful, hoistRlpcT
+    , liftErrorful, liftMaybe, hoistRlpcT
     -- * Misc. Rlpc Monad -related types
     , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
     , MsgEnvelope(..), Severity(..)
@@ -108,6 +108,9 @@ evalRLPCT opt r = runRLPCT r
 liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
 liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
 
+liftMaybe :: (Monad m) => Maybe a -> RLPCT m a
+liftMaybe m = RLPCT . lift . ErrorfulT . pure $ (m, [])
+
 hoistRlpcT :: (forall a. m a -> n a)
          -> RLPCT m a -> RLPCT n a
 hoistRlpcT f rma = RLPCT $ ReaderT $ \opt ->
diff --git a/src/Core/Utils.hs b/src/Core/Utils.hs
index 7d62bba..68fc1be 100644
--- a/src/Core/Utils.hs
+++ b/src/Core/Utils.hs
@@ -2,8 +2,6 @@ module Core.Utils
     ( programRhss
     , programGlobals
     , isAtomic
-    -- , insertModule
-    , extractProgram
     , freeVariables
     )
     where
@@ -30,15 +28,6 @@ isAtomic _        = False
 
 ----------------------------------------------------------------------------------
 
--- TODO: export list awareness
--- insertModule :: Module b -> Program b -> Program b
--- insertModule (Module _ p) = programScDefs %~ (<>m)
-
-extractProgram :: Module b -> Program b
-extractProgram (Module _ p) = p
-
-----------------------------------------------------------------------------------
-
 freeVariables :: Expr' -> Set Name
 freeVariables = cata go
     where
diff --git a/src/Core2Core.hs b/src/Core2Core.hs
index 6fa535d..eb33eff 100644
--- a/src/Core2Core.hs
+++ b/src/Core2Core.hs
@@ -116,7 +116,7 @@ floatNonStrictCases g = goE
             goE e
             traverse_ goE altBodies
             pure e'
-        goC (f :$ x)            = (:$) <$> goC f <*> goC x
+        goC (App f x)           = App <$> goC f <*> goC x
         goC (Let r bs e)        = Let r <$> bs' <*> goE e
             where bs' = travBs goC bs
         goC (Lit l)             = pure (Lit l)
@@ -132,6 +132,7 @@ floatNonStrictCases g = goE
                     & traverse goC
                     & const (pure bs)
         -- ^ ??? what the fuck?
+        -- ^ 24/02/22: what is this shit lol?
 
 -- when provided with a case expr, floatCase will float the case into a
 -- supercombinator of its free variables. the sc is returned along with an
diff --git a/src/Misc/Lift1.hs b/src/Misc/Lift1.hs
new file mode 100644
index 0000000..e2929bc
--- /dev/null
+++ b/src/Misc/Lift1.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Misc.Lift1
+    ( Lift1(..)
+    , liftCon, liftCon2, liftCon3
+    , Lift(..)
+    )
+    where
+--------------------------------------------------------------------------------
+import Language.Haskell.TH              hiding (Type, Name)
+import Language.Haskell.TH.Syntax       hiding (Type, Name)
+import Language.Haskell.TH.Syntax       qualified as TH
+import Language.Haskell.TH.Quote
+import Data.Kind                        qualified
+import GHC.Generics
+
+import Data.Fix
+--------------------------------------------------------------------------------
+
+class Lift1 (f :: Data.Kind.Type -> Data.Kind.Type) where
+    lift1 :: (Quote m, Lift t) => f t -> m Exp
+
+liftCon :: Quote m => TH.Name -> m Exp -> m Exp
+liftCon n = fmap (AppE (ConE n))
+
+liftCon2 :: Quote m => TH.Name -> m Exp -> m Exp -> m Exp
+liftCon2 n a b = do
+    a' <- a
+    b' <- b
+    pure $ ConE n `AppE` a' `AppE` b'
+
+liftCon3 :: Quote m => TH.Name -> m Exp -> m Exp -> m Exp -> m Exp
+liftCon3 n a b c = do
+    a' <- a
+    b' <- b
+    c' <- c
+    pure $ ConE n `AppE` a' `AppE` b' `AppE` c'
+
+instance Lift1 f => Lift (Fix f) where
+    lift (Fix f) = AppE (ConE 'Fix) <$> lift1 f
+
+