Use deriving

playground/samples/Tour.newt

@@ -127,19 +127,22 @@ isVowel _ = False
 
 -- And primitive functions have a type and a javascript definition:
 
-pfunc plusInt : Int -> Int -> Int := `(x,y) => x + y`
-pfunc plusString : String -> String -> String := `(x,y) => x + y`
+pfunc addInt : Int -> Int -> Int := `(x,y) => x + y`
+pfunc addString : String -> String -> String := `(x,y) => x + y`
 
--- We can make them Plus instances:
 
 instance Add Int where
-  _+_ = plusInt
+  _+_ = addInt
+
+
+infixr 7 _++_
+class Concat a where
+  _++_ : a → a → a
+
+instance Concat String where
+  _++_ = addString
 
-instance Add String where
-  _+_ = plusString
 
-concat : String -> String -> String
-concat a b = a + b
 
 -- Now we define Monad
 class Monad (m : U -> U) where
@@ -172,40 +175,32 @@ _>>=_ ma amb = bind ma amb
 _>>_ :  ∀ m a b. {{Monad m}} -> m a -> m b -> m b
 ma >> mb = ma >>= (λ _ => mb)
 
--- Now we define list and show it is a monad. At the moment, I don't
--- have sugar for Lists,
+-- Now we define list and show it is a monad.
 
 infixr 3 _::_
 data List : U -> U where
   Nil : ∀ A.  List A
   _::_ : ∀ A. A -> List A -> List A
 
-infixr 7 _++_
-_++_ : ∀ a.  List a -> List a -> List a
-Nil ++ ys = ys
-(x :: xs) ++ ys = x :: (xs ++ ys)
-
 instance Monad List where
   pure a = a :: Nil
   bind Nil f = Nil
   bind (x :: xs) f = f x ++ bind xs f
 
-/-
-This desugars to: (the names in guillemots are not user-accessible)
+-- and has the _++_ operator
 
-«Monad List,pure» : { a : U } -> a:0 -> List a:1
-pure a = _::_ a Nil
+instance ∀ a. Concat (List a) where
+  Nil ++ ys = ys
+  (x :: xs) ++ ys = x :: (xs ++ ys)
 
-«Monad List,bind» : { a : U } -> { b : U } -> (List a) -> (a -> List b) -> List b
-bind Nil f = Nil bind (_::_ x xs) f = _++_ (f x) (bind xs f)
+-- A utility function used in generating Show instances below:
 
-«Monad List» : Monad List
-«Monad List» = MkMonad «Monad List,pure» «Monad List,bind»
+joinBy : String → List String → String
+joinBy _ Nil = ""
+joinBy _ (x :: Nil) = x
+joinBy s (x :: y :: xs) = joinBy s ((x ++ s ++ y) :: xs)
 
--/
-
--- We'll want Pair below.  `,` has been left for use as an operator.
--- Also we see that → can be used in lieu of ->
+-- We define a product of two types (→ can be used in lieu of ->)
 infixr 1 _,_ _×_
 data _×_ : U → U → U where
   _,_ : ∀ A B. A → B → A × B
@@ -218,6 +213,18 @@ prod xs ys = do
   y <- ys
   pure (x, y)
 
+-- The prelude defines Eq and Show, which can be derived
+
+infixl 6 _==_
+class Eq a where
+  _==_ : a → a → Bool
+
+derive Eq Nat
+
+class Show a where
+  show : a → String
+
+derive Show Nat
 
 data Unit = MkUnit
 
@@ -235,8 +242,10 @@ instance Monad IO where
 
 pfunc putStrLn uses (MkIORes MkUnit) : String -> IO Unit := `(s) => (w) => {
   console.log(s)
-  return Prelude_MkIORes(null,Prelude_MkUnit,w)
+  return Tour_MkIORes(Tour_MkUnit, w)
 }`
 
 main : IO Unit
