diff --git a/src/Language/PureScript/Constants/PLC.hs b/src/Language/PureScript/Constants/PLC.hs index 0f66516a..513f703c 100644 --- a/src/Language/PureScript/Constants/PLC.hs +++ b/src/Language/PureScript/Constants/PLC.hs @@ -4,7 +4,7 @@ module Language.PureScript.Constants.PLC where -import Language.PureScript.Constants.PLC.TH ( mkBuiltinMap ) -import PlutusCore.Default ( DefaultFun ) +import Language.PureScript.Constants.PLC.TH (mkBuiltinMap) +import PlutusCore.Default (DefaultFun) mkBuiltinMap ''DefaultFun diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index a6d0763b..d83250c3 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -30,12 +30,12 @@ import Language.PureScript.AST.SourcePos (nullSourceAnn, pattern NullSourceAnn) import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Constants.Purus qualified as PLC import Language.PureScript.Crash (internalError) -import Language.PureScript.Names (Ident(..), ProperName (..), ProperNameType (..), Qualified (..), QualifiedBy (..), coerceProperName, disqualify) +import Language.PureScript.Names (Ident (..), ProperName (..), ProperNameType (..), Qualified (..), QualifiedBy (..), coerceProperName, disqualify) import Language.PureScript.Roles (Role (..)) import Language.PureScript.TypeClassDictionaries (NamedDict) import Language.PureScript.Types (SourceConstraint, SourceType, Type (..), TypeVarVisibility (..), eqType, freeTypeVariables, quantify, srcTypeApp, srcTypeConstructor) -import Language.Purus.Config ( maxTupleSize ) +import Language.Purus.Config (maxTupleSize) -- | The @Environment@ defines all values and types which are currently in scope: data Environment = Environment @@ -113,16 +113,17 @@ instance A.ToJSON FunctionalDependency where , "determined" .= fdDetermined ] --- | The initial environment with only builtin PLC functions and Prim PureScript types defined --- TODO: Move all of the purus-specific stuff out of this module, --- reset the initEnvironment to the default, and --- modify it at the call site (Language.PureScript.Make) --- --- This will improve the dependency structure of the project, but also, --- allows someone else to adapt Purus for another purpose. The pipeline up to --- up to `GenerateDataTypes` is more-or-less backend agnostic, so --- someone could easily use this to compile PureScript to another typed --- functional language using the IR. +{- | The initial environment with only builtin PLC functions and Prim PureScript types defined +TODO: Move all of the purus-specific stuff out of this module, + reset the initEnvironment to the default, and + modify it at the call site (Language.PureScript.Make) + + This will improve the dependency structure of the project, but also, + allows someone else to adapt Purus for another purpose. The pipeline up to + up to `GenerateDataTypes` is more-or-less backend agnostic, so + someone could easily use this to compile PureScript to another typed + functional language using the IR. +-} initEnvironment :: Environment initEnvironment = Environment (builtinFunctions <> primFunctions) allPrimTypes primCtors M.empty M.empty allPrimClasses @@ -489,7 +490,7 @@ primTypes = , (C.Int, (kindType, ExternData [])) , (C.Boolean, (kindType, boolData)) , (C.Partial <&> coerceProperName, (kindConstraint, ExternData [])) - , (C.Unit, (kindType,ExternData [])) + , (C.Unit, (kindType, ExternData [])) ] where boolData = @@ -952,7 +953,7 @@ tyByteString :: SourceType tyByteString = srcTypeConstructor PLC.BuiltinByteString tyUnit :: SourceType -tyUnit = srcTypeConstructor C.Unit +tyUnit = srcTypeConstructor C.Unit -- just for readability (#@) :: Qualified Ident -> SourceType -> (Qualified Ident, SourceType) @@ -972,7 +973,7 @@ builtinTypes = , (PLC.BuiltinByteString, (kindType, ExternData [])) ] -primFunctions :: M.Map (Qualified Ident) (SourceType,NameKind,NameVisibility) +primFunctions :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) primFunctions = M.singleton (Qualified (ByModuleName C.M_Prim) (Ident "unit")) (tyUnit, Public, Defined) builtinFunctions :: M.Map (Qualified Ident) (SourceType, NameKind, NameVisibility) @@ -993,7 +994,7 @@ builtinCxt = , PLC.I_modInteger #@ tyInt -:> tyInt -:> tyInt , PLC.I_equalsInteger #@ tyInt -:> tyInt -:> tyBoolean , PLC.I_lessThanInteger #@ tyInt -:> tyInt -:> tyBoolean - , PLC.I_lessThanEqualsInteger #@ tyInt -:> tyInt -:> tyBoolean + , PLC.I_lessThanEqualsInteger #@ tyInt -:> tyInt -:> tyBoolean , -- ByteStrings PLC.I_appendByteString #@ tyByteString -:> tyByteString -:> tyByteString , -- \/ Check the implications of the variant semantics for this (https://github.com/IntersectMBO/plutus/blob/973e03bbccbe3b860e2c8bf70c2f49418811a6ce/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs#L1179-L1207) @@ -1018,11 +1019,11 @@ builtinCxt = , PLC.I_decodeUtf8 #@ tyByteString -:> tyString , -- Bool -- NOTE: Specializing this to "Type", which miiiight not be what we want depending on how we do the data encoding - PLC.I_ifThenElse #@ forallT "x" $ \x -> tyBoolean -:> x -:> x -:> x + PLC.I_ifThenElse #@ forallT "x" $ \x -> tyBoolean -:> x -:> x -:> x , -- Unit PLC.I_chooseUnit #@ forallT "x" $ \x -> tyUnit -:> x -:> x , -- Tracing - PLC.I_trace #@ forallT "x" $ \x -> tyString -:> x -:> x + PLC.I_trace #@ forallT "x" $ \x -> tyString -:> x -:> x , -- Pairs PLC.I_fstPair #@ forallT "a" $ \a -> forallT "b" $ \b -> tyBuiltinPair a b -:> a , PLC.I_sndPair #@ forallT "a" $ \a -> forallT "b" $ \b -> tyBuiltinPair a b -:> b @@ -1053,6 +1054,6 @@ builtinCxt = PLC.I_mkPairData #@ tyBuiltinData -:> tyBuiltinData -:> tyBuiltinPair tyBuiltinData tyBuiltinData , PLC.I_mkNilData #@ tyUnit -:> tyBuiltinList tyBuiltinData , PLC.I_mkNilPairData #@ tyUnit -:> tyBuiltinList (tyBuiltinPair tyBuiltinData tyBuiltinData) - -- TODO: the Bls12 crypto primfuns + -- TODO: the Bls12 crypto primfuns -- NOTE: IntegerToByteString & ByteStringToInteger don't appear to be in the version of PlutusCore we have? ] diff --git a/src/Language/Purus/Eval.hs b/src/Language/Purus/Eval.hs index 7e9b82f3..cb8362a1 100644 --- a/src/Language/Purus/Eval.hs +++ b/src/Language/Purus/Eval.hs @@ -1,11 +1,11 @@ {-# LANGUAGE TypeApplications #-} module Language.Purus.Eval ( - compileToUPLC, - evaluateTerm, - -- temporary for GHCI testing. TODO move these to the test suite - passing - ) where + compileToUPLC, + evaluateTerm, + -- temporary for GHCI testing. TODO move these to the test suite + passing, +) where import Prelude diff --git a/src/Language/Purus/IR.hs b/src/Language/Purus/IR.hs index 9313acf9..739d7c7f 100644 --- a/src/Language/Purus/IR.hs +++ b/src/Language/Purus/IR.hs @@ -18,7 +18,7 @@ import Prelude import Protolude.List (ordNub) -import Control.Monad ( join, ap ) +import Control.Monad (ap, join) import Data.Bifunctor (Bifunctor (first)) import Data.Kind qualified as GHC import Data.List (elemIndex, sortOn) @@ -29,8 +29,10 @@ import Data.Text (Text) import Data.Text qualified as T import Language.PureScript.Constants.Prim qualified as C -import Language.PureScript.CoreFn.TypeLike - ( instantiateWithArgs, TypeLike(..) ) +import Language.PureScript.CoreFn.TypeLike ( + TypeLike (..), + instantiateWithArgs, + ) import Language.PureScript.Names (Ident (..), ProperName (..), ProperNameType (..), Qualified (..), QualifiedBy (..), disqualify, runIdent, runModuleName, showIdent, showQualified) import Language.PureScript.PSString (PSString, decodeStringWithReplacement, prettyPrintString) import Language.PureScript.Types ( @@ -43,35 +45,39 @@ import Language.Purus.Debug (doTrace) import Language.Purus.Pretty ((<::>)) import Language.Purus.Pretty.Common (prettyStr) -import Bound ( Bound(..), Var(..), Scope, fromScope ) +import Bound (Bound (..), Scope, Var (..), fromScope) import Bound.Scope (instantiateEither) -import Control.Lens.Plated ( Plated(..) ) +import Control.Lens.Plated (Plated (..)) import Control.Lens.TH (makePrisms) -import Data.Functor.Classes - ( Eq1(..), Ord1(..), Show1(liftShowsPrec) ) - -import Prettyprinter - ( Doc, - Pretty(pretty), - viaShow, - layoutPretty, - (<+>), - align, - defaultLayoutOptions, - encloseSep, - group, - hardline, - hsep, - indent, - vcat, - vsep, - dot, - parens ) +import Data.Functor.Classes ( + Eq1 (..), + Ord1 (..), + Show1 (liftShowsPrec), + ) + +import Prettyprinter ( + Doc, + Pretty (pretty), + align, + defaultLayoutOptions, + dot, + encloseSep, + group, + hardline, + hsep, + indent, + layoutPretty, + parens, + vcat, + viaShow, + vsep, + (<+>), + ) import Prettyprinter.Render.Text (renderStrict) -import Text.Show.Deriving ( deriveShow1, makeLiftShowsPrec ) +import Text.Show.Deriving (deriveShow1, makeLiftShowsPrec) -- The final representation of types and terms, where all constructions that diff --git a/src/Language/Purus/IR/Utils.hs b/src/Language/Purus/IR/Utils.hs index e1b3c85b..1edd3da2 100644 --- a/src/Language/Purus/IR/Utils.hs +++ b/src/Language/Purus/IR/Utils.hs @@ -32,31 +32,33 @@ module Language.Purus.IR.Utils ( allBoundVars, stripSkolems, stripSkolemsFromExpr, - ) where +) where import Prelude -import Bound ( Scope, Var(..), abstract, fromScope ) -import Control.Monad ( join ) +import Bound (Scope, Var (..), abstract, fromScope) +import Control.Monad (join) import Data.Void (Void) import Language.PureScript.CoreFn.Expr (PurusType) -import Language.PureScript.CoreFn.TypeLike ( TypeLike(KindOf) ) -import Language.PureScript.Names - ( Ident(Ident), - ModuleName(ModuleName), - Qualified(..), - QualifiedBy(ByModuleName) ) -import Language.Purus.IR - ( BindE(..), - FVar(..), - BVar(..), - Exp(..), - Alt(..), - Lit(ObjectL, IntL, StringL, CharL), - Pat(ConP, VarP, LitP), - XAccessor, - XObjectLiteral, - XObjectUpdate ) +import Language.PureScript.CoreFn.TypeLike (TypeLike (KindOf)) +import Language.PureScript.Names ( + Ident (Ident), + ModuleName (ModuleName), + Qualified (..), + QualifiedBy (ByModuleName), + ) +import Language.Purus.IR ( + Alt (..), + BVar (..), + BindE (..), + Exp (..), + FVar (..), + Lit (CharL, IntL, ObjectL, StringL), + Pat (ConP, LitP, VarP), + XAccessor, + XObjectLiteral, + XObjectUpdate, + ) import Prettyprinter (Pretty) import Data.Set (Set) diff --git a/src/Language/Purus/Make.hs b/src/Language/Purus/Make.hs index df34c846..fb85b67f 100644 --- a/src/Language/Purus/Make.hs +++ b/src/Language/Purus/Make.hs @@ -32,9 +32,9 @@ import Language.PureScript.Names ( runModuleName, ) +import Language.Purus.Eval import Language.Purus.IR.Utils (IR_Decl, foldBinds) import Language.Purus.Pipeline.CompileToPIR (compileToPIR) -import Language.Purus.Eval import Language.Purus.Pipeline.DesugarCore (desugarCoreModule) import Language.Purus.Pipeline.DesugarObjects ( desugarObjects, @@ -58,7 +58,7 @@ import Language.Purus.Pipeline.Monad ( ) import Language.Purus.Pretty.Common (prettyStr) import Language.Purus.Prim.Data (primDataPS) -import Language.Purus.Types (PIRTerm, initDatatypeDict, PLCTerm) +import Language.Purus.Types (PIRTerm, PLCTerm, initDatatypeDict) import Language.Purus.Utils ( decodeModuleIO, findDeclBodyWithIndex, @@ -77,10 +77,9 @@ import Algebra.Graph.AdjacencyMap.Algorithm (topSort) import System.FilePath.Glob qualified as Glob import PlutusCore.Evaluation.Result (EvaluationResult) --- import Debug.Trace (traceM) ---import PlutusIR.Core.Instance.Pretty.Readable (prettyPirReadable) - +-- import Debug.Trace (traceM) +-- import PlutusIR.Core.Instance.Pretty.Readable (prettyPirReadable) {- Compiles a main function to PIR, given its module name, dependencies, and a Prim module that will be compiled before anything else. (This is kind of a hack-ey shim @@ -113,38 +112,39 @@ compile primModule orderedModules mainModuleName mainFunctionName = go :: CounterT (Either String) PIRTerm go = do (summedModule, dsCxt) <- runDesugarCore $ desugarCoreModules primModule orderedModules - let --traceBracket lbl msg = traceM ("\n" <> lbl <> "\n\n" <> msg <> "\n\n") - decls = moduleDecls summedModule - declIdentsSet = foldBinds (\acc nm _ -> S.insert nm acc) S.empty decls - couldn'tFindMain n = - "Error: Could not find a main function with the name (" - <> show (n :: Int) - <> ") '" - <> T.unpack (runIdent mainFunctionName) - <> "' in module " - <> T.unpack (runModuleName mainModuleName) - <> "\nin declarations:\n" - <> prettyStr (S.toList declIdentsSet) + let + -- traceBracket lbl msg = traceM ("\n" <> lbl <> "\n\n" <> msg <> "\n\n") + decls = moduleDecls summedModule + declIdentsSet = foldBinds (\acc nm _ -> S.insert nm acc) S.empty decls + couldn'tFindMain n = + "Error: Could not find a main function with the name (" + <> show (n :: Int) + <> ") '" + <> T.unpack (runIdent mainFunctionName) + <> "' in module " + <> T.unpack (runModuleName mainModuleName) + <> "\nin declarations:\n" + <> prettyStr (S.toList declIdentsSet) mainFunctionIx <- note (couldn'tFindMain 1) $ dsCxt ^? globalScope . at mainModuleName . folded . at mainFunctionName . folded - --traceM $ "Found main function Index: " <> show mainFunctionIx + -- traceM $ "Found main function Index: " <> show mainFunctionIx mainFunctionBody <- note (couldn'tFindMain 2) $ findDeclBodyWithIndex mainFunctionName mainFunctionIx decls - --traceM "Found main function body" + -- traceM "Found main function body" inlined <- runInline summedModule $ lift (mainFunctionName, mainFunctionIx) mainFunctionBody >>= inline - --traceBracket "Done inlining. Result:" $ prettyStr inlined + -- traceBracket "Done inlining. Result:" $ prettyStr inlined let !instantiated = applyPolyRowArgs $ instantiateTypes inlined - --traceBracket "Done instantiating types. Result:" $ prettyStr instantiated + -- traceBracket "Done instantiating types. Result:" $ prettyStr instantiated withoutObjects <- instantiateTypes <$> runCounter (desugarObjects instantiated) - --traceBracket "Desugared objects. Result:\n" $ prettyStr withoutObjects + -- traceBracket "Desugared objects. Result:\n" $ prettyStr withoutObjects datatypes <- runCounter $ desugarObjectsInDatatypes (moduleDataTypes summedModule) - --traceM "Desugared datatypes" + -- traceM "Desugared datatypes" runPlutusContext initDatatypeDict $ do generateDatatypes datatypes - --traceM "Generated PIR datatypes" + -- traceM "Generated PIR datatypes" withoutCases <- eliminateCases datatypes withoutObjects - --traceM "Eliminated case expressions. Compiling to PIR..." + -- traceM "Eliminated case expressions. Compiling to PIR..." compileToPIR datatypes withoutCases - --traceM . docString $ prettyPirReadable pirTerm +-- traceM . docString $ prettyPirReadable pirTerm modulesInDependencyOrder :: [[FilePath]] -> IO [Module (Bind Ann) PurusType PurusType Ann] modulesInDependencyOrder (concat -> paths) = do @@ -218,10 +218,9 @@ makeForTest main = make "tests/purus/passing/Misc" "Lib" main Nothing evalForTest_ :: Text -> IO () evalForTest_ main = evalForTest main >>= print -evalForTest :: Text -> IO (EvaluationResult PLCTerm,[Text]) +evalForTest :: Text -> IO (EvaluationResult PLCTerm, [Text]) evalForTest main = makeForTest main >>= evaluateTerm - -- TODO put this somewhere else note :: (MonadError String m) => String -> Maybe a -> m a note msg = \case diff --git a/src/Language/Purus/Pipeline/CompileToPIR.hs b/src/Language/Purus/Pipeline/CompileToPIR.hs index 278d6ea6..3e1518ff 100644 --- a/src/Language/Purus/Pipeline/CompileToPIR.hs +++ b/src/Language/Purus/Pipeline/CompileToPIR.hs @@ -18,8 +18,8 @@ import Control.Monad ( import Control.Monad.Except (MonadError (..)) import Data.Bifunctor (Bifunctor (..)) -import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Constants.PLC (defaultFunMap) +import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.CoreFn.FromJSON () import Language.PureScript.CoreFn.Module ( Datatypes, @@ -27,7 +27,9 @@ import Language.PureScript.CoreFn.Module ( import Language.PureScript.CoreFn.TypeLike (TypeLike (..)) import Language.PureScript.Names ( Ident (..), - runIdent, Qualified (..), QualifiedBy (ByModuleName), + Qualified (..), + QualifiedBy (ByModuleName), + runIdent, ) import Language.PureScript.PSString (prettyPrintString) @@ -101,18 +103,18 @@ compileToPIR' datatypes _exp = F Unit -> pure $ mkConstant () () F (FVar _ ident@(Qualified _ (runIdent -> nm))) -> case M.lookup (T.unpack nm) defaultFunMap of - Just aBuiltinFun -> case M.lookup aBuiltinFun builtinSubstitutions of - Nothing -> pure $ Builtin () aBuiltinFun - Just substBuiltin -> substBuiltin - Nothing -> do - getConstructorName ident >>= \case - Just aCtorNm -> pure $ PIR.Var () aCtorNm - Nothing -> throwError $ - T.unpack nm - <> " isn't a builtin, and it shouldn't be possible to have a" - <> " free variable that's anything but a builtin. Please " - <> "report this bug to the Purus authors. " - + Just aBuiltinFun -> case M.lookup aBuiltinFun builtinSubstitutions of + Nothing -> pure $ Builtin () aBuiltinFun + Just substBuiltin -> substBuiltin + Nothing -> do + getConstructorName ident >>= \case + Just aCtorNm -> pure $ PIR.Var () aCtorNm + Nothing -> + throwError $ + T.unpack nm + <> " isn't a builtin, and it shouldn't be possible to have a" + <> " free variable that's anything but a builtin. Please " + <> "report this bug to the Purus authors. " B (BVar bvix _ (runIdent -> nm)) -> pure $ PIR.Var () (Name nm $ Unique bvix) LitE _ lit -> compileToPIRLit lit lam@(LamE (BVar bvIx bvT bvNm) body) -> do diff --git a/src/Language/Purus/Pipeline/CompileToPIR/Utils.hs b/src/Language/Purus/Pipeline/CompileToPIR/Utils.hs index 5cc07f18..2cceb066 100644 --- a/src/Language/Purus/Pipeline/CompileToPIR/Utils.hs +++ b/src/Language/Purus/Pipeline/CompileToPIR/Utils.hs @@ -2,6 +2,7 @@ Monad to perform tasks that require access to the datatype context or counter. -} {-# LANGUAGE GADTs #-} + module Language.Purus.Pipeline.CompileToPIR.Utils (builtinSubstitutions) where import Prelude @@ -12,18 +13,21 @@ import Data.Map qualified as M import Language.Purus.IR (Ty (..)) import Language.Purus.Pipeline.GenerateDatatypes (toPIRType) import Language.Purus.Pipeline.GenerateDatatypes.Utils ( - freshName, getConstructorName, note, getDestructorTy, + freshName, + getConstructorName, + getDestructorTy, + note, ) import Language.Purus.Pipeline.Monad (PlutusContext) import Language.Purus.Types (PIRTerm, PIRType) +import Language.Purus.Prim.Utils (properToIdent) import PlutusCore qualified as PLC import PlutusIR ( Type (TyBuiltin), ) import PlutusIR qualified as PIR import PlutusIR.MkPir (mkConstant) -import Language.Purus.Prim.Utils ( properToIdent ) import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Constants.Purus qualified as C @@ -45,15 +49,16 @@ unitTerm = mkConstant () () {- A la plutarch, helper for writing the other functions in this module-} (#) :: PIRTerm -> PIRTerm -> PIRTerm e1 # e2 = PIR.Apply () e1 e2 + -- I think this is the right fixity? TODO: Check plutarch infixl 9 # -- :: con bool -> Boolean pirBoolToBoolean :: PIRTerm -> PlutusContext PIRTerm pirBoolToBoolean conBoolTerm = do - tyConBool <- toPIRType tyBool - trueNm <- note "True not defined" =<< getConstructorName (properToIdent <$> C.C_True) - falseNm <- note "False not defined" =<< getConstructorName (properToIdent <$> C.C_False) + tyConBool <- toPIRType tyBool + trueNm <- note "True not defined" =<< getConstructorName (properToIdent <$> C.C_True) + falseNm <- note "False not defined" =<< getConstructorName (properToIdent <$> C.C_False) let true = PIR.Var () trueNm false = PIR.Var () falseNm pirIfThen tyConBool conBoolTerm true false @@ -62,7 +67,7 @@ pirBoolToBoolean conBoolTerm = do pirBooleanToBool :: PIRTerm -> PlutusContext PIRTerm pirBooleanToBool psBool = do boolDctor <- PIR.Var () <$> getDestructorTy C.Boolean - pure $ PIR.TyInst () (boolDctor # psBool # mkConstant () True # mkConstant () False) tyBuiltinBool + pure $ PIR.TyInst () (boolDctor # psBool # mkConstant () True # mkConstant () False) tyBuiltinBool {- This is *NOT* the thing that we desugar `Builtin.IfThenElse` to. This is a *lazy* if-then-else (using TyAbs/TyInst to emulate force/delay since PIR lacks force/delay). You have to pass in the @@ -98,7 +103,6 @@ freshLam' t f = do pirTyInst :: PIRType -> PIRTerm -> PIRTerm pirTyInst ty term = PIR.TyInst () term ty - {- Delay/Force implemented with type abstraction/instantiation -} pirDelay :: PIRTerm -> PlutusContext PIRTerm pirDelay term = do @@ -114,8 +118,7 @@ pirTyAbs f = do tName <- PIR.TyName <$> freshName let kindType = PIR.Type () body <- f (PIR.TyVar () tName) - pure $ PIR.TyAbs () tName kindType body - + pure $ PIR.TyAbs () tName kindType body {- REVIEW: Is this right? Is that what we *want*? TODO: Add a "fake" function to Language.PureScript.Environment so that users can... use this... @@ -123,7 +126,6 @@ pirTyAbs f = do pirError :: PIRType -> PlutusContext PIRTerm pirError t = pirForce <$> pirDelay (PIR.Error () t) - {- Builtin function substitutions. Each builtin function with a Purus type that contains a `Boolean` is a lie. We use algebraic datatype Booleans, not the Plutus builtin. (This makes case expression desugaring much easier.) @@ -135,25 +137,26 @@ pirError t = pirForce <$> pirDelay (PIR.Error () t) There shouldn't be any need to duplicate them. -} builtinSubstitutions :: Map PLC.DefaultFun (PlutusContext PIRTerm) -builtinSubstitutions - = M.fromList [ (PLC.EqualsInteger,pirEqInt) - , (PLC.EqualsString,pirEqString) - , (PLC.LessThanInteger,pirLessThanInteger) - , (PLC.LessThanEqualsInteger,pirLessThanEqualsInteger) - , (PLC.EqualsByteString,pirEqualsByteString) - , (PLC.LessThanByteString,pirLessThanByteString) - , (PLC.LessThanEqualsByteString,pirLessThanEqualsByteString) - , (PLC.VerifyEd25519Signature,pirVerifyEd25519Signature) - , (PLC.VerifyEcdsaSecp256k1Signature,pirVerifyEcdsaSecp256k1Signature) - , (PLC.EqualsData,pirEqualsData) - , (PLC.IfThenElse,pirIfThenElse) - , (PLC.NullList,pirNullList) - ] +builtinSubstitutions = + M.fromList + [ (PLC.EqualsInteger, pirEqInt) + , (PLC.EqualsString, pirEqString) + , (PLC.LessThanInteger, pirLessThanInteger) + , (PLC.LessThanEqualsInteger, pirLessThanEqualsInteger) + , (PLC.EqualsByteString, pirEqualsByteString) + , (PLC.LessThanByteString, pirLessThanByteString) + , (PLC.LessThanEqualsByteString, pirLessThanEqualsByteString) + , (PLC.VerifyEd25519Signature, pirVerifyEd25519Signature) + , (PLC.VerifyEcdsaSecp256k1Signature, pirVerifyEcdsaSecp256k1Signature) + , (PLC.EqualsData, pirEqualsData) + , (PLC.IfThenElse, pirIfThenElse) + , (PLC.NullList, pirNullList) + ] tyInt, tyBool, tyByteString, tyData, tyString :: Ty tyInt = TyCon C.Int tyBool = TyCon C.Boolean -tyByteString = TyCon C.BuiltinByteString +tyByteString = TyCon C.BuiltinByteString tyData = TyCon C.BuiltinData tyString = TyCon C.String @@ -167,26 +170,25 @@ wrapBoolToBoolean3 t f = freshLam t $ \_ x1 -> freshLam t $ \_ x2 -> freshLam t let fun = PIR.Builtin () f pirBoolToBoolean $ fun # x1 # x2 # x3 - -- Int -> Int -> Bool pirEqInt :: PlutusContext PIRTerm -pirEqInt = wrapBoolToBoolean2 tyInt PLC.EqualsInteger +pirEqInt = wrapBoolToBoolean2 tyInt PLC.EqualsInteger -- String -> String -> Bool pirEqString :: PlutusContext PIRTerm -pirEqString = wrapBoolToBoolean2 tyString PLC.EqualsString +pirEqString = wrapBoolToBoolean2 tyString PLC.EqualsString -- Int -> Int -> Bool -pirLessThanInteger :: PlutusContext PIRTerm +pirLessThanInteger :: PlutusContext PIRTerm pirLessThanInteger = wrapBoolToBoolean2 tyInt PLC.LessThanInteger -- Int -> Int -> Bool -pirLessThanEqualsInteger :: PlutusContext PIRTerm +pirLessThanEqualsInteger :: PlutusContext PIRTerm pirLessThanEqualsInteger = wrapBoolToBoolean2 tyInt PLC.LessThanEqualsInteger -- Bytestring -> ByteString -> Bool pirEqualsByteString :: PlutusContext PIRTerm -pirEqualsByteString = wrapBoolToBoolean2 tyByteString PLC.EqualsByteString +pirEqualsByteString = wrapBoolToBoolean2 tyByteString PLC.EqualsByteString -- Bytestring -> ByteString -> Bool pirLessThanByteString :: PlutusContext PIRTerm @@ -215,22 +217,24 @@ pirEqualsData = wrapBoolToBoolean2 tyData PLC.EqualsData -- (also we're not adding force/delay here) -- forall x. Bool -> x -> x -> x pirIfThenElse :: PlutusContext PIRTerm -pirIfThenElse - = pirTyAbs $ \tv -> +pirIfThenElse = + pirTyAbs $ \tv -> freshLam tyBool $ \_ cond -> - freshLam' tv $ \_ trueVar -> - freshLam' tv $ \_ falseVar -> do - pirIfiedCond <- pirBooleanToBool cond - let pirIFTE = PIR.Builtin () PLC.IfThenElse - pure $ pirIFTE # pirIfiedCond # trueVar # falseVar + freshLam' tv $ \_ trueVar -> + freshLam' tv $ \_ falseVar -> do + pirIfiedCond <- pirBooleanToBool cond + let pirIFTE = PIR.Builtin () PLC.IfThenElse + pure $ pirIFTE # pirIfiedCond # trueVar # falseVar -- forall x. BuiltinList x -> Bool pirNullList :: PlutusContext PIRTerm -pirNullList - = pirTyAbs $ \tv -> do - let listAppliedTy = PIR.TyApp () - (TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoList)) - tv - freshLam' listAppliedTy $ \_ arg -> do - let nullListFun = PIR.Builtin () PLC.NullList - pirBoolToBoolean (pirTyInst tv nullListFun # arg) +pirNullList = + pirTyAbs $ \tv -> do + let listAppliedTy = + PIR.TyApp + () + (TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoList)) + tv + freshLam' listAppliedTy $ \_ arg -> do + let nullListFun = PIR.Builtin () PLC.NullList + pirBoolToBoolean (pirTyInst tv nullListFun # arg) diff --git a/src/Language/Purus/Pipeline/DesugarCore.hs b/src/Language/Purus/Pipeline/DesugarCore.hs index 81cfe101..ffb639b0 100644 --- a/src/Language/Purus/Pipeline/DesugarCore.hs +++ b/src/Language/Purus/Pipeline/DesugarCore.hs @@ -17,20 +17,11 @@ import Data.Foldable (Foldable (foldl'), foldrM, traverse_) import Data.List (sort, sortOn) import Data.Maybe (fromJust, isJust) -import Data.Bifunctor (Bifunctor (first,second)) +import Data.Bifunctor (Bifunctor (first, second)) -import Control.Monad.Reader ( join, unless, MonadReader(local) ) +import Control.Monad.Reader (MonadReader (local), join, unless) import Control.Monad.State (get, modify) -import Language.PureScript.Names - ( runIdent, - Ident(..), - ModuleName(ModuleName), - ProperName(ProperName), - Qualified(Qualified), - QualifiedBy(ByModuleName), - coerceProperName, - disqualify ) import Language.PureScript.AST.Literals (Literal (..)) import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.CoreFn.Ann (Ann, nullAnn) @@ -46,6 +37,16 @@ import Language.PureScript.CoreFn.Module (Datatypes, Module (..)) import Language.PureScript.CoreFn.TypeLike (TypeLike (..)) import Language.PureScript.CoreFn.Utils (exprType) import Language.PureScript.Environment (mkCtorTy, mkTupleTyName) +import Language.PureScript.Names ( + Ident (..), + ModuleName (ModuleName), + ProperName (ProperName), + Qualified (Qualified), + QualifiedBy (ByModuleName), + coerceProperName, + disqualify, + runIdent, + ) import Language.PureScript.Types (Type (..)) import Language.Purus.Debug ( @@ -64,14 +65,21 @@ import Language.Purus.IR ( Pat (..), expTy, ) -import Language.Purus.IR.Utils - ( foldBinds, WithObjects, Vars, IR_Decl, mapBind, viaExp ) -import Language.Purus.Pipeline.Monad - ( globalScope, - DesugarContext(DesugarContext), - DesugarCore, - localScope, - MonadCounter(next) ) +import Language.Purus.IR.Utils ( + IR_Decl, + Vars, + WithObjects, + foldBinds, + mapBind, + viaExp, + ) +import Language.Purus.Pipeline.Monad ( + DesugarContext (DesugarContext), + DesugarCore, + MonadCounter (next), + globalScope, + localScope, + ) import Language.Purus.Pretty (prettyStr, prettyTypeStr, renderExprStr) import Language.Purus.Pretty.Common qualified as PC @@ -137,9 +145,8 @@ isCtorOrPrim = \case {- We don't bind anything b/c the type level isn't `Bound` -} tyAbs :: forall x t. Text -> KindOf t -> Exp x t (Vars t) -> DesugarCore (Exp x t (Vars t)) tyAbs nm k exp' = do - u <- next - pure $ TyAbs (BVar u k (Ident nm)) exp' - + u <- next + pure $ TyAbs (BVar u k (Ident nm)) exp' tyAbsMany :: forall x t. [(Text, KindOf t)] -> Exp x t (Vars t) -> DesugarCore (Exp x t (Vars t)) tyAbsMany vars expr = foldrM (uncurry tyAbs) expr vars @@ -406,7 +413,6 @@ toPat = \case tupCtorName = coerceProperName <$> tupTyName ConP tupTyName tupCtorName <$> traverse (toPat . snd) fs - desugarLit :: Literal (Expr Ann) -> DesugarCore (Lit WithObjects (Exp WithObjects PurusType (Vars PurusType))) desugarLit (NumericLiteral (Left int)) = pure $ IntL int desugarLit (NumericLiteral (Right _)) = error "TODO: Remove Number lits from all preceding ASTs" -- pure $ NumL number diff --git a/src/Language/Purus/Pipeline/DesugarObjects.hs b/src/Language/Purus/Pipeline/DesugarObjects.hs index 54a51ee9..636c8e61 100644 --- a/src/Language/Purus/Pipeline/DesugarObjects.hs +++ b/src/Language/Purus/Pipeline/DesugarObjects.hs @@ -20,8 +20,10 @@ import Language.PureScript.CoreFn.Expr ( PurusType, ) import Language.PureScript.CoreFn.FromJSON () -import Language.PureScript.CoreFn.Module - ( bitraverseDatatypes, Datatypes ) +import Language.PureScript.CoreFn.Module ( + Datatypes, + bitraverseDatatypes, + ) import Language.PureScript.CoreFn.TypeLike (TypeLike (..)) import Language.PureScript.Environment (kindType, mkTupleTyName, pattern RecordT, pattern (:->)) import Language.PureScript.Names (Ident (..), coerceProperName) @@ -35,7 +37,7 @@ import Language.PureScript.Types ( srcTypeApp, srcTypeConstructor, ) -import Language.Purus.Debug ( doTraceM ) +import Language.Purus.Debug (doTraceM) import Language.Purus.IR ( Alt (..), BVar (..), @@ -50,17 +52,24 @@ import Language.Purus.IR ( ppExp, pattern (:~>), ) -import Language.Purus.IR.Utils - ( WithObjects, Vars, WithoutObjects, fromExp, toExp ) -import Language.Purus.Pipeline.Monad - ( Counter, MonadCounter(next) ) -import Language.Purus.Pretty.Common ( prettyStr ) -import Language.Purus.Pretty.Types ( prettyTypeStr ) +import Language.Purus.IR.Utils ( + Vars, + WithObjects, + WithoutObjects, + fromExp, + toExp, + ) +import Language.Purus.Pipeline.Monad ( + Counter, + MonadCounter (next), + ) +import Language.Purus.Pretty.Common (prettyStr) +import Language.Purus.Pretty.Types (prettyTypeStr) import Language.Purus.Utils (mkFieldMap) import Prelude import Bound (Var (..)) -import Bound.Scope ( toScope ) +import Bound.Scope (toScope) import Control.Lens (ix, (&), (.~)) @@ -407,7 +416,6 @@ assembleDesugaredObjectLit expr (_ :~> b) (arg : args) = assembleDesugaredObject assembleDesugaredObjectLit expr _ [] = pure expr -- TODO better error assembleDesugaredObjectLit _ _ _ = error "something went wrong in assembleDesugaredObjectLit" - purusTypeToKind :: SourceType -> Either String Kind purusTypeToKind _t = doTraceM "sourceTypeToKind" (prettyStr _t) >> case _t of diff --git a/src/Language/Purus/Pipeline/EliminateCases.hs b/src/Language/Purus/Pipeline/EliminateCases.hs index 2bd80b8b..ca29be87 100644 --- a/src/Language/Purus/Pipeline/EliminateCases.hs +++ b/src/Language/Purus/Pipeline/EliminateCases.hs @@ -27,12 +27,19 @@ import Language.PureScript.CoreFn.Module ( lookupDataDecl, tyDict, ) -import Language.PureScript.CoreFn.TypeLike - ( getAllInstantiations, - getInstantiations, - safeFunArgTypes, - TypeLike(replaceAllTypeVars, instTy, quantify, splitFunTyParts, - applyType, funTy) ) +import Language.PureScript.CoreFn.TypeLike ( + TypeLike ( + applyType, + funTy, + instTy, + quantify, + replaceAllTypeVars, + splitFunTyParts + ), + getAllInstantiations, + getInstantiations, + safeFunArgTypes, + ) import Language.PureScript.Names ( Ident (..), ProperName (..), @@ -45,7 +52,7 @@ import Language.PureScript.Types ( TypeVarVisibility (TypeVarVisible), ) -import Language.Purus.Debug ( doTrace, doTraceM, prettify ) +import Language.Purus.Debug (doTrace, doTraceM, prettify) import Language.Purus.IR ( Alt (..), BVar (BVar), @@ -62,22 +69,30 @@ import Language.Purus.IR ( pattern (:~>), ) import Language.Purus.IR qualified as IR -import Language.Purus.IR.Utils - ( Vars, WithoutObjects, toExp, isConstructor, fromExp ) +import Language.Purus.IR.Utils ( + Vars, + WithoutObjects, + fromExp, + isConstructor, + toExp, + ) import Language.Purus.Pipeline.DesugarCore ( matchVarLamAbs, ) -import Language.Purus.Pipeline.GenerateDatatypes.Utils - ( analyzeTyApp, - foldr1Err, - freshName, - funResultTy, - getDestructorTy, - prettyQI, - prettyQPN ) -import Language.Purus.Pipeline.Monad - ( MonadCounter(next), PlutusContext ) -import Language.Purus.Pretty.Common ( prettyStr ) +import Language.Purus.Pipeline.GenerateDatatypes.Utils ( + analyzeTyApp, + foldr1Err, + freshName, + funResultTy, + getDestructorTy, + prettyQI, + prettyQPN, + ) +import Language.Purus.Pipeline.Monad ( + MonadCounter (next), + PlutusContext, + ) +import Language.Purus.Pretty.Common (prettyStr) import Bound (Var (..)) import Bound.Scope ( @@ -121,7 +136,7 @@ import PlutusIR ( (or: with types as monomorphic as they can be). To instantiate nullary constructors, we just look at the type annotation, figure out the necessary instantiations by unifying the annotated type with the - type in the declaration, and instantiate. + type in the declaration, and instantiate. -} eliminateCases :: @@ -351,20 +366,22 @@ desugarConstructorPattern datatypes altBodyTy _e = else V . B $ bv other -> error $ "Expected an irrefutable alt but got: " <> prettyStr other result <- assemblePartialCtorCase (CtorCase irrefutable (M.fromList indexedBranches) destructor scrutTy) allCtors - let msg = prettify [ "INPUT TY:\n" <> prettyStr _eTy - , "INPUT:\n" <> prettyStr _e - , "RESULT TY:\n" <> prettyStr (expTy id result) - , "DESTRUCTOR TY:\n" <> prettyStr (expTy id destructor) - , "ORIGINAL CASE RES TY:\n" <> prettyStr _resTy - , "DEDUCED BRANCH RES TY:\n" <> prettyStr branchRetTy - , "SPLIT BRANCH TY:\n" <> prettyStr branchSplit - , "FULL BRANCH TY:\n" <> prettyStr branchTy - , "SCRUT TY:\n" <> prettyStr scrutTy - , "SCRUT EXPR:\n" <> prettyStr scrut - , "RESULT:\n" <> prettyStr result - , "ALT BODY TY:\n" <> prettyStr altBodyTy - , "INSTANTIATED ALT BODY TY:\n" <> prettyStr retTy' - ] + let msg = + prettify + [ "INPUT TY:\n" <> prettyStr _eTy + , "INPUT:\n" <> prettyStr _e + , "RESULT TY:\n" <> prettyStr (expTy id result) + , "DESTRUCTOR TY:\n" <> prettyStr (expTy id destructor) + , "ORIGINAL CASE RES TY:\n" <> prettyStr _resTy + , "DEDUCED BRANCH RES TY:\n" <> prettyStr branchRetTy + , "SPLIT BRANCH TY:\n" <> prettyStr branchSplit + , "FULL BRANCH TY:\n" <> prettyStr branchTy + , "SCRUT TY:\n" <> prettyStr scrutTy + , "SCRUT EXPR:\n" <> prettyStr scrut + , "RESULT:\n" <> prettyStr result + , "ALT BODY TY:\n" <> prettyStr altBodyTy + , "INSTANTIATED ALT BODY TY:\n" <> prettyStr retTy' + ] doTraceM "desugarConstructorPattern" msg pure result other -> pure other @@ -414,12 +431,14 @@ desugarConstructorPattern datatypes altBodyTy _e = resTy = expTy id result - msg = prettify [ "INPUT TY:\n" <> prettyStr t - , "INPUT EXPR:\n" <> prettyStr e - , "INPUT EXPR TY:\n" <> prettyStr (expTy id e) - , "OUTPUT TY:\n" <> prettyStr resTy - , "OUTPUT:\n" <> prettyStr result - ] + msg = + prettify + [ "INPUT TY:\n" <> prettyStr t + , "INPUT EXPR:\n" <> prettyStr e + , "INPUT EXPR TY:\n" <> prettyStr (expTy id e) + , "OUTPUT TY:\n" <> prettyStr resTy + , "OUTPUT:\n" <> prettyStr result + ] {- This is a bit weird. If the alt body type is already quantified then we don't want to do any instantiations. TODO: Explain why (kind of complicated) -} @@ -430,10 +449,12 @@ desugarConstructorPattern datatypes altBodyTy _e = result = case analyzeTyApp scrutT of Just (_, tyArgs) -> foldr instTy (quantify altT) (reverse tyArgs) Nothing -> altT - msg = prettify [ "INPUT SCRUT TY:\n" <> prettyStr scrutT - , "INPUT TARG TY:\n" <> prettyStr altT - , "OUTPUT TY:\n" <> prettyStr result - ] + msg = + prettify + [ "INPUT SCRUT TY:\n" <> prettyStr scrutT + , "INPUT TARG TY:\n" <> prettyStr altT + , "OUTPUT TY:\n" <> prettyStr result + ] mkIndexedBranch :: Ty -> @@ -489,13 +510,15 @@ instantiateCtor datatypes expr = case expr of monoFields = monoCtorInst tyNm ctorNm (funResultTy t) datatypes fe' = foldr TyInstE fe monoFields result = foldl' AppE fe' args - msg = prettify [ "NAME:" <> T.unpack (showQualified runIdent n) - , "MONO TYPE:\n" <> prettyStr t - , "INPUT:\n" <> prettyStr expr - , "RESULT:\n" <> prettyStr result - , "MONO FIELDS:\n" <> prettyStr monoFields - , "INSTANTIATED FUN:\n" <> prettyStr fe' - ] + msg = + prettify + [ "NAME:" <> T.unpack (showQualified runIdent n) + , "MONO TYPE:\n" <> prettyStr t + , "INPUT:\n" <> prettyStr expr + , "RESULT:\n" <> prettyStr result + , "MONO FIELDS:\n" <> prettyStr monoFields + , "INSTANTIATED FUN:\n" <> prettyStr fe' + ] in doTrace "instantiateCtor" msg result _ -> expr _ -> expr @@ -507,8 +530,11 @@ instantiateNullaryWithAnnotatedType :: Exp x Ty (Vars Ty) instantiateNullaryWithAnnotatedType datatypes _e = doTrace "instantiateNullaryWithAnnotatedType" msg result where - msg = prettify [ "INPUT:\n" <> prettyStr _e - , "OUTPUT:\n" <> prettyStr result ] + msg = + prettify + [ "INPUT:\n" <> prettyStr _e + , "OUTPUT:\n" <> prettyStr result + ] result = transform go _e go :: Exp x Ty (Vars Ty) -> @@ -559,7 +585,7 @@ monoCtorInst tn cn t datatypes = doTrace "monoCtorInst" msg $ snd <$> reverse in retrieve its data declaration), return the index of the constructor and its instantiated arguments. This is used, primarily, to ensure that the annotations attached to Var patterns are correctly instantiated to the - type of the scrutinee they serve as matchers for. + type of the scrutinee they serve as matchers for. -} monoCtorFields :: Qualified (ProperName 'TypeName) -> @@ -569,14 +595,16 @@ monoCtorFields :: (Int, [Ty]) -- Constructor index & list of field types monoCtorFields tn cn t datatypes = doTrace "monoCtorFields" msg (thisCtorIx, monoCtorArgs) where - msg = prettify [ "TYPE NAME:" <> T.unpack (showQualified runProperName tn) - , "CTOR NAME:\n" <> T.unpack (showQualified runProperName cn) - , "MONO IN TYPE:\n" <> prettyStr t - , "CTOR DECL ARGS:\n" <> prettyStr ctorArgs - , "POLY TY:\n" <> prettyStr polyTy - , "RESULT TYS:\n" <> prettyStr monoCtorArgs - , "INSTANTIATIONS:\n" <> prettyStr instantiations - ] + msg = + prettify + [ "TYPE NAME:" <> T.unpack (showQualified runProperName tn) + , "CTOR NAME:\n" <> T.unpack (showQualified runProperName cn) + , "MONO IN TYPE:\n" <> prettyStr t + , "CTOR DECL ARGS:\n" <> prettyStr ctorArgs + , "POLY TY:\n" <> prettyStr polyTy + , "RESULT TYS:\n" <> prettyStr monoCtorArgs + , "INSTANTIATIONS:\n" <> prettyStr instantiations + ] (thisCtorIx, thisCtorDecl) = either error id $ getConstructorIndexAndDecl cn datatypes ctorArgs = snd <$> thisCtorDecl ^. cdCtorFields thisDataDecl = fromJust $ lookupDataDecl tn datatypes @@ -598,7 +626,6 @@ Variables bound in patterns contain type annotations in those patterns. We gener in previous compiler passes, as they do not matter there. Here, we need to ensure that the annotations are correct so that the constructor pattern desugaring works as intended & the lambdas introduced there have the correct types. - An example might be helpful. If we have ``` @@ -661,36 +688,36 @@ monomorphizePatterns datatypes _e' = case _e' of e' = rebindPat p' e in UnguardedAlt p' e' -desugarLiteralPatterns :: Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) - -> Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) +desugarLiteralPatterns :: + Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) -> + Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) desugarLiteralPatterns = transform desugarLiteralPattern - desugarLiteralPattern :: Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) -> Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) -desugarLiteralPattern = \case +desugarLiteralPattern = \case CaseE resTy scrut (UnguardedAlt (LitP patLit) rhs : alts) -> - let eqTest = mkEqTestFun scrut patLit + let eqTest = mkEqTestFun scrut patLit trueP = ConP C.Boolean C.C_True [] falseP = ConP C.Boolean C.C_False [] - rest = fromExp $ desugarLiteralPattern (CaseE resTy scrut alts) - in CaseE - resTy - eqTest - [ UnguardedAlt trueP rhs - , UnguardedAlt falseP rest - ] + rest = fromExp $ desugarLiteralPattern (CaseE resTy scrut alts) + in CaseE + resTy + eqTest + [ UnguardedAlt trueP rhs + , UnguardedAlt falseP rest + ] CaseE _ _ (UnguardedAlt WildP rhs : _) -> toExp rhs -- FIXME: Wrong! Need to do the same - -- catchall stuff we do in the ctor - -- case eliminator - -- NOTE (8/28): I'm not sure if the previous FIXME still matters? + -- catchall stuff we do in the ctor + -- case eliminator + -- NOTE (8/28): I'm not sure if the previous FIXME still matters? CaseE _ scrut (UnguardedAlt (VarP bvId bvIx _) rhs : _) -> flip instantiate rhs $ \case bv@(BVar bvIx' _ bvId') -> if bvIx == bvIx' && bvId == bvId' then scrut else V . B $ bv - other -> other + other -> other where eqInt = V . F $ @@ -719,14 +746,14 @@ desugarLiteralPattern = \case desugarIrrefutables :: Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) -> Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) -desugarIrrefutables = transform $ \case - CaseE _ _ (UnguardedAlt WildP rhs : _) -> toExp rhs - CaseE _ scrut (UnguardedAlt (VarP bvId bvIx _) rhs : _) -> flip instantiate rhs $ \case - bv@(BVar bvIx' _ bvId') -> - if bvIx == bvIx' && bvId == bvId' - then scrut - else V . B $ bv - other -> other +desugarIrrefutables = transform $ \case + CaseE _ _ (UnguardedAlt WildP rhs : _) -> toExp rhs + CaseE _ scrut (UnguardedAlt (VarP bvId bvIx _) rhs : _) -> flip instantiate rhs $ \case + bv@(BVar bvIx' _ bvId') -> + if bvIx == bvIx' && bvId == bvId' + then scrut + else V . B $ bv + other -> other data CtorCase = CtorCase { irrefutableRHS :: Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) @@ -753,16 +780,20 @@ ezMonomorphize = transform go let instantiations = reverse (snd <$> instantiations') f' = foldr TyInstE f instantiations result = foldl' AppE f' args - msg = prettify [ "INPUT:\n" <> prettyStr expr - , "OUTPUT:\n" - , prettyStr result ] + msg = + prettify + [ "INPUT:\n" <> prettyStr expr + , "OUTPUT:\n" + , prettyStr result + ] in doTrace "ezMonomorphize" msg result ft -> - let msg = prettify [ - "NO CHANGE (NOT A FORALL):" - , "FUN TY:\n" <> prettyStr ft - , "ARG TYPES:\n" <> prettyStr (expTy id <$> args) - , "ORIGINAL EXPR:\n" <> prettyStr expr - ] + let msg = + prettify + [ "NO CHANGE (NOT A FORALL):" + , "FUN TY:\n" <> prettyStr ft + , "ARG TYPES:\n" <> prettyStr (expTy id <$> args) + , "ORIGINAL EXPR:\n" <> prettyStr expr + ] in doTrace "ezMonomorphize" msg expr _ -> expr -- doTrace "ezMonomorphize" ("" <> prettyStr expr) expr diff --git a/src/Language/Purus/Pipeline/GenerateDatatypes.hs b/src/Language/Purus/Pipeline/GenerateDatatypes.hs index 213aec85..b10d2476 100644 --- a/src/Language/Purus/Pipeline/GenerateDatatypes.hs +++ b/src/Language/Purus/Pipeline/GenerateDatatypes.hs @@ -1,7 +1,6 @@ {- Generates the PIR Datatype declarations which must be let- bound in order for - our modules to compile. + our modules to compile. -} - {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -9,8 +8,8 @@ module Language.Purus.Pipeline.GenerateDatatypes ( generateDatatypes, toPIRType, - mkKind - ) where + mkKind, +) where import Prelude @@ -54,7 +53,7 @@ import Language.PureScript.Types ( import Language.Purus.Debug (doTraceM) import Language.Purus.IR ( Ty (..), - ppTy + ppTy, ) import Language.Purus.IR qualified as IR import Language.Purus.Pipeline.GenerateDatatypes.Utils ( @@ -85,7 +84,7 @@ import PlutusIR qualified as PIR import Control.Lens ( over, to, - (^.) + (^.), ) import Control.Monad.Except ( MonadError (throwError), @@ -110,9 +109,9 @@ import Control.Monad.Except ( generateDatatypes :: Datatypes IR.Kind Ty -> PlutusContext () -generateDatatypes datatypes = mkPIRDatatypes datatypes allTypeConstructors +generateDatatypes datatypes = mkPIRDatatypes datatypes allTypeConstructors where - allTypeConstructors :: S.Set (Qualified (ProperName 'TypeName)) + allTypeConstructors :: S.Set (Qualified (ProperName 'TypeName)) allTypeConstructors = datatypes ^. tyDict . to M.keys . to S.fromList mkPIRDatatypes :: diff --git a/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs b/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs index 56caefcc..49611b40 100644 --- a/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs +++ b/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs @@ -14,8 +14,8 @@ module Language.Purus.Pipeline.GenerateDatatypes.Utils ( mkConstrName, mkNewTyVar, mkTyName, - note - ) where + note, +) where import Prelude diff --git a/src/Language/Purus/Pipeline/Inline.hs b/src/Language/Purus/Pipeline/Inline.hs index 733aede7..85c26e0d 100644 --- a/src/Language/Purus/Pipeline/Inline.hs +++ b/src/Language/Purus/Pipeline/Inline.hs @@ -47,7 +47,7 @@ import Language.PureScript.Types ( isMonoType, ) -import Language.Purus.Debug ( doTrace, doTraceM, prettify ) +import Language.Purus.Debug (doTrace, doTraceM, prettify) import Language.Purus.IR ( BVar (..), BindE (..), @@ -93,7 +93,7 @@ import Language.Purus.Pipeline.Lift.Types ( unHole, pattern LiftedHole, ) -import Language.Purus.Pipeline.Monad ( Inline, MonadCounter(next) ) +import Language.Purus.Pipeline.Monad (Inline, MonadCounter (next)) import Language.Purus.Pretty.Common (prettyStr) import Algebra.Graph.AdjacencyMap ( diff --git a/src/Language/Purus/Pipeline/Inline/Types.hs b/src/Language/Purus/Pipeline/Inline/Types.hs index e064ccff..db44bbae 100644 --- a/src/Language/Purus/Pipeline/Inline/Types.hs +++ b/src/Language/Purus/Pipeline/Inline/Types.hs @@ -2,11 +2,11 @@ module Language.Purus.Pipeline.Inline.Types where import Prelude -import Language.PureScript.Names ( Ident ) +import Language.PureScript.Names (Ident) -import Language.Purus.Pipeline.Lift.Types ( MonoScoped ) +import Language.Purus.Pipeline.Lift.Types (MonoScoped) -import Prettyprinter ( Pretty ) +import Prettyprinter (Pretty) newtype LoopBreakerScore = LoopBreakerScore {getScore :: ((Ident, Int), Maybe Int)} deriving (Show, Eq, Ord) diff --git a/src/Language/Purus/Pipeline/Instantiate.hs b/src/Language/Purus/Pipeline/Instantiate.hs index b5e7c663..c8e4c70a 100644 --- a/src/Language/Purus/Pipeline/Instantiate.hs +++ b/src/Language/Purus/Pipeline/Instantiate.hs @@ -17,13 +17,19 @@ import Data.Text (Text) import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.CoreFn.Expr (PurusType) import Language.PureScript.CoreFn.TypeLike (TypeLike (..), instantiates) -import Language.PureScript.Names ( Ident(Ident) ) +import Language.PureScript.Names (Ident (Ident)) import Language.PureScript.Types (Type (..)) -import Language.Purus.Debug ( doTrace, prettify ) +import Language.Purus.Debug (doTrace, prettify) import Language.Purus.IR (BVar (..), Exp (..), analyzeApp, expTy) -import Language.Purus.IR.Utils - ( WithObjects, Vars, mapAlt, mapBind, transformTypesInExp, viaExp ) +import Language.Purus.IR.Utils ( + Vars, + WithObjects, + mapAlt, + mapBind, + transformTypesInExp, + viaExp, + ) import Language.Purus.Pretty.Common (prettyStr) import Control.Lens (transform, view, _2) diff --git a/src/Language/Purus/Pipeline/Lift.hs b/src/Language/Purus/Pipeline/Lift.hs index 1a875d55..083d3c8b 100644 --- a/src/Language/Purus/Pipeline/Lift.hs +++ b/src/Language/Purus/Pipeline/Lift.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} + {-# HLINT ignore "Use if" #-} {-# HLINT ignore "Use <&>" #-} {-# HLINT ignore "Move concatMap out" #-} @@ -44,19 +45,20 @@ import Language.Purus.IR.Utils ( toExp, viaExp, ) -import Language.Purus.Pipeline.Lift.Types - ( LiftResult(LiftResult), - MonoExp, - pattern LiftedHole, - pattern LiftedHoleTerm, - fromHole, - toHole, - unHole, - Hole(Hole), - MonoAlt, - MonoBind, - MonoScoped, - ToLift(ToLift, declarations) ) +import Language.Purus.Pipeline.Lift.Types ( + Hole (Hole), + LiftResult (LiftResult), + MonoAlt, + MonoBind, + MonoExp, + MonoScoped, + ToLift (ToLift, declarations), + fromHole, + toHole, + unHole, + pattern LiftedHole, + pattern LiftedHoleTerm, + ) import Language.Purus.Pipeline.Monad (Inline, MonadCounter (next)) import Language.Purus.Pretty.Common (docString, prettyStr) @@ -82,8 +84,13 @@ import Control.Lens (cosmos, over, toListOf, transform, (^..), _1) import Bound.Scope (abstract) import Bound.Var (Var (..)) -import Prettyprinter - ( Pretty(pretty), align, hardline, indent, vcat ) +import Prettyprinter ( + Pretty (pretty), + align, + hardline, + indent, + vcat, + ) {- Given a collection of declarations that will be lifted, determine for each declaration the "deep" (recursive) set of NEW variable dependencies which need to be added diff --git a/src/Language/Purus/Pipeline/Monad.hs b/src/Language/Purus/Pipeline/Monad.hs index 97fb664d..b1c00d8e 100644 --- a/src/Language/Purus/Pipeline/Monad.hs +++ b/src/Language/Purus/Pipeline/Monad.hs @@ -9,9 +9,8 @@ GenerateDatatypes, EliminateCases, and CompileToPIR run in the PlutusContext Monad. - Intantiate is pure. + Intantiate is pure. -} - {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StarIsType #-} {-# LANGUAGE TemplateHaskell #-} @@ -24,23 +23,32 @@ import Prelude import Data.Map (Map) import Data.Map qualified as M -import Language.PureScript.CoreFn.Ann ( Ann ) -import Language.PureScript.CoreFn.Expr ( PurusType ) -import Language.PureScript.CoreFn.Module ( Module ) -import Language.PureScript.Names ( Ident, ModuleName ) -import Language.Purus.IR.Utils ( IR_Decl ) -import Language.Purus.Types ( DatatypeDictionary ) +import Language.PureScript.CoreFn.Ann (Ann) +import Language.PureScript.CoreFn.Expr (PurusType) +import Language.PureScript.CoreFn.Module (Module) +import Language.PureScript.Names (Ident, ModuleName) +import Language.Purus.IR.Utils (IR_Decl) +import Language.Purus.Types (DatatypeDictionary) -import Control.Monad.Except (MonadError) -import Control.Monad.Reader ( MonadReader(..), MonadTrans(..) ) -import Control.Monad.State - ( evalStateT, StateT(..), MonadState(get, put), gets ) -import Control.Lens.Operators ( (%=), (+=), (.=) ) +import Control.Lens.Operators ((%=), (+=), (.=)) import Control.Lens.TH (makeLenses) - -import Prettyprinter - ( Pretty(pretty), (<+>), align, hardline, indent, vcat ) - +import Control.Monad.Except (MonadError) +import Control.Monad.Reader (MonadReader (..), MonadTrans (..)) +import Control.Monad.State ( + MonadState (get, put), + StateT (..), + evalStateT, + gets, + ) + +import Prettyprinter ( + Pretty (pretty), + align, + hardline, + indent, + vcat, + (<+>), + ) newtype CounterT m a = CounterT {runCounterT :: StateT Int m a} deriving newtype (Functor, Applicative, Monad, MonadTrans) diff --git a/src/Language/Purus/Prim/Data.hs b/src/Language/Purus/Prim/Data.hs index 58cbf99b..24a3a0b5 100644 --- a/src/Language/Purus/Prim/Data.hs +++ b/src/Language/Purus/Prim/Data.hs @@ -9,7 +9,7 @@ We also create tuples here. They're directly exposed to users (albeit in the somewhat ugly Tuple1, Tuple2, ... form), but, more importantly, we need tuples (qua anonymous products) to eliminate Records (which - Plutus has no notion of). + Plutus has no notion of). -} @@ -23,7 +23,7 @@ import Data.Map qualified as M import Data.Text (Text) import Data.Text qualified as T -import Language.PureScript.AST.SourcePos (pattern NullSourceAnn, SourceAnn) +import Language.PureScript.AST.SourcePos (SourceAnn, pattern NullSourceAnn) import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.CoreFn.Desugar.Utils (properToIdent) import Language.PureScript.CoreFn.Expr @@ -45,11 +45,13 @@ import Language.PureScript.Names ( Qualified (..), QualifiedBy (ByModuleName), ) -import Language.PureScript.Types (Type (..), SourceType) +import Language.PureScript.Types (SourceType, Type (..)) -import Language.Purus.IR - ( Kind(KindType), Ty(TyVar, TyApp, TyCon) ) -import Language.Purus.Config ( maxTupleSize ) +import Language.Purus.Config (maxTupleSize) +import Language.Purus.IR ( + Kind (KindType), + Ty (TyApp, TyCon, TyVar), + ) import Control.Lens ((<&>), (^.)) @@ -59,7 +61,6 @@ pattern ArrayCons = Qualified (ByModuleName C.M_Prim) (Ident "Cons") pattern ArrayNil :: Qualified Ident pattern ArrayNil = Qualified (ByModuleName C.M_Prim) (Ident "Nil") - mkProdFields :: [t] -> [(Ident, t)] mkProdFields = map (UnusedIdent,) diff --git a/src/Language/Purus/Prim/Ledger.hs b/src/Language/Purus/Prim/Ledger.hs index 146759b9..fd2a52f4 100644 --- a/src/Language/Purus/Prim/Ledger.hs +++ b/src/Language/Purus/Prim/Ledger.hs @@ -4,11 +4,11 @@ module Language.Purus.Prim.Ledger ( ledgerTypes, ledgerCons, ledgerConstructorsEnv, - ledgerConstructorsEnvReadable - ) where + ledgerConstructorsEnvReadable, +) where import Data.Map qualified as M - + import Data.Bifunctor (first) import Data.List (foldl') import Language.PureScript.AST.SourcePos (SourceAnn, nullSourceAnn) @@ -37,32 +37,38 @@ import Language.PureScript.Types ( Type (TypeConstructor, TypeVar), ) import Language.Purus.IR () -import Language.Purus.Prim.LedgerData ( ledgerDecls ) -import Language.Purus.Prim.Utils - ( arm, - listOf, - mapOf, - maybeOf, - monoType, - mononym, - newtypeOf, - nominalVar, - polyNewtypeOf, - polyRecordType, - polySumType, - polyType, - primName, - recordType, - sumType, - tuple2Of, - tyApp, - tyCon, - tyVar ) +import Language.Purus.Prim.LedgerData (ledgerDecls) +import Language.Purus.Prim.Utils ( + arm, + listOf, + mapOf, + maybeOf, + monoType, + mononym, + newtypeOf, + nominalVar, + polyNewtypeOf, + polyRecordType, + polySumType, + polyType, + primName, + recordType, + sumType, + tuple2Of, + tyApp, + tyCon, + tyVar, + ) import Prelude import Language.Purus.Pretty.Common (docString) -import Prettyprinter - ( Pretty(pretty), (<+>), hardline, punctuate, vcat ) +import Prettyprinter ( + Pretty (pretty), + hardline, + punctuate, + vcat, + (<+>), + ) -- | Ledger API (V2) types, as per https://github.com/IntersectMBO/plutus/blob/master/plutus-ledger-api/src/PlutusLedgerApi/V2.hs ledgerTypes :: [(Qualified (ProperName 'TypeName), (Type SourceAnn, TypeKind))] diff --git a/src/Language/Purus/Types.hs b/src/Language/Purus/Types.hs index cf025a4b..214dcef5 100644 --- a/src/Language/Purus/Types.hs +++ b/src/Language/Purus/Types.hs @@ -9,13 +9,17 @@ import Data.Map qualified as M import Data.Text (Text) -import Language.PureScript.Names - ( Ident, ProperName, ProperNameType(TypeName), Qualified ) +import Language.PureScript.Names ( + Ident, + ProperName, + ProperNameType (TypeName), + Qualified, + ) import PlutusCore qualified as PLC import PlutusIR qualified as PIR -import Control.Lens.TH ( makeLenses ) +import Control.Lens.TH (makeLenses) type PIRDatatype = PIR.Datatype @@ -28,7 +32,7 @@ type PIRType = PIR.Type PIR.TyName PLC.DefaultUni () type PIRTerm = PIR.Term PIR.TyName PIR.Name PLC.DefaultUni PLC.DefaultFun () -type PLCTerm = PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () +type PLCTerm = PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () data DatatypeDictionary = DatatypeDictionary { _pirDatatypes :: Map (Qualified (ProperName 'TypeName)) PIRDatatype diff --git a/src/Language/Purus/Utils.hs b/src/Language/Purus/Utils.hs index f72c81f9..e8e6ed6d 100644 --- a/src/Language/Purus/Utils.hs +++ b/src/Language/Purus/Utils.hs @@ -11,14 +11,17 @@ import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn.Expr (Bind, PurusType) import Language.PureScript.CoreFn.FromJSON () import Language.PureScript.CoreFn.Module (Module (..)) -import Language.PureScript.Names - ( pattern ByNullSourcePos, Ident(Ident), Qualified(..) ) - -import Language.Purus.Debug ( doTrace ) -import Language.Purus.IR ( BVar, BindE(..), Exp ) +import Language.PureScript.Names ( + Ident (Ident), + Qualified (..), + pattern ByNullSourcePos, + ) + +import Language.Purus.Debug (doTrace) +import Language.Purus.IR (BVar, BindE (..), Exp) import Language.Purus.IR.Utils (IR_Decl, Vars, WithObjects, foldBinds, toExp) -import Control.Exception ( throwIO ) +import Control.Exception (throwIO) import Data.List (find) @@ -30,8 +33,7 @@ import Data.Text qualified as T import Data.Aeson qualified as Aeson -import Bound ( Scope ) - +import Bound (Scope) {- IO utility. Reads a CoreFn module from a source file.