feat: wildcards (#1049)

primer-service/test/outputs/OpenAPI/openapi.json

@@ -193,6 +193,12 @@
                     "MakeLetRec",
                     "MakeLam",
                     "MakeLAM",
+                    "AddBranch",
+                    "AddBranchInt",
+                    "AddBranchChar",
+                    "DeleteBranch",
+                    "DeleteBranchInt",
+                    "DeleteBranchChar",
                     "RenamePattern",
                     "RenameLet",
                     "RenameLam",
@@ -401,13 +407,15 @@
                     "TEmptyHole",
                     "THole",
                     "TFun",
-                    "TApp"
+                    "TApp",
+                    "PatternWildcard"
                 ],
                 "type": "string"
             },
             "NodeFlavorPrimBody": {
                 "enum": [
-                    "PrimCon"
+                    "PrimCon",
+                    "PrimPattern"
                 ],
                 "type": "string"
             },
@@ -1251,6 +1259,12 @@
                                 "MakeLetRec",
                                 "MakeLam",
                                 "MakeLAM",
+                                "AddBranch",
+                                "AddBranchInt",
+                                "AddBranchChar",
+                                "DeleteBranch",
+                                "DeleteBranchInt",
+                                "DeleteBranchChar",
                                 "RenamePattern",
                                 "RenameLet",
                                 "RenameLam",

primer/gen/Primer/Gen/Core/Raw.hs