-main = putStrLn "Hello, World!"
+main = do
+  putStrLn "Hello, World!"
+  putStrLn $ show (S (S Z))

src/Lib/Common.newt

@@ -25,12 +25,7 @@ instance Add Bounds where
       empty (MkBounds 0 0 0 0) = True
       empty _ = False
 
-instance Eq Bounds where
-  (MkBounds sl sc el ec) == (MkBounds sl' sc' el' ec') =
-      sl == sl'
-   && sc == sc'
-   && el == el'
-   && ec == ec'
+derive Eq Bounds
 
 record WithBounds ty where
   constructor MkBounded

src/Lib/Elab.newt

@@ -100,9 +100,7 @@ instance Monoid UnifyResult where
   neutral = MkResult Nil
 
 data UnifyMode = UNormal | UPattern
-instance Show UnifyMode where
-  show UNormal = "UNormal"
-  show UPattern = "UPattern"
+derive Show UnifyMode
 
 check : Context -> Raw -> Val -> M Tm
 

src/Lib/Eval.newt

@@ -105,7 +105,7 @@ evalCase env sc@(VRef _ nm sp) (cc@(CaseCons name nms t) :: xs) = do
   top <- getTop
   if nm == name
     then do
-      debug $ \ _ =>  "ECase \{show nm} \{show sp} \{show nms} \{showTm t}"
+      debug $ \ _ =>  "ECase \{show nm} \{show sp} \{show nms} \{show t}"
       pushArgs env (sp <>> Nil) nms
     else case lookup nm top of
       (Just (MkEntry _ str type (DCon _ _ k str1) _)) => evalCase env sc xs

src/Lib/ProcessDecl.newt

@@ -306,7 +306,7 @@ processInstance ns instfc ty decls = do
   debug $ \ _ => "dcty \{render 90 $ pprint Nil dcty}"
   let (_,args) = funArgs codomain
 
-  debug $ \ _ => "traverse \{show $ map showTm args}"
+  debug $ \ _ => "traverse \{show $ map show args}"
   -- This is a little painful because we're reverse engineering the
   -- individual types back out from the composite type
   args' <- traverse (eval env) args

src/Lib/Syntax.newt

@@ -123,68 +123,17 @@ record Module where
   imports : List Import
   decls : List Decl
 
-foo : List String -> String
-foo ts = "(" ++ unwords ts ++ ")"
-
 instance Show Raw
 
