Classify constructors, only dump modules if they successfully compile

src/Lib/CompileExp.newt

@@ -62,7 +62,7 @@ arityForName fc nm = do
     Nothing => error fc "Name \{show nm} not in scope"
     (Just Axiom) => pure Z
     (Just (TCon arity strs)) => pure $ cast arity
-    (Just (DCon k str)) => pure $ cast k
+    (Just (DCon _ k str)) => pure $ cast k
     (Just (Fn t)) => pure $ lamArity t
     (Just (PrimTCon arity)) => pure $ cast arity
     (Just (PrimFn t arity used)) => pure arity
@@ -148,17 +148,17 @@ compileFun tm = go tm Lin
     go tm args = CFun (args <>> Nil) <$> compileTerm tm
 
 -- What are the Defs used for above? (Arity for name)
-compileDCon : QName → Int → CExp
-compileDCon (QN _ nm) 0 = CConstr nm Nil
-compileDCon (QN _ nm) arity =
+compileDCon : QName → ConInfo → Int → CExp
+compileDCon (QN _ nm) info 0 = CConstr nm Nil
+compileDCon (QN _ nm) info arity =
   let args = map (\k => "h\{show k}") (range 0 arity) in
   CFun args $ CConstr nm $ map (\k => CBnd $ arity - k - 1) (range 0 arity)
 
 -- probably want to drop the Ref2 when we can
 defToCExp : {{Ref2 Defs St}} → (QName × Def) -> M (QName × CExp)
 defToCExp (qn, Axiom)          = pure $ (qn, CErased)
-defToCExp (qn, DCon arity _)   = pure $ (qn, compileDCon qn arity)
-defToCExp (qn, TCon arity _)   = pure $ (qn, compileDCon qn arity)
-defToCExp (qn, PrimTCon arity) = pure $ (qn, compileDCon qn arity)
+defToCExp (qn, DCon info arity _)   = pure $ (qn, compileDCon qn info arity)
+defToCExp (qn, TCon arity _)   = pure $ (qn, compileDCon qn NormalCon arity)
+defToCExp (qn, PrimTCon arity) = pure $ (qn, compileDCon qn NormalCon arity)
 defToCExp (qn, PrimFn src _ deps) = pure $ (qn, CRaw src deps)
 defToCExp (qn, Fn tm)          = (_,_ qn) <$> compileFun tm

src/Lib/Elab.newt

@@ -694,7 +694,7 @@ getConstructors ctx scfc (VRef fc nm _) = do
     lookupDCon nm = do
       top <- getTop
       case lookup nm top of
-        (Just (MkEntry _ name type (DCon k str))) => pure (name, k, type)
+        (Just (MkEntry _ name type (DCon _ k str))) => pure (name, k, type)
         Just _ => error fc "Internal Error: \{show nm} is not a DCon"
         Nothing => error fc "Internal Error: DCon \{show nm} not found"
 getConstructors ctx scfc tm = do
@@ -946,7 +946,7 @@ buildCase ctx prob scnm scty (dcName, arity, ty) = do
               -- TODO can we check this when we make the PatCon?
               top <- getTop
               case lookup nm top of
-                  (Just (MkEntry _ name type (DCon k tcname))) =>
+                  (Just (MkEntry _ name type (DCon _ k tcname))) =>
                     if (tcname /= sctynm)
                       then error fc "Constructor is \{show tcname} expected \{show sctynm}"
                       else pure Nothing
@@ -974,7 +974,7 @@ mkPat (tm, icit) = do
   top <- getTop
   case splitArgs tm Nil of
     ((RVar fc nm), b) => case lookupRaw nm top of
-                (Just (MkEntry _ name type (DCon k str))) => do
+                (Just (MkEntry _ name type (DCon _ k str))) => do
                   -- TODO check arity, also figure out why we need reverse
                   bpat <- traverse (mkPat) b
                   pure $ PatCon fc icit name bpat Nothing

src/Lib/Eval.newt

@@ -112,7 +112,7 @@ evalCase env mode sc@(VRef _ nm sp) (cc@(CaseCons name nms t) :: xs) = do
       debug $ \ _ =>  "ECase \{show nm} \{show sp} \{show nms} \{showTm t}"
       go env (sp <>> Nil) nms
     else case lookup nm top of
-      (Just (MkEntry _ str type (DCon k str1))) => evalCase env mode sc xs
+      (Just (MkEntry _ str type (DCon _ k str1))) => evalCase env mode sc xs
       -- bail for a stuck function
       _ => pure Nothing
   where

src/Lib/ProcessDecl.newt

@@ -274,7 +274,7 @@ processInstance ns instfc ty decls = do
     | _ => error tyFC "\{show tconName} is not a type constructor"
   let (con :: Nil) = cons
     | _ => error tyFC "\{show tconName} has multiple constructors \{show cons}"
-  let (Just (MkEntry _ _ dcty (DCon _ _))) = lookup con top
+  let (Just (MkEntry _ _ dcty (DCon _ _ _))) = lookup con top
     | _ => error tyFC "can't find constructor \{show con}"
   vdcty@(VPi _ nm icit rig a b) <- eval Nil CBN dcty
     | x => error (getFC x) "dcty not Pi"