@@ -29,6 +29,7 @@ import Hedgehog.Range qualified as Range
 import Primer.Core (
   Bind' (Bind),
   CaseBranch' (CaseBranch),
+  CaseFallback' (CaseExhaustive, CaseFallback),
   Expr,
   Expr' (..),
   GVarName,
@@ -38,6 +39,7 @@ import Primer.Core (
   LocalName (LocalName),
   Meta (..),
   ModuleName (ModuleName),
+  Pattern (PatCon, PatPrim),
   PrimCon (..),
   TmVarRef (..),
   TyConName,
@@ -135,21 +137,27 @@ genLetrec :: ExprGen Expr
 genLetrec = Letrec <$> genMeta <*> genLVarName <*> genExpr <*> genType <*> genExpr
 
 genCase :: ExprGen Expr
-genCase = Case <$> genMeta <*> genExpr <*> Gen.list (Range.linear 0 5) genBranch
+genCase = Case <$> genMeta <*> genExpr <*> Gen.list (Range.linear 0 5) genBranch <*> Gen.choice [pure CaseExhaustive, CaseFallback <$> genExpr]
   where
-    genBranch = CaseBranch <$> genValConName <*> Gen.list (Range.linear 0 5) genBind <*> genExpr
+    genBranch = CaseBranch <$> genScrut <*> Gen.list (Range.linear 0 5) genBind <*> genExpr
+    genScrut =
+      Gen.choice
+        [ PatCon <$> genValConName
+        , PatPrim <$> genPrimCon
+        ]
     genBind = Bind <$> genMeta <*> genLVarName
 
 genPrim :: ExprGen Expr
 genPrim = PrimCon <$> genMeta <*> genPrimCon
+
+genPrimCon :: MonadGen m => m PrimCon
+genPrimCon =
+  Gen.choice
+    [ PrimChar <$> Gen.unicodeAll
+    , PrimInt <$> Gen.integral (Range.linear (-intBound) intBound)
+    ]
   where
     intBound = fromIntegral (maxBound :: Word64) -- arbitrary
-    genPrimCon :: (StateT ID Gen PrimCon)
-    genPrimCon =
-      Gen.choice
-        [ PrimChar <$> Gen.unicodeAll
-        , PrimInt <$> Gen.integral (Range.linear (-intBound) intBound)
-        ]
     -- This ensures that when we modify the constructors of `PrimCon` (i.e. we add/remove primitive types),
     -- we are alerted that we need to update this generator.
     _ = \case

primer/gen/Primer/Gen/Core/Typed.hs

@@ -35,6 +35,7 @@ import Foreword hiding (mod)
 import Control.Monad.Fresh (MonadFresh, fresh)
 import Control.Monad.Morph (hoist)
 import Control.Monad.Reader (mapReaderT)
+import Data.List.Extra (nubSortOn)
 import Data.Map qualified as M
 import Hedgehog (
   GenT,
@@ -47,6 +48,7 @@ import Hedgehog.Range qualified as Range
 import Primer.Core (
   Bind' (Bind),
   CaseBranch' (CaseBranch),
+  CaseFallback' (..),
   Expr' (..),
   GVarName,
   GlobalName (qualifiedModule),
@@ -55,6 +57,7 @@ import Primer.Core (
   LVarName,
   LocalName (LocalName, unLocalName),
   ModuleName (),
+  Pattern (PatCon, PatPrim),
   PrimCon (..),
   TmVarRef (..),
   TyConName,
@@ -436,24 +439,59 @@ genChk ty = do
             -}
         ]
     case_ :: WT (Maybe (GenT WT ExprG))
-    case_ =
+    case_ = (\ca cp -> Gen.frequency [(5, ca), (1, cp)]) <<$>> caseADT <<*>> casePrim
+    caseADT :: WT (Maybe (GenT WT ExprG))
+    caseADT =
       asks (M.assocs . typeDefs) <&> \adts ->
         if null adts
           then Nothing
           else Just $ do
             (tc, td) <- Gen.element adts
             let t = mkTAppCon tc (TEmptyHole () <$ typeDefParameters td)
-            (e, brs) <- Gen.justT $ do
+            (e, (brs, fb)) <- Gen.justT $ do
               (e, eTy) <- genSyns t -- NB: this could return something only consistent with t, e.g. if t=List ?, could get eT=? Nat
               vcs' <- instantiateValCons eTy
               fmap (e,) <$> case vcs' of
-                Left TDIHoleType -> pure $ Just []
+                Left TDIHoleType -> pure $ Just ([], CaseExhaustive)
                 Left _err -> pure Nothing -- if we didn't get an instance of t, try again; TODO: this is rather inefficient, and discards a lot...
-                Right (_, _, vcs) -> fmap Just . for vcs $ \(c, params) -> do
-                  ns <- for params $ \nt -> (,nt) <$> genLVarNameAvoiding [ty, nt]
-                  let binds = map (Bind () . fst) ns
-                  CaseBranch c binds <$> local (extendLocalCxts ns) (genChk ty)
-            pure $ Case () e brs
+                Right (_, _, allVcs) -> case nonEmpty allVcs of
+                  Nothing -> pure $ Just ([], CaseExhaustive)
+                  Just allVcs' -> do
+                    (vcs, fb) <-
+                      Gen.frequency
+                        [ (3, pure (allVcs, CaseExhaustive))
+                        , (1, (,) <$> genStrictSubsequence allVcs' <*> fmap CaseFallback (genChk ty))
+                        ]
+                    fmap (Just . (,fb)) . for vcs $ \(c, params) -> do
+                      ns <- for params $ \nt -> (,nt) <$> genLVarNameAvoiding [ty, nt]
+                      let binds = map (Bind () . fst) ns
+                      CaseBranch (PatCon c) binds <$> local (extendLocalCxts ns) (genChk ty)
+            pure $ Case () e brs fb
+    casePrim :: WT (Maybe (GenT WT ExprG))
+    casePrim = do
+      primGens <- genPrimCon
+      pure $
+        if null primGens
+          then Nothing
+          else Just $ do
+            (pg, scrutTy0) <- Gen.element primGens
+            let scrutTy = TCon () scrutTy0
+            (e0, scrutTy') <- genSyns scrutTy
+            let e = if scrutTy == scrutTy' then e0 else Ann () e0 scrutTy
+            brs0 <- Gen.list (Range.linear 0 5) $ do
+              p <- pg
+              (p,) . CaseBranch (PatPrim p) [] <$> genChk ty
+            let brs = nubSortOn ((\case PrimInt n -> Left n; PrimChar c -> Right c) . fst) brs0
+            fb <- genChk ty
+            pure $ Case () e (snd <$> brs) (CaseFallback fb)
+
+genStrictSubsequence :: MonadGen m => NonEmpty a -> m [a]
+genStrictSubsequence xs = Gen.justT $ do
+  s <- Gen.subsequence $ toList xs
+  pure $
+    if length s == length xs
+      then Nothing
+      else Just s
 
 -- | Generates types which infer kinds consistent with the argument
 -- I.e. @genWTType k@ will generate types @ty@ such that @synthKind ty = k'@

primer/primer.cabal

@@ -163,6 +163,7 @@ library primer-hedgehog
   build-depends:
     , base
     , containers
+    , extra
     , hedgehog        ^>=1.1
     , mmorph          ^>=1.2.0
     , mtl

primer/src/Primer/API.hs

@@ -143,6 +143,7 @@ import Primer.App.Base (TypeDefNodeSelection (..))
 import Primer.Core (
   Bind' (..),
   CaseBranch' (..),
+  CaseFallback' (CaseExhaustive, CaseFallback),
   Expr,
   Expr' (..),
   GVarName,
@@ -167,7 +168,7 @@ import Primer.Core (
   _typeMetaLens,
  )
 import Primer.Core.DSL qualified as DSL
-import Primer.Core.Meta (LocalName)
+import Primer.Core.Meta (LocalName, Pattern (PatCon, PatPrim))
 import Primer.Core.Meta qualified as Core
 import Primer.Database (
   OffsetLimit,
@@ -822,7 +823,7 @@ viewTreeExpr e0 = case e0 of
       , childTrees = [viewTreeExpr e1, viewTreeType t, viewTreeExpr e2]
       , rightChild = Nothing
       }
-  Case _ e bs ->
+  Case _ e bs fb ->
     Tree
       { nodeId
       , body = NoBody Flavor.Case
@@ -837,10 +838,10 @@ viewTreeExpr e0 = case e0 of
           --  which should only happen when matching on `Void`
           ifoldr
             (\i b next -> Just $ (viewCaseBranch i b){rightChild = next})
-            Nothing
+            viewFallback
             bs
         )
-      viewCaseBranch i (CaseBranch con binds rhs) =
+      viewCaseBranch i (CaseBranch p binds rhs) =
         let
           -- these IDs will not clash with any others in the tree,
           -- since node IDs in the input expression are unique,
@@ -854,7 +855,7 @@ viewTreeExpr e0 = case e0 of
                 BoxBody . RecordPair Flavor.Pattern $
                   ( Tree
                       { nodeId = patternRootId
-                      , body = TextBody $ RecordPair Flavor.PatternCon $ globalName con
+                      , body = pat p
                       , childTrees =
                           map
                             ( \(Bind m v) ->
@@ -872,6 +873,34 @@ viewTreeExpr e0 = case e0 of
             , childTrees = [viewTreeExpr rhs]
             , rightChild = Nothing
             }
+      viewFallback = case fb of
+        CaseExhaustive -> Nothing
+        CaseFallback rhs ->
+          let
+            -- these IDs will not clash with any others in the tree,
+            -- since node IDs in the input expression are unique,
+            -- and don't contain non-numerical characters
+            boxId = nodeId <> "Pwild"
+            patternRootId = boxId <> "B"
+           in
+            Just $
+              Tree
+                { nodeId = boxId
+                , body =
+                    BoxBody . RecordPair Flavor.Pattern $
+                      ( Tree
+                          { nodeId = patternRootId
+                          , body = NoBody Flavor.PatternWildcard
+                          , childTrees = []
+                          , rightChild = Nothing
+                          }
+                      )
+                , childTrees = [viewTreeExpr rhs]
+                , rightChild = Nothing
+                }
+      pat = \case
+        PatCon n -> TextBody $ RecordPair Flavor.PatternCon $ globalName n
+        PatPrim pc -> PrimBody $ RecordPair Flavor.PrimPattern pc
   PrimCon _ pc ->
     Tree
       { nodeId

primer/src/Primer/API/NodeFlavor.hs

@@ -40,6 +40,7 @@ data NodeFlavorTextBody
 
 data NodeFlavorPrimBody
   = PrimCon
+  | PrimPattern
   deriving stock (Show, Read, Eq, Generic, Enum, Bounded)
   deriving (ToJSON, FromJSON) via CustomJSON '[TagSingleConstructors] NodeFlavorPrimBody
   deriving anyclass (NFData)
@@ -62,6 +63,7 @@ data NodeFlavorNoBody
   | THole
   | TFun
   | TApp
+  | PatternWildcard
   deriving stock (Show, Read, Eq, Generic, Enum, Bounded)
   deriving (ToJSON, FromJSON) via PrimerJSON NodeFlavorNoBody
   deriving anyclass (NFData)