From ec612353b14906fdf54db5b91d64970ad56bce75 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Thu, 7 Apr 2022 14:08:24 +0100 Subject: [PATCH 1/8] refactor: move definition of builtins This is in preperation for adding module names, which will require some renaming of primitives. We will export some identifiers for these names instead of writing them as literal strings, to make any future renames easier. --- primer-service/src/Primer/Server.hs | 2 +- primer/primer.cabal | 1 + primer/src/Primer/App.hs | 78 +--------------- primer/src/Primer/Builtins.hs | 135 ++++++++++++++++++++++++++++ primer/test/Tests/Eval.hs | 2 +- primer/test/Tests/EvalFull.hs | 2 +- primer/test/Tests/Typecheck.hs | 10 ++- 7 files changed, 146 insertions(+), 84 deletions(-) create mode 100644 primer/src/Primer/Builtins.hs diff --git a/primer-service/src/Primer/Server.hs b/primer-service/src/Primer/Server.hs index 166139041..f71c37b92 100644 --- a/primer-service/src/Primer/Server.hs +++ b/primer-service/src/Primer/Server.hs @@ -64,9 +64,9 @@ import Primer.App ( Prog, ProgAction (BodyAction, MoveToDef), ProgError (NoDefSelected), - boolDef, newProg, ) +import Primer.Builtins (boolDef) import Primer.Core ( ASTDef (..), ASTTypeDef, diff --git a/primer/primer.cabal b/primer/primer.cabal index fbe57708e..26280b008 100644 --- a/primer/primer.cabal +++ b/primer/primer.cabal @@ -19,6 +19,7 @@ library Primer.Action.Priorities Primer.API Primer.App + Primer.Builtins Primer.Core Primer.Core.DSL Primer.Core.Transform diff --git a/primer/src/Primer/App.hs b/primer/src/Primer/App.hs index 7f63fcfee..8dca44cbf 100644 --- a/primer/src/Primer/App.hs +++ b/primer/src/Primer/App.hs @@ -42,10 +42,6 @@ module Primer.App ( EvalFullReq (..), EvalFullResp (..), lookupASTDef, - boolDef, - natDef, - listDef, - eitherDef, defaultTypeDefs, ) where @@ -90,6 +86,7 @@ import Primer.Action ( applyActionsToBody, applyActionsToTypeSig, ) +import Primer.Builtins (boolDef, eitherDef, listDef, maybeDef, natDef, pairDef) import Primer.Core ( ASTDef (..), ASTTypeDef (..), @@ -103,7 +100,6 @@ import Primer.Core ( GVarName, GlobalName (baseName), ID (..), - Kind (..), LocalName (LocalName, unLocalName), Meta (..), PrimDef (..), @@ -1301,75 +1297,3 @@ defaultTypeDefs = <> map TypeDefPrim (Map.elems allPrimTypeDefs) - --- | A definition of the Bool type -boolDef :: ASTTypeDef -boolDef = - ASTTypeDef - { astTypeDefName = "Bool" - , astTypeDefParameters = [] - , astTypeDefConstructors = - [ ValCon "True" [] - , ValCon "False" [] - ] - , astTypeDefNameHints = ["p", "q"] - } - --- | A definition of the Nat type -natDef :: ASTTypeDef -natDef = - ASTTypeDef - { astTypeDefName = "Nat" - , astTypeDefParameters = [] - , astTypeDefConstructors = - [ ValCon "Zero" [] - , ValCon "Succ" [TCon () "Nat"] - ] - , astTypeDefNameHints = ["i", "j", "n", "m"] - } - --- | A definition of the List type -listDef :: ASTTypeDef -listDef = - ASTTypeDef - { astTypeDefName = "List" - , astTypeDefParameters = [("a", KType)] - , astTypeDefConstructors = - [ ValCon "Nil" [] - , ValCon "Cons" [TVar () "a", TApp () (TCon () "List") (TVar () "a")] - ] - , astTypeDefNameHints = ["xs", "ys", "zs"] - } - --- | A definition of the Maybe type -maybeDef :: ASTTypeDef -maybeDef = - ASTTypeDef - { astTypeDefName = "Maybe" - , astTypeDefParameters = [("a", KType)] - , astTypeDefConstructors = - [ ValCon "Nothing" [] - , ValCon "Just" [TVar () "a"] - ] - , astTypeDefNameHints = ["mx", "my", "mz"] - } - --- | A definition of the Pair type -pairDef :: ASTTypeDef -pairDef = - ASTTypeDef - { astTypeDefName = "Pair" - , astTypeDefParameters = [("a", KType), ("b", KType)] - , astTypeDefConstructors = [ValCon "MakePair" [TVar () "a", TVar () "b"]] - , astTypeDefNameHints = [] - } - --- | A definition of the Either type -eitherDef :: ASTTypeDef -eitherDef = - ASTTypeDef - { astTypeDefName = "Either" - , astTypeDefParameters = [("a", KType), ("b", KType)] - , astTypeDefConstructors = [ValCon "Left" [TVar () "a"], ValCon "Right" [TVar () "b"]] - , astTypeDefNameHints = [] - } diff --git a/primer/src/Primer/Builtins.hs b/primer/src/Primer/Builtins.hs new file mode 100644 index 000000000..a1a391b0f --- /dev/null +++ b/primer/src/Primer/Builtins.hs @@ -0,0 +1,135 @@ +-- | This module defines some builtin types that are used to seed initial programs. +-- The definitions here are no different than ones than a user can create, except +-- for the fact that some of the primitive functions (see "Primer.Primitives") +-- refer to these types. +module Primer.Builtins ( + boolDef, + natDef, + listDef, + maybeDef, + pairDef, + eitherDef, +) where + +import Primer.Core ( + ASTTypeDef ( + ASTTypeDef, + astTypeDefConstructors, + astTypeDefName, + astTypeDefNameHints, + astTypeDefParameters + ), + Kind (KType), + TyConName, + Type' (TApp, TCon, TVar), + ValCon (ValCon), + ValConName, + ) + +tBool :: TyConName +tBool = "Bool" +cTrue, cFalse :: ValConName +cTrue = "True" +cFalse = "False" + +tNat :: TyConName +tNat = "Nat" +cZero, cSucc :: ValConName +cZero = "Zero" +cSucc = "Succ" + +tList :: TyConName +tList = "List" +cNil, cCons :: ValConName +cNil = "Nil" +cCons = "Cons" + +tMaybe :: TyConName +tMaybe = "Maybe" +cNothing :: ValConName +cNothing = "Nothing" +cJust :: ValConName +cJust = "Just" + +tPair :: TyConName +tPair = "Pair" +cMakePair :: ValConName +cMakePair = "MakePair" + +tEither :: TyConName +tEither = "Either" +cLeft, cRight :: ValConName +cLeft = "Left" +cRight = "Right" + +-- | A definition of the Bool type +boolDef :: ASTTypeDef +boolDef = + ASTTypeDef + { astTypeDefName = tBool + , astTypeDefParameters = [] + , astTypeDefConstructors = + [ ValCon cTrue [] + , ValCon cFalse [] + ] + , astTypeDefNameHints = ["p", "q"] + } + +-- | A definition of the Nat type +natDef :: ASTTypeDef +natDef = + ASTTypeDef + { astTypeDefName = tNat + , astTypeDefParameters = [] + , astTypeDefConstructors = + [ ValCon cZero [] + , ValCon cSucc [TCon () tNat] + ] + , astTypeDefNameHints = ["i", "j", "n", "m"] + } + +-- | A definition of the List type +listDef :: ASTTypeDef +listDef = + ASTTypeDef + { astTypeDefName = tList + , astTypeDefParameters = [("a", KType)] + , astTypeDefConstructors = + [ ValCon cNil [] + , ValCon cCons [TVar () "a", TApp () (TCon () tList) (TVar () "a")] + ] + , astTypeDefNameHints = ["xs", "ys", "zs"] + } + +-- | A definition of the Maybe type +maybeDef :: ASTTypeDef +maybeDef = + ASTTypeDef + { astTypeDefName = tMaybe + , astTypeDefParameters = [("a", KType)] + , astTypeDefConstructors = + [ ValCon cNothing [] + , ValCon cJust [TVar () "a"] + ] + , astTypeDefNameHints = ["mx", "my", "mz"] + } + +-- | A definition of the Pair type +pairDef :: ASTTypeDef +pairDef = + ASTTypeDef + { astTypeDefName = tPair + , astTypeDefParameters = [("a", KType), ("b", KType)] + , astTypeDefConstructors = [ValCon cMakePair [TVar () "a", TVar () "b"]] + , astTypeDefNameHints = [] + } + +-- | A definition of the Either type +eitherDef :: ASTTypeDef +eitherDef = + ASTTypeDef + { astTypeDefName = tEither + , astTypeDefParameters = [("a", KType), ("b", KType)] + , astTypeDefConstructors = [ValCon cLeft [TVar () "a"], ValCon cRight [TVar () "b"]] + , astTypeDefNameHints = [] + } diff --git a/primer/test/Tests/Eval.hs b/primer/test/Tests/Eval.hs index 1fd672d32..54a578bda 100644 --- a/primer/test/Tests/Eval.hs +++ b/primer/test/Tests/Eval.hs @@ -12,11 +12,11 @@ import Primer.App ( EvalReq (EvalReq, evalReqExpr, evalReqRedex), EvalResp (EvalResp, evalRespExpr), Prog (progModule), - boolDef, handleEvalRequest, importModules, newEmptyApp, ) +import Primer.Builtins (boolDef) import Primer.Core ( ASTDef (..), Def (..), diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs index c5c9aa8d1..d96a0dadb 100644 --- a/primer/test/Tests/EvalFull.hs +++ b/primer/test/Tests/EvalFull.hs @@ -19,12 +19,12 @@ import Primer.App ( EvalFullReq (EvalFullReq, evalFullCxtDir, evalFullMaxSteps, evalFullReqExpr), EvalFullResp (EvalFullRespNormal, EvalFullRespTimedOut), Prog (progModule), - boolDef, defaultTypeDefs, handleEvalFullRequest, importModules, newEmptyApp, ) +import Primer.Builtins (boolDef) import Primer.Core import Primer.Core.DSL import Primer.Core.Utils (forgetIDs, forgetTypeIDs, generateIDs, generateTypeIDs) diff --git a/primer/test/Tests/Typecheck.hs b/primer/test/Tests/Typecheck.hs index c5c1a6807..fc4696ae9 100644 --- a/primer/test/Tests/Typecheck.hs +++ b/primer/test/Tests/Typecheck.hs @@ -23,15 +23,17 @@ import qualified Hedgehog.Range as Range import Optics (over, set) import Primer.App ( Prog (progImports), - boolDef, defaultTypeDefs, - eitherDef, - listDef, - natDef, newEmptyProg, newProg, progModule, ) +import Primer.Builtins ( + boolDef, + eitherDef, + listDef, + natDef, + ) import Primer.Core ( ASTTypeDef (..), Def (..), From db68e006fd6e15c5d84431a3e8e7449e648339e4 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Thu, 7 Apr 2022 14:20:34 +0100 Subject: [PATCH 2/8] refactor: use exported names This is in preperation for adding module names, which will require some renaming of primitives. --- primer-rel8/test/TestUtils.hs | 39 ++-- primer/src/Primer/Builtins.hs | 17 ++ primer/src/Primer/Core/DSL.hs | 15 +- primer/src/Primer/Primitives.hs | 130 +++++++----- primer/test/TestUtils.hs | 18 ++ primer/test/Tests/Action.hs | 260 ++++++++++++----------- primer/test/Tests/Action/Available.hs | 27 +-- primer/test/Tests/Action/Capture.hs | 3 +- primer/test/Tests/Action/Prog.hs | 39 ++-- primer/test/Tests/AlphaEquality.hs | 45 ++-- primer/test/Tests/Eval.hs | 46 ++-- primer/test/Tests/EvalFull.hs | 183 ++++++++-------- primer/test/Tests/FreeVars.hs | 5 +- primer/test/Tests/Primitives.hs | 12 +- primer/test/Tests/Question.hs | 41 ++-- primer/test/Tests/Refine.hs | 39 ++-- primer/test/Tests/Serialization.hs | 3 +- primer/test/Tests/Subst.hs | 13 +- primer/test/Tests/Transform.hs | 5 +- primer/test/Tests/Typecheck.hs | 195 +++++++++-------- primer/test/Tests/Unification.hs | 54 ++--- primer/test/Tests/Zipper/BindersAbove.hs | 17 +- 22 files changed, 659 insertions(+), 547 deletions(-) diff --git a/primer-rel8/test/TestUtils.hs b/primer-rel8/test/TestUtils.hs index b4c72acd2..8ad37bf47 100644 --- a/primer-rel8/test/TestUtils.hs +++ b/primer-rel8/test/TestUtils.hs @@ -48,6 +48,19 @@ import Primer.App ( newEmptyApp, newEmptyProg, ) +import Primer.Builtins ( + cFalse, + cJust, + cLeft, + cSucc, + cTrue, + cZero, + tBool, + tEither, + tList, + tMaybe, + tNat, + ) import Primer.Core ( ASTDef (..), Def (DefAST, DefPrim), @@ -245,14 +258,14 @@ testASTDef = ((astDefExpr, astDefType), _) = create $ (,) <$> e <*> t t = tfun - (tcon "Nat") + (tcon tNat) ( tforall "a" KType ( tapp ( thole ( tapp - (tcon "List") + (tcon tList) tEmptyHole ) ) @@ -262,19 +275,19 @@ testASTDef = e = let_ "x" - (con "True") + (con cTrue) ( letrec "y" ( app ( hole - (con "Just") + (con cJust) ) ( hole (gvar "0") ) ) ( thole - (tcon "Maybe") + (tcon tMaybe) ) ( ann ( lam @@ -285,9 +298,9 @@ testASTDef = ( aPP ( letType "b" - (tcon "Bool") + (tcon tBool) ( aPP - (con "Left") + (con cLeft) (tvar "b") ) ) @@ -296,11 +309,11 @@ testASTDef = ( case_ (lvar "i") [ branch - "Zero" + cZero [] - (con "False") + (con cFalse) , branch - "Succ" + cSucc [ ( "n" , Nothing @@ -319,14 +332,14 @@ testASTDef = ) ) ( tfun - (tcon "Nat") + (tcon tNat) ( tforall "α" KType ( tapp ( tapp - (tcon "Either") - (tcon "Bool") + (tcon tEither) + (tcon tBool) ) (tvar "α") ) diff --git a/primer/src/Primer/Builtins.hs b/primer/src/Primer/Builtins.hs index a1a391b0f..0ca268eb8 100644 --- a/primer/src/Primer/Builtins.hs +++ b/primer/src/Primer/Builtins.hs @@ -3,11 +3,28 @@ -- for the fact that some of the primitive functions (see "Primer.Primitives") -- refer to these types. module Primer.Builtins ( + tBool, + cTrue, + cFalse, boolDef, + tNat, + cZero, + cSucc, natDef, + tList, + cNil, + cCons, listDef, + tMaybe, + cNothing, + cJust, maybeDef, + tPair, + cMakePair, pairDef, + tEither, + cLeft, + cRight, eitherDef, ) where diff --git a/primer/src/Primer/Core/DSL.hs b/primer/src/Primer/Core/DSL.hs index cac8d8a60..ab2369c00 100644 --- a/primer/src/Primer/Core/DSL.hs +++ b/primer/src/Primer/Core/DSL.hs @@ -42,6 +42,7 @@ import Foreword import Control.Monad.Fresh (MonadFresh, fresh) import Numeric.Natural (Natural) import Optics (set) +import Primer.Builtins (cCons, cFalse, cJust, cNil, cNothing, cSucc, cTrue, cZero) import Primer.Core ( Bind' (..), CaseBranch, @@ -167,22 +168,22 @@ meta' a = Meta <$> fresh <*> pure a <*> pure Nothing -- These functions rely on particular types being in scope. bool_ :: MonadFresh ID m => Bool -> m Expr -bool_ b = con $ if b then "True" else "False" +bool_ b = con $ if b then cTrue else cFalse nat :: MonadFresh ID m => Natural -> m Expr nat = \case - 0 -> con "Zero" - n -> app (con "Succ") $ nat (n - 1) + 0 -> con cZero + n -> app (con cSucc) $ nat (n - 1) maybe_ :: MonadFresh ID m => m Type -> (a -> m Expr) -> Maybe a -> m Expr maybe_ t f = \case - Nothing -> con "Nothing" `aPP` t - Just x -> con "Just" `aPP` t `app` f x + Nothing -> con cNothing `aPP` t + Just x -> con cJust `aPP` t `app` f x list_ :: MonadFresh ID m => TyConName -> [m Expr] -> m Expr list_ t = foldr ( \a b -> - con "Cons" + con cCons `aPP` tcon t `app` a `app` b ) - (con "Nil" `aPP` tcon t) + (con cNil `aPP` tcon t) diff --git a/primer/src/Primer/Primitives.hs b/primer/src/Primer/Primitives.hs index 73f84fdad..5cbf8f596 100644 --- a/primer/src/Primer/Primitives.hs +++ b/primer/src/Primer/Primitives.hs @@ -3,6 +3,9 @@ module Primer.Primitives ( allPrimDefs, allPrimTypeDefs, + tInt, + tChar, + primitiveGVar, ) where import Foreword @@ -10,6 +13,15 @@ import Foreword import Data.Bitraversable (bisequence) import qualified Data.Map as M import Numeric.Natural (Natural) +import Primer.Builtins ( + cJust, + cNothing, + cSucc, + cZero, + tBool, + tMaybe, + tNat, + ) import Primer.Core ( Expr' (App, Con, PrimCon), ExprAnyFresh (..), @@ -19,6 +31,7 @@ import Primer.Core ( PrimFunError (..), PrimTypeDef (..), TyConName, + qualifyName, ) import Primer.Core.DSL ( aPP, @@ -32,13 +45,24 @@ import Primer.Core.DSL ( tapp, tcon, ) +import Primer.Name (Name) + +tChar :: TyConName +tChar = "Char" + +tInt :: TyConName +tInt = "Int" + +-- | Construct a reference to a primitive definition. For use in tests. +primitiveGVar :: Name -> GVarName +primitiveGVar = qualifyName -- | Primitive type definitions. -- There should be one entry here for each constructor of `PrimCon`. allPrimTypeDefs :: Map TyConName PrimTypeDef allPrimTypeDefs = M.fromList - [ let name = "Char" + [ let name = tChar in ( name , PrimTypeDef { primTypeDefName = name @@ -46,7 +70,7 @@ allPrimTypeDefs = , primTypeDefNameHints = ["c"] } ) - , let name = "Int" + , let name = tInt in ( name , PrimTypeDef { primTypeDefName = name @@ -67,128 +91,128 @@ allPrimTypeDefs = allPrimDefs :: Map GVarName PrimFun allPrimDefs = M.fromList - [ let name = "toUpper" + [ let name = primitiveGVar "toUpper" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Char"] $ tcon "Char" + { primFunTypes = sequenceTypes [tcon tChar] (tcon tChar) , primFunDef = \case [PrimCon _ (PrimChar c)] -> Right $ ExprAnyFresh $ char $ toUpper c xs -> Left $ PrimFunError name xs } ) - , let name = "isSpace" + , let name = primitiveGVar "isSpace" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Char"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tChar] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimChar c)] -> Right $ ExprAnyFresh $ bool_ $ isSpace c xs -> Left $ PrimFunError name xs } ) - , let name = "hexToNat" + , let name = primitiveGVar "hexToNat" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Char"] $ tcon "Maybe" `tapp` tcon "Nat" + { primFunTypes = sequenceTypes [tcon tChar] $ tcon tMaybe `tapp` tcon tNat , primFunDef = \case [PrimCon _ (PrimChar c)] -> do - Right $ ExprAnyFresh $ maybe_ (tcon "Nat") nat $ digitToIntSafe c + Right $ ExprAnyFresh $ maybe_ (tcon tNat) nat $ digitToIntSafe c where digitToIntSafe :: Char -> Maybe Natural digitToIntSafe c' = fromIntegral <$> (guard (isHexDigit c') $> digitToInt c') xs -> Left $ PrimFunError name xs } ) - , let name = "natToHex" + , let name = primitiveGVar "natToHex" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Nat"] $ tcon "Maybe" `tapp` tcon "Char" + { primFunTypes = sequenceTypes [tcon tNat] $ tcon tMaybe `tapp` tcon tChar , primFunDef = \case [exprToNat -> Just n] -> - Right $ ExprAnyFresh $ maybe_ (tcon "Char") char $ intToDigitSafe n + Right $ ExprAnyFresh $ maybe_ (tcon tChar) char $ intToDigitSafe n where intToDigitSafe :: Natural -> Maybe Char intToDigitSafe n' = guard (0 <= n && n <= 15) $> intToDigit (fromIntegral n') xs -> Left $ PrimFunError name xs } ) - , let name = "eqChar" + , let name = primitiveGVar "eqChar" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Char", tcon "Char"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tChar, tcon tChar] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimChar c1), PrimCon _ (PrimChar c2)] -> Right $ ExprAnyFresh $ bool_ $ c1 == c2 xs -> Left $ PrimFunError name xs } ) - , let name = "Int.+" + , let name = primitiveGVar "Int.+" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tInt) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ int $ x + y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.-" + , let name = primitiveGVar "Int.-" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tInt) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ int $ x - y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.×" + , let name = primitiveGVar "Int.×" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tInt) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ int $ x * y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.quotient" + , let name = primitiveGVar "Int.quotient" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Maybe" `tapp` tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] $ tcon tMaybe `tapp` tcon tInt , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ if y == 0 - then con "Nothing" `aPP` tcon "Int" + then con cNothing `aPP` tcon tInt else - con "Just" `aPP` tcon "Int" + con cJust `aPP` tcon tInt `app` int (x `div` y) xs -> Left $ PrimFunError name xs } ) - , let name = "Int.remainder" + , let name = primitiveGVar "Int.remainder" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Maybe" `tapp` tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] $ tcon tMaybe `tapp` tcon tInt , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ if y == 0 - then con "Nothing" `aPP` tcon "Int" + then con cNothing `aPP` tcon tInt else - con "Just" `aPP` tcon "Int" + con cJust `aPP` tcon tInt `app` int (x `mod` y) xs -> Left $ PrimFunError name xs } ) - , let name = "Int.quot" + , let name = primitiveGVar "Int.quot" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tInt) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ @@ -199,10 +223,10 @@ allPrimDefs = xs -> Left $ PrimFunError name xs } ) - , let name = "Int.rem" + , let name = primitiveGVar "Int.rem" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tInt) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ @@ -213,86 +237,86 @@ allPrimDefs = xs -> Left $ PrimFunError name xs } ) - , let name = "Int.<" + , let name = primitiveGVar "Int.<" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x < y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.≤" + , let name = primitiveGVar "Int.≤" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x <= y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.>" + , let name = primitiveGVar "Int.>" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x > y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.≥" + , let name = primitiveGVar "Int.≥" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x >= y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.=" + , let name = primitiveGVar "Int.=" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x == y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.≠" + , let name = primitiveGVar "Int.≠" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int", tcon "Int"] $ tcon "Bool" + { primFunTypes = sequenceTypes [tcon tInt, tcon tInt] (tcon tBool) , primFunDef = \case [PrimCon _ (PrimInt x), PrimCon _ (PrimInt y)] -> Right $ ExprAnyFresh $ bool_ $ x /= y xs -> Left $ PrimFunError name xs } ) - , let name = "Int.toNat" + , let name = primitiveGVar "Int.toNat" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Int"] $ tcon "Maybe" `tapp` tcon "Nat" + { primFunTypes = sequenceTypes [tcon tInt] $ tcon tMaybe `tapp` tcon tNat , primFunDef = \case [PrimCon _ (PrimInt x)] -> Right $ ExprAnyFresh $ if x < 0 - then con "Nothing" `aPP` tcon "Nat" + then con cNothing `aPP` tcon tNat else - con "Just" - `aPP` tcon "Nat" `app` nat (fromInteger x) + con cJust + `aPP` tcon tNat `app` nat (fromInteger x) xs -> Left $ PrimFunError name xs } ) - , let name = "Int.fromNat" + , let name = primitiveGVar "Int.fromNat" in ( name , PrimFun - { primFunTypes = sequenceTypes [tcon "Nat"] $ tcon "Int" + { primFunTypes = sequenceTypes [tcon tNat] (tcon tInt) , primFunDef = \case [exprToNat -> Just n] -> Right $ ExprAnyFresh $ int $ fromIntegral n @@ -303,6 +327,6 @@ allPrimDefs = where sequenceTypes args res = bisequence (sequence args, res) exprToNat = \case - Con _ "Zero" -> Just 0 - App _ (Con _ "Succ") x -> succ <$> exprToNat x + Con _ c | c == cZero -> Just 0 + App _ (Con _ c) x | c == cSucc -> succ <$> exprToNat x _ -> Nothing diff --git a/primer/test/TestUtils.hs b/primer/test/TestUtils.hs index 41f25fefb..300fa79f8 100644 --- a/primer/test/TestUtils.hs +++ b/primer/test/TestUtils.hs @@ -1,18 +1,26 @@ -- | Utilities useful across several types of tests. module TestUtils ( withPrimDefs, + constructTCon, + constructCon, + constructRefinedCon, ) where import Foreword import Control.Monad.Fresh (MonadFresh) import qualified Data.Map as Map +import Primer.Action (Action (ConstructCon, ConstructRefinedCon, ConstructTCon)) import Primer.Core ( GVarName, ID, PrimDef (..), + TyConName, + ValConName, + baseName, primFunType, ) +import Primer.Name (Name (unName)) import Primer.Primitives (allPrimDefs) withPrimDefs :: MonadFresh ID m => (Map GVarName PrimDef -> m a) -> m a @@ -23,3 +31,13 @@ withPrimDefs f = do (\(name, p) -> PrimDef name <$> primFunType p) f (Map.fromList $ (\d -> (primDefName d, d)) <$> defs) + +-- impedence mismatch: ConstructTCon takes text, but tChar etc are TyConNames +constructTCon :: TyConName -> Action +constructTCon = ConstructTCon . unName . baseName + +constructCon :: ValConName -> Action +constructCon = ConstructCon . unName . baseName + +constructRefinedCon :: ValConName -> Action +constructRefinedCon = ConstructRefinedCon . unName . baseName diff --git a/primer/test/Tests/Action.hs b/primer/test/Tests/Action.hs index 23684178d..c71504059 100644 --- a/primer/test/Tests/Action.hs +++ b/primer/test/Tests/Action.hs @@ -20,6 +20,7 @@ import Primer.Action ( applyActionsToExpr, ) import Primer.App (defaultTypeDefs) +import Primer.Builtins import Primer.Core ( Expr, Expr' (..), @@ -46,6 +47,7 @@ import Primer.Zipper ( ) import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) import TestM (evalTestM) +import TestUtils (constructCon, constructRefinedCon, constructTCon) -- | The largest used ID in an expression maxID :: Expr -> ID @@ -191,10 +193,10 @@ unit_7 = ( ann (lam "f" (lam "g" (app (lvar "f") (hole (lvar "g"))))) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) - (tcon "Nat") + (tfun (tcon tNat) (tcon tNat)) + (tcon tNat) ) ) ) @@ -202,10 +204,10 @@ unit_7 = ( ann (lam "f" (lam "g" (app (lvar "f") (hole (app (lvar "g") emptyHole))))) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) - (tcon "Nat") + (tfun (tcon tNat) (tcon tNat)) + (tcon tNat) ) ) ) @@ -219,10 +221,10 @@ unit_8 = , EnterType , ConstructArrowL , Move Child1 - , ConstructTCon "Bool" + , constructTCon tBool , Move Parent , Move Child2 - , ConstructTCon "Bool" + , constructTCon tBool , ExitType , Move Child1 , ConstructLam (Just "x") @@ -231,9 +233,9 @@ unit_8 = , Move Parent , ConstructApp , Move Child2 - , ConstructCon "True" + , constructCon cTrue ] - (app (ann (lam "x" (lvar "x")) (tfun (tcon "Bool") (tcon "Bool"))) (con "True")) + (app (ann (lam "x" (lvar "x")) (tfun (tcon tBool) (tcon tBool))) (con cTrue)) unit_9 :: Assertion unit_9 = @@ -242,28 +244,28 @@ unit_9 = emptyHole [ ConstructLet (Just "x") , Move Child1 - , ConstructCon "True" + , constructCon cTrue , Move Parent , Move Child2 , ConstructVar $ LocalVarRef "x" ] - (let_ "x" (con "True") (lvar "x")) + (let_ "x" (con cTrue) (lvar "x")) unit_construct_arrow_left :: Assertion unit_construct_arrow_left = actionTest NoSmartHoles - (ann emptyHole (tcon "Bool")) - [EnterType, ConstructArrowL, Move Child2, ConstructTCon "Nat"] - (ann emptyHole (tfun (tcon "Bool") (tcon "Nat"))) + (ann emptyHole (tcon tBool)) + [EnterType, ConstructArrowL, Move Child2, constructTCon tNat] + (ann emptyHole (tfun (tcon tBool) (tcon tNat))) unit_construct_arrow_right :: Assertion unit_construct_arrow_right = actionTest NoSmartHoles - (ann emptyHole (tcon "Bool")) - [EnterType, ConstructArrowR, Move Child1, ConstructTCon "Nat"] - (ann emptyHole (tfun (tcon "Nat") (tcon "Bool"))) + (ann emptyHole (tcon tBool)) + [EnterType, ConstructArrowR, Move Child1, constructTCon tNat] + (ann emptyHole (tfun (tcon tNat) (tcon tBool))) unit_construct_letrec :: Assertion unit_construct_letrec = @@ -272,7 +274,7 @@ unit_construct_letrec = emptyHole [ ConstructLetrec (Just "x") , EnterType - , ConstructTCon "Bool" + , constructTCon tBool , ExitType , Move Child1 , ConstructVar $ LocalVarRef "x" @@ -280,31 +282,31 @@ unit_construct_letrec = , Move Child2 , ConstructVar $ LocalVarRef "x" ] - (letrec "x" (lvar "x") (tcon "Bool") (lvar "x")) + (letrec "x" (lvar "x") (tcon tBool) (lvar "x")) unit_rename_let :: Assertion unit_rename_let = actionTest NoSmartHoles - (let_ "x" (con "True") (lvar "x")) + (let_ "x" (con cTrue) (lvar "x")) [RenameLet "y"] - (let_ "y" (con "True") (lvar "y")) + (let_ "y" (con cTrue) (lvar "y")) unit_rename_letrec :: Assertion unit_rename_letrec = actionTest NoSmartHoles - (letrec "x" (lvar "x") (tcon "Bool") (lvar "x")) + (letrec "x" (lvar "x") (tcon tBool) (lvar "x")) [RenameLet "y"] - (letrec "y" (lvar "y") (tcon "Bool") (lvar "y")) + (letrec "y" (lvar "y") (tcon tBool) (lvar "y")) unit_rename_lam :: Assertion unit_rename_lam = actionTest NoSmartHoles - (ann (lam "x" (app (lvar "x") (con "False"))) tEmptyHole) + (ann (lam "x" (app (lvar "x") (con cFalse))) tEmptyHole) [Move Child1, RenameLam "y"] - (ann (lam "y" (app (lvar "y") (con "False"))) tEmptyHole) + (ann (lam "y" (app (lvar "y") (con cFalse))) tEmptyHole) unit_rename_lam_2 :: Assertion unit_rename_lam_2 = @@ -318,31 +320,31 @@ unit_rename_LAM :: Assertion unit_rename_LAM = actionTest NoSmartHoles - (ann (lAM "a" (aPP (con "Nil") (tvar "a"))) (tforall "b" KType $ tapp (tcon "List") (tvar "b"))) + (ann (lAM "a" (aPP (con cNil) (tvar "a"))) (tforall "b" KType $ tapp (tcon tList) (tvar "b"))) [Move Child1, RenameLAM "b"] - (ann (lAM "b" (aPP (con "Nil") (tvar "b"))) (tforall "b" KType $ tapp (tcon "List") (tvar "b"))) + (ann (lAM "b" (aPP (con cNil) (tvar "b"))) (tforall "b" KType $ tapp (tcon tList) (tvar "b"))) unit_rename_LAM_2 :: Assertion unit_rename_LAM_2 = actionTestExpectFail (const True) NoSmartHoles - (ann (lAM "b" (lAM "a" (aPP (con "Nil") (tvar "b")))) tEmptyHole) + (ann (lAM "b" (lAM "a" (aPP (con cNil) (tvar "b")))) tEmptyHole) [Move Child1, Move Child1, RenameLAM "b"] unit_convert_let_to_letrec :: Assertion unit_convert_let_to_letrec = actionTest NoSmartHoles - (let_ "x" (con "True") (lvar "x")) + (let_ "x" (con cTrue) (lvar "x")) [ConvertLetToLetrec] - (letrec "x" (con "True") tEmptyHole (lvar "x")) + (letrec "x" (con cTrue) tEmptyHole (lvar "x")) unit_delete_type :: Assertion unit_delete_type = actionTest NoSmartHoles - (ann emptyHole (tcon "Nat")) + (ann emptyHole (tcon tNat)) [EnterType, Delete] (ann emptyHole tEmptyHole) @@ -351,7 +353,7 @@ unit_setcursor_type = -- Note: we guess that the ID of the tcon will be 2 actionTest NoSmartHoles - (ann emptyHole (tcon "Nat")) + (ann emptyHole (tcon tNat)) [SetCursor 2, Delete] (ann emptyHole tEmptyHole) @@ -376,7 +378,7 @@ unit_bad_app = actionTestExpectFail (const True) NoSmartHoles - (con "True") + (con cTrue) [ConstructApp] unit_insert_expr_in_type :: Assertion @@ -385,7 +387,7 @@ unit_insert_expr_in_type = (const True) NoSmartHoles (ann emptyHole tEmptyHole) - [EnterType, ConstructCon "True"] + [EnterType, constructCon cTrue] unit_bad_lambda :: Assertion unit_bad_lambda = @@ -400,16 +402,16 @@ unit_enter_emptyHole = actionTest NoSmartHoles emptyHole - [EnterHole, ConstructCon "True"] - (hole $ con "True") + [EnterHole, constructCon cTrue] + (hole $ con cTrue) unit_enter_nonEmptyHole :: Assertion unit_enter_nonEmptyHole = actionTest NoSmartHoles (hole emptyHole) - [Move Child1, ConstructCon "True"] - (hole $ con "True") + [Move Child1, constructCon cTrue] + (hole $ con cTrue) unit_bad_enter_hole :: Assertion unit_bad_enter_hole = @@ -426,7 +428,7 @@ unit_case_create = NoSmartHoles ( ann (lam "x" emptyHole) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [ Move Child1 , Move Child1 @@ -435,8 +437,8 @@ unit_case_create = , ConstructAnn , Move Child1 , ConstructCase - , Move (Branch "True") - , ConstructCon "Zero" + , Move (Branch cTrue) + , constructCon cZero ] ( ann ( lam "x" $ @@ -444,11 +446,11 @@ unit_case_create = ann ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) tEmptyHole ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) -- Test tidying up after the creation of cases @@ -462,20 +464,20 @@ unit_case_tidy = ann ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) tEmptyHole ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [Move Child1, Move Child1, FinishHole, RemoveAnn] ( ann ( lam "x" $ case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) -- Test movement into RHS of branches @@ -489,20 +491,20 @@ unit_case_move_branch_1 = ann ( case_ (lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) tEmptyHole ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [ Move Child1 , Move Child1 , Move Child1 , Move Child1 - , Move (Branch "Zero") - , ConstructCon "Zero" + , Move (Branch cZero) + , constructCon cZero , Move Parent - , Move (Branch "Succ") + , Move (Branch cSucc) , ConstructVar $ LocalVarRef "n" ] ( ann @@ -511,11 +513,11 @@ unit_case_move_branch_1 = ann ( case_ (lvar "x") - [branch "Zero" [] (con "Zero"), branch "Succ" [("n", Nothing)] (lvar "n")] + [branch cZero [] (con cZero), branch cSucc [("n", Nothing)] (lvar "n")] ) tEmptyHole ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) -- Test movement into RHS of branches (case not wrapped in a hole) @@ -527,25 +529,25 @@ unit_case_move_branch_2 = ( lam "x" $ case_ (lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [ Move Child1 , Move Child1 - , Move (Branch "Zero") - , ConstructCon "Zero" + , Move (Branch cZero) + , constructCon cZero , Move Parent - , Move (Branch "Succ") + , Move (Branch cSucc) , ConstructVar $ LocalVarRef "n" ] ( ann ( lam "x" $ case_ (lvar "x") - [branch "Zero" [] (con "Zero"), branch "Succ" [("n", Nothing)] (lvar "n")] + [branch cZero [] (con cZero), branch cSucc [("n", Nothing)] (lvar "n")] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) -- Test movement into scrutinee @@ -559,11 +561,11 @@ unit_case_move_scrutinee_1 = ann ( case_ (lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) tEmptyHole ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [ Move Child1 , Move Child1 @@ -578,11 +580,11 @@ unit_case_move_scrutinee_1 = ann ( case_ (setMeta "meta" $ lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) tEmptyHole ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) -- Test movement into scrutinee (case not wrapped in a hole) @@ -594,18 +596,18 @@ unit_case_move_scrutinee_2 = ( lam "x" $ case_ (lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [Move Child1, Move Child1, Move Child1, SetMetadata "meta"] ( ann ( lam "x" $ case_ (setMeta "meta" $ lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) unit_bad_case_1 :: Assertion @@ -615,7 +617,7 @@ unit_bad_case_1 = NoSmartHoles ( ann (lam "x" $ hole $ lvar "x") - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [ConstructCase] @@ -638,11 +640,11 @@ unit_bad_case_3 = ann ( case_ (lvar "x") - [branch "True" [] emptyHole, branch "False" [] emptyHole] + [branch cTrue [] emptyHole, branch cFalse [] emptyHole] ) tEmptyHole ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [Move Child1, Move Child1, Move Child1, Move Child1, Move Child2] @@ -656,23 +658,23 @@ unit_case_on_hole = NoSmartHoles ( ann (lam "x" emptyHole) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [ Move Child1 , Move Child1 , ConstructAnn , EnterType - , ConstructTCon "Nat" + , constructTCon tNat , ExitType , ConstructCase ] ( ann ( lam "x" $ case_ - (ann emptyHole $ tcon "Nat") - [branch "Zero" [] emptyHole, branch "Succ" [("a13", Nothing)] emptyHole] -- NB: fragile names here + (ann emptyHole $ tcon tNat) + [branch cZero [] emptyHole, branch cSucc [("a13", Nothing)] emptyHole] -- NB: fragile names here ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) -- Changing the scrutinee is ok, as long as the type does not change @@ -683,10 +685,10 @@ unit_case_fill_hole_scrut = ( ann ( lam "x" $ case_ - (ann emptyHole $ tcon "Nat") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + (ann emptyHole $ tcon tNat) + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) [ Move Child1 , Move Child1 @@ -700,9 +702,9 @@ unit_case_fill_hole_scrut = ( lam "x" $ case_ (lvar "x") - [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole] + [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole] ) - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ) -- Test creation of cases, with smart actions @@ -712,24 +714,24 @@ unit_case_create_smart_on_term = SmartHoles ( ann (lam "x" emptyHole) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [ Move Child1 , Move Child1 , ConstructVar $ LocalVarRef "x" , ConstructCase - , Move (Branch "True") - , ConstructCon "Zero" + , Move (Branch cTrue) + , constructCon cZero ] ( ann ( lam "x" ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) unit_case_create_smart_on_hole :: Assertion @@ -738,7 +740,7 @@ unit_case_create_smart_on_hole = SmartHoles ( ann (lam "x" emptyHole) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) [ Move Child1 , Move Child1 @@ -746,18 +748,18 @@ unit_case_create_smart_on_hole = , Move Child1 , ConstructVar $ LocalVarRef "x" , Move Parent - , Move (Branch "True") - , ConstructCon "Zero" + , Move (Branch cTrue) + , constructCon cZero ] ( ann ( lam "x" ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) ) unit_case_change_smart_scrutinee_type :: Assertion @@ -766,39 +768,39 @@ unit_case_change_smart_scrutinee_type = SmartHoles ( ann ( case_ - (con "True") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + (con cTrue) + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) - (tcon "Nat") + (tcon tNat) ) [ Move Child1 , Move Child1 , Delete - , ConstructCon "Zero" + , constructCon cZero ] ( ann ( case_ - (con "Zero") - [branch "Zero" [] emptyHole, branch "Succ" [("a11", Nothing)] emptyHole] -- fragile names here + (con cZero) + [branch cZero [] emptyHole, branch cSucc [("a11", Nothing)] emptyHole] -- fragile names here ) - (tcon "Nat") + (tcon tNat) ) unit_constructAPP :: Assertion unit_constructAPP = actionTest NoSmartHoles - (con "Nil") - [ConstructAPP, EnterType, ConstructTCon "Bool"] - (con "Nil" `aPP` tcon "Bool") + (con cNil) + [ConstructAPP, EnterType, constructTCon tBool] + (con cNil `aPP` tcon tBool) unit_constructLAM :: Assertion unit_constructLAM = actionTest NoSmartHoles (emptyHole `ann` tEmptyHole) - [Move Child1, ConstructLAM (Just "a"), ConstructCon "True"] - (lAM "a" (con "True") `ann` tEmptyHole) + [Move Child1, ConstructLAM (Just "a"), constructCon cTrue] + (lAM "a" (con cTrue) `ann` tEmptyHole) unit_construct_TForall :: Assertion unit_construct_TForall = @@ -812,16 +814,16 @@ unit_rename_TForall :: Assertion unit_rename_TForall = actionTest NoSmartHoles - (emptyHole `ann` tforall "a" KType (tapp (tcon "List") (tvar "a"))) + (emptyHole `ann` tforall "a" KType (tapp (tcon tList) (tvar "a"))) [EnterType, RenameForall "b"] - (emptyHole `ann` tforall "b" KType (tapp (tcon "List") (tvar "b"))) + (emptyHole `ann` tforall "b" KType (tapp (tcon tList) (tvar "b"))) unit_rename_TForall_2 :: Assertion unit_rename_TForall_2 = actionTestExpectFail (const True) NoSmartHoles - (emptyHole `ann` tforall "b" KType (tforall "a" KType $ tapp (tcon "List") (tvar "b"))) + (emptyHole `ann` tforall "b" KType (tforall "a" KType $ tapp (tcon tList) (tvar "b"))) [EnterType, Move Child1, RenameLAM "b"] unit_construct_TForall_TVar :: Assertion @@ -888,40 +890,40 @@ unit_constructTApp = actionTest NoSmartHoles (emptyHole `ann` tEmptyHole) - [EnterType, ConstructTApp, Move Child1, ConstructTCon "List", Move Parent, Move Child2, ConstructTCon "Bool"] - (emptyHole `ann` (tcon "List" `tapp` tcon "Bool")) + [EnterType, ConstructTApp, Move Child1, constructTCon tList, Move Parent, Move Child2, constructTCon tBool] + (emptyHole `ann` (tcon tList `tapp` tcon tBool)) unit_construct_lam :: Assertion unit_construct_lam = actionTest SmartHoles - (con "True") + (con cTrue) [ConstructLam (Just "x")] - (ann (lam "x" (con "True")) tEmptyHole) + (ann (lam "x" (con cTrue)) tEmptyHole) unit_construct_LAM :: Assertion unit_construct_LAM = actionTest SmartHoles - (con "True") + (con cTrue) [ConstructLAM (Just "a")] - (ann (lAM "a" (con "True")) tEmptyHole) + (ann (lAM "a" (con cTrue)) tEmptyHole) unit_smart_type_1 :: Assertion unit_smart_type_1 = actionTest SmartHoles - (emptyHole `ann` tcon "Nat") + (emptyHole `ann` tcon tNat) [EnterType, ConstructTApp, Move Child1] - (emptyHole `ann` (thole (tcon "Nat") `tapp` tEmptyHole)) + (emptyHole `ann` (thole (tcon tNat) `tapp` tEmptyHole)) unit_smart_type_2 :: Assertion unit_smart_type_2 = actionTest SmartHoles - (emptyHole `ann` thole (tcon "List")) + (emptyHole `ann` thole (tcon tList)) [EnterType, ConstructTApp] - (emptyHole `ann` (tcon "List" `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tList `tapp` tEmptyHole)) unit_refine_1 :: Assertion unit_refine_1 = @@ -929,39 +931,39 @@ unit_refine_1 = (\case RefineError _ -> True; _ -> False) NoSmartHoles emptyHole - [ConstructRefinedCon "Nil"] + [constructRefinedCon cNil] unit_refine_2 :: Assertion unit_refine_2 = actionTest NoSmartHoles - (emptyHole `ann` (tcon "List" `tapp` tcon "Nat")) - [Move Child1, ConstructRefinedCon "Nil"] - ((con "Nil" `aPP` tcon "Nat") `ann` (tcon "List" `tapp` tcon "Nat")) + (emptyHole `ann` (tcon tList `tapp` tcon tNat)) + [Move Child1, constructRefinedCon cNil] + ((con cNil `aPP` tcon tNat) `ann` (tcon tList `tapp` tcon tNat)) unit_refine_3 :: Assertion unit_refine_3 = actionTest NoSmartHoles - (emptyHole `ann` (tcon "List" `tapp` tEmptyHole)) - [Move Child1, ConstructRefinedCon "Nil"] - ((con "Nil" `aPP` tEmptyHole) `ann` (tcon "List" `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tList `tapp` tEmptyHole)) + [Move Child1, constructRefinedCon cNil] + ((con cNil `aPP` tEmptyHole) `ann` (tcon tList `tapp` tEmptyHole)) unit_refine_4 :: Assertion unit_refine_4 = actionTest NoSmartHoles - (let_ "nil" (con "Nil") $ emptyHole `ann` (tcon "List" `tapp` tcon "Nat")) + (let_ "nil" (con cNil) $ emptyHole `ann` (tcon tList `tapp` tcon tNat)) [Move Child2, Move Child1, InsertRefinedVar $ LocalVarRef "nil"] - (let_ "nil" (con "Nil") $ (lvar "nil" `aPP` tcon "Nat") `ann` (tcon "List" `tapp` tcon "Nat")) + (let_ "nil" (con cNil) $ (lvar "nil" `aPP` tcon tNat) `ann` (tcon tList `tapp` tcon tNat)) unit_refine_5 :: Assertion unit_refine_5 = actionTest NoSmartHoles - (let_ "nil" (con "Nil") $ emptyHole `ann` (tcon "List" `tapp` tEmptyHole)) + (let_ "nil" (con cNil) $ emptyHole `ann` (tcon tList `tapp` tEmptyHole)) [Move Child2, Move Child1, InsertRefinedVar $ LocalVarRef "nil"] - (let_ "nil" (con "Nil") $ (lvar "nil" `aPP` tEmptyHole) `ann` (tcon "List" `tapp` tEmptyHole)) + (let_ "nil" (con cNil) $ (lvar "nil" `aPP` tEmptyHole) `ann` (tcon tList `tapp` tEmptyHole)) -- * Helpers diff --git a/primer/test/Tests/Action/Available.hs b/primer/test/Tests/Action/Available.hs index 57bed0476..0f6fe5860 100644 --- a/primer/test/Tests/Action/Available.hs +++ b/primer/test/Tests/Action/Available.hs @@ -11,6 +11,7 @@ import qualified Data.Text.Lazy as TL import Optics (adjoin, toListOf, (%)) import Primer.Action (ActionName (..), OfferedAction (name)) import Primer.Action.Available (actionsForDef, actionsForDefBody, actionsForDefSig) +import Primer.Builtins import Primer.Core ( ASTDef (..), GlobalName (baseName), @@ -66,14 +67,14 @@ test_1 = ((astDefExpr, astDefType), _) = create $ (,) <$> e <*> t t = tfun - (tcon "Nat") + (tcon tNat) ( tforall "a" KType ( tapp ( thole ( tapp - (tcon "List") + (tcon tList) tEmptyHole ) ) @@ -83,19 +84,19 @@ test_1 = e = let_ "x" - (con "True") + (con cTrue) ( letrec "y" ( app ( hole - (con "Just") + (con cJust) ) ( hole (gvar "0") ) ) ( thole - (tcon "Maybe") + (tcon tMaybe) ) ( ann ( lam @@ -106,9 +107,9 @@ test_1 = ( aPP ( letType "b" - (tcon "Bool") + (tcon tBool) ( aPP - (con "Left") + (con cLeft) (tvar "b") ) ) @@ -117,11 +118,11 @@ test_1 = ( case_ (lvar "i") [ branch - "Zero" + cZero [] - (con "False") + (con cFalse) , branch - "Succ" + cSucc [ ( "n" , Nothing @@ -140,14 +141,14 @@ test_1 = ) ) ( tfun - (tcon "Nat") + (tcon tNat) ( tforall "α" KType ( tapp ( tapp - (tcon "Either") - (tcon "Bool") + (tcon tEither) + (tcon tBool) ) (tvar "α") ) diff --git a/primer/test/Tests/Action/Capture.hs b/primer/test/Tests/Action/Capture.hs index a16eac380..544419872 100644 --- a/primer/test/Tests/Action/Capture.hs +++ b/primer/test/Tests/Action/Capture.hs @@ -8,6 +8,7 @@ import Primer.Action ( ActionError (NameCapture, NeedEmptyHole), Movement (..), ) +import Primer.Builtins import Primer.Core ( Kind (KType), ) @@ -161,7 +162,7 @@ unit_ty_tm_same_namespace = actionTestExpectFail isNameCapture NoSmartHoles - (ann (lAM "a" $ con "Nil" `aPP` tvar "a") tEmptyHole) + (ann (lAM "a" $ con cNil `aPP` tvar "a") tEmptyHole) [Move Child1, Move Child1, ConstructLam (Just "a")] -- * Helpers diff --git a/primer/test/Tests/Action/Prog.hs b/primer/test/Tests/Action/Prog.hs index 87975204a..d68f2068d 100644 --- a/primer/test/Tests/Action/Prog.hs +++ b/primer/test/Tests/Action/Prog.hs @@ -14,7 +14,6 @@ import Primer.Action ( ConstructArrowL, ConstructLam, ConstructLet, - ConstructTCon, ConstructVar, Delete, EnterType, @@ -44,6 +43,7 @@ import Primer.App ( newProg, tcWholeProg, ) +import Primer.Builtins (cCons, cJust, cMakePair, cNil, tBool, tList, tMaybe, tPair) import Primer.Core ( ASTDef (..), ASTTypeDef (..), @@ -92,10 +92,11 @@ import Primer.Core.DSL ( import Primer.Core.Utils (forgetIDs) import Primer.Module (Module (moduleDefs, moduleTypes)) import Primer.Name +import Primer.Primitives (tChar, tInt) import Primer.Typecheck (mkTypeDefMap) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import TestM (TestM, evalTestM) -import TestUtils (withPrimDefs) +import TestUtils (constructTCon, withPrimDefs) import Tests.Typecheck (checkProgWellFormed) unit_empty_actions_only_change_the_log :: Assertion @@ -421,15 +422,15 @@ unit_sigaction_creates_holes = let acts = [ -- main :: Char MoveToDef "main" - , SigAction [ConstructTCon "Char"] + , SigAction [constructTCon tChar] , -- other :: Char; other = main MoveToDef "other" - , SigAction [ConstructTCon "Char"] + , SigAction [constructTCon tChar] , BodyAction [ConstructVar $ GlobalVarRef "main"] , -- main :: Int -- We expect this to change 'other' to contain a hole MoveToDef "main" - , SigAction [Delete, ConstructTCon "Int"] + , SigAction [Delete, constructTCon tInt] ] in progActionTest defaultFullProg acts $ expectSuccess $ \_ prog' -> @@ -444,8 +445,8 @@ unit_sigaction_creates_holes = unit_copy_paste_duplicate :: Assertion unit_copy_paste_duplicate = do let ((p, fromType, fromExpr, _toType, _toExpr), maxID) = create $ do - mainType <- tforall "a" KType (tvar "a" `tfun` (tcon "Maybe" `tapp` tEmptyHole)) - mainExpr <- lAM "b" $ lam "x" $ con "Just" `aPP` tvar "b" `app` lvar "x" + mainType <- tforall "a" KType (tvar "a" `tfun` (tcon tMaybe `tapp` tEmptyHole)) + mainExpr <- lAM "b" $ lam "x" $ con cJust `aPP` tvar "b" `app` lvar "x" let mainDef = ASTDef "main" mainExpr mainType blankDef <- ASTDef "blank" <$> emptyHole <*> tEmptyHole pure @@ -539,18 +540,18 @@ unit_raise = do unit_copy_paste_expr_1 :: Assertion unit_copy_paste_expr_1 = do let ((pInitial, srcID, pExpected), maxID) = create $ do - ty <- tforall "a" KType $ (tcon "List" `tapp` tvar "a") `tfun` tforall "b" KType (tvar "b" `tfun` (tcon "Pair" `tapp` tvar "a" `tapp` tvar "b")) - let toCopy' = con "MakePair" `aPP` tvar "a" `aPP` tvar "b" `app` lvar "y" `app` lvar "z" -- want different IDs for the two occurences in expected + ty <- tforall "a" KType $ (tcon tList `tapp` tvar "a") `tfun` tforall "b" KType (tvar "b" `tfun` (tcon tPair `tapp` tvar "a" `tapp` tvar "b")) + let toCopy' = con cMakePair `aPP` tvar "a" `aPP` tvar "b" `app` lvar "y" `app` lvar "z" -- want different IDs for the two occurences in expected toCopy <- toCopy' let skel r = lAM "a" $ lam "x" $ case_ (lvar "x") - [ branch "Nil" [] r - , branch "Cons" [("y", Nothing), ("ys", Nothing)] $ lAM "b" $ lam "z" $ pure toCopy + [ branch cNil [] r + , branch cCons [("y", Nothing), ("ys", Nothing)] $ lAM "b" $ lam "z" $ pure toCopy ] - expectPasted <- con "MakePair" `aPP` tvar "a" `aPP` tEmptyHole `app` emptyHole `app` emptyHole + expectPasted <- con cMakePair `aPP` tvar "a" `aPP` tEmptyHole `app` emptyHole `app` emptyHole -- TODO: in the future we may want to insert let bindings for variables -- which are out of scope in the target, and produce something like -- expectPasted <- letType "b" tEmptyHole $ let_ "y" (emptyHole `ann` tvar "a") $ let_ "z" (emptyHole `ann` tvar "b") toCopy' @@ -562,7 +563,7 @@ unit_copy_paste_expr_1 = do , newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST expected)] ) let a = newApp{appProg = pInitial} - actions = [MoveToDef "main", CopyPasteBody ("main", srcID) [Move Child1, Move Child1, Move (Branch "Nil")]] + actions = [MoveToDef "main", CopyPasteBody ("main", srcID) [Move Child1, Move Child1, Move (Branch cNil)]] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg pExpected <*> handleEditRequest actions case result of Left e -> assertFailure $ show e @@ -575,7 +576,7 @@ unit_copy_paste_expr_1 = do unit_copy_paste_ann :: Assertion unit_copy_paste_ann = do let ((p, fromAnn), maxID) = create $ do - toCopy <- tcon "Bool" + toCopy <- tcon tBool mainDef <- ASTDef "main" <$> emptyHole `ann` pure toCopy <*> tEmptyHole blankDef <- ASTDef "blank" <$> emptyHole `ann` tEmptyHole <*> tEmptyHole pure @@ -600,9 +601,9 @@ unit_copy_paste_ann = do unit_copy_paste_ann2sig :: Assertion unit_copy_paste_ann2sig = do let ((pInitial, srcID, pExpected), maxID) = create $ do - toCopy <- tcon "Bool" + toCopy <- tcon tBool defInitial <- ASTDef "main" <$> emptyHole `ann` pure toCopy <*> tEmptyHole - expected <- ASTDef "main" <$> emptyHole `ann` pure toCopy <*> tcon "Bool" + expected <- ASTDef "main" <$> emptyHole `ann` pure toCopy <*> tcon tBool pure ( newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] , getID toCopy @@ -622,9 +623,9 @@ unit_copy_paste_ann2sig = do unit_copy_paste_sig2ann :: Assertion unit_copy_paste_sig2ann = do let ((pInitial, srcID, pExpected), maxID) = create $ do - toCopy <- tcon "Bool" + toCopy <- tcon tBool defInitial <- ASTDef "main" <$> emptyHole <*> pure toCopy - expected <- ASTDef "main" <$> emptyHole `ann` tcon "Bool" <*> pure toCopy + expected <- ASTDef "main" <$> emptyHole `ann` tcon tBool <*> pure toCopy pure ( newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] , getID toCopy @@ -672,7 +673,7 @@ unit_import_reference = _ <- handleEditRequest [ MoveToDef i - , SigAction [ConstructTCon "Char"] + , SigAction [constructTCon tChar] , BodyAction [ConstructVar $ GlobalVarRef $ defName toUpperDef] ] pure $ pure () diff --git a/primer/test/Tests/AlphaEquality.hs b/primer/test/Tests/AlphaEquality.hs index 88e1d097b..69419bacb 100644 --- a/primer/test/Tests/AlphaEquality.hs +++ b/primer/test/Tests/AlphaEquality.hs @@ -9,6 +9,7 @@ import Gen.Core.Raw ( ) import Hedgehog hiding (check) import Optics (set) +import Primer.Builtins import Primer.Core ( Kind (KFun, KType), Type', @@ -21,68 +22,68 @@ import Test.Tasty.HUnit hiding (assert) unit_1 :: Assertion unit_1 = assertNotEqual - (create' (tcon "Nat")) - (create' (tcon "Bool")) + (create' (tcon tNat)) + (create' (tcon tBool)) unit_2 :: Assertion unit_2 = (@?=) - (create' (tcon "List" `tapp` tcon "Nat")) - (create' (tcon "List" `tapp` tcon "Nat")) + (create' (tcon tList `tapp` tcon tNat)) + (create' (tcon tList `tapp` tcon tNat)) unit_3 :: Assertion unit_3 = assertNotEqual - (create' (tcon "List" `tapp` tcon "Bool")) - (create' (tcon "List" `tapp` tcon "Nat")) + (create' (tcon tList `tapp` tcon tBool)) + (create' (tcon tList `tapp` tcon tNat)) unit_4 :: Assertion unit_4 = assertNotEqual - (create' (tcon "List" `tapp` tcon "Bool")) - (create' (tcon "Nat")) + (create' (tcon tList `tapp` tcon tBool)) + (create' (tcon tNat)) unit_5 :: Assertion unit_5 = assertNotEqual - (create' (tforall "a" KType $ tcon "List" `tapp` tvar "a")) - (create' (tcon "Nat")) + (create' (tforall "a" KType $ tcon tList `tapp` tvar "a")) + (create' (tcon tNat)) unit_6 :: Assertion unit_6 = (@?=) - (create' (tforall "a" KType $ tcon "List" `tapp` tvar "a")) - (create' (tforall "b" KType $ tcon "List" `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 "List" `tapp` tvar "a")) - (create' (tforall "b" KType $ tcon "List" `tapp` tcon "Bool")) + (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 "Bool")) - (create' (tforall "b" (KFun KType KType) $ tcon "Bool")) + (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 "List" `tapp` tvar "a")) - (create' (tforall "a" KType $ tforall "b" KType $ tcon "List" `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 "List" `tapp` tvar "a")) - (create' (tcon "List" `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 "Bool" `tfun` (tcon "List" `tapp` tvar "a"))) - (create' (tcon "Bool" `tfun` tforall "a" KType (tcon "List" `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 diff --git a/primer/test/Tests/Eval.hs b/primer/test/Tests/Eval.hs index 54a578bda..8cd988ab3 100644 --- a/primer/test/Tests/Eval.hs +++ b/primer/test/Tests/Eval.hs @@ -16,7 +16,14 @@ import Primer.App ( importModules, newEmptyApp, ) -import Primer.Builtins (boolDef) +import Primer.Builtins ( + boolDef, + cFalse, + cNil, + cTrue, + cZero, + tBool, + ) import Primer.Core ( ASTDef (..), Def (..), @@ -47,6 +54,7 @@ import Primer.Eval ( tryReduceType, ) import Primer.Module (Module (Module, moduleDefs, moduleTypes)) +import Primer.Primitives (primitiveGVar, tChar) import Primer.Typecheck (mkTypeDefMap) import Primer.Zipper (target) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=)) @@ -65,7 +73,7 @@ runTryReduceType globals locals (ty, i) = evalTestM i $ runExceptT $ tryReduceTy unit_tryReduce_no_redex :: Assertion unit_tryReduce_no_redex = do - runTryReduce mempty mempty (create (con "Zero")) @?= Left NotRedex + runTryReduce mempty mempty (create (con cZero)) @?= Left NotRedex unit_tryReduce_beta :: Assertion unit_tryReduce_beta = do @@ -73,7 +81,7 @@ unit_tryReduce_beta = do create $ do x <- lvar "x" l <- lam "x" (pure x) - a <- con "Zero" + a <- con cZero i <- app (pure l) (pure a) r <- let_ "x" (pure a) (pure x) pure (l, x, a, i, r) @@ -231,9 +239,9 @@ unit_tryReduce_BETA :: Assertion unit_tryReduce_BETA = do let ((body, lambda, arg, input, expectedResult), maxid) = create $ do - b <- aPP (con "Nil") (tvar "x") + b <- aPP (con cNil) (tvar "x") l <- lAM "x" (pure b) - a <- tcon "Bool" + a <- tcon tBool i <- aPP (pure l) (pure a) r <- letType "x" (pure a) (pure b) pure (b, l, a, i, r) @@ -523,8 +531,8 @@ unit_tryReduce_prim = do let ((expr, expectedResult, globals), i) = create . withPrimDefs $ \m -> (,,) - <$> gvar "eqChar" `app` char 'a' `app` char 'a' - <*> con "True" + <$> gvar (primitiveGVar "eqChar") `app` char 'a' `app` char 'a' + <*> con cTrue <*> pure m result = runTryReduce (DefPrim <$> globals) mempty (expr, i) case result of @@ -533,7 +541,7 @@ unit_tryReduce_prim = do applyPrimFunBefore detail ~= expr applyPrimFunAfter detail ~= expr' - applyPrimFunName detail @?= "eqChar" + applyPrimFunName detail @?= primitiveGVar "eqChar" applyPrimFunArgIDs detail @?= [101, 102] _ -> assertFailure $ show result @@ -542,7 +550,7 @@ unit_tryReduce_prim_fail_unsaturated = do let ((expr, globals), i) = create . withPrimDefs $ \m -> (,) - <$> gvar "eqChar" `app` char 'a' + <$> gvar (primitiveGVar "eqChar") `app` char 'a' <*> pure m result = runTryReduce (DefPrim <$> globals) mempty (expr, i) result @?= Left NotRedex @@ -552,7 +560,7 @@ unit_tryReduce_prim_fail_unreduced_args = do let ((expr, globals), i) = create . withPrimDefs $ \m -> (,) - <$> gvar "eqChar" `app` char 'a' `app` (gvar "toUpper" `app` char 'a') + <$> gvar (primitiveGVar "eqChar") `app` char 'a' `app` (gvar (primitiveGVar "toUpper") `app` char 'a') <*> pure m result = runTryReduce (DefPrim <$> globals) mempty (expr, i) result @?= Left NotRedex @@ -790,24 +798,24 @@ unit_redexes_case_5 = unit_redexes_prim_1 :: Assertion unit_redexes_prim_1 = - redexesOfWithPrims (gvar "eqChar" `app` char 'a' `app` char 'b') @?= Set.fromList [98] + redexesOfWithPrims (gvar (primitiveGVar "eqChar") `app` char 'a' `app` char 'b') @?= Set.fromList [98] unit_redexes_prim_2 :: Assertion unit_redexes_prim_2 = - redexesOfWithPrims (gvar "eqChar" `app` lvar "a" `app` char 'b') @?= Set.empty + redexesOfWithPrims (gvar (primitiveGVar "eqChar") `app` lvar "a" `app` char 'b') @?= Set.empty unit_redexes_prim_3 :: Assertion unit_redexes_prim_3 = - redexesOfWithPrims (gvar "eqChar" `app` char 'a') @?= Set.empty + redexesOfWithPrims (gvar (primitiveGVar "eqChar") `app` char 'a') @?= Set.empty unit_redexes_prim_ann :: Assertion unit_redexes_prim_ann = redexesOfWithPrims expr @?= Set.singleton 98 where expr = - gvar "toUpper" - `ann` (tcon "Char" `tfun` tcon "Char") - `app` (char 'a' `ann` tcon "Char") + gvar (primitiveGVar "toUpper") + `ann` (tcon tChar `tfun` tcon tChar) + `app` (char 'a' `ann` tcon tChar) -- Test that handleEvalRequest will reduce imported terms unit_eval_modules :: Assertion @@ -815,7 +823,7 @@ unit_eval_modules = let test = do p <- defaultFullProg importModules [progModule p] - foo <- gvar "toUpper" `app` char 'a' + foo <- gvar (primitiveGVar "toUpper") `app` char 'a' EvalResp{evalRespExpr = e} <- handleEvalRequest EvalReq{evalReqExpr = foo, evalReqRedex = getID foo} @@ -831,11 +839,11 @@ unit_eval_modules_scrutinize_imported_type :: Assertion unit_eval_modules_scrutinize_imported_type = let test = do importModules [m] - foo <- case_ (con "True") [branch "True" [] $ con "False", branch "False" [] $ con "True"] + foo <- case_ (con cTrue) [branch cTrue [] $ con cFalse, branch cFalse [] $ con cTrue] EvalResp{evalRespExpr = e} <- handleEvalRequest EvalReq{evalReqExpr = foo, evalReqRedex = getID foo} - expect <- con "False" + expect <- con cFalse pure $ e ~= expect a = newEmptyApp in case fst $ runAppTestM (ID $ appIdCounter a) a test of diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs index d96a0dadb..8fa78a868 100644 --- a/primer/test/Tests/EvalFull.hs +++ b/primer/test/Tests/EvalFull.hs @@ -24,13 +24,13 @@ import Primer.App ( importModules, newEmptyApp, ) -import Primer.Builtins (boolDef) +import Primer.Builtins import Primer.Core import Primer.Core.DSL import Primer.Core.Utils (forgetIDs, forgetTypeIDs, generateIDs, generateTypeIDs) import Primer.EvalFull import Primer.Module (Module (Module, moduleDefs, moduleTypes)) -import Primer.Primitives (allPrimDefs) +import Primer.Primitives (allPrimDefs, primitiveGVar, tChar, tInt) import Primer.Typecheck ( SmartHoles (NoSmartHoles), buildTypingContext, @@ -98,8 +98,8 @@ unit_4 = unit_5 :: Assertion unit_5 = let ((e, expt), maxID) = create $ do - a <- letrec "x" (lvar "x") (tcon "Bool") (lvar "x") - b <- letrec "x" (lvar "x") (tcon "Bool") (lvar "x" `ann` tcon "Bool") `ann` tcon "Bool" + a <- letrec "x" (lvar "x") (tcon tBool) (lvar "x") + b <- letrec "x" (lvar "x") (tcon tBool) (lvar "x" `ann` tcon tBool) `ann` tcon tBool pure (a, b) s = evalFullTest maxID mempty mempty 100 Syn e in do @@ -109,8 +109,8 @@ unit_5 = unit_6 :: Assertion unit_6 = let ((e, expt), maxID) = create $ do - tr <- con "True" - an <- ann (pure tr) (tcon "Bool") + tr <- con cTrue + an <- ann (pure tr) (tcon tBool) pure (an, tr) s = evalFullTest maxID mempty mempty 1 Syn e t = evalFullTest maxID mempty mempty 2 Chk e @@ -139,7 +139,7 @@ unit_8 :: Assertion unit_8 = let n = 10 ((globals, e, expected), maxID) = create $ do - mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon "List" `tapp` tvar "a") `tfun` (tcon "List" `tapp` tvar "b")) + mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) map_ <- lAM "a" $ lAM "b" $ @@ -147,23 +147,23 @@ unit_8 = lam "xs" $ case_ (lvar "xs") - [ branch "Nil" [] $ con "Nil" `aPP` tvar "b" - , branch "Cons" [("y", Nothing), ("ys", Nothing)] $ con "Cons" `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (gvar "map" `aPP` tvar "a" `aPP` tvar "b" `app` lvar "f" `app` lvar "ys") + [ branch cNil [] $ con cNil `aPP` tvar "b" + , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cCons `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (gvar "map" `aPP` tvar "a" `aPP` tvar "b" `app` lvar "f" `app` lvar "ys") ] -- even and odd have almost the same type, but their types contain different IDs - let evenOddTy = tcon "Nat" `tfun` tcon "Bool" + let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy oddTy <- evenOddTy - isEven <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "True", branch "Succ" [("n", Nothing)] $ gvar "odd" `app` lvar "n"] - isOdd <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "False", branch "Succ" [("n", Nothing)] $ gvar "even" `app` lvar "n"] - let mkList t = foldr (\x xs -> con "Cons" `aPP` t `app` x `app` xs) (con "Nil" `aPP` t) - let lst = mkList (tcon "Nat") $ take n $ iterate (con "Succ" `app`) (con "Zero") - expr <- gvar "map" `aPP` tcon "Nat" `aPP` tcon "Bool" `app` gvar "even" `app` lst + isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar "odd" `app` lvar "n"] + isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar "even" `app` lvar "n"] + let mkList t = foldr (\x xs -> con cCons `aPP` t `app` x `app` xs) (con cNil `aPP` t) + let lst = mkList (tcon tNat) $ take n $ iterate (con cSucc `app`) (con cZero) + expr <- gvar "map" `aPP` tcon tNat `aPP` tcon tBool `app` gvar "even" `app` lst let mapDef = DefAST $ ASTDef "map" map_ mapTy let evenDef = DefAST $ ASTDef "even" isEven evenTy let oddDef = DefAST $ ASTDef "odd" isOdd oddTy let globs = [("map", mapDef), ("even", evenDef), ("odd", oddDef)] - expect <- mkList (tcon "Bool") (take n $ cycle [con "True", con "False"]) `ann` (tcon "List" `tapp` tcon "Bool") + expect <- mkList (tcon tBool) (take n $ cycle [con cTrue, con cFalse]) `ann` (tcon tList `tapp` tcon tBool) pure (globs, expr, expect) in do case evalFullTest maxID defaultTypeDefs (M.fromList globals) 500 Syn e of @@ -178,29 +178,29 @@ unit_9 :: Assertion unit_9 = let n = 10 ((globals, e, expected), maxID) = create $ do - mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon "List" `tapp` tvar "a") `tfun` (tcon "List" `tapp` tvar "b")) + mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) let worker = lam "xs" $ case_ (lvar "xs") - [ branch "Nil" [] $ con "Nil" `aPP` tvar "b" - , branch "Cons" [("y", Nothing), ("ys", Nothing)] $ con "Cons" `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (lvar "go" `app` lvar "ys") + [ branch cNil [] $ con cNil `aPP` tvar "b" + , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cCons `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (lvar "go" `app` lvar "ys") ] - map_ <- lAM "a" $ lAM "b" $ lam "f" $ letrec "go" worker ((tcon "List" `tapp` tvar "a") `tfun` (tcon "List" `tapp` tvar "b")) $ lvar "go" + map_ <- lAM "a" $ lAM "b" $ lam "f" $ letrec "go" worker ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) $ lvar "go" -- even and odd have almost the same type, but their types contain different IDs - let evenOddTy = tcon "Nat" `tfun` tcon "Bool" + let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy oddTy <- evenOddTy - isEven <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "True", branch "Succ" [("n", Nothing)] $ gvar "odd" `app` lvar "n"] - isOdd <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "False", branch "Succ" [("n", Nothing)] $ gvar "even" `app` lvar "n"] - let mkList t = foldr (\x xs -> con "Cons" `aPP` t `app` x `app` xs) (con "Nil" `aPP` t) - let lst = mkList (tcon "Nat") $ take n $ iterate (con "Succ" `app`) (con "Zero") - expr <- gvar "map" `aPP` tcon "Nat" `aPP` tcon "Bool" `app` gvar "even" `app` lst + isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar "odd" `app` lvar "n"] + isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar "even" `app` lvar "n"] + let mkList t = foldr (\x xs -> con cCons `aPP` t `app` x `app` xs) (con cNil `aPP` t) + let lst = mkList (tcon tNat) $ take n $ iterate (con cSucc `app`) (con cZero) + expr <- gvar "map" `aPP` tcon tNat `aPP` tcon tBool `app` gvar "even" `app` lst let mapDef = DefAST $ ASTDef "map" map_ mapTy let evenDef = DefAST $ ASTDef "even" isEven evenTy let oddDef = DefAST $ ASTDef "odd" isOdd oddTy let globs = [("map", mapDef), ("even", evenDef), ("odd", oddDef)] - expect <- mkList (tcon "Bool") (take n $ cycle [con "True", con "False"]) `ann` (tcon "List" `tapp` tcon "Bool") + expect <- mkList (tcon tBool) (take n $ cycle [con cTrue, con cFalse]) `ann` (tcon tList `tapp` tcon tBool) pure (globs, expr, expect) in do case evalFullTest maxID defaultTypeDefs (M.fromList globals) 500 Syn e of @@ -219,17 +219,17 @@ unit_10 = let ((s, t, expected), maxID) = create $ do annCase <- case_ - (con "Zero" `ann` tcon "Nat") - [ branch "Zero" [] $ con "True" - , branch "Succ" [("n", Nothing)] $ con "False" + (con cZero `ann` tcon tNat) + [ branch cZero [] $ con cTrue + , branch cSucc [("n", Nothing)] $ con cFalse ] noannCase <- case_ - (con "Zero") - [ branch "Zero" [] $ con "True" - , branch "Succ" [("n", Nothing)] $ con "False" + (con cZero) + [ branch cZero [] $ con cTrue + , branch cSucc [("n", Nothing)] $ con cFalse ] - expect <- con "True" + expect <- con cTrue pure (annCase, noannCase, expect) in do let s' = evalFullTest maxID defaultTypeDefs mempty 2 Syn s @@ -245,23 +245,24 @@ unit_11 :: Assertion unit_11 = let ((globals, e, expected), maxID) = create $ do -- even and odd have almost the same type, but their types contain different IDs - let evenOddTy = tcon "Nat" `tfun` tcon "Bool" + let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy oddTy <- evenOddTy - isEven <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "True", branch "Succ" [("n", Nothing)] $ gvar "odd" `app` lvar "n"] - isOdd <- lam "x" $ case_ (lvar "x") [branch "Zero" [] $ con "False", branch "Succ" [("n", Nothing)] $ gvar "even" `app` lvar "n"] - let ty = tcon "Nat" `tfun` (tcon "Pair" `tapp` tcon "Bool" `tapp` tcon "Nat") + isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar "odd" `app` lvar "n"] + isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar "even" `app` lvar "n"] + + let ty = tcon tNat `tfun` (tcon tPair `tapp` tcon tBool `tapp` tcon tNat) let expr1 = - let_ "x" (con "Zero") $ - lam "n" (con "MakePair" `aPP` tcon "Bool" `aPP` tcon "Nat" `app` (gvar "even" `app` lvar "n") `app` lvar "x") + let_ "x" (con cZero) $ + lam "n" (con cMakePair `aPP` tcon tBool `aPP` tcon tNat `app` (gvar "even" `app` lvar "n") `app` lvar "x") `ann` ty - expr <- expr1 `app` con "Zero" + expr <- expr1 `app` con cZero let evenDef = DefAST $ ASTDef "even" isEven evenTy let oddDef = DefAST $ ASTDef "odd" isOdd oddTy let globs = [("even", evenDef), ("odd", oddDef)] expect <- - (con "MakePair" `aPP` tcon "Bool" `aPP` tcon "Nat" `app` con "True" `app` con "Zero") - `ann` (tcon "Pair" `tapp` tcon "Bool" `tapp` tcon "Nat") + (con cMakePair `aPP` tcon tBool `aPP` tcon tNat `app` con cTrue `app` con cZero) + `ann` (tcon tPair `tapp` tcon tBool `tapp` tcon tNat) pure (globs, expr, expect) in do case evalFullTest maxID defaultTypeDefs (M.fromList globals) 10 Syn e of @@ -282,11 +283,11 @@ unit_12 = lam "x" $ case_ (lvar "x") - [ branch "Zero" [] $ con "True" - , branch "Succ" [("i", Nothing)] $ lvar "f" `app` lvar "i" + [ branch cZero [] $ con cTrue + , branch cSucc [("i", Nothing)] $ lvar "f" `app` lvar "i" ] - expr <- let_ "n" (con "Zero") $ letrec "f" f (tcon "Nat" `tfun` tcon "Bool") $ lvar "f" `app` lvar "n" - expect <- con "True" `ann` tcon "Bool" + expr <- let_ "n" (con cZero) $ letrec "f" f (tcon tNat `tfun` tcon tBool) $ lvar "f" `app` lvar "n" + expect <- con cTrue `ann` tcon tBool pure (expr, expect) in do let s = evalFullTest maxID defaultTypeDefs mempty 15 Syn e @@ -296,8 +297,8 @@ unit_12 = unit_13 :: Assertion unit_13 = let ((e, expected), maxID) = create $ do - expr <- (lam "x" (con "C" `app` lvar "x" `app` let_ "x" (con "True") (lvar "x") `app` lvar "x") `ann` (tcon "Nat" `tfun` tcon "Bool")) `app` con "Zero" - expect <- (con "C" `app` con "Zero" `app` con "True" `app` con "Zero") `ann` tcon "Bool" + expr <- (lam "x" (con "C" `app` lvar "x" `app` let_ "x" (con cTrue) (lvar "x") `app` lvar "x") `ann` (tcon tNat `tfun` tcon tBool)) `app` con cZero + expect <- (con "C" `app` con cZero `app` con cTrue `app` con cZero) `ann` tcon tBool pure (expr, expect) in do let s = evalFullTest maxID defaultTypeDefs mempty 15 Syn e @@ -307,8 +308,8 @@ unit_13 = unit_14 :: Assertion unit_14 = let ((e, expected), maxID) = create $ do - expr <- (lam "x" (lam "x" $ lvar "x") `ann` (tcon "Bool" `tfun` (tcon "Nat" `tfun` tcon "Nat"))) `app` con "True" `app` con "Zero" - expect <- con "Zero" `ann` tcon "Nat" + expr <- (lam "x" (lam "x" $ lvar "x") `ann` (tcon tBool `tfun` (tcon tNat `tfun` tcon tNat))) `app` con cTrue `app` con cZero + expect <- con cZero `ann` tcon tNat pure (expr, expect) in do let s = evalFullTest maxID defaultTypeDefs mempty 15 Syn e @@ -349,7 +350,7 @@ unit_15 = unit_hole_ann_case :: Assertion unit_hole_ann_case = - let (tm, maxID) = create $ hole $ ann (case_ emptyHole []) (tcon "Bool") + let (tm, maxID) = create $ hole $ ann (case_ emptyHole []) (tcon tBool) in evalFullTest maxID defaultTypeDefs mempty 1 Chk tm @?= Right tm -- TODO: examples with holes @@ -485,29 +486,29 @@ hprop_prim_hex_nat = withTests 20 . property $ do then create . withPrimDefs $ \globals -> (,,) <$> case_ - ( gvar "natToHex" + ( gvar (primitiveGVar "natToHex") `app` ne ) [ branch - "Nothing" + cNothing [] - (con "Nothing") + (con cNothing) , branch - "Just" + cJust [("x", Nothing)] - ( gvar "hexToNat" + ( gvar (primitiveGVar "hexToNat") `app` lvar "x" ) ] - <*> (con "Just" `aPP` tcon "Nat") + <*> (con cJust `aPP` tcon tNat) `app` ne <*> pure (DefPrim <$> globals) else create . withPrimDefs $ \globals -> (,,) - <$> gvar "natToHex" + <$> gvar (primitiveGVar "natToHex") `app` ne - <*> con "Nothing" - `aPP` tcon "Char" + <*> con cNothing + `aPP` tcon tChar <*> pure (DefPrim <$> globals) s = evalFullTest maxID defaultTypeDefs gs 7 Syn e set _ids' 0 s === set _ids' 0 (Right r) @@ -518,7 +519,7 @@ unit_prim_char_eq_1 = "eqChar" (char 'a') (char 'a') - (con "True") + (con cTrue) unit_prim_char_eq_2 :: Assertion unit_prim_char_eq_2 = @@ -526,14 +527,14 @@ unit_prim_char_eq_2 = "eqChar" (char 'a') (char 'A') - (con "False") + (con cFalse) unit_prim_char_partial :: Assertion unit_prim_char_partial = let ((e, gs), maxID) = create . withPrimDefs $ \globals -> (,) - <$> gvar "eqChar" + <$> gvar (primitiveGVar "eqChar") `app` char 'a' <*> pure (DefPrim <$> globals) s = evalFullTest maxID mempty gs 1 Syn e @@ -589,7 +590,7 @@ unit_prim_int_quotient = "Int.quotient" (int 7) (int 3) - (con "Just" `aPP` tcon "Int" `app` int 2) + (con cJust `aPP` tcon tInt `app` int 2) unit_prim_int_quotient_negative :: Assertion unit_prim_int_quotient_negative = @@ -597,7 +598,7 @@ unit_prim_int_quotient_negative = "Int.quotient" (int (-7)) (int 3) - (con "Just" `aPP` tcon "Int" `app` int (-3)) + (con cJust `aPP` tcon tInt `app` int (-3)) unit_prim_int_quotient_zero :: Assertion unit_prim_int_quotient_zero = @@ -605,7 +606,7 @@ unit_prim_int_quotient_zero = "Int.quotient" (int (-7)) (int 0) - (con "Nothing" `aPP` tcon "Int") + (con cNothing `aPP` tcon tInt) unit_prim_int_remainder :: Assertion unit_prim_int_remainder = @@ -613,7 +614,7 @@ unit_prim_int_remainder = "Int.remainder" (int 7) (int 3) - (con "Just" `aPP` tcon "Int" `app` int 1) + (con cJust `aPP` tcon tInt `app` int 1) unit_prim_int_remainder_negative_1 :: Assertion unit_prim_int_remainder_negative_1 = @@ -621,7 +622,7 @@ unit_prim_int_remainder_negative_1 = "Int.remainder" (int (-7)) (int (-3)) - (con "Just" `aPP` tcon "Int" `app` int (-1)) + (con cJust `aPP` tcon tInt `app` int (-1)) unit_prim_int_remainder_negative_2 :: Assertion unit_prim_int_remainder_negative_2 = @@ -629,7 +630,7 @@ unit_prim_int_remainder_negative_2 = "Int.remainder" (int (-7)) (int 3) - (con "Just" `aPP` tcon "Int" `app` int 2) + (con cJust `aPP` tcon tInt `app` int 2) unit_prim_int_remainder_negative_3 :: Assertion unit_prim_int_remainder_negative_3 = @@ -637,7 +638,7 @@ unit_prim_int_remainder_negative_3 = "Int.remainder" (int 7) (int (-3)) - (con "Just" `aPP` tcon "Int" `app` int (-2)) + (con cJust `aPP` tcon tInt `app` int (-2)) unit_prim_int_remainder_zero :: Assertion unit_prim_int_remainder_zero = @@ -645,7 +646,7 @@ unit_prim_int_remainder_zero = "Int.remainder" (int 7) (int 0) - (con "Nothing" `aPP` tcon "Int") + (con cNothing `aPP` tcon tInt) unit_prim_int_quot :: Assertion unit_prim_int_quot = @@ -828,14 +829,14 @@ unit_prim_int_toNat = unaryPrimTest "Int.toNat" (int 0) - (con "Just" `aPP` tcon "Nat" `app` nat 0) + (con cJust `aPP` tcon tNat `app` nat 0) unit_prim_int_toNat_negative :: Assertion unit_prim_int_toNat_negative = unaryPrimTest "Int.toNat" (int (-1)) - (con "Nothing" `aPP` tcon "Nat") + (con cNothing `aPP` tcon tNat) unit_prim_int_fromNat :: Assertion unit_prim_int_fromNat = @@ -849,10 +850,10 @@ unit_prim_ann = let ((e, r, gs), maxID) = create . withPrimDefs $ \globals -> (,,) - <$> ( gvar "toUpper" - `ann` (tcon "Char" `tfun` tcon "Char") + <$> ( gvar (primitiveGVar "toUpper") + `ann` (tcon tChar `tfun` tcon tChar) ) - `app` (char 'a' `ann` tcon "Char") + `app` (char 'a' `ann` tcon tChar) <*> char 'A' <*> pure (DefPrim <$> globals) s = evalFullTest maxID defaultTypeDefs gs 2 Syn e @@ -867,22 +868,22 @@ unit_prim_partial_map = map_ <- mapDef (,,) <$> gvar (defName map_) - `aPP` tcon "Char" - `aPP` tcon "Char" - `app` gvar "toUpper" + `aPP` tcon tChar + `aPP` tcon tChar + `app` gvar (primitiveGVar "toUpper") `app` list_ - "Char" + tChar [ char 'a' , char 'b' , char 'c' ] <*> list_ - "Char" + tChar [ char 'A' , char 'B' , char 'C' ] - `ann` (tcon "List" `tapp` tcon "Char") + `ann` (tcon tList `tapp` tcon tChar) <*> pure (M.singleton (defName map_) map_ <> (DefPrim <$> globals)) s = evalFullTest maxID defaultTypeDefs gs 65 Syn e in do @@ -891,15 +892,15 @@ unit_prim_partial_map = where mapDef :: MonadFresh ID m => m Def mapDef = do - mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon "List" `tapp` tvar "a") `tfun` (tcon "List" `tapp` tvar "b")) + mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) let worker = lam "xs" $ case_ (lvar "xs") - [ branch "Nil" [] $ con "Nil" `aPP` tvar "b" - , branch "Cons" [("y", Nothing), ("ys", Nothing)] $ con "Cons" `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (lvar "go" `app` lvar "ys") + [ branch cNil [] $ con cNil `aPP` tvar "b" + , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cCons `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (lvar "go" `app` lvar "ys") ] - map_ <- lAM "a" $ lAM "b" $ lam "f" $ letrec "go" worker ((tcon "List" `tapp` tvar "a") `tfun` (tcon "List" `tapp` tvar "b")) $ lvar "go" + map_ <- lAM "a" $ lAM "b" $ lam "f" $ letrec "go" worker ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) $ lvar "go" pure $ DefAST $ ASTDef "map" map_ mapTy -- Test that handleEvalFullRequest will reduce imported terms @@ -908,7 +909,7 @@ unit_eval_full_modules = let test = do p <- defaultFullProg importModules [progModule p] - foo <- gvar "toUpper" `app` char 'a' + foo <- gvar (primitiveGVar "toUpper") `app` char 'a' resp <- handleEvalFullRequest EvalFullReq @@ -930,11 +931,11 @@ unit_eval_full_modules_scrutinize_imported_type :: Assertion unit_eval_full_modules_scrutinize_imported_type = let test = do importModules [m] - foo <- case_ (con "True") [branch "True" [] $ con "False", branch "False" [] $ con "True"] + foo <- case_ (con cTrue) [branch cTrue [] $ con cFalse, branch cFalse [] $ con cTrue] resp <- handleEvalFullRequest EvalFullReq{evalFullReqExpr = foo, evalFullCxtDir = Chk, evalFullMaxSteps = 2} - expect <- con "False" + expect <- con cFalse pure $ case resp of EvalFullRespTimedOut _ -> assertFailure "EvalFull timed out" EvalFullRespNormal e -> e ~= expect @@ -1033,7 +1034,7 @@ withGlobals mdefs prop = do -- Currently: an AST identity function on Char and a primitive @toUpper@. testGlobals :: WT [Def] testGlobals = do - idCharDef <- ASTDef <$> pure "idChar" <*> lam "x" (lvar "x") <*> (tcon "Char" `tfun` tcon "Char") + idCharDef <- ASTDef <$> pure "idChar" <*> lam "x" (lvar "x") <*> (tcon tChar `tfun` tcon tChar) let toUpperFun = allPrimDefs ! "toUpper" toUpperDef <- PrimDef <$> pure "toUpper" <*> primFunType toUpperFun pure [DefAST idCharDef, DefPrim toUpperDef] diff --git a/primer/test/Tests/FreeVars.hs b/primer/test/Tests/FreeVars.hs index 6f7782969..1d20a1d84 100644 --- a/primer/test/Tests/FreeVars.hs +++ b/primer/test/Tests/FreeVars.hs @@ -3,6 +3,7 @@ module Tests.FreeVars where import Foreword import qualified Data.Set as Set +import Primer.Builtins import Primer.Core (Kind (KType)) import Primer.Core.DSL import Primer.Core.Utils @@ -22,8 +23,8 @@ unit_2 = ( lam "x" $ case_ (lvar "x") - [ branch "Zero" [] $ con "True" - , branch "Succ" [("n", Nothing)] (app (lvar "f") (lvar "n")) + [ branch cZero [] $ con cTrue + , branch cSucc [("n", Nothing)] (app (lvar "f") (lvar "n")) ] ) (lvar "y") diff --git a/primer/test/Tests/Primitives.hs b/primer/test/Tests/Primitives.hs index 4d72378fc..d77e7c1d7 100644 --- a/primer/test/Tests/Primitives.hs +++ b/primer/test/Tests/Primitives.hs @@ -22,7 +22,7 @@ import Primer.Core ( primConName, ) import Primer.Core.DSL (char, tcon) -import Primer.Primitives (allPrimTypeDefs) +import Primer.Primitives (allPrimTypeDefs, tChar) import Primer.Typecheck ( SmartHoles (NoSmartHoles), TypeError (PrimitiveTypeNotInScope, UnknownTypeConstructor), @@ -46,8 +46,8 @@ hprop_all_prim_cons_have_typedef = propertyWT (buildTypingContext defaultTypeDef unit_prim_con_scope :: Assertion unit_prim_con_scope = do -- Char is indeed not in scope - test (checkKind KType =<< tcon "Char") @?= Left (UnknownTypeConstructor "Char") - test (synth =<< char 'a') @?= Left (PrimitiveTypeNotInScope "Char") + test (checkKind KType =<< tcon tChar) @?= Left (UnknownTypeConstructor tChar) + test (synth =<< char 'a') @?= Left (PrimitiveTypeNotInScope tChar) where cxt = buildTypingContext mempty mempty NoSmartHoles test = runTypecheckTestMFromIn 0 cxt @@ -61,13 +61,13 @@ unit_prim_con_scope_ast = do -- Char is in scope (though the wrong kind to accept 'PrimChar's!) assertBool "Char is not in scope?" $ isRight $ - test $ checkKind (KType `KFun` KType) =<< tcon "Char" - test (synth =<< char 'a') @?= Left (PrimitiveTypeNotInScope "Char") + test $ checkKind (KType `KFun` KType) =<< tcon tChar + test (synth =<< char 'a') @?= Left (PrimitiveTypeNotInScope tChar) where charASTDef = TypeDefAST $ ASTTypeDef - { astTypeDefName = "Char" + { astTypeDefName = tChar , astTypeDefParameters = [("a", KType)] , astTypeDefConstructors = mempty , astTypeDefNameHints = mempty diff --git a/primer/test/Tests/Question.hs b/primer/test/Tests/Question.hs index 3ae4dda8d..471c5c147 100644 --- a/primer/test/Tests/Question.hs +++ b/primer/test/Tests/Question.hs @@ -10,6 +10,7 @@ import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Primer.App (defaultTypeDefs) +import Primer.Builtins import Primer.Core ( Expr, GVarName, @@ -164,46 +165,46 @@ unit_variablesInScope_empty = -- Given a single lambda, we return just the variable it binds unit_variablesInScope_lambda :: Assertion unit_variablesInScope_lambda = do - let expr = ann (lam "x" emptyHole) (tfun (tcon "Bool") (tcon "Bool")) + let expr = ann (lam "x" emptyHole) (tfun (tcon tBool) (tcon tBool)) hasVariables expr pure [] hasVariables expr down [] - hasVariables expr (down >=> down) [("x", TCon () "Bool")] + hasVariables expr (down >=> down) [("x", TCon () tBool)] -- Given a let, its bound variable is in scope in the body but not the bound expression unit_variablesInScope_let :: Assertion unit_variablesInScope_let = do - let oneLet = let_ "x" (con "True") emptyHole - twoLet = let_ "x" (con "True") (let_ "y" (con "Zero") emptyHole) + let oneLet = let_ "x" (con cTrue) emptyHole + twoLet = let_ "x" (con cTrue) (let_ "y" (con cZero) emptyHole) hasVariables oneLet pure mempty hasVariables oneLet down mempty - hasVariables oneLet (down >=> right) [("x", TCon () "Bool")] + hasVariables oneLet (down >=> right) [("x", TCon () tBool)] hasVariables twoLet (down >=> right >=> down) - [("x", TCon () "Bool")] + [("x", TCon () tBool)] hasVariables twoLet (down >=> right >=> down >=> right) - [("x", TCon () "Bool"), ("y", TCon () "Nat")] + [("x", TCon () tBool), ("y", TCon () tNat)] -- Given a letrec, its bound variable is in scope in both the body and the bound expression unit_variablesInScope_letrec :: Assertion unit_variablesInScope_letrec = do - let expr = letrec "x" (con "True") (tcon "Bool") emptyHole + let expr = letrec "x" (con cTrue) (tcon tBool) emptyHole hasVariables expr pure [] - hasVariables expr down [("x", TCon () "Bool")] - hasVariables expr (down >=> right) [("x", TCon () "Bool")] + hasVariables expr down [("x", TCon () tBool)] + hasVariables expr (down >=> right) [("x", TCon () tBool)] -- Given a case expression, any variables bound by its branches are in scope in their corresponding -- LHS. unit_variablesInScope_case :: Assertion unit_variablesInScope_case = do - let expr = ann (case_ (con "Zero") [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole]) (tcon "Nat") + let expr = ann (case_ (con cZero) [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole]) (tcon tNat) hasVariables expr pure [] hasVariables expr down [] hasVariables expr (down >=> down) [] hasVariables expr (down >=> down >=> right) [] - hasVariables expr (down >=> down >=> right >=> right) [("n", TCon () "Nat")] + hasVariables expr (down >=> down >=> right >=> right) [("n", TCon () tNat)] unit_variablesInScope_type :: Assertion unit_variablesInScope_type = do @@ -216,8 +217,8 @@ unit_variablesInScope_type = do unit_variablesInScope_shadowed :: Assertion unit_variablesInScope_shadowed = do - let ty = tforall "a" (KFun KType KType) $ tforall "b" KType $ tcon "Nat" `tfun` tforall "a" KType (tcon "Bool" `tfun` (tcon "List" `tapp` tvar "b")) - expr' = lAM "c" $ lAM "d" $ lam "c" $ lAM "c" $ lam "c" $ con "Nil" `aPP` tvar "d" + let ty = tforall "a" (KFun KType KType) $ tforall "b" KType $ tcon tNat `tfun` tforall "a" KType (tcon tBool `tfun` (tcon tList `tapp` tvar "b")) + expr' = lAM "c" $ lAM "d" $ lam "c" $ lAM "c" $ lam "c" $ con cNil `aPP` tvar "d" expr = ann expr' ty hasVariablesType ty pure [] hasVariablesType ty down [("a", KFun KType KType)] @@ -227,9 +228,9 @@ unit_variablesInScope_shadowed = do hasVariablesTyTm expr pure [] [] hasVariablesTyTm expr (down >=> down) [("c", KFun KType KType)] [] hasVariablesTyTm expr (down >=> down >=> down) [("c", KFun KType KType), ("d", KType)] [] - hasVariablesTyTm expr (down >=> down >=> down >=> down) [("d", KType)] [("c", TCon () "Nat")] + hasVariablesTyTm expr (down >=> down >=> down >=> down) [("d", KType)] [("c", TCon () tNat)] hasVariablesTyTm expr (down >=> down >=> down >=> down >=> down) [("d", KType), ("c", KType)] [] - hasVariablesTyTm expr (down >=> down >=> down >=> down >=> down >=> down) [("d", KType)] [("c", TCon () "Bool")] + hasVariablesTyTm expr (down >=> down >=> down >=> down >=> down >=> down) [("d", KType)] [("c", TCon () tBool)] -- | Test that if we walk 'path' to some node in 'expr', that node will have -- 'expected' in-scope variables. @@ -269,12 +270,12 @@ unit_hasGeneratedNames_1 :: Assertion unit_hasGeneratedNames_1 = do hasGeneratedNamesExpr emptyHole Nothing pure ["x", "y", "z"] hasGeneratedNamesExpr emptyHole (Just $ tfun tEmptyHole tEmptyHole) pure ["f", "g", "h"] - hasGeneratedNamesExpr emptyHole (Just $ tcon "Nat") pure ["i", "j", "m", "n"] - hasGeneratedNamesExpr emptyHole (Just $ tcon "List" `tapp` tcon "Nat") pure ["xs", "ys", "zs"] + hasGeneratedNamesExpr emptyHole (Just $ tcon tNat) pure ["i", "j", "m", "n"] + hasGeneratedNamesExpr emptyHole (Just $ tcon tList `tapp` tcon tNat) pure ["xs", "ys", "zs"] let expr = lam "x" $ lam "i" emptyHole hasGeneratedNamesExpr expr Nothing pure ["y", "z", "x1"] - hasGeneratedNamesExpr expr (Just $ tcon "Nat") pure ["j", "m", "n", "i1"] - hasGeneratedNamesExpr expr (Just $ tcon "List" `tapp` tcon "Nat") pure ["xs", "ys", "zs"] + hasGeneratedNamesExpr expr (Just $ tcon tNat) pure ["j", "m", "n", "i1"] + hasGeneratedNamesExpr expr (Just $ tcon tList `tapp` tcon tNat) pure ["xs", "ys", "zs"] -- test type-level names unit_hasGeneratedNames_2 :: Assertion diff --git a/primer/test/Tests/Refine.hs b/primer/test/Tests/Refine.hs index 5240c1abd..369174895 100644 --- a/primer/test/Tests/Refine.hs +++ b/primer/test/Tests/Refine.hs @@ -27,6 +27,7 @@ import Hedgehog ( import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Primer.App (defaultTypeDefs) +import Primer.Builtins (tBool, tList, tNat) import Primer.Core ( Expr' (APP, Ann, App, EmptyHole), ID, @@ -83,10 +84,10 @@ unit_con_refl = 0 ( refine' defaultCxt - (TCon () "Nat") - (TCon () "Nat") + (TCon () tNat) + (TCon () tNat) ) - @?= Just ([], TCon () "Nat") + @?= Just ([], TCon () tNat) -- refine [...] Nat Bool fails unit_distinct_con :: Assertion @@ -95,8 +96,8 @@ unit_distinct_con = 0 ( refine' defaultCxt - (TCon () "Nat") - (TCon () "Bool") + (TCon () tNat) + (TCon () tBool) ) @?= Nothing @@ -107,10 +108,10 @@ unit_instApp = 0 ( refine' defaultCxt - (TCon () "Nat") - (TFun () (TCon () "Bool") (TCon () "Nat")) + (TCon () tNat) + (TFun () (TCon () tBool) (TCon () tNat)) ) - @?= Just ([InstApp $ TCon () "Bool"], TCon () "Nat") + @?= Just ([InstApp $ TCon () tBool], TCon () tNat) -- refine [...] Nat (∀a.Nat) succeeds: have an unconstraind APP to do unit_instUnconstrainedAPP :: Assertion @@ -120,10 +121,10 @@ unit_instUnconstrainedAPP = 0 ( refine' defaultCxt - (TCon () "Nat") - (TForall () "a" KType (TCon () "Nat")) + (TCon () tNat) + (TForall () "a" KType (TCon () tNat)) ) - @?= Just ([InstUnconstrainedAPP "a1" KType], TCon () "Nat") + @?= Just ([InstUnconstrainedAPP "a1" KType], TCon () tNat) -- refine [...] Nat (∀a.a) succeeds: have an APP Nat to do unit_instAPP :: Assertion @@ -132,10 +133,10 @@ unit_instAPP = 0 ( refine' defaultCxt - (TCon () "Nat") + (TCon () tNat) (TForall () "a" KType (TVar () "a")) ) - @?= Just ([InstAPP $ TCon () "Nat"], TCon () "Nat") + @?= Just ([InstAPP $ TCon () tNat], TCon () tNat) -- refine [...] Nat (∀a.List a) fails unit_forall_fail :: Assertion @@ -144,8 +145,8 @@ unit_forall_fail = 0 ( refine' defaultCxt - (TCon () "Nat") - (TForall () "a" KType $ TApp () (TCon () "List") (TVar () "a")) + (TCon () tNat) + (TForall () "a" KType $ TApp () (TCon () tList) (TVar () "a")) ) @?= Nothing @@ -156,7 +157,7 @@ unit_ill_kinded_fail = 0 ( refine' defaultCxt - (TCon () "Nat") + (TCon () tNat) (TForall () "a" (KFun KType KType) $ TVar () "a") ) @?= Nothing @@ -168,15 +169,15 @@ unit_ill_kinded_fail_2 = 0 ( refine' defaultCxt - (TApp () (TEmptyHole ()) (TCon () "List")) - (TForall () "a" KType $ TApp () (TCon () "List") (TVar () "a")) + (TApp () (TEmptyHole ()) (TCon () tList)) + (TForall () "a" KType $ TApp () (TCon () tList) (TVar () "a")) ) @?= Nothing -- refine [...] (∀a. List a) (∀b. List b) succeeds, trivially unit_alpha :: Assertion unit_alpha = - let t n = (TForall () n KType $ TApp () (TCon () "List") (TVar () n)) + let t n = (TForall () n KType $ TApp () (TCon () tList) (TVar () n)) in evalTestM 0 (refine' defaultCxt (t "a") (t "b")) @?= Just ([], t "b") -- refine cxt T T succeeds diff --git a/primer/test/Tests/Serialization.hs b/primer/test/Tests/Serialization.hs index 2a71f8145..5e998834b 100644 --- a/primer/test/Tests/Serialization.hs +++ b/primer/test/Tests/Serialization.hs @@ -24,6 +24,7 @@ import Primer.App ( ProgError (NoDefSelected), Selection (..), ) +import Primer.Builtins (tNat) import Primer.Core ( ASTDef (..), ASTTypeDef (..), @@ -100,7 +101,7 @@ fixtures = ASTTypeDef { astTypeDefName = "T" , astTypeDefParameters = [("a", KType), ("b", KFun KType KType)] - , astTypeDefConstructors = [ValCon "C" [TApp () (TVar () "b") (TVar () "a"), TCon () "Nat"]] + , astTypeDefConstructors = [ValCon "C" [TApp () (TVar () "b") (TVar () "a"), TCon () tNat]] , astTypeDefNameHints = [] } progerror :: ProgError diff --git a/primer/test/Tests/Subst.hs b/primer/test/Tests/Subst.hs index 166c8ee8e..3695fca39 100644 --- a/primer/test/Tests/Subst.hs +++ b/primer/test/Tests/Subst.hs @@ -3,6 +3,7 @@ module Tests.Subst where import Foreword import Optics (set) +import Primer.Builtins (tBool, tList) import Primer.Core ( Kind (KType), TyVarName, @@ -16,10 +17,10 @@ import TestM (evalTestM) unit_1 :: Assertion unit_1 = - create' (tcon "Bool") + create' (tcon tBool) @=? substTy' "a" - (create' $ tcon "Bool") + (create' $ tcon tBool) (create' $ tvar "a") unit_2 :: Assertion @@ -27,16 +28,16 @@ unit_2 = create' (tforall "a" KType $ tvar "a") @=? substTy' "a" - (create' $ tcon "Bool") + (create' $ tcon tBool) (create' $ tforall "a" KType $ tvar "a") unit_3 :: Assertion unit_3 = - create' (tforall "b" KType $ tcon "List" `tapp` tcon "Bool") + create' (tforall "b" KType $ tcon tList `tapp` tcon tBool) @=? substTy' "a" - (create' $ tcon "Bool") - (create' $ tforall "b" KType $ tcon "List" `tapp` tvar "a") + (create' $ tcon tBool) + (create' $ tforall "b" KType $ tcon tList `tapp` tvar "a") create' :: S (Type' a) -> Type' () create' = set _typeMeta () . fst . create diff --git a/primer/test/Tests/Transform.hs b/primer/test/Tests/Transform.hs index ebab82dc8..5c83246eb 100644 --- a/primer/test/Tests/Transform.hs +++ b/primer/test/Tests/Transform.hs @@ -3,6 +3,7 @@ module Tests.Transform where import Foreword import Optics (over, view) +import Primer.Builtins import Primer.Core import Primer.Core.DSL import Primer.Core.Transform @@ -145,7 +146,7 @@ unit_app :: Assertion unit_app = afterRename "x" "y" (app (lvar "x") (lvar "x")) (Just (app (lvar "y") (lvar "y"))) unit_con :: Assertion -unit_con = afterRename "x" "y" (con "True") (Just (con "True")) +unit_con = afterRename "x" "y" (con cTrue) (Just (con cTrue)) unit_case :: Assertion unit_case = @@ -187,7 +188,7 @@ unit_tEmptyHole :: Assertion unit_tEmptyHole = afterRenameTy "x" "y" tEmptyHole (Just tEmptyHole) unit_tcon :: Assertion -unit_tcon = afterRenameTy "x" "y" (tcon "Bool") (Just $ tcon "Bool") +unit_tcon = afterRenameTy "x" "y" (tcon tBool) (Just $ tcon tBool) unit_tfun :: Assertion unit_tfun = afterRenameTy "x" "y" (tfun (tvar "x") (tvar "x")) (Just $ tfun (tvar "y") (tvar "y")) diff --git a/primer/test/Tests/Typecheck.hs b/primer/test/Tests/Typecheck.hs index fc4696ae9..d3352a1db 100644 --- a/primer/test/Tests/Typecheck.hs +++ b/primer/test/Tests/Typecheck.hs @@ -30,9 +30,20 @@ import Primer.App ( ) import Primer.Builtins ( boolDef, + cCons, + cFalse, + cNil, + cSucc, + cTrue, + cZero, eitherDef, listDef, natDef, + tBool, + tEither, + tList, + tMaybe, + tNat, ) import Primer.Core ( ASTTypeDef (..), @@ -63,6 +74,7 @@ import Primer.Core.DSL import Primer.Core.Utils (generateIDs, generateTypeIDs) import Primer.Module import Primer.Name (NameCounter) +import Primer.Primitives (primitiveGVar, tChar) import Primer.Typecheck ( CheckEverythingRequest (CheckEverything, toCheck, trusted), Cxt, @@ -84,7 +96,7 @@ import Tests.Gen.Core.Typed unit_identity :: Assertion unit_identity = - expectTyped $ ann (lam "x" (lvar "x")) (tfun (tcon "Bool") (tcon "Bool")) + expectTyped $ ann (lam "x" (lvar "x")) (tfun (tcon tBool) (tcon tBool)) unit_undefined_variable :: Assertion unit_undefined_variable = @@ -95,10 +107,10 @@ unit_const = expectTyped $ ann (lam "x" (lam "y" (lvar "x"))) - (tfun (tcon "Bool") (tfun (tcon "Bool") (tcon "Bool"))) + (tfun (tcon tBool) (tfun (tcon tBool) (tcon tBool))) unit_true :: Assertion -unit_true = expectTyped $ con "True" +unit_true = expectTyped $ con cTrue unit_constructor_doesn't_exist :: Assertion unit_constructor_doesn't_exist = @@ -108,8 +120,8 @@ unit_inc :: Assertion unit_inc = expectTyped $ ann - (lam "n" (app (con "Succ") (lvar "n"))) - (tfun (tcon "Nat") (tcon "Nat")) + (lam "n" (app (con cSucc) (lvar "n"))) + (tfun (tcon tNat) (tcon tNat)) unit_compose_nat :: Assertion unit_compose_nat = @@ -117,17 +129,17 @@ unit_compose_nat = ann (lam "f" (lam "g" (app (lvar "f") (hole (lvar "g"))))) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) + (tfun (tcon tNat) (tcon tNat)) ( tfun - (tfun (tcon "Nat") (tcon "Nat")) - (tcon "Nat") + (tfun (tcon tNat) (tcon tNat)) + (tcon tNat) ) ) -- let x = True in x unit_let :: Assertion unit_let = - expectTyped $ let_ "x" (con "True") (lvar "x") + expectTyped $ let_ "x" (con cTrue) (lvar "x") -- Normal lets do not permit recursion unit_recursive_let :: Assertion @@ -139,7 +151,7 @@ unit_recursive_let = unit_letrec_1 :: Assertion unit_letrec_1 = expectTyped $ - letrec "x" (lvar "x") (tcon "Bool") (lvar "x") + letrec "x" (lvar "x") (tcon tBool) (lvar "x") -- let double : Nat -> Nat -- double = \x -> case x of @@ -155,26 +167,26 @@ unit_letrec_2 = "x" ( case_ (lvar "x") - [ branch "Zero" [] (con "Zero") + [ branch cZero [] (con cZero) , branch - "Succ" + cSucc [("n", Nothing)] ( app - (con "Succ") - (app (con "Succ") (app (lvar "double") (lvar "n"))) + (con cSucc) + (app (con cSucc) (app (lvar "double") (lvar "n"))) ) ] ) ) - (tfun (tcon "Nat") (tcon "Nat")) - (app (lvar "double") (app (con "Succ") (con "Zero"))) + (tfun (tcon tNat) (tcon tNat)) + (app (lvar "double") (app (con cSucc) (con cZero))) -- let x = True -- in let y = False -- in x unit_nested_let :: Assertion unit_nested_let = - expectTyped $ let_ "x" (con "True") (let_ "y" (con "False") (lvar "x")) + expectTyped $ let_ "x" (con cTrue) (let_ "y" (con cFalse) (lvar "x")) -- let yes = \x -> True : Bool -> Bool -- in let y = False @@ -184,8 +196,8 @@ unit_let_function = expectTyped $ let_ "yes" - (ann (lam "x" (con "True")) (tfun (tcon "Bool") (tcon "Bool"))) - (let_ "y" (con "False") (app (lvar "yes") (lvar "y"))) + (ann (lam "x" (con cTrue)) (tfun (tcon tBool) (tcon tBool))) + (let_ "y" (con cFalse) (app (lvar "yes") (lvar "y"))) -- (\f -> f : (Bool -> Bool) -> (Bool -> Bool)) (let y = True in \x -> y) unit_let_in_arg :: Assertion @@ -194,9 +206,9 @@ unit_let_in_arg = app ( ann (lam "f" (lvar "f")) - (tfun (tfun (tcon "Bool") (tcon "Bool")) (tfun (tcon "Bool") (tcon "Bool"))) + (tfun (tfun (tcon tBool) (tcon tBool)) (tfun (tcon tBool) (tcon tBool))) ) - (let_ "y" (con "True") (lam "x" (lvar "y"))) + (let_ "y" (con cTrue) (lam "x" (lvar "y"))) unit_mkTAppCon :: Assertion unit_mkTAppCon = do @@ -238,21 +250,21 @@ unit_typeDefKind = do unit_valConType :: Assertion unit_valConType = do - f boolDef @?= [TCon () "Bool", TCon () "Bool"] - f natDef @?= [TCon () "Nat", TFun () (TCon () "Nat") (TCon () "Nat")] + f boolDef @?= [TCon () tBool, TCon () tBool] + f natDef @?= [TCon () tNat, TFun () (TCon () tNat) (TCon () tNat)] f listDef - @?= [ TForall () "a" KType (TApp () (TCon () "List") (TVar () "a")) - , TForall () "a" KType $ TFun () (TVar () "a") $ TFun () (TApp () (TCon () "List") (TVar () "a")) $ TApp () (TCon () "List") (TVar () "a") + @?= [ TForall () "a" KType (TApp () (TCon () tList) (TVar () "a")) + , TForall () "a" KType $ TFun () (TVar () "a") $ TFun () (TApp () (TCon () tList) (TVar () "a")) $ TApp () (TCon () tList) (TVar () "a") ] f eitherDef @?= [ TForall () "a" KType $ TForall () "b" KType $ TFun () (TVar () "a") $ - TApp () (TApp () (TCon () "Either") (TVar () "a")) (TVar () "b") + TApp () (TApp () (TCon () tEither) (TVar () "a")) (TVar () "b") , TForall () "a" KType $ TForall () "b" KType $ TFun () (TVar () "b") $ - TApp () (TApp () (TCon () "Either") (TVar () "a")) (TVar () "b") + TApp () (TApp () (TCon () tEither) (TVar () "a")) (TVar () "b") ] where f t = map (valConType t) (astTypeDefConstructors t) @@ -261,19 +273,19 @@ unit_valConType = do unit_case_isZero :: Assertion unit_case_isZero = expectTyped $ - ann (lam "x" $ case_ (lvar "x") [branch "Zero" [] (con "True"), branch "Succ" [("n", Nothing)] (con "False")]) (tfun (tcon "Nat") (tcon "Bool")) + ann (lam "x" $ case_ (lvar "x") [branch cZero [] (con cTrue), branch cSucc [("n", Nothing)] (con cFalse)]) (tfun (tcon tNat) (tcon tBool)) -- Nat -> Bool rejects \x . case x of {} unit_case_badEmpty :: Assertion unit_case_badEmpty = - ann (lam "x" $ case_ (lvar "x") []) (tfun (tcon "Nat") (tcon "Bool")) - `expectFailsWith` const (WrongCaseBranches "Nat" []) + ann (lam "x" $ case_ (lvar "x") []) (tfun (tcon tNat) (tcon tBool)) + `expectFailsWith` const (WrongCaseBranches tNat []) -- Cannot case on a Nat -> Nat unit_case_badType :: Assertion unit_case_badType = - ann (lam "x" $ case_ (lvar "x") []) (tfun (tfun (tcon "Nat") (tcon "Nat")) (tcon "Bool")) - `expectFailsWith` const (CannotCaseNonADT $ TFun () (TCon () "Nat") (TCon () "Nat")) + ann (lam "x" $ case_ (lvar "x") []) (tfun (tfun (tcon tNat) (tcon tNat)) (tcon tBool)) + `expectFailsWith` const (CannotCaseNonADT $ TFun () (TCon () tNat) (TCon () tNat)) -- Cannot annotate something with a non-existent type constructor unit_ann_bad :: Assertion @@ -282,13 +294,13 @@ unit_ann_bad = unit_ann_insert :: Assertion unit_ann_insert = - app (lam "x" $ lvar "x") (con "Zero") - `smartSynthGives` app (ann (lam "x" $ lvar "x") tEmptyHole) (con "Zero") + app (lam "x" $ lvar "x") (con cZero) + `smartSynthGives` app (ann (lam "x" $ lvar "x") tEmptyHole) (con cZero) unit_app_not_arrow :: Assertion unit_app_not_arrow = - app (con "Zero") (con "Zero") - `smartSynthGives` app (hole (con "Zero")) (con "Zero") + app (con cZero) (con cZero) + `smartSynthGives` app (hole (con cZero)) (con cZero) -- Note: there is something odd with this test, related to -- annotations-changing-types/chk-annotations I think the correct thing to give @@ -297,28 +309,28 @@ unit_app_not_arrow = -- The smartTC currently gives an annotation inside a hole. unit_chk_lam_not_arrow :: Assertion unit_chk_lam_not_arrow = - app (con "Succ") (lam "x" $ lvar "x") - `smartSynthGives` app (con "Succ") (hole $ ann (lam "x" $ lvar "x") tEmptyHole) + app (con cSucc) (lam "x" $ lvar "x") + `smartSynthGives` app (con cSucc) (hole $ ann (lam "x" $ lvar "x") tEmptyHole) unit_check_emb :: Assertion unit_check_emb = - app (con "Succ") (con "True") - `smartSynthGives` app (con "Succ") (hole $ con "True") + app (con cSucc) (con cTrue) + `smartSynthGives` app (con cSucc) (hole $ con cTrue) unit_case_scrutinee :: Assertion unit_case_scrutinee = - ann (case_ (con "Succ") [branch "C" [] $ lvar "x"]) (tcon "Bool") - `smartSynthGives` ann (case_ (hole $ con "Succ") []) (tcon "Bool") + ann (case_ (con cSucc) [branch "C" [] $ lvar "x"]) (tcon tBool) + `smartSynthGives` ann (case_ (hole $ con cSucc) []) (tcon tBool) unit_case_branches :: Assertion unit_case_branches = - ann (case_ (con "Zero") [branch "C" [] $ lvar "x"]) (tcon "Bool") - `smartSynthGives` ann (case_ (con "Zero") [branch "Zero" [] emptyHole, branch "Succ" [("a7", Nothing)] emptyHole]) (tcon "Bool") -- Fragile name here "a7" + ann (case_ (con cZero) [branch "C" [] $ lvar "x"]) (tcon tBool) + `smartSynthGives` ann (case_ (con cZero) [branch cZero [] emptyHole, branch cSucc [("a7", Nothing)] emptyHole]) (tcon tBool) -- Fragile name here "a7" unit_remove_hole :: Assertion unit_remove_hole = - ann (lam "x" $ hole (lvar "x")) (tfun (tcon "Nat") (tcon "Nat")) - `smartSynthGives` ann (lam "x" $ lvar "x") (tfun (tcon "Nat") (tcon "Nat")) + ann (lam "x" $ hole (lvar "x")) (tfun (tcon tNat) (tcon tNat)) + `smartSynthGives` ann (lam "x" $ lvar "x") (tfun (tcon tNat) (tcon tNat)) -- It is not clear how to (efficiently) remove the hole in -- {? Succ ?} Zero @@ -328,9 +340,9 @@ unit_remove_hole = -- This is tracked as https://github.com/hackworthltd/primer/issues/7 unit_remove_hole_not_perfect :: Assertion unit_remove_hole_not_perfect = - app (hole (con "Succ")) (con "Zero") - `smartSynthGives` app (hole (con "Succ")) (con "Zero") -- We currently give this as output - -- app (con "Succ") (con "Zero") -- We would prefer to see the hole removed + app (hole (con cSucc)) (con cZero) + `smartSynthGives` app (hole (con cSucc)) (con cZero) -- We currently give this as output + -- app (con cSucc) (con cZero) -- We would prefer to see the hole removed -- When not using "smart" TC which automatically inserts holes etc, -- one would have to do a bit of dance to build a case expression, and @@ -344,21 +356,21 @@ unit_smart_remove_clean_case = ann ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) tEmptyHole ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) `smartSynthGives` ann ( lam "x" $ ann ( case_ (lvar "x") - [branch "True" [] (con "Zero"), branch "False" [] emptyHole] + [branch cTrue [] (con cZero), branch cFalse [] emptyHole] ) tEmptyHole ) - (tfun (tcon "Bool") (tcon "Nat")) + (tfun (tcon tBool) (tcon tNat)) unit_poly :: Assertion unit_poly = @@ -374,101 +386,101 @@ unit_poly_head_Nat = ( lam "x" $ case_ (lvar "x") - [ branch "Nil" [] (con "Zero") - , branch "Cons" [("y", Nothing), ("ys", Nothing)] $ con "Succ" `app` lvar "y" + [ branch cNil [] (con cZero) + , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cSucc `app` lvar "y" ] ) - ((tcon "List" `tapp` tcon "Nat") `tfun` tcon "Nat") + ((tcon tList `tapp` tcon tNat) `tfun` tcon tNat) unit_type_hole_1 :: Assertion unit_type_hole_1 = tEmptyHole `expectKinded` KHole unit_type_hole_2 :: Assertion -unit_type_hole_2 = tapp tEmptyHole (tcon "Bool") `expectKinded` KHole +unit_type_hole_2 = tapp tEmptyHole (tcon tBool) `expectKinded` KHole unit_type_hole_3 :: Assertion -unit_type_hole_3 = tapp tEmptyHole (tcon "List") `expectKinded` KHole +unit_type_hole_3 = tapp tEmptyHole (tcon tList) `expectKinded` KHole unit_type_hole_4 :: Assertion -unit_type_hole_4 = tapp (tcon "MaybeT") tEmptyHole `expectKinded` KFun KType KType +unit_type_hole_4 = tapp (tcon tMaybeT) tEmptyHole `expectKinded` KFun KType KType unit_type_hole_5 :: Assertion unit_type_hole_5 = tforall "a" KType tEmptyHole `expectKinded` KType unit_type_hole_6 :: Assertion -unit_type_hole_6 = thole (tcon "Bool") `expectKinded` KHole +unit_type_hole_6 = thole (tcon tBool) `expectKinded` KHole unit_smart_type_not_arrow :: Assertion unit_smart_type_not_arrow = - tapp (tcon "Bool") (tcon "Bool") - `smartSynthKindGives` tapp (thole $ tcon "Bool") (tcon "Bool") + tapp (tcon tBool) (tcon tBool) + `smartSynthKindGives` tapp (thole $ tcon tBool) (tcon tBool) unit_smart_type_forall :: Assertion unit_smart_type_forall = - tforall "a" KType (tcon "List") - `smartSynthKindGives` tforall "a" KType (thole $ tcon "List") + tforall "a" KType (tcon tList) + `smartSynthKindGives` tforall "a" KType (thole $ tcon tList) unit_smart_type_not_type :: Assertion unit_smart_type_not_type = - tapp (tcon "List") (tcon "List") - `smartSynthKindGives` tapp (tcon "List") (thole $ tcon "List") + tapp (tcon tList) (tcon tList) + `smartSynthKindGives` tapp (tcon tList) (thole $ tcon tList) unit_smart_type_fun :: Assertion unit_smart_type_fun = - tfun (tcon "List") (tcon "MaybeT") - `smartSynthKindGives` tfun (thole $ tcon "List") (thole $ tcon "MaybeT") + tfun (tcon tList) (tcon tMaybeT) + `smartSynthKindGives` tfun (thole $ tcon tList) (thole $ tcon tMaybeT) unit_smart_type_inside_hole_1 :: Assertion unit_smart_type_inside_hole_1 = - thole (tcon "Bool" `tapp` tcon "MaybeT") - `smartSynthKindGives` (thole (tcon "Bool") `tapp` tcon "MaybeT") + thole (tcon tBool `tapp` tcon tMaybeT) + `smartSynthKindGives` (thole (tcon tBool) `tapp` tcon tMaybeT) unit_smart_type_inside_hole_2 :: Assertion unit_smart_type_inside_hole_2 = - thole (tcon "List" `tapp` tcon "MaybeT") - `smartSynthKindGives` (tcon "List" `tapp` thole (tcon "MaybeT")) + thole (tcon tList `tapp` tcon tMaybeT) + `smartSynthKindGives` (tcon tList `tapp` thole (tcon tMaybeT)) unit_smart_type_inside_hole_3 :: Assertion unit_smart_type_inside_hole_3 = - (tcon "List" `tapp` thole (tcon "MaybeT" `tapp` tcon "Bool")) - `smartSynthKindGives` (tcon "List" `tapp` thole (tcon "MaybeT" `tapp` thole (tcon "Bool"))) + (tcon tList `tapp` thole (tcon tMaybeT `tapp` tcon tBool)) + `smartSynthKindGives` (tcon tList `tapp` thole (tcon tMaybeT `tapp` thole (tcon tBool))) unit_smart_type_remove_1 :: Assertion unit_smart_type_remove_1 = - tapp (thole $ tcon "List") (tcon "Bool") - `smartSynthKindGives` tapp (tcon "List") (tcon "Bool") + tapp (thole $ tcon tList) (tcon tBool) + `smartSynthKindGives` tapp (tcon tList) (tcon tBool) unit_smart_type_remove_2 :: Assertion unit_smart_type_remove_2 = - tforall "a" KType (thole $ tcon "Bool") - `smartSynthKindGives` tforall "a" KType (tcon "Bool") + tforall "a" KType (thole $ tcon tBool) + `smartSynthKindGives` tforall "a" KType (tcon tBool) unit_smart_type_remove_3 :: Assertion unit_smart_type_remove_3 = - tapp (tcon "List") (thole $ tcon "Bool") - `smartSynthKindGives` tapp (tcon "List") (tcon "Bool") + tapp (tcon tList) (thole $ tcon tBool) + `smartSynthKindGives` tapp (tcon tList) (tcon tBool) unit_smart_type_remove_4 :: Assertion unit_smart_type_remove_4 = - tfun (thole $ tcon "Bool") (thole $ tcon "Nat") - `smartSynthKindGives` tfun (tcon "Bool") (tcon "Nat") + tfun (thole $ tcon tBool) (thole $ tcon tNat) + `smartSynthKindGives` tfun (tcon tBool) (tcon tNat) unit_smart_type_remove_5 :: Assertion unit_smart_type_remove_5 = - thole (tapp (tcon "List") tEmptyHole) - `smartSynthKindGives` tapp (tcon "List") tEmptyHole + thole (tapp (tcon tList) tEmptyHole) + `smartSynthKindGives` tapp (tcon tList) tEmptyHole unit_prim_char :: Assertion unit_prim_char = - expectTyped $ ann (char 'a') (tcon "Char") + expectTyped $ ann (char 'a') (tcon tChar) unit_prim_fun :: Assertion unit_prim_fun = - expectTypedWithPrims $ ann (gvar "hexToNat") (tfun (tcon "Char") (tapp (tcon "Maybe") (tcon "Nat"))) + expectTypedWithPrims $ ann (gvar $ primitiveGVar "hexToNat") (tfun (tcon tChar) (tapp (tcon tMaybe) (tcon tNat))) unit_prim_fun_applied :: Assertion unit_prim_fun_applied = - expectTypedWithPrims $ ann (app (gvar "hexToNat") (char 'a')) (tapp (tcon "Maybe") (tcon "Nat")) + expectTypedWithPrims $ ann (app (gvar $ primitiveGVar "hexToNat") (char 'a')) (tapp (tcon tMaybe) (tcon tNat)) -- Whenever we synthesise a type, then it kind-checks against KType hprop_synth_well_typed_extcxt :: Property @@ -523,7 +535,7 @@ unit_good_maybeT = case runTypecheckTestM NoSmartHoles $ unit_bad_prim_map :: Assertion unit_bad_prim_map = case runTypecheckTestM NoSmartHoles $ do - fooType <- tcon "Nat" + fooType <- tcon tNat let foo = PrimDef{primDefName = "bar", primDefType = fooType} checkEverything NoSmartHoles @@ -641,11 +653,14 @@ runTypecheckTestMWithPrims sh = testingTypeDefs :: Map TyConName TypeDef testingTypeDefs = mkTypeDefMap [TypeDefAST maybeTDef] <> defaultTypeDefs +tMaybeT :: TyConName +tMaybeT = "MaybeT" + maybeTDef :: ASTTypeDef maybeTDef = ASTTypeDef - { astTypeDefName = "MaybeT" + { astTypeDefName = tMaybeT , astTypeDefParameters = [("m", KFun KType KType), ("a", KType)] - , astTypeDefConstructors = [ValCon "MakeMaybeT" [TApp () (TVar () "m") (TApp () (TCon () "Maybe") (TVar () "a"))]] + , astTypeDefConstructors = [ValCon "MakeMaybeT" [TApp () (TVar () "m") (TApp () (TCon () tMaybe) (TVar () "a"))]] , astTypeDefNameHints = [] } diff --git a/primer/test/Tests/Unification.hs b/primer/test/Tests/Unification.hs index 5e10a75cf..2d5486337 100644 --- a/primer/test/Tests/Unification.hs +++ b/primer/test/Tests/Unification.hs @@ -33,9 +33,11 @@ import Hedgehog ( import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Primer.App (defaultTypeDefs) +import Primer.Builtins (tList, tNat) import Primer.Core (ID, Kind (KFun, KHole, KType), TyVarName, Type' (TApp, TCon, TEmptyHole, TForall, TFun, THole, TVar)) import Primer.Core.Utils (forgetTypeIDs, freeVarsTy, generateTypeIDs) import Primer.Name (NameCounter) +import Primer.Primitives (tInt) import Primer.Subst (substTys) import Primer.Typecheck ( Cxt, @@ -79,8 +81,8 @@ unit_Int_refl = ( unify' defaultCxt mempty - (TCon () "Int") - (TCon () "Int") + (TCon () tInt) + (TCon () tInt) ) @?= Just mempty @@ -106,7 +108,7 @@ unit_var_con = (extendLocalCxtTy ("a", KType) defaultCxt) mempty (TVar () "a") - (TCon () "Nat") + (TCon () tNat) ) @?= Nothing @@ -119,9 +121,9 @@ unit_unif_var_con = (extendLocalCxtTy ("a", KType) defaultCxt) (S.singleton "a") (TVar () "a") - (TCon () "Nat") + (TCon () tNat) ) - @?= Just (M.singleton "a" $ TCon () "Nat") + @?= Just (M.singleton "a" $ TCon () tNat) -- unify [...,a:*] [a] a a = Just [] unit_unif_var_refl :: Assertion @@ -145,7 +147,7 @@ unit_ill_kinded = (extendLocalCxtTy ("a", KFun KType KType) defaultCxt) (S.singleton "a") (TVar () "a") - (TCon () "Nat") + (TCon () tNat) ) @?= Nothing @@ -158,9 +160,9 @@ unit_List_Nat = (extendLocalCxtTy ("a", KType) defaultCxt) (S.singleton "a") (TVar () "a") - (TApp () (TCon () "List") (TCon () "Nat")) + (TApp () (TCon () tList) (TCon () tNat)) ) - @?= Just (M.singleton "a" $ TApp () (TCon () "List") (TCon () "Nat")) + @?= Just (M.singleton "a" $ TApp () (TCon () tList) (TCon () tNat)) -- unify [...,a:*] [a] (List a) (List Nat) = Just [Nat/a] unit_List :: Assertion @@ -170,10 +172,10 @@ unit_List = ( unify' (extendLocalCxtTy ("a", KType) defaultCxt) (S.singleton "a") - (TApp () (TCon () "List") (TVar () "a")) - (TApp () (TCon () "List") (TCon () "Nat")) + (TApp () (TCon () tList) (TVar () "a")) + (TApp () (TCon () tList) (TCon () tNat)) ) - @?= Just (M.singleton "a" $ TCon () "Nat") + @?= Just (M.singleton "a" $ TCon () tNat) -- unify [...,a:*] [a] (List Nat) (List Nat) = Just [] unit_List_Nat_refl :: Assertion @@ -183,8 +185,8 @@ unit_List_Nat_refl = ( unify' (extendLocalCxtTy ("a", KType) defaultCxt) (S.singleton "a") - (TApp () (TCon () "List") (TCon () "Nat")) - (TApp () (TCon () "List") (TCon () "Nat")) + (TApp () (TCon () tList) (TCon () tNat)) + (TApp () (TCon () tList) (TCon () tNat)) ) @?= Just mempty @@ -196,10 +198,10 @@ unit_higher_kinded = ( unify' (extendLocalCxtTy ("a", KFun KType KType) defaultCxt) (S.singleton "a") - (TApp () (TVar () "a") (TCon () "Nat")) - (TApp () (TCon () "List") (TCon () "Nat")) + (TApp () (TVar () "a") (TCon () tNat)) + (TApp () (TCon () tList) (TCon () tNat)) ) - @?= Just (M.singleton "a" $ TCon () "List") + @?= Just (M.singleton "a" $ TCon () tList) -- unify [...] [a] (? List) (List a) fails, as 'a' is not in the context -- In particular, it does not succeed with the nonsense [List/a], as we throw @@ -213,8 +215,8 @@ unit_ill_kinded_0 = unify defaultCxt (S.singleton "a") - (TApp () (TEmptyHole ()) (TCon () "List")) - (TApp () (TCon () "List") (TVar () "a")) + (TApp () (TEmptyHole ()) (TCon () tList)) + (TApp () (TCon () tList) (TVar () "a")) ) in assertBool "Should have detected a unification variable was not in the context" $ isLeft res @@ -227,10 +229,10 @@ unit_uv_not_in_context = ( unify' (extendLocalCxtTy ("b", KType) defaultCxt) (S.fromList ["a", "b"]) - (TCon () "Nat") + (TCon () tNat) (TVar () "b") ) - @?= Just (M.singleton "b" $ TCon () "Nat") + @?= Just (M.singleton "b" $ TCon () tNat) -- unify [...,a:*] [a] (? List) (List a) = Nothing unit_ill_kinded_1 :: Assertion @@ -240,8 +242,8 @@ unit_ill_kinded_1 = ( unify' (extendLocalCxtTy ("a", KType) defaultCxt) (S.singleton "a") - (TApp () (TEmptyHole ()) (TCon () "List")) - (TApp () (TCon () "List") (TVar () "a")) + (TApp () (TEmptyHole ()) (TCon () tList)) + (TApp () (TCon () tList) (TVar () "a")) ) @?= Nothing @@ -255,10 +257,10 @@ unit_ill_kinded_2 = ( unify' (extendLocalCxtTy ("a", KFun KType KType) defaultCxt) (S.singleton "a") - (TApp () (TEmptyHole ()) (TCon () "List")) - (TApp () (TCon () "List") (TVar () "a")) + (TApp () (TEmptyHole ()) (TCon () tList)) + (TApp () (TCon () tList) (TVar () "a")) ) - @?= Just (M.singleton "a" $ TCon () "List") + @?= Just (M.singleton "a" $ TCon () tList) -- unify [...,a:*,b:*->*] [a] a b = Nothing unit_ill_kinded_3 :: Assertion @@ -347,7 +349,7 @@ unit_unify_hole_trivial_1 = defaultCxt mempty (TEmptyHole ()) - (THole () $ TCon () "Nat") + (THole () $ TCon () tNat) ) @?= Just mempty diff --git a/primer/test/Tests/Zipper/BindersAbove.hs b/primer/test/Tests/Zipper/BindersAbove.hs index 09c2f672a..4cf548254 100644 --- a/primer/test/Tests/Zipper/BindersAbove.hs +++ b/primer/test/Tests/Zipper/BindersAbove.hs @@ -8,6 +8,7 @@ import Primer.Action ( Movement (..), moveExpr, ) +import Primer.Builtins (cSucc, cZero, tNat) import Primer.Core ( Expr, ) @@ -42,43 +43,43 @@ unit_4 = unit_5 :: Assertion unit_5 = bindersAboveTest - (letrec "x" (lam "y" emptyHole) (tcon "Nat") (lam "z" emptyHole)) + (letrec "x" (lam "y" emptyHole) (tcon tNat) (lam "z" emptyHole)) [Child1, Child1] (S.fromList ["x", "y"]) unit_6 :: Assertion unit_6 = bindersAboveTest - (letrec "x" (lam "y" emptyHole) (tcon "Nat") (lam "z" emptyHole)) + (letrec "x" (lam "y" emptyHole) (tcon tNat) (lam "z" emptyHole)) [Child2, Child1] (S.fromList ["x", "z"]) unit_7 :: Assertion unit_7 = bindersAboveTest - (case_ (lvar "x") [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole]) + (case_ (lvar "x") [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole]) [] (S.fromList []) unit_8 :: Assertion unit_8 = bindersAboveTest - (case_ (lvar "x") [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole]) + (case_ (lvar "x") [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole]) [Child1] (S.fromList []) unit_9 :: Assertion unit_9 = bindersAboveTest - (case_ (lvar "x") [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole]) - [Branch "Zero"] + (case_ (lvar "x") [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole]) + [Branch cZero] (S.fromList []) unit_10 :: Assertion unit_10 = bindersAboveTest - (case_ (lvar "x") [branch "Zero" [] emptyHole, branch "Succ" [("n", Nothing)] emptyHole]) - [Branch "Succ"] + (case_ (lvar "x") [branch cZero [] emptyHole, branch cSucc [("n", Nothing)] emptyHole]) + [Branch cSucc] (S.fromList ["n"]) -- * Helpers From af7a5d623157fdcd88368232fcf6b91fe67766d2 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Thu, 7 Apr 2022 21:06:03 +0100 Subject: [PATCH 3/8] refactor: introduce buildTypingContextFromModules --- primer/src/Primer/Action.hs | 9 +++------ primer/src/Primer/App.hs | 3 ++- primer/src/Primer/Typecheck.hs | 13 ++++++++----- 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/primer/src/Primer/Action.hs b/primer/src/Primer/Action.hs index 2f53081fb..f2aafddba 100644 --- a/primer/src/Primer/Action.hs +++ b/primer/src/Primer/Action.hs @@ -89,7 +89,7 @@ import Primer.Core.DSL ( import Primer.Core.Transform (renameLocalVar, renameTyVar, renameTyVarExpr) import Primer.Core.Utils (forgetTypeIDs, generateTypeIDs) import Primer.JSON -import Primer.Module (Module (moduleDefs, moduleTypes)) +import Primer.Module (Module (moduleDefs)) import Primer.Name (Name, NameCounter, unName) import Primer.Name.Fresh ( isFresh, @@ -104,6 +104,7 @@ import Primer.Typecheck ( SmartHoles, TypeError, buildTypingContext, + buildTypingContextFromModules, check, checkEverything, exprTtoExpr, @@ -441,11 +442,7 @@ applyActionsToTypeSig :: applyActionsToTypeSig smartHoles imports mod def actions = runReaderT go - ( buildTypingContext - (foldMap moduleTypes $ mod : imports) - (foldMap moduleDefs $ mod : imports) - smartHoles - ) + (buildTypingContextFromModules (mod : imports) smartHoles) & runExceptT where go :: ActionM m => m (ASTDef, Module, TypeZ) diff --git a/primer/src/Primer/App.hs b/primer/src/Primer/App.hs index 8dca44cbf..418b2933f 100644 --- a/primer/src/Primer/App.hs +++ b/primer/src/Primer/App.hs @@ -153,6 +153,7 @@ import Primer.Typecheck ( SmartHoles (NoSmartHoles, SmartHoles), TypeError, buildTypingContext, + buildTypingContextFromModules, checkDef, checkEverything, checkTypeDefs, @@ -1271,7 +1272,7 @@ transformCaseBranches prog type_ f = transformM $ \case e -> pure e progCxt :: Prog -> Cxt -progCxt p = buildTypingContext (allTypes p) (allDefs p) (progSmartHoles p) +progCxt p = buildTypingContextFromModules (progModule p : progImports p) (progSmartHoles p) -- | Run a computation in some context whose errors can be promoted to `ProgError`. liftError :: MonadEditApp m => (e -> ProgError) -> ExceptT e m b -> m b diff --git a/primer/src/Primer/Typecheck.hs b/primer/src/Primer/Typecheck.hs index 3d3b47ae9..8667a905b 100644 --- a/primer/src/Primer/Typecheck.hs +++ b/primer/src/Primer/Typecheck.hs @@ -26,6 +26,7 @@ module Primer.Typecheck ( KindOrType (..), initialCxt, buildTypingContext, + buildTypingContextFromModules, TypeError (..), typeOf, maybeTypeOf, @@ -253,6 +254,12 @@ buildTypingContext tydefs defs sh = let globals = Map.elems $ fmap (\def -> (defName def, forgetTypeIDs (defType def))) defs in extendTypeDefCxt (Map.elems tydefs) $ extendGlobalCxt globals $ initialCxt sh +buildTypingContextFromModules :: [Module] -> SmartHoles -> Cxt +buildTypingContextFromModules modules = + buildTypingContext + (foldMap moduleTypes modules) + (foldMap moduleDefs modules) + -- | Create a mapping of name to typedef for fast lookup. -- Ensures that @typeDefName (mkTypeDefMap ! n) == n@ mkTypeDefMap :: [TypeDef] -> Map TyConName TypeDef @@ -403,11 +410,7 @@ checkEverything :: CheckEverythingRequest -> m [Module] checkEverything sh CheckEverything{trusted, toCheck} = - let cxt = - buildTypingContext - (foldMap moduleTypes trusted) - (foldMap moduleDefs trusted) - sh + let cxt = buildTypingContextFromModules trusted sh in flip runReaderT cxt $ do -- Check that the definition map has the right keys for_ toCheck $ \m -> flip Map.traverseWithKey (moduleDefs m) $ \n d -> From b918ba8bed538e0f93a6485c6c28440f9ac78f38 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Thu, 7 Apr 2022 21:34:55 +0100 Subject: [PATCH 4/8] refactor: use expectTypedWithPrims for unit_prim_char This is not yet needed, as currently primitive types are always in scope -- the '...WithPrims' just adds primitive terms. But this will change shortly. --- primer/test/Tests/Typecheck.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/primer/test/Tests/Typecheck.hs b/primer/test/Tests/Typecheck.hs index d3352a1db..0278bd92c 100644 --- a/primer/test/Tests/Typecheck.hs +++ b/primer/test/Tests/Typecheck.hs @@ -472,7 +472,7 @@ unit_smart_type_remove_5 = unit_prim_char :: Assertion unit_prim_char = - expectTyped $ ann (char 'a') (tcon tChar) + expectTypedWithPrims $ ann (char 'a') (tcon tChar) unit_prim_fun :: Assertion unit_prim_fun = From d3bc436eb5c980adcb4d20984faa2b5cdb9d7b63 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Thu, 7 Apr 2022 21:06:59 +0100 Subject: [PATCH 5/8] refactor: use modules where possible Instead of using 'defaultTypeDefs', define and use 'builtinModule' and 'primitiveModule'. This is in preparation for adding module names and taking modules more seriously. There is one theoretical drawback: in Tests.EvalFull we lose the ability to generate definitions for global variables. However, we never actually used this ability, so there is no loss in practice. (However, we may want to re-instate this ability in the future so we can generate an arbitrary context in these tests.) --- primer-rel8/test/TestUtils.hs | 51 +++----- primer/src/Primer/Action.hs | 16 ++- primer/src/Primer/App.hs | 42 ++----- primer/src/Primer/Builtins.hs | 14 +++ primer/src/Primer/Module.hs | 10 +- primer/src/Primer/Primitives.hs | 26 ++++ primer/src/Primer/Typecheck.hs | 1 - primer/test/Gen/Core/Typed.hs | 10 +- primer/test/Tests/Action.hs | 3 +- primer/test/Tests/Action/Prog.hs | 45 +++---- primer/test/Tests/Eval.hs | 12 +- primer/test/Tests/EvalFull.hs | 180 +++++++++++++--------------- primer/test/Tests/Gen/Core/Typed.hs | 23 ++-- primer/test/Tests/Primitives.hs | 17 +-- primer/test/Tests/Question.hs | 5 +- primer/test/Tests/Refine.hs | 27 +++-- primer/test/Tests/Serialization.hs | 4 +- primer/test/Tests/Typecheck.hs | 34 +++--- primer/test/Tests/Unification.hs | 40 +++---- 19 files changed, 274 insertions(+), 286 deletions(-) diff --git a/primer-rel8/test/TestUtils.hs b/primer-rel8/test/TestUtils.hs index 8ad37bf47..ecd921cf0 100644 --- a/primer-rel8/test/TestUtils.hs +++ b/primer-rel8/test/TestUtils.hs @@ -44,11 +44,11 @@ import Primer.App ( App (..), InitialApp (NewApp), Prog (..), - defaultTypeDefs, newEmptyApp, newEmptyProg, ) import Primer.Builtins ( + builtinModule, cFalse, cJust, cLeft, @@ -63,15 +63,9 @@ import Primer.Builtins ( ) import Primer.Core ( ASTDef (..), - Def (DefAST, DefPrim), - GVarName, + Def (DefAST), ID, Kind (KType), - PrimDef (..), - PrimFun, - defName, - primDefType, - primFunType, ) import Primer.Core.DSL ( aPP, @@ -110,9 +104,7 @@ import Primer.Module ( moduleTypes ), ) -import Primer.Primitives ( - allPrimDefs, - ) +import Primer.Primitives (primitiveModule) import Rel8 ( Expr, Insert (Insert, into, onConflict, returning, rows), @@ -248,14 +240,17 @@ insertSessionRow row conn = -- so it should be refactored into a common test library. See: -- https://github.com/hackworthltd/primer/issues/273 testASTDef :: ASTDef -testASTDef = - ASTDef +testASTDefNextID :: ID +(testASTDef, testASTDefNextID) = + ( ASTDef { astDefName = "1" , astDefExpr , astDefType } + , nextID + ) where - ((astDefExpr, astDefType), _) = create $ (,) <$> e <*> t + ((astDefExpr, astDefType), nextID) = create $ (,) <$> e <*> t t = tfun (tcon tNat) @@ -348,24 +343,6 @@ testASTDef = ) ) --- | Helper function for creating test apps from a predefined list of --- 'ASTDef's and 'PrimFun's. --- --- TODO: move this function into 'Primer.App'. See: --- https://github.com/hackworthltd/primer/issues/273#issuecomment-1058713380 -mkTestDefs :: [ASTDef] -> Map GVarName PrimFun -> (Map GVarName Def, ID) -mkTestDefs astDefs primMap = - let (defs, nextID) = create $ do - primDefs <- for (Map.toList primMap) $ \(primDefName, def) -> do - primDefType <- primFunType def - pure $ - PrimDef - { primDefName - , primDefType - } - pure $ map DefAST astDefs <> map DefPrim primDefs - in (Map.fromList $ (\d -> (defName d, d)) <$> defs, nextID) - -- | 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 @@ -375,16 +352,16 @@ testApp = newEmptyApp { appProg = testProg , appInit = NewApp - , appIdCounter = fromEnum nextId + , appIdCounter = fromEnum testASTDefNextID } where - (defs, nextId) = mkTestDefs [testASTDef] allPrimDefs testProg :: Prog testProg = newEmptyProg - { progModule = + { progImports = [builtinModule, primitiveModule] + , progModule = Module - { moduleTypes = defaultTypeDefs - , moduleDefs = defs + { moduleTypes = mempty + , moduleDefs = Map.singleton (astDefName testASTDef) (DefAST testASTDef) } } diff --git a/primer/src/Primer/Action.hs b/primer/src/Primer/Action.hs index f2aafddba..b07447b01 100644 --- a/primer/src/Primer/Action.hs +++ b/primer/src/Primer/Action.hs @@ -103,7 +103,6 @@ import Primer.Typecheck ( CheckEverythingRequest (CheckEverything, toCheck, trusted), SmartHoles, TypeError, - buildTypingContext, buildTypingContextFromModules, check, checkEverything, @@ -489,14 +488,13 @@ applyActionsToTypeSig smartHoles imports mod def actions = applyActionsToBody :: (MonadFresh ID m, MonadFresh NameCounter m) => SmartHoles -> - Map TyConName TypeDef -> - Map GVarName Def -> + [Module] -> ASTDef -> [Action] -> m (Either ActionError (ASTDef, Loc)) -applyActionsToBody sh typeDefs defs def actions = +applyActionsToBody sh modules def actions = go - & flip runReaderT (buildTypingContext typeDefs defs sh) + & flip runReaderT (buildTypingContextFromModules modules sh) & runExceptT where go :: ActionM m => m (ASTDef, Loc) @@ -523,12 +521,12 @@ applyActionAndCheck ty action z = do -- This is currently only used for tests. -- We may need it in the future for a REPL, where we want to build standalone expressions. --- We take a list of the types that should be in scope for the test. -applyActionsToExpr :: (MonadFresh ID m, MonadFresh NameCounter m) => SmartHoles -> Map TyConName TypeDef -> Expr -> [Action] -> m (Either ActionError (Either ExprZ TypeZ)) -applyActionsToExpr sh typeDefs expr actions = +-- We take a list of the modules that should be in scope for the test. +applyActionsToExpr :: (MonadFresh ID m, MonadFresh NameCounter m) => SmartHoles -> [Module] -> Expr -> [Action] -> m (Either ActionError (Either ExprZ TypeZ)) +applyActionsToExpr sh modules expr actions = foldM (flip applyActionAndSynth) (focusLoc expr) actions -- apply all actions <&> locToEither - & flip runReaderT (buildTypingContext typeDefs mempty sh) + & flip runReaderT (buildTypingContextFromModules modules sh) & runExceptT -- catch any errors applyActionAndSynth :: ActionM m => Action -> Loc -> m Loc diff --git a/primer/src/Primer/App.hs b/primer/src/Primer/App.hs index 418b2933f..d5dad46f3 100644 --- a/primer/src/Primer/App.hs +++ b/primer/src/Primer/App.hs @@ -42,7 +42,6 @@ module Primer.App ( EvalFullReq (..), EvalFullResp (..), lookupASTDef, - defaultTypeDefs, ) where import Foreword hiding (mod) @@ -86,7 +85,7 @@ import Primer.Action ( applyActionsToBody, applyActionsToTypeSig, ) -import Primer.Builtins (boolDef, eitherDef, listDef, maybeDef, natDef, pairDef) +import Primer.Builtins (builtinModule) import Primer.Core ( ASTDef (..), ASTTypeDef (..), @@ -102,7 +101,6 @@ import Primer.Core ( ID (..), LocalName (LocalName, unLocalName), Meta (..), - PrimDef (..), TmVarRef (GlobalVarRef, LocalVarRef), TyConName, TyVarName, @@ -116,7 +114,6 @@ import Primer.Core ( defName, defPrim, getID, - primFunType, qualifyName, typeDefAST, typesInExpr, @@ -137,9 +134,9 @@ import Primer.Eval (EvalDetail, EvalError) import qualified Primer.Eval as Eval import Primer.EvalFull (Dir, EvalFullError (TimedOut), TerminationBound, evalFull) import Primer.JSON -import Primer.Module (Module (Module, moduleDefs, moduleTypes)) +import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) import Primer.Name (Name, NameCounter, freshName) -import Primer.Primitives (allPrimDefs, allPrimTypeDefs) +import Primer.Primitives (primitiveModule) import Primer.Questions ( Question (..), generateNameExpr, @@ -157,7 +154,6 @@ import Primer.Typecheck ( checkDef, checkEverything, checkTypeDefs, - mkTypeDefMap, synth, ) import Primer.Zipper ( @@ -532,7 +528,7 @@ applyProgAction prog mdefName = \case (TypeDefError . show @TypeError) ( runReaderT (checkTypeDefs $ mkTypeDefMap [TypeDefAST td]) - (buildTypingContext (allTypes prog) mempty NoSmartHoles) + (buildTypingContextFromModules (progModule prog : progImports prog) NoSmartHoles) ) RenameType old (unsafeMkGlobalName -> new) -> (,Nothing) <$> do @@ -746,7 +742,7 @@ applyProgAction prog mdefName = \case BodyAction actions -> do withDef mdefName prog $ \def -> do smartHoles <- gets $ progSmartHoles . appProg - res <- applyActionsToBody smartHoles (allTypes prog) (allDefs prog) def actions + res <- applyActionsToBody smartHoles (progModule prog : progImports prog) def actions case res of Left err -> throwError $ ActionError err Right (def', z) -> do @@ -948,13 +944,14 @@ newEmptyApp = , appInit = NewEmptyApp } --- | An initial program with some useful typedefs. +-- | An initial program with some useful typedefs imported. newProg :: Prog newProg = newEmptyProg - { progModule = + { progImports = [builtinModule, primitiveModule] + , progModule = Module - { moduleTypes = defaultTypeDefs + { moduleTypes = mempty , moduleDefs = defaultDefs } } @@ -972,14 +969,7 @@ defaultDefs :: Map GVarName Def , astDefType = mainType } ] - primDefs <- for (Map.toList allPrimDefs) $ \(primDefName, def) -> do - primDefType <- primFunType def - pure $ - PrimDef - { primDefName - , primDefType - } - pure $ map DefAST astDefs <> map DefPrim primDefs + pure $ map DefAST astDefs in (Map.fromList $ (\d -> (defName d, d)) <$> defs, nextID) -- | An initial app whose program includes some useful definitions. @@ -1151,7 +1141,7 @@ copyPasteBody p (fromDefName, fromId) toDefName setup = do smartHoles <- gets $ progSmartHoles . appProg -- The Loc zipper captures all the changes, they are only reflected in the -- returned Def, which we thus ignore - (oldDef, doneSetup) <- withDef (Just toDefName) p $ \def -> (def,) <$> applyActionsToBody smartHoles (allTypes p) (allDefs p) def setup + (oldDef, doneSetup) <- withDef (Just toDefName) p $ \def -> (def,) <$> applyActionsToBody smartHoles (progModule p : progImports p) def setup tgt <- case doneSetup of Left err -> throwError $ ActionError err Right (_, tgt) -> pure tgt @@ -1288,13 +1278,3 @@ allConNames = % #astTypeDefConstructors % traversed % #valConName - -defaultTypeDefs :: Map TyConName TypeDef -defaultTypeDefs = - mkTypeDefMap $ - map - TypeDefAST - [boolDef, natDef, listDef, maybeDef, pairDef, eitherDef] - <> map - TypeDefPrim - (Map.elems allPrimTypeDefs) diff --git a/primer/src/Primer/Builtins.hs b/primer/src/Primer/Builtins.hs index 0ca268eb8..66535b618 100644 --- a/primer/src/Primer/Builtins.hs +++ b/primer/src/Primer/Builtins.hs @@ -3,6 +3,7 @@ -- for the fact that some of the primitive functions (see "Primer.Primitives") -- refer to these types. module Primer.Builtins ( + builtinModule, tBool, cTrue, cFalse, @@ -28,6 +29,8 @@ module Primer.Builtins ( eitherDef, ) where +import Foreword + import Primer.Core ( ASTTypeDef ( ASTTypeDef, @@ -39,9 +42,20 @@ import Primer.Core ( Kind (KType), TyConName, Type' (TApp, TCon, TVar), + TypeDef (TypeDefAST), ValCon (ValCon), ValConName, ) +import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) + +builtinModule :: Module +builtinModule = + Module + { moduleTypes = + mkTypeDefMap $ + map TypeDefAST [boolDef, natDef, listDef, maybeDef, pairDef, eitherDef] + , moduleDefs = mempty + } tBool :: TyConName tBool = "Bool" diff --git a/primer/src/Primer/Module.hs b/primer/src/Primer/Module.hs index 7e67ab45e..173c4819d 100644 --- a/primer/src/Primer/Module.hs +++ b/primer/src/Primer/Module.hs @@ -1,7 +1,8 @@ -module Primer.Module (Module (..)) where +module Primer.Module (Module (..), mkTypeDefMap) where +import qualified Data.Map as M import Foreword -import Primer.Core (Def, GlobalName, GlobalNameKind (ADefName, ATyCon), TypeDef) +import Primer.Core (Def, GlobalName, GlobalNameKind (ADefName, ATyCon), TypeDef, typeDefName) import Primer.JSON data Module = Module @@ -10,3 +11,8 @@ data Module = Module } deriving (Eq, Show, Generic) deriving (FromJSON, ToJSON) via VJSON Module + +-- | Create a mapping of name to typedef for fast lookup. +-- Ensures that @typeDefName (mkTypeDefMap ! n) == n@ +mkTypeDefMap :: [TypeDef] -> Map (GlobalName 'ATyCon) TypeDef +mkTypeDefMap defs = M.fromList $ map (\d -> (typeDefName d, d)) defs diff --git a/primer/src/Primer/Primitives.hs b/primer/src/Primer/Primitives.hs index 5cbf8f596..97e02606c 100644 --- a/primer/src/Primer/Primitives.hs +++ b/primer/src/Primer/Primitives.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ViewPatterns #-} module Primer.Primitives ( + primitiveModule, allPrimDefs, allPrimTypeDefs, tInt, @@ -23,14 +24,18 @@ import Primer.Builtins ( tNat, ) import Primer.Core ( + Def (DefPrim), Expr' (App, Con, PrimCon), ExprAnyFresh (..), GVarName, PrimCon (..), + PrimDef (PrimDef, primDefName, primDefType), PrimFun (..), PrimFunError (..), PrimTypeDef (..), TyConName, + TypeDef (TypeDefPrim), + primFunType, qualifyName, ) import Primer.Core.DSL ( @@ -39,14 +44,35 @@ import Primer.Core.DSL ( bool_, char, con, + create, int, maybe_, nat, tapp, tcon, ) +import Primer.Module (Module (Module, moduleDefs, moduleTypes)) import Primer.Name (Name) +-- | This module depends on the builtin module, due to some terms referencing builtin types. +-- It contains all primitive types and terms. +primitiveModule :: Module +primitiveModule = + Module + { moduleTypes = TypeDefPrim <$> allPrimTypeDefs + , moduleDefs = fst . create $ + getAp $ + flip M.foldMapWithKey allPrimDefs $ \n def -> Ap $ do + ty <- primFunType def + pure $ + M.singleton n $ + DefPrim + PrimDef + { primDefName = n + , primDefType = ty + } + } + tChar :: TyConName tChar = "Char" diff --git a/primer/src/Primer/Typecheck.hs b/primer/src/Primer/Typecheck.hs index 8667a905b..ed31043d0 100644 --- a/primer/src/Primer/Typecheck.hs +++ b/primer/src/Primer/Typecheck.hs @@ -49,7 +49,6 @@ module Primer.Typecheck ( lookupLocalTy, lookupVar, primConInScope, - mkTypeDefMap, consistentKinds, consistentTypes, extendLocalCxtTy, diff --git a/primer/test/Gen/Core/Typed.hs b/primer/test/Gen/Core/Typed.hs index 99faed814..890e50342 100644 --- a/primer/test/Gen/Core/Typed.hs +++ b/primer/test/Gen/Core/Typed.hs @@ -70,12 +70,15 @@ import Primer.Core ( valConType, ) import Primer.Core.Utils (freeVarsTy) +import Primer.Module (Module, mkTypeDefMap) import Primer.Name (Name, NameCounter, freshName, unName, unsafeMkName) import Primer.Refine (Inst (InstAPP, InstApp, InstUnconstrainedAPP), refine) import Primer.Subst (substTy, substTys) import Primer.Typecheck ( Cxt (), + SmartHoles (NoSmartHoles), TypeDefError (TDIHoleType), + buildTypingContextFromModules, consistentKinds, extendLocalCxt, extendLocalCxtTy, @@ -89,7 +92,6 @@ import Primer.Typecheck ( localTyVars, matchArrowType, matchForallType, - mkTypeDefMap, primConInScope, typeDefs, ) @@ -527,5 +529,7 @@ hoist' cxt = pure . evalTestM 0 . flip runReaderT cxt . unWT -- It is recommended to do more than default number of tests when using this module. -- That is to say, generating well-typed syntax is hard, and you probably want -- to increase the number of tests run to get decent coverage. -propertyWT :: Cxt -> PropertyT WT () -> Property -propertyWT cxt = property . hoist (hoist' cxt) +-- The modules form the 'Cxt' in the environment of the 'WT' monad +-- (thus the definitions of terms is ignored) +propertyWT :: [Module] -> PropertyT WT () -> Property +propertyWT mods = property . hoist (hoist' $ buildTypingContextFromModules mods NoSmartHoles) diff --git a/primer/test/Tests/Action.hs b/primer/test/Tests/Action.hs index c71504059..c18cb7ee6 100644 --- a/primer/test/Tests/Action.hs +++ b/primer/test/Tests/Action.hs @@ -19,7 +19,6 @@ import Primer.Action ( Movement (..), applyActionsToExpr, ) -import Primer.App (defaultTypeDefs) import Primer.Builtins import Primer.Core ( Expr, @@ -999,4 +998,4 @@ actionTestExpectFail f sh expr actions = runTestActions :: SmartHoles -> ID -> Expr -> [Action] -> Either ActionError Expr runTestActions sh i expr actions = either unfocusExpr (unfocusExpr . unfocusType) - <$> evalTestM (i + 1) (applyActionsToExpr sh defaultTypeDefs expr actions) + <$> evalTestM (i + 1) (applyActionsToExpr sh [builtinModule] expr actions) diff --git a/primer/test/Tests/Action/Prog.hs b/primer/test/Tests/Action/Prog.hs index d68f2068d..b4c394d7e 100644 --- a/primer/test/Tests/Action/Prog.hs +++ b/primer/test/Tests/Action/Prog.hs @@ -32,7 +32,6 @@ import Primer.App ( ProgError (..), Question (VariablesInScope), Selection (..), - defaultTypeDefs, handleEditRequest, handleQuestion, importModules, @@ -43,7 +42,7 @@ import Primer.App ( newProg, tcWholeProg, ) -import Primer.Builtins (cCons, cJust, cMakePair, cNil, tBool, tList, tMaybe, tPair) +import Primer.Builtins (builtinModule, cCons, cJust, cMakePair, cNil, tBool, tList, tMaybe, tPair) import Primer.Core ( ASTDef (..), ASTTypeDef (..), @@ -90,13 +89,12 @@ import Primer.Core.DSL ( tvar, ) import Primer.Core.Utils (forgetIDs) -import Primer.Module (Module (moduleDefs, moduleTypes)) +import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) import Primer.Name -import Primer.Primitives (tChar, tInt) -import Primer.Typecheck (mkTypeDefMap) +import Primer.Primitives (primitiveModule, tChar, tInt) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import TestM (TestM, evalTestM) -import TestUtils (constructTCon, withPrimDefs) +import TestUtils (constructTCon) import Tests.Typecheck (checkProgWellFormed) unit_empty_actions_only_change_the_log :: Assertion @@ -646,8 +644,7 @@ unit_copy_paste_sig2ann = do unit_import_vars :: Assertion unit_import_vars = let test = do - p <- defaultFullProg - importModules [progModule p] + importModules [builtinModule, primitiveModule] gets (Map.assocs . moduleDefs . progModule . appProg) >>= \case [(i, DefAST d)] -> do a' <- get @@ -688,10 +685,18 @@ unit_import_reference = unit_copy_paste_import :: Assertion unit_copy_paste_import = let test = do - p <- defaultFullProg - importModules [progModule p] + importModules [builtinModule] + ty <- tcon tBool `tfun` tcon tBool + e <- lam "x" $ lvar "x" + let def = ASTDef "foo" e ty + let m = + Module + { moduleTypes = mempty + , moduleDefs = Map.singleton "foo" $ DefAST def + } + importModules [m] prog <- gets appProg - case (findGlobalByName prog "other", Map.assocs $ moduleDefs $ progModule prog) of + case (findGlobalByName prog "foo", Map.assocs $ moduleDefs $ progModule prog) of (Just (DefAST other), [(i, _)]) -> do let fromDef = astDefName other fromType = getID $ astDefType other @@ -703,7 +708,7 @@ unit_copy_paste_import = , CopyPasteBody (fromDef, fromExpr) [] ] pure $ pure () - (Nothing, _) -> pure $ assertFailure "Could not find the imported 'other'" + (Nothing, _) -> pure $ assertFailure "Could not find the imported 'foo'" (Just _, _) -> pure $ assertFailure "Expected one def 'main' from newEmptyApp" a = newEmptyApp in case fst $ runAppTestM (ID $ appIdCounter a) a test of @@ -1061,15 +1066,14 @@ unit_good_defaultEmptyProg :: Assertion unit_good_defaultEmptyProg = checkProgWellFormed defaultEmptyProg -- `defaultEmptyProg`, plus all primitive definitions (types and terms), --- and all builtin types. +-- and all builtin types, all moved into the editable module defaultFullProg :: MonadFresh ID m => m Prog defaultFullProg = do p <- defaultEmptyProg - withPrimDefs $ \m -> - pure $ - over (#progModule % #moduleTypes) (defaultTypeDefs <>) - . over (#progModule % #moduleDefs) ((DefPrim <$> m) <>) - $ p + pure $ + over (#progModule % #moduleTypes) ((moduleTypes builtinModule <> moduleTypes primitiveModule) <>) + . over (#progModule % #moduleDefs) (moduleDefs primitiveModule <>) + $ p findTypeDef :: TyConName -> Prog -> IO ASTTypeDef findTypeDef d p = maybe (assertFailure "couldn't find typedef") pure $ (typeDefAST <=< Map.lookup d) $ p ^. (#progModule % #moduleTypes) @@ -1078,9 +1082,10 @@ findDef :: GVarName -> Prog -> IO ASTDef findDef d p = maybe (assertFailure "couldn't find def") pure $ (defAST <=< Map.lookup d) $ p ^. (#progModule % #moduleDefs) -- We use the same type definition for all tests related to editing type definitions +-- (This is added to `defaultFullProg`) defaultProgEditableTypeDefs :: MonadFresh ID f => f [ASTDef] -> f Prog defaultProgEditableTypeDefs ds = do - p <- defaultEmptyProg + p <- defaultFullProg ds' <- ds let tds = [ TypeDefAST @@ -1093,7 +1098,7 @@ defaultProgEditableTypeDefs ds = do ] pure $ p - & (#progModule % #moduleTypes) %~ ((mkTypeDefMap tds <> defaultTypeDefs) <>) + & (#progModule % #moduleTypes) %~ (mkTypeDefMap tds <>) & (#progModule % #moduleDefs) %~ (Map.fromList ((\d -> (astDefName d, DefAST d)) <$> ds') <>) unit_good_defaultFullProg :: Assertion diff --git a/primer/test/Tests/Eval.hs b/primer/test/Tests/Eval.hs index 8cd988ab3..536995ece 100644 --- a/primer/test/Tests/Eval.hs +++ b/primer/test/Tests/Eval.hs @@ -11,13 +11,13 @@ import Primer.App ( App (appIdCounter), EvalReq (EvalReq, evalReqExpr, evalReqRedex), EvalResp (EvalResp, evalRespExpr), - Prog (progModule), handleEvalRequest, importModules, newEmptyApp, ) import Primer.Builtins ( boolDef, + builtinModule, cFalse, cNil, cTrue, @@ -53,14 +53,13 @@ import Primer.Eval ( tryReduceExpr, tryReduceType, ) -import Primer.Module (Module (Module, moduleDefs, moduleTypes)) -import Primer.Primitives (primitiveGVar, tChar) -import Primer.Typecheck (mkTypeDefMap) +import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) +import Primer.Primitives (primitiveGVar, primitiveModule, tChar) import Primer.Zipper (target) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=)) import TestM (evalTestM) import TestUtils (withPrimDefs) -import Tests.Action.Prog (defaultFullProg, runAppTestM) +import Tests.Action.Prog (runAppTestM) -- * 'tryReduce' tests @@ -821,8 +820,7 @@ unit_redexes_prim_ann = unit_eval_modules :: Assertion unit_eval_modules = let test = do - p <- defaultFullProg - importModules [progModule p] + importModules [primitiveModule, builtinModule] foo <- gvar (primitiveGVar "toUpper") `app` char 'a' EvalResp{evalRespExpr = e} <- handleEvalRequest diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs index 8fa78a868..531c671a3 100644 --- a/primer/test/Tests/EvalFull.hs +++ b/primer/test/Tests/EvalFull.hs @@ -5,8 +5,8 @@ import Foreword hiding (unlines) import Control.Monad.Fresh (MonadFresh) import Data.Generics.Uniplate.Data (universe) import Data.List ((\\)) -import Data.Map ((!)) import qualified Data.Map as M +import qualified Data.Map as Map import qualified Data.Set as S import Data.String (unlines) import Gen.Core.Typed (WT, forAllT, genChk, genSyn, genWTType, isolateWT, propertyWT) @@ -18,8 +18,6 @@ import Primer.App ( App (appIdCounter), EvalFullReq (EvalFullReq, evalFullCxtDir, evalFullMaxSteps, evalFullReqExpr), EvalFullResp (EvalFullRespNormal, EvalFullRespTimedOut), - Prog (progModule), - defaultTypeDefs, handleEvalFullRequest, importModules, newEmptyApp, @@ -27,25 +25,19 @@ import Primer.App ( import Primer.Builtins import Primer.Core import Primer.Core.DSL -import Primer.Core.Utils (forgetIDs, forgetTypeIDs, generateIDs, generateTypeIDs) +import Primer.Core.Utils (forgetIDs, generateIDs) import Primer.EvalFull -import Primer.Module (Module (Module, moduleDefs, moduleTypes)) -import Primer.Primitives (allPrimDefs, primitiveGVar, tChar, tInt) +import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) +import Primer.Primitives (primitiveGVar, primitiveModule, tChar, tInt) import Primer.Typecheck ( - SmartHoles (NoSmartHoles), - buildTypingContext, - extendGlobalCxt, - globalCxt, - mkTypeDefMap, typeDefs, ) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=)) import TestM import TestUtils (withPrimDefs) -import Tests.Action.Prog (defaultFullProg, runAppTestM) +import Tests.Action.Prog (runAppTestM) import Tests.Eval ((~=)) import Tests.Gen.Core.Typed (checkTest) -import Prelude (error) unit_1 :: Assertion unit_1 = @@ -166,10 +158,10 @@ unit_8 = expect <- mkList (tcon tBool) (take n $ cycle [con cTrue, con cFalse]) `ann` (tcon tList `tapp` tcon tBool) pure (globs, expr, expect) in do - case evalFullTest maxID defaultTypeDefs (M.fromList globals) 500 Syn e of + case evalFullTest maxID builtinTypes (M.fromList globals) 500 Syn e of Left (TimedOut _) -> pure () x -> assertFailure $ show x - let s = evalFullTest maxID defaultTypeDefs (M.fromList globals) 1000 Syn e + let s = evalFullTest maxID builtinTypes (M.fromList globals) 1000 Syn e distinctIDs s s <~==> Right expected @@ -203,10 +195,10 @@ unit_9 = expect <- mkList (tcon tBool) (take n $ cycle [con cTrue, con cFalse]) `ann` (tcon tList `tapp` tcon tBool) pure (globs, expr, expect) in do - case evalFullTest maxID defaultTypeDefs (M.fromList globals) 500 Syn e of + case evalFullTest maxID builtinTypes (M.fromList globals) 500 Syn e of Left (TimedOut _) -> pure () x -> assertFailure $ show x - let s = evalFullTest maxID defaultTypeDefs (M.fromList globals) 1000 Syn e + let s = evalFullTest maxID builtinTypes (M.fromList globals) 1000 Syn e distinctIDs s s <~==> Right expected @@ -232,8 +224,8 @@ unit_10 = expect <- con cTrue pure (annCase, noannCase, expect) in do - let s' = evalFullTest maxID defaultTypeDefs mempty 2 Syn s - t' = evalFullTest maxID defaultTypeDefs mempty 2 Syn t + let s' = evalFullTest maxID builtinTypes mempty 2 Syn s + t' = evalFullTest maxID builtinTypes mempty 2 Syn t distinctIDs s' s' <~==> Right expected distinctIDs t' @@ -265,10 +257,10 @@ unit_11 = `ann` (tcon tPair `tapp` tcon tBool `tapp` tcon tNat) pure (globs, expr, expect) in do - case evalFullTest maxID defaultTypeDefs (M.fromList globals) 10 Syn e of + case evalFullTest maxID builtinTypes (M.fromList globals) 10 Syn e of Left (TimedOut _) -> pure () x -> assertFailure $ show x - let s = evalFullTest maxID defaultTypeDefs (M.fromList globals) 20 Syn e + let s = evalFullTest maxID builtinTypes (M.fromList globals) 20 Syn e distinctIDs s s <~==> Right expected @@ -290,7 +282,7 @@ unit_12 = expect <- con cTrue `ann` tcon tBool pure (expr, expect) in do - let s = evalFullTest maxID defaultTypeDefs mempty 15 Syn e + let s = evalFullTest maxID builtinTypes mempty 15 Syn e distinctIDs s s <~==> Right expected @@ -301,7 +293,7 @@ unit_13 = expect <- (con "C" `app` con cZero `app` con cTrue `app` con cZero) `ann` tcon tBool pure (expr, expect) in do - let s = evalFullTest maxID defaultTypeDefs mempty 15 Syn e + let s = evalFullTest maxID builtinTypes mempty 15 Syn e distinctIDs s s <~==> Right expected @@ -312,7 +304,7 @@ unit_14 = expect <- con cZero `ann` tcon tNat pure (expr, expect) in do - let s = evalFullTest maxID defaultTypeDefs mempty 15 Syn e + let s = evalFullTest maxID builtinTypes mempty 15 Syn e distinctIDs s s <~==> Right expected @@ -339,19 +331,19 @@ unit_15 = e5 <- lam y' $ c "y" y' pure (e0, [e0, e1, e2, e3, e4, e5], e5) in do - let si = map (\i -> evalFullTest maxID defaultTypeDefs mempty i Syn expr) [0 .. fromIntegral $ length steps - 1] + let si = map (\i -> evalFullTest maxID builtinTypes mempty i Syn expr) [0 .. fromIntegral $ length steps - 1] f s e = do distinctIDs s s <~==> Left (TimedOut e) zipWithM_ f si steps - let s = evalFullTest maxID defaultTypeDefs mempty (fromIntegral $ length steps) Syn expr + let s = evalFullTest maxID builtinTypes mempty (fromIntegral $ length steps) Syn expr distinctIDs s s <~==> Right expected unit_hole_ann_case :: Assertion unit_hole_ann_case = let (tm, maxID) = create $ hole $ ann (case_ emptyHole []) (tcon tBool) - in evalFullTest maxID defaultTypeDefs mempty 1 Chk tm @?= Right tm + in evalFullTest maxID builtinTypes mempty 1 Chk tm @?= Right tm -- TODO: examples with holes @@ -362,14 +354,14 @@ unit_hole_ann_case = -- | Resuming evaluation is the same as running it for longer in the first place hprop_resume :: Property hprop_resume = withDiscards 2000 $ - propertyWT (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ - withGlobals testGlobals $ \fixedGlobs -> do - (dir, t, _, globs) <- genDirTmGlobs fixedGlobs - resumeTest globs dir t + propertyWT testModules $ do + (dir, t, _) <- genDirTm + resumeTest testModules dir t -- A helper for hprop_resume, and hprop_resume_regression -resumeTest :: Map GVarName Def -> Dir -> Expr -> PropertyT WT () -resumeTest globs dir t = do +resumeTest :: [Module] -> Dir -> Expr -> PropertyT WT () +resumeTest mods dir t = do + let globs = foldMap moduleDefs mods tds <- asks typeDefs n <- forAllT $ Gen.integral $ Range.linear 2 1000 -- Arbitrary limit here -- NB: We need to run this first reduction in an isolated context @@ -398,7 +390,7 @@ resumeTest globs dir t = do -- the two reduction attempts in resumeTest should not interfere with each -- other's names, else we will get occasional failures in that property test. hprop_resume_regression :: Property -hprop_resume_regression = propertyWT (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do +hprop_resume_regression = propertyWT [] $ do -- This indeed requires fresh names when reducing (see unit_type_preservation_rename_LAM_regression) t <- lAM "a" (letrec "b" emptyHole (tvar "a") (lAM "a" emptyHole)) resumeTest mempty Chk t @@ -430,31 +422,31 @@ unit_type_preservation_rename_LAM_regression = hprop_type_preservation :: Property hprop_type_preservation = withTests 1000 $ withDiscards 2000 $ - propertyWT (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ - withGlobals testGlobals $ \fixedGlobs -> do - tds <- asks typeDefs - (dir, t, ty, globs) <- genDirTmGlobs fixedGlobs - let test msg e = do - s <- case e of - Left (TimedOut s') -> label (msg <> "TimedOut") >> pure s' - Right s' -> label (msg <> "NF") >> pure s' - if null [() | LetType{} <- universe s] - then do - annotateShow s - s' <- checkTest ty s - forgetIDs s === forgetIDs s' -- check no smart holes happened - else label (msg <> "skipped due to LetType") >> success - maxSteps <- forAllT $ Gen.integral $ Range.linear 1 1000 -- Arbitrary limit here - (steps, s) <- evalFullStepCount tds globs maxSteps dir t - -- s is often reduced to normal form - test "long " s - -- also test an intermediate point - if steps <= 1 - then label "generated a normal form" - else do - midSteps <- forAllT $ Gen.integral $ Range.linear 1 (steps - 1) - (_, s') <- evalFullStepCount tds globs midSteps dir t - test "mid " s' + propertyWT testModules $ do + let globs = foldMap moduleDefs testModules + tds <- asks typeDefs + (dir, t, ty) <- genDirTm + let test msg e = do + s <- case e of + Left (TimedOut s') -> label (msg <> "TimedOut") >> pure s' + Right s' -> label (msg <> "NF") >> pure s' + if null [() | LetType{} <- universe s] + then do + annotateShow s + s' <- checkTest ty s + forgetIDs s === forgetIDs s' -- check no smart holes happened + else label (msg <> "skipped due to LetType") >> success + maxSteps <- forAllT $ Gen.integral $ Range.linear 1 1000 -- Arbitrary limit here + (steps, s) <- evalFullStepCount tds globs maxSteps dir t + -- s is often reduced to normal form + test "long " s + -- also test an intermediate point + if steps <= 1 + then label "generated a normal form" + else do + midSteps <- forAllT $ Gen.integral $ Range.linear 1 (steps - 1) + (_, s') <- evalFullStepCount tds globs midSteps dir t + test "mid " s' unit_prim_toUpper :: Assertion unit_prim_toUpper = @@ -510,7 +502,7 @@ hprop_prim_hex_nat = withTests 20 . property $ do <*> con cNothing `aPP` tcon tChar <*> pure (DefPrim <$> globals) - s = evalFullTest maxID defaultTypeDefs gs 7 Syn e + s = evalFullTest maxID builtinTypes gs 7 Syn e set _ids' 0 s === set _ids' 0 (Right r) unit_prim_char_eq_1 :: Assertion @@ -856,7 +848,7 @@ unit_prim_ann = `app` (char 'a' `ann` tcon tChar) <*> char 'A' <*> pure (DefPrim <$> globals) - s = evalFullTest maxID defaultTypeDefs gs 2 Syn e + s = evalFullTest maxID builtinTypes gs 2 Syn e in do distinctIDs s s <~==> Right r @@ -885,7 +877,7 @@ unit_prim_partial_map = ] `ann` (tcon tList `tapp` tcon tChar) <*> pure (M.singleton (defName map_) map_ <> (DefPrim <$> globals)) - s = evalFullTest maxID defaultTypeDefs gs 65 Syn e + s = evalFullTest maxID builtinTypes gs 65 Syn e in do distinctIDs s s <~==> Right r @@ -907,8 +899,7 @@ unit_prim_partial_map = unit_eval_full_modules :: Assertion unit_eval_full_modules = let test = do - p <- defaultFullProg - importModules [progModule p] + importModules [primitiveModule, builtinModule] foo <- gvar (primitiveGVar "toUpper") `app` char 'a' resp <- handleEvalFullRequest @@ -987,20 +978,13 @@ binaryPrimTest f x y z = -- -- * a term (to be the subject of some evaluation steps) -- --- * definitions for each global variable (to be the environment of the evaluation steps) --- -- Also returns -- -- * whether the term is synthesisable or checkable -- -- * the type of the term --- --- The first arg is "given" globals: in the "globals" return, we will --- return the corresponding ones in this list, if one exists. --- Thus you can specify a few particular terms you want in scope --- (e.g. primitives), and generate the rest. -genDirTmGlobs :: [Def] -> PropertyT WT (Dir, Expr, Type' (), M.Map GVarName Def) -genDirTmGlobs defs = do +genDirTm :: PropertyT WT (Dir, Expr, Type' ()) +genDirTm = do dir <- forAllT $ Gen.element [Chk, Syn] (t', ty) <- case dir of Chk -> do @@ -1009,35 +993,28 @@ genDirTmGlobs defs = do pure (t', ty') Syn -> forAllT genSyn t <- generateIDs t' - globTypes <- asks globalCxt - let genDef n defTy = case find ((== n) . defName) defs of - Just d -> do - unless (forgetTypeIDs (defType d) == defTy) $ - -- This is a bug in the calling property. Bail out loudly! - error "genDirTmGlobs: given def had different type to expected from context" - pure d - Nothing -> - (\ty' e -> DefAST ASTDef{astDefName = n, astDefType = ty', astDefExpr = e}) - <$> generateTypeIDs defTy <*> (generateIDs =<< genChk defTy) - globs <- forAllT $ M.traverseWithKey genDef globTypes - pure (dir, t, ty, globs) - --- | Adds the global's types to the global context, and gives you access to the definitions, --- to e.g. pass to 'genDirTmGlobs' -withGlobals :: WT [Def] -> ([Def] -> PropertyT WT a) -> PropertyT WT a -withGlobals mdefs prop = do - defs <- lift mdefs - let cxtext = flip map defs $ \d -> (defName d, forgetTypeIDs $ defType d) - local (extendGlobalCxt cxtext) (prop defs) + pure (dir, t, ty) -- | Some generally-useful globals to have around when testing. --- Currently: an AST identity function on Char and a primitive @toUpper@. -testGlobals :: WT [Def] -testGlobals = do - idCharDef <- ASTDef <$> pure "idChar" <*> lam "x" (lvar "x") <*> (tcon tChar `tfun` tcon tChar) - let toUpperFun = allPrimDefs ! "toUpper" - toUpperDef <- PrimDef <$> pure "toUpper" <*> primFunType toUpperFun - pure [DefAST idCharDef, DefPrim toUpperDef] +-- Currently: an AST identity function on Char and all builtins and +-- primitives +testModules :: [Module] +testModules = [builtinModule, primitiveModule, testModule] + +testModule :: Module +testModule = + let (ty, expr) = fst . create $ (,) <$> tcon tChar `tfun` tcon tChar <*> lam "x" (lvar "x") + in Module + { moduleTypes = mempty + , moduleDefs = + Map.singleton "idChar" $ + DefAST + ASTDef + { astDefName = "idChar" + , astDefType = ty + , astDefExpr = expr + } + } _ids :: Traversal' Expr ID _ids = (_exprMeta % _id) `adjoin` (_exprTypeMeta % _id) @@ -1064,3 +1041,6 @@ distinctIDs e = ] ) (nIds == nDistinct) + +builtinTypes :: Map TyConName TypeDef +builtinTypes = moduleTypes builtinModule diff --git a/primer/test/Tests/Gen/Core/Typed.hs b/primer/test/Tests/Gen/Core/Typed.hs index aae5eb88d..2ccdbf5b3 100644 --- a/primer/test/Tests/Gen/Core/Typed.hs +++ b/primer/test/Tests/Gen/Core/Typed.hs @@ -29,7 +29,7 @@ import Hedgehog ( (===), ) import Hedgehog.Internal.Property (forAllT) -import Primer.App (defaultTypeDefs) +import Primer.Builtins (builtinModule) import Primer.Core ( Expr, Kind (KType), @@ -43,12 +43,13 @@ import Primer.Core.Utils ( generateIDs, generateTypeIDs, ) +import Primer.Module (Module) +import Primer.Primitives (primitiveModule) import Primer.Typecheck ( Cxt (..), ExprT, SmartHoles (NoSmartHoles), TypeError, - buildTypingContext, check, checkKind, checkValidContext, @@ -75,15 +76,15 @@ inExtendedLocalCxt p = do annotateShow $ M.differenceWith (\l r -> if l == r then Nothing else Just l) (localCxt cxtE) (localCxt cxt) local (const cxtE) p -propertyWTInExtendedGlobalCxt :: Cxt -> PropertyT WT () -> Property -propertyWTInExtendedGlobalCxt cxt = propertyWT cxt . inExtendedGlobalCxt +propertyWTInExtendedGlobalCxt :: [Module] -> PropertyT WT () -> Property +propertyWTInExtendedGlobalCxt mods = propertyWT mods . inExtendedGlobalCxt -propertyWTInExtendedLocalGlobalCxt :: Cxt -> PropertyT WT () -> Property -propertyWTInExtendedLocalGlobalCxt cxt = propertyWT cxt . inExtendedLocalCxt . inExtendedGlobalCxt +propertyWTInExtendedLocalGlobalCxt :: [Module] -> PropertyT WT () -> Property +propertyWTInExtendedLocalGlobalCxt mods = propertyWT mods . inExtendedLocalCxt . inExtendedGlobalCxt hprop_genTy :: Property hprop_genTy = withTests 1000 $ - propertyWTInExtendedGlobalCxt (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do + propertyWTInExtendedGlobalCxt [builtinModule, primitiveModule] $ do k <- forAllT genWTKind ty <- forAllT $ genWTType k ty' <- checkKindTest k =<< generateTypeIDs ty @@ -116,7 +117,7 @@ checkValidContextTest t = do -- This indirectly also tests genCxtExtendingLocal, genCxtExtendingGlobal and genTypeDefGroup hprop_genCxtExtending_typechecks :: Property hprop_genCxtExtending_typechecks = withTests 1000 $ - propertyWT (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do + propertyWT [builtinModule, primitiveModule] $ do cxt <- forAllT genCxtExtendingGlobal checkValidContextTest cxt cxt' <- forAllT $ local (const cxt) genCxtExtendingLocal @@ -126,7 +127,7 @@ hprop_genCxtExtending_is_extension :: Property hprop_genCxtExtending_is_extension = withTests 1000 $ let cxt0 = initialCxt NoSmartHoles - in propertyWT cxt0 $ do + in propertyWT [] $ do cxt1 <- forAllT genCxtExtendingGlobal diff cxt0 extendsGlobal cxt1 cxt2 <- forAllT $ local (const cxt1) genCxtExtendingGlobal @@ -155,7 +156,7 @@ hprop_genCxtExtending_is_extension = hprop_genSyns :: Property hprop_genSyns = withTests 1000 $ withDiscards 2000 $ - propertyWTInExtendedLocalGlobalCxt (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do + propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tgtTy <- forAllT $ genWTType KType _ :: Type' (Meta Kind) <- checkKindTest KType =<< generateTypeIDs tgtTy (e, ty) <- forAllT $ genSyns tgtTy @@ -169,7 +170,7 @@ hprop_genSyns = withTests 1000 $ hprop_genChk :: Property hprop_genChk = withTests 1000 $ withDiscards 2000 $ - propertyWTInExtendedLocalGlobalCxt (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do + propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do ty <- forAllT $ genWTType KType _ :: Type' (Meta Kind) <- checkKindTest KType =<< generateTypeIDs ty t <- forAllT $ genChk ty diff --git a/primer/test/Tests/Primitives.hs b/primer/test/Tests/Primitives.hs index d77e7c1d7..e8322feec 100644 --- a/primer/test/Tests/Primitives.hs +++ b/primer/test/Tests/Primitives.hs @@ -8,7 +8,6 @@ import qualified Data.Map as M import Gen.Core.Typed (forAllT, genPrimCon, propertyWT) import Hedgehog (Property, assert) import Hedgehog.Gen (choice) -import Primer.App (defaultTypeDefs) import Primer.Core ( ASTTypeDef ( ASTTypeDef, @@ -22,22 +21,24 @@ import Primer.Core ( primConName, ) import Primer.Core.DSL (char, tcon) -import Primer.Primitives (allPrimTypeDefs, tChar) +import Primer.Primitives (allPrimTypeDefs, primitiveModule, tChar) import Primer.Typecheck ( SmartHoles (NoSmartHoles), TypeError (PrimitiveTypeNotInScope, UnknownTypeConstructor), buildTypingContext, + buildTypingContextFromModules, checkKind, checkValidContext, - mkTypeDefMap, synth, ) +import Primer.Builtins (builtinModule) +import Primer.Module (mkTypeDefMap) import Test.Tasty.HUnit (Assertion, assertBool, (@?=)) -import Tests.Typecheck (runTypecheckTestMFromIn) +import Tests.Typecheck (runTypecheckTestMIn) hprop_all_prim_cons_have_typedef :: Property -hprop_all_prim_cons_have_typedef = propertyWT (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do +hprop_all_prim_cons_have_typedef = propertyWT [builtinModule, primitiveModule] $ do c <- forAllT $ (fmap fst . choice) =<< genPrimCon assert $ primConName c `elem` M.keys allPrimTypeDefs @@ -49,8 +50,8 @@ unit_prim_con_scope = do test (checkKind KType =<< tcon tChar) @?= Left (UnknownTypeConstructor tChar) test (synth =<< char 'a') @?= Left (PrimitiveTypeNotInScope tChar) where - cxt = buildTypingContext mempty mempty NoSmartHoles - test = runTypecheckTestMFromIn 0 cxt + cxt = buildTypingContextFromModules mempty NoSmartHoles + test = runTypecheckTestMIn cxt -- If we use a prim con, then we need the corresponding prim type -- in scope, and not some other type of that name @@ -74,4 +75,4 @@ unit_prim_con_scope_ast = do } cxt = buildTypingContext (mkTypeDefMap [charASTDef]) mempty NoSmartHoles - test = runTypecheckTestMFromIn 0 cxt + test = runTypecheckTestMIn cxt diff --git a/primer/test/Tests/Question.hs b/primer/test/Tests/Question.hs index 471c5c147..95f7f8000 100644 --- a/primer/test/Tests/Question.hs +++ b/primer/test/Tests/Question.hs @@ -9,7 +9,6 @@ import Hedgehog hiding (check) import Hedgehog.Classes import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Primer.App (defaultTypeDefs) import Primer.Builtins import Primer.Core ( Expr, @@ -37,7 +36,7 @@ import Primer.Questions ( import Primer.Typecheck ( Cxt, SmartHoles (NoSmartHoles), - buildTypingContext, + buildTypingContextFromModules, exprTtoExpr, synth, ) @@ -298,7 +297,7 @@ unit_hasGeneratedNames_3 = do hasGeneratedNamesExpr expr Nothing (down >=> down >=> right) ["z", "x1", "y1"] defCxt :: Cxt -defCxt = buildTypingContext defaultTypeDefs mempty NoSmartHoles +defCxt = buildTypingContextFromModules [builtinModule] NoSmartHoles hasGeneratedNamesExpr :: S Expr -> Maybe (S Type) -> (ExprZ -> Maybe ExprZ) -> [Name] -> Assertion hasGeneratedNamesExpr expr ty path expected = do diff --git a/primer/test/Tests/Refine.hs b/primer/test/Tests/Refine.hs index 369174895..4702be4ff 100644 --- a/primer/test/Tests/Refine.hs +++ b/primer/test/Tests/Refine.hs @@ -26,8 +26,7 @@ import Hedgehog ( ) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Primer.App (defaultTypeDefs) -import Primer.Builtins (tBool, tList, tNat) +import Primer.Builtins (builtinModule, tBool, tList, tNat) import Primer.Core ( Expr' (APP, Ann, App, EmptyHole), ID, @@ -41,13 +40,14 @@ import Primer.Core ( ) import Primer.Core.Utils (forgetIDs, freeVarsTy, generateIDs, noHoles) import Primer.Name (NameCounter) +import Primer.Primitives (primitiveModule) import Primer.Refine (Inst (InstAPP, InstApp, InstUnconstrainedAPP), refine) import Primer.Subst (substTy, substTys) import Primer.Typecheck ( Cxt, SmartHoles (NoSmartHoles), Type, - buildTypingContext, + buildTypingContextFromModules, consistentTypes, extendLocalCxtTy, typeDefs, @@ -57,7 +57,7 @@ import TestM (evalTestM) import Tests.Gen.Core.Typed (propertyWTInExtendedLocalGlobalCxt, synthTest) defaultCxt :: Cxt -defaultCxt = buildTypingContext defaultTypeDefs mempty NoSmartHoles +defaultCxt = buildTypingContextFromModules [builtinModule, primitiveModule] NoSmartHoles refine' :: (MonadFresh NameCounter m, MonadFresh ID m) => Cxt -> Type -> Type -> m (Maybe ([Inst], Type)) refine' cxt s t = fmap (either crash identity) $ runExceptT $ refine cxt s t @@ -182,7 +182,7 @@ unit_alpha = -- refine cxt T T succeeds hprop_refl :: Property -hprop_refl = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_refl = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do k <- forAllT genWTKind ty <- forAllT $ genWTType k cxt <- ask @@ -191,7 +191,7 @@ hprop_refl = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- refine _ ? S succeeds hprop_tgt_hole :: Property -hprop_tgt_hole = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_tgt_hole = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do k <- forAllT genWTKind tgt <- forAllT $ Gen.choice [pure $ TEmptyHole (), THole () <$> genWTType k] src <- forAllT $ genWTType k @@ -201,7 +201,7 @@ hprop_tgt_hole = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- refine _ T ? succeeds hprop_src_hole :: Property -hprop_src_hole = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_src_hole = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do k <- forAllT genWTKind tgt <- forAllT $ genWTType k src <- forAllT $ Gen.choice [pure $ TEmptyHole (), THole () <$> genWTType k] @@ -211,9 +211,10 @@ hprop_src_hole = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- constructor types refine to their fully-applied typedef hprop_con :: Property -hprop_con = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_con = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tcs <- asks $ mapMaybe typeDefAST . M.elems . typeDefs - -- NB: this only works because defaultCxt has at least one tydef with a constructor + -- NB: this only works because our context has at least one tydef with a constructor + -- (because, among others, it includes builtinModule that contains Bool) td <- forAllT $ Gen.element tcs let cons = astTypeDefConstructors td when (null cons) discard @@ -232,7 +233,7 @@ hprop_con = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- refine cxt T S succeds when S is built from T, S1 -> _, ∀a._ -- The success may not instantiate as much as one would expect, if T has holes in hprop_arr_app :: Property -hprop_arr_app = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_arr_app = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tgt <- forAllT $ genWTType KType when (isHole tgt) discard src' <- forAllT $ Gen.list (Range.linear 0 10) $ Gen.choice [Left <$> genWTType KType, curry Right <$> freshTyVarNameForCxt <*> genWTKind] @@ -257,7 +258,7 @@ hprop_arr_app = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- if refine _ T S = Just (I:IS,_) , then refine _ T (S $ I) = Just (IS,_); here "S $ I" means "inspect S, I assert they match and strip off a layer" hprop_matches :: Property hprop_matches = withDiscards 2000 $ - propertyWTInExtendedLocalGlobalCxt defaultCxt $ do + propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tgt <- forAllT $ genWTType KType src <- forAllT $ genWTType KType cxt <- ask @@ -281,7 +282,7 @@ hprop_matches = withDiscards 2000 $ -- if refine cxt tgt s = Just (is,ty) => (? : s) $ ∈ ty[instantiation vars substituted appropriately] ~ tgt hprop_refinement_synths :: Property -hprop_refinement_synths = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_refinement_synths = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tgt <- forAllT $ genWTType KType src <- forAllT $ genWTType KType cxt <- ask @@ -305,7 +306,7 @@ hprop_refinement_synths = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- | (Because unif vars are only in one side) the names from -- 'InstUnconstrainedAPP' do not appear in 'InstAPP's (but can in 'InstApp's) hprop_scoping :: Property -hprop_scoping = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_scoping = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do tgt <- forAllT $ genWTType KType src <- forAllT $ genWTType KType cxt <- ask diff --git a/primer/test/Tests/Serialization.hs b/primer/test/Tests/Serialization.hs index 5e998834b..75a4800f8 100644 --- a/primer/test/Tests/Serialization.hs +++ b/primer/test/Tests/Serialization.hs @@ -43,9 +43,9 @@ import Primer.Core ( TypeMeta, ValCon (..), ) -import Primer.Module (Module (Module, moduleDefs, moduleTypes)) +import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) import Primer.Name (unsafeMkName) -import Primer.Typecheck (SmartHoles (SmartHoles), mkTypeDefMap) +import Primer.Typecheck (SmartHoles (SmartHoles)) import System.FilePath (takeBaseName) import Test.Tasty import Test.Tasty.Golden diff --git a/primer/test/Tests/Typecheck.hs b/primer/test/Tests/Typecheck.hs index 0278bd92c..50523d894 100644 --- a/primer/test/Tests/Typecheck.hs +++ b/primer/test/Tests/Typecheck.hs @@ -23,13 +23,13 @@ import qualified Hedgehog.Range as Range import Optics (over, set) import Primer.App ( Prog (progImports), - defaultTypeDefs, newEmptyProg, newProg, progModule, ) import Primer.Builtins ( boolDef, + builtinModule, cCons, cFalse, cNil, @@ -74,24 +74,22 @@ import Primer.Core.DSL import Primer.Core.Utils (generateIDs, generateTypeIDs) import Primer.Module import Primer.Name (NameCounter) -import Primer.Primitives (primitiveGVar, tChar) +import Primer.Primitives (primitiveGVar, primitiveModule, tChar) import Primer.Typecheck ( CheckEverythingRequest (CheckEverything, toCheck, trusted), Cxt, ExprT, SmartHoles (NoSmartHoles, SmartHoles), TypeError (..), - buildTypingContext, + buildTypingContextFromModules, checkEverything, decomposeTAppCon, mkTAppCon, - mkTypeDefMap, synth, synthKind, ) import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) import TestM (TestM, evalTestM) -import TestUtils (withPrimDefs) import Tests.Gen.Core.Typed unit_identity :: Assertion @@ -486,7 +484,7 @@ unit_prim_fun_applied = hprop_synth_well_typed_extcxt :: Property hprop_synth_well_typed_extcxt = withTests 1000 $ withDiscards 2000 $ - propertyWTInExtendedLocalGlobalCxt (buildTypingContext defaultTypeDefs mempty NoSmartHoles) $ do + propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do (e, _ty) <- forAllT genSyn ty' <- generateTypeIDs . fst =<< synthTest =<< generateIDs e void $ checkKindTest KType ty' @@ -497,7 +495,7 @@ hprop_synth_well_typed_extcxt = withTests 1000 $ hprop_synth_well_typed_defcxt :: Property hprop_synth_well_typed_defcxt = withTests 1000 $ withDiscards 2000 $ - propertyWT (buildTypingContext mempty mempty NoSmartHoles) $ do + propertyWT [] $ do (e, _ty) <- forAllT genSyn ty' <- generateTypeIDs . fst =<< synthTest =<< generateIDs e void $ checkKindTest KType ty' @@ -527,7 +525,7 @@ unit_good_maybeT = case runTypecheckTestM NoSmartHoles $ checkEverything NoSmartHoles CheckEverything - { trusted = [progModule newProg] + { trusted = [builtinModule] , toCheck = [Module (mkTypeDefMap [TypeDefAST maybeTDef]) mempty] } of Left err -> assertFailure $ show err @@ -636,22 +634,24 @@ newtype TypecheckTestM a = TypecheckTestM {unTypecheckTestM :: ExceptT TypeError , MonadError TypeError ) -runTypecheckTestMFromIn :: ID -> Cxt -> TypecheckTestM a -> Either TypeError a -runTypecheckTestMFromIn nextFresh cxt = - evalTestM nextFresh +runTypecheckTestMIn :: Cxt -> TypecheckTestM a -> Either TypeError a +runTypecheckTestMIn cxt = + evalTestM 0 . flip runReaderT cxt . runExceptT . unTypecheckTestM runTypecheckTestM :: SmartHoles -> TypecheckTestM a -> Either TypeError a -runTypecheckTestM sh = runTypecheckTestMFromIn 0 (buildTypingContext testingTypeDefs mempty sh) +runTypecheckTestM sh = runTypecheckTestMIn (buildTypingContextFromModules [testModule, builtinModule] sh) runTypecheckTestMWithPrims :: SmartHoles -> TypecheckTestM a -> Either TypeError a runTypecheckTestMWithPrims sh = - runTypecheckTestMFromIn n (buildTypingContext testingTypeDefs defs sh) - where - (defs, n) = create $ withPrimDefs $ \m -> pure $ DefPrim <$> m + runTypecheckTestMIn (buildTypingContextFromModules [testModule, builtinModule, primitiveModule] sh) -testingTypeDefs :: Map TyConName TypeDef -testingTypeDefs = mkTypeDefMap [TypeDefAST maybeTDef] <> defaultTypeDefs +testModule :: Module +testModule = + Module + { moduleTypes = mkTypeDefMap [TypeDefAST maybeTDef] + , moduleDefs = mempty + } tMaybeT :: TyConName tMaybeT = "MaybeT" diff --git a/primer/test/Tests/Unification.hs b/primer/test/Tests/Unification.hs index 2d5486337..94d83461e 100644 --- a/primer/test/Tests/Unification.hs +++ b/primer/test/Tests/Unification.hs @@ -32,18 +32,18 @@ import Hedgehog ( ) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range -import Primer.App (defaultTypeDefs) -import Primer.Builtins (tList, tNat) +import Primer.Builtins (builtinModule, tList, tNat) import Primer.Core (ID, Kind (KFun, KHole, KType), TyVarName, Type' (TApp, TCon, TEmptyHole, TForall, TFun, THole, TVar)) import Primer.Core.Utils (forgetTypeIDs, freeVarsTy, generateTypeIDs) +import Primer.Module (Module) import Primer.Name (NameCounter) -import Primer.Primitives (tInt) +import Primer.Primitives (primitiveModule, tInt) import Primer.Subst (substTys) import Primer.Typecheck ( Cxt, SmartHoles (NoSmartHoles), Type, - buildTypingContext, + buildTypingContextFromModules, consistentTypes, extendLocalCxt, extendLocalCxtTy, @@ -59,7 +59,7 @@ import Tests.Gen.Core.Typed ( ) defaultCxt :: Cxt -defaultCxt = buildTypingContext defaultTypeDefs mempty NoSmartHoles +defaultCxt = buildTypingContextFromModules [builtinModule, primitiveModule] NoSmartHoles unify' :: (MonadFresh NameCounter m, MonadFresh ID m) => @@ -385,24 +385,24 @@ genCxtExtendingLocalUVs = do -- Run a property in a context extended with typedefs, globals and locals. Some -- of the locals (mentioned in the Set) are considered unification variables. -propertyWTInExtendedUVCxt' :: Cxt -> (M.Map TyVarName Kind -> PropertyT WT ()) -> Property -propertyWTInExtendedUVCxt' cxt p = propertyWT cxt $ do +propertyWTInExtendedUVCxt' :: [Module] -> (M.Map TyVarName Kind -> PropertyT WT ()) -> Property +propertyWTInExtendedUVCxt' mods p = propertyWT mods $ do cxtG <- forAllT genCxtExtendingGlobal local (const cxtG) $ do (cxtL, uvs) <- forAllT genCxtExtendingLocalUVs annotateShow uvs local (const cxtL) $ p uvs -propertyWTInExtendedUVCxt :: Cxt -> (S.Set TyVarName -> PropertyT WT ()) -> Property -propertyWTInExtendedUVCxt cxt p = propertyWTInExtendedUVCxt' cxt $ p . M.keysSet +propertyWTInExtendedUVCxt :: [Module] -> (S.Set TyVarName -> PropertyT WT ()) -> Property +propertyWTInExtendedUVCxt mods p = propertyWTInExtendedUVCxt' mods $ p . M.keysSet hprop_extendedUVCxt_typechecks :: Property -hprop_extendedUVCxt_typechecks = propertyWTInExtendedUVCxt defaultCxt $ \_ -> +hprop_extendedUVCxt_typechecks = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \_ -> checkValidContextTest =<< ask -- unify _ _ T T is Just [] hprop_refl :: Property -hprop_refl = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_refl = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind t <- forAllT $ genWTType k @@ -411,7 +411,7 @@ hprop_refl = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- unify _ [] S T is Nothing or Just [], exactly when S = T up to holes hprop_eq :: Property -hprop_eq = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do +hprop_eq = propertyWTInExtendedLocalGlobalCxt [builtinModule, primitiveModule] $ do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -428,7 +428,7 @@ hprop_eq = propertyWTInExtendedLocalGlobalCxt defaultCxt $ do -- unify ga uvs S T = Maybe sub => sub <= uvs hprop_only_sub_uvs :: Property -hprop_only_sub_uvs = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_only_sub_uvs = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -440,7 +440,7 @@ hprop_only_sub_uvs = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- unify ga uvs S T = Maybe sub => S[sub] = T[sub] hprop_sub_unifies :: Property -hprop_sub_unifies = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_sub_unifies = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -455,7 +455,7 @@ hprop_sub_unifies = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- unify ga uvs S T = Maybe sub => for t/a in sub, have checkKind uvs(a) t hprop_sub_checks :: Property -hprop_sub_checks = propertyWTInExtendedUVCxt' defaultCxt $ \uvs -> do +hprop_sub_checks = propertyWTInExtendedUVCxt' [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -470,7 +470,7 @@ hprop_sub_checks = propertyWTInExtendedUVCxt' defaultCxt $ \uvs -> do -- (S,T kind check and) unify ga uvs S T = Maybe sub => S[sub] , T[sub] kind check hprop_unified_checks :: Property -hprop_unified_checks = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_unified_checks = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -490,7 +490,7 @@ hprop_unified_checks = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- This requires each to not be holey - i.e. don't synthesise KHole hprop_diff_kinds_never_unify :: Property hprop_diff_kinds_never_unify = withDiscards 5000 $ - propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do + propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k1 <- forAllT genWTKind k2 <- forAllT genWTKind @@ -506,7 +506,7 @@ hprop_diff_kinds_never_unify = withDiscards 5000 $ -- unification is symmetric hprop_sym :: Property -hprop_sym = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_sym = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -517,7 +517,7 @@ hprop_sym = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- the sub should be "non-cyclic", i.e. any sub should stabalise if done repeatedly hprop_non_cyclic :: Property -hprop_non_cyclic = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do +hprop_non_cyclic = propertyWTInExtendedUVCxt [builtinModule, primitiveModule] $ \uvs -> do cxt <- ask k <- forAllT genWTKind s <- forAllT $ genWTType k @@ -533,7 +533,7 @@ hprop_non_cyclic = propertyWTInExtendedUVCxt defaultCxt $ \uvs -> do -- unifying a unif var gives simple success hprop_uv_succeeds :: Property -hprop_uv_succeeds = propertyWT defaultCxt $ do +hprop_uv_succeeds = propertyWT [builtinModule, primitiveModule] $ do k <- forAllT genWTKind t <- forAllT $ genWTType k uv <- forAllT freshTyVarNameForCxt From d077aa02e8b0ce635eacce59578b5682b7e820d9 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Mon, 25 Apr 2022 12:43:08 +0100 Subject: [PATCH 6/8] refactor: utility to get all modules of a Prog --- primer/src/Primer/App.hs | 16 ++++++++++------ primer/test/Tests/Action/Prog.hs | 3 ++- primer/test/Tests/Typecheck.hs | 5 +++-- 3 files changed, 15 insertions(+), 9 deletions(-) diff --git a/primer/src/Primer/App.hs b/primer/src/Primer/App.hs index d5dad46f3..3f59a88e3 100644 --- a/primer/src/Primer/App.hs +++ b/primer/src/Primer/App.hs @@ -22,6 +22,7 @@ module Primer.App ( runEditAppM, runQueryAppM, Prog (..), + progAllModules, tcWholeProg, ProgAction (..), ProgError (..), @@ -197,6 +198,9 @@ data Prog = Prog deriving (Eq, Show, Generic) deriving (FromJSON, ToJSON) via VJSON Prog +progAllModules :: Prog -> [Module] +progAllModules p = progModule p : progImports p + -- Note [Modules] -- The invariant is that the @progImports@ modules are never edited, but -- one can insert new ones (and perhaps delete unneeded ones). @@ -235,11 +239,11 @@ importModules ms = do -- | Get all type definitions from all modules (including imports) allTypes :: Prog -> Map TyConName TypeDef -allTypes p = foldMap moduleTypes $ progModule p : progImports p +allTypes p = foldMap moduleTypes $ progAllModules p -- | Get all definitions from all modules (including imports) allDefs :: Prog -> Map GVarName Def -allDefs p = foldMap moduleDefs $ progModule p : progImports p +allDefs p = foldMap moduleDefs $ progAllModules p -- | Add a definition to the editable module addDef :: ASTDef -> Prog -> Prog @@ -528,7 +532,7 @@ applyProgAction prog mdefName = \case (TypeDefError . show @TypeError) ( runReaderT (checkTypeDefs $ mkTypeDefMap [TypeDefAST td]) - (buildTypingContextFromModules (progModule prog : progImports prog) NoSmartHoles) + (buildTypingContextFromModules (progAllModules prog) NoSmartHoles) ) RenameType old (unsafeMkGlobalName -> new) -> (,Nothing) <$> do @@ -742,7 +746,7 @@ applyProgAction prog mdefName = \case BodyAction actions -> do withDef mdefName prog $ \def -> do smartHoles <- gets $ progSmartHoles . appProg - res <- applyActionsToBody smartHoles (progModule prog : progImports prog) def actions + res <- applyActionsToBody smartHoles (progAllModules prog) def actions case res of Left err -> throwError $ ActionError err Right (def', z) -> do @@ -1141,7 +1145,7 @@ copyPasteBody p (fromDefName, fromId) toDefName setup = do smartHoles <- gets $ progSmartHoles . appProg -- The Loc zipper captures all the changes, they are only reflected in the -- returned Def, which we thus ignore - (oldDef, doneSetup) <- withDef (Just toDefName) p $ \def -> (def,) <$> applyActionsToBody smartHoles (progModule p : progImports p) def setup + (oldDef, doneSetup) <- withDef (Just toDefName) p $ \def -> (def,) <$> applyActionsToBody smartHoles (progAllModules p) def setup tgt <- case doneSetup of Left err -> throwError $ ActionError err Right (_, tgt) -> pure tgt @@ -1262,7 +1266,7 @@ transformCaseBranches prog type_ f = transformM $ \case e -> pure e progCxt :: Prog -> Cxt -progCxt p = buildTypingContextFromModules (progModule p : progImports p) (progSmartHoles p) +progCxt p = buildTypingContextFromModules (progAllModules p) (progSmartHoles p) -- | Run a computation in some context whose errors can be promoted to `ProgError`. liftError :: MonadEditApp m => (e -> ProgError) -> ExceptT e m b -> m b diff --git a/primer/test/Tests/Action/Prog.hs b/primer/test/Tests/Action/Prog.hs index b4c394d7e..36cc71b7d 100644 --- a/primer/test/Tests/Action/Prog.hs +++ b/primer/test/Tests/Action/Prog.hs @@ -40,6 +40,7 @@ import Primer.App ( newEmptyApp, newEmptyProg, newProg, + progAllModules, tcWholeProg, ) import Primer.Builtins (builtinModule, cCons, cJust, cMakePair, cNil, tBool, tList, tMaybe, tPair) @@ -1035,7 +1036,7 @@ unit_AddConField_case = -- * Utilities findGlobalByName :: Prog -> GVarName -> Maybe Def -findGlobalByName p n = Map.lookup n . foldMap moduleDefs $ progModule p : progImports p +findGlobalByName p n = Map.lookup n . foldMap moduleDefs $ progAllModules p -- We use a program with two defs: "main" and "other" defaultEmptyProg :: MonadFresh ID m => m Prog diff --git a/primer/test/Tests/Typecheck.hs b/primer/test/Tests/Typecheck.hs index 50523d894..a66a2e4bc 100644 --- a/primer/test/Tests/Typecheck.hs +++ b/primer/test/Tests/Typecheck.hs @@ -22,9 +22,10 @@ import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Optics (over, set) import Primer.App ( - Prog (progImports), + Prog, newEmptyProg, newProg, + progAllModules, progModule, ) import Primer.Builtins ( @@ -509,7 +510,7 @@ checkProgWellFormed p' = case runTypecheckTestM NoSmartHoles $ do NoSmartHoles CheckEverything { trusted = mempty - , toCheck = progModule p : progImports p + , toCheck = progAllModules p } of Left err -> assertFailure $ show err Right _ -> pure () From 764e4ee88fe77b372af6e80252318136ffeab464 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Thu, 7 Apr 2022 17:49:24 +0100 Subject: [PATCH 7/8] feat!: add module names This is a large commit, but most of it is pretty mechanical. NB: we remove the test 'unit_rename_def_capture'. It tested that we could not rename a definition in such a way that a reference would be captured by a local binding. However, now that global variables have module-qualified names, this is no longer possible: a local binding is not considered to shadow any globals. BREAKING CHANGE: this change requires a database migration, as it changes the representation of `Prog`. However, since this is just serialised to json and stored as a blob in the DB, it requires no schema changes. Since we have no programs we need to preserve, we decided not to bother with a migration. This means that DBs created before this commit will not load with a primer containing this commit. --- primer-rel8/test/TestUtils.hs | 14 +- primer-service/src/Primer/Server.hs | 9 +- primer/src/Foreword.hs | 1 + primer/src/Primer/Action.hs | 49 +- primer/src/Primer/Action/Available.hs | 5 +- primer/src/Primer/App.hs | 193 +++--- primer/src/Primer/Builtins.hs | 48 +- primer/src/Primer/Core.hs | 43 +- primer/src/Primer/Core/DSL.hs | 21 + primer/src/Primer/Core/Transform.hs | 71 +- primer/src/Primer/Module.hs | 66 +- primer/src/Primer/Name/Fresh.hs | 4 +- primer/src/Primer/Primitives.hs | 20 +- primer/src/Primer/Questions.hs | 4 +- primer/src/Primer/Typecheck.hs | 62 +- primer/test/Gen/Core/Raw.hs | 10 +- primer/test/Gen/Core/Typed.hs | 28 +- primer/test/TestUtils.hs | 25 +- primer/test/Tests/API.hs | 15 +- primer/test/Tests/Action.hs | 4 +- primer/test/Tests/Action/Available.hs | 12 +- primer/test/Tests/Action/Prog.hs | 629 +++++++++++------- primer/test/Tests/Eval.hs | 183 ++--- primer/test/Tests/EvalFull.hs | 111 ++-- primer/test/Tests/FreeVars.hs | 2 +- primer/test/Tests/Primitives.hs | 4 +- primer/test/Tests/Question.hs | 8 +- primer/test/Tests/Serialization.hs | 17 +- primer/test/Tests/Transform.hs | 33 +- primer/test/Tests/Typecheck.hs | 63 +- primer/test/Tests/Unification.hs | 32 +- primer/test/outputs/serialization/def.json | 5 +- .../serialization/edit_response_2.json | 26 +- primer/test/outputs/serialization/prog.json | 26 +- .../outputs/serialization/progaction.json | 5 +- .../test/outputs/serialization/selection.json | 5 +- .../test/outputs/serialization/typeDef.json | 15 +- 37 files changed, 1170 insertions(+), 698 deletions(-) diff --git a/primer-rel8/test/TestUtils.hs b/primer-rel8/test/TestUtils.hs index ecd921cf0..2d6cbce10 100644 --- a/primer-rel8/test/TestUtils.hs +++ b/primer-rel8/test/TestUtils.hs @@ -64,8 +64,10 @@ import Primer.Builtins ( import Primer.Core ( ASTDef (..), Def (DefAST), + GlobalName (baseName), ID, Kind (KType), + qualifyName, ) import Primer.Core.DSL ( aPP, @@ -76,7 +78,7 @@ import Primer.Core.DSL ( con, create, emptyHole, - gvar, + gvar', hole, lAM, lam, @@ -101,6 +103,7 @@ import Primer.Module ( Module ( Module, moduleDefs, + moduleName, moduleTypes ), ) @@ -243,7 +246,7 @@ testASTDef :: ASTDef testASTDefNextID :: ID (testASTDef, testASTDefNextID) = ( ASTDef - { astDefName = "1" + { astDefName = qualifyName "TestModule" "1" , astDefExpr , astDefType } @@ -278,7 +281,7 @@ testASTDefNextID :: ID (con cJust) ) ( hole - (gvar "0") + (gvar' "TestModule" "0") ) ) ( thole @@ -361,7 +364,8 @@ testApp = { progImports = [builtinModule, primitiveModule] , progModule = Module - { moduleTypes = mempty - , moduleDefs = Map.singleton (astDefName testASTDef) (DefAST testASTDef) + { moduleName = "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 f71c37b92..6b6c3c28b 100644 --- a/primer-service/src/Primer/Server.hs +++ b/primer-service/src/Primer/Server.hs @@ -81,8 +81,9 @@ import Primer.Core ( Type' (TEmptyHole), TypeCache (..), 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, @@ -329,14 +330,14 @@ testEndpoints = :<|> mkTest (TCBoth (TEmptyHole ()) (TEmptyHole ())) :<|> mkTest (create' (app emptyHole emptyHole)) :<|> mkTest (create' $ case_ emptyHole []) - :<|> mkTest (create' $ case_ emptyHole [branch "C" [("x", Nothing)] emptyHole]) + :<|> mkTest (create' $ case_ emptyHole [branch' ("M", "C") [("x", Nothing)] emptyHole]) :<|> mkTest (KFun KType KType) :<|> mkTest 0 :<|> mkTest (Log [[BodyAction [Move Child1]]]) :<|> mkTest newProg - :<|> mkTest (MoveToDef "main") + :<|> mkTest (MoveToDef $ qualifyName "M" "main") :<|> mkTest NoDefSelected - :<|> mkTest (DefAST $ ASTDef "main" expr ty) + :<|> mkTest (DefAST $ ASTDef (qualifyName "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/Foreword.hs b/primer/src/Foreword.hs index a35a7b2dd..4ecbf9751 100644 --- a/primer/src/Foreword.hs +++ b/primer/src/Foreword.hs @@ -33,6 +33,7 @@ import Protolude hiding ( gcast, ignore, lenientDecode, + moduleName, orElse, replace, retry, diff --git a/primer/src/Primer/Action.hs b/primer/src/Primer/Action.hs index b07447b01..9e4e350c4 100644 --- a/primer/src/Primer/Action.hs +++ b/primer/src/Primer/Action.hs @@ -45,6 +45,7 @@ import Primer.Core ( ID, LVarName, LocalName (LocalName, unLocalName), + ModuleName, TmVarRef (..), TyConName, TyVarName, @@ -58,6 +59,7 @@ import Primer.Core ( bindName, defName, getID, + qualifiedModule, unsafeMkGlobalName, unsafeMkLocalName, valConArgs, @@ -89,7 +91,7 @@ import Primer.Core.DSL ( import Primer.Core.Transform (renameLocalVar, renameTyVar, renameTyVarExpr) import Primer.Core.Utils (forgetTypeIDs, generateTypeIDs) import Primer.JSON -import Primer.Module (Module (moduleDefs)) +import Primer.Module (Module, insertDef) import Primer.Name (Name, NameCounter, unName) import Primer.Name.Fresh ( isFresh, @@ -175,8 +177,8 @@ data FunctionFiltering -- This type is parameterised because we may need it for other things in -- future, and because it lets us derive a useful functor instance. data UserInput a - = ChooseConstructor FunctionFiltering (Text -> a) - | ChooseTypeConstructor (Text -> a) + = ChooseConstructor FunctionFiltering (QualifiedText -> a) + | ChooseTypeConstructor (QualifiedText -> a) | -- | Renders a choice between some options (as buttons), -- plus a textbox to manually enter a name ChooseOrEnterName @@ -229,19 +231,24 @@ nameString :: Text nameString = "n" <> T.singleton '\x200C' <> "ame" -- | Given a definition name and a program, return a unique variant of --- that name. Note that if no definition of the given name already --- exists in the program, this function will return the same name --- it's been given. -uniquifyDefName :: Text -> Map ID Def -> Text -uniquifyDefName name' defs = +-- that name (within the specified module). Note that if no definition +-- of the given name already exists in the program, this function will +-- return the same name it's been given. +uniquifyDefName :: C.ModuleName -> Text -> Map ID Def -> Text +uniquifyDefName m name' defs = if name' `notElem` avoid then name' else let go i = if (name' <> "_" <> show i) `notElem` avoid then name' <> "_" <> show i else go (i + 1) in go (1 :: Int) where + f qn + | qualifiedModule qn == m = Just (unName $ baseName qn) + | otherwise = Nothing avoid :: [Text] - avoid = Map.elems $ map (unName . baseName . defName) defs + avoid = mapMaybe (f . defName) $ Map.elems defs + +type QualifiedText = (Text, Text) -- | Core actions. -- These describe edits to the core AST. @@ -283,11 +290,11 @@ data Action | -- | Construct a type abstraction "big-lambda" ConstructLAM (Maybe Text) | -- | Put a constructor in an empty hole - ConstructCon Text + ConstructCon QualifiedText | -- | Put a constructor applied to a saturated spine in an empty hole - ConstructSaturatedCon Text + ConstructSaturatedCon QualifiedText | -- | Put a constructor in an empty hole, and infer what it should be applied to - ConstructRefinedCon Text + ConstructRefinedCon QualifiedText | -- | Put a let expression in an empty hole ConstructLet (Maybe Text) | -- | Put a letrec expression in an empty hole @@ -313,7 +320,7 @@ data Action -- The type under the cursor is placed in the range (right) position. ConstructArrowR | -- | Put a type constructor in a type hole - ConstructTCon Text + ConstructTCon QualifiedText | -- | Construct a type variable in an empty type hole ConstructTVar Text | -- | Construct a forall type (only at kind KType for now) @@ -360,6 +367,9 @@ data ActionError -- a bug. It does not get thrown for "no valid refinement found" -- - see Note [No valid refinement] RefineError (Either Text TypeError) + | -- | Cannot import modules whose names clash with previously-imported things + -- (or with each other) + ImportNameClash [ModuleName] | -- | Importing some modules failed. -- This should be impossible as long as the requested modules are well-typed -- and all of their dependencies are already imported @@ -374,7 +384,7 @@ data ActionError data ProgAction = -- | Move the cursor to the definition with the given Name MoveToDef GVarName - | -- | Rename the definition with the given Name + | -- | Rename the definition with the given (base) Name RenameDef GVarName Text | -- | Create a new definition CreateDef (Maybe Text) @@ -450,8 +460,7 @@ applyActionsToTypeSig smartHoles imports mod def actions = let t = target (top zt) e <- check (forgetTypeIDs t) (astDefExpr def) let def' = def{astDefExpr = exprTtoExpr e, astDefType = t} - defs' = Map.insert (astDefName def) (DefAST def') $ moduleDefs mod - mod' = mod{moduleDefs = defs'} + mod' = insertDef mod (DefAST def') -- The actions were applied to the type successfully, and the definition body has been -- typechecked against the new type. -- Now we need to typecheck the whole program again, to check any uses of the definition @@ -819,12 +828,12 @@ constructLAM mx ze = do result <- flip replace ze <$> lAM x (pure (target ze)) moveExpr Child1 result -constructCon :: ActionM m => Text -> ExprZ -> m ExprZ +constructCon :: ActionM m => QualifiedText -> ExprZ -> m ExprZ constructCon c ze = case target ze of EmptyHole{} -> flip replace ze <$> con (unsafeMkGlobalName c) e -> throwError $ NeedEmptyHole (ConstructCon c) e -constructSatCon :: ActionM m => Text -> ExprZ -> m ExprZ +constructSatCon :: ActionM m => QualifiedText -> ExprZ -> m ExprZ constructSatCon c ze = case target ze of -- Similar comments re smartholes apply as to insertSatVar EmptyHole{} -> do @@ -846,7 +855,7 @@ getConstructorType c = Just (vc, td) -> Right $ valConType td vc Nothing -> Left $ "Could not find constructor " <> show c -constructRefinedCon :: ActionM m => Text -> ExprZ -> m ExprZ +constructRefinedCon :: ActionM m => QualifiedText -> ExprZ -> m ExprZ constructRefinedCon c ze = do let n = unsafeMkGlobalName c cTy <- @@ -1030,7 +1039,7 @@ constructArrowL zt = flip replace zt <$> tfun (pure (target zt)) tEmptyHole constructArrowR :: ActionM m => TypeZ -> m TypeZ constructArrowR zt = flip replace zt <$> tfun tEmptyHole (pure (target zt)) -constructTCon :: ActionM m => Text -> TypeZ -> m TypeZ +constructTCon :: ActionM m => QualifiedText -> TypeZ -> m TypeZ constructTCon c zt = case target zt of TEmptyHole{} -> flip replace zt <$> tcon (unsafeMkGlobalName c) _ -> throwError $ CustomFailure (ConstructTCon c) "can only construct tcon in hole" diff --git a/primer/src/Primer/Action/Available.hs b/primer/src/Primer/Action/Available.hs index 0e5e15b11..5d065ae93 100644 --- a/primer/src/Primer/Action/Available.hs +++ b/primer/src/Primer/Action/Available.hs @@ -42,7 +42,7 @@ import Primer.Core ( Expr' (..), ExprMeta, GVarName, - GlobalName (baseName), + GlobalName (baseName, qualifiedModule), ID, Kind, Meta (..), @@ -97,7 +97,8 @@ actionsForDef l defs def = bodyID = astDefExpr def ^. _exprMetaLens % _id - copyName = uniquifyDefName (unName (baseName $ astDefName def) <> "Copy") defs + qn = astDefName def + copyName = uniquifyDefName (qualifiedModule qn) (unName (baseName qn) <> "Copy") defs in NoInputRequired [ CreateDef (Just copyName) , CopyPasteSig (astDefName def, sigID) [] diff --git a/primer/src/Primer/App.hs b/primer/src/Primer/App.hs index 3f59a88e3..4d7145bce 100644 --- a/primer/src/Primer/App.hs +++ b/primer/src/Primer/App.hs @@ -59,7 +59,8 @@ import Data.Generics.Uniplate.Operations (descendM, transform, transformM) import Data.Generics.Uniplate.Zipper ( fromZipper, ) -import Data.List.Extra ((!?)) +import Data.List (intersect, (\\)) +import Data.List.Extra (anySame, disjoint, (!?)) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Optics ( @@ -98,10 +99,11 @@ import Primer.Core ( Expr' (Case, Con, EmptyHole, Hole, Var), ExprMeta, GVarName, - GlobalName (baseName), + GlobalName (baseName, qualifiedModule), ID (..), LocalName (LocalName, unLocalName), Meta (..), + ModuleName, TmVarRef (GlobalVarRef, LocalVarRef), TyConName, TyVarName, @@ -135,8 +137,15 @@ import Primer.Eval (EvalDetail, EvalError) import qualified Primer.Eval as Eval import Primer.EvalFull (Dir, EvalFullError (TimedOut), TerminationBound, evalFull) import Primer.JSON -import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) -import Primer.Name (Name, NameCounter, freshName) +import Primer.Module ( + Module (Module, moduleDefs, moduleName, moduleTypes), + deleteDef, + insertDef, + mkTypeDefMap, + moduleDefsQualified, + moduleTypesQualified, + ) +import Primer.Name (Name (unName), NameCounter, freshName, unsafeMkName) import Primer.Primitives (primitiveModule) import Primer.Questions ( Question (..), @@ -155,6 +164,7 @@ import Primer.Typecheck ( checkDef, checkEverything, checkTypeDefs, + mkTypeDefMapQualified, synth, ) import Primer.Zipper ( @@ -205,15 +215,8 @@ progAllModules p = progModule p : progImports p -- The invariant is that the @progImports@ modules are never edited, but -- one can insert new ones (and perhaps delete unneeded ones). -- --- Currently we assume that all Names and IDs are globally unique (across --- all the imported and editable modules). We intend to lift this restriction --- shortly by introducing unique module identifiers. Since the user has no --- control over IDs, this means that importing modules is unsafe: either it may --- break this invariant, or it could fail with no way for a end-user to fix it. --- (Or it would have to do a lot of work to uniquify names and ids, and then --- bear this in mind when importing further modules that may reference these.) --- Since we do not yet expose any way for an end-user to import modules, this --- restriction is not particularly severe in practice. +-- We assume that all Names and IDs are unique within one module, and that +-- module names are unique. -- -- All modules in a @Prog@ shall be well-typed, in the appropriate scope: -- all the imports are in one mutual dependency group @@ -223,13 +226,17 @@ progAllModules p = progModule p : progImports p -- (and all their dependencies are already imported) importModules :: MonadEditApp m => [Module] -> m () importModules ms = do - -- NB: we do not enforce the invariant that IDs and Names are globally unique - -- (see Note [Modules]), because we plan to only use this function internally - -- until we add unique names to modules. - -- This means that any call to this function should ensure that the IDs/Names - -- in the imported module are distinct from those already existing in the - -- App. p <- gets appProg + -- Module names must be unique + let currentModules = progAllModules p + let currentNames = moduleName <$> currentModules + let newNames = moduleName <$> ms + unless (disjoint currentNames newNames && not (anySame newNames)) $ + throwError $ + ActionError $ + ImportNameClash $ + (currentNames `intersect` newNames) <> (newNames \\ ordNub newNames) + -- Imports must be well-typed (and cannot depend on the editable module) checkedImports <- liftError (ActionError . ImportFailed ()) $ checkEverything NoSmartHoles $ @@ -239,22 +246,22 @@ importModules ms = do -- | Get all type definitions from all modules (including imports) allTypes :: Prog -> Map TyConName TypeDef -allTypes p = foldMap moduleTypes $ progAllModules p +allTypes p = foldMap moduleTypesQualified $ progAllModules p -- | Get all definitions from all modules (including imports) allDefs :: Prog -> Map GVarName Def -allDefs p = foldMap moduleDefs $ progAllModules p +allDefs p = foldMap moduleDefsQualified $ progAllModules p -- | Add a definition to the editable module +-- assumes the def has the correct name to go in the editable module addDef :: ASTDef -> Prog -> Prog addDef d p = let mod = progModule p - defs = moduleDefs mod - defs' = Map.insert (astDefName d) (DefAST d) defs - mod' = mod{moduleDefs = defs'} + mod' = insertDef mod $ DefAST d in p{progModule = mod'} -- | Add a type definition to the editable module +-- assumes the def has the correct name to go in the editable module addTypeDef :: ASTTypeDef -> Prog -> Prog addTypeDef t p = let mod = progModule p @@ -385,8 +392,8 @@ handleQuestion = \case Right zT -> (variablesInScopeTy zT, [], []) pure ((tyvars, termvars), globals) GenerateName defid nodeid typeKind -> do - progTypeDefs <- asks $ moduleTypes . progModule . appProg - progDefs <- asks $ moduleDefs . progModule . appProg + progTypeDefs <- asks $ moduleTypesQualified . progModule . appProg + progDefs <- asks $ moduleDefsQualified . progModule . appProg names <- focusNode' defid nodeid <&> \case Left zE -> generateNameExpr typeKind zE @@ -400,7 +407,7 @@ handleQuestion = \case -- This only looks in the editable module, not in any imports focusNode :: MonadError ProgError m => Prog -> GVarName -> ID -> m (Either (Either ExprZ TypeZ) TypeZip) -focusNode prog = focusNodeDefs $ moduleDefs $ progModule prog +focusNode prog = focusNodeDefs $ moduleDefsQualified $ progModule prog -- This looks in the editable module and also in any imports focusNodeImports :: MonadError ProgError m => Prog -> GVarName -> ID -> m (Either (Either ExprZ TypeZ) TypeZip) @@ -467,15 +474,14 @@ handleEvalFullRequest (EvalFullReq{evalFullReqExpr, evalFullCxtDir, evalFullMaxS -- Prog actions only affect the editable module applyProgAction :: MonadEditApp m => Prog -> Maybe GVarName -> ProgAction -> m (Prog, Maybe GVarName) applyProgAction prog mdefName = \case - MoveToDef d -> case Map.lookup d (moduleDefs $ progModule prog) of + MoveToDef d -> case Map.lookup d (moduleDefsQualified $ progModule prog) of Nothing -> throwError $ DefNotFound d Just _ -> pure (prog, Just d) - DeleteDef d - | mod <- progModule prog - , Map.member d (moduleDefs mod) -> do - let modDefs' = Map.delete d $ moduleDefs mod - mod' = mod{moduleDefs = modDefs'} - prog' = prog{progModule = mod', progSelection = Nothing} + DeleteDef d -> + case deleteDef (progModule prog) d of + Nothing -> throwError $ DefNotFound d + Just mod' -> do + let prog' = prog{progModule = mod', progSelection = Nothing} -- Run a full TC solely to ensure that no references to the removed id -- remain. This is rather inefficient and could be improved in the -- future. @@ -484,42 +490,51 @@ applyProgAction prog mdefName = \case NoSmartHoles CheckEverything{trusted = progImports prog, toCheck = [mod']} pure (prog', Nothing) - DeleteDef d -> throwError $ DefNotFound d - RenameDef d nameStr -> case lookupASTDef d (moduleDefs $ progModule prog) of + RenameDef d nameStr -> case lookupASTDef d (moduleDefsQualified $ progModule prog) of Nothing -> throwError $ DefNotFound d Just def -> do let defs = moduleDefs $ progModule prog - name = unsafeMkGlobalName nameStr - if Map.member name defs - then throwError $ DefAlreadyExists name + oldNameBase = baseName d + newNameBase = unsafeMkName nameStr + newName = qualifyName (moduleName $ progModule prog) newNameBase + if Map.member newNameBase defs + then throwError $ DefAlreadyExists newName else do - let def' = DefAST def{astDefName = name} + let def' = DefAST def{astDefName = newName} defs' <- maybe (throwError $ ActionError NameCapture) pure $ traverse ( traverseOf (#_DefAST % #astDefExpr) $ - renameVar (GlobalVarRef d) (GlobalVarRef name) + renameVar (GlobalVarRef d) (GlobalVarRef newName) ) - (Map.insert name def' $ Map.delete d defs) + (Map.insert newNameBase def' $ Map.delete oldNameBase defs) let prog' = prog & #progSelection ?~ Selection (defName def') Nothing & #progModule % #moduleDefs .~ defs' pure (prog', mdefName) CreateDef n -> do - let defs = moduleDefs $ progModule prog + let mod = progModule prog + let modName = moduleName mod + let defs = moduleDefs mod name <- case n of Just nameStr -> - let name = unsafeMkGlobalName nameStr - in if Map.member name defs + let baseName = unsafeMkName nameStr + name = qualifyName modName baseName + in if Map.member baseName defs then throwError $ DefAlreadyExists name else pure name - Nothing -> fmap qualifyName . freshName $ Set.fromList $ map (baseName . defName) $ Map.elems defs + Nothing -> fmap (qualifyName modName) $ freshName $ Map.keysSet defs expr <- newExpr ty <- newType let def = ASTDef name expr ty pure (addDef def prog{progSelection = Just $ Selection name Nothing}, Just name) AddTypeDef td -> do + -- The frontend should never let this error happen, + -- so we just dump out a raw string for debugging/logging purposes + let m = moduleName $ progModule prog + unless (m == qualifiedModule (astTypeDefName td)) $ + throwError $ TypeDefError $ "Cannot create a type definition with incorrect module name: expected " <> unName m (addTypeDef td prog, mdefName) <$ liftError -- The frontend should never let this error case happen, @@ -531,10 +546,10 @@ applyProgAction prog mdefName = \case -- see https://github.com/hackworthltd/primer/issues/3) (TypeDefError . show @TypeError) ( runReaderT - (checkTypeDefs $ mkTypeDefMap [TypeDefAST td]) + (checkTypeDefs $ mkTypeDefMapQualified [TypeDefAST td]) (buildTypingContextFromModules (progAllModules prog) NoSmartHoles) ) - RenameType old (unsafeMkGlobalName -> new) -> + RenameType old (unsafeMkName -> nameRaw) -> (,Nothing) <$> do traverseOf #progModule @@ -543,17 +558,16 @@ applyProgAction prog mdefName = \case ) prog where + new = qualifyName (qualifiedModule old) nameRaw updateType m = do d0 <- -- NB We do not allow primitive types to be renamed. -- To relax this, we'd have to be careful about how it interacts with type-checking of primitive literals. maybe (throwError $ TypeDefIsPrim old) pure . typeDefAST - =<< maybe (throwError $ TypeDefNotFound old) pure (Map.lookup old m) - -- TODO we should really check this against _all_ modules, but we will very shortly be adding namespacing - when (Map.member new m) $ throwError $ TypeDefAlreadyExists new - let nameRaw = baseName new + =<< maybe (throwError $ TypeDefNotFound old) pure (Map.lookup (baseName old) m) + when (Map.member nameRaw m) $ throwError $ TypeDefAlreadyExists new when (nameRaw `elem` map (unLocalName . fst) (astTypeDefParameters d0)) $ throwError $ TyConParamClash nameRaw - pure $ Map.insert new (TypeDefAST $ d0 & #astTypeDefName .~ new) $ Map.delete old m + pure $ Map.insert nameRaw (TypeDefAST $ d0 & #astTypeDefName .~ new) $ Map.delete (baseName old) m updateRefsInTypes = over (traversed % #_TypeDefAST % #astTypeDefConstructors % traversed % #valConArgs % traversed) @@ -567,12 +581,12 @@ applyProgAction prog mdefName = \case #astDefExpr $ transform $ over typesInExpr $ transform $ over (#_TCon % _2) updateName updateName n = if n == old then new else n - RenameCon type_ old (unsafeMkGlobalName -> new) -> + RenameCon type_ old (unsafeMkGlobalName . (unName (qualifiedModule type_),) -> new) -> (,Nothing) <$> do when (new `elem` allConNames prog) $ throwError $ ConAlreadyExists new traverseOf #progModule - ( traverseOf #moduleTypes updateType + ( updateType <=< traverseOf #moduleDefs (pure . updateDefs) ) prog @@ -590,11 +604,11 @@ applyProgAction prog mdefName = \case over (traversed % #_DefAST % #astDefExpr) $ transform $ over (#_Con % _2) updateName updateName n = if n == old then new else n - RenameTypeParam type_ old (unsafeMkLocalName -> new) -> + RenameTypeParam type_ old (unsafeMkLocalName -> new) -> do (,Nothing) <$> traverseOf #progModule - (traverseOf #moduleTypes updateType) + updateType prog where updateType = @@ -621,7 +635,7 @@ applyProgAction prog mdefName = \case ) $ over _freeVarsTy $ \(_, v) -> TVar () $ updateName v updateName n = if n == old then new else n - AddCon type_ index (unsafeMkGlobalName -> con) -> + AddCon type_ index (unsafeMkGlobalName . (unName (qualifiedModule type_),) -> con) -> (,Nothing) <$> do when (con `elem` allConNames prog) $ throwError $ ConAlreadyExists con @@ -630,9 +644,7 @@ applyProgAction prog mdefName = \case ( traverseOf (#moduleDefs % traversed % #_DefAST % #astDefExpr) updateDefs - <=< traverseOf - #moduleTypes - updateType + <=< updateType ) prog where @@ -646,12 +658,12 @@ applyProgAction prog mdefName = \case (maybe (throwError $ IndexOutOfRange index) pure . insertAt index (ValCon con [])) ) type_ - SetConFieldType type_ con index new -> + SetConFieldType type_ con index new -> do (,Nothing) <$> traverseOf #progModule ( traverseOf #moduleDefs updateDefs - <=< traverseOf #moduleTypes updateType + <=< updateType ) prog where @@ -699,12 +711,12 @@ applyProgAction prog mdefName = \case ) e else pure cb - AddConField type_ con index new -> + AddConField type_ con index new -> do (,Nothing) <$> traverseOf #progModule ( traverseOf #moduleDefs updateDefs - <=< traverseOf #moduleTypes updateType + <=< updateType ) prog where @@ -810,7 +822,7 @@ withDef mdefName prog f = case mdefName of Nothing -> throwError NoDefSelected Just defname -> do - case lookupASTDef defname (moduleDefs $ progModule prog) of + case lookupASTDef defname (moduleDefsQualified $ progModule prog) of Nothing -> throwError $ DefNotFound defname Just def -> f def @@ -925,13 +937,14 @@ newEmptyProg :: Prog newEmptyProg = let expr = EmptyHole (Meta 1 Nothing Nothing) ty = TEmptyHole (Meta 2 Nothing Nothing) - def = DefAST $ ASTDef "main" expr ty + def = DefAST $ ASTDef (qualifyName "Main" "main") expr ty in Prog { progImports = mempty , progModule = Module - { moduleTypes = mempty - , moduleDefs = Map.singleton (defName def) def + { moduleName = "Main" + , moduleTypes = mempty + , moduleDefs = Map.singleton (baseName $ defName def) def } , progSelection = Nothing , progSmartHoles = SmartHoles @@ -955,26 +968,29 @@ newProg = { progImports = [builtinModule, primitiveModule] , progModule = Module - { moduleTypes = mempty - , moduleDefs = defaultDefs + { moduleName = "Main" + , moduleTypes = mempty + , moduleDefs = defaultDefs "Main" } } +-- Since IDs should be unique in a module, we record 'defaultDefsNextID' +-- to initialise the 'appIdCounter' defaultDefsNextId :: ID -defaultDefs :: Map GVarName Def +defaultDefs :: ModuleName -> Map Name Def (defaultDefs, defaultDefsNextId) = let (defs, nextID) = create $ do mainExpr <- emptyHole mainType <- tEmptyHole - let astDefs = + let astDefs m = [ ASTDef - { astDefName = "main" + { astDefName = qualifyName m "main" , astDefExpr = mainExpr , astDefType = mainType } ] - pure $ map DefAST astDefs - in (Map.fromList $ (\d -> (defName d, d)) <$> defs, nextID) + pure $ \m -> map DefAST $ astDefs m + in (\m -> Map.fromList $ (\d -> (baseName $ defName d, d)) <$> defs m, nextID) -- | An initial app whose program includes some useful definitions. newApp :: App @@ -1230,19 +1246,24 @@ alterTypeDef :: MonadEditApp m => (ASTTypeDef -> m ASTTypeDef) -> TyConName -> - Map TyConName TypeDef -> - m (Map TyConName TypeDef) -alterTypeDef f type_ = - Map.alterF - ( maybe - (throwError $ TypeDefNotFound type_) + Module -> + m Module +alterTypeDef f type_ m = do + unless (qualifiedModule type_ == moduleName m) $ throwError $ TypeDefNotFound type_ + traverseOf + #moduleTypes + ( Map.alterF ( maybe - (throwError $ TypeDefIsPrim type_) - (map (Just . TypeDefAST) . f) - . typeDefAST + (throwError $ TypeDefNotFound type_) + ( maybe + (throwError $ TypeDefIsPrim type_) + (map (Just . TypeDefAST) . f) + . typeDefAST + ) ) + (baseName type_) ) - type_ + m -- | Apply a bottom-up transformation to all branches of case expressions on the given type. transformCaseBranches :: diff --git a/primer/src/Primer/Builtins.hs b/primer/src/Primer/Builtins.hs index 66535b618..7d142e000 100644 --- a/primer/src/Primer/Builtins.hs +++ b/primer/src/Primer/Builtins.hs @@ -39,59 +39,69 @@ import Primer.Core ( astTypeDefNameHints, astTypeDefParameters ), + GlobalName, Kind (KType), TyConName, Type' (TApp, TCon, TVar), TypeDef (TypeDefAST), ValCon (ValCon), ValConName, + qualifyName, ) -import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) +import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), mkTypeDefMap) +import Primer.Name (Name) + +builtinModuleName :: Name +builtinModuleName = "Builtins" + +builtin :: Name -> GlobalName k +builtin = qualifyName builtinModuleName builtinModule :: Module builtinModule = Module - { moduleTypes = + { moduleName = builtinModuleName + , moduleTypes = mkTypeDefMap $ map TypeDefAST [boolDef, natDef, listDef, maybeDef, pairDef, eitherDef] , moduleDefs = mempty } tBool :: TyConName -tBool = "Bool" +tBool = builtin "Bool" cTrue, cFalse :: ValConName -cTrue = "True" -cFalse = "False" +cTrue = builtin "True" +cFalse = builtin "False" tNat :: TyConName -tNat = "Nat" +tNat = builtin "Nat" cZero, cSucc :: ValConName -cZero = "Zero" -cSucc = "Succ" +cZero = builtin "Zero" +cSucc = builtin "Succ" tList :: TyConName -tList = "List" +tList = builtin "List" cNil, cCons :: ValConName -cNil = "Nil" -cCons = "Cons" +cNil = builtin "Nil" +cCons = builtin "Cons" tMaybe :: TyConName -tMaybe = "Maybe" +tMaybe = builtin "Maybe" cNothing :: ValConName -cNothing = "Nothing" +cNothing = builtin "Nothing" cJust :: ValConName -cJust = "Just" +cJust = builtin "Just" tPair :: TyConName -tPair = "Pair" +tPair = builtin "Pair" cMakePair :: ValConName -cMakePair = "MakePair" +cMakePair = builtin "MakePair" tEither :: TyConName -tEither = "Either" +tEither = builtin "Either" cLeft, cRight :: ValConName -cLeft = "Left" -cRight = "Right" +cLeft = builtin "Left" +cRight = builtin "Right" -- | A definition of the Bool type boolDef :: ASTTypeDef diff --git a/primer/src/Primer/Core.hs b/primer/src/Primer/Core.hs index b82399bd3..932e742e5 100644 --- a/primer/src/Primer/Core.hs +++ b/primer/src/Primer/Core.hs @@ -12,7 +12,6 @@ module Primer.Core ( Expr' (..), Bind' (..), TmVarRef (..), - varRefName, CaseBranch, CaseBranch' (..), Def (..), @@ -27,8 +26,9 @@ module Primer.Core ( setID, HasMetadata (_metadata), ID (ID), + ModuleName, GlobalNameKind (..), - GlobalName (baseName), + GlobalName (qualifiedModule, baseName), qualifyName, unsafeMkGlobalName, TyConName, @@ -165,25 +165,31 @@ _synthed = #_TCSynthed `afailing` (#_TCEmb % #tcSynthed) -- nodes we're inserting. type ExprMeta = Meta (Maybe TypeCache) +type ModuleName = Name + -- | Tags for 'GlobalName' data GlobalNameKind = ATyCon | AValCon | ADefName --- | Global names are currently the same as 'Name's, but will shortly contain --- a module prefix also. They are tagged with what sort of name they are. -newtype GlobalName (k :: GlobalNameKind) = GlobalName {baseName :: Name} - deriving (Eq, Ord, Generic, Data) - deriving newtype (Show, IsString) - deriving newtype (FromJSON, ToJSON, FromJSONKey, ToJSONKey) +-- | Global names are fully qualified with a module name. +-- They are tagged with what sort of name they are. +data GlobalName (k :: GlobalNameKind) = GlobalName + { qualifiedModule :: ModuleName + , baseName :: Name + } + deriving (Eq, Ord, Generic, Data, Show) + +instance FromJSON (GlobalName k) +instance ToJSON (GlobalName k) -unsafeMkGlobalName :: Text -> GlobalName k -unsafeMkGlobalName = GlobalName . unsafeMkName +-- | Construct a name from a Text. This is called unsafe because there are no +-- guarantees about whether the name refers to anything that is in scope. +unsafeMkGlobalName :: (Text, Text) -> GlobalName k +unsafeMkGlobalName (m, n) = GlobalName (unsafeMkName m) (unsafeMkName n) --- | Currently just wraps the name, but shortly will take another --- argument for a module prefix -qualifyName :: Name -> GlobalName k +qualifyName :: Name -> Name -> GlobalName k qualifyName = GlobalName type TyConName = GlobalName 'ATyCon @@ -201,7 +207,7 @@ data LocalNameKind newtype LocalName (k :: LocalNameKind) = LocalName {unLocalName :: Name} deriving (Eq, Ord, Show, Data, Generic) deriving (IsString) via Name - deriving (FromJSON, ToJSON, FromJSONKey, ToJSONKey) via Name + deriving (FromJSON, ToJSON) via Name unsafeMkLocalName :: Text -> LocalName k unsafeMkLocalName = LocalName . unsafeMkName @@ -250,11 +256,6 @@ data TmVarRef deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON TmVarRef -varRefName :: TmVarRef -> Name -varRefName = \case - GlobalVarRef (GlobalName n) -> n - LocalVarRef (LocalName n) -> n - -- Note [Synthesisable constructors] -- Whilst our calculus is heavily inspired by bidirectional type systems -- (especially McBride's principled rendition), we do not treat constructors @@ -496,8 +497,8 @@ data PrimCon -- This should be a key in `allPrimTypeDefs`. primConName :: PrimCon -> TyConName primConName = \case - PrimChar _ -> "Char" - PrimInt _ -> "Int" + PrimChar _ -> qualifyName "Primitives" "Char" + PrimInt _ -> qualifyName "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 index ab2369c00..99f7684a1 100644 --- a/primer/src/Primer/Core/DSL.hs +++ b/primer/src/Primer/Core/DSL.hs @@ -35,6 +35,10 @@ module Primer.Core.DSL ( create, setMeta, S, + tcon', + con', + gvar', + branch', ) where import Foreword @@ -54,6 +58,7 @@ import Primer.Core ( Kind, LVarName, Meta (..), + ModuleName, PrimCon (..), TmVarRef (..), TyConName, @@ -63,8 +68,10 @@ import Primer.Core ( TypeCache, ValConName, Value, + qualifyName, _metadata, ) +import Primer.Name (Name) newtype S a = S {unS :: State ID a} deriving newtype (Functor, Applicative, Monad) @@ -187,3 +194,17 @@ list_ t = `app` b ) (con cNil `aPP` tcon t) + +-- | A helper for use in testsuite. With OverloadedStrings one can use literals +-- for both arguments +tcon' :: MonadFresh ID m => ModuleName -> Name -> m Type +tcon' m n = tcon $ qualifyName m n + +con' :: MonadFresh ID m => ModuleName -> Name -> m Expr +con' m n = con $ qualifyName m n + +gvar' :: MonadFresh ID m => ModuleName -> Name -> m Expr +gvar' m n = gvar $ qualifyName m n + +branch' :: MonadFresh ID m => (ModuleName, Name) -> [(LVarName, Maybe TypeCache)] -> m Expr -> m CaseBranch +branch' (m, n) = branch $ qualifyName m n diff --git a/primer/src/Primer/Core/Transform.hs b/primer/src/Primer/Core/Transform.hs index d2a994fcb..e1ed17a3f 100644 --- a/primer/src/Primer/Core/Transform.hs +++ b/primer/src/Primer/Core/Transform.hs @@ -17,7 +17,17 @@ import Control.Monad.Fresh (MonadFresh) import Data.Data (Data) import Data.Generics.Uniplate.Data (descendM) import qualified Data.List.NonEmpty as NE -import Primer.Core (CaseBranch' (..), Expr, Expr' (..), ID, LVarName, LocalName (unLocalName), TmVarRef (..), TyVarName, Type' (..), bindName, varRefName) +import Primer.Core ( + CaseBranch' (..), + Expr, + Expr' (..), + ID, + LVarName, + TmVarRef (..), + TyVarName, + Type' (..), + bindName, + ) import Primer.Core.DSL (meta) -- AST transformations. @@ -28,44 +38,27 @@ import Primer.Core.DSL (meta) -- Returns 'Nothing' if replacement could result in variable capture. -- See the tests for explanation and examples. renameVar :: (Data a, Data b) => TmVarRef -> TmVarRef -> Expr' a b -> Maybe (Expr' a b) -renameVar x y = - let xn = varRefName x - yn = varRefName y - in \case - Lam m v e - | LocalVarRef v == x -> pure $ Lam m v e - | LocalVarRef v == y -> Nothing - -- If we have the same Name, but different local/global scopes - -- also bail out as something has gone wrong. - | unLocalName v == xn || unLocalName v == yn -> Nothing - | otherwise -> Lam m v <$> renameVar x y e - Let m v e1 e2 - | LocalVarRef v == x -> pure $ Let m v e1 e2 - | LocalVarRef v == y -> Nothing - -- If we have the same Name, but different local/global scopes - -- also bail out as something has gone wrong. - | unLocalName v == xn || unLocalName v == yn -> Nothing - | otherwise -> Let m v <$> renameVar x y e1 <*> renameVar x y e2 - Case m scrut branches -> Case m <$> renameVar x y scrut <*> mapM renameBranch branches - where - renameBranch b@(CaseBranch con termargs rhs) - | LocalVarRef lx <- x, lx `elem` bindingNames b = pure b - | LocalVarRef ly <- y, ly `elem` bindingNames b = Nothing - -- If we have the same Name, but different local/global scopes - -- also bail out as something has gone wrong. - | bns <- map unLocalName $ bindingNames b - , xn `elem` bns || yn `elem` bns = - Nothing - | otherwise = CaseBranch con termargs <$> renameVar x y rhs - bindingNames (CaseBranch _ bs _) = map bindName bs - Var m v - | v == x -> pure $ Var m y - | v == y -> Nothing - -- If we have the same Name, but different local/global scopes - -- also bail out as something has gone wrong. - | varRefName v == xn || varRefName v == yn -> Nothing - | otherwise -> pure $ Var m v - e -> descendM (renameVar x y) e +renameVar x y = \case + Lam m v e + | LocalVarRef v == x -> pure $ Lam m v e + | LocalVarRef v == y -> Nothing + | otherwise -> Lam m v <$> renameVar x y e + Let m v e1 e2 + | LocalVarRef v == x -> pure $ Let m v e1 e2 + | LocalVarRef v == y -> Nothing + | otherwise -> Let m v <$> renameVar x y e1 <*> renameVar x y e2 + Case m scrut branches -> Case m <$> renameVar x y scrut <*> mapM renameBranch branches + where + renameBranch b@(CaseBranch con termargs rhs) + | LocalVarRef lx <- x, lx `elem` bindingNames b = pure b + | LocalVarRef ly <- y, ly `elem` bindingNames b = Nothing + | otherwise = CaseBranch con termargs <$> renameVar x y rhs + bindingNames (CaseBranch _ bs _) = map bindName bs + Var m v + | v == x -> pure $ Var m y + | v == y -> Nothing + | otherwise -> pure $ Var m v + e -> descendM (renameVar x y) e -- | As 'renameVar', but specialised to local variables renameLocalVar :: (Data a, Data b) => LVarName -> LVarName -> Expr' a b -> Maybe (Expr' a b) diff --git a/primer/src/Primer/Module.hs b/primer/src/Primer/Module.hs index 173c4819d..027458309 100644 --- a/primer/src/Primer/Module.hs +++ b/primer/src/Primer/Module.hs @@ -1,18 +1,68 @@ -module Primer.Module (Module (..), mkTypeDefMap) where +module Primer.Module ( + Module (..), + mkTypeDefMap, + qualifyTyConName, + moduleTypesQualified, + qualifyDefName, + moduleDefsQualified, + insertDef, + deleteDef, +) where +import Data.Map (delete, insert, mapKeys, member) import qualified Data.Map as M import Foreword -import Primer.Core (Def, GlobalName, GlobalNameKind (ADefName, ATyCon), TypeDef, typeDefName) +import Primer.Core ( + Def, + GVarName, + GlobalName (baseName), + ModuleName, + TyConName, + TypeDef, + defName, + qualifyName, + typeDefName, + ) import Primer.JSON +import Primer.Name (Name) data Module = Module - { moduleTypes :: Map (GlobalName 'ATyCon) TypeDef - , moduleDefs :: Map (GlobalName 'ADefName) Def -- The current program: a set of definitions indexed by Name + { moduleName :: ModuleName + , -- Invariant: the names are consistent: keys cache the names in the Defs. + -- In particular, if (n,d) is in the moduleDefs map, + -- then "qualifyDefName m n == defName d" + moduleTypes :: Map Name TypeDef + , moduleDefs :: Map Name Def -- The current program: a set of definitions indexed by Name } deriving (Eq, Show, Generic) deriving (FromJSON, ToJSON) via VJSON Module --- | Create a mapping of name to typedef for fast lookup. --- Ensures that @typeDefName (mkTypeDefMap ! n) == n@ -mkTypeDefMap :: [TypeDef] -> Map (GlobalName 'ATyCon) TypeDef -mkTypeDefMap defs = M.fromList $ map (\d -> (typeDefName d, d)) defs +-- | Create a mapping of name to typedef for use in modules. +-- Ensures that @baseName $ typeDefName (mkTypeDefMap ! n) == n@ +-- Assumes that all the typedefs have the same @qualifiedModule@ part to their name. +mkTypeDefMap :: [TypeDef] -> Map Name TypeDef +mkTypeDefMap defs = M.fromList $ map (\d -> (baseName $ typeDefName d, d)) defs + +qualifyTyConName :: Module -> Name -> TyConName +qualifyTyConName m = qualifyName (moduleName m) + +moduleTypesQualified :: Module -> Map TyConName TypeDef +moduleTypesQualified m = mapKeys (qualifyTyConName m) $ moduleTypes m + +qualifyDefName :: Module -> Name -> GVarName +qualifyDefName m = qualifyName (moduleName m) + +moduleDefsQualified :: Module -> Map GVarName Def +moduleDefsQualified m = mapKeys (qualifyDefName m) $ moduleDefs m + +-- | This assumes that the definition has the correct name to be inserted +-- into the module. I.e. @qualifiedModule (defName d) == moduleName m@. +insertDef :: Module -> Def -> Module +insertDef m d = m{moduleDefs = insert (baseName $ defName d) d $ moduleDefs m} + +-- | Returns 'Nothing' if (and only if) the definition was not found in the module +deleteDef :: Module -> GVarName -> Maybe Module +deleteDef m d = + if d `member` moduleDefsQualified m + then Just $ m{moduleDefs = delete (baseName d) (moduleDefs m)} + else Nothing diff --git a/primer/src/Primer/Name/Fresh.hs b/primer/src/Primer/Name/Fresh.hs index 1297fbfb0..f6ad7d23c 100644 --- a/primer/src/Primer/Name/Fresh.hs +++ b/primer/src/Primer/Name/Fresh.hs @@ -63,7 +63,7 @@ mkAvoidForFreshNameTy :: MonadReader TC.Cxt m => TypeZ -> m (S.Set Name) mkAvoidForFreshNameTy t = do let moreGlobal = bindersAboveTypeZ t moreLocal = S.map unLocalName $ bindersBelowTy $ focusOnlyType t - globals <- TC.getGlobalNames + globals <- TC.getGlobalBaseNames pure $ S.unions [moreGlobal, moreLocal, globals] mkFreshNameTy :: (MonadFresh NameCounter m, MonadReader TC.Cxt m) => TypeZ -> m Name @@ -73,5 +73,5 @@ mkAvoidForFreshName :: MonadReader TC.Cxt m => ExprZ -> m (S.Set Name) mkAvoidForFreshName e = do let moreGlobal = bindersAbove e moreLocal = bindersBelow e - globals <- TC.getGlobalNames + globals <- TC.getGlobalBaseNames pure $ S.unions [moreGlobal, moreLocal, globals] diff --git a/primer/src/Primer/Primitives.hs b/primer/src/Primer/Primitives.hs index 97e02606c..f652ae9dc 100644 --- a/primer/src/Primer/Primitives.hs +++ b/primer/src/Primer/Primitives.hs @@ -28,6 +28,7 @@ import Primer.Core ( Expr' (App, Con, PrimCon), ExprAnyFresh (..), GVarName, + GlobalName (baseName), PrimCon (..), PrimDef (PrimDef, primDefName, primDefType), PrimFun (..), @@ -51,21 +52,28 @@ import Primer.Core.DSL ( tapp, tcon, ) -import Primer.Module (Module (Module, moduleDefs, moduleTypes)) +import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes)) import Primer.Name (Name) +primitiveModuleName :: Name +primitiveModuleName = "Primitives" + +primitive :: Name -> GlobalName k +primitive = qualifyName primitiveModuleName + -- | This module depends on the builtin module, due to some terms referencing builtin types. -- It contains all primitive types and terms. primitiveModule :: Module primitiveModule = Module - { moduleTypes = TypeDefPrim <$> allPrimTypeDefs + { moduleName = primitiveModuleName + , moduleTypes = TypeDefPrim <$> M.mapKeys baseName allPrimTypeDefs , moduleDefs = fst . create $ getAp $ flip M.foldMapWithKey allPrimDefs $ \n def -> Ap $ do ty <- primFunType def pure $ - M.singleton n $ + M.singleton (baseName n) $ DefPrim PrimDef { primDefName = n @@ -74,14 +82,14 @@ primitiveModule = } tChar :: TyConName -tChar = "Char" +tChar = primitive "Char" tInt :: TyConName -tInt = "Int" +tInt = primitive "Int" -- | Construct a reference to a primitive definition. For use in tests. primitiveGVar :: Name -> GVarName -primitiveGVar = qualifyName +primitiveGVar = primitive -- | Primitive type definitions. -- There should be one entry here for each constructor of `PrimCon`. diff --git a/primer/src/Primer/Questions.hs b/primer/src/Primer/Questions.hs index 2435edc44..a6a04e8d1 100644 --- a/primer/src/Primer/Questions.hs +++ b/primer/src/Primer/Questions.hs @@ -31,7 +31,7 @@ import Primer.Core ( ) import Primer.Name (Name, unName, unsafeMkName) import Primer.Name.Fresh (mkAvoidForFreshName, mkAvoidForFreshNameTy) -import Primer.Typecheck (Cxt, decomposeTAppCon, getGlobalNames, typeDefs) +import Primer.Typecheck (Cxt, decomposeTAppCon, getGlobalBaseNames, typeDefs) import Primer.Zipper ( ExprZ, TypeZ, @@ -131,7 +131,7 @@ getAvoidSet = \case getAvoidSetTy :: MonadReader Cxt m => TypeZip -> m (Set.Set Name) getAvoidSetTy z = do - globals <- getGlobalNames + globals <- getGlobalBaseNames pure $ Set.map unLocalName (bindersAboveTy z <> bindersBelowTy z) <> globals -- We do not use Name.freshName as we don't want a global fresh counter diff --git a/primer/src/Primer/Typecheck.hs b/primer/src/Primer/Typecheck.hs index ed31043d0..3e6a0de16 100644 --- a/primer/src/Primer/Typecheck.hs +++ b/primer/src/Primer/Typecheck.hs @@ -45,10 +45,12 @@ module Primer.Typecheck ( checkDef, substituteTypeVars, getGlobalNames, + getGlobalBaseNames, lookupGlobal, lookupLocalTy, lookupVar, primConInScope, + mkTypeDefMapQualified, consistentKinds, consistentTypes, extendLocalCxtTy, @@ -56,12 +58,14 @@ module Primer.Typecheck ( extendLocalCxt, extendLocalCxts, extendGlobalCxt, + extendTypeDefCxt, localTmVars, localTyVars, ) where import Foreword +import Control.Arrow ((&&&)) import Control.Monad.Fresh (MonadFresh (..)) import Control.Monad.NestedError (MonadNestedError (..)) import Data.Functor.Compose (Compose (Compose), getCompose) @@ -81,12 +85,13 @@ import Primer.Core ( Expr' (..), ExprMeta, GVarName, - GlobalName (baseName), + GlobalName (baseName, qualifiedModule), ID, Kind (..), LVarName, LocalName (LocalName), Meta (..), + ModuleName, PrimCon, PrimDef (primDefType), TmVarRef (..), @@ -116,8 +121,18 @@ import Primer.Core ( import Primer.Core.DSL (branch, emptyHole, meta, meta') import Primer.Core.Utils (alphaEqTy, forgetTypeIDs, freshLocalName, generateTypeIDs) import Primer.JSON (CustomJSON (CustomJSON), FromJSON, ToJSON, VJSON) -import Primer.Module (Module (moduleDefs, moduleTypes)) -import Primer.Name (Name, NameCounter, freshName) +import Primer.Module ( + Module ( + moduleDefs, + moduleName, + moduleTypes + ), + moduleDefsQualified, + moduleTypesQualified, + qualifyDefName, + qualifyTyConName, + ) +import Primer.Name (Name (unName), NameCounter, freshName) import Primer.Subst (substTy) -- | Typechecking takes as input an Expr with 'Maybe Type' annotations and @@ -256,8 +271,13 @@ buildTypingContext tydefs defs sh = buildTypingContextFromModules :: [Module] -> SmartHoles -> Cxt buildTypingContextFromModules modules = buildTypingContext - (foldMap moduleTypes modules) - (foldMap moduleDefs modules) + (foldMap moduleTypesQualified modules) + (foldMap moduleDefsQualified modules) + +-- | Create a mapping of name to typedef for fast lookup. +-- Ensures that @typeDefName (mkTypeDefMap ! n) == n@ +mkTypeDefMapQualified :: [TypeDef] -> Map TyConName TypeDef +mkTypeDefMapQualified defs = M.fromList $ map (\d -> (typeDefName d, d)) defs -- | Create a mapping of name to typedef for fast lookup. -- Ensures that @typeDefName (mkTypeDefMap ! n) == n@ @@ -372,6 +392,12 @@ checkTypeDefs tds = do checkTypeDef td = do let params = astTypeDefParameters td let cons = astTypeDefConstructors td + assert + ( (1 ==) . S.size $ + S.fromList $ + qualifiedModule (astTypeDefName td) : fmap (qualifiedModule . valConName) cons + ) + "Module name of type and all constructors must be the same" assert (distinct $ map (unLocalName . fst) params <> map (baseName . valConName) cons) "Duplicate names in one tydef: between parameter-names and constructor-names" @@ -411,11 +437,16 @@ checkEverything :: checkEverything sh CheckEverything{trusted, toCheck} = let cxt = buildTypingContextFromModules trusted sh in flip runReaderT cxt $ do + -- Check the type definitions have the right modules + for_ toCheck $ \m -> flip Map.traverseWithKey (moduleTypes m) $ \n td -> + unless (qualifyTyConName m n == typeDefName td) $ + throwError' $ InternalError $ "Inconsistant names in moduleTypes for module " <> unName (moduleName m) -- Check that the definition map has the right keys for_ toCheck $ \m -> flip Map.traverseWithKey (moduleDefs m) $ \n d -> - unless (n == defName d) $ throwError' $ InternalError "Inconsistant names in moduleDefs map" - checkTypeDefs $ foldMap moduleTypes toCheck - let newTypes = foldMap moduleTypes toCheck + unless (qualifyDefName m n == defName d) $ + throwError' $ InternalError $ "Inconsistant names in moduleDefs map for module " <> unName (moduleName m) + checkTypeDefs $ foldMap moduleTypesQualified toCheck + let newTypes = foldMap moduleTypesQualified toCheck newDefs = foldMap (\d -> [(defName d, forgetTypeIDs $ defType d)]) $ foldMap moduleDefs toCheck @@ -863,7 +894,7 @@ checkBranch t (vc, args) (CaseBranch nb patterns rhs) = -- if the branch is nonsense, replace it with a sensible pattern and an empty hole (False, SmartHoles) -> do -- Avoid automatically generated names shadowing anything - globals <- getGlobalNames + globals <- getGlobalBaseNames locals <- asks $ M.keysSet . localCxt liftA2 (,) (mapM (createBinding (locals <> globals)) args) emptyHole -- otherwise, convert all @Maybe TypeCache@ metadata to @TypeCache@ @@ -977,16 +1008,21 @@ typeTtoType :: TypeT -> Type' TypeMeta typeTtoType = over _typeMeta (fmap Just) -- Helper to create fresh names -getGlobalNames :: MonadReader Cxt m => m (S.Set Name) +getGlobalNames :: MonadReader Cxt m => m (S.Set (ModuleName, Name)) getGlobalNames = do tyDefs <- asks typeDefs - topLevel <- asks $ S.fromList . map baseName . M.keys . globalCxt + topLevel <- asks $ S.fromList . map f . M.keys . globalCxt let ctors = Map.foldMapWithKey ( \t def -> S.fromList $ - (baseName t :) $ - map (baseName . valConName) $ maybe [] astTypeDefConstructors $ typeDefAST def + (f t :) $ + map (f . valConName) $ maybe [] astTypeDefConstructors $ typeDefAST def ) tyDefs pure $ S.union topLevel ctors + where + f = qualifiedModule &&& baseName + +getGlobalBaseNames :: MonadReader Cxt m => m (S.Set Name) +getGlobalBaseNames = S.map snd <$> getGlobalNames diff --git a/primer/test/Gen/Core/Raw.hs b/primer/test/Gen/Core/Raw.hs index 302ccf410..bb7c815cd 100644 --- a/primer/test/Gen/Core/Raw.hs +++ b/primer/test/Gen/Core/Raw.hs @@ -9,6 +9,7 @@ module Gen.Core.Raw ( evalExprGen, genID, genName, + genModuleName, genLVarName, genTyVarName, genTyConName, @@ -84,8 +85,11 @@ genApp = App <$> genMeta <*> genExpr <*> genExpr genAPP :: ExprGen Expr genAPP = APP <$> genMeta <*> genExpr <*> genType +genModuleName :: MonadGen m => m Name +genModuleName = Gen.frequency [(9, pure "M"), (1, genName)] + genValConName :: ExprGen ValConName -genValConName = qualifyName <$> genName +genValConName = qualifyName <$> genModuleName <*> genName genCon :: ExprGen Expr genCon = Con <$> genMeta <*> genValConName @@ -100,7 +104,7 @@ genLocalVar :: ExprGen Expr genLocalVar = Var <$> genMeta <*> (LocalVarRef <$> genLVarName) genGlobalVar :: ExprGen Expr -genGlobalVar = Var <$> genMeta <*> (GlobalVarRef . qualifyName <$> genName) +genGlobalVar = Var <$> genMeta <*> ((\m n -> GlobalVarRef $ qualifyName m n) <$> genModuleName <*> genName) genLet :: ExprGen Expr genLet = Let <$> genMeta <*> genLVarName <*> genExpr <*> genExpr @@ -148,7 +152,7 @@ genType = ] genTyConName :: ExprGen TyConName -genTyConName = qualifyName <$> genName +genTyConName = qualifyName <$> genModuleName <*> genName genKind :: ExprGen Kind genKind = Gen.recursive Gen.choice [pure KType, pure KHole] [KFun <$> genKind <*> genKind] diff --git a/primer/test/Gen/Core/Typed.hs b/primer/test/Gen/Core/Typed.hs index 890e50342..66bc8967e 100644 --- a/primer/test/Gen/Core/Typed.hs +++ b/primer/test/Gen/Core/Typed.hs @@ -33,7 +33,7 @@ import Control.Monad.Fresh (MonadFresh, fresh) import Control.Monad.Morph (hoist) import Control.Monad.Reader (mapReaderT) import qualified Data.Map as M -import Gen.Core.Raw (genLVarName, genName, genTyVarName) +import Gen.Core.Raw (genLVarName, genModuleName, genName, genTyVarName) import Hedgehog ( GenT, MonadGen, @@ -50,6 +50,7 @@ import Primer.Core ( CaseBranch' (CaseBranch), Expr' (..), GVarName, + GlobalName (qualifiedModule), ID, Kind (..), LVarName, @@ -70,7 +71,7 @@ import Primer.Core ( valConType, ) import Primer.Core.Utils (freeVarsTy) -import Primer.Module (Module, mkTypeDefMap) +import Primer.Module (Module) import Primer.Name (Name, NameCounter, freshName, unName, unsafeMkName) import Primer.Refine (Inst (InstAPP, InstApp, InstUnconstrainedAPP), refine) import Primer.Subst (substTy, substTys) @@ -84,7 +85,7 @@ import Primer.Typecheck ( extendLocalCxtTy, extendLocalCxtTys, extendLocalCxts, - getGlobalNames, + getGlobalBaseNames, globalCxt, instantiateValCons, localCxt, @@ -92,6 +93,7 @@ import Primer.Typecheck ( localTyVars, matchArrowType, matchForallType, + mkTypeDefMapQualified, primConInScope, typeDefs, ) @@ -143,7 +145,7 @@ instance MonadFresh ID (PropertyT WT) where freshNameForCxt :: GenT WT Name freshNameForCxt = do - globs <- getGlobalNames + globs <- getGlobalBaseNames locals <- asks $ M.keysSet . localCxt freshName $ globs <> locals @@ -153,6 +155,9 @@ freshLVarNameForCxt = LocalName <$> freshNameForCxt freshTyVarNameForCxt :: GenT WT TyVarName freshTyVarNameForCxt = LocalName <$> freshNameForCxt +freshTyConNameForCxt :: GenT WT TyConName +freshTyConNameForCxt = qualifyName <$> genModuleName <*> freshNameForCxt + -- We try to have a decent distribution of names, where there is a -- significant chance that the same name is reused (both in disjoint -- contexts, and with shadowing). However, we need to ensure that our @@ -422,7 +427,7 @@ genGlobalCxtExtension :: GenT WT [(GVarName, TypeG)] genGlobalCxtExtension = local forgetLocals $ Gen.list (Range.linear 1 5) $ - (,) <$> fmap qualifyName genName <*> genWTType KType + (,) <$> (qualifyName <$> genModuleName <*> genName) <*> genWTType KType where -- we are careful to not let the globals depend on whatever locals may be in -- the cxt @@ -432,14 +437,14 @@ genGlobalCxtExtension = genTypeDefGroup :: GenT WT [TypeDef] genTypeDefGroup = do let genParams = Gen.list (Range.linear 0 5) $ (,) <$> freshTyVarNameForCxt <*> genWTKind - nps <- Gen.list (Range.linear 1 5) $ (,) <$> freshNameForCxt <*> genParams + nps <- Gen.list (Range.linear 1 5) $ (,) <$> freshTyConNameForCxt <*> genParams -- create empty typedefs to temporarilly extend the context, so can do recursive types let types = map ( \(n, ps) -> TypeDefAST ASTTypeDef - { astTypeDefName = qualifyName n + { astTypeDefName = n , astTypeDefParameters = ps , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -447,22 +452,23 @@ genTypeDefGroup = do ) nps let genConArgs params = Gen.list (Range.linear 0 5) $ local (extendLocalCxtTys params . addTypeDefs types) $ genWTType KType -- params+types scope... - let genCons params = Gen.list (Range.linear 0 5) $ ValCon <$> fmap qualifyName freshNameForCxt <*> genConArgs params + let freshValConNameForCxt tyConName = qualifyName (qualifiedModule tyConName) <$> freshNameForCxt + let genCons ty params = Gen.list (Range.linear 0 5) $ ValCon <$> freshValConNameForCxt ty <*> genConArgs params let genTD (n, ps) = ( \cons -> TypeDefAST ASTTypeDef - { astTypeDefName = qualifyName n + { astTypeDefName = n , astTypeDefParameters = ps , astTypeDefConstructors = cons , astTypeDefNameHints = [] } ) - <$> genCons ps + <$> genCons n ps mapM genTD nps addTypeDefs :: [TypeDef] -> Cxt -> Cxt -addTypeDefs tds cxt = cxt{typeDefs = typeDefs cxt <> mkTypeDefMap tds} +addTypeDefs tds cxt = cxt{typeDefs = typeDefs cxt <> mkTypeDefMapQualified tds} extendGlobals :: [(GVarName, TypeG)] -> Cxt -> Cxt extendGlobals nts cxt = cxt{globalCxt = globalCxt cxt <> M.fromList nts} diff --git a/primer/test/TestUtils.hs b/primer/test/TestUtils.hs index 300fa79f8..8fa26342c 100644 --- a/primer/test/TestUtils.hs +++ b/primer/test/TestUtils.hs @@ -4,6 +4,9 @@ module TestUtils ( constructTCon, constructCon, constructRefinedCon, + tcn, + vcn, + gvn, ) where import Foreword @@ -13,12 +16,14 @@ import qualified Data.Map as Map import Primer.Action (Action (ConstructCon, ConstructRefinedCon, ConstructTCon)) import Primer.Core ( GVarName, + GlobalName (baseName, qualifiedModule), ID, + ModuleName, PrimDef (..), TyConName, ValConName, - baseName, primFunType, + qualifyName, ) import Primer.Name (Name (unName)) import Primer.Primitives (allPrimDefs) @@ -34,10 +39,22 @@ withPrimDefs f = do -- impedence mismatch: ConstructTCon takes text, but tChar etc are TyConNames constructTCon :: TyConName -> Action -constructTCon = ConstructTCon . unName . baseName +constructTCon = ConstructTCon . toQualText constructCon :: ValConName -> Action -constructCon = ConstructCon . unName . baseName +constructCon = ConstructCon . toQualText constructRefinedCon :: ValConName -> Action -constructRefinedCon = ConstructRefinedCon . unName . baseName +constructRefinedCon = ConstructRefinedCon . toQualText + +toQualText :: GlobalName k -> (Text, Text) +toQualText n = (unName $ qualifiedModule n, unName $ baseName n) + +vcn :: ModuleName -> Name -> ValConName +vcn = qualifyName + +tcn :: ModuleName -> Name -> TyConName +tcn = qualifyName + +gvn :: ModuleName -> Name -> GVarName +gvn = qualifyName diff --git a/primer/test/Tests/API.hs b/primer/test/Tests/API.hs index e522a0e57..68fe2641f 100644 --- a/primer/test/Tests/API.hs +++ b/primer/test/Tests/API.hs @@ -28,7 +28,7 @@ hprop_viewTreeType_injective = property $ do unit_viewTreeExpr_injective_con :: Assertion unit_viewTreeExpr_injective_con = - distinctTreeExpr (con "C") (con "D") + distinctTreeExpr (con' "M" "C") (con' "M" "D") unit_viewTreeExpr_injective_lam :: Assertion unit_viewTreeExpr_injective_lam = @@ -44,15 +44,16 @@ unit_viewTreeExpr_injective_var = unit_viewTreeExpr_injective_globalvar :: Assertion unit_viewTreeExpr_injective_globalvar = - distinctTreeExpr (gvar "0") (gvar "1") + distinctTreeExpr (gvar' "M" "0") (gvar' "M" "1") -- When we changed how references were handled so 'Expr' had one constructor -- that handled both local and global variable references, there was a -- regression where they both rendered identically. --- This is a regression test for said issue. +-- This is a regression test for said issue (which occurred before +-- global variables had a qualified name). unit_viewTreeExpr_injective_locglobvar :: Assertion unit_viewTreeExpr_injective_locglobvar = - distinctTreeExpr (lvar "x") (gvar "x") + distinctTreeExpr (lvar "x") (gvar' "M" "x") unit_viewTreeExpr_injective_let :: Assertion unit_viewTreeExpr_injective_let = @@ -68,15 +69,15 @@ unit_viewTreeExpr_injective_letrec = unit_viewTreeExpr_injective_case_conName :: Assertion unit_viewTreeExpr_injective_case_conName = - distinctTreeExpr (case_ emptyHole [branch "C" [("x", Nothing)] emptyHole]) (case_ emptyHole [branch "D" [("x", Nothing)] emptyHole]) + distinctTreeExpr (case_ emptyHole [branch' ("M", "C") [("x", Nothing)] emptyHole]) (case_ emptyHole [branch' ("M", "D") [("x", Nothing)] emptyHole]) unit_viewTreeExpr_injective_case_paramName :: Assertion unit_viewTreeExpr_injective_case_paramName = - distinctTreeExpr (case_ emptyHole [branch "C" [("x", Nothing)] emptyHole]) (case_ emptyHole [branch "C" [("y", Nothing)] emptyHole]) + distinctTreeExpr (case_ emptyHole [branch' ("M", "C") [("x", Nothing)] emptyHole]) (case_ emptyHole [branch' ("M", "C") [("y", Nothing)] emptyHole]) unit_viewTreeType_injective_con :: Assertion unit_viewTreeType_injective_con = - distinctTreeType (tcon "T") (tcon "S") + distinctTreeType (tcon' "M" "T") (tcon' "M" "S") unit_viewTreeType_injective_var :: Assertion unit_viewTreeType_injective_var = diff --git a/primer/test/Tests/Action.hs b/primer/test/Tests/Action.hs index c18cb7ee6..45359e3c5 100644 --- a/primer/test/Tests/Action.hs +++ b/primer/test/Tests/Action.hs @@ -362,7 +362,7 @@ unit_bad_constructor = (const True) NoSmartHoles emptyHole - [ConstructCon "NotARealConstructor"] + [ConstructCon ("M", "NotARealConstructor")] unit_bad_type_constructor :: Assertion unit_bad_type_constructor = @@ -370,7 +370,7 @@ unit_bad_type_constructor = (const True) NoSmartHoles (ann emptyHole tEmptyHole) - [EnterType, ConstructTCon "NotARealTypeConstructor"] + [EnterType, ConstructTCon ("M", "NotARealTypeConstructor")] unit_bad_app :: Assertion unit_bad_app = diff --git a/primer/test/Tests/Action/Available.hs b/primer/test/Tests/Action/Available.hs index 0f6fe5860..b10cbde6d 100644 --- a/primer/test/Tests/Action/Available.hs +++ b/primer/test/Tests/Action/Available.hs @@ -14,7 +14,7 @@ import Primer.Action.Available (actionsForDef, actionsForDefBody, actionsForDefS import Primer.Builtins import Primer.Core ( ASTDef (..), - GlobalName (baseName), + GlobalName (baseName, qualifiedModule), HasID (_id), ID, Kind (KType), @@ -31,7 +31,7 @@ import Primer.Core.DSL ( con, create, emptyHole, - gvar, + gvar', hole, lAM, lam, @@ -52,6 +52,7 @@ import System.FilePath (()) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (goldenVsString) import Test.Tasty.HUnit () +import TestUtils (gvn) import Text.Pretty.Simple (pShowNoColor) -- | This definition contains every construct in the Primer language. @@ -59,7 +60,7 @@ test_1 :: TestTree test_1 = mkTests ASTDef - { astDefName = "1" + { astDefName = gvn "M" "1" , astDefExpr , astDefType } @@ -92,7 +93,7 @@ test_1 = (con cJust) ) ( hole - (gvar "0") + (gvar' "M" "0") ) ) ( thole @@ -167,7 +168,8 @@ data Output = Output -- | Golden tests for the available actions at each node of the definition, for each level. mkTests :: ASTDef -> TestTree mkTests def = - let testName = T.unpack $ unName $ baseName $ astDefName def + let defName = astDefName def + testName = T.unpack $ unName (qualifiedModule defName) <> "." <> unName (baseName defName) in testGroup testName $ enumerate <&> \level -> diff --git a/primer/test/Tests/Action/Prog.hs b/primer/test/Tests/Action/Prog.hs index 36cc71b7d..fa3a22542 100644 --- a/primer/test/Tests/Action/Prog.hs +++ b/primer/test/Tests/Action/Prog.hs @@ -6,20 +6,22 @@ module Tests.Action.Prog where import Foreword import Control.Monad.Fresh +import Data.Generics.Uniplate.Data (transformBi) +import Data.List.Extra (anySame) import qualified Data.Map.Strict as Map import Optics import Primer.Action ( Action ( ConstructAnn, ConstructArrowL, - ConstructLam, ConstructLet, + ConstructTCon, ConstructVar, Delete, EnterType, Move ), - ActionError (NameCapture), + ActionError (ImportNameClash), Movement (Branch, Child1, Child2), ) import Primer.App ( @@ -48,20 +50,29 @@ import Primer.Core ( ASTDef (..), ASTTypeDef (..), Def (..), + Expr, Expr' (..), GVarName, + GlobalName (baseName, qualifiedModule), ID (ID), Kind (KType), Meta (..), + ModuleName, + PrimDef (primDefName, primDefType), + PrimTypeDef (primTypeDefName), TmVarRef (..), TyConName, + Type, Type' (..), TypeDef (..), ValCon (..), + ValConName, defAST, defName, getID, + qualifyName, typeDefAST, + typeDefName, _exprMeta, _exprTypeMeta, _id, @@ -90,12 +101,14 @@ import Primer.Core.DSL ( tvar, ) import Primer.Core.Utils (forgetIDs) -import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) +import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), mkTypeDefMap, moduleDefsQualified, moduleTypesQualified) import Primer.Name -import Primer.Primitives (primitiveModule, tChar, tInt) +import Primer.Primitives (primitiveGVar, primitiveModule, tChar) +import Primer.Typecheck (TypeError (UnknownTypeConstructor)) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import TestM (TestM, evalTestM) import TestUtils (constructTCon) +import qualified TestUtils import Tests.Typecheck (checkProgWellFormed) unit_empty_actions_only_change_the_log :: Assertion @@ -106,17 +119,17 @@ unit_empty_actions_only_change_the_log = progActionTest defaultEmptyProg [] $ -- We can move to the default def in a program -- (this may only exist at the start of a session) unit_move_to_def_main :: Assertion -unit_move_to_def_main = progActionTest defaultEmptyProg [MoveToDef "main"] $ +unit_move_to_def_main = progActionTest defaultEmptyProg [moveToDef "main"] $ expectSuccess $ \prog prog' -> - prog' @?= prog{progLog = Log [[MoveToDef "main"]]} + prog' @?= prog{progLog = Log [[moveToDef "main"]]} -- Expression actions are tested in ActionTest - here we just check that we can modify the correct -- def. unit_move_to_def_and_construct_let :: Assertion unit_move_to_def_and_construct_let = - progActionTest defaultEmptyProg [MoveToDef "other", BodyAction [ConstructLet (Just "x")]] $ + progActionTest defaultEmptyProg [moveToDef "other", BodyAction [ConstructLet (Just "x")]] $ expectSuccess $ \prog prog' -> - case astDefExpr <$> lookupASTDef "other" (moduleDefs $ progModule prog') of + case astDefExpr <$> lookupASTDef' "other" (moduleDefs $ progModule prog') of Just Let{} -> -- Check that main is unchanged Map.lookup "main" (moduleDefs $ progModule prog') @?= Map.lookup "main" (moduleDefs $ progModule prog) @@ -124,79 +137,79 @@ unit_move_to_def_and_construct_let = unit_rename_def :: Assertion unit_rename_def = - progActionTest defaultEmptyProg [RenameDef "other" "foo"] $ + progActionTest defaultEmptyProg [renameDef "other" "foo"] $ expectSuccess $ \_ prog' -> do fmap defName (Map.lookup "other" (moduleDefs $ progModule prog')) @?= Nothing - fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just "foo" - fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just "main" + fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just (gvn "foo") + fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just (gvn "main") unit_rename_def_to_same_name_as_existing_def :: Assertion unit_rename_def_to_same_name_as_existing_def = - progActionTest defaultEmptyProg [RenameDef "main" "main"] $ - expectError (@?= DefAlreadyExists "main") + progActionTest defaultEmptyProg [renameDef "main" "main"] $ + expectError (@?= DefAlreadyExists (gvn "main")) unit_rename_def_to_same_name_as_existing_def_prim :: Assertion unit_rename_def_to_same_name_as_existing_def_prim = - progActionTest defaultFullProg [RenameDef "other" "toUpper"] $ - expectError (@?= DefAlreadyExists "toUpper") + progActionTest defaultFullProg [renameDef "other" "toUpper"] $ + expectError (@?= DefAlreadyExists (gvn "toUpper")) unit_rename_def_referenced :: Assertion unit_rename_def_referenced = progActionTest defaultEmptyProg - [ MoveToDef "main" - , BodyAction [ConstructVar $ GlobalVarRef "other"] - , RenameDef "other" "foo" + [ moveToDef "main" + , BodyAction [ConstructVar $ globalVarRef "other"] + , renameDef "other" "foo" ] $ expectSuccess $ \_ prog' -> do fmap defName (Map.lookup "other" (moduleDefs $ progModule prog')) @?= Nothing - fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just "foo" - fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just "main" - fmap (set _exprMeta () . astDefExpr) (defAST =<< Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just (Var () $ GlobalVarRef "foo") + fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just (gvn "foo") + fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just (gvn "main") + fmap (set _exprMeta () . astDefExpr) (defAST =<< Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just (Var () $ globalVarRef "foo") unit_rename_def_recursive :: Assertion unit_rename_def_recursive = progActionTest defaultEmptyProg - [ MoveToDef "main" - , BodyAction [ConstructVar $ GlobalVarRef "main"] - , RenameDef "main" "foo" + [ moveToDef "main" + , BodyAction [ConstructVar $ globalVarRef "main"] + , renameDef "main" "foo" ] $ expectSuccess $ \_ prog' -> do fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Nothing - fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just "foo" - fmap (set _exprMeta () . astDefExpr) (defAST =<< Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just (Var () $ GlobalVarRef "foo") + fmap defName (Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just (gvn "foo") + fmap (set _exprMeta () . astDefExpr) (defAST =<< Map.lookup "foo" (moduleDefs $ progModule prog')) @?= Just (Var () $ globalVarRef "foo") unit_delete_def :: Assertion unit_delete_def = - progActionTest defaultEmptyProg [DeleteDef "other"] $ + progActionTest defaultEmptyProg [deleteDef "other"] $ expectSuccess $ \_ prog' -> do fmap defName (Map.lookup "other" (moduleDefs $ progModule prog')) @?= Nothing - fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just "main" + fmap defName (Map.lookup "main" (moduleDefs $ progModule prog')) @?= Just (gvn "main") unit_delete_def_unknown_id :: Assertion unit_delete_def_unknown_id = - progActionTest defaultEmptyProg [DeleteDef "unknown"] $ - expectError (@?= DefNotFound "unknown") + progActionTest defaultEmptyProg [deleteDef "unknown"] $ + expectError (@?= DefNotFound (gvn "unknown")) unit_delete_def_used_id :: Assertion unit_delete_def_used_id = - progActionTest defaultEmptyProg [MoveToDef "main", BodyAction [ConstructVar $ GlobalVarRef "other"], DeleteDef "other"] $ - expectError (@?= DefInUse "other") + progActionTest defaultEmptyProg [moveToDef "main", BodyAction [ConstructVar $ globalVarRef "other"], deleteDef "other"] $ + expectError (@?= DefInUse (gvn "other")) -- 'foo = foo' shouldn't count as "in use" and block deleting itself unit_delete_def_recursive :: Assertion unit_delete_def_recursive = - progActionTest defaultEmptyProg [MoveToDef "main", BodyAction [ConstructVar $ GlobalVarRef "main"], DeleteDef "main"] $ + progActionTest defaultEmptyProg [moveToDef "main", BodyAction [ConstructVar $ globalVarRef "main"], deleteDef "main"] $ expectSuccess $ \prog prog' -> Map.delete "main" (moduleDefs $ progModule prog) @?= moduleDefs (progModule prog') unit_move_to_unknown_def :: Assertion unit_move_to_unknown_def = - progActionTest defaultEmptyProg [MoveToDef "unknown"] $ expectError (@?= DefNotFound "unknown") + progActionTest defaultEmptyProg [moveToDef "unknown"] $ expectError (@?= DefNotFound (gvn "unknown")) unit_rename_unknown_def :: Assertion unit_rename_unknown_def = - progActionTest defaultEmptyProg [RenameDef "unknown" "foo"] $ expectError (@?= DefNotFound "unknown") + progActionTest defaultEmptyProg [renameDef "unknown" "foo"] $ expectError (@?= DefNotFound (gvn "unknown")) unit_construct_let_without_moving_to_def_first :: Assertion unit_construct_let_without_moving_to_def_first = @@ -205,34 +218,34 @@ unit_construct_let_without_moving_to_def_first = unit_create_def :: Assertion unit_create_def = progActionTest defaultEmptyProg [CreateDef $ Just "newDef"] $ expectSuccess $ \_ prog' -> do - case lookupASTDef "newDef" (moduleDefs $ progModule prog') of + case lookupASTDef' "newDef" (moduleDefs $ progModule prog') of Nothing -> assertFailure $ show $ moduleDefs $ progModule prog' Just def -> do - astDefName def @?= "newDef" + astDefName def @?= gvn "newDef" astDefExpr def @?= EmptyHole (Meta 4 Nothing Nothing) unit_create_def_clash_prim :: Assertion unit_create_def_clash_prim = progActionTest defaultFullProg [CreateDef $ Just "toUpper"] $ - expectError (@?= DefAlreadyExists "toUpper") + expectError (@?= DefAlreadyExists (gvn "toUpper")) unit_create_typedef :: Assertion unit_create_typedef = let lst = ASTTypeDef - { astTypeDefName = "List" + { astTypeDefName = tcn "List" , astTypeDefParameters = [("a", KType)] , astTypeDefConstructors = - [ ValCon "Nil" [] - , ValCon "Cons" [TVar () "a", TApp () (TCon () "List") (TVar () "a")] + [ ValCon (vcn "Nil") [] + , ValCon (vcn "Cons") [TVar () "a", TApp () (TCon () (tcn "List")) (TVar () "a")] ] , astTypeDefNameHints = ["xs", "ys", "zs"] } tree = ASTTypeDef - { astTypeDefName = "Tree" + { astTypeDefName = tcn "Tree" , astTypeDefParameters = [("a", KType)] - , astTypeDefConstructors = [ValCon "Node" [TVar () "a", TApp () (TCon () "List") (TApp () (TCon () "Tree") (TVar () "a"))]] + , astTypeDefConstructors = [ValCon (vcn "Node") [TVar () "a", TApp () (TCon () (tcn "List")) (TApp () (TCon () (tcn "Tree")) (TVar () "a"))]] , astTypeDefNameHints = ["xs", "ys", "zs"] } in progActionTest defaultEmptyProg [AddTypeDef lst, AddTypeDef tree] $ @@ -249,27 +262,27 @@ unit_create_typedef_bad_1 :: Assertion unit_create_typedef_bad_1 = let td = ASTTypeDef - { astTypeDefName = "Tree" + { astTypeDefName = tcn "Tree" , astTypeDefParameters = [("a", KType)] - , astTypeDefConstructors = [ValCon "Node" [TVar () "a", TApp () (TCon () "List") (TApp () (TCon () "Tree") (TVar () "a"))]] + , astTypeDefConstructors = [ValCon (vcn "Node") [TVar () "a", TApp () (TCon () $ tcn "List") (TApp () (TCon () $ tcn "Tree") (TVar () "a"))]] , astTypeDefNameHints = ["xs", "ys", "zs"] } in progActionTest defaultEmptyProg [AddTypeDef td] $ - expectError (@?= TypeDefError "UnknownTypeConstructor \"List\"") + expectError (@?= (TypeDefError $ show $ UnknownTypeConstructor (tcn "List"))) -- duplicate type(names) added unit_create_typedef_bad_2 :: Assertion unit_create_typedef_bad_2 = let td1 = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [] , astTypeDefConstructors = [] , astTypeDefNameHints = [] } td2 = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [] , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -282,11 +295,11 @@ unit_create_typedef_bad_3 :: Assertion unit_create_typedef_bad_3 = let td = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [] , astTypeDefConstructors = - [ ValCon "C" [] - , ValCon "C" [] + [ ValCon (vcn "C") [] + , ValCon (vcn "C") [] ] , astTypeDefNameHints = [] } @@ -298,16 +311,16 @@ unit_create_typedef_bad_4 :: Assertion unit_create_typedef_bad_4 = let td1 = ASTTypeDef - { astTypeDefName = "T1" + { astTypeDefName = tcn "T1" , astTypeDefParameters = [] - , astTypeDefConstructors = [ValCon "C" []] + , astTypeDefConstructors = [ValCon (vcn "C") []] , astTypeDefNameHints = [] } td2 = ASTTypeDef - { astTypeDefName = "T2" + { astTypeDefName = tcn "T2" , astTypeDefParameters = [] - , astTypeDefConstructors = [ValCon "C" []] + , astTypeDefConstructors = [ValCon (vcn "C") []] , astTypeDefNameHints = [] } in progActionTest defaultEmptyProg [AddTypeDef td1, AddTypeDef td2] $ @@ -318,7 +331,7 @@ unit_create_typedef_bad_5 :: Assertion unit_create_typedef_bad_5 = let td = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [("a", KType), ("a", KType)] , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -331,7 +344,7 @@ unit_create_typedef_bad_6 :: Assertion unit_create_typedef_bad_6 = let td = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [("T", KType)] , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -344,9 +357,9 @@ unit_create_typedef_bad_7 :: Assertion unit_create_typedef_bad_7 = let td = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [("a", KType)] - , astTypeDefConstructors = [ValCon "a" []] + , astTypeDefConstructors = [ValCon (vcn "a") []] , astTypeDefNameHints = [] } in progActionTest defaultEmptyProg [AddTypeDef td] $ @@ -357,7 +370,7 @@ unit_create_typedef_bad_prim :: Assertion unit_create_typedef_bad_prim = let td = ASTTypeDef - { astTypeDefName = "Char" + { astTypeDefName = tcn "Char" , astTypeDefParameters = [] , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -370,9 +383,9 @@ unit_create_typedef_8 :: Assertion unit_create_typedef_8 = let td = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [] - , astTypeDefConstructors = [ValCon "T" []] + , astTypeDefConstructors = [ValCon (vcn "T") []] , astTypeDefNameHints = [] } in progActionTest defaultEmptyProg [AddTypeDef td] $ @@ -383,14 +396,14 @@ unit_create_typedef_9 :: Assertion unit_create_typedef_9 = let td1 = ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "T" , astTypeDefParameters = [] - , astTypeDefConstructors = [ValCon "C" []] + , astTypeDefConstructors = [ValCon (vcn "C") []] , astTypeDefNameHints = [] } td2 = ASTTypeDef - { astTypeDefName = "C" + { astTypeDefName = tcn "C" , astTypeDefParameters = [] , astTypeDefConstructors = [] , astTypeDefNameHints = [] @@ -400,9 +413,9 @@ unit_create_typedef_9 = unit_construct_arrow_in_sig :: Assertion unit_construct_arrow_in_sig = - progActionTest defaultEmptyProg [MoveToDef "other", SigAction [ConstructArrowL, Move Child1]] $ + progActionTest defaultEmptyProg [moveToDef "other", SigAction [ConstructArrowL, Move Child1]] $ expectSuccess $ \_ prog' -> - case lookupASTDef "other" (moduleDefs $ progModule prog') of + case lookupASTDef' "other" (moduleDefs $ progModule prog') of Just def -> -- Check that the signature is an arrow type case astDefType def of @@ -420,34 +433,36 @@ unit_sigaction_creates_holes :: Assertion unit_sigaction_creates_holes = let acts = [ -- main :: Char - MoveToDef "main" - , SigAction [constructTCon tChar] + moveToDef "main" + , SigAction [ConstructTCon (mainModuleNameText, "Char")] , -- other :: Char; other = main - MoveToDef "other" - , SigAction [constructTCon tChar] - , BodyAction [ConstructVar $ GlobalVarRef "main"] + moveToDef "other" + , SigAction [ConstructTCon (mainModuleNameText, "Char")] + , BodyAction [ConstructVar $ GlobalVarRef $ gvn "main"] , -- main :: Int -- We expect this to change 'other' to contain a hole - MoveToDef "main" - , SigAction [Delete, constructTCon tInt] + moveToDef "main" + , SigAction [Delete, ConstructTCon (mainModuleNameText, "Int")] ] in progActionTest defaultFullProg acts $ expectSuccess $ \_ prog' -> - case lookupASTDef "other" (moduleDefs $ progModule prog') of + case lookupASTDef' "other" (moduleDefs $ progModule prog') of Just def -> -- Check that the definition is a non-empty hole case astDefExpr def of - Hole _ (Var _ (GlobalVarRef "main")) -> pure () + Hole _ (Var _ (GlobalVarRef n)) | n == gvn "main" -> pure () _ -> assertFailure "expected {? main ?}" _ -> assertFailure "definition not found" unit_copy_paste_duplicate :: Assertion unit_copy_paste_duplicate = do - let ((p, fromType, fromExpr, _toType, _toExpr), maxID) = create $ do + let fromDef = gvn "main" + toDef = gvn "blank" + ((p, fromType, fromExpr, _toType, _toExpr), maxID) = create $ do mainType <- tforall "a" KType (tvar "a" `tfun` (tcon tMaybe `tapp` tEmptyHole)) mainExpr <- lAM "b" $ lam "x" $ con cJust `aPP` tvar "b" `app` lvar "x" - let mainDef = ASTDef "main" mainExpr mainType - blankDef <- ASTDef "blank" <$> emptyHole <*> tEmptyHole + let mainDef = ASTDef fromDef mainExpr mainType + blankDef <- ASTDef toDef <$> emptyHole <*> tEmptyHole pure ( newProg{progSelection = Nothing} & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST mainDef), ("blank", DefAST blankDef)] @@ -456,8 +471,6 @@ unit_copy_paste_duplicate = do , getID (astDefType blankDef) , getID (astDefExpr blankDef) ) - fromDef = "main" - toDef = "blank" let a = newApp{appProg = p} actions = [MoveToDef toDef, CopyPasteSig (fromDef, fromType) [], CopyPasteBody (fromDef, fromExpr) []] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg p <*> handleEditRequest actions @@ -466,12 +479,12 @@ unit_copy_paste_duplicate = do Right (tcp, r) -> -- use the typechecked input p, as the result will have had a typecheck run, so -- we need the cached kinds to match up - let src = lookupASTDef fromDef (moduleDefs $ progModule tcp) + let src = lookupASTDef fromDef (moduleDefsQualified $ progModule tcp) clearIDs = set (_Just % _defIDs) 0 in do - src @?= lookupASTDef fromDef (moduleDefs $ progModule r) - assertBool "equal to toDef" $ src /= lookupASTDef "blank" (moduleDefs $ progModule r) - clearIDs (set (_Just % #astDefName) "blank" src) @?= clearIDs (lookupASTDef "blank" (moduleDefs $ progModule r)) + src @?= lookupASTDef fromDef (moduleDefsQualified $ progModule r) + assertBool "equal to toDef" $ src /= lookupASTDef' "blank" (moduleDefs $ progModule r) + clearIDs (set (_Just % #astDefName) toDef src) @?= clearIDs (lookupASTDef' "blank" (moduleDefs $ progModule r)) -- ∀a . (∀b,c . a -> b -> ∀d. c -> d) -> ∀c. ? -- copy ^------------------^ @@ -487,18 +500,19 @@ unit_copy_paste_duplicate = do -- - The d is bound within the copied subtree, so it is in-scope unit_copy_paste_type_scoping :: Assertion unit_copy_paste_type_scoping = do - let ((pInitial, srcID, pExpected), maxID) = create $ do + let mainName = gvn "main" + ((pInitial, srcID, pExpected), maxID) = create $ do toCopy <- tvar "a" `tfun` tvar "b" `tfun` tforall "d" KType (tvar "c" `tfun` tvar "d") let skel r = tforall "a" KType $ tfun (tforall "b" KType $ tforall "c" KType $ pure toCopy) $ tforall "c" KType r - defInitial <- ASTDef "main" <$> emptyHole <*> skel tEmptyHole - expected <- ASTDef "main" <$> emptyHole <*> skel (tvar "a" `tfun` tEmptyHole `tfun` tforall "d" KType (tEmptyHole `tfun` tvar "d")) + defInitial <- ASTDef mainName <$> emptyHole <*> skel tEmptyHole + expected <- ASTDef mainName <$> emptyHole <*> skel (tvar "a" `tfun` tEmptyHole `tfun` tforall "d" KType (tEmptyHole `tfun` tvar "d")) pure ( newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] , getID toCopy , newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST expected)] ) let a = newEmptyApp{appProg = pInitial} - actions = [MoveToDef "main", CopyPasteSig ("main", srcID) [Move Child1, Move Child2, Move Child1]] + actions = [MoveToDef mainName, CopyPasteSig (mainName, srcID) [Move Child1, Move Child2, Move Child1]] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg pExpected <*> handleEditRequest actions case result of Left e -> assertFailure $ show e @@ -506,23 +520,24 @@ unit_copy_paste_type_scoping = do -- use the typechecked input p, as the result will have had a typecheck run, so -- we need the cached kinds to match up let clearIDs = set (traversed % #_DefAST % _defIDs) 0 - in -- clearIDs (set (_Just % #defName) "blank" src ) @?= clearIDs (Map.lookup toDef (progDefs r)) - clearIDs (moduleDefs $ progModule r) @?= clearIDs (moduleDefs $ progModule tcpExpected) + in clearIDs (moduleDefs $ progModule r) @?= clearIDs (moduleDefs $ progModule tcpExpected) -- ∀a b.a ~> ∀a.a unit_raise :: Assertion unit_raise = do - let ((pInitial, srcID, pExpected), maxID) = create $ do + let mainName' = "main" + mainName = gvn mainName' + ((pInitial, srcID, pExpected), maxID) = create $ do toCopy <- tvar "a" - defInitial <- ASTDef "main" <$> emptyHole <*> tforall "a" KType (tforall "b" KType $ pure toCopy) - expected <- ASTDef "main" <$> emptyHole <*> tforall "a" KType (tvar "a") + defInitial <- ASTDef mainName <$> emptyHole <*> tforall "a" KType (tforall "b" KType $ pure toCopy) + expected <- ASTDef mainName <$> emptyHole <*> tforall "a" KType (tvar "a") pure - ( newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] + ( newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [(mainName', DefAST defInitial)] , getID toCopy - , newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST expected)] + , newEmptyProg & #progModule % #moduleDefs .~ Map.fromList [(mainName', DefAST expected)] ) let a = newEmptyApp{appProg = pInitial} - actions = [MoveToDef "main", CopyPasteSig ("main", srcID) [Move Child1, Delete]] + actions = [MoveToDef mainName, CopyPasteSig (mainName, srcID) [Move Child1, Delete]] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg pExpected <*> handleEditRequest actions case result of Left e -> assertFailure $ show e @@ -538,7 +553,9 @@ unit_raise = do -- /\a . λ x . case x of Nil -> lettype b = ? in let y = ? : a in Pair @a @b y z ; Cons y ys -> /\@b z -> Pair @a @b y z unit_copy_paste_expr_1 :: Assertion unit_copy_paste_expr_1 = do - let ((pInitial, srcID, pExpected), maxID) = create $ do + let mainName' = "main" + mainName = gvn mainName' + ((pInitial, srcID, pExpected), maxID) = create $ do ty <- tforall "a" KType $ (tcon tList `tapp` tvar "a") `tfun` tforall "b" KType (tvar "b" `tfun` (tcon tPair `tapp` tvar "a" `tapp` tvar "b")) let toCopy' = con cMakePair `aPP` tvar "a" `aPP` tvar "b" `app` lvar "y" `app` lvar "z" -- want different IDs for the two occurences in expected toCopy <- toCopy' @@ -554,15 +571,15 @@ unit_copy_paste_expr_1 = do -- TODO: in the future we may want to insert let bindings for variables -- which are out of scope in the target, and produce something like -- expectPasted <- letType "b" tEmptyHole $ let_ "y" (emptyHole `ann` tvar "a") $ let_ "z" (emptyHole `ann` tvar "b") toCopy' - defInitial <- ASTDef "main" <$> skel emptyHole <*> pure ty - expected <- ASTDef "main" <$> skel (pure expectPasted) <*> pure ty + defInitial <- ASTDef mainName <$> skel emptyHole <*> pure ty + expected <- ASTDef mainName <$> skel (pure expectPasted) <*> pure ty pure - ( newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] + ( newProg & #progModule % #moduleDefs .~ Map.fromList [(mainName', DefAST defInitial)] , getID toCopy - , newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST expected)] + , newProg & #progModule % #moduleDefs .~ Map.fromList [(mainName', DefAST expected)] ) let a = newApp{appProg = pInitial} - actions = [MoveToDef "main", CopyPasteBody ("main", srcID) [Move Child1, Move Child1, Move (Branch cNil)]] + actions = [MoveToDef mainName, CopyPasteBody (mainName, srcID) [Move Child1, Move Child1, Move (Branch cNil)]] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg pExpected <*> handleEditRequest actions case result of Left e -> assertFailure $ show e @@ -574,42 +591,46 @@ unit_copy_paste_expr_1 = do unit_copy_paste_ann :: Assertion unit_copy_paste_ann = do - let ((p, fromAnn), maxID) = create $ do + let fromDef' = "main" + fromDef = gvn fromDef' + toDef' = "blank" + toDef = gvn toDef' + ((p, fromAnn), maxID) = create $ do toCopy <- tcon tBool - mainDef <- ASTDef "main" <$> emptyHole `ann` pure toCopy <*> tEmptyHole - blankDef <- ASTDef "blank" <$> emptyHole `ann` tEmptyHole <*> tEmptyHole + mainDef <- ASTDef fromDef <$> emptyHole `ann` pure toCopy <*> tEmptyHole + blankDef <- ASTDef toDef <$> emptyHole `ann` tEmptyHole <*> tEmptyHole pure - ( newProg{progSelection = Nothing} & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST mainDef), ("blank", DefAST blankDef)] + ( newProg{progSelection = Nothing} & #progModule % #moduleDefs .~ Map.fromList [(fromDef', DefAST mainDef), ("blank", DefAST blankDef)] , getID toCopy ) let a = newApp{appProg = p} - actions = [MoveToDef "blank", CopyPasteBody ("main", fromAnn) [EnterType]] + actions = [MoveToDef toDef, CopyPasteBody (fromDef, fromAnn) [EnterType]] let (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg p <*> handleEditRequest actions case result of Left e -> assertFailure $ show e Right (tcp, r) -> -- use the typechecked input p, as the result will have had a typecheck run, so -- we need the cached kinds to match up - let src = lookupASTDef "main" (moduleDefs $ progModule tcp) + let src = lookupASTDef' fromDef' (moduleDefs $ progModule tcp) clearIDs = set (_Just % _defIDs) 0 in do - src @?= lookupASTDef "main" (moduleDefs $ progModule r) - assertBool "equal to blank" $ src /= lookupASTDef "blank" (moduleDefs $ progModule r) - clearIDs (set (_Just % #astDefName) "blank" src) @?= clearIDs (lookupASTDef "blank" (moduleDefs $ progModule r)) + src @?= lookupASTDef' fromDef' (moduleDefs $ progModule r) + assertBool "equal to blank" $ src /= lookupASTDef' toDef' (moduleDefs $ progModule r) + clearIDs (set (_Just % #astDefName) toDef src) @?= clearIDs (lookupASTDef' toDef' (moduleDefs $ progModule r)) unit_copy_paste_ann2sig :: Assertion unit_copy_paste_ann2sig = do let ((pInitial, srcID, pExpected), maxID) = create $ do toCopy <- tcon tBool - defInitial <- ASTDef "main" <$> emptyHole `ann` pure toCopy <*> tEmptyHole - expected <- ASTDef "main" <$> emptyHole `ann` pure toCopy <*> tcon tBool + defInitial <- astDef "main" <$> emptyHole `ann` pure toCopy <*> tEmptyHole + expected <- astDef "main" <$> emptyHole `ann` pure toCopy <*> tcon tBool pure ( newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] , getID toCopy , newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST expected)] ) let a = newApp{appProg = pInitial} - actions = [MoveToDef "main", CopyPasteSig ("main", srcID) []] + actions = [moveToDef "main", copyPasteSig ("main", srcID) []] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg pExpected <*> handleEditRequest actions case result of Left e -> assertFailure $ show e @@ -623,15 +644,15 @@ unit_copy_paste_sig2ann :: Assertion unit_copy_paste_sig2ann = do let ((pInitial, srcID, pExpected), maxID) = create $ do toCopy <- tcon tBool - defInitial <- ASTDef "main" <$> emptyHole <*> pure toCopy - expected <- ASTDef "main" <$> emptyHole `ann` tcon tBool <*> pure toCopy + defInitial <- astDef "main" <$> emptyHole <*> pure toCopy + expected <- astDef "main" <$> emptyHole `ann` tcon tBool <*> pure toCopy pure ( newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST defInitial)] , getID toCopy , newProg & #progModule % #moduleDefs .~ Map.fromList [("main", DefAST expected)] ) let a = newApp{appProg = pInitial} - actions = [MoveToDef "main", CopyPasteBody ("main", srcID) [ConstructAnn, EnterType]] + actions = [moveToDef "main", copyPasteBody ("main", srcID) [ConstructAnn, EnterType]] (result, _) = runAppTestM maxID a $ (,) <$> tcWholeProg pExpected <*> handleEditRequest actions case result of Left e -> assertFailure $ show e @@ -646,13 +667,13 @@ unit_import_vars :: Assertion unit_import_vars = let test = do importModules [builtinModule, primitiveModule] - gets (Map.assocs . moduleDefs . progModule . appProg) >>= \case + gets (Map.assocs . moduleDefsQualified . progModule . appProg) >>= \case [(i, DefAST d)] -> do a' <- get (_, vs) <- runReaderT (handleQuestion (VariablesInScope i $ getID $ astDefExpr d)) a' pure $ assertBool "VariablesInScope did not report the imported Int.+" $ - any ((== "Int.+") . fst) vs + any ((== primitiveGVar "Int.+") . fst) vs _ -> pure $ assertFailure "Expected one def 'main' from newEmptyApp" a = newEmptyApp in case fst $ runAppTestM (ID $ appIdCounter a) a test of @@ -663,10 +684,9 @@ unit_import_vars = unit_import_reference :: Assertion unit_import_reference = let test = do - p <- defaultFullProg - importModules [progModule p] + importModules [builtinModule, primitiveModule] prog <- gets appProg - case (findGlobalByName prog "toUpper", Map.assocs $ moduleDefs $ progModule prog) of + case (findGlobalByName prog $ primitiveGVar "toUpper", Map.assocs $ moduleDefsQualified $ progModule prog) of (Just toUpperDef, [(i, _)]) -> do _ <- handleEditRequest @@ -682,6 +702,25 @@ unit_import_reference = Left err -> assertFailure $ show err Right assertion -> assertion +unit_import_twice_1 :: Assertion +unit_import_twice_1 = + let test = do + importModules [builtinModule] + importModules [builtinModule] + a = newEmptyApp + in case fst $ runAppTestM (ID $ appIdCounter a) a test of + Left err -> err @?= ActionError (ImportNameClash [moduleName builtinModule]) + Right _ -> assertFailure "Expected importModules to error, since module names clash with prior import" + +unit_import_twice_2 :: Assertion +unit_import_twice_2 = + let test = do + importModules [builtinModule, builtinModule] + a = newEmptyApp + in case fst $ runAppTestM (ID $ appIdCounter a) a test of + Left err -> err @?= ActionError (ImportNameClash [moduleName builtinModule]) + Right _ -> assertFailure "Expected importModules to error, since module names clash within one import" + -- Can copy and paste from an imported module unit_copy_paste_import :: Assertion unit_copy_paste_import = @@ -689,19 +728,20 @@ unit_copy_paste_import = importModules [builtinModule] ty <- tcon tBool `tfun` tcon tBool e <- lam "x" $ lvar "x" - let def = ASTDef "foo" e ty + let def = ASTDef (TestUtils.gvn "M" "foo") e ty let m = Module - { moduleTypes = mempty + { moduleName = "M" + , moduleTypes = mempty , moduleDefs = Map.singleton "foo" $ DefAST def } importModules [m] prog <- gets appProg - case (findGlobalByName prog "foo", Map.assocs $ moduleDefs $ progModule prog) of - (Just (DefAST other), [(i, _)]) -> do - let fromDef = astDefName other - fromType = getID $ astDefType other - fromExpr = getID $ astDefExpr other + case (findGlobalByName prog $ TestUtils.gvn "M" "foo", Map.assocs $ moduleDefsQualified $ progModule prog) of + (Just (DefAST fooDef), [(i, _)]) -> do + let fromDef = astDefName fooDef + fromType = getID $ astDefType fooDef + fromExpr = getID $ astDefExpr fooDef _ <- handleEditRequest [ MoveToDef i @@ -716,38 +756,33 @@ unit_copy_paste_import = Left err -> assertFailure $ show err Right assertion -> assertion -unit_rename_def_capture :: Assertion -unit_rename_def_capture = - progActionTest defaultEmptyProg [MoveToDef "other", BodyAction [ConstructLam $ Just "foo"], RenameDef "main" "foo"] $ - expectError (@?= ActionError NameCapture) - unit_RenameType :: Assertion unit_RenameType = progActionTest ( defaultProgEditableTypeDefs $ sequence [ do - x <- emptyHole `ann` (tcon "T" `tapp` tcon "Bool") - ASTDef "def" x <$> tEmptyHole + x <- emptyHole `ann` (tcon tT `tapp` tcon (tcn "Bool")) + astDef "def" x <$> tEmptyHole ] ) - [RenameType "T" "T'"] + [RenameType tT "T'"] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T'" prog' - astTypeDefName td @?= "T'" - def <- findDef "def" prog' + td <- findTypeDef (tcn "T'") prog' + astTypeDefName td @?= tcn "T'" + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ - emptyHole `ann` (tcon "T'" `tapp` tcon "Bool") + emptyHole `ann` (tcon (tcn "T'") `tapp` tcon (tcn "Bool")) ) unit_RenameType_clash :: Assertion unit_RenameType_clash = progActionTest (defaultProgEditableTypeDefs $ pure []) - [RenameType "T" "Int"] - $ expectError (@?= TypeDefAlreadyExists "Int") + [RenameType tT "Int"] + $ expectError (@?= TypeDefAlreadyExists (tcn "Int")) unit_RenameCon :: Assertion unit_RenameCon = @@ -758,25 +793,25 @@ unit_RenameCon = x <- hole ( hole - (con "A") + (con cA) ) - ASTDef "def" x <$> tEmptyHole + astDef "def" x <$> tEmptyHole ] ) - [RenameCon "T" "A" "A'"] + [RenameCon tT cA "A'"] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T" prog' + td <- findTypeDef tT prog' astTypeDefConstructors td - @?= [ ValCon "A'" [TCon () "Bool", TCon () "Bool", TCon () "Bool"] - , ValCon "B" [TVar () "b"] + @?= [ ValCon (vcn "A'") [TCon () (tcn "Bool"), TCon () (tcn "Bool"), TCon () (tcn "Bool")] + , ValCon cB [TVar () "b"] ] - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ hole ( hole - (con "A'") + (con $ vcn "A'") ) ) @@ -789,32 +824,32 @@ unit_RenameCon_clash = x <- hole ( hole - (con "A") + (con cA) ) - ASTDef "def" x <$> tEmptyHole + astDef "def" x <$> tEmptyHole ] ) - [RenameCon "T" "A" "True"] - $ expectError (@?= ConAlreadyExists "True") + [RenameCon tT cA "True"] + $ expectError (@?= ConAlreadyExists (vcn "True")) unit_RenameTypeParam :: Assertion unit_RenameTypeParam = progActionTest (defaultProgEditableTypeDefs $ pure []) - [RenameTypeParam "T" "b" "b'"] + [RenameTypeParam tT "b" "b'"] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T" prog' + td <- findTypeDef tT prog' astTypeDefParameters td @?= [("a", KType), ("b'", KType)] astTypeDefConstructors td - @?= [ ValCon "A" [TCon () "Bool", TCon () "Bool", TCon () "Bool"] - , ValCon "B" [TVar () "b'"] + @?= [ ValCon cA [TCon () (tcn "Bool"), TCon () (tcn "Bool"), TCon () (tcn "Bool")] + , ValCon cB [TVar () "b'"] ] unit_RenameTypeParam_clash :: Assertion unit_RenameTypeParam_clash = progActionTest (defaultProgEditableTypeDefs $ pure []) - [RenameTypeParam "T" "a" "b"] + [RenameTypeParam tT "a" "b"] $ expectError (@?= ParamAlreadyExists "b") unit_AddCon :: Assertion @@ -825,30 +860,30 @@ unit_AddCon = [ do x <- case_ - (emptyHole `ann` (tcon "T" `tapp` tcon "Bool" `tapp` tcon "Int")) - [ branch "A" [] emptyHole - , branch "B" [] emptyHole + (emptyHole `ann` (tcon tT `tapp` tcon (tcn "Bool") `tapp` tcon (tcn "Int"))) + [ branch cA [] emptyHole + , branch cB [] emptyHole ] - ASTDef "def" x <$> tEmptyHole + astDef "def" x <$> tEmptyHole ] ) - [AddCon "T" 1 "C"] + [AddCon tT 1 "C"] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T" prog' + td <- findTypeDef tT prog' astTypeDefConstructors td - @?= [ ValCon "A" [TCon () "Bool", TCon () "Bool", TCon () "Bool"] - , ValCon "C" [] - , ValCon "B" [TVar () "b"] + @?= [ ValCon cA [TCon () (tcn "Bool"), TCon () (tcn "Bool"), TCon () (tcn "Bool")] + , ValCon (vcn "C") [] + , ValCon cB [TVar () "b"] ] - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ case_ - (emptyHole `ann` (tcon "T" `tapp` tcon "Bool" `tapp` tcon "Int")) - [ branch "A" [] emptyHole - , branch "C" [] emptyHole - , branch "B" [] emptyHole + (emptyHole `ann` (tcon tT `tapp` tcon (tcn "Bool") `tapp` tcon (tcn "Int"))) + [ branch cA [] emptyHole + , branch (vcn "C") [] emptyHole + , branch cB [] emptyHole ] ) @@ -856,40 +891,40 @@ unit_SetConFieldType :: Assertion unit_SetConFieldType = progActionTest ( defaultProgEditableTypeDefs . sequence . pure $ do - x <- con "A" `app` lvar "x" `app` (gvar "y" `ann` tcon "Bool") - ASTDef "def" x <$> tEmptyHole + x <- con cA `app` lvar "x" `app` (gvar (gvn "y") `ann` tcon (tcn "Bool")) + astDef "def" x <$> tEmptyHole ) - [SetConFieldType "T" "A" 1 $ TCon () "Int"] + [SetConFieldType tT cA 1 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T" prog' + td <- findTypeDef tT prog' astTypeDefConstructors td - @?= [ ValCon "A" [TCon () "Bool", TCon () "Int", TCon () "Bool"] - , ValCon "B" [TVar () "b"] + @?= [ ValCon cA [TCon () (tcn "Bool"), TCon () (tcn "Int"), TCon () (tcn "Bool")] + , ValCon cB [TVar () "b"] ] - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ - con "A" `app` lvar "x" `app` hole (gvar "y" `ann` tcon "Bool") + con cA `app` lvar "x" `app` hole (gvar (gvn "y") `ann` tcon (tcn "Bool")) ) unit_SetConFieldType_partial_app :: Assertion unit_SetConFieldType_partial_app = progActionTest ( defaultProgEditableTypeDefs $ do - x <- con "A" `app` lvar "x" + x <- con cA `app` lvar "x" sequence - [ ASTDef "def" x <$> tcon "T" + [ astDef "def" x <$> tcon tT ] ) - [SetConFieldType "T" "A" 1 $ TCon () "Int"] + [SetConFieldType tT cA 1 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ hole $ - con "A" `app` lvar "x" + con cA `app` lvar "x" ) unit_SetConFieldType_case :: Assertion @@ -898,30 +933,30 @@ unit_SetConFieldType_case = ( defaultProgEditableTypeDefs $ do x <- case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("z", Nothing)] (lvar "y") - , branch "B" [] emptyHole + , branch cB [] emptyHole ] sequence - [ ASTDef "def" x <$> tcon "Bool" + [ astDef "def" x <$> tcon (tcn "Bool") ] ) - [SetConFieldType "T" "A" 1 $ TCon () "Int"] + [SetConFieldType tT cA 1 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("z", Nothing)] (hole $ lvar "y") - , branch "B" [] emptyHole + , branch cB [] emptyHole ] ) @@ -931,31 +966,31 @@ unit_SetConFieldType_shadow = ( defaultProgEditableTypeDefs $ do x <- case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("z", Nothing)] (lam "y" (lvar "y") `app` lvar "y") - , branch "B" [] emptyHole + , branch cB [] emptyHole ] sequence - [ ASTDef "def" x <$> tcon "Bool" + [ astDef "def" x <$> tcon (tcn "Bool") ] ) - [SetConFieldType "T" "A" 1 $ TCon () "Int"] + [SetConFieldType tT cA 1 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("z", Nothing)] -- only the free `y` should be put in to a hole (lam "y" (lvar "y") `app` hole (lvar "y")) - , branch "B" [] emptyHole + , branch cB [] emptyHole ] ) @@ -963,41 +998,41 @@ unit_AddConField :: Assertion unit_AddConField = progActionTest ( defaultProgEditableTypeDefs $ do - x <- con "A" `app` con "True" + x <- con cA `app` con (vcn "True") sequence - [ ASTDef "def" x <$> tEmptyHole + [ astDef "def" x <$> tEmptyHole ] ) - [AddConField "T" "A" 1 $ TCon () "Int"] + [AddConField tT cA 1 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - td <- findTypeDef "T" prog' + td <- findTypeDef tT prog' astTypeDefConstructors td - @?= [ ValCon "A" [TCon () "Bool", TCon () "Int", TCon () "Bool", TCon () "Bool"] - , ValCon "B" [TVar () "b"] + @?= [ ValCon cA [TCon () (tcn "Bool"), TCon () (tcn "Int"), TCon () (tcn "Bool"), TCon () (tcn "Bool")] + , ValCon cB [TVar () "b"] ] - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ - con "A" `app` con "True" `app` emptyHole + con cA `app` con (vcn "True") `app` emptyHole ) unit_AddConField_partial_app :: Assertion unit_AddConField_partial_app = progActionTest ( defaultProgEditableTypeDefs $ do - x <- con "A" `app` con "True" + x <- con cA `app` con (vcn "True") sequence - [ ASTDef "def" x <$> tEmptyHole + [ astDef "def" x <$> tEmptyHole ] ) - [AddConField "T" "A" 2 $ TCon () "Int"] + [AddConField tT cA 2 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ - hole $ con "A" `app` con "True" + hole $ con cA `app` con (vcn "True") ) unit_AddConField_case :: Assertion @@ -1006,37 +1041,37 @@ unit_AddConField_case = ( defaultProgEditableTypeDefs $ do x <- case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("z", Nothing)] (lvar "y") - , branch "B" [] emptyHole + , branch cB [] emptyHole ] sequence - [ ASTDef "def" x <$> tEmptyHole + [ astDef "def" x <$> tEmptyHole ] ) - [AddConField "T" "A" 2 $ TCon () "Int"] + [AddConField tT cA 2 $ TCon () (tcn "Int")] $ expectSuccess $ \_ prog' -> do - def <- findDef "def" prog' + def <- findDef (gvn "def") prog' forgetIDs (astDefExpr def) @?= forgetIDs ( fst . create $ case_ - (emptyHole `ann` (tcon "T" `tapp` tEmptyHole `tapp` tEmptyHole)) + (emptyHole `ann` (tcon tT `tapp` tEmptyHole `tapp` tEmptyHole)) [ branch - "A" + cA [("x", Nothing), ("y", Nothing), ("a19", Nothing), ("z", Nothing)] (lvar "y") - , branch "B" [] emptyHole + , branch cB [] emptyHole ] ) -- * Utilities findGlobalByName :: Prog -> GVarName -> Maybe Def -findGlobalByName p n = Map.lookup n . foldMap moduleDefs $ progAllModules p +findGlobalByName p n = Map.lookup n . foldMap moduleDefsQualified $ progAllModules p -- We use a program with two defs: "main" and "other" defaultEmptyProg :: MonadFresh ID m => m Prog @@ -1045,8 +1080,8 @@ defaultEmptyProg = do mainType <- tEmptyHole otherExpr <- emptyHole otherType <- tEmptyHole - let mainDef = ASTDef "main" mainExpr mainType - otherDef = ASTDef "other" otherExpr otherType + let mainDef = astDef "main" mainExpr mainType + otherDef = astDef "other" otherExpr otherType in pure $ newEmptyProg { progSelection = @@ -1061,29 +1096,75 @@ defaultEmptyProg = do } & #progModule % #moduleDefs - .~ Map.fromList [(astDefName mainDef, DefAST mainDef), (astDefName otherDef, DefAST otherDef)] + .~ Map.fromList [(astDefBaseName mainDef, DefAST mainDef), (astDefBaseName otherDef, DefAST otherDef)] unit_good_defaultEmptyProg :: Assertion unit_good_defaultEmptyProg = checkProgWellFormed defaultEmptyProg --- `defaultEmptyProg`, plus all primitive definitions (types and terms), +-- `defaultEmptyProg`, plus all primitive definitions (types and terms) -- and all builtin types, all moved into the editable module +-- NB: this means that primitive constructors are unusable, since they +-- will not typecheck (we now have only a "Main.Char" type, not a +-- "Primitive.Char" type), but we can now test our error handling for +-- adding types whose name clashes with that of a primitive etc. defaultFullProg :: MonadFresh ID m => m Prog defaultFullProg = do p <- defaultEmptyProg + let m = moduleName $ progModule p + -- We need to move the primitives, which requires renaming + -- unit_defaultFullModule_no_clash ensures that there will be no clashes + renamed = + renameMod (moduleName primitiveModule) m $ + renameMod (moduleName builtinModule) m [builtinModule, primitiveModule] + renamedTypes = renamed ^.. folded % #moduleTypes % folded + renamedDefs = foldOf (folded % #moduleDefs) renamed pure $ - over (#progModule % #moduleTypes) ((moduleTypes builtinModule <> moduleTypes primitiveModule) <>) - . over (#progModule % #moduleDefs) (moduleDefs primitiveModule <>) - $ p + p & #progModule % #moduleTypes %~ (mkTypeDefMap renamedTypes <>) + & #progModule % #moduleDefs %~ (renamedDefs <>) + where + -- TODO: can we use uniplate and write something like `transformBi rnName`? + -- (This will require data instances for Def etc) + -- However we should be careful as ModuleName = Name, and we don't want to + -- transform Names inside LocalName etc! + renameMod :: ModuleName -> ModuleName -> [Module] -> [Module] + -- Caution: if we expose something similar as an action, we would need a + -- test for duplicate module names similar to this for safety, but that + -- would get in the way for our testing purposes here. + -- | any ((== to).moduleName) mods = error "clashing name" + renameMod fromName toName = map rn1 + where + rn1 (m :: Module) = + m & #moduleName %~ rnName + & #moduleTypes % mapped %~ rnTyDef + & #moduleDefs % mapped %~ rnDef + rnName n = if n == fromName then toName else n + rnTyDef (TypeDefPrim td) = TypeDefPrim $ td & #primTypeDefName % #qualifiedModule %~ rnName + rnTyDef (TypeDefAST td) = + TypeDefAST $ + td & #astTypeDefName % #qualifiedModule %~ rnName + & #astTypeDefConstructors % mapped %~ rnVC + rnVC vc = + vc & #valConName % #qualifiedModule %~ rnName + & #valConArgs % mapped %~ transformBi rnName + rnDef (DefPrim d) = + DefPrim $ + d & #primDefName % #qualifiedModule %~ rnName + & #primDefType %~ transformBi rnName + rnDef (DefAST d) = + DefAST $ + d & #astDefName % #qualifiedModule %~ rnName + & #astDefExpr %~ transformBi rnName + & #astDefType %~ transformBi rnName findTypeDef :: TyConName -> Prog -> IO ASTTypeDef -findTypeDef d p = maybe (assertFailure "couldn't find typedef") pure $ (typeDefAST <=< Map.lookup d) $ p ^. (#progModule % #moduleTypes) +findTypeDef d p = maybe (assertFailure "couldn't find typedef") pure $ (typeDefAST <=< Map.lookup d) $ p ^. (#progModule % to moduleTypesQualified) findDef :: GVarName -> Prog -> IO ASTDef -findDef d p = maybe (assertFailure "couldn't find def") pure $ (defAST <=< Map.lookup d) $ p ^. (#progModule % #moduleDefs) +findDef d p = maybe (assertFailure "couldn't find def") pure $ (defAST <=< Map.lookup d) $ p ^. (#progModule % to moduleDefsQualified) -- We use the same type definition for all tests related to editing type definitions -- (This is added to `defaultFullProg`) +-- The qualified name for this is recorded in 'tT', and its constructors are 'cA' and 'cB' defaultProgEditableTypeDefs :: MonadFresh ID f => f [ASTDef] -> f Prog defaultProgEditableTypeDefs ds = do p <- defaultFullProg @@ -1091,20 +1172,40 @@ defaultProgEditableTypeDefs ds = do let tds = [ TypeDefAST ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tT , astTypeDefParameters = [("a", KType), ("b", KType)] - , astTypeDefConstructors = [ValCon "A" (replicate 3 $ TCon () "Bool"), ValCon "B" [TVar () "b"]] + , astTypeDefConstructors = [ValCon cA (replicate 3 $ TCon () (tcn "Bool")), ValCon cB [TVar () "b"]] , astTypeDefNameHints = [] } ] pure $ p & (#progModule % #moduleTypes) %~ (mkTypeDefMap tds <>) - & (#progModule % #moduleDefs) %~ (Map.fromList ((\d -> (astDefName d, DefAST d)) <$> ds') <>) + & (#progModule % #moduleDefs) %~ (Map.fromList ((\d -> (baseName $ astDefName d, DefAST d)) <$> ds') <>) + +tT :: TyConName +tT = tcn "T" + +cA :: ValConName +cA = vcn "A" + +cB :: ValConName +cB = vcn "B" unit_good_defaultFullProg :: Assertion 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 + ms = progModule p : [builtinModule, primitiveModule] + typeNames = ms ^.. folded % #moduleTypes % folded % to typeDefName % #baseName + termNames = ms ^.. folded % #moduleDefs % to Map.keys % folded + in do + assertBool "Expected every type making up defaultFullProg to have distinct names" $ not $ anySame typeNames + assertBool "Expected every term making up defaultFullProg to have distinct names" $ not $ anySame termNames + _defIDs :: Traversal' ASTDef ID _defIDs = #astDefExpr % (_exprMeta % _id `adjoin` _exprTypeMeta % _id) `adjoin` #astDefType % _typeMeta % _id @@ -1143,3 +1244,49 @@ runAppTestM startID a m = case evalTestM startID $ runExceptT $ flip runStateT a $ unAppTestM m of Left err -> (Left err, a) Right (res, app') -> (Right res, app') + +-- Looks up a definition, ignoring any module prefix +-- Useful in these tests so we don't have to specify +-- the name of the module all the time +lookupASTDef' :: Name -> Map Name Def -> Maybe ASTDef +lookupASTDef' name = defAST <=< Map.lookup name + +astDefBaseName :: ASTDef -> Name +astDefBaseName = baseName . astDefName + +-- Some helpers to run actions on the current module +mainModuleName :: ModuleName +mainModuleName = moduleName $ progModule newEmptyProg + +mainModuleNameText :: Text +mainModuleNameText = unName mainModuleName + +moveToDef :: Name -> ProgAction +moveToDef = MoveToDef . qualifyName mainModuleName + +renameDef :: Name -> Text -> ProgAction +renameDef = RenameDef . qualifyName mainModuleName + +deleteDef :: Name -> ProgAction +deleteDef = DeleteDef . gvn + +tcn :: Name -> TyConName +tcn = TestUtils.tcn mainModuleName + +vcn :: Name -> ValConName +vcn = TestUtils.vcn mainModuleName + +gvn :: Name -> GVarName +gvn = TestUtils.gvn mainModuleName + +astDef :: Name -> Expr -> Type -> ASTDef +astDef = ASTDef . gvn + +copyPasteSig :: (Name, ID) -> [Action] -> ProgAction +copyPasteSig (d, i) = CopyPasteSig (gvn d, i) + +copyPasteBody :: (Name, ID) -> [Action] -> ProgAction +copyPasteBody (d, i) = CopyPasteBody (gvn d, i) + +globalVarRef :: Name -> TmVarRef +globalVarRef = GlobalVarRef . gvn diff --git a/primer/test/Tests/Eval.hs b/primer/test/Tests/Eval.hs index 536995ece..25d38003a 100644 --- a/primer/test/Tests/Eval.hs +++ b/primer/test/Tests/Eval.hs @@ -28,6 +28,7 @@ import Primer.Core ( ASTDef (..), Def (..), Expr, + GlobalName (qualifiedModule), ID (ID), Type, TypeDef (TypeDefAST), @@ -53,12 +54,12 @@ import Primer.Eval ( tryReduceExpr, tryReduceType, ) -import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) +import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), mkTypeDefMap) import Primer.Primitives (primitiveGVar, primitiveModule, tChar) import Primer.Zipper (target) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=)) import TestM (evalTestM) -import TestUtils (withPrimDefs) +import TestUtils (gvn, vcn, withPrimDefs) import Tests.Action.Prog (runAppTestM) -- * 'tryReduce' tests @@ -102,11 +103,11 @@ unit_tryReduce_beta_annotation :: Assertion unit_tryReduce_beta_annotation = do let ((lambda, body, arg, input, expectedResult, argType, resultType), maxid) = create $ do - t1 <- tcon "A" - t2 <- tcon "B" + t1 <- tcon' "M" "A" + t2 <- tcon' "M" "B" x <- lvar "x" l <- lam "x" (pure x) - a <- con "C" + a <- con' "M" "C" i <- app (ann (pure l) (tfun (pure t1) (pure t2))) (pure a) r <- ann (let_ "x" (ann (pure a) (pure t1)) (pure x)) (pure t2) pure (l, x, a, i, r, t1, t2) @@ -132,7 +133,7 @@ unit_tryReduce_beta_annotation_hole = do t2 <- tEmptyHole x <- lvar "x" l <- lam "x" (pure x) - a <- con "C" + a <- con' "M" "C" i <- app (ann (pure l) tEmptyHole) (pure a) r <- hole (let_ "x" (hole (pure a)) (pure x)) pure (l, x, a, i, r, t1, t2) @@ -157,16 +158,16 @@ unit_tryReduce_beta_nested = do create $ do e <- lam "y" (lvar "x") l <- lam "x" (pure e) - a <- con "C" - i <- app (app (pure l) (pure a)) (con "D") - r <- app (let_ "x" (pure a) (pure e)) (con "D") + a <- con' "M" "C" + i <- app (app (pure l) (pure a)) (con' "M" "D") + r <- app (let_ "x" (pure a) (pure e)) (con' "M" "D") pure (l, e, a, i, r) result = runTryReduce mempty mempty (input, maxid) case result of Right (expr, BetaReduction detail) -> do expr ~= expectedResult - betaBefore detail ~= fst (create (app (lam "x" (lam "y" (lvar "x"))) (con "C"))) - betaAfter detail ~= fst (create (let_ "x" (con "C") (lam "y" (lvar "x")))) + 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")))) betaBindingName detail @?= "x" betaLambdaID detail @?= lambda ^. _id betaArgID detail @?= arg ^. _id @@ -178,20 +179,20 @@ unit_tryReduce_beta_annotation_nested :: Assertion unit_tryReduce_beta_annotation_nested = do let ((lambda, body, arg, input, expectedResult, argType, resultType), maxid) = create $ do - t1 <- tcon "A" - t2 <- tcon "B" + t1 <- tcon' "M" "A" + t2 <- tcon' "M" "B" x <- lvar "x" l <- lam "x" (pure x) - a <- con "C" - i <- app (app (ann (pure l) (tfun (pure t1) (pure t2))) (pure a)) (con "D") - r <- app (ann (let_ "x" (ann (pure a) (pure t1)) (pure x)) (pure t2)) (con "D") + a <- con' "M" "C" + i <- app (app (ann (pure l) (tfun (pure t1) (pure t2))) (pure a)) (con' "M" "D") + r <- app (ann (let_ "x" (ann (pure a) (pure t1)) (pure x)) (pure t2)) (con' "M" "D") pure (l, x, a, i, r, t1, t2) result = runTryReduce mempty mempty (input, maxid) 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 "A") (tcon "B"))) (con "C"))) - betaAfter detail ~= fst (create (ann (let_ "x" (ann (con "C") (tcon "A")) (lvar "x")) (tcon "B"))) + 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"))) betaBindingName detail @?= "x" betaLambdaID detail @?= lambda ^. _id betaArgID detail @?= arg ^. _id @@ -213,7 +214,7 @@ unit_tryReduce_beta_name_clash :: Assertion unit_tryReduce_beta_name_clash = do let ((c, lambda, body, arg, input, expectedResult), maxid) = create $ do - c_ <- con "C" + c_ <- con' "M" "C" e <- lam "x0" (lvar "x") l <- lam "x" (pure e) a <- lvar "x" @@ -261,7 +262,7 @@ unit_tryReduce_BETA = do unit_tryReduce_local_term_var :: Assertion unit_tryReduce_local_term_var = do -- We assume we're inside a larger expression (e.g. a let) where the node that binds x has ID 5. - let ((expr, val), i) = create $ (,) <$> lvar "x" <*> con "C" + let ((expr, val), i) = create $ (,) <$> lvar "x" <*> con' "M" "C" locals = Map.singleton "x" (5, Left val) result = runTryReduce mempty locals (expr, i) case result of @@ -279,7 +280,7 @@ unit_tryReduce_local_term_var = do unit_tryReduce_local_type_var :: Assertion unit_tryReduce_local_type_var = do -- We assume we're inside a larger expression (e.g. a let type) where the node that binds x has ID 5. - let ((tyvar, val), i) = create $ (,) <$> tvar "x" <*> tcon "C" + let ((tyvar, val), i) = create $ (,) <$> tvar "x" <*> tcon' "M" "C" locals = Map.singleton "x" (5, Right val) result = runTryReduceType mempty locals (tyvar, i) case result of @@ -296,14 +297,15 @@ unit_tryReduce_local_type_var = do unit_tryReduce_global_var :: Assertion unit_tryReduce_global_var = do - let ((expr, def), i) = create $ do - g <- gvar "f" + let f = gvn "M" "f" + ((expr, def), i) = create $ do + g <- gvar f e <- lam "x" (lvar "x") - t <- tfun (tcon "A") (tcon "B") - pure (g, ASTDef{astDefName = "f", astDefExpr = e, astDefType = t}) - globals = Map.singleton "f" (DefAST def) + t <- tfun (tcon' "M" "A") (tcon' "M" "B") + 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 "A") (tcon "B")) + expectedResult = fst $ create $ ann (lam "x" (lvar "x")) (tfun (tcon' "M" "A") (tcon' "M" "B")) case result of Right (expr', GlobalVarInline detail) -> do expr' ~= expectedResult @@ -315,9 +317,9 @@ unit_tryReduce_global_var = do unit_tryReduce_let :: Assertion unit_tryReduce_let = do - let (expr, i) = create $ let_ "x" (con "C") (con "D") + let (expr, i) = create $ let_ "x" (con' "M" "C") (con' "M" "D") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con "D" + expectedResult = fst $ create $ con' "M" "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -331,9 +333,9 @@ unit_tryReduce_let = do unit_tryReduce_lettype :: Assertion unit_tryReduce_lettype = do - let (expr, i) = create $ letType "x" (tcon "C") (con "D") + let (expr, i) = create $ letType "x" (tcon' "M" "C") (con' "M" "D") result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ con "D" + expectedResult = fst $ create $ con' "M" "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -347,9 +349,9 @@ unit_tryReduce_lettype = do unit_tryReduce_letrec :: Assertion unit_tryReduce_letrec = do - let (expr, i) = create $ letrec "x" (con "C") (tcon "T") (con "D") + 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 "D" + expectedResult = fst $ create $ con' "M" "D" case result of Right (expr', LetRemoval detail) -> do expr' ~= expectedResult @@ -366,13 +368,13 @@ unit_tryReduce_letrec = do unit_tryReduce_letrec_app :: Assertion unit_tryReduce_letrec_app = do let ((arg, lambda, letrec_, expr), i) = create $ do - arg_ <- con "D" + arg_ <- con' "M" "D" lam_ <- lam "x" $ app (lvar "f") (lvar "x") - lr <- letrec "f" (lam "x" (lvar "x")) (tcon "T") (pure lam_) + lr <- letrec "f" (lam "x" (lvar "x")) (tcon' "M" "T") (pure lam_) 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 "T") (app (lam "x" (app (lvar "f") (lvar "x"))) (con "D")) + expectedResult = fst $ 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 @@ -391,13 +393,13 @@ unit_tryReduce_letrec_app = do unit_tryReduce_letrec_APP :: Assertion unit_tryReduce_letrec_APP = do let ((arg, lambda, letrec_, expr), i) = create $ do - arg_ <- tcon "B" + arg_ <- tcon' "M" "B" lam_ <- lAM "x" $ aPP (lvar "f") (tvar "x") - lr <- letrec "f" (lAM "x" (con "A")) (tcon "T") (pure lam_) + lr <- letrec "f" (lAM "x" (con' "M" "A")) (tcon' "M" "T") (pure lam_) 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 "A")) (tcon "T") (aPP (lAM "x" (aPP (lvar "f") (tvar "x"))) (tcon "B")) + expectedResult = fst $ 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 @@ -420,9 +422,9 @@ unit_tryReduce_letrec_name_clash = do -- locals map. This simulates focusing on the letrec inside the let expression. let ((expr, d, letd), i) = create $ do -- the value bound by the outer let - d_ <- con "D" + d_ <- con' "M" "D" -- the application - e <- app (letrec "f" (lam "x" (lvar "x")) (tcon "T") (lam "x" (app (lvar "f") (lvar "x")))) (lvar "f") + e <- app (letrec "f" (lam "x" (lvar "x")) (tcon' "M" "T") (lam "x" (app (lvar "f") (lvar "x")))) (lvar "f") -- the outer let letd_ <- let_ "f" (pure d_) (pure e) pure (e, d_, letd_) @@ -431,9 +433,9 @@ unit_tryReduce_letrec_name_clash = do unit_tryReduce_case_1 :: Assertion unit_tryReduce_case_1 = do - let (expr, i) = create $ case_ (con "C") [branch "B" [("b", Nothing)] (con "D"), branch "C" [] (con "E")] + 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 "E" + expectedResult = fst $ create $ con' "M" "E" case result of Right (expr', CaseReduction detail) -> do expr' ~= expectedResult @@ -442,7 +444,7 @@ unit_tryReduce_case_1 = do caseAfter detail ~= expectedResult caseTargetID detail @?= 1 caseTargetCtorID detail @?= 1 - caseCtorName detail @?= "C" + caseCtorName detail @?= vcn "M" "C" caseTargetArgIDs detail @?= [] caseBranchBindingIDs detail @?= [] caseBranchRhsID detail @?= 4 @@ -454,12 +456,12 @@ unit_tryReduce_case_2 = do let (expr, i) = create $ case_ - (app (app (app (con "C") (lam "x" (lvar "x"))) (lvar "y")) (lvar "z")) - [ branch "B" [("b", Nothing)] (con "D") - , branch "C" [("c", Nothing), ("d", Nothing), ("e", Nothing)] (con "E") + (app (app (app (con' "M" "C") (lam "x" (lvar "x"))) (lvar "y")) (lvar "z")) + [ branch' ("M", "B") [("b", Nothing)] (con' "M" "D") + , 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 "E"))) + expectedResult = fst $ 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 @@ -468,7 +470,7 @@ unit_tryReduce_case_2 = do caseAfter detail ~= expectedResult caseTargetID detail @?= 1 caseTargetCtorID detail @?= 4 - caseCtorName detail @?= "C" + caseCtorName detail @?= vcn "M" "C" caseTargetArgIDs detail @?= [5, 7, 8] caseBranchBindingIDs detail @?= [11, 12, 13] caseBranchRhsID detail @?= 14 @@ -480,12 +482,12 @@ unit_tryReduce_case_3 = do let (expr, i) = create $ case_ - (app (aPP (con "C") (tcon "D")) (con "E")) - [ branch "B" [("b", Nothing)] (con "D") - , branch "C" [("c", Nothing)] (con "F") + (app (aPP (con' "M" "C") (tcon' "M" "D")) (con' "M" "E")) + [ branch' ("M", "B") [("b", Nothing)] (con' "M" "D") + , branch' ("M", "C") [("c", Nothing)] (con' "M" "F") ] result = runTryReduce mempty mempty (expr, i) - expectedResult = fst $ create $ let_ "c" (con "E") (con "F") + expectedResult = fst $ create $ let_ "c" (con' "M" "E") (con' "M" "F") case result of Right (expr', CaseReduction detail) -> do expr' ~= expectedResult @@ -494,7 +496,7 @@ unit_tryReduce_case_3 = do caseAfter detail ~= expectedResult caseTargetID detail @?= 1 caseTargetCtorID detail @?= 3 - caseCtorName detail @?= "C" + caseCtorName detail @?= vcn "M" "C" caseTargetArgIDs detail @?= [5] caseBranchBindingIDs detail @?= [8] caseBranchRhsID detail @?= 9 @@ -503,25 +505,25 @@ unit_tryReduce_case_3 = do unit_tryReduce_case_too_many_bindings :: Assertion unit_tryReduce_case_too_many_bindings = do - let (expr, i) = create $ case_ (con "C") [branch "C" [("b", Nothing)] (con "D")] + let (expr, i) = create $ case_ (con' "M" "C") [branch' ("M", "C") [("b", Nothing)] (con' "M" "D")] result = runTryReduce mempty mempty (expr, i) result @?= Left CaseBranchBindingLengthMismatch unit_tryReduce_case_too_few_bindings :: Assertion unit_tryReduce_case_too_few_bindings = do - let (expr, i) = create $ case_ (app (con "B") (lvar "y")) [branch "B" [] (con "D")] + let (expr, i) = create $ case_ (app (con' "M" "B") (lvar "y")) [branch' ("M", "B") [] (con' "M" "D")] result = runTryReduce mempty mempty (expr, i) result @?= Left CaseBranchBindingLengthMismatch unit_tryReduce_case_scrutinee_not_redex :: Assertion unit_tryReduce_case_scrutinee_not_redex = do - let (expr, i) = create $ case_ (lvar "x") [branch "B" [] (con "D")] + let (expr, i) = create $ case_ (lvar "x") [branch' ("M", "B") [] (con' "M" "D")] result = runTryReduce mempty mempty (expr, i) result @?= Left NotRedex unit_tryReduce_case_no_matching_branch :: Assertion unit_tryReduce_case_no_matching_branch = do - let (expr, i) = create $ case_ (con "C") [branch "B" [] (con "D")] + let (expr, i) = create $ case_ (con' "M" "C") [branch' ("M", "B") [] (con' "M" "D")] result = runTryReduce mempty mempty (expr, i) result @?= Left NoMatchingCaseBranch @@ -568,9 +570,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 "T") (lvar "x") + let expr = fst $ create $ letrec "x" (lvar "x") (tcon' "M" "T") (lvar "x") x = fst $ create $ lvar "x" - t = fst $ create $ tcon "T" + t = fst $ 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 @@ -603,7 +605,7 @@ unit_findNodeByID_1 = do -- id 0 x_ <- lvar "x" -- id 1 - c_ <- con "C" + c_ <- con' "M" "C" -- id 2 e <- let_ "x" (pure c_) (pure x_) pure (x_, c_, e) @@ -636,7 +638,7 @@ unit_findNodeByID_2 = do -- id 0 x_ <- tvar "x" -- id 1 - t_ <- tcon "T" + t_ <- tcon' "M" "T" -- id 2 e <- letType "x" (pure t_) (ann (lvar "y") (pure x_)) pure (x_, t_, e) @@ -659,7 +661,7 @@ unit_findNodeByID_2 = do -- e.g. -- -- 0 1 2 3 4 5 6 7 --- lam "y" (app (lam "x" (var "x")) (app (lam "z" (var "z")) (con "C"))) +-- lam "y" (app (lam "x" (var "x")) (app (lam "z" (var "z")) (con' "M" "C"))) -- | A helper for these tests redexesOf :: S Expr -> Set ID @@ -670,130 +672,130 @@ redexesOfWithPrims :: S Expr -> Set ID redexesOfWithPrims x = uncurry redexes $ fst $ create $ withPrimDefs $ \globals -> (globals,) <$> x unit_redexes_con :: Assertion -unit_redexes_con = redexesOf (con "C") @?= mempty +unit_redexes_con = redexesOf (con' "M" "C") @?= mempty unit_redexes_lam_1 :: Assertion unit_redexes_lam_1 = - redexesOf (app (lam "x" (lvar "x")) (con "C")) @?= Set.singleton 0 + redexesOf (app (lam "x" (lvar "x")) (con' "M" "C")) @?= Set.singleton 0 unit_redexes_lam_2 :: Assertion unit_redexes_lam_2 = - redexesOf (lam "y" (app (lam "x" (lvar "x")) (con "C"))) @?= Set.singleton 1 + redexesOf (lam "y" (app (lam "x" (lvar "x")) (con' "M" "C"))) @?= Set.singleton 1 unit_redexes_lam_3 :: Assertion unit_redexes_lam_3 = - redexesOf (lam "y" (app (lam "x" (lvar "x")) (app (lam "z" (lvar "z")) (con "C")))) + redexesOf (lam "y" (app (lam "x" (lvar "x")) (app (lam "z" (lvar "z")) (con' "M" "C")))) @?= Set.fromList [1, 4] unit_redexes_lam_4 :: Assertion unit_redexes_lam_4 = - redexesOf (lam "y" (app (lam "x" (lvar "x")) (app (lam "z" (lvar "z")) (con "C")))) + redexesOf (lam "y" (app (lam "x" (lvar "x")) (app (lam "z" (lvar "z")) (con' "M" "C")))) @?= Set.fromList [1, 4] unit_redexes_LAM_1 :: Assertion unit_redexes_LAM_1 = - redexesOf (lAM "a" (con "C")) @?= mempty + redexesOf (lAM "a" (con' "M" "C")) @?= mempty unit_redexes_LAM_2 :: Assertion unit_redexes_LAM_2 = - redexesOf (aPP (lAM "a" (con "C")) (tcon "A")) @?= Set.fromList [0] + redexesOf (aPP (lAM "a" (con' "M" "C")) (tcon' "M" "A")) @?= Set.fromList [0] unit_redexes_LAM_3 :: Assertion unit_redexes_LAM_3 = - redexesOf (lAM "a" (aPP (lAM "b" (con "X")) (tcon "T"))) @?= Set.fromList [1] + redexesOf (lAM "a" (aPP (lAM "b" (con' "M" "X")) (tcon' "M" "T"))) @?= Set.fromList [1] unit_redexes_LAM_4 :: Assertion unit_redexes_LAM_4 = - redexesOf (let_ "x" (con "C") (lAM "a" (aPP (lAM "b" (lvar "x")) (tcon "T")))) + redexesOf (let_ "x" (con' "M" "C") (lAM "a" (aPP (lAM "b" (lvar "x")) (tcon' "M" "T")))) @?= Set.fromList [3, 5] unit_redexes_let_1 :: Assertion unit_redexes_let_1 = - redexesOf (let_ "x" (con "C") (app (lvar "x") (lvar "y"))) + redexesOf (let_ "x" (con' "M" "C") (app (lvar "x") (lvar "y"))) @?= Set.singleton 3 unit_redexes_let_2 :: Assertion unit_redexes_let_2 = - redexesOf (let_ "x" (con "C") (lam "x" (app (lvar "x") (lvar "y")))) + redexesOf (let_ "x" (con' "M" "C") (lam "x" (app (lvar "x") (lvar "y")))) @?= Set.singleton 0 unit_redexes_letrec_1 :: Assertion unit_redexes_letrec_1 = - redexesOf (letrec "x" (app (con "C") (lvar "x")) (tcon "T") (app (lvar "x") (lvar "y"))) + redexesOf (letrec "x" (app (con' "M" "C") (lvar "x")) (tcon' "M" "T") (app (lvar "x") (lvar "y"))) @?= Set.fromList [3, 6] unit_redexes_letrec_2 :: Assertion unit_redexes_letrec_2 = - redexesOf (letrec "x" (app (con "C") (lvar "x")) (tcon "T") (lvar "y")) + redexesOf (letrec "x" (app (con' "M" "C") (lvar "x")) (tcon' "M" "T") (lvar "y")) @?= Set.fromList [0, 3] -- The application can be reduced by pushing the argument inside the letrec unit_redexes_letrec_app_1 :: Assertion unit_redexes_letrec_app_1 = - redexesOf (app (letrec "e" (con "C") (tcon "T") (lam "x" (lvar "e"))) (con "D")) + redexesOf (app (letrec "e" (con' "M" "C") (tcon' "M" "T") (lam "x" (lvar "e"))) (con' "M" "D")) @?= Set.fromList [0, 5] -- The application can't be reduced because variables in the argument clash with the letrec unit_redexes_letrec_app_2 :: Assertion unit_redexes_letrec_app_2 = - redexesOf (let_ "e" (con "D") (app (letrec "e" (con "C") (tcon "T") (lam "x" (lvar "e"))) (lvar "e"))) + redexesOf (let_ "e" (con' "M" "D") (app (letrec "e" (con' "M" "C") (tcon' "M" "T") (lam "x" (lvar "e"))) (lvar "e"))) @?= Set.fromList [7, 8] unit_redexes_letrec_APP_1 :: Assertion unit_redexes_letrec_APP_1 = - redexesOf (aPP (letrec "e" (con "C") (tcon "T") (lAM "x" (lvar "e"))) (tcon "D")) + redexesOf (aPP (letrec "e" (con' "M" "C") (tcon' "M" "T") (lAM "x" (lvar "e"))) (tcon' "M" "D")) @?= Set.fromList [0, 5] unit_redexes_letrec_APP_2 :: Assertion unit_redexes_letrec_APP_2 = - redexesOf (letType "e" (tcon "D") (aPP (letrec "e" (con "C") (tcon "T") (lAM "x" (lvar "e"))) (tvar "e"))) + redexesOf (letType "e" (tcon' "M" "D") (aPP (letrec "e" (con' "M" "C") (tcon' "M" "T") (lAM "x" (lvar "e"))) (tvar "e"))) @?= Set.fromList [7, 8] unit_redexes_lettype_1 :: Assertion unit_redexes_lettype_1 = - redexesOf (letType "x" (tcon "T") (con "C")) @?= Set.fromList [0] + redexesOf (letType "x" (tcon' "M" "T") (con' "M" "C")) @?= Set.fromList [0] unit_redexes_lettype_2 :: Assertion unit_redexes_lettype_2 = - redexesOf (letType "x" (tcon "T") (aPP (con "C") (tvar "x"))) @?= Set.fromList [4] + redexesOf (letType "x" (tcon' "M" "T") (aPP (con' "M" "C") (tvar "x"))) @?= Set.fromList [4] unit_redexes_lettype_3 :: Assertion unit_redexes_lettype_3 = - redexesOf (letType "x" (tcon "T") (letrec "y" (con "C") (tvar "x") (lvar "y"))) @?= Set.fromList [4, 5] + redexesOf (letType "x" (tcon' "M" "T") (letrec "y" (con' "M" "C") (tvar "x") (lvar "y"))) @?= Set.fromList [4, 5] unit_redexes_case_1 :: Assertion unit_redexes_case_1 = - redexesOf (case_ (con "C") [branch "C" [] (con "D")]) + redexesOf (case_ (con' "M" "C") [branch' ("M", "C") [] (con' "M" "D")]) @?= Set.singleton 0 -- Same as above, but the scrutinee has an annotation unit_redexes_case_1_annotated :: Assertion unit_redexes_case_1_annotated = - redexesOf (case_ (ann (con "C") (tcon "C")) [branch "C" [] (con "D")]) + redexesOf (case_ (ann (con' "M" "C") (tcon' "M" "C")) [branch' ("M", "C") [] (con' "M" "D")]) @?= Set.singleton 0 unit_redexes_case_2 :: Assertion unit_redexes_case_2 = - redexesOf (case_ (lam "x" (lvar "x")) [branch "C" [] (con "D")]) + redexesOf (case_ (lam "x" (lvar "x")) [branch' ("M", "C") [] (con' "M" "D")]) @?= mempty -- The case expression can be reduced, as can the variable x in the branch rhs. unit_redexes_case_3 :: Assertion unit_redexes_case_3 = - redexesOf (let_ "x" (con "C") (case_ (con "C") [branch "C" [] (lvar "x")])) + redexesOf (let_ "x" (con' "M" "C") (case_ (con' "M" "C") [branch' ("M", "C") [] (lvar "x")])) @?= Set.fromList [2, 4] -- The variable x in the rhs is bound to the branch pattern, so is no longer reducible. -- However this means the let is redundant, and can be reduced. unit_redexes_case_4 :: Assertion unit_redexes_case_4 = - redexesOf (let_ "x" (con "C") (case_ (con "C") [branch "C" [("x", Nothing)] (lvar "x")])) + redexesOf (let_ "x" (con' "M" "C") (case_ (con' "M" "C") [branch' ("M", "C") [("x", Nothing)] (lvar "x")])) @?= Set.fromList [0, 2] -- If scrutinee of a case is a redex itself, we recognise that unit_redexes_case_5 :: Assertion unit_redexes_case_5 = - redexesOf (let_ "x" (con "C") (case_ (lvar "x") [])) @?= Set.fromList [3] + redexesOf (let_ "x" (con' "M" "C") (case_ (lvar "x") [])) @?= Set.fromList [3] unit_redexes_prim_1 :: Assertion unit_redexes_prim_1 = @@ -850,7 +852,8 @@ unit_eval_modules_scrutinize_imported_type = where m = Module - { moduleTypes = mkTypeDefMap [TypeDefAST boolDef] + { moduleName = qualifiedModule tBool + , moduleTypes = mkTypeDefMap [TypeDefAST boolDef] , moduleDefs = mempty } diff --git a/primer/test/Tests/EvalFull.hs b/primer/test/Tests/EvalFull.hs index 531c671a3..d0650adbc 100644 --- a/primer/test/Tests/EvalFull.hs +++ b/primer/test/Tests/EvalFull.hs @@ -22,19 +22,36 @@ import Primer.App ( importModules, newEmptyApp, ) -import Primer.Builtins +import Primer.Builtins ( + boolDef, + builtinModule, + cCons, + cFalse, + cJust, + cMakePair, + cNil, + cNothing, + cSucc, + cTrue, + cZero, + tBool, + tList, + tNat, + tPair, + ) import Primer.Core import Primer.Core.DSL import Primer.Core.Utils (forgetIDs, generateIDs) import Primer.EvalFull -import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) +import Primer.Module (Module (Module, moduleDefs, moduleName, moduleTypes), mkTypeDefMap, moduleDefsQualified, moduleTypesQualified) +import Primer.Name (Name) import Primer.Primitives (primitiveGVar, primitiveModule, tChar, tInt) import Primer.Typecheck ( typeDefs, ) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, (@?=)) import TestM -import TestUtils (withPrimDefs) +import TestUtils (gvn, withPrimDefs) import Tests.Action.Prog (runAppTestM) import Tests.Eval ((~=)) import Tests.Gen.Core.Typed (checkTest) @@ -59,9 +76,9 @@ unit_2 = unit_3 :: Assertion unit_3 = let ((expr, expected), maxID) = create $ do - e <- letType "a" (tvar "b") $ emptyHole `ann` (tcon "T" `tapp` tvar "a" `tapp` tforall "a" KType (tvar "a") `tapp` tforall "b" KType (tcon "S" `tapp` tvar "a" `tapp` tvar "b")) + e <- letType "a" (tvar "b") $ emptyHole `ann` (tcon' "M" "T" `tapp` tvar "a" `tapp` tforall "a" KType (tvar "a") `tapp` tforall "b" KType (tcon' "M" "S" `tapp` tvar "a" `tapp` tvar "b")) let b' = "a33" -- NB: fragile name a33 - expect <- emptyHole `ann` (tcon "T" `tapp` tvar "b" `tapp` tforall "a" KType (tvar "a") `tapp` tforall b' KType (tcon "S" `tapp` tvar "b" `tapp` tvar b')) + expect <- emptyHole `ann` (tcon' "M" "T" `tapp` tvar "b" `tapp` tforall "a" KType (tvar "a") `tapp` tforall b' KType (tcon' "M" "S" `tapp` tvar "b" `tapp` tvar b')) pure (e, expect) s = evalFullTest maxID mempty mempty 5 Syn expr in do @@ -72,9 +89,9 @@ unit_3 = unit_4 :: Assertion unit_4 = let ((expr, expected), maxID) = create $ do - e <- let_ "a" (lvar "b") $ con "C" `app` lvar "a" `app` lam "a" (lvar "a") `app` lam "b" (con "D" `app` lvar "a" `app` lvar "b") + e <- let_ "a" (lvar "b") $ con' "M" "C" `app` lvar "a" `app` lam "a" (lvar "a") `app` lam "b" (con' "M" "D" `app` lvar "a" `app` lvar "b") let b' = "a29" -- NB: fragile name a29 - expect <- con "C" `app` lvar "b" `app` lam "a" (lvar "a") `app` lam b' (con "D" `app` lvar "b" `app` lvar b') + expect <- con' "M" "C" `app` lvar "b" `app` lam "a" (lvar "a") `app` lam b' (con' "M" "D" `app` lvar "b" `app` lvar b') pure (e, expect) s = evalFullTest maxID mempty mempty 7 Syn expr in do @@ -131,6 +148,7 @@ unit_8 :: Assertion unit_8 = let n = 10 ((globals, e, expected), maxID) = create $ do + let mapName = gvn "M" "map" mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) map_ <- lAM "a" $ @@ -140,21 +158,23 @@ unit_8 = case_ (lvar "xs") [ branch cNil [] $ con cNil `aPP` tvar "b" - , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cCons `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (gvar "map" `aPP` tvar "a" `aPP` tvar "b" `app` lvar "f" `app` lvar "ys") + , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cCons `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (gvar mapName `aPP` tvar "a" `aPP` tvar "b" `app` lvar "f" `app` lvar "ys") ] + let evenName = gvn "M" "even" + let oddName = gvn "M" "odd" -- even and odd have almost the same type, but their types contain different IDs let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy oddTy <- evenOddTy - isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar "odd" `app` lvar "n"] - isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar "even" `app` lvar "n"] + isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar oddName `app` lvar "n"] + isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar evenName `app` lvar "n"] let mkList t = foldr (\x xs -> con cCons `aPP` t `app` x `app` xs) (con cNil `aPP` t) let lst = mkList (tcon tNat) $ take n $ iterate (con cSucc `app`) (con cZero) - expr <- gvar "map" `aPP` tcon tNat `aPP` tcon tBool `app` gvar "even" `app` lst - let mapDef = DefAST $ ASTDef "map" map_ mapTy - let evenDef = DefAST $ ASTDef "even" isEven evenTy - let oddDef = DefAST $ ASTDef "odd" isOdd oddTy - let globs = [("map", mapDef), ("even", evenDef), ("odd", oddDef)] + expr <- gvar mapName `aPP` tcon tNat `aPP` tcon tBool `app` gvar evenName `app` lst + let mapDef = DefAST $ ASTDef mapName map_ mapTy + let evenDef = DefAST $ ASTDef evenName isEven evenTy + let oddDef = DefAST $ ASTDef oddName isOdd oddTy + let globs = [(mapName, mapDef), (evenName, evenDef), (oddName, oddDef)] expect <- mkList (tcon tBool) (take n $ cycle [con cTrue, con cFalse]) `ann` (tcon tList `tapp` tcon tBool) pure (globs, expr, expect) in do @@ -170,6 +190,7 @@ unit_9 :: Assertion unit_9 = let n = 10 ((globals, e, expected), maxID) = create $ do + let mapName = gvn "M" "map" mapTy <- tforall "a" KType $ tforall "b" KType $ (tvar "a" `tfun` tvar "b") `tfun` ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) let worker = lam "xs" $ @@ -179,19 +200,21 @@ unit_9 = , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cCons `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (lvar "go" `app` lvar "ys") ] map_ <- lAM "a" $ lAM "b" $ lam "f" $ letrec "go" worker ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) $ lvar "go" + let evenName = gvn "M" "even" + let oddName = gvn "M" "odd" -- even and odd have almost the same type, but their types contain different IDs let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy oddTy <- evenOddTy - isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar "odd" `app` lvar "n"] - isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar "even" `app` lvar "n"] + isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar oddName `app` lvar "n"] + isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar evenName `app` lvar "n"] let mkList t = foldr (\x xs -> con cCons `aPP` t `app` x `app` xs) (con cNil `aPP` t) let lst = mkList (tcon tNat) $ take n $ iterate (con cSucc `app`) (con cZero) - expr <- gvar "map" `aPP` tcon tNat `aPP` tcon tBool `app` gvar "even" `app` lst - let mapDef = DefAST $ ASTDef "map" map_ mapTy - let evenDef = DefAST $ ASTDef "even" isEven evenTy - let oddDef = DefAST $ ASTDef "odd" isOdd oddTy - let globs = [("map", mapDef), ("even", evenDef), ("odd", oddDef)] + expr <- gvar mapName `aPP` tcon tNat `aPP` tcon tBool `app` gvar evenName `app` lst + let mapDef = DefAST $ ASTDef mapName map_ mapTy + let evenDef = DefAST $ ASTDef evenName isEven evenTy + let oddDef = DefAST $ ASTDef oddName isOdd oddTy + let globs = [(mapName, mapDef), (evenName, evenDef), (oddName, oddDef)] expect <- mkList (tcon tBool) (take n $ cycle [con cTrue, con cFalse]) `ann` (tcon tList `tapp` tcon tBool) pure (globs, expr, expect) in do @@ -236,22 +259,24 @@ unit_10 = unit_11 :: Assertion unit_11 = let ((globals, e, expected), maxID) = create $ do + let evenName = gvn "M" "even" + let oddName = gvn "M" "odd" -- even and odd have almost the same type, but their types contain different IDs let evenOddTy = tcon tNat `tfun` tcon tBool evenTy <- evenOddTy oddTy <- evenOddTy - isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar "odd" `app` lvar "n"] - isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar "even" `app` lvar "n"] + isEven <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cTrue, branch cSucc [("n", Nothing)] $ gvar oddName `app` lvar "n"] + isOdd <- lam "x" $ case_ (lvar "x") [branch cZero [] $ con cFalse, branch cSucc [("n", Nothing)] $ gvar evenName `app` lvar "n"] let ty = tcon tNat `tfun` (tcon tPair `tapp` tcon tBool `tapp` tcon tNat) let expr1 = let_ "x" (con cZero) $ - lam "n" (con cMakePair `aPP` tcon tBool `aPP` tcon tNat `app` (gvar "even" `app` lvar "n") `app` lvar "x") + lam "n" (con cMakePair `aPP` tcon tBool `aPP` tcon tNat `app` (gvar evenName `app` lvar "n") `app` lvar "x") `ann` ty expr <- expr1 `app` con cZero - let evenDef = DefAST $ ASTDef "even" isEven evenTy - let oddDef = DefAST $ ASTDef "odd" isOdd oddTy - let globs = [("even", evenDef), ("odd", oddDef)] + let evenDef = DefAST $ ASTDef evenName isEven evenTy + let oddDef = DefAST $ ASTDef oddName isOdd oddTy + let globs = [(evenName, evenDef), (oddName, oddDef)] expect <- (con cMakePair `aPP` tcon tBool `aPP` tcon tNat `app` con cTrue `app` con cZero) `ann` (tcon tPair `tapp` tcon tBool `tapp` tcon tNat) @@ -289,8 +314,8 @@ unit_12 = unit_13 :: Assertion unit_13 = let ((e, expected), maxID) = create $ do - expr <- (lam "x" (con "C" `app` lvar "x" `app` let_ "x" (con cTrue) (lvar "x") `app` lvar "x") `ann` (tcon tNat `tfun` tcon tBool)) `app` con cZero - expect <- (con "C" `app` con cZero `app` con cTrue `app` con cZero) `ann` tcon tBool + expr <- (lam "x" (con' "M" "C" `app` lvar "x" `app` let_ "x" (con cTrue) (lvar "x") `app` lvar "x") `ann` (tcon tNat `tfun` tcon tBool)) `app` con cZero + expect <- (con' "M" "C" `app` con cZero `app` con cTrue `app` con cZero) `ann` tcon tBool pure (expr, expect) in do let s = evalFullTest maxID builtinTypes mempty 15 Syn e @@ -321,7 +346,7 @@ unit_15 :: Assertion unit_15 = let ((expr, steps, expected), maxID) = create $ do let l = let_ "x" (lvar "y") - let c a b = con "C" `app` lvar a `app` lvar b + let c a b = con' "M" "C" `app` lvar a `app` lvar b e0 <- l $ lam "y" $ c "x" "y" let y' = "a50" -- NB: fragile name "a50" e1 <- l $ lam y' $ let_ "y" (lvar y') $ c "x" "y" @@ -361,7 +386,7 @@ hprop_resume = withDiscards 2000 $ -- A helper for hprop_resume, and hprop_resume_regression resumeTest :: [Module] -> Dir -> Expr -> PropertyT WT () resumeTest mods dir t = do - let globs = foldMap moduleDefs mods + let globs = foldMap moduleDefsQualified mods tds <- asks typeDefs n <- forAllT $ Gen.integral $ Range.linear 2 1000 -- Arbitrary limit here -- NB: We need to run this first reduction in an isolated context @@ -423,7 +448,7 @@ hprop_type_preservation :: Property hprop_type_preservation = withTests 1000 $ withDiscards 2000 $ propertyWT testModules $ do - let globs = foldMap moduleDefs testModules + let globs = foldMap moduleDefsQualified testModules tds <- asks typeDefs (dir, t, ty) <- genDirTm let test msg e = do @@ -893,7 +918,7 @@ unit_prim_partial_map = , branch cCons [("y", Nothing), ("ys", Nothing)] $ con cCons `aPP` tvar "b" `app` (lvar "f" `app` lvar "y") `app` (lvar "go" `app` lvar "ys") ] map_ <- lAM "a" $ lAM "b" $ lam "f" $ letrec "go" worker ((tcon tList `tapp` tvar "a") `tfun` (tcon tList `tapp` tvar "b")) $ lvar "go" - pure $ DefAST $ ASTDef "map" map_ mapTy + pure $ DefAST $ ASTDef (gvn "M" "map") map_ mapTy -- Test that handleEvalFullRequest will reduce imported terms unit_eval_full_modules :: Assertion @@ -937,7 +962,8 @@ unit_eval_full_modules_scrutinize_imported_type = where m = Module - { moduleTypes = mkTypeDefMap [TypeDefAST boolDef] + { moduleName = qualifiedModule tBool + , moduleTypes = mkTypeDefMap [TypeDefAST boolDef] , moduleDefs = mempty } @@ -946,12 +972,12 @@ unit_eval_full_modules_scrutinize_imported_type = evalFullTest :: ID -> M.Map TyConName TypeDef -> M.Map GVarName Def -> TerminationBound -> Dir -> Expr -> Either EvalFullError Expr evalFullTest id_ tydefs globals n d e = evalTestM id_ $ evalFull tydefs globals n d e -unaryPrimTest :: GVarName -> S Expr -> S Expr -> Assertion +unaryPrimTest :: Name -> S Expr -> S Expr -> Assertion unaryPrimTest f x y = let ((e, r, gs), maxID) = create . withPrimDefs $ \globals -> (,,) - <$> gvar f + <$> gvar (primitiveGVar f) `app` x <*> y <*> pure (DefPrim <$> globals) @@ -959,12 +985,12 @@ unaryPrimTest f x y = in do distinctIDs s s <~==> Right r -binaryPrimTest :: GVarName -> S Expr -> S Expr -> S Expr -> Assertion +binaryPrimTest :: Name -> S Expr -> S Expr -> S Expr -> Assertion binaryPrimTest f x y z = let ((e, r, gs), maxID) = create . withPrimDefs $ \globals -> (,,) - <$> gvar f + <$> gvar (primitiveGVar f) `app` x `app` y <*> z @@ -1005,12 +1031,13 @@ testModule :: Module testModule = let (ty, expr) = fst . create $ (,) <$> tcon tChar `tfun` tcon tChar <*> lam "x" (lvar "x") in Module - { moduleTypes = mempty + { moduleName = "M" + , moduleTypes = mempty , moduleDefs = Map.singleton "idChar" $ DefAST ASTDef - { astDefName = "idChar" + { astDefName = gvn "M" "idChar" , astDefType = ty , astDefExpr = expr } @@ -1043,4 +1070,4 @@ distinctIDs e = (nIds == nDistinct) builtinTypes :: Map TyConName TypeDef -builtinTypes = moduleTypes builtinModule +builtinTypes = moduleTypesQualified builtinModule diff --git a/primer/test/Tests/FreeVars.hs b/primer/test/Tests/FreeVars.hs index 1d20a1d84..98e1a6de7 100644 --- a/primer/test/Tests/FreeVars.hs +++ b/primer/test/Tests/FreeVars.hs @@ -29,4 +29,4 @@ unit_2 = ) (lvar "y") ) - (tforall "a" KType $ tcon "T" `tapp` tvar "a" `tapp` tvar "b") + (tforall "a" KType $ tcon' "M" "T" `tapp` tvar "a" `tapp` tvar "b") diff --git a/primer/test/Tests/Primitives.hs b/primer/test/Tests/Primitives.hs index e8322feec..b26c99d80 100644 --- a/primer/test/Tests/Primitives.hs +++ b/primer/test/Tests/Primitives.hs @@ -29,11 +29,11 @@ import Primer.Typecheck ( buildTypingContextFromModules, checkKind, checkValidContext, + mkTypeDefMapQualified, synth, ) import Primer.Builtins (builtinModule) -import Primer.Module (mkTypeDefMap) import Test.Tasty.HUnit (Assertion, assertBool, (@?=)) import Tests.Typecheck (runTypecheckTestMIn) @@ -74,5 +74,5 @@ unit_prim_con_scope_ast = do , astTypeDefNameHints = mempty } - cxt = buildTypingContext (mkTypeDefMap [charASTDef]) mempty NoSmartHoles + cxt = buildTypingContext (mkTypeDefMapQualified [charASTDef]) mempty NoSmartHoles test = runTypecheckTestMIn cxt diff --git a/primer/test/Tests/Question.hs b/primer/test/Tests/Question.hs index 95f7f8000..124b93ad4 100644 --- a/primer/test/Tests/Question.hs +++ b/primer/test/Tests/Question.hs @@ -139,11 +139,13 @@ nameSTE' = \case genSTE' :: Gen [STE'] genSTE' = let g = Gen.either_ genKind $ (,) <$> fmap forgetTypeIDs genType <*> Gen.bool - toSTE' n = \case + toSTE' m n = \case Left k -> TyVar (LocalName n, k) Right (ty, False) -> TmVar (LocalName n, ty) - Right (ty, True) -> Global (qualifyName n, ty) - in evalExprGen 0 $ Gen.list (Range.linear 0 20) $ toSTE' <$> genName <*> g + Right (ty, True) -> Global (qualifyName m n, ty) + in evalExprGen 0 $ Gen.list (Range.linear 0 20) $ toSTE' <$> genModuleName <*> genName <*> g + where + genModuleName = Gen.element ["M", "M1"] genSTE :: Gen ShadowedVarsExpr genSTE = deal . nubBy ((==) `on` nameSTE') <$> genSTE' diff --git a/primer/test/Tests/Serialization.hs b/primer/test/Tests/Serialization.hs index 75a4800f8..7ea85d7ca 100644 --- a/primer/test/Tests/Serialization.hs +++ b/primer/test/Tests/Serialization.hs @@ -32,6 +32,7 @@ import Primer.Core ( Expr, Expr' (EmptyHole, PrimCon), ExprMeta, + GlobalName (baseName), ID (..), Kind (KFun, KType), Meta (..), @@ -43,13 +44,14 @@ import Primer.Core ( TypeMeta, ValCon (..), ) -import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap) +import Primer.Module (Module (Module, moduleDefs, moduleTypes), mkTypeDefMap, moduleName) import Primer.Name (unsafeMkName) import Primer.Typecheck (SmartHoles (SmartHoles)) import System.FilePath (takeBaseName) import Test.Tasty import Test.Tasty.Golden import Test.Tasty.HUnit +import TestUtils (gvn, tcn, vcn) -- | Check that encoding the value produces the file. test_encode :: TestTree @@ -94,27 +96,28 @@ fixtures = log :: Log log = Log [[BodyAction [Move Child1]]] def :: ASTDef - def = ASTDef{astDefName = "main", astDefExpr = expr, astDefType = TEmptyHole typeMeta} + def = ASTDef{astDefName = gvn "M" "main", astDefExpr = expr, astDefType = TEmptyHole typeMeta} typeDef :: TypeDef typeDef = TypeDefAST ASTTypeDef - { astTypeDefName = "T" + { astTypeDefName = tcn "M" "T" , astTypeDefParameters = [("a", KType), ("b", KFun KType KType)] - , astTypeDefConstructors = [ValCon "C" [TApp () (TVar () "b") (TVar () "a"), TCon () tNat]] + , astTypeDefConstructors = [ValCon (vcn "M" "C") [TApp () (TVar () "b") (TVar () "a"), TCon () tNat]] , astTypeDefNameHints = [] } progerror :: ProgError progerror = NoDefSelected progaction :: ProgAction - progaction = MoveToDef "main" + progaction = MoveToDef $ gvn "M" "main" prog = Prog { progImports = mempty , progModule = Module - { moduleTypes = mkTypeDefMap [typeDef] - , moduleDefs = Map.singleton (astDefName def) (DefAST def) + { moduleName = "M" + , moduleTypes = mkTypeDefMap [typeDef] + , moduleDefs = Map.singleton (baseName $ astDefName def) (DefAST def) } , progSelection = Just selection , progSmartHoles = SmartHoles diff --git a/primer/test/Tests/Transform.hs b/primer/test/Tests/Transform.hs index 5c83246eb..506a51e2a 100644 --- a/primer/test/Tests/Transform.hs +++ b/primer/test/Tests/Transform.hs @@ -8,6 +8,7 @@ import Primer.Core import Primer.Core.DSL import Primer.Core.Transform import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) +import TestUtils (vcn) -- When renaming we have to be careful of binding sites. If we're renaming x to -- y and we encounter a binding site for a new variable v, then there are three @@ -78,15 +79,15 @@ unit_case_1 = "y" ( case_ (lvar "x") - [ branch "A" [("t", Nothing), ("u", Nothing)] (lvar "x") - , branch "B" [("v", Nothing), ("w", Nothing)] (lvar "x") + [ branch' ("M", "A") [("t", Nothing), ("u", Nothing)] (lvar "x") + , branch' ("M", "B") [("v", Nothing), ("w", Nothing)] (lvar "x") ] ) ( Just ( case_ (lvar "y") - [ branch "A" [("t", Nothing), ("u", Nothing)] (lvar "y") - , branch "B" [("v", Nothing), ("w", Nothing)] (lvar "y") + [ branch' ("M", "A") [("t", Nothing), ("u", Nothing)] (lvar "y") + , branch' ("M", "B") [("v", Nothing), ("w", Nothing)] (lvar "y") ] ) ) @@ -99,8 +100,8 @@ unit_case_2 = "y" ( case_ (lvar "x") - [ branch "A" [("t", Nothing), ("u", Nothing)] (lvar "x") - , branch "B" [("v", Nothing), ("y", Nothing)] (lvar "x") + [ branch' ("M", "A") [("t", Nothing), ("u", Nothing)] (lvar "x") + , branch' ("M", "B") [("v", Nothing), ("y", Nothing)] (lvar "x") ] ) Nothing @@ -114,15 +115,15 @@ unit_case_3 = "y" ( case_ (lvar "x") - [ branch "A" [("t", Nothing), ("u", Nothing)] (lvar "x") - , branch "B" [("x", Nothing), ("w", Nothing)] (lvar "x") + [ branch' ("M", "A") [("t", Nothing), ("u", Nothing)] (lvar "x") + , branch' ("M", "B") [("x", Nothing), ("w", Nothing)] (lvar "x") ] ) ( Just ( case_ (lvar "y") - [ branch "A" [("t", Nothing), ("u", Nothing)] (lvar "y") - , branch "B" [("x", Nothing), ("w", Nothing)] (lvar "x") + [ branch' ("M", "A") [("t", Nothing), ("u", Nothing)] (lvar "y") + , branch' ("M", "B") [("x", Nothing), ("w", Nothing)] (lvar "x") ] ) ) @@ -155,8 +156,8 @@ unit_case = "y" ( case_ (lvar "x") - [ branch "A" [("y", Nothing), ("z", Nothing)] (lvar "y") - , branch "B" [("u", Nothing), ("v", Nothing)] (lvar "u") + [ branch' ("M", "A") [("y", Nothing), ("z", Nothing)] (lvar "y") + , branch' ("M", "B") [("u", Nothing), ("v", Nothing)] (lvar "u") ] ) Nothing @@ -253,12 +254,12 @@ afterRename' rename clearMeta fromVar toVar input output = do unit_unfoldApp_1 :: Assertion unit_unfoldApp_1 = let expr :: Expr' () () - expr = App () (App () (App () (Con () "C") (Lam () "x" (v "x"))) (App () (v "w") (v "y"))) (v "z") + expr = App () (App () (App () (Con () $ vcn "M" "C") (Lam () "x" (v "x"))) (App () (v "w") (v "y"))) (v "z") v = Var () . LocalVarRef - in unfoldApp expr @?= (Con () "C", [Lam () "x" (v "x"), App () (v "w") (v "y"), v "z"]) + in unfoldApp expr @?= (Con () $ vcn "M" "C", [Lam () "x" (v "x"), App () (v "w") (v "y"), v "z"]) unit_unfoldApp_2 :: Assertion unit_unfoldApp_2 = let expr :: Expr' () () - expr = Con () "C" - in unfoldApp expr @?= (Con () "C", []) + expr = Con () $ vcn "M" "C" + in unfoldApp expr @?= (Con () $ vcn "M" "C", []) diff --git a/primer/test/Tests/Typecheck.hs b/primer/test/Tests/Typecheck.hs index a66a2e4bc..7fd5b1dfb 100644 --- a/primer/test/Tests/Typecheck.hs +++ b/primer/test/Tests/Typecheck.hs @@ -91,6 +91,7 @@ import Primer.Typecheck ( ) import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) import TestM (TestM, evalTestM) +import TestUtils (gvn, tcn, vcn) import Tests.Gen.Core.Typed unit_identity :: Assertion @@ -113,7 +114,9 @@ unit_true = expectTyped $ con cTrue unit_constructor_doesn't_exist :: Assertion unit_constructor_doesn't_exist = - con "Nope" `expectFailsWith` const (UnknownConstructor "Nope") + con nope `expectFailsWith` const (UnknownConstructor nope) + where + nope = vcn "M" "Nope" unit_inc :: Assertion unit_inc = @@ -211,9 +214,13 @@ unit_let_in_arg = unit_mkTAppCon :: Assertion unit_mkTAppCon = do - mkTAppCon "C" [] @?= TCon () "C" - mkTAppCon "C" [TCon () "X"] @?= TApp () (TCon () "C") (TCon () "X") - mkTAppCon "C" [TCon () "X", TCon () "Y"] @?= TApp () (TApp () (TCon () "C") (TCon () "X")) (TCon () "Y") + mkTAppCon c [] @?= TCon () c + mkTAppCon c [TCon () x] @?= TApp () (TCon () c) (TCon () x) + mkTAppCon c [TCon () x, TCon () y] @?= TApp () (TApp () (TCon () c) (TCon () x)) (TCon () y) + where + c = tcn "M1" "C" + x = tcn "M2" "X" + y = tcn "M2" "Y" -- Note [cover] -- We disable coverage checking as it causes spurious hydra failures which are @@ -289,7 +296,9 @@ unit_case_badType = -- Cannot annotate something with a non-existent type constructor unit_ann_bad :: Assertion unit_ann_bad = - ann emptyHole (tcon "IDoNotExist") `expectFailsWith` const (UnknownTypeConstructor "IDoNotExist") + ann emptyHole (tcon nonexistant) `expectFailsWith` const (UnknownTypeConstructor nonexistant) + where + nonexistant = tcn "M" "IDoNotExist" unit_ann_insert :: Assertion unit_ann_insert = @@ -318,12 +327,12 @@ unit_check_emb = unit_case_scrutinee :: Assertion unit_case_scrutinee = - ann (case_ (con cSucc) [branch "C" [] $ lvar "x"]) (tcon tBool) + ann (case_ (con cSucc) [branch' ("M", "C") [] $ lvar "x"]) (tcon tBool) `smartSynthGives` ann (case_ (hole $ con cSucc) []) (tcon tBool) unit_case_branches :: Assertion unit_case_branches = - ann (case_ (con cZero) [branch "C" [] $ lvar "x"]) (tcon tBool) + ann (case_ (con cZero) [branch' ("M", "C") [] $ lvar "x"]) (tcon tBool) `smartSynthGives` ann (case_ (con cZero) [branch cZero [] emptyHole, branch cSucc [("a7", Nothing)] emptyHole]) (tcon tBool) -- Fragile name here "a7" unit_remove_hole :: Assertion @@ -527,35 +536,48 @@ unit_good_maybeT = case runTypecheckTestM NoSmartHoles $ NoSmartHoles CheckEverything { trusted = [builtinModule] - , toCheck = [Module (mkTypeDefMap [TypeDefAST maybeTDef]) mempty] + , toCheck = [Module "TestModule" (mkTypeDefMap [TypeDefAST maybeTDef]) mempty] } of Left err -> assertFailure $ show err Right _ -> pure () -unit_bad_prim_map :: Assertion -unit_bad_prim_map = case runTypecheckTestM NoSmartHoles $ do +unit_bad_prim_map_base :: Assertion +unit_bad_prim_map_base = case runTypecheckTestM NoSmartHoles $ do + fooType <- tcon tNat + let foo = PrimDef{primDefName = gvn "M" "bar", primDefType = fooType} + checkEverything + NoSmartHoles + CheckEverything + { trusted = [progModule newProg] + , toCheck = [Module "M" mempty $ Map.singleton "foo" $ DefPrim foo] + } of + Left err -> err @?= InternalError "Inconsistant names in moduleDefs map for module M" + Right _ -> assertFailure "Expected failure but succeeded" + +unit_bad_prim_map_module :: Assertion +unit_bad_prim_map_module = case runTypecheckTestM NoSmartHoles $ do fooType <- tcon tNat - let foo = PrimDef{primDefName = "bar", primDefType = fooType} + let foo = PrimDef{primDefName = gvn "OtherMod" "foo", primDefType = fooType} checkEverything NoSmartHoles CheckEverything { trusted = [progModule newProg] - , toCheck = [Module mempty $ Map.singleton "foo" $ DefPrim foo] + , toCheck = [Module "M" mempty $ Map.singleton "foo" $ DefPrim foo] } of - Left err -> err @?= InternalError "Inconsistant names in moduleDefs map" + Left err -> err @?= InternalError "Inconsistant names in moduleDefs map for module M" Right _ -> assertFailure "Expected failure but succeeded" unit_bad_prim_type :: Assertion unit_bad_prim_type = case runTypecheckTestM NoSmartHoles $ do - fooType <- tcon "NonExistant" - let foo = PrimDef{primDefName = "foo", primDefType = fooType} + fooType <- tcon' "M" "NonExistant" + let foo = PrimDef{primDefName = gvn "M" "foo", primDefType = fooType} checkEverything NoSmartHoles CheckEverything { trusted = [progModule newProg] - , toCheck = [Module mempty $ Map.singleton "foo" $ DefPrim foo] + , toCheck = [Module "M" mempty $ Map.singleton "foo" $ DefPrim foo] } of - Left err -> err @?= UnknownTypeConstructor "NonExistant" + Left err -> err @?= UnknownTypeConstructor (tcn "M" "NonExistant") Right _ -> assertFailure "Expected failure but succeeded" -- * Helpers @@ -650,18 +672,19 @@ runTypecheckTestMWithPrims sh = testModule :: Module testModule = Module - { moduleTypes = mkTypeDefMap [TypeDefAST maybeTDef] + { moduleName = "TestModule" + , moduleTypes = mkTypeDefMap [TypeDefAST maybeTDef] , moduleDefs = mempty } tMaybeT :: TyConName -tMaybeT = "MaybeT" +tMaybeT = tcn "TestModule" "MaybeT" maybeTDef :: ASTTypeDef maybeTDef = ASTTypeDef { astTypeDefName = tMaybeT , astTypeDefParameters = [("m", KFun KType KType), ("a", KType)] - , astTypeDefConstructors = [ValCon "MakeMaybeT" [TApp () (TVar () "m") (TApp () (TCon () tMaybe) (TVar () "a"))]] + , astTypeDefConstructors = [ValCon (vcn "TestModule" "MakeMaybeT") [TApp () (TVar () "m") (TApp () (TCon () tMaybe) (TVar () "a"))]] , astTypeDefNameHints = [] } diff --git a/primer/test/Tests/Unification.hs b/primer/test/Tests/Unification.hs index 94d83461e..87cfe7c07 100644 --- a/primer/test/Tests/Unification.hs +++ b/primer/test/Tests/Unification.hs @@ -33,7 +33,14 @@ import Hedgehog ( import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Primer.Builtins (builtinModule, tList, tNat) -import Primer.Core (ID, Kind (KFun, KHole, KType), TyVarName, Type' (TApp, TCon, TEmptyHole, TForall, TFun, THole, TVar)) +import Primer.Core ( + ASTTypeDef (ASTTypeDef, astTypeDefConstructors, astTypeDefName, astTypeDefNameHints, astTypeDefParameters), + ID, + Kind (KFun, KHole, KType), + TyVarName, + Type' (TApp, TCon, TEmptyHole, TForall, TFun, THole, TVar), + TypeDef (TypeDefAST), + ) import Primer.Core.Utils (forgetTypeIDs, freeVarsTy, generateTypeIDs) import Primer.Module (Module) import Primer.Name (NameCounter) @@ -47,10 +54,12 @@ import Primer.Typecheck ( consistentTypes, extendLocalCxt, extendLocalCxtTy, + extendTypeDefCxt, ) import Primer.Unification (unify) import Test.Tasty.HUnit (Assertion, assertBool, (@?=)) import TestM (evalTestM) +import TestUtils (tcn) import Tests.Gen.Core.Typed ( checkKindTest, checkValidContextTest, @@ -86,6 +95,27 @@ unit_Int_refl = ) @?= Just mempty +unit_diff_module_not_refl :: Assertion +unit_diff_module_not_refl = + evalTestM + 0 + ( unify' + (extendTypeDefCxt [mint] defaultCxt) + mempty + (TCon () tInt) + (TCon () $ tcn "M" "Int") + ) + @?= Nothing + where + mint = + TypeDefAST $ + ASTTypeDef + { astTypeDefName = tcn "M" "Int" + , astTypeDefParameters = mempty + , astTypeDefConstructors = mempty + , astTypeDefNameHints = mempty + } + -- unify [...,a:*] [] a a = Just [] unit_a_refl :: Assertion unit_a_refl = diff --git a/primer/test/outputs/serialization/def.json b/primer/test/outputs/serialization/def.json index 677035463..b1aa0d01f 100644 --- a/primer/test/outputs/serialization/def.json +++ b/primer/test/outputs/serialization/def.json @@ -13,7 +13,10 @@ ], "tag": "EmptyHole" }, - "astDefName": "main", + "astDefName": { + "baseName": "main", + "qualifiedModule": "M" + }, "astDefType": { "contents": [ 0, diff --git a/primer/test/outputs/serialization/edit_response_2.json b/primer/test/outputs/serialization/edit_response_2.json index 9936c2986..e3f51e522 100644 --- a/primer/test/outputs/serialization/edit_response_2.json +++ b/primer/test/outputs/serialization/edit_response_2.json @@ -36,7 +36,10 @@ ], "tag": "EmptyHole" }, - "astDefName": "main", + "astDefName": { + "baseName": "main", + "qualifiedModule": "M" + }, "astDefType": { "contents": [ 0, @@ -51,6 +54,7 @@ "tag": "DefAST" } }, + "moduleName": "M", "moduleTypes": { "T": { "contents": { @@ -80,15 +84,24 @@ { "contents": [ [], - "Nat" + { + "baseName": "Nat", + "qualifiedModule": "Builtins" + } ], "tag": "TCon" } ], - "valConName": "C" + "valConName": { + "baseName": "C", + "qualifiedModule": "M" + } } ], - "astTypeDefName": "T", + "astTypeDefName": { + "baseName": "T", + "qualifiedModule": "M" + }, "astTypeDefNameHints": [], "astTypeDefParameters": [ [ @@ -118,7 +131,10 @@ } }, "progSelection": { - "selectedDef": "main", + "selectedDef": { + "baseName": "main", + "qualifiedModule": "M" + }, "selectedNode": { "meta": { "Left": [ diff --git a/primer/test/outputs/serialization/prog.json b/primer/test/outputs/serialization/prog.json index 6ee4f26c5..244cca776 100644 --- a/primer/test/outputs/serialization/prog.json +++ b/primer/test/outputs/serialization/prog.json @@ -35,7 +35,10 @@ ], "tag": "EmptyHole" }, - "astDefName": "main", + "astDefName": { + "baseName": "main", + "qualifiedModule": "M" + }, "astDefType": { "contents": [ 0, @@ -50,6 +53,7 @@ "tag": "DefAST" } }, + "moduleName": "M", "moduleTypes": { "T": { "contents": { @@ -79,15 +83,24 @@ { "contents": [ [], - "Nat" + { + "baseName": "Nat", + "qualifiedModule": "Builtins" + } ], "tag": "TCon" } ], - "valConName": "C" + "valConName": { + "baseName": "C", + "qualifiedModule": "M" + } } ], - "astTypeDefName": "T", + "astTypeDefName": { + "baseName": "T", + "qualifiedModule": "M" + }, "astTypeDefNameHints": [], "astTypeDefParameters": [ [ @@ -117,7 +130,10 @@ } }, "progSelection": { - "selectedDef": "main", + "selectedDef": { + "baseName": "main", + "qualifiedModule": "M" + }, "selectedNode": { "meta": { "Left": [ diff --git a/primer/test/outputs/serialization/progaction.json b/primer/test/outputs/serialization/progaction.json index c84b5a70e..5eb0e1139 100644 --- a/primer/test/outputs/serialization/progaction.json +++ b/primer/test/outputs/serialization/progaction.json @@ -1,4 +1,7 @@ { - "contents": "main", + "contents": { + "baseName": "main", + "qualifiedModule": "M" + }, "tag": "MoveToDef" } \ No newline at end of file diff --git a/primer/test/outputs/serialization/selection.json b/primer/test/outputs/serialization/selection.json index 597a7cade..107a95980 100644 --- a/primer/test/outputs/serialization/selection.json +++ b/primer/test/outputs/serialization/selection.json @@ -1,5 +1,8 @@ { - "selectedDef": "main", + "selectedDef": { + "baseName": "main", + "qualifiedModule": "M" + }, "selectedNode": { "meta": { "Left": [ diff --git a/primer/test/outputs/serialization/typeDef.json b/primer/test/outputs/serialization/typeDef.json index 3399e62f1..4d7f83851 100644 --- a/primer/test/outputs/serialization/typeDef.json +++ b/primer/test/outputs/serialization/typeDef.json @@ -26,15 +26,24 @@ { "contents": [ [], - "Nat" + { + "baseName": "Nat", + "qualifiedModule": "Builtins" + } ], "tag": "TCon" } ], - "valConName": "C" + "valConName": { + "baseName": "C", + "qualifiedModule": "M" + } } ], - "astTypeDefName": "T", + "astTypeDefName": { + "baseName": "T", + "qualifiedModule": "M" + }, "astTypeDefNameHints": [], "astTypeDefParameters": [ [ From 40fc654fa2191e0c85a3eb9d984f7991cef49562 Mon Sep 17 00:00:00 2001 From: Ben Price Date: Tue, 12 Apr 2022 15:36:15 +0100 Subject: [PATCH 8/8] refactor: use Uniplate for renameMod test utility --- primer/src/Primer/Core.hs | 14 +++++----- primer/src/Primer/Module.hs | 3 ++- primer/test/Tests/Action/Prog.hs | 46 +++++++++++++------------------- 3 files changed, 27 insertions(+), 36 deletions(-) diff --git a/primer/src/Primer/Core.hs b/primer/src/Primer/Core.hs index 932e742e5..fecb31d5c 100644 --- a/primer/src/Primer/Core.hs +++ b/primer/src/Primer/Core.hs @@ -449,7 +449,7 @@ instance HasMetadata (Bind' ExprMeta) where data Def = DefPrim PrimDef | DefAST ASTDef - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON Def -- | A primitive, built-in definition @@ -458,7 +458,7 @@ data PrimDef = PrimDef -- ^ Used for display, and to link to an entry in `allPrimDefs` , primDefType :: Type } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON PrimDef -- | A top-level definition, built from an 'Expr' @@ -467,7 +467,7 @@ data ASTDef = ASTDef , astDefExpr :: Expr , astDefType :: Type } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON ASTDef defName :: Def -> GVarName @@ -532,7 +532,7 @@ data PrimFunError data TypeDef = TypeDefPrim PrimTypeDef | TypeDefAST ASTTypeDef - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON TypeDef -- | Definition of a primitive data type @@ -541,7 +541,7 @@ data PrimTypeDef = PrimTypeDef , primTypeDefParameters :: [Kind] , primTypeDefNameHints :: [Name] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON PrimTypeDef -- | Definition of an algebraic data type @@ -555,14 +555,14 @@ data ASTTypeDef = ASTTypeDef , astTypeDefConstructors :: [ValCon] , astTypeDefNameHints :: [Name] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON ASTTypeDef data ValCon = ValCon { valConName :: ValConName , valConArgs :: [Type' ()] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON ValCon valConType :: ASTTypeDef -> ValCon -> Type' () diff --git a/primer/src/Primer/Module.hs b/primer/src/Primer/Module.hs index 027458309..6ee87d80d 100644 --- a/primer/src/Primer/Module.hs +++ b/primer/src/Primer/Module.hs @@ -9,6 +9,7 @@ module Primer.Module ( deleteDef, ) where +import Data.Data (Data) import Data.Map (delete, insert, mapKeys, member) import qualified Data.Map as M import Foreword @@ -34,7 +35,7 @@ data Module = Module moduleTypes :: Map Name TypeDef , moduleDefs :: Map Name Def -- The current program: a set of definitions indexed by Name } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Data, Generic) deriving (FromJSON, ToJSON) via VJSON Module -- | Create a mapping of name to typedef for use in modules. diff --git a/primer/test/Tests/Action/Prog.hs b/primer/test/Tests/Action/Prog.hs index fa3a22542..2a75d438a 100644 --- a/primer/test/Tests/Action/Prog.hs +++ b/primer/test/Tests/Action/Prog.hs @@ -58,8 +58,6 @@ import Primer.Core ( Kind (KType), Meta (..), ModuleName, - PrimDef (primDefName, primDefType), - PrimTypeDef (primTypeDefName), TmVarRef (..), TyConName, Type, @@ -1122,39 +1120,31 @@ defaultFullProg = do p & #progModule % #moduleTypes %~ (mkTypeDefMap renamedTypes <>) & #progModule % #moduleDefs %~ (renamedDefs <>) where - -- TODO: can we use uniplate and write something like `transformBi rnName`? - -- (This will require data instances for Def etc) - -- However we should be careful as ModuleName = Name, and we don't want to - -- transform Names inside LocalName etc! renameMod :: ModuleName -> ModuleName -> [Module] -> [Module] -- Caution: if we expose something similar as an action, we would need a -- test for duplicate module names similar to this for safety, but that -- would get in the way for our testing purposes here. -- | any ((== to).moduleName) mods = error "clashing name" - renameMod fromName toName = map rn1 + renameMod fromName toName = map rnMod where - rn1 (m :: Module) = - m & #moduleName %~ rnName - & #moduleTypes % mapped %~ rnTyDef - & #moduleDefs % mapped %~ rnDef + rnMod (m :: Module) = + transformBi rnRef1 $ + transformBi rnRef2 $ + transformBi rnRef3 $ + over #moduleName rnName m rnName n = if n == fromName then toName else n - rnTyDef (TypeDefPrim td) = TypeDefPrim $ td & #primTypeDefName % #qualifiedModule %~ rnName - rnTyDef (TypeDefAST td) = - TypeDefAST $ - td & #astTypeDefName % #qualifiedModule %~ rnName - & #astTypeDefConstructors % mapped %~ rnVC - rnVC vc = - vc & #valConName % #qualifiedModule %~ rnName - & #valConArgs % mapped %~ transformBi rnName - rnDef (DefPrim d) = - DefPrim $ - d & #primDefName % #qualifiedModule %~ rnName - & #primDefType %~ transformBi rnName - rnDef (DefAST d) = - DefAST $ - d & #astDefName % #qualifiedModule %~ rnName - & #astDefExpr %~ transformBi rnName - & #astDefType %~ transformBi rnName + -- We have to be careful here, as ModuleName = Name, and we don't want + -- to transform Names inside LocalName etc! + -- TODO: perhaps ModuleName should be its own type? + -- Annoyingly we cannot do this in one pass of transformBi, as it cannot + -- take a function of type GlobalName k -> GlobalName k and act on all + -- instances of k at once. + rnRef1 :: GVarName -> GVarName + rnRef1 qn = qn & #qualifiedModule %~ rnName + rnRef2 :: TyConName -> TyConName + rnRef2 qn = qn & #qualifiedModule %~ rnName + rnRef3 :: ValConName -> ValConName + rnRef3 qn = qn & #qualifiedModule %~ rnName findTypeDef :: TyConName -> Prog -> IO ASTTypeDef findTypeDef d p = maybe (assertFailure "couldn't find typedef") pure $ (typeDefAST <=< Map.lookup d) $ p ^. (#progModule % to moduleTypesQualified)