Merge pull request #461 from hackworthltd/dhess/more-dsl-improvements

feat: Better example program re-use in tests.
hackworthltd · Jun 7, 2022 · 37f5f84 · 37f5f84
2 parents 12036c3 + b93078f
commit 37f5f84
Show file tree

Hide file tree

Showing 24 changed files with 502 additions and 625 deletions.
diff --git a/primer-rel8/test/TestUtils.hs b/primer-rel8/test/TestUtils.hs
@@ -46,59 +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),
-  ModuleName (ModuleName),
-  qualifyName,
- )
-import Primer.Core.DSL (
-  aPP,
-  ann,
-  app,
-  branch,
-  case_,
-  con,
-  create,
-  emptyHole,
-  gvar',
-  hole,
-  lAM,
-  lam,
-  letType,
-  let_,
-  letrec,
-  lvar,
-  tEmptyHole,
-  tapp,
-  tcon,
-  tforall,
-  tfun,
-  thole,
-  tvar,
+  baseName,
+  defName,
+  mkSimpleModuleName,
  )
+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,
@@ -237,136 +197,27 @@ insertSessionRow row conn =
             , returning = NumberOfRowsAffected
             }
 
--- | This definition contains every construct 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) =
-  ( ASTDef
-      { astDefName = qualifyName (ModuleName $ "TestModule" :| []) "1"
-      , astDefExpr
-      , astDefType
-      }
-  , nextID
-  )
-  where
-    ((astDefExpr, astDefType), nextID) = create $ (,) <$> e <*> t
-    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 every construct 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 = ModuleName $ "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-service/src/Primer/Server.hs b/primer-service/src/Primer/Server.hs
@@ -76,15 +76,23 @@ import Primer.Core (
   ID,
   Kind (KFun, KType),
   LVarName,
-  ModuleName (ModuleName),
   TyVarName,
   Type,
   Type' (TEmptyHole),
   TypeCache (..),
   TypeCacheBoth (..),
+  mkSimpleModuleName,
   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,
@@ -336,17 +344,16 @@ 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}
     :<|> mkTest EvalFullReq{evalFullReqExpr = expr, evalFullMaxSteps = 10, evalFullCxtDir = Syn}
     :<|> 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/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
@@ -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
@@ -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/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