Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Sean/new ast #33

Merged
merged 85 commits into from
Sep 4, 2024
Merged
Changes from 1 commit
Commits
Show all changes
85 commits
Select commit Hold shift + click to select a range
04eece1
flake
gnumonik Nov 29, 2023
c6c8930
shell
gnumonik Nov 29, 2023
3e3562c
Added uplc command line option for , pulled in plutus-core dep from C…
gnumonik Nov 30, 2023
99c51cb
PlutusIR dependency sorted out
gnumonik Nov 30, 2023
75012d1
Typed CoreFn conversion & pretty printer (messy)
gnumonik Dec 6, 2023
62c4685
More detailed tracing to investigate type reprs
gnumonik Dec 6, 2023
b173baf
Switched to a typed CoreFn data type (instead of stashing type info i…
Jan 12, 2024
5b02fe1
Preserving ForAll quantifiers in output CoreFn AST (WIP/maybe broken)
Jan 17, 2024
822c6d4
Let bindings/declaration groups debugging, working on quantifier pres…
gnumonik Jan 18, 2024
23fac0a
Working on conversion of typeclass dictionaries. (Pretty messy, using…
gnumonik Jan 20, 2024
f3a86eb
Adjusted typeclass desugaring to use real source locations in the cas…
gnumonik Jan 24, 2024
28a850e
Conversion to typed CoreFn for desugared typeclass dictionaries seems…
gnumonik Jan 24, 2024
282d951
Typed CoreFn conversion now works with MPTCs, cleaned up a bunch of u…
gnumonik Jan 25, 2024
cdd4bb1
Substantial cleanup + documentation pass
gnumonik Jan 25, 2024
766b580
Merge pull request #17 from mlabs-haskell/sean/typedCoreFn.typeclasse…
gnumonik Jan 25, 2024
6e2ca01
Nested 'let' expressions w/ mix of type sigs/no type sigs w/ quantifiers
gnumonik Jan 25, 2024
51344c8
Mutually recursive binding groups, binders, attempt at generalizing T…
gnumonik Feb 1, 2024
9ffcbcf
Merge pull request #19 from mlabs-haskell/sean/typedCoreFn.wip
gnumonik Feb 1, 2024
722a0cc
fixed small mistake, deleted some traces, added comment or two
gnumonik Feb 1, 2024
e6237d8
Merge branch 'sean/typedCoreFn.wip' into sean/typedCoreFn
gnumonik Feb 1, 2024
02129dd
Fixed mutual recursion bug in declToCoreFn, removed let generalizatio…
gnumonik Feb 3, 2024
b2befc1
Fixed problem w/ object literal binders, cleaned up the interface of …
gnumonik Feb 6, 2024
5f464c5
Primitive infrastructure for golden tests, removed some dead options
gnumonik Feb 21, 2024
aa95066
testing infrastructure, ported some tests/purs/passing tests to debug…
gnumonik Feb 22, 2024
5a83437
Fixed bug discovered in test #4301 (I hope...)
gnumonik Feb 27, 2024
c99c476
Fixed issue w/ transitive imports resulting from explicitly desguarin…
gnumonik Feb 29, 2024
293acc9
Documenting/Explaining the use of new utils
gnumonik Feb 29, 2024
1e17804
Type inference/checking machinery removed from CoreFn desugaring mach…
gnumonik Mar 1, 2024
161bdef
Added some empty list tests
gnumonik Mar 1, 2024
f35cdb0
Prettyprinter replacement implemented (still needs some tweaking)
gnumonik Mar 2, 2024
b4f557e
prettyprinter improvements
gnumonik Mar 2, 2024
7876fdb
even prettier
gnumonik Mar 2, 2024
c862bd5
extremely pretty
gnumonik Mar 2, 2024
4b6112c
Refactored pretty printer update to use Reader monad (hopefully makes…
gnumonik Mar 5, 2024
cb11738
Final cleanup/tweaks to pretty printer
gnumonik Mar 5, 2024
d295a01
Module-ized prettyprinter + some small tweaks
gnumonik Mar 6, 2024
ae4f703
Nix setup
t4ccer Feb 18, 2024
991c758
Trigger CI
t4ccer Feb 18, 2024
4214ae6
Remove unused configs
t4ccer Feb 18, 2024
6349472
Disable typos check
t4ccer Feb 18, 2024
ed35645
Remove Nix Plutarch wrapper
t4ccer Feb 23, 2024
a9f7a14
Removed some dead comments, testing pre-commit hooks
gnumonik Mar 6, 2024
115cb65
working on monomorphizer (seems to work w/ non-recursive binding grou…
gnumonik Mar 15, 2024
cada4c7
re-implementing monomorphizer (wip)
gnumonik Mar 16, 2024
584cf12
monomorphizer works on the simplest possible mutually recursive examp…
gnumonik Mar 19, 2024
babc876
Support for PLC Builtins and primitive types
gnumonik Mar 20, 2024
db81559
re-organize modules
gnumonik Mar 20, 2024
3a1302d
utilities for object desugaring
gnumonik Mar 20, 2024
7106f6f
Conversion to Bound, object desugaring
gnumonik Mar 21, 2024
d08e03e
Prettyprinter for Bound AST, fixed some bugs in object desguaring, re…
gnumonik Mar 22, 2024
9e83557
Reworked final IR, prettyprinters, debugging + reworking monomorphize…
gnumonik Mar 22, 2024
8a84e77
forgot to commit new file
gnumonik Mar 22, 2024
9dbd7b7
full Purs->UPLC pipeline working for very simple examples. builtins w…
gnumonik Mar 23, 2024
71add6a
remoted test output dirs from gitignore (so can link to things)
gnumonik Mar 23, 2024
3b24eef
wrong output file name in test
gnumonik Mar 23, 2024
3f8183d
working on case expressions
gnumonik Mar 26, 2024
87fd8cc
basic PLC test infrastructure
gnumonik Mar 26, 2024
e076b6a
fixed some tests
gnumonik Mar 26, 2024
e6cb3ba
architecture doc
gnumonik Mar 28, 2024
d3a263c
Removed type annotations from CoreFn and ctors
gnumonik Mar 29, 2024
809249c
Working on better case desugaring. (Their algorithm works for us but …
gnumonik Apr 13, 2024
c8fac0a
Guard/case desugaring w/ correct types
gnumonik Apr 19, 2024
1b55f26
Fix objects introduced by forall without typeclass constraints
t4ccer Apr 24, 2024
e19e729
Add tests for objects with forall
t4ccer Apr 25, 2024
5d12065
Fix arrays introduced by forall
t4ccer Apr 25, 2024
dd62554
Remove FFI codegen
t4ccer Apr 22, 2024
722270d
Tentative fix for #30 (superclass method access)
gnumonik Apr 30, 2024
c06ac6b
Parametrize IR AST with type
t4ccer May 1, 2024
376ef2f
Initial CoreFn -> IR transformation
t4ccer May 2, 2024
ac9137b
Track object presence on type level
t4ccer May 5, 2024
b971e9c
Remove guarded patterns
t4ccer May 5, 2024
8aedd54
Merge branch 'sean/monomorph-cleanup' into t4/ast2
t4ccer May 5, 2024
5d70096
Ignore `cache-db.json` files
t4ccer May 5, 2024
1ddbe4e
WIP Monomorphizer rework for AST
t4ccer May 5, 2024
f74e778
Some stuff
t4ccer May 8, 2024
3ad78bf
Parameterized module, TypeLike class for common operations on types, …
gnumonik May 9, 2024
d1dd427
IndexedPlated instance for Exp
gnumonik May 10, 2024
df5cc44
changed IndexedPlated to Plated
gnumonik May 10, 2024
33476ce
monomorphizer utils, started reworking inlineAs
gnumonik May 11, 2024
eca9e88
types mostly line up, might break things in a sec
gnumonik May 14, 2024
1b17a50
made the types line up in the monomorphizer rewrite
gnumonik May 15, 2024
96d4b9e
monomorphizer rewrite works for simple examples
gnumonik May 16, 2024
f05bf14
Changed the body of BindE to Exps (from Scopes), cleanup, doc comments
gnumonik May 16, 2024
0993609
Removed dead code, misc cleanup
gnumonik May 16, 2024
fe6d66e
disabled UPLC tests while we rewrite things
gnumonik May 16, 2024
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Prev Previous commit
Next Next commit
made the types line up in the monomorphizer rewrite
gnumonik committed May 15, 2024
commit 1b17a50ae9149550eacbbddb2534e8d2a8345185
11 changes: 6 additions & 5 deletions src/Language/PureScript/CoreFn/Convert/DesugarObjects.hs
Original file line number Diff line number Diff line change
@@ -27,8 +27,8 @@ import Language.PureScript.AST.SourcePos
( pattern NullSourceAnn )
import Control.Lens.IndexedPlated
import Control.Lens ( ix )
import Language.PureScript.CoreFn.Convert.Monomorphize
( nullAnn, mkFieldMap, decodeModuleIO, MonoError (..), monomorphizeExpr, findDeclBody )
import Language.PureScript.CoreFn.Convert.MonomorphizeV2
import Language.PureScript.CoreFn.Convert.Monomorphize.Utils
import Data.Text (Text)
import Bound
import Data.Bifunctor (Bifunctor(first, second))
@@ -54,8 +54,9 @@ import Data.Void (Void)
test :: FilePath -> Text -> IO (Exp WithoutObjects Ty (FVar Ty))
test path decl = do
myMod <- decodeModuleIO path
case monomorphizeExpr myMod decl of
Left (MonoError _ msg ) -> throwIO $ userError $ "Couldn't monomorphize " <> T.unpack decl <> "\nReason:\n" <> msg
Just myDecl <- pure $ findDeclBody decl myMod
case monomorphizeExpr myMod myDecl of
Left (MonoError msg ) -> throwIO $ userError $ "Couldn't monomorphize " <> T.unpack decl <> "\nReason:\n" <> msg
Right body -> case tryConvertExpr body of
Left convertErr -> throwIO $ userError convertErr
Right e -> do
@@ -86,7 +87,7 @@ prepPIR path decl = do
<> T.unpack (runModuleName moduleName <> ".main") <> "\nReason:\n" <> msg

case monomorphizeExpr myMod desugaredExpr of
Left (MonoError _ msg ) ->
Left (MonoError msg ) ->
throwIO
$ userError
$ "Couldn't monomorphize "
83 changes: 53 additions & 30 deletions src/Language/PureScript/CoreFn/Convert/Monomorphize/Utils.hs
Original file line number Diff line number Diff line change
@@ -1,53 +1,43 @@
{-# OPTIONS_GHC -Wno-orphans #-} -- has to be here (more or less)
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use if" #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeApplications #-}

module Language.PureScript.CoreFn.Convert.Monomorphize.Utils where

import Prelude

import Language.PureScript.CoreFn.Expr (PurusType)
import Language.PureScript.CoreFn.Convert.IR (_V, Exp(..), FVar(..), BindE(..), Ty (..), pattern (:~>), BVar (..), flattenBind, expTy', abstractMany, mkBindings, Alt (..), Lit (..), expTy)
import Language.PureScript.CoreFn.Convert.IR (_V, Exp(..), FVar(..), BindE(..), BVar (..), flattenBind, expTy', abstractMany, mkBindings, Alt (..), Lit (..), expTy)
import Language.PureScript.Names (Ident(..), ModuleName (..), QualifiedBy (..), Qualified (..), pattern ByNullSourcePos)
import Language.PureScript.Types
( SourceType, TypeVarVisibility (TypeVarInvisible), genPureName, RowListItem (..), rowToList )
( SourceType, RowListItem (..), rowToList )
import Language.PureScript.CoreFn.FromJSON ()
import Data.Text qualified as T
import Data.Map (Map)
import Data.Map qualified as M
import Control.Lens
( _2, view, Indexable (..), (<&>) )
import Control.Lens ( (<&>), (^?) )
import Control.Monad.RWS.Class (gets, modify', MonadReader (..))
import Control.Monad.RWS (RWST(..), MonadTrans (..))
import Control.Monad.RWS (RWST(..))
import Control.Monad.Except (throwError)
import Language.PureScript.CoreFn.Utils (Context)
import Data.Text (Text)
import Language.PureScript.CoreFn.Convert.DesugarCore (WithObjects)
import Bound.Var (Var(..))
import Bound.Scope (instantiateEither, Scope (..), abstract, abstractEither, splat, toScope, fromScope, mapScope, mapBound)
import Data.Bifunctor (first, Bifunctor (..))
import Data.Maybe (fromMaybe)
import Data.List (sortOn, find)
import Protolude.List (ordNub)
import Bound.Scope (instantiateEither, Scope (..), abstractEither, toScope, fromScope, mapScope, mapBound)
import Data.Bifunctor (Bifunctor (..))
import Data.List (find)
import Language.PureScript.CoreFn.TypeLike (TypeLike(..))
import Control.Lens ((^?))
import Control.Lens.IndexedPlated
import Bound (Scope(unscope), Bound (..))
import Control.Lens.Plated
import Bound (instantiate)
import Control.Monad (join)
import Control.Lens.Type (IndexedTraversal')
import Data.Functor.Identity (Identity(..))
import Language.PureScript.Environment (pattern (:->))
import Language.PureScript.CoreFn.Pretty (prettyTypeStr)
import Language.PureScript.AST (SourceAnn)
import Language.PureScript.PSString (PSString)
import Language.PureScript.Label (Label(runLabel))
import Language.PureScript.CoreFn.Module
import Language.PureScript.CoreFn.Ann


transverseScopeAndVariables ::
@@ -160,6 +150,19 @@ freshen ident = do
-- other two shouldn't exist at this stage
other -> pure other

freshBVar :: t -> Monomorphizer (BVar t)
freshBVar t = do
u <- gets unique
modify' $ \(MonoState v _) -> MonoState v (u + 1)
let gIdent = Ident $ T.pack ("x_$$" <> show u)
pure $ BVar u t gIdent

uniqueIx :: Monomorphizer Int
uniqueIx = do
u <- gets unique
modify' $ \(MonoState v _) -> MonoState v (u + 1)
pure u

qualifyNull :: Ident -> Qualified Ident
qualifyNull = Qualified ByNullSourcePos

@@ -220,9 +223,18 @@ updateVarTyS' (BVar ix _ ident) ty scoped = mapScope goBound goFree scoped
goFree fv@(F (FVar _ (Qualified q@(BySourcePos _) varId)))
| varId == ident = F $ FVar ty (Qualified q varId)
| otherwise = fv
goFree bv@(B bvar) = B (goBound bvar)
goFree (B bvar) = B (goBound bvar)
goFree other = other

-- doesn't change types!
renameBoundVar :: Ident
-> Ident
-> Scope (BVar t) (Exp WithObjects t) (FVar t)
-> Scope (BVar t) (Exp WithObjects t) (FVar t)
renameBoundVar old new = mapBound $ \case
BVar bvIx bvTy bvIdent | bvIdent == old -> BVar bvIx bvTy new
other -> other

-- TODO: Eventually we shouldn't need this but it's useful to throw errors
-- while debugging if we get something that's not a function
unsafeApply ::
@@ -270,12 +282,23 @@ updateFreeVar dict expr = case expr ^? _V of
Just (newId,newType) -> V (FVar newType (Qualified ByNullSourcePos newId))
_ -> expr


-- doesn't change types!
renameBoundVar :: Ident
-> Ident
-> Scope (BVar t) (Exp WithObjects t) (FVar t)
-> Scope (BVar t) (Exp WithObjects t) (FVar t)
renameBoundVar old new = mapBound $ \case
BVar bvIx bvTy bvIdent | bvIdent == old -> BVar bvIx bvTy new
other -> other
scopedToExp :: TypeLike t
=> Scope (BVar t) (Exp x t) (FVar t)
-> Monomorphizer (Exp x t (FVar t))
scopedToExp scoped = do
let ty = expTy' F scoped
newBVar@(BVar bvIx _ bvId) <- freshBVar ty
let fv = FVar ty (qualifyNull bvId)
bindings = M.singleton bvIx fv
binds = [NonRecursive bvId scoped]
pure $ LetE bindings binds (Scope $ pure $ B newBVar)


findDeclBody :: Text
-> Module IR_Decl Ann
-> Maybe (Scope (BVar PurusType) (Exp WithObjects PurusType) (FVar PurusType))
findDeclBody nm Module{..} = case findInlineDeclGroup (Ident nm) moduleDecls of
Nothing -> Nothing
Just decl -> case decl of
NonRecursive _ e -> Just e
Recursive xs -> snd <$> find (\x -> fst x == Ident nm) xs
106 changes: 68 additions & 38 deletions src/Language/PureScript/CoreFn/Convert/MonomorphizeV2.hs
Original file line number Diff line number Diff line change
@@ -1,18 +1,29 @@
{-# OPTIONS_GHC -Wno-orphans #-} -- has to be here (more or less)
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Use if" #-}
module Language.PureScript.CoreFn.Convert.MonomorphizeV2 where

import Prelude
import Data.Bifunctor
import Data.Bifunctor ( Bifunctor(second) )

import Language.PureScript.CoreFn.Ann (Ann)
import Language.PureScript.CoreFn.Expr (PurusType)
import Language.PureScript.CoreFn.Module ( Module(..) )
import Language.PureScript.CoreFn.Convert.IR (Exp(..), FVar(..), Lit(..), BindE(..), ppExp, unsafeAnalyzeApp, BVar (..), expTy, expTy', FuncType (..))
import Language.PureScript.CoreFn.Convert.IR
( Exp(..),
FVar(..),
Lit(..),
BindE(..),
ppExp,
unsafeAnalyzeApp,
BVar(..),
expTy,
expTy',
FuncType(..),
Alt(..),
Alt )
import Language.PureScript.Names (Ident(..), Qualified (..), QualifiedBy (..), ModuleName (..))
import Language.PureScript.Types
( RowListItem(..), SourceType, Type(..), replaceTypeVars, isMonoType )
@@ -35,9 +46,30 @@ import Debug.Trace (trace, traceM)
import Language.PureScript.CoreFn.Convert.DesugarCore (WithObjects)
import Bound (fromScope)
import Bound.Var (Var(..))
import Bound.Scope (Scope (..), toScope)
import Bound.Scope (Scope (..), toScope, mapBound)
import Language.PureScript.CoreFn.TypeLike
( TypeLike(splitFunTyParts, instantiates) )
import Language.PureScript.CoreFn.Convert.Monomorphize.Utils
( IR_Decl,
Monomorphizer,
MonoState(MonoState),
MonoError(..),
transverseScopeViaExp,
getModBinds,
note,
freshen,
freshBVar,
qualifyNull,
gLet,
updateVarTyS,
updateVarTyS',
unsafeApply,
findInlineDeclGroup,
mkFieldMap,
extractAndFlattenAlts,
joinScope,
updateFreeVars,
scopedToExp )

{- This is the entry point for monomorphization. Typically,
you will search the module for a 'main' decl and use its
@@ -47,17 +79,16 @@ monomorphizeExpr ::
Module IR_Decl Ann ->
Exp WithObjects PurusType (FVar PurusType) ->
Either MonoError (Exp WithObjects PurusType (FVar PurusType))
monomorphizeExpr m@Module{..} expr =
monomorphizeExpr Module{..} expr =
runRWST (monomorphize expr) (moduleName,moduleDecls) (MonoState M.empty 0) & \case
Left err -> Left err
Right (a,_,_) -> Right a

monomorphize ::
forall a.
Exp WithObjects PurusType (FVar PurusType) ->
Monomorphizer (Exp WithObjects PurusType (FVar PurusType))
monomorphize xpr = trace ("monomorphizeA " <> "\n " <> ppExp xpr) $ case xpr of
app@(AppE _ arg) -> do
app@(AppE _ _) -> do
let (f,args) = unsafeAnalyzeApp app
traceM $ "FUN: " <> ppExp f
traceM $ "ARGS: " <> show (ppExp <$> args)
@@ -70,11 +101,9 @@ monomorphize xpr = trace ("monomorphizeA " <> "\n " <> ppExp xpr) $ case xpr
other -> pure other
where
-- N.B. we need qualified names in the vars to write this, will fix later
isBuiltin = undefined

isMonomorphizedVar :: Exp WithObjects PurusType (FVar PurusType) -> Bool
isMonomorphizedVar (V (FVar sty _)) = snd (stripQuantifiers sty) == sty
isMonomorphizedVar _ = error "IsMonomorphizedVar called on BVar (I think that shouldn't happen and indicates a mistakes?)"
isBuiltin = \case
V (FVar _ (Qualified (ByModuleName (ModuleName "Builtin")) _ )) -> True
_ -> False

handleFunction :: Exp WithObjects PurusType (FVar PurusType)
-> [Exp WithObjects PurusType (FVar PurusType)] -- TODO: List could be empty?
@@ -100,7 +129,7 @@ handleFunction expr@(LamE (ForAll _ _ var _ inner _) bv@(BVar bvIx _ bvIdent)
handleFunction v@(V (FVar ty qn)) es = trace ("handleFunction VarGo: " <> ppExp v) $ do
traceM (ppExp v)
traceM (show $ ppExp <$> es)
e' <- either (uncurry gLet) id <$> inlineAs ty qn
e' <- inlineAs ty qn
handleFunction e' es
handleFunction e es | isMonoType (expTy F e) = pure $ unsafeApply e es
handleFunction e es = throwError $ MonoError
@@ -111,22 +140,18 @@ handleFunction e es = throwError $ MonoError
inlineAs ::
PurusType ->
Qualified Ident ->
Monomorphizer (Either
( [BindE PurusType (Exp WithObjects PurusType) (FVar PurusType)]
, Scope (BVar PurusType) (Exp WithObjects PurusType) (FVar PurusType))
(Exp WithObjects PurusType (FVar PurusType)))
Monomorphizer (Exp WithObjects PurusType (FVar PurusType))
-- TODO: Review whether this has any purpose here \/
inlineAs ty nm@(Qualified (ByModuleName (ModuleName "Builtin")) idnt ) = do
pure . Right $ undefined
inlineAs ty nm@(Qualified (ByModuleName (ModuleName "Builtin")) _ ) = do
pure $ V (FVar ty nm)
-- TODO: Probably can inline locally bound variables? FIX: Keep track of local name bindings
inlineAs _ (Qualified (BySourcePos _) ident) = throwError $ MonoError $ "can't inline bound variable " <> showIdent' ident
inlineAs ty qmn@(Qualified (ByModuleName mn') ident) = trace ("inlineAs: " <> showIdent' ident <> " :: " <> prettyTypeStr ty) $ ask >>= \(mn,modDict) ->
inlineAs ty (Qualified (ByModuleName mn') ident) = trace ("inlineAs: " <> showIdent' ident <> " :: " <> prettyTypeStr ty) $ ask >>= \(mn,modDict) ->
if mn == mn' then do
let msg = "Couldn't find a declaration with identifier " <> showIdent' ident <> " to inline as " <> prettyTypeStr ty
note msg (findInlineDeclGroup ident modDict) >>= \case
NonRecursive _ e -> do
e' <- transverseScopeViaExp (monomorphizeWithType ty) e
pure . Right $ e'
scopedToExp e'
Recursive xs -> do
let msg' = "Target expression with identifier " <> showIdent' ident <> " not found in mutually recursive group"
(targIdent,targExpr) <- note msg' $ find (\x -> fst x == ident) xs -- has to be there
@@ -137,7 +162,9 @@ inlineAs ty qmn@(Qualified (ByModuleName mn') ident) = trace ("inlineAs: " <> sh
bindingMap = M.elems dict
binds <- traverse (\(newId,newTy,oldE) -> makeBind renameMap newId newTy oldE) bindingMap
case M.lookup targIdent renameMap of
Just (newId,newTy) -> pure $ Left (binds, undefined ) {- -Var nullAnn newTy (Qualified ByNullSourcePos newId)) -}
Just (newId,newTy) -> do
let body = pure (FVar newTy $ qualifyNull newId)
pure $ gLet binds body
Nothing -> throwError
$ MonoError
$ "Couldn't inline " <> showIdent' ident <> " - identifier didn't appear in collected bindings:\n " <> show renameMap
@@ -218,6 +245,7 @@ inlineAs ty qmn@(Qualified (ByModuleName mn') ident) = trace ("inlineAs: " <> sh
collectRecBinds visited' t' declBody
Just _ -> pure visited
other -> throwError $ MonoError $ "Unexpected expression in collectFun:\n " <> ppExp other
collectFun _ _ [] = throwError $ MonoError "Ran out of types in collectFun"

collectRecBinds ::
Map Ident (Ident, SourceType, Scope (BVar PurusType) (Exp WithObjects PurusType) (FVar PurusType)) ->
@@ -270,6 +298,8 @@ inlineAs ty qmn@(Qualified (ByModuleName mn') ident) = trace ("inlineAs: " <> sh
LetE _ _ ex ->
-- not sure abt this
collectRecBinds visited t (joinScope ex)
-- TODO: Figure out what to do w/ bound vars
V (B bv) -> throwError $ MonoError $ "collectRecBinds: Not sure what to do with BVars yet: " <> show bv



@@ -282,7 +312,7 @@ monomorphizeWithType ::
monomorphizeWithType ty expr
| expTy F expr == ty = pure expr
| otherwise = trace ("monomorphizeWithType:\n " <> ppExp expr <> "\n " <> prettyTypeStr ty) $ case expr of
LitE ty (ArrayL arr) -> case ty of
LitE ty' (ArrayL arr) -> case ty' of
ArrayT inner -> LitE ty . ArrayL <$> traverse (monomorphizeWithType inner) arr
_ -> throwError $ MonoError ("Failed to collect recursive binds: " <> prettyTypeStr ty <> " is not a Record type")

@@ -292,7 +322,7 @@ monomorphizeWithType ty expr
LitE ty . ObjectL ext <$> monomorphizeFieldsWithTypes fieldMap fs
_ -> throwError $ MonoError ("Failed to collect recursive binds: " <> prettyTypeStr ty <> " is not a Record type")

LitE ty lit -> pure $ LitE ty lit
LitE _ lit -> pure $ LitE ty lit

CtorE _ tName cName fs -> pure $ CtorE ty tName cName fs

@@ -306,31 +336,31 @@ monomorphizeWithType ty expr

-- TODO: IMPORTANT! We need something like 'freshen' for BVar indices
AccessorE ext _ str e -> pure $ AccessorE ext ty str e -- idk?
fun@(LamE _ bv@(BVar _ _ ident) body) -> trace ("MTABs:\n " <> ppExp fun <> " :: " <> prettyTypeStr ty) $ do
fun@(LamE _ bv@(BVar oldIx _ oldIdent) body) -> trace ("MTABs:\n " <> ppExp fun <> " :: " <> prettyTypeStr ty) $ do
case ty of
(a :-> b) -> do
freshIdent <- freshen ident
let body' = renameBoundVar ident freshIdent $ updateVarTyS bv a body
-- REVIEW: If something is weirdly broken w/ bound vars look here first
freshBV <- freshBVar a
let replaceBVar = mapBound $ \x -> if x == bv then freshBV else x
body' = replaceBVar $ updateVarTyS bv a body
body'' <- transverseScopeViaExp (monomorphizeWithType b) body'
pure $ LamE ty
error "TODO"
-- pure $ Abs nullAnn ty freshIdent body''
pure $ LamE ty freshBV body''
_ -> throwError $ MonoError "Abs isn't a function"

app@(AppE _ e2) -> trace ("MTAPP:\n " <> ppExp app) $ do
let (f,args) = unsafeAnalyzeApp app
types = (expTy F <$> args) <> [ty]
e1' <- handleFunction f args
pure $ AppE e1' e2

V a -> pure $ V a -- idk

CaseE _ scrut alts -> error "TODO: wtf?"
-- let f = monomorphizeWithType ty d
-- -- goAlt :: Alt WithObjects PurusType -> Monomorphizer (CaseAlternative Ann)
-- goAlt (CaseAlternative binders results) =
-- CaseAlternative binders <$> bitraverse (traverse (bitraverse f f)) f results
-- in Case a ty scrut <$> traverse goAlt alts
CaseE _ scrut alts -> do
let f = monomorphizeWithType ty
goAlt :: Alt WithObjects PurusType (Exp WithObjects PurusType) (FVar PurusType)
-> Monomorphizer (Alt WithObjects PurusType (Exp WithObjects PurusType) (FVar PurusType))
goAlt (UnguardedAlt bindings binders result) =
UnguardedAlt bindings binders <$> transverseScopeViaExp f result
CaseE ty scrut <$> traverse goAlt alts

LetE a binds e -> LetE a binds <$> transverseScopeViaExp (monomorphizeWithType ty) e
where