Use deriving

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`