-instance Show Clause where
-  show (MkClause fc cons pats expr) = show (fc, cons, pats, expr)
-
-instance Show Import where
-  show (MkImport _ str) = foo ("MkImport" :: show str :: Nil)
-
-instance Show BindInfo where
-  show (BI _ nm icit quant) = foo ("BI" :: show nm :: show icit :: show quant :: Nil)
-
--- this is for debugging, use pretty when possible
-
-instance Show Decl where
-  show (TypeSig _ str x) = foo ("TypeSig" :: show str :: show x :: Nil)
-  show (DDerive _ x y) = foo ("DDerive" :: show x :: show y :: Nil)
-  show (FunDef _ str clauses) = foo ("FunDef" :: show str :: show clauses :: Nil)
-  show (Data _ str xs ys) = foo ("Data" :: show str :: show xs :: show ys :: Nil)
-  show (DCheck _ x y) = foo ("DCheck" :: show x :: show y :: Nil)
-  show (PType _ name ty) = foo ("PType" :: name :: show ty :: Nil)
-  show (ShortData _ lhs sigs) = foo ("ShortData" :: show lhs :: show sigs :: Nil)
-  show (PFunc _ nm used ty src) = foo ("PFunc" :: nm :: show used :: show ty :: show src :: Nil)
-  show (PMixFix _ nms prec fix) = foo ("PMixFix" :: show nms :: show prec :: show fix :: Nil)
-  show (Class _ (_,nm) tele decls) = foo ("Class" ::  nm :: "..." :: (show $ map show decls) :: Nil)
-  show (Instance _ nm decls) = foo ("Instance" ::  show nm :: (show $ map show decls) :: Nil)
-  show (Record _ nm tele nm1 decls) = foo ("Record" :: show nm :: show tele :: show nm1 :: show decls :: Nil)
-  show (Exports _ nms) = foo ("Exports" :: show nms :: Nil)
-
-
-instance Show Module where
-  show (MkModule name imports decls) = foo ("MkModule" :: show name :: show imports :: show decls :: Nil)
-
-
-instance Show RCaseAlt where
-  show (MkAlt x y)= foo ("MkAlt" :: show x :: show y :: Nil)
-
-instance Show UpdateClause where
-  show (ModifyField _ nm tm) = foo ("ModifyField" :: nm :: show tm :: Nil)
-  show (AssignField _ nm tm) = foo ("AssignField" :: nm :: show tm :: Nil)
-
-instance Show Raw where
-  show (RImplicit _) = "_"
-  show (RImpossible _) = "()"
-  show (RHole _) = "?"
-  show (RUpdateRec _ clauses tm) = foo ("RUpdateRec" :: show clauses :: show tm :: Nil)
-  show (RVar _ name) = foo ("RVar" :: show name :: Nil)
-  show (RLit _ x) = foo ( "RLit" :: show x :: Nil)
-  show (RLet _ x ty v scope) = foo ( "Let" :: show x :: " : " :: show ty :: " = " :: show v :: " in " :: show scope :: Nil)
-  show (RPi _ bi y z) = foo ( "Pi" :: show bi :: show y :: show z :: Nil)
-  show (RApp _ x y z) = foo ( "App" :: show x :: show y :: show z :: Nil)
-  show (RLam _ bi y) = foo ( "Lam" :: show bi :: show y :: Nil)
-  show (RCase _ x Nothing xs) = foo ( "Case" :: show x :: " of " :: show xs :: Nil)
-  show (RCase _ x (Just ty) xs) = foo ( "Case" :: show x :: " : " :: show ty :: " of " :: show xs :: Nil)
-  show (RDo _ stmts) = foo ( "DO" :: "FIXME" :: Nil)
-  show (RU _) = "U"
-  show (RIf _ x y z) = foo ( "If" :: show x :: show y :: show z :: Nil)
-  show (RWhere _ _ _) = foo ( "Where" :: "FIXME" :: Nil)
-  show (RAs _ nm x) = foo ( "RAs" :: nm :: show x :: Nil)
-
+derive Show Clause
+derive Show Import
+derive Show BindInfo
+derive Show DoStmt
+derive Show Decl
+derive Show Module
+derive Show RCaseAlt
+derive Show UpdateClause
+derive Show Raw
 
 instance Pretty Literal where
   pretty (LString t) = text t

src/Lib/Token.newt

@@ -13,44 +13,14 @@ data Kind
   | StringKind
   | JSLit
   | Symbol
-  | Space
-  | Comment
   | Pragma
   | Projection
-  -- not doing Layout.idr
-  | LBrace
-  | Semi
-  | RBrace
-  | EOI
   | StartQuote
   | EndQuote
   | StartInterp
   | EndInterp
 
-
-instance Show Kind where
-  show Ident   = "Ident"
-  show UIdent   = "UIdent"
-  show Keyword = "Keyword"
-  show MixFix = "MixFix"
-  show Number  = "Number"
-  show Character  = "Character"
-  show Symbol  = "Symbol"
-  show Space  = "Space"
-  show LBrace  = "LBrace"
-  show Semi    = "Semi"
-  show RBrace  = "RBrace"
-  show Comment = "Comment"
-  show EOI     = "EOI"
-  show Pragma  = "Pragma"
-  show StringKind = "String"
-  show JSLit = "JSLit"
-  show Projection = "Projection"
-  show StartQuote = "StartQuote"
-  show EndQuote = "EndQuote"
-  show StartInterp = "StartInterp"
-  show EndInterp = "EndInterp"
-
+derive Show Kind
 
 instance Eq Kind where
   a == b = show a == show b