@@ -377,6 +377,32 @@ processShortData ns fc lhs sigs = do
     mkDecl args acc (RApp fc' t u icit) = mkDecl args (u :: acc) t
     mkDecl args acc tm = error (getFC tm) "Expected contructor application, got: \{show tm}"
 
+-- Identify Nat-like, enum-like, etc
+populateConInfo : List TopEntry → List TopEntry
+populateConInfo entries =
+  let (Nothing) = traverse checkEnum entries
+    | Just entries => entries in
+  let (a :: b :: Nil) = entries | _ => entries in
+  let (Just succ) = find isSucc entries | _ => entries in
+  let (Just zero) = find isZero entries | _ => entries in
+  setInfo zero ZeroCon :: setInfo succ SuccCon :: Nil
+  where
+    setInfo : TopEntry → ConInfo → TopEntry
+    setInfo (MkEntry fc nm dty (DCon _ arity hn)) info = MkEntry fc nm dty (DCon info arity hn)
+    setInfo x _ = x
+
+    checkEnum : TopEntry → Maybe TopEntry
+    checkEnum (MkEntry fc nm dty (DCon _ 0 hn)) = Just $ MkEntry fc nm dty (DCon EnumCon 0 hn)
+    checkEnum _ = Nothing
+
+    isZero : TopEntry → Bool
+    isZero (MkEntry fc nm dty (DCon _ 0 hn)) = True
+    isZero _ = False
+
+    -- TODO - handle indexes, etc
+    isSucc : TopEntry → Bool
+    isSucc (MkEntry fc nm dty@(Pi _ _ _ _ (Ref _ a) (Ref _ b)) (DCon _ 1 hn)) = a == b
+    isSucc _ = False
 
 processData : List String → FC → String → Raw → List Decl → M Unit
 processData ns fc nm ty cons = do
@@ -392,7 +418,7 @@ processData ns fc nm ty cons = do
       unifyCatch fc (mkCtx fc) tyty' type'
     Just (MkEntry _ name type _) => error fc "\{show nm} already declared"
     Nothing => setDef (QN ns nm) fc tyty Axiom
-  cnames <- for cons $ \x => case x of
+  entries <- join <$> (for cons $ \x => case x of
       (TypeSig fc names tm) => do
           debug $ \ _ => "check dcon \{show names} \{show tm}"
           dty <- check (mkCtx fc) tm (VU fc)
@@ -407,15 +433,17 @@ processData ns fc nm ty cons = do
             | (tm, _) => error (getFC tm) "expected \{nm} got \{render 90 $ pprint tnames tm}"
           when (hn /= QN ns nm) $ \ _ =>
             error (getFC codomain) "Constructor codomain is \{render 90 $ pprint tnames codomain} rather than \{nm}"
+          pure $ map (\ nm' => (MkEntry fc (QN ns nm') dty (DCon NormalCon (getArity dty) hn))) names
+      decl => throwError $ E (getFC decl) "expected constructor declaration")
+  for entries $ \case (MkEntry name fc dty def) => setDef fc name dty def
+  let entries = populateConInfo entries
+  let cnames = map (\x => x.name) entries
 
-          for names $ \ nm' => do
-            setDef (QN ns nm') fc dty (DCon (getArity dty) hn)
-          pure $ map (QN ns) names
-      decl => throwError $ E (getFC decl) "expected constructor declaration"
-  log 1 $ \ _ => "setDef \{nm}  TCon \{show $ join cnames}"
+  log 1 $ \ _ => "setDef \{nm}  TCon \{show cnames}"
   let arity = cast $ piArity tyty
-  updateDef (QN ns nm) fc tyty (TCon arity (join cnames))
+  updateDef (QN ns nm) fc tyty (TCon arity cnames)
   where
+
     binderName : Binder → Name
     binderName (MkBinder _ nm _ _ _) = nm
 

src/Lib/Types.newt

@@ -307,13 +307,21 @@ record MetaContext where
   next : Int
   mcmode : MetaMode
 
-data Def = Axiom | TCon Int (List QName) | DCon Int QName | Fn Tm | PrimTCon Int
+data ConInfo = NormalCon | SuccCon | ZeroCon | EnumCon
+
+instance Show ConInfo where
+  show NormalCon = ""
+  show SuccCon = "[S]"
+  show ZeroCon = "[Z]"
+  show EnumCon = "[E]"
+
+data Def = Axiom | TCon Int (List QName) | DCon ConInfo Int QName | Fn Tm | PrimTCon Int
          | PrimFn String Nat (List QName)
 
 instance Show Def where
   show Axiom = "axiom"
   show (TCon _ strs) = "TCon \{show strs}"
-  show (DCon k tyname) = "DCon \{show k} \{show tyname}"
+  show (DCon ci k tyname) = "DCon \{show k} \{show tyname} \{show ci}"
   show (Fn t) = "Fn \{show t}"
   show (PrimTCon _) = "PrimTCon"
   show (PrimFn src arity used) = "PrimFn \{show src} \{show arity} \{show used}"