Skip to content

Commit

Permalink
refactor: Create a comprehensive example AST and DRY.
Browse files Browse the repository at this point in the history 
Previously, we used this test definition verbatim in 2 different
places.
  • Loading branch information
@dhess
dhess committed Jun 6, 2022
1 parent ee3466e commit 5cca2a8
Show file tree
Hide file tree
Showing 6 changed files with 286 additions and 436 deletions.
193 changes: 24 additions & 169 deletions primer-rel8/test/TestUtils.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down Expand Up @@ -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_
}
111 changes: 110 additions & 1 deletion primer/src/Primer/Examples.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,6 +21,7 @@ module Primer.Examples (
map',
even,
odd,
comprehensive,
) where

import Foreword hiding (
Expand All @@ -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,
)

Expand Down Expand Up @@ -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_
Loading

0 comments on commit 5cca2a8

Please sign in to comment.