@@ -61,22 +31,18 @@ record Token where
   kind : Kind
   text : String
 
-
-
 instance Show Token where
   show (Tok k v) = "<\{show k}:\{show v}>"
 
-
 BTok : U
 BTok = WithBounds Token
 
-
-value : BTok -> String
+value : BTok → String
 value (MkBounded (Tok _ s) _) = s
 
 
-getStart : BTok -> (Int × Int)
+getStart : BTok → (Int × Int)
 getStart (MkBounded _ (MkBounds l c _ _)) = (l,c)
 
-getEnd : BTok -> (Int × Int)
+getEnd : BTok → (Int × Int)
 getEnd (MkBounded _ (MkBounds _ _ el ec)) = (el,ec)

src/Lib/Types.newt

@@ -14,33 +14,16 @@ Name : U
 Name = String
 
 data Icit = Implicit | Explicit | Auto
-
-instance Show Icit where
-  show Implicit = "Implicit"
-  show Explicit = "Explicit"
-  show Auto = "Auto"
+derive Show Icit
+derive Eq Icit
 
 data BD = Bound | Defined
-
-instance Eq BD where
-  Bound == Bound = True
-  Defined == Defined = True
-  _ == _ = False
-
-instance Show BD where
-  show Bound = "bnd"
-  show Defined = "def"
+derive Eq BD
+derive Show BD
 
 data Quant = Zero | Many
-
-instance Show Quant where
-  show Zero = "0 "
-  show Many = ""
-
-instance Eq Quant where
-  Zero == Zero = True
-  Many == Many = True
-  _ == _ = False
+derive Eq Quant
+derive Show Quant
 
 -- We could make this polymorphic and use for environment...
 
@@ -130,37 +113,6 @@ showCaseAlt (CaseLit lit tm) = "\{show lit} => \{show tm}"
 instance Show CaseAlt where
   show = showCaseAlt
 
