From aa2cbdae18eb3df65eb7c49b42b89f6b02357ad0 Mon Sep 17 00:00:00 2001 From: Drew Hess Date: Tue, 17 May 2022 17:29:15 +0100 Subject: [PATCH 1/5] refactor: Add a `mkASTDef` helper function. --- primer-rel8/test/TestUtils.hs | 20 ++++++++------------ primer/src/Primer/Core/Utils.hs | 17 +++++++++++++++++ primer/test/Tests/Action/Available.hs | 14 +++++--------- 3 files changed, 30 insertions(+), 21 deletions(-) diff --git a/primer-rel8/test/TestUtils.hs b/primer-rel8/test/TestUtils.hs index 3a92afaad..56374c0da 100644 --- a/primer-rel8/test/TestUtils.hs +++ b/primer-rel8/test/TestUtils.hs @@ -76,7 +76,6 @@ import Primer.Core.DSL ( branch, case_, con, - create, emptyHole, gvar', hole, @@ -94,6 +93,9 @@ import Primer.Core.DSL ( thole, tvar, ) +import Primer.Core.Utils ( + mkASTDef, + ) import Primer.Database.Rel8.Rel8Db ( Rel8Db, runRel8Db, @@ -237,7 +239,8 @@ insertSessionRow row conn = , returning = NumberOfRowsAffected } --- | This definition contains every construct in the Primer language. +-- | This definition contains most of the non-primitive constructs in +-- the Primer language. -- -- TODO: this is identical to a program in the core Primer test suite, -- so it should be refactored into a common test library. See: @@ -245,15 +248,8 @@ insertSessionRow row conn = testASTDef :: ASTDef testASTDefNextID :: ID (testASTDef, testASTDefNextID) = - ( ASTDef - { astDefName = qualifyName (ModuleName $ "TestModule" :| []) "1" - , astDefExpr - , astDefType - } - , nextID - ) + mkASTDef (qualifyName (ModuleName $ "TestModule" :| []) "1") t e where - ((astDefExpr, astDefType), nextID) = create $ (,) <$> e <*> t t = tfun (tcon tNat) @@ -348,8 +344,8 @@ testASTDefNextID :: ID -- | An initial test 'App' instance that contains all default type -- definitions (including primitive types), all primitive functions, --- and a top-level definition that contains every construct in the --- Primer language.x +-- and a top-level definition that contains most of the non-primitive +-- constructs in the Primer language.x testApp :: App testApp = newEmptyApp diff --git a/primer/src/Primer/Core/Utils.hs b/primer/src/Primer/Core/Utils.hs index fc401c436..7f335eefd 100644 --- a/primer/src/Primer/Core/Utils.hs +++ b/primer/src/Primer/Core/Utils.hs @@ -16,6 +16,9 @@ module Primer.Core.Utils ( freeVarsTy, alphaEqTy, concreteTy, + + -- * Construct ASTs. + mkASTDef, ) where import Foreword @@ -28,9 +31,11 @@ import qualified Data.Set as S import Data.Set.Optics (setOf) import Optics (Fold, Traversal, getting, hasn't, set, summing, to, traversalVL, traverseOf, (%), _2, _Left, _Right) import Primer.Core ( + ASTDef (..), CaseBranch' (..), Expr, Expr' (..), + GVarName, HasID (_id), ID, Kind (KHole), @@ -46,6 +51,10 @@ import Primer.Core ( _exprTypeMeta, _typeMeta, ) +import Primer.Core.DSL ( + S, + create, + ) import Primer.Name (Name, NameCounter, freshName) -- | Helper, wrapping 'freshName' @@ -228,3 +237,11 @@ _freeTyVars = traversalVL $ go mempty concreteTy :: Data b => Type' b -> Bool concreteTy ty = hasn't (getting _freeVarsTy) ty && noHoles ty + +-- | Given a 'GVarName' and a DSL 'Type' and 'Expr', construct a new +-- 'ASTDef' and the next valid 'ID'. Note that this AST isn't +-- guaranteed to typecheck; it is simply syntactically correct. +mkASTDef :: GVarName -> S Type -> S Expr -> (ASTDef, ID) +mkASTDef n t e = (ASTDef n expr typ, nextID) + where + ((expr, typ), nextID) = create $ (,) <$> e <*> t diff --git a/primer/test/Tests/Action/Available.hs b/primer/test/Tests/Action/Available.hs index 492f34c84..9b997763a 100644 --- a/primer/test/Tests/Action/Available.hs +++ b/primer/test/Tests/Action/Available.hs @@ -26,7 +26,6 @@ import Primer.Core.DSL ( branch, case_, con, - create, emptyHole, gvar', hole, @@ -44,6 +43,9 @@ import Primer.Core.DSL ( thole, tvar, ) +import Primer.Core.Utils ( + mkASTDef, + ) import Primer.Name (Name (unName)) import System.FilePath (()) import Test.Tasty (TestTree, testGroup) @@ -52,17 +54,11 @@ import Test.Tasty.HUnit () import TestUtils (exprIDs, gvn) import Text.Pretty.Simple (pShowNoColor) --- | This definition contains every construct in the Primer language. +-- | This definition contains most constructs in the Primer language. test_1 :: TestTree test_1 = - mkTests - ASTDef - { astDefName = gvn ["M"] "1" - , astDefExpr - , astDefType - } + mkTests $ fst $ mkASTDef (gvn ["M"] "1") t e where - ((astDefExpr, astDefType), _) = create $ (,) <$> e <*> t t = tfun (tcon tNat) From b741eceebfdee7ce4e4968051c6f1ab1698a0bb5 Mon Sep 17 00:00:00 2001 From: Drew Hess Date: Mon, 23 May 2022 13:26:31 +0100 Subject: [PATCH 2/5] refactor: Add a variant of `create` that drops the ID. --- primer-service/src/Primer/Server.hs | 11 +++- primer/src/Primer/Core/DSL.hs | 5 ++ primer/src/Primer/Primitives.hs | 4 +- primer/test/Tests/API.hs | 8 +-- primer/test/Tests/Action.hs | 4 +- primer/test/Tests/Action/Prog.hs | 70 ++++++++++++------------- primer/test/Tests/AlphaEquality.hs | 50 +++++++++--------- primer/test/Tests/Eval.hs | 79 ++++++++++++++--------------- primer/test/Tests/EvalFull.hs | 2 +- primer/test/Tests/FreeVars.hs | 4 +- primer/test/Tests/Question.hs | 10 ++-- primer/test/Tests/Subst.hs | 22 ++++---- primer/test/Tests/Transform.hs | 4 +- 13 files changed, 141 insertions(+), 132 deletions(-) diff --git a/primer-service/src/Primer/Server.hs b/primer-service/src/Primer/Server.hs index 85f36d7e9..8518d758f 100644 --- a/primer-service/src/Primer/Server.hs +++ b/primer-service/src/Primer/Server.hs @@ -84,7 +84,15 @@ import Primer.Core ( TypeCacheBoth (..), qualifyName, ) -import Primer.Core.DSL (app, branch', case_, create, emptyHole, tEmptyHole, tfun) +import Primer.Core.DSL ( + app, + branch', + case_, + create', + emptyHole, + tEmptyHole, + tfun, + ) import Primer.Database ( Session, SessionId, @@ -346,7 +354,6 @@ testEndpoints = :<|> mkTest (EvalFullRespNormal expr) where mkTest x = pure x :<|> pure - create' = fst . create expr = create' emptyHole ty = create' tEmptyHole reductionDetail = diff --git a/primer/src/Primer/Core/DSL.hs b/primer/src/Primer/Core/DSL.hs index 7ee597170..a39b9db84 100644 --- a/primer/src/Primer/Core/DSL.hs +++ b/primer/src/Primer/Core/DSL.hs @@ -33,6 +33,7 @@ module Primer.Core.DSL ( meta, meta', create, + create', setMeta, S, tcon', @@ -87,6 +88,10 @@ instance MonadFresh ID S where create :: S a -> (a, ID) create = flip runState 0 . unS +-- | As 'create', but drop the 'ID'. +create' :: S a -> a +create' = fst . create + setMeta :: Functor m => Value -> m Expr -> m Expr setMeta m e = set _metadata (Just m) <$> e diff --git a/primer/src/Primer/Primitives.hs b/primer/src/Primer/Primitives.hs index cb81f8954..e51b72aa9 100644 --- a/primer/src/Primer/Primitives.hs +++ b/primer/src/Primer/Primitives.hs @@ -45,7 +45,7 @@ import Primer.Core.DSL ( bool_, char, con, - create, + create', int, maybe_, nat, @@ -68,7 +68,7 @@ primitiveModule = Module { moduleName = primitiveModuleName , moduleTypes = TypeDefPrim <$> M.mapKeys baseName allPrimTypeDefs - , moduleDefs = fst . create $ + , moduleDefs = create' $ getAp $ flip M.foldMapWithKey allPrimDefs $ \n def -> Ap $ do ty <- primFunType def diff --git a/primer/test/Tests/API.hs b/primer/test/Tests/API.hs index 4283e4fbf..cbd5ab5fd 100644 --- a/primer/test/Tests/API.hs +++ b/primer/test/Tests/API.hs @@ -93,12 +93,12 @@ unit_viewTreeType_injective_forall_kind = distinctTreeExpr :: S Expr -> S Expr -> Assertion distinctTreeExpr e1 e2 = - let t1 = viewTreeExpr $ fst $ create e1 - t2 = viewTreeExpr $ fst $ create e2 + let t1 = viewTreeExpr $ create' e1 + t2 = viewTreeExpr $ create' e2 in assertBool ("non-injective viewTreeExpr: " ++ show t1) (t1 /= t2) distinctTreeType :: S Type -> S Type -> Assertion distinctTreeType e1 e2 = - let t1 = viewTreeType $ fst $ create e1 - t2 = viewTreeType $ fst $ create e2 + let t1 = viewTreeType $ create' e1 + t2 = viewTreeType $ create' e2 in assertBool ("non-injective viewTreeType: " ++ show t1) (t1 /= t2) diff --git a/primer/test/Tests/Action.hs b/primer/test/Tests/Action.hs index 17dd463d4..fb95929d5 100644 --- a/primer/test/Tests/Action.hs +++ b/primer/test/Tests/Action.hs @@ -48,7 +48,7 @@ maxID = maximum . map getID . universe hprop_ConstructVar_succeeds_on_hole_when_in_scope :: Property hprop_ConstructVar_succeeds_on_hole_when_in_scope = property $ do -- Generate \x -> ? - let expr = fst $ create $ ann (lam "x" emptyHole) (tfun tEmptyHole tEmptyHole) + let expr = create' $ ann (lam "x" emptyHole) (tfun tEmptyHole tEmptyHole) annotateShow expr expr' <- either (\err -> footnoteShow err >> failure) pure $ @@ -965,7 +965,7 @@ actionTest :: SmartHoles -> S Expr -> [Action] -> S Expr -> Assertion actionTest sh inputExpr actions expectedOutput = do let (expr, i) = create inputExpr result <- either (assertFailure . show) pure $ runTestActions sh i expr actions - let (expected, _) = create expectedOutput + let expected = create' expectedOutput -- Compare result to input, ignoring any difference in metadata -- NB: we don't compare up-to-alpha, as names should be determined by the -- actions on-the-nose diff --git a/primer/test/Tests/Action/Prog.hs b/primer/test/Tests/Action/Prog.hs index 4660be667..92ac88b63 100644 --- a/primer/test/Tests/Action/Prog.hs +++ b/primer/test/Tests/Action/Prog.hs @@ -98,6 +98,7 @@ import Primer.Core.DSL ( case_, con, create, + create', emptyHole, hole, lAM, @@ -825,7 +826,7 @@ unit_RenameType = def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs - ( fst . create $ + ( create' $ emptyHole `ann` (tcon (tcn "T'") `tapp` tcon (tcn "Bool")) ) @@ -868,7 +869,7 @@ unit_RenameCon = def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs - ( fst . create $ + ( create' $ hole ( hole $ case_ @@ -946,7 +947,7 @@ unit_AddCon = def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs - ( fst . create $ + ( create' $ case_ (emptyHole `ann` (tcon tT `tapp` tcon (tcn "Bool") `tapp` tcon (tcn "Int"))) [ branch cA [] emptyHole @@ -976,7 +977,7 @@ unit_SetConFieldType = def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs - ( fst . create $ + ( create' $ con cA `aPP` tEmptyHole `aPP` tEmptyHole `app` con (vcn "True") `app` hole (con (vcn "True")) @@ -997,7 +998,7 @@ unit_SetConFieldType_partial_app = def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs - ( fst . create $ + ( create' $ hole $ con cA `app` lvar "x" ) @@ -1024,7 +1025,7 @@ unit_SetConFieldType_case = def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs - ( fst . create $ + ( create' $ case_ (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch @@ -1057,7 +1058,7 @@ unit_SetConFieldType_shadow = def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs - ( fst . create $ + ( create' $ case_ (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch @@ -1097,7 +1098,7 @@ unit_AddConField = def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs - ( fst . create $ + ( create' $ case_ ( con cA `aPP` tEmptyHole `aPP` tEmptyHole `app` con (vcn "True") @@ -1124,7 +1125,7 @@ unit_AddConField_partial_app = def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs - ( fst . create $ + ( create' $ hole $ con cA `app` con (vcn "True") ) @@ -1147,7 +1148,7 @@ unit_AddConField_partial_app_end = def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs - ( fst . create $ + ( create' $ con cA `app` con (vcn "True") `app` emptyHole ) @@ -1173,7 +1174,7 @@ unit_AddConField_case_ann = def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs - ( fst . create $ + ( create' $ case_ (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch @@ -1301,7 +1302,7 @@ unit_good_defaultFullProg = checkProgWellFormed defaultFullProg -- All primitives,builtins and defaultEmptyProg things have distinct base names (defaultFullProg expects this) unit_defaultFullProg_no_clash :: Assertion unit_defaultFullProg_no_clash = - let (p, _) = create defaultEmptyProg + let p = create' defaultEmptyProg ms = progModules p <> [builtinModule, primitiveModule] typeNames = ms ^.. folded % #moduleTypes % folded % to typeDefName % #baseName termNames = ms ^.. folded % #moduleDefs % to Map.keys % folded @@ -1460,29 +1461,28 @@ unit_cross_module_actions = n = ["Module2"] qualifyM :: Name -> GlobalName k qualifyM = qualifyName $ moduleName m - m = fst $ - create $ do - let ty = - ASTTypeDef - { astTypeDefName = qualifyM "T" - , astTypeDefParameters = [] - , astTypeDefConstructors = [ValCon (qualifyM "C") [TCon () tNat]] - , astTypeDefNameHints = [] - } - defTy <- tcon (astTypeDefName ty) `tfun` tcon (astTypeDefName ty) - defExpr <- emptyHole - let def = - ASTDef - { astDefName = qualifyM "foo" - , astDefType = defTy - , astDefExpr = defExpr - } - pure - Module - { moduleName = ModuleName n - , moduleTypes = Map.singleton "T" (TypeDefAST ty) - , moduleDefs = Map.singleton "foo" (DefAST def) - } + m = create' $ do + let ty = + ASTTypeDef + { astTypeDefName = qualifyM "T" + , astTypeDefParameters = [] + , astTypeDefConstructors = [ValCon (qualifyM "C") [TCon () tNat]] + , astTypeDefNameHints = [] + } + defTy <- tcon (astTypeDefName ty) `tfun` tcon (astTypeDefName ty) + defExpr <- emptyHole + let def = + ASTDef + { astDefName = qualifyM "foo" + , astDefType = defTy + , astDefExpr = defExpr + } + pure + Module + { moduleName = ModuleName n + , moduleTypes = Map.singleton "T" (TypeDefAST ty) + , moduleDefs = Map.singleton "foo" (DefAST def) + } -- We turn off smartholes, as we want to test our actions work without it a = newEmptyApp & #appProg % #progModules %~ (m :) diff --git a/primer/test/Tests/AlphaEquality.hs b/primer/test/Tests/AlphaEquality.hs index 1b44ac2b6..1e620eec3 100644 --- a/primer/test/Tests/AlphaEquality.hs +++ b/primer/test/Tests/AlphaEquality.hs @@ -20,68 +20,68 @@ import Test.Tasty.HUnit hiding (assert) unit_1 :: Assertion unit_1 = assertNotEqual - (create' (tcon tNat)) - (create' (tcon tBool)) + (create_ (tcon tNat)) + (create_ (tcon tBool)) unit_2 :: Assertion unit_2 = (@?=) - (create' (tcon tList `tapp` tcon tNat)) - (create' (tcon tList `tapp` tcon tNat)) + (create_ (tcon tList `tapp` tcon tNat)) + (create_ (tcon tList `tapp` tcon tNat)) unit_3 :: Assertion unit_3 = assertNotEqual - (create' (tcon tList `tapp` tcon tBool)) - (create' (tcon tList `tapp` tcon tNat)) + (create_ (tcon tList `tapp` tcon tBool)) + (create_ (tcon tList `tapp` tcon tNat)) unit_4 :: Assertion unit_4 = assertNotEqual - (create' (tcon tList `tapp` tcon tBool)) - (create' (tcon tNat)) + (create_ (tcon tList `tapp` tcon tBool)) + (create_ (tcon tNat)) unit_5 :: Assertion unit_5 = assertNotEqual - (create' (tforall "a" KType $ tcon tList `tapp` tvar "a")) - (create' (tcon tNat)) + (create_ (tforall "a" KType $ tcon tList `tapp` tvar "a")) + (create_ (tcon tNat)) unit_6 :: Assertion unit_6 = (@?=) - (create' (tforall "a" KType $ tcon tList `tapp` tvar "a")) - (create' (tforall "b" KType $ tcon tList `tapp` tvar "b")) + (create_ (tforall "a" KType $ tcon tList `tapp` tvar "a")) + (create_ (tforall "b" KType $ tcon tList `tapp` tvar "b")) unit_7 :: Assertion unit_7 = assertNotEqual - (create' (tforall "a" KType $ tcon tList `tapp` tvar "a")) - (create' (tforall "b" KType $ tcon tList `tapp` tcon tBool)) + (create_ (tforall "a" KType $ tcon tList `tapp` tvar "a")) + (create_ (tforall "b" KType $ tcon tList `tapp` tcon tBool)) unit_8 :: Assertion unit_8 = assertNotEqual - (create' (tforall "a" KType $ tcon tBool)) - (create' (tforall "b" (KFun KType KType) $ tcon tBool)) + (create_ (tforall "a" KType $ tcon tBool)) + (create_ (tforall "b" (KFun KType KType) $ tcon tBool)) unit_9 :: Assertion unit_9 = assertNotEqual - (create' (tforall "a" KType $ tforall "b" KType $ tcon tList `tapp` tvar "a")) - (create' (tforall "a" KType $ tforall "b" KType $ tcon tList `tapp` tvar "b")) + (create_ (tforall "a" KType $ tforall "b" KType $ tcon tList `tapp` tvar "a")) + (create_ (tforall "a" KType $ tforall "b" KType $ tcon tList `tapp` tvar "b")) unit_10 :: Assertion unit_10 = assertNotEqual - (create' (tforall "a" KType $ tcon tList `tapp` tvar "a")) - (create' (tcon tList `tapp` tforall "a" KType (tvar "b"))) + (create_ (tforall "a" KType $ tcon tList `tapp` tvar "a")) + (create_ (tcon tList `tapp` tforall "a" KType (tvar "b"))) unit_11 :: Assertion unit_11 = assertNotEqual - (create' (tforall "a" KType $ tcon tBool `tfun` (tcon tList `tapp` tvar "a"))) - (create' (tcon tBool `tfun` tforall "a" KType (tcon tList `tapp` tvar "a"))) + (create_ (tforall "a" KType $ tcon tBool `tfun` (tcon tList `tapp` tvar "a"))) + (create_ (tcon tBool `tfun` tforall "a" KType (tcon tList `tapp` tvar "a"))) hprop_refl :: Property hprop_refl = property $ do @@ -94,10 +94,10 @@ hprop_alpha = property $ do t <- f <$> forAll (evalExprGen 0 genTyVarName) s === t where - f v = create' $ tforall v KType $ tvar v + f v = create_ $ tforall v KType $ tvar v -create' :: S (Type' a) -> Alpha -create' = Alpha . forgetTypeIDs . fst . create +create_ :: S (Type' a) -> Alpha +create_ = Alpha . forgetTypeIDs . create' -- | Like @Type' ()@, but 'Eq' only compares up to alpha-equality. newtype Alpha = Alpha (Type' ()) diff --git a/primer/test/Tests/Eval.hs b/primer/test/Tests/Eval.hs index 390f22269..7f1887128 100644 --- a/primer/test/Tests/Eval.hs +++ b/primer/test/Tests/Eval.hs @@ -165,8 +165,8 @@ unit_tryReduce_beta_nested = do case result of Right (expr, BetaReduction detail) -> do expr ~= expectedResult - betaBefore detail ~= fst (create (app (lam "x" (lam "y" (lvar "x"))) (con' ["M"] "C"))) - betaAfter detail ~= fst (create (let_ "x" (con' ["M"] "C") (lam "y" (lvar "x")))) + betaBefore detail ~= create' (app (lam "x" (lam "y" (lvar "x"))) (con' ["M"] "C")) + betaAfter detail ~= create' (let_ "x" (con' ["M"] "C") (lam "y" (lvar "x"))) betaBindingName detail @?= "x" betaLambdaID detail @?= lambda ^. _id betaArgID detail @?= arg ^. _id @@ -190,8 +190,8 @@ unit_tryReduce_beta_annotation_nested = do case result of Right (expr, BetaReduction detail@BetaReductionDetail{betaTypes = Just (l, r)}) -> do expr ~= expectedResult - betaBefore detail ~= fst (create (app (ann (lam "x" (lvar "x")) (tfun (tcon' ["M"] "A") (tcon' ["M"] "B"))) (con' ["M"] "C"))) - betaAfter detail ~= fst (create (ann (let_ "x" (ann (con' ["M"] "C") (tcon' ["M"] "A")) (lvar "x")) (tcon' ["M"] "B"))) + betaBefore detail ~= create' (app (ann (lam "x" (lvar "x")) (tfun (tcon' ["M"] "A") (tcon' ["M"] "B"))) (con' ["M"] "C")) + betaAfter detail ~= create' (ann (let_ "x" (ann (con' ["M"] "C") (tcon' ["M"] "A")) (lvar "x")) (tcon' ["M"] "B")) betaBindingName detail @?= "x" betaLambdaID detail @?= lambda ^. _id betaArgID detail @?= arg ^. _id @@ -329,7 +329,7 @@ unit_tryReduce_global_var = do pure (g, ASTDef{astDefName = f, astDefExpr = e, astDefType = t}) globals = Map.singleton f (DefAST def) result = runTryReduce globals mempty (expr, i) - expectedResult = fst $ create $ ann (lam "x" (lvar "x")) (tfun (tcon' ["M"] "A") (tcon' ["M"] "B")) + expectedResult = create' $ ann (lam "x" (lvar "x")) (tfun (tcon' ["M"] "A") (tcon' ["M"] "B")) case result of Right (expr', GlobalVarInline detail) -> do expr' ~= expectedResult @@ -343,7 +343,7 @@ unit_tryReduce_let :: Assertion unit_tryReduce_let = do let (expr, i) = create $ let_ "x" (con' ["M"] "C") (con' ["M"] "D") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con' ["M"] "D" + expectedResult = create' $ con' ["M"] "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -360,7 +360,7 @@ unit_tryReduce_let_self_capture :: Assertion unit_tryReduce_let_self_capture = do let (expr, i) = create $ let_ "x" (lvar "x") (lvar "x") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ let_ "x0" (lvar "x") (lvar "x0") + expectedResult = create' $ let_ "x0" (lvar "x") (lvar "x0") case result of Right (expr', LetRename detail) -> do expr' ~= expectedResult @@ -378,7 +378,7 @@ unit_tryReduce_lettype :: Assertion unit_tryReduce_lettype = do let (expr, i) = create $ letType "x" (tcon' ["M"] "C") (con' ["M"] "D") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con' ["M"] "D" + expectedResult = create' $ con' ["M"] "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -395,7 +395,7 @@ unit_tryReduce_lettype_self_capture :: Assertion unit_tryReduce_lettype_self_capture = do let (expr, i) = create $ letType "x" (tvar "x") (emptyHole `ann` tvar "x") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ letType "x0" (tvar "x") (emptyHole `ann` tvar "x0") + expectedResult = create' $ letType "x0" (tvar "x") (emptyHole `ann` tvar "x0") case result of Right (expr', LetRename detail) -> do expr' ~= expectedResult @@ -413,7 +413,7 @@ unit_tryReduce_letrec :: Assertion unit_tryReduce_letrec = do let (expr, i) = create $ letrec "x" (con' ["M"] "C") (tcon' ["M"] "T") (con' ["M"] "D") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con' ["M"] "D" + expectedResult = create' $ con' ["M"] "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -436,7 +436,7 @@ unit_tryReduce_letrec_app = do expr_ <- app (pure lr) (pure arg_) pure (arg_, lam_, lr, expr_) result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ letrec "f" (lam "x" (lvar "x")) (tcon' ["M"] "T") (app (lam "x" (app (lvar "f") (lvar "x"))) (con' ["M"] "D")) + expectedResult = create' $ letrec "f" (lam "x" (lvar "x")) (tcon' ["M"] "T") (app (lam "x" (app (lvar "f") (lvar "x"))) (con' ["M"] "D")) case result of Right (expr', PushAppIntoLetrec detail) -> do expr' ~= expectedResult @@ -461,7 +461,7 @@ unit_tryReduce_letrec_APP = do expr_ <- aPP (pure lr) (pure arg_) pure (arg_, lam_, lr, expr_) result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ letrec "f" (lAM "x" (con' ["M"] "A")) (tcon' ["M"] "T") (aPP (lAM "x" (aPP (lvar "f") (tvar "x"))) (tcon' ["M"] "B")) + expectedResult = create' $ letrec "f" (lAM "x" (con' ["M"] "A")) (tcon' ["M"] "T") (aPP (lAM "x" (aPP (lvar "f") (tvar "x"))) (tcon' ["M"] "B")) case result of Right (expr', PushAppIntoLetrec detail) -> do expr' ~= expectedResult @@ -497,7 +497,7 @@ unit_tryReduce_case_1 :: Assertion unit_tryReduce_case_1 = do let (expr, i) = create $ case_ (con' ["M"] "C") [branch' (["M"], "B") [("b", Nothing)] (con' ["M"] "D"), branch' (["M"], "C") [] (con' ["M"] "E")] result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con' ["M"] "E" + expectedResult = create' $ con' ["M"] "E" case result of Right (expr', CaseReduction detail) -> do expr' ~= expectedResult @@ -523,7 +523,7 @@ unit_tryReduce_case_2 = do , branch' (["M"], "C") [("c", Nothing), ("d", Nothing), ("e", Nothing)] (con' ["M"] "E") ] result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ let_ "c" (lam "x" (lvar "x")) (let_ "d" (lvar "y") (let_ "e" (lvar "z") (con' ["M"] "E"))) + expectedResult = create' $ let_ "c" (lam "x" (lvar "x")) (let_ "d" (lvar "y") (let_ "e" (lvar "z") (con' ["M"] "E"))) case result of Right (expr', CaseReduction detail) -> do expr' ~= expectedResult @@ -549,7 +549,7 @@ unit_tryReduce_case_3 = do , branch' (["M"], "C") [("c", Nothing)] (con' ["M"] "F") ] result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ let_ "c" (con' ["M"] "E") (con' ["M"] "F") + expectedResult = create' $ let_ "c" (con' ["M"] "E") (con' ["M"] "F") case result of Right (expr', CaseReduction detail) -> do expr' ~= expectedResult @@ -574,9 +574,8 @@ unit_tryReduce_case_name_clash = do [branch' (["M"], "C") [("x", Nothing), ("y", Nothing)] emptyHole] result = runTryReduce mempty mempty (expr, i) expectedResult = - fst $ - create $ - let_ "x0" emptyHole $ let_ "y" (lvar "x") emptyHole + create' $ + let_ "x0" emptyHole $ let_ "y" (lvar "x") emptyHole case result of Right (expr', CaseReduction detail) -> do expr' ~= expectedResult @@ -659,9 +658,9 @@ unit_tryReduce_prim_fail_unreduced_args = do unit_findNodeByID_letrec :: Assertion unit_findNodeByID_letrec = do - let expr = fst $ create $ letrec "x" (lvar "x") (tcon' ["M"] "T") (lvar "x") - x = fst $ create $ lvar "x" - t = fst $ create $ tcon' ["M"] "T" + let expr = create' $ letrec "x" (lvar "x") (tcon' ["M"] "T") (lvar "x") + x = create' $ lvar "x" + t = create' $ tcon' ["M"] "T" case findNodeByID 0 expr of Just (locals, Left z) -> do assertBool "no locals in scope at node 0" $ Map.null locals @@ -689,15 +688,14 @@ unit_findNodeByID_letrec = do unit_findNodeByID_1 :: Assertion unit_findNodeByID_1 = do - let (x, c, expr) = fst $ - create $ do - -- id 0 - x_ <- lvar "x" - -- id 1 - c_ <- con' ["M"] "C" - -- id 2 - e <- let_ "x" (pure c_) (pure x_) - pure (x_, c_, e) + let (x, c, expr) = create' $ do + -- id 0 + x_ <- lvar "x" + -- id 1 + c_ <- con' ["M"] "C" + -- id 2 + e <- let_ "x" (pure c_) (pure x_) + pure (x_, c_, e) case findNodeByID 0 expr of Just (locals, Left z) -> do case Map.lookup "x" locals of @@ -722,15 +720,14 @@ unit_findNodeByID_1 = do unit_findNodeByID_2 :: Assertion unit_findNodeByID_2 = do - let (x, t, expr) = fst $ - create $ do - -- id 0 - x_ <- tvar "x" - -- id 1 - t_ <- tcon' ["M"] "T" - -- id 2 - e <- letType "x" (pure t_) (ann (lvar "y") (pure x_)) - pure (x_, t_, e) + let (x, t, expr) = create' $ do + -- id 0 + x_ <- tvar "x" + -- id 1 + t_ <- tcon' ["M"] "T" + -- id 2 + e <- letType "x" (pure t_) (ann (lvar "y") (pure x_)) + pure (x_, t_, e) case findNodeByID 0 expr of Just (locals, Right z) -> do case Map.lookup "x" locals of @@ -754,11 +751,11 @@ unit_findNodeByID_2 = do -- | A helper for these tests redexesOf :: S Expr -> Set ID -redexesOf = redexes mempty . fst . create +redexesOf = redexes mempty . create' -- | A variation of 'redexesOf' for when the expression tested requires primitives to be in scope. redexesOfWithPrims :: S Expr -> Set ID -redexesOfWithPrims x = uncurry redexes $ fst $ create $ withPrimDefs $ \globals -> (globals,) <$> x +redexesOfWithPrims x = uncurry redexes $ create' $ withPrimDefs $ \globals -> (globals,) <$> x unit_redexes_con :: Assertion unit_redexes_con = redexesOf (con' ["M"] "C") @?= mempty diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs index a47b3ddc7..e34d3113d 100644 --- a/primer/test/Tests/EvalFull.hs +++ b/primer/test/Tests/EvalFull.hs @@ -1139,7 +1139,7 @@ testModules = [builtinModule, primitiveModule, testModule] testModule :: Module testModule = - let (ty, expr) = fst . create $ (,) <$> tcon tChar `tfun` tcon tChar <*> lam "x" (lvar "x") + let (ty, expr) = create' $ (,) <$> tcon tChar `tfun` tcon tChar <*> lam "x" (lvar "x") in Module { moduleName = ModuleName ["M"] , moduleTypes = mempty diff --git a/primer/test/Tests/FreeVars.hs b/primer/test/Tests/FreeVars.hs index 280877435..4680f6f35 100644 --- a/primer/test/Tests/FreeVars.hs +++ b/primer/test/Tests/FreeVars.hs @@ -10,12 +10,12 @@ import Primer.Core.Utils import Test.Tasty.HUnit unit_1 :: Assertion -unit_1 = freeVars (fst $ create emptyHole) @=? Set.empty +unit_1 = freeVars (create' emptyHole) @=? Set.empty unit_2 :: Assertion unit_2 = Set.fromList ["f", "y", "b"] - @=? freeVars (fst $ create t) + @=? freeVars (create' t) where t = ann diff --git a/primer/test/Tests/Question.hs b/primer/test/Tests/Question.hs index 42b019dc9..dd0cae4cc 100644 --- a/primer/test/Tests/Question.hs +++ b/primer/test/Tests/Question.hs @@ -239,7 +239,7 @@ unit_variablesInScope_shadowed = do -- We start by typechecking the expression, so it is annotated with types. hasVariables :: S Expr -> (ExprZ -> Maybe ExprZ) -> [(LVarName, Type' ())] -> Assertion hasVariables expr path expected = do - let e = fst $ create expr + let e = create' expr case runTypecheckTestM NoSmartHoles (synth e) of Left err -> assertFailure $ show err Right (_, exprT) -> case path $ focus $ exprTtoExpr exprT of @@ -249,7 +249,7 @@ hasVariables expr path expected = do -- | Like 'hasVariables' but for type variables inside terms also hasVariablesTyTm :: S Expr -> (ExprZ -> Maybe ExprZ) -> [(TyVarName, Kind)] -> [(LVarName, Type' ())] -> Assertion hasVariablesTyTm expr path expectedTy expectedTm = do - let e = fst $ create expr + let e = create' expr case runTypecheckTestM NoSmartHoles (synth e) of Left err -> assertFailure $ show err Right (_, exprT) -> case path $ focus $ exprTtoExpr exprT of @@ -262,7 +262,7 @@ hasVariablesTyTm expr path expectedTy expectedTm = do -- | Like 'hasVariables' but for types hasVariablesType :: S Type -> (TypeZip -> Maybe TypeZip) -> [(TyVarName, Kind)] -> Assertion hasVariablesType ty path expected = do - let t = fst $ create ty + let t = create' ty case path $ focus t of Just z -> variablesInScopeTy z @?= expected Nothing -> assertFailure "" @@ -304,14 +304,14 @@ defCxt = buildTypingContextFromModules [builtinModule] NoSmartHoles hasGeneratedNamesExpr :: S Expr -> Maybe (S Type) -> (ExprZ -> Maybe ExprZ) -> [Name] -> Assertion hasGeneratedNamesExpr expr ty path expected = do - let (e, t) = fst . create $ (,) <$> expr <*> sequence ty + let (e, t) = create' $ (,) <$> expr <*> sequence ty case path $ focus e of Just z -> runReader (generateNameExpr (Left $ fmap forgetTypeIDs t) (Left z)) defCxt @?= expected Nothing -> assertFailure "" hasGeneratedNamesTy :: S Type -> Maybe Kind -> (TypeZip -> Maybe TypeZip) -> [Name] -> Assertion hasGeneratedNamesTy ty k path expected = do - let t = fst $ create ty + let t = create' ty case path $ focus t of Just z -> runReader (generateNameTy (Right k) z) defCxt @?= expected Nothing -> assertFailure "" diff --git a/primer/test/Tests/Subst.hs b/primer/test/Tests/Subst.hs index e2ba4d1e6..1705e2841 100644 --- a/primer/test/Tests/Subst.hs +++ b/primer/test/Tests/Subst.hs @@ -16,30 +16,30 @@ import TestM (evalTestM) unit_1 :: Assertion unit_1 = - create' (tcon tBool) + create_ (tcon tBool) @=? substTy' "a" - (create' $ tcon tBool) - (create' $ tvar "a") + (create_ $ tcon tBool) + (create_ $ tvar "a") unit_2 :: Assertion unit_2 = - create' (tforall "a" KType $ tvar "a") + create_ (tforall "a" KType $ tvar "a") @=? substTy' "a" - (create' $ tcon tBool) - (create' $ tforall "a" KType $ tvar "a") + (create_ $ tcon tBool) + (create_ $ tforall "a" KType $ tvar "a") unit_3 :: Assertion unit_3 = - create' (tforall "b" KType $ tcon tList `tapp` tcon tBool) + create_ (tforall "b" KType $ tcon tList `tapp` tcon tBool) @=? substTy' "a" - (create' $ tcon tBool) - (create' $ tforall "b" KType $ tcon tList `tapp` tvar "a") + (create_ $ tcon tBool) + (create_ $ tforall "b" KType $ tcon tList `tapp` tvar "a") -create' :: S (Type' a) -> Type' () -create' = forgetTypeIDs . fst . create +create_ :: S (Type' a) -> Type' () +create_ = forgetTypeIDs . create' substTy' :: TyVarName -> Type' () -> Type' () -> Type' () substTy' n s t = evalTestM 0 $ substTy n s t diff --git a/primer/test/Tests/Transform.hs b/primer/test/Tests/Transform.hs index eb97bf229..c32d93070 100644 --- a/primer/test/Tests/Transform.hs +++ b/primer/test/Tests/Transform.hs @@ -249,12 +249,12 @@ afterRename' :: Maybe (S a) -> Assertion afterRename' rename normalise fromVar toVar input output = do - let (x, _) = create input + let x = create' input result = rename fromVar toVar x case output of Nothing -> result @?= Nothing Just o -> do - let (expected, _) = create o + let expected = create' o case result of Nothing -> assertFailure "rename failed" Just r -> on (@?=) normalise r expected From 7ab2b3786f1ac66a0e56bfc9a67f140051dbd3eb Mon Sep 17 00:00:00 2001 From: Drew Hess Date: Mon, 30 May 2022 19:45:29 +0100 Subject: [PATCH 3/5] refactor: add a `mkSimpleModuleName` helper function. This doesn't save much typing, but the `NonEmptyList` constructor name is annoyingly hard to remember. --- primer-rel8/test/TestUtils.hs | 6 +++--- primer-service/src/Primer/Server.hs | 6 +++--- primer/src/Primer/App.hs | 9 +++++---- primer/src/Primer/Builtins.hs | 5 +++-- primer/src/Primer/Core.hs | 9 +++++++-- primer/src/Primer/Examples.hs | 4 ++-- primer/src/Primer/Primitives.hs | 5 +++-- 7 files changed, 26 insertions(+), 18 deletions(-) diff --git a/primer-rel8/test/TestUtils.hs b/primer-rel8/test/TestUtils.hs index 56374c0da..dcbb9da97 100644 --- a/primer-rel8/test/TestUtils.hs +++ b/primer-rel8/test/TestUtils.hs @@ -66,7 +66,7 @@ import Primer.Core ( GlobalName (baseName), ID, Kind (KType), - ModuleName (ModuleName), + mkSimpleModuleName, qualifyName, ) import Primer.Core.DSL ( @@ -248,7 +248,7 @@ insertSessionRow row conn = testASTDef :: ASTDef testASTDefNextID :: ID (testASTDef, testASTDefNextID) = - mkASTDef (qualifyName (ModuleName $ "TestModule" :| []) "1") t e + mkASTDef (qualifyName (mkSimpleModuleName "TestModule") "1") t e where t = tfun @@ -360,7 +360,7 @@ testApp = { progImports = [builtinModule, primitiveModule] , progModules = [ Module - { moduleName = ModuleName $ "TestModule" :| [] + { moduleName = mkSimpleModuleName "TestModule" , moduleTypes = mempty , moduleDefs = Map.singleton (baseName $ astDefName testASTDef) (DefAST testASTDef) } diff --git a/primer-service/src/Primer/Server.hs b/primer-service/src/Primer/Server.hs index 8518d758f..f130f939c 100644 --- a/primer-service/src/Primer/Server.hs +++ b/primer-service/src/Primer/Server.hs @@ -76,12 +76,12 @@ import Primer.Core ( ID, Kind (KFun, KType), LVarName, - ModuleName (ModuleName), TyVarName, Type, Type' (TEmptyHole), TypeCache (..), TypeCacheBoth (..), + mkSimpleModuleName, qualifyName, ) import Primer.Core.DSL ( @@ -344,9 +344,9 @@ testEndpoints = :<|> mkTest 0 :<|> mkTest (Log [[BodyAction [Move Child1]]]) :<|> mkTest newProg - :<|> mkTest (MoveToDef $ qualifyName (ModuleName $ "M" :| []) "main") + :<|> mkTest (MoveToDef $ qualifyName (mkSimpleModuleName "M") "main") :<|> mkTest NoDefSelected - :<|> mkTest (DefAST $ ASTDef (qualifyName (ModuleName $ "M" :| []) "main") expr ty) + :<|> mkTest (DefAST $ ASTDef (qualifyName (mkSimpleModuleName "M") "main") expr ty) :<|> mkTest boolDef :<|> mkTest EvalReq{evalReqExpr = expr, evalReqRedex = 0} :<|> mkTest EvalResp{evalRespExpr = expr, evalRespRedexes = [0, 1], evalRespDetail = reductionDetail} diff --git a/primer/src/Primer/App.hs b/primer/src/Primer/App.hs index b6d85ba3c..a79fea18e 100644 --- a/primer/src/Primer/App.hs +++ b/primer/src/Primer/App.hs @@ -118,6 +118,7 @@ import Primer.Core ( defName, defPrim, getID, + mkSimpleModuleName, qualifyName, typeDefAST, typesInExpr, @@ -997,12 +998,12 @@ newEmptyProg :: Prog newEmptyProg = let expr = EmptyHole (Meta 1 Nothing Nothing) ty = TEmptyHole (Meta 2 Nothing Nothing) - def = DefAST $ ASTDef (qualifyName (ModuleName $ "Main" :| []) "main") expr ty + def = DefAST $ ASTDef (qualifyName (mkSimpleModuleName "Main") "main") expr ty in Prog { progImports = mempty , progModules = [ Module - { moduleName = ModuleName $ "Main" :| [] + { moduleName = mkSimpleModuleName "Main" , moduleTypes = mempty , moduleDefs = Map.singleton (baseName $ defName def) def } @@ -1029,9 +1030,9 @@ newProg = { progImports = [builtinModule, primitiveModule] , progModules = [ Module - { moduleName = ModuleName $ "Main" :| [] + { moduleName = mkSimpleModuleName "Main" , moduleTypes = mempty - , moduleDefs = defaultDefs $ ModuleName $ "Main" :| [] + , moduleDefs = defaultDefs $ mkSimpleModuleName "Main" } ] } diff --git a/primer/src/Primer/Builtins.hs b/primer/src/Primer/Builtins.hs index 2fd2839cb..30ff05557 100644 --- a/primer/src/Primer/Builtins.hs +++ b/primer/src/Primer/Builtins.hs @@ -41,19 +41,20 @@ import Primer.Core ( ), GlobalName, Kind (KType), - ModuleName (ModuleName), + ModuleName, TyConName, Type' (TApp, TCon, TVar), TypeDef (TypeDefAST), ValCon (ValCon), ValConName, + mkSimpleModuleName, qualifyName, ) import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), mkTypeDefMap) import Primer.Name (Name) builtinModuleName :: ModuleName -builtinModuleName = ModuleName $ "Builtins" :| [] +builtinModuleName = mkSimpleModuleName "Builtins" builtin :: Name -> GlobalName k builtin = qualifyName builtinModuleName diff --git a/primer/src/Primer/Core.hs b/primer/src/Primer/Core.hs index 63b7fb366..34472daf2 100644 --- a/primer/src/Primer/Core.hs +++ b/primer/src/Primer/Core.hs @@ -24,6 +24,7 @@ module Primer.Core ( HasMetadata (_metadata), ID (ID), ModuleName (ModuleName, unModuleName), + mkSimpleModuleName, moduleNamePretty, GlobalNameKind (..), GlobalName (qualifiedModule, baseName), @@ -169,6 +170,10 @@ newtype ModuleName = ModuleName {unModuleName :: NonEmpty Name} deriving (Eq, Ord, Show, Data, Generic) deriving (FromJSON, ToJSON) via NonEmpty Name +-- | Helper function for simple (non-hierarchical) module names. +mkSimpleModuleName :: Name -> ModuleName +mkSimpleModuleName n = ModuleName $ n :| [] + moduleNamePretty :: ModuleName -> Text moduleNamePretty = mconcat . intersperse "." . toList . fmap unName . unModuleName @@ -529,8 +534,8 @@ data PrimCon -- This should be a key in `allPrimTypeDefs`. primConName :: PrimCon -> TyConName primConName = \case - PrimChar _ -> qualifyName (ModuleName $ "Primitives" :| []) "Char" - PrimInt _ -> qualifyName (ModuleName $ "Primitives" :| []) "Int" + PrimChar _ -> qualifyName (mkSimpleModuleName "Primitives") "Char" + PrimInt _ -> qualifyName (mkSimpleModuleName "Primitives") "Int" data PrimFun = PrimFun { primFunTypes :: forall m. MonadFresh ID m => m ([Type], Type) diff --git a/primer/src/Primer/Examples.hs b/primer/src/Primer/Examples.hs index cf43638ce..7303c43eb 100644 --- a/primer/src/Primer/Examples.hs +++ b/primer/src/Primer/Examples.hs @@ -36,7 +36,7 @@ import Primer.Core ( GlobalName, ID, Kind (KType), - ModuleName (ModuleName), + mkSimpleModuleName, qualifyName, ) import Primer.Core.DSL ( @@ -59,7 +59,7 @@ import Primer.Core.DSL ( import Primer.Name (Name) qn :: Name -> GlobalName k -qn = qualifyName (ModuleName $ "Examples" :| []) +qn = qualifyName $ mkSimpleModuleName "Examples" -- | The polymorphic function @map@ (over @List a@ as defined by -- 'listDef'). diff --git a/primer/src/Primer/Primitives.hs b/primer/src/Primer/Primitives.hs index e51b72aa9..cc4622911 100644 --- a/primer/src/Primer/Primitives.hs +++ b/primer/src/Primer/Primitives.hs @@ -28,7 +28,7 @@ import Primer.Core ( Expr' (App, Con, PrimCon), GVarName, GlobalName (baseName), - ModuleName (ModuleName), + ModuleName, PrimCon (..), PrimDef (PrimDef, primDefName, primDefType), PrimFun (..), @@ -36,6 +36,7 @@ import Primer.Core ( PrimTypeDef (..), TyConName, TypeDef (TypeDefPrim), + mkSimpleModuleName, primFunType, qualifyName, ) @@ -56,7 +57,7 @@ import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes)) import Primer.Name (Name) primitiveModuleName :: ModuleName -primitiveModuleName = ModuleName $ "Primitives" :| [] +primitiveModuleName = mkSimpleModuleName "Primitives" primitive :: Name -> GlobalName k primitive = qualifyName primitiveModuleName From 05f39240e880cce4fc71b715be36e252213ffa04 Mon Sep 17 00:00:00 2001 From: Drew Hess Date: Mon, 30 May 2022 23:59:01 +0100 Subject: [PATCH 4/5] feat: Module-retargetable example functions. We parameterize the `Primer.Examples` functions over module names, to make them easier to reuse in tests, example DSL programs, etc. --- primer/src/Primer/Examples.hs | 40 ++++++++++++++++------------------- primer/test/Tests/EvalFull.hs | 26 +++++++++++++---------- 2 files changed, 33 insertions(+), 33 deletions(-) diff --git a/primer/src/Primer/Examples.hs b/primer/src/Primer/Examples.hs index 7303c43eb..87d4cbffe 100644 --- a/primer/src/Primer/Examples.hs +++ b/primer/src/Primer/Examples.hs @@ -14,8 +14,9 @@ module Primer.Examples ( -- * Functions as top-level definitions. - -- - -- These live in the Primer module named @Examples@. + -- | In Primer, top-level definitions names must be qualified by + -- their module name. These examples take a 'ModuleName' so that the + -- 'Def's they return can be resued in multiple contexts. map, map', even, @@ -33,10 +34,9 @@ import qualified Primer.Builtins as B import Primer.Core ( ASTDef (ASTDef), Def (DefAST), - GlobalName, ID, Kind (KType), - mkSimpleModuleName, + ModuleName, qualifyName, ) import Primer.Core.DSL ( @@ -56,16 +56,12 @@ import Primer.Core.DSL ( tfun, tvar, ) -import Primer.Name (Name) - -qn :: Name -> GlobalName k -qn = qualifyName $ mkSimpleModuleName "Examples" -- | The polymorphic function @map@ (over @List a@ as defined by -- 'listDef'). -map :: MonadFresh ID m => m Def -map = - let this = qn "map" +map :: MonadFresh ID m => ModuleName -> m Def +map modName = + let this = qualifyName modName "map" in do type_ <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon B.tList `tapp` tvar "a") `tfun` (tcon B.tList `tapp` tvar "b")) term <- @@ -84,8 +80,8 @@ map = -- | The polymorphic function @map@ (over @List a@ as defined by -- 'listDef'), implemented using a worker. -map' :: MonadFresh ID m => m Def -map' = do +map' :: MonadFresh ID m => ModuleName -> m Def +map' modName = do type_ <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon B.tList `tapp` tvar "a") `tfun` (tcon B.tList `tapp` tvar "b")) let worker = lam "xs" $ @@ -101,36 +97,36 @@ map' = do lam "f" $ letrec "go" worker ((tcon B.tList `tapp` tvar "a") `tfun` (tcon B.tList `tapp` tvar "b")) $ lvar "go" - pure $ DefAST $ ASTDef (qn "map'") term type_ + pure $ DefAST $ ASTDef (qualifyName modName "map'") term type_ -- | The function @odd@, defined over the inductive natural number -- type @Natural@ as defined by 'natDef'. -- -- Note that this function is mutually recursive on @even@. -odd :: MonadFresh ID m => m Def -odd = do +odd :: MonadFresh ID m => ModuleName -> m Def +odd modName = do type_ <- tcon B.tNat `tfun` tcon B.tBool term <- lam "x" $ case_ (lvar "x") [ branch B.cZero [] $ con B.cFalse - , branch B.cSucc [("n", Nothing)] $ gvar (qn "even") `app` lvar "n" + , branch B.cSucc [("n", Nothing)] $ gvar (qualifyName modName "even") `app` lvar "n" ] - pure $ DefAST $ ASTDef (qn "odd") term type_ + pure $ DefAST $ ASTDef (qualifyName modName "odd") term type_ -- | The function @even@, defined over the inductive natural number -- type @Natural@ as defined by 'natDef'. -- -- Note that this function is mutually recursive on @odd@. -even :: MonadFresh ID m => m Def -even = do +even :: MonadFresh ID m => ModuleName -> m Def +even modName = do type_ <- tcon B.tNat `tfun` tcon B.tBool term <- lam "x" $ case_ (lvar "x") [ branch B.cZero [] $ con B.cTrue - , branch B.cSucc [("n", Nothing)] $ gvar (qn "odd") `app` lvar "n" + , branch B.cSucc [("n", Nothing)] $ gvar (qualifyName modName "odd") `app` lvar "n" ] - pure $ DefAST $ ASTDef (qn "even") term type_ + pure $ DefAST $ ASTDef (qualifyName modName "even") term type_ diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs index e34d3113d..daff4ac1a 100644 --- a/primer/test/Tests/EvalFull.hs +++ b/primer/test/Tests/EvalFull.hs @@ -154,10 +154,11 @@ unit_7 = unit_8 :: Assertion unit_8 = let n = 10 + modName = mkSimpleModuleName "TestModule" ((globals, e, expected), maxID) = create $ do - mapDef <- Examples.map - evenDef <- Examples.even - oddDef <- Examples.odd + mapDef <- Examples.map modName + evenDef <- Examples.even modName + oddDef <- Examples.odd modName let lst = list_ tNat $ take n $ iterate (con cSucc `app`) (con cZero) let mapName = defName mapDef let evenName = defName evenDef @@ -178,10 +179,11 @@ unit_8 = unit_9 :: Assertion unit_9 = let n = 10 + modName = mkSimpleModuleName "TestModule" ((globals, e, expected), maxID) = create $ do - mapDef <- Examples.map' - evenDef <- Examples.even - oddDef <- Examples.odd + mapDef <- Examples.map' modName + evenDef <- Examples.even modName + oddDef <- Examples.odd modName let lst = list_ tNat $ take n $ iterate (con cSucc `app`) (con cZero) let mapName = defName mapDef let evenName = defName evenDef @@ -231,9 +233,10 @@ unit_10 = -- substitute, otherwise we may go down a rabbit hole! unit_11 :: Assertion unit_11 = - let ((globals, e, expected), maxID) = create $ do - evenDef <- Examples.even - oddDef <- Examples.odd + let modName = mkSimpleModuleName "TestModule" + ((globals, e, expected), maxID) = create $ do + evenDef <- Examples.even modName + oddDef <- Examples.odd modName let evenName = defName evenDef let oddName = defName oddDef let ty = tcon tNat `tfun` (tcon tPair `tapp` tcon tBool `tapp` tcon tNat) @@ -1002,9 +1005,10 @@ unit_prim_ann = unit_prim_partial_map :: Assertion unit_prim_partial_map = - let ((e, r, gs), maxID) = + let modName = mkSimpleModuleName "TestModule" + ((e, r, gs), maxID) = create . withPrimDefs $ \globals -> do - mapDef <- Examples.map' + mapDef <- Examples.map' modName let mapName = defName mapDef (,,) <$> gvar mapName From b93078f9ad33a9f95b9f9387008700991c33b4b9 Mon Sep 17 00:00:00 2001 From: Drew Hess Date: Mon, 6 Jun 2022 12:19:02 +0100 Subject: [PATCH 5/5] refactor: Create a comprehensive example AST and DRY. Previously, we used this test definition verbatim in 2 different places. --- primer-rel8/test/TestUtils.hs | 193 +++--------------- primer/src/Primer/Examples.hs | 111 +++++++++- primer/test/Tests/Action/Available.hs | 136 +----------- .../Beginner.fragment | 94 ++++----- .../{M.1 => M.comprehensive}/Expert.fragment | 94 ++++----- .../Intermediate.fragment | 94 ++++----- weeder.dhall | 7 +- 7 files changed, 290 insertions(+), 439 deletions(-) rename primer/test/outputs/available-actions/{M.1 => M.comprehensive}/Beginner.fragment (100%) rename primer/test/outputs/available-actions/{M.1 => M.comprehensive}/Expert.fragment (100%) rename primer/test/outputs/available-actions/{M.1 => M.comprehensive}/Intermediate.fragment (100%) diff --git a/primer-rel8/test/TestUtils.hs b/primer-rel8/test/TestUtils.hs index dcbb9da97..134856910 100644 --- a/primer-rel8/test/TestUtils.hs +++ b/primer-rel8/test/TestUtils.hs @@ -46,61 +46,19 @@ import Primer.App ( newEmptyApp, newEmptyProg, ) -import Primer.Builtins ( - builtinModule, - cFalse, - cJust, - cLeft, - cSucc, - cTrue, - cZero, - tBool, - tEither, - tList, - tMaybe, - tNat, - ) +import Primer.Builtins (builtinModule) import Primer.Core ( - ASTDef (..), - Def (DefAST), - GlobalName (baseName), - ID, - Kind (KType), + baseName, + defName, mkSimpleModuleName, - qualifyName, - ) -import Primer.Core.DSL ( - aPP, - ann, - app, - branch, - case_, - con, - emptyHole, - gvar', - hole, - lAM, - lam, - letType, - let_, - letrec, - lvar, - tEmptyHole, - tapp, - tcon, - tforall, - tfun, - thole, - tvar, - ) -import Primer.Core.Utils ( - mkASTDef, ) +import Primer.Core.DSL (create) import Primer.Database.Rel8.Rel8Db ( Rel8Db, runRel8Db, ) import Primer.Database.Rel8.Schema as Schema hiding (app) +import Primer.Examples (comprehensive) import Primer.Module ( Module ( Module, @@ -239,130 +197,27 @@ insertSessionRow row conn = , returning = NumberOfRowsAffected } --- | This definition contains most of the non-primitive constructs in --- the Primer language. --- --- TODO: this is identical to a program in the core Primer test suite, --- so it should be refactored into a common test library. See: --- https://github.com/hackworthltd/primer/issues/273 -testASTDef :: ASTDef -testASTDefNextID :: ID -(testASTDef, testASTDefNextID) = - mkASTDef (qualifyName (mkSimpleModuleName "TestModule") "1") t e - where - t = - tfun - (tcon tNat) - ( tforall - "a" - KType - ( tapp - ( thole - ( tapp - (tcon tList) - tEmptyHole - ) - ) - (tvar "a") - ) - ) - e = - let_ - "x" - (con cTrue) - ( letrec - "y" - ( app - ( hole - (con cJust) - ) - ( hole - (gvar' ("TestModule" :| []) "0") - ) - ) - ( thole - (tcon tMaybe) - ) - ( ann - ( lam - "i" - ( lAM - "β" - ( app - ( aPP - ( letType - "b" - (tcon tBool) - ( aPP - (con cLeft) - (tvar "b") - ) - ) - (tvar "β") - ) - ( case_ - (lvar "i") - [ branch - cZero - [] - (con cFalse) - , branch - cSucc - [ - ( "n" - , Nothing - ) - ] - ( app - ( app - emptyHole - (lvar "x") - ) - (lvar "y") - ) - ] - ) - ) - ) - ) - ( tfun - (tcon tNat) - ( tforall - "α" - KType - ( tapp - ( tapp - (tcon tEither) - (tcon tBool) - ) - (tvar "α") - ) - ) - ) - ) - ) - -- | An initial test 'App' instance that contains all default type -- definitions (including primitive types), all primitive functions, --- and a top-level definition that contains most of the non-primitive --- constructs in the Primer language.x +-- and a top-level definition with extensive coverage of Primer's +-- core language. testApp :: App testApp = - newEmptyApp - { appProg = testProg - , appInit = NewApp - , appIdCounter = fromEnum testASTDefNextID - } - where - testProg :: Prog - testProg = - newEmptyProg - { progImports = [builtinModule, primitiveModule] - , progModules = - [ Module - { moduleName = mkSimpleModuleName "TestModule" - , moduleTypes = mempty - , moduleDefs = Map.singleton (baseName $ astDefName testASTDef) (DefAST testASTDef) - } - ] + let modName = mkSimpleModuleName "TestModule" + (def, id_) = create $ comprehensive modName + testProg = + newEmptyProg + { progImports = [builtinModule, primitiveModule] + , progModules = + [ Module + { moduleName = mkSimpleModuleName "TestModule" + , moduleTypes = mempty + , moduleDefs = Map.singleton (baseName $ defName def) def + } + ] + } + in newEmptyApp + { appProg = testProg + , appInit = NewApp + , appIdCounter = fromEnum id_ } diff --git a/primer/src/Primer/Examples.hs b/primer/src/Primer/Examples.hs index 87d4cbffe..f0636aa3f 100644 --- a/primer/src/Primer/Examples.hs +++ b/primer/src/Primer/Examples.hs @@ -21,6 +21,7 @@ module Primer.Examples ( map', even, odd, + comprehensive, ) where import Foreword hiding ( @@ -36,24 +37,32 @@ import Primer.Core ( Def (DefAST), ID, Kind (KType), - ModuleName, + ModuleName (unModuleName), qualifyName, ) import Primer.Core.DSL ( aPP, + ann, app, branch, case_, con, + emptyHole, gvar, + gvar', + hole, lAM, lam, + letType, + let_, letrec, lvar, + tEmptyHole, tapp, tcon, tforall, tfun, + thole, tvar, ) @@ -130,3 +139,103 @@ even modName = do , branch B.cSucc [("n", Nothing)] $ gvar (qualifyName modName "odd") `app` lvar "n" ] pure $ DefAST $ ASTDef (qualifyName modName "even") term type_ + +-- | A comprehensive 'Def' containing most of the non-primitive +-- built-in constructs in Primer. +-- +-- Note that this 'Def' is nonsensical and is provided only for +-- language coverage. +comprehensive :: MonadFresh ID m => ModuleName -> m Def +comprehensive modName = do + type_ <- + tfun + (tcon B.tNat) + ( tforall + "a" + KType + ( tapp + ( thole + ( tapp + (tcon B.tList) + tEmptyHole + ) + ) + (tvar "a") + ) + ) + term <- + let_ + "x" + (con B.cTrue) + ( letrec + "y" + ( app + ( hole + (con B.cJust) + ) + ( hole + (gvar' (unModuleName modName) "unboundName") + ) + ) + ( thole + (tcon B.tMaybe) + ) + ( ann + ( lam + "i" + ( lAM + "β" + ( app + ( aPP + ( letType + "b" + (tcon B.tBool) + ( aPP + (con B.cLeft) + (tvar "b") + ) + ) + (tvar "β") + ) + ( case_ + (lvar "i") + [ branch + B.cZero + [] + (con B.cFalse) + , branch + B.cSucc + [ + ( "n" + , Nothing + ) + ] + ( app + ( app + emptyHole + (lvar "x") + ) + (lvar "y") + ) + ] + ) + ) + ) + ) + ( tfun + (tcon B.tNat) + ( tforall + "α" + KType + ( tapp + ( tapp + (tcon B.tEither) + (tcon B.tBool) + ) + (tvar "α") + ) + ) + ) + ) + ) + pure $ DefAST $ ASTDef (qualifyName modName "comprehensive") term type_ diff --git a/primer/test/Tests/Action/Available.hs b/primer/test/Tests/Action/Available.hs index 9b997763a..7e1d2a9de 100644 --- a/primer/test/Tests/Action/Available.hs +++ b/primer/test/Tests/Action/Available.hs @@ -6,150 +6,35 @@ import qualified Data.ByteString.Lazy.Char8 as BS import Data.List.Extra (enumerate) import qualified Data.Text as T import qualified Data.Text.Lazy as TL +import GHC.Err (error) import Optics (toListOf, (%)) import Primer.Action (ActionName (..), OfferedAction (name)) import Primer.Action.Available (actionsForDef, actionsForDefBody, actionsForDefSig) -import Primer.Builtins import Primer.Core ( ASTDef (..), + Def (DefAST, DefPrim), GlobalName (baseName, qualifiedModule), HasID (_id), ID, - Kind (KType), + mkSimpleModuleName, moduleNamePretty, _typeMeta, ) import Primer.Core.DSL ( - aPP, - ann, - app, - branch, - case_, - con, - emptyHole, - gvar', - hole, - lAM, - lam, - letType, - let_, - letrec, - lvar, - tEmptyHole, - tapp, - tcon, - tforall, - tfun, - thole, - tvar, - ) -import Primer.Core.Utils ( - mkASTDef, + create', ) +import Primer.Examples (comprehensive) import Primer.Name (Name (unName)) import System.FilePath (()) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (goldenVsString) import Test.Tasty.HUnit () -import TestUtils (exprIDs, gvn) +import TestUtils (exprIDs) import Text.Pretty.Simple (pShowNoColor) --- | This definition contains most constructs in the Primer language. +-- | Comprehensive DSL test. test_1 :: TestTree -test_1 = - mkTests $ fst $ mkASTDef (gvn ["M"] "1") t e - where - t = - tfun - (tcon tNat) - ( tforall - "a" - KType - ( tapp - ( thole - ( tapp - (tcon tList) - tEmptyHole - ) - ) - (tvar "a") - ) - ) - e = - let_ - "x" - (con cTrue) - ( letrec - "y" - ( app - ( hole - (con cJust) - ) - ( hole - (gvar' ["M"] "0") - ) - ) - ( thole - (tcon tMaybe) - ) - ( ann - ( lam - "i" - ( lAM - "β" - ( app - ( aPP - ( letType - "b" - (tcon tBool) - ( aPP - (con cLeft) - (tvar "b") - ) - ) - (tvar "β") - ) - ( case_ - (lvar "i") - [ branch - cZero - [] - (con cFalse) - , branch - cSucc - [ - ( "n" - , Nothing - ) - ] - ( app - ( app - emptyHole - (lvar "x") - ) - (lvar "y") - ) - ] - ) - ) - ) - ) - ( tfun - (tcon tNat) - ( tforall - "α" - KType - ( tapp - ( tapp - (tcon tEither) - (tcon tBool) - ) - (tvar "α") - ) - ) - ) - ) - ) +test_1 = mkTests $ create' $ comprehensive $ mkSimpleModuleName "M" data Output = Output { defActions :: [ActionName] @@ -159,8 +44,9 @@ data Output = Output deriving (Show) -- | Golden tests for the available actions at each node of the definition, for each level. -mkTests :: ASTDef -> TestTree -mkTests def = +mkTests :: Def -> TestTree +mkTests (DefPrim _) = error "mkTests is unimplemented for primitive definitions." +mkTests (DefAST def) = let defName = astDefName def testName = T.unpack $ moduleNamePretty (qualifiedModule defName) <> "." <> unName (baseName defName) in testGroup testName $ diff --git a/primer/test/outputs/available-actions/M.1/Beginner.fragment b/primer/test/outputs/available-actions/M.comprehensive/Beginner.fragment similarity index 100% rename from primer/test/outputs/available-actions/M.1/Beginner.fragment rename to primer/test/outputs/available-actions/M.comprehensive/Beginner.fragment index 932f4d8a9..fcbf4da4f 100644 --- a/primer/test/outputs/available-actions/M.1/Beginner.fragment +++ b/primer/test/outputs/available-actions/M.comprehensive/Beginner.fragment @@ -6,7 +6,7 @@ Output ] , bodyActions = [ - ( 0 + ( 9 , [ Code "λx" , Code "m" @@ -16,7 +16,7 @@ Output ] ) , - ( 1 + ( 10 , [ Code "λx" , Code "m" @@ -25,7 +25,7 @@ Output ] ) , - ( 2 + ( 11 , [ Code "λx" , Code "m" @@ -35,7 +35,7 @@ Output ] ) , - ( 3 + ( 12 , [ Code "λx" , Code "m" @@ -44,7 +44,7 @@ Output ] ) , - ( 4 + ( 13 , [ Code "λx" , Code "m" @@ -54,7 +54,7 @@ Output ] ) , - ( 5 + ( 14 , [ Code "λx" , Code "m" @@ -62,7 +62,7 @@ Output ] ) , - ( 6 + ( 15 , [ Code "λx" , Code "m" @@ -72,7 +72,7 @@ Output ] ) , - ( 7 + ( 16 , [ Code "λx" , Code "m" @@ -80,7 +80,7 @@ Output ] ) , - ( 10 + ( 19 , [ Code "λx" , Code "m" @@ -89,7 +89,7 @@ Output ] ) , - ( 11 + ( 20 , [ Code "λx" , Code "m" @@ -99,7 +99,7 @@ Output ] ) , - ( 12 + ( 21 , [ Code "λx" , Code "m" @@ -108,7 +108,7 @@ Output ] ) , - ( 13 + ( 22 , [ Code "λx" , Code "m" @@ -117,7 +117,7 @@ Output ] ) , - ( 14 + ( 23 , [ Code "λx" , Code "m" @@ -126,7 +126,7 @@ Output ] ) , - ( 15 + ( 24 , [ Code "λx" , Code "m" @@ -135,7 +135,7 @@ Output ] ) , - ( 17 + ( 26 , [ Code "λx" , Code "m" @@ -144,7 +144,7 @@ Output ] ) , - ( 18 + ( 27 , [ Code "λx" , Code "m" @@ -153,7 +153,7 @@ Output ] ) , - ( 21 + ( 30 , [ Code "λx" , Code "m" @@ -162,7 +162,7 @@ Output ] ) , - ( 22 + ( 31 , [ Code "λx" , Code "m" @@ -171,7 +171,7 @@ Output ] ) , - ( 23 + ( 32 , [ Code "λx" , Code "m" @@ -180,12 +180,12 @@ Output ] ) , - ( 24 + ( 33 , [ Prose "r" ] ) , - ( 25 + ( 34 , [ Code "λx" , Code "m" @@ -194,7 +194,7 @@ Output ] ) , - ( 26 + ( 35 , [ Code "λx" , Code "m" @@ -203,7 +203,7 @@ Output ] ) , - ( 27 + ( 36 , [ Code "λx" , Code "m" @@ -213,7 +213,7 @@ Output ] ) , - ( 28 + ( 37 , [ Code "λx" , Code "m" @@ -222,7 +222,7 @@ Output ] ) , - ( 29 + ( 38 , [ Code "λx" , Code "m" @@ -231,14 +231,14 @@ Output ] ) , - ( 8 + ( 17 , [ Code "→" , Prose "⌫" ] ) , - ( 9 + ( 18 , [ Code "→" , Prose "⌫" @@ -246,28 +246,28 @@ Output ] ) , - ( 16 + ( 25 , [ Code "→" , Prose "⌫" ] ) , - ( 19 + ( 28 , [ Code "→" , Prose "⌫" ] ) , - ( 20 + ( 29 , [ Code "→" , Prose "⌫" ] ) , - ( 30 + ( 39 , [ Code "→" , Prose "⌫" @@ -275,7 +275,7 @@ Output ] ) , - ( 31 + ( 40 , [ Code "→" , Prose "⌫" @@ -283,7 +283,7 @@ Output ] ) , - ( 32 + ( 41 , [ Code "→" , Prose "⌫" @@ -291,7 +291,7 @@ Output ] ) , - ( 33 + ( 42 , [ Code "→" , Prose "⌫" @@ -299,7 +299,7 @@ Output ] ) , - ( 34 + ( 43 , [ Code "→" , Prose "⌫" @@ -307,7 +307,7 @@ Output ] ) , - ( 35 + ( 44 , [ Code "→" , Prose "⌫" @@ -315,7 +315,7 @@ Output ] ) , - ( 36 + ( 45 , [ Code "→" , Prose "⌫" @@ -323,7 +323,7 @@ Output ] ) , - ( 37 + ( 46 , [ Code "→" , Prose "⌫" @@ -333,7 +333,7 @@ Output ] , sigActions = [ - ( 38 + ( 0 , [ Code "→" , Prose "⌫" @@ -341,7 +341,7 @@ Output ] ) , - ( 39 + ( 1 , [ Code "→" , Prose "⌫" @@ -349,7 +349,7 @@ Output ] ) , - ( 40 + ( 2 , [ Code "→" , Prose "⌫" @@ -357,7 +357,7 @@ Output ] ) , - ( 41 + ( 3 , [ Code "→" , Prose "⌫" @@ -365,7 +365,7 @@ Output ] ) , - ( 42 + ( 4 , [ Code "→" , Prose "⌫" @@ -373,7 +373,7 @@ Output ] ) , - ( 43 + ( 5 , [ Code "→" , Prose "⌫" @@ -381,7 +381,7 @@ Output ] ) , - ( 44 + ( 6 , [ Code "→" , Prose "⌫" @@ -389,7 +389,7 @@ Output ] ) , - ( 45 + ( 7 , [ Code "→" , Code "T" @@ -397,7 +397,7 @@ Output ] ) , - ( 46 + ( 8 , [ Code "→" , Prose "⌫" diff --git a/primer/test/outputs/available-actions/M.1/Expert.fragment b/primer/test/outputs/available-actions/M.comprehensive/Expert.fragment similarity index 100% rename from primer/test/outputs/available-actions/M.1/Expert.fragment rename to primer/test/outputs/available-actions/M.comprehensive/Expert.fragment index 6a8968c69..61ee4e4e5 100644 --- a/primer/test/outputs/available-actions/M.1/Expert.fragment +++ b/primer/test/outputs/available-actions/M.comprehensive/Expert.fragment @@ -6,7 +6,7 @@ Output ] , bodyActions = [ - ( 0 + ( 9 , [ Code ":" , Code "$" @@ -20,7 +20,7 @@ Output ] ) , - ( 1 + ( 10 , [ Code ":" , Code "$" @@ -33,7 +33,7 @@ Output ] ) , - ( 2 + ( 11 , [ Code ":" , Code "$" @@ -47,7 +47,7 @@ Output ] ) , - ( 3 + ( 12 , [ Code ":" , Code "$" @@ -60,7 +60,7 @@ Output ] ) , - ( 4 + ( 13 , [ Code ":" , Code "$" @@ -74,7 +74,7 @@ Output ] ) , - ( 5 + ( 14 , [ Code ":" , Code "$" @@ -86,7 +86,7 @@ Output ] ) , - ( 6 + ( 15 , [ Code ":" , Code "$" @@ -100,7 +100,7 @@ Output ] ) , - ( 7 + ( 16 , [ Code ":" , Code "$" @@ -112,7 +112,7 @@ Output ] ) , - ( 10 + ( 19 , [ Code ":" , Code "$" @@ -126,7 +126,7 @@ Output ] ) , - ( 11 + ( 20 , [ Code ":" , Code "$" @@ -140,7 +140,7 @@ Output ] ) , - ( 12 + ( 21 , [ Code ":" , Code "$" @@ -154,7 +154,7 @@ Output ] ) , - ( 13 + ( 22 , [ Code ":" , Code "$" @@ -167,7 +167,7 @@ Output ] ) , - ( 14 + ( 23 , [ Code ":" , Code "$" @@ -180,7 +180,7 @@ Output ] ) , - ( 15 + ( 24 , [ Code ":" , Code "$" @@ -193,7 +193,7 @@ Output ] ) , - ( 17 + ( 26 , [ Code ":" , Code "$" @@ -206,7 +206,7 @@ Output ] ) , - ( 18 + ( 27 , [ Code ":" , Code "$" @@ -219,7 +219,7 @@ Output ] ) , - ( 21 + ( 30 , [ Code ":" , Code "$" @@ -232,7 +232,7 @@ Output ] ) , - ( 22 + ( 31 , [ Code ":" , Code "$" @@ -245,7 +245,7 @@ Output ] ) , - ( 23 + ( 32 , [ Code ":" , Code "$" @@ -258,12 +258,12 @@ Output ] ) , - ( 24 + ( 33 , [ Prose "r" ] ) , - ( 25 + ( 34 , [ Code ":" , Code "$" @@ -276,7 +276,7 @@ Output ] ) , - ( 26 + ( 35 , [ Code ":" , Code "$" @@ -289,7 +289,7 @@ Output ] ) , - ( 27 + ( 36 , [ Code ":" , Code "$" @@ -308,7 +308,7 @@ Output ] ) , - ( 28 + ( 37 , [ Code ":" , Code "$" @@ -321,7 +321,7 @@ Output ] ) , - ( 29 + ( 38 , [ Code ":" , Code "$" @@ -334,7 +334,7 @@ Output ] ) , - ( 8 + ( 17 , [ Code "→" , Code "∀" @@ -343,7 +343,7 @@ Output ] ) , - ( 9 + ( 18 , [ Code "→" , Code "∀" @@ -353,7 +353,7 @@ Output ] ) , - ( 16 + ( 25 , [ Code "→" , Code "∀" @@ -362,7 +362,7 @@ Output ] ) , - ( 19 + ( 28 , [ Code "→" , Code "∀" @@ -371,7 +371,7 @@ Output ] ) , - ( 20 + ( 29 , [ Code "→" , Code "∀" @@ -380,7 +380,7 @@ Output ] ) , - ( 30 + ( 39 , [ Code "→" , Code "∀" @@ -390,7 +390,7 @@ Output ] ) , - ( 31 + ( 40 , [ Code "→" , Code "∀" @@ -400,7 +400,7 @@ Output ] ) , - ( 32 + ( 41 , [ Code "→" , Code "∀" @@ -411,7 +411,7 @@ Output ] ) , - ( 33 + ( 42 , [ Code "→" , Code "∀" @@ -421,7 +421,7 @@ Output ] ) , - ( 34 + ( 43 , [ Code "→" , Code "∀" @@ -431,7 +431,7 @@ Output ] ) , - ( 35 + ( 44 , [ Code "→" , Code "∀" @@ -441,7 +441,7 @@ Output ] ) , - ( 36 + ( 45 , [ Code "→" , Code "∀" @@ -451,7 +451,7 @@ Output ] ) , - ( 37 + ( 46 , [ Code "→" , Code "∀" @@ -463,7 +463,7 @@ Output ] , sigActions = [ - ( 38 + ( 0 , [ Code "→" , Code "∀" @@ -473,7 +473,7 @@ Output ] ) , - ( 39 + ( 1 , [ Code "→" , Code "∀" @@ -483,7 +483,7 @@ Output ] ) , - ( 40 + ( 2 , [ Code "→" , Code "∀" @@ -494,7 +494,7 @@ Output ] ) , - ( 41 + ( 3 , [ Code "→" , Code "∀" @@ -504,7 +504,7 @@ Output ] ) , - ( 42 + ( 4 , [ Code "→" , Code "∀" @@ -514,7 +514,7 @@ Output ] ) , - ( 43 + ( 5 , [ Code "→" , Code "∀" @@ -524,7 +524,7 @@ Output ] ) , - ( 44 + ( 6 , [ Code "→" , Code "∀" @@ -534,7 +534,7 @@ Output ] ) , - ( 45 + ( 7 , [ Code "→" , Code "∀" @@ -545,7 +545,7 @@ Output ] ) , - ( 46 + ( 8 , [ Code "→" , Code "∀" diff --git a/primer/test/outputs/available-actions/M.1/Intermediate.fragment b/primer/test/outputs/available-actions/M.comprehensive/Intermediate.fragment similarity index 100% rename from primer/test/outputs/available-actions/M.1/Intermediate.fragment rename to primer/test/outputs/available-actions/M.comprehensive/Intermediate.fragment index 2c20c3ce9..6e869c426 100644 --- a/primer/test/outputs/available-actions/M.1/Intermediate.fragment +++ b/primer/test/outputs/available-actions/M.comprehensive/Intermediate.fragment @@ -6,7 +6,7 @@ Output ] , bodyActions = [ - ( 0 + ( 9 , [ Code "λx" , Code "m" @@ -17,7 +17,7 @@ Output ] ) , - ( 1 + ( 10 , [ Code "λx" , Code "m" @@ -27,7 +27,7 @@ Output ] ) , - ( 2 + ( 11 , [ Code "λx" , Code "m" @@ -38,7 +38,7 @@ Output ] ) , - ( 3 + ( 12 , [ Code "λx" , Code "m" @@ -48,7 +48,7 @@ Output ] ) , - ( 4 + ( 13 , [ Code "λx" , Code "m" @@ -59,7 +59,7 @@ Output ] ) , - ( 5 + ( 14 , [ Code "λx" , Code "m" @@ -68,7 +68,7 @@ Output ] ) , - ( 6 + ( 15 , [ Code "λx" , Code "m" @@ -79,7 +79,7 @@ Output ] ) , - ( 7 + ( 16 , [ Code "λx" , Code "m" @@ -88,7 +88,7 @@ Output ] ) , - ( 10 + ( 19 , [ Code "λx" , Code "m" @@ -98,7 +98,7 @@ Output ] ) , - ( 11 + ( 20 , [ Code "λx" , Code "m" @@ -109,7 +109,7 @@ Output ] ) , - ( 12 + ( 21 , [ Code "λx" , Code "m" @@ -119,7 +119,7 @@ Output ] ) , - ( 13 + ( 22 , [ Code "λx" , Code "m" @@ -129,7 +129,7 @@ Output ] ) , - ( 14 + ( 23 , [ Code "λx" , Code "m" @@ -139,7 +139,7 @@ Output ] ) , - ( 15 + ( 24 , [ Code "λx" , Code "m" @@ -149,7 +149,7 @@ Output ] ) , - ( 17 + ( 26 , [ Code "λx" , Code "m" @@ -159,7 +159,7 @@ Output ] ) , - ( 18 + ( 27 , [ Code "λx" , Code "m" @@ -169,7 +169,7 @@ Output ] ) , - ( 21 + ( 30 , [ Code "λx" , Code "m" @@ -179,7 +179,7 @@ Output ] ) , - ( 22 + ( 31 , [ Code "λx" , Code "m" @@ -189,7 +189,7 @@ Output ] ) , - ( 23 + ( 32 , [ Code "λx" , Code "m" @@ -199,12 +199,12 @@ Output ] ) , - ( 24 + ( 33 , [ Prose "r" ] ) , - ( 25 + ( 34 , [ Code "λx" , Code "m" @@ -214,7 +214,7 @@ Output ] ) , - ( 26 + ( 35 , [ Code "λx" , Code "m" @@ -224,7 +224,7 @@ Output ] ) , - ( 27 + ( 36 , [ Code "λx" , Code "m" @@ -240,7 +240,7 @@ Output ] ) , - ( 28 + ( 37 , [ Code "λx" , Code "m" @@ -250,7 +250,7 @@ Output ] ) , - ( 29 + ( 38 , [ Code "λx" , Code "m" @@ -260,14 +260,14 @@ Output ] ) , - ( 8 + ( 17 , [ Code "→" , Prose "⌫" ] ) , - ( 9 + ( 18 , [ Code "→" , Prose "⌫" @@ -275,28 +275,28 @@ Output ] ) , - ( 16 + ( 25 , [ Code "→" , Prose "⌫" ] ) , - ( 19 + ( 28 , [ Code "→" , Prose "⌫" ] ) , - ( 20 + ( 29 , [ Code "→" , Prose "⌫" ] ) , - ( 30 + ( 39 , [ Code "→" , Prose "⌫" @@ -304,7 +304,7 @@ Output ] ) , - ( 31 + ( 40 , [ Code "→" , Prose "⌫" @@ -312,7 +312,7 @@ Output ] ) , - ( 32 + ( 41 , [ Code "→" , Prose "⌫" @@ -320,7 +320,7 @@ Output ] ) , - ( 33 + ( 42 , [ Code "→" , Prose "⌫" @@ -328,7 +328,7 @@ Output ] ) , - ( 34 + ( 43 , [ Code "→" , Prose "⌫" @@ -336,7 +336,7 @@ Output ] ) , - ( 35 + ( 44 , [ Code "→" , Prose "⌫" @@ -344,7 +344,7 @@ Output ] ) , - ( 36 + ( 45 , [ Code "→" , Prose "⌫" @@ -352,7 +352,7 @@ Output ] ) , - ( 37 + ( 46 , [ Code "→" , Prose "⌫" @@ -362,7 +362,7 @@ Output ] , sigActions = [ - ( 38 + ( 0 , [ Code "→" , Prose "⌫" @@ -370,7 +370,7 @@ Output ] ) , - ( 39 + ( 1 , [ Code "→" , Prose "⌫" @@ -378,7 +378,7 @@ Output ] ) , - ( 40 + ( 2 , [ Code "→" , Prose "⌫" @@ -386,7 +386,7 @@ Output ] ) , - ( 41 + ( 3 , [ Code "→" , Prose "⌫" @@ -394,7 +394,7 @@ Output ] ) , - ( 42 + ( 4 , [ Code "→" , Prose "⌫" @@ -402,7 +402,7 @@ Output ] ) , - ( 43 + ( 5 , [ Code "→" , Prose "⌫" @@ -410,7 +410,7 @@ Output ] ) , - ( 44 + ( 6 , [ Code "→" , Prose "⌫" @@ -418,7 +418,7 @@ Output ] ) , - ( 45 + ( 7 , [ Code "→" , Code "T" @@ -426,7 +426,7 @@ Output ] ) , - ( 46 + ( 8 , [ Code "→" , Prose "⌫" diff --git a/weeder.dhall b/weeder.dhall index 167336769..09bfea39e 100644 --- a/weeder.dhall +++ b/weeder.dhall @@ -10,8 +10,9 @@ let -- Anything specific we want Weeder to ignore goes here. This -- includes things that we export for the convenience of users of -- these packages, but don't actually make use of ourselves. - ignoreRoots = [ - "^Primer.Database.Rel8.Rel8Db.runRel8Db" - ] + ignoreRoots = + [ "^Primer.Core.Utils.mkASTDef" + , "^Primer.Database.Rel8.Rel8Db.runRel8Db" + ] in { roots = [ "^Main.main$" ] # tmpRoots # ignoreRoots, type-class-roots = True }