-
-showTm : Tm -> String
-showTm = show
-
--- I can't really show val because it's HOAS...
-
--- TODO derive
-
-instance Eq Icit where
-  Implicit == Implicit = True
-  Explicit == Explicit = True
-  Auto == Auto = True
-  _ == _ = False
-
--- Eq on Tm. We've got deBruijn indices, so I'm not comparing names
-
-instance Eq (Tm) where
-  -- (Local x) == (Local y) = x == y
-  (Bnd _ x) == (Bnd _ y) = x == y
-  (Ref _ x) == Ref _ y = x == y
-  (Lam _ n _ _ t) == Lam _ n' _ _ t' = t == t'
-  (App _ t u) == App _ t' u' = t == t' && u == u'
-  (UU _) == (UU _) = True
-  (Pi _ n icit rig t u) == (Pi _ n' icit' rig' t' u') = icit == icit' && rig == rig' && t == t' && u == u'
-  _ == _ = False
-
--- TODO App and Lam should have <+/> but we need to fix
--- INFO pprint to `nest 2 ...`
--- maybe return Doc and have an Interpolation..
--- If we need to flatten, case is going to get in the way.
-
 pprint' : Int -> List String -> Tm -> Doc
 pprintAlt : Int -> List String -> CaseAlt -> Doc
 pprintAlt p names (CaseDefault t) = text "_" <+> text "=>" <+> pprint' p ("_" :: names) t
@@ -283,25 +235,12 @@ instance Show Val where
 
 showClosure (MkClosure xs t) = "(%cl [\{show $ length xs} env] \{show t})"
 
--- instance Show Closure where
---   show = showClosure
-
 Context : U
 
 data MetaKind = Normal | User | AutoSolve | ErrorHole
 
-instance Show MetaKind where
-  show Normal = "Normal"
-  show User = "User"
-  show AutoSolve = "Auto"
-  show ErrorHole = "ErrorHole"
-
-instance Eq MetaKind where
-  Normal == Normal = True
-  User == User = True
-  AutoSolve == AutoSolve = True
-  ErrorHole == ErrorHole = True
-  _ == _ = False
+derive Show MetaKind
+derive Eq MetaKind
 
 -- constrain meta applied to val to be a val
 
@@ -328,22 +267,11 @@ record MetaContext where
   next : Int
   mcmode : MetaMode
 
-instance Eq MetaMode where
-  CheckAll == CheckAll = True
-  CheckFirst == CheckFirst = True
-  NoCheck == NoCheck = True
-  _ == _ = False
+derive Eq MetaMode
 
 data ConInfo = NormalCon | SuccCon | ZeroCon | EnumCon | TrueCon | FalseCon
 
-instance Eq ConInfo where
-  NormalCon == NormalCon = True
-  SuccCon == SuccCon = True
-  ZeroCon == ZeroCon = True
-  EnumCon == EnumCon = True
-  TrueCon == TrueCon = True
-  FalseCon == FalseCon = True
-  _ == _ = False
+derive Eq ConInfo
 
 instance Show ConInfo where
   show NormalCon = ""
@@ -356,30 +284,11 @@ instance Show ConInfo where
 data Def = Axiom | TCon Int (List QName) | DCon Nat ConInfo (List Quant) QName | Fn Tm | PrimTCon Int
          | PrimFn String Nat (List QName)
          | PrimOp String
-
-instance Show Def where
-  show Axiom = "axiom"
-  show (PrimOp op) = "PrimOp \{show op}"
-  show (TCon _ strs) = "TCon \{show strs}"
-  show (DCon ix ci k tyname) = "DCon \{show ix} \{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}"
-
--- entry in the top level context
+derive Show Def
 
 data EFlag = Hint | Inline | Export
-
-instance Show EFlag where
-  show Hint = "hint"
-  show Inline = "inline"
-  show Export = "export"
-
-instance Eq EFlag where
-  Hint == Hint = True
-  Inline == Inline = True
-  Export == Export = True
-  _ == _ = False
+derive Show EFlag
+derive Eq EFlag
 
 record TopEntry where
   constructor MkEntry
@@ -410,14 +319,6 @@ record ModContext where
   modErrors : List Error
   modInfos : List EditorInfo
 
--- Top level context.
--- Most of the reason this is separate is to have a different type
--- `Def` for the entries.
---
--- The price is that we have names in addition to levels. Do we want to
--- expand these during normalization?
-
--- A placeholder while walking through dependencies of a module
 emptyModCtx : String → String → ModContext
 emptyModCtx modName source = MkModCtx modName source emptyMap (MC emptyMap Nil 0 NoCheck) emptyMap Nil Nil Nil
 

src/Lib/Util.newt

@@ -20,8 +20,6 @@ funArgs tm = go tm Nil
 data Binder : U where
   MkBinder : FC -> String -> Icit -> Quant -> Tm -> Binder
 
--- I don't have a show for terms without a name list
-
 instance Show Binder where
   show (MkBinder _ nm icit quant t) = "[\{show quant}\{nm} \{show icit} : ...]"
 

src/Prelude.newt

@@ -744,11 +744,7 @@ tail Nil = Nil
 tail (x :: xs) = xs
 
 data Ordering = LT | EQ | GT
-instance Eq Ordering where
-  LT == LT = True
-  EQ == EQ = True
-  GT == GT = True
-  _ == _ = False
+derive Eq Ordering
 
 pfunc jsCompare uses (EQ LT GT) : ∀ a. a → a → Ordering := `(_, a, b) => a == b ? Prelude_EQ : a < b ? Prelude_LT : Prelude_GT`