+38 -29

playground/samples/Tour.newt

··· 127 127 128 128 -- And primitive functions have a type and a javascript definition: 129 129 130 130 - pfunc plusInt : Int -> Int -> Int := `(x,y) => x + y` 131 131 - pfunc plusString : String -> String -> String := `(x,y) => x + y` 130 130 + pfunc addInt : Int -> Int -> Int := `(x,y) => x + y` 131 131 + pfunc addString : String -> String -> String := `(x,y) => x + y` 132 132 133 133 - -- We can make them Plus instances: 134 133 135 134 instance Add Int where 136 136 - _+_ = plusInt 135 135 + _+_ = addInt 137 136 138 138 - instance Add String where 139 139 - _+_ = plusString 137 137 + 138 138 + infixr 7 _++_ 139 139 + class Concat a where 140 140 + _++_ : a → a → a 140 141 141 141 - concat : String -> String -> String 142 142 - concat a b = a + b 142 142 + instance Concat String where 143 143 + _++_ = addString 144 144 + 145 145 + 143 146 144 147 -- Now we define Monad 145 148 class Monad (m : U -> U) where ··· 172 175 _>>_ : ∀ m a b. {{Monad m}} -> m a -> m b -> m b 173 176 ma >> mb = ma >>= (λ _ => mb) 174 177 175 175 - -- Now we define list and show it is a monad. At the moment, I don't 176 176 - -- have sugar for Lists, 178 178 + -- Now we define list and show it is a monad. 177 179 178 180 infixr 3 _::_ 179 181 data List : U -> U where 180 182 Nil : ∀ A. List A 181 183 _::_ : ∀ A. A -> List A -> List A 182 182 - 183 183 - infixr 7 _++_ 184 184 - _++_ : ∀ a. List a -> List a -> List a 185 185 - Nil ++ ys = ys 186 186 - (x :: xs) ++ ys = x :: (xs ++ ys) 187 184 188 185 instance Monad List where 189 186 pure a = a :: Nil 190 187 bind Nil f = Nil 191 188 bind (x :: xs) f = f x ++ bind xs f 192 189 193 193 - /- 194 194 - This desugars to: (the names in guillemots are not user-accessible) 190 190 + -- and has the _++_ operator 195 191 196 196 - «Monad List,pure» : { a : U } -> a:0 -> List a:1 197 197 - pure a = _::_ a Nil 192 192 + instance ∀ a. Concat (List a) where 193 193 + Nil ++ ys = ys 194 194 + (x :: xs) ++ ys = x :: (xs ++ ys) 198 195 199 199 - «Monad List,bind» : { a : U } -> { b : U } -> (List a) -> (a -> List b) -> List b 200 200 - bind Nil f = Nil bind (_::_ x xs) f = _++_ (f x) (bind xs f) 196 196 + -- A utility function used in generating Show instances below: 201 197 202 202 - «Monad List» : Monad List 203 203 - «Monad List» = MkMonad «Monad List,pure» «Monad List,bind» 204 204 - 205 205 - -/ 198 198 + joinBy : String → List String → String 199 199 + joinBy _ Nil = "" 200 200 + joinBy _ (x :: Nil) = x 201 201 + joinBy s (x :: y :: xs) = joinBy s ((x ++ s ++ y) :: xs) 206 202 207 207 - -- We'll want Pair below. `,` has been left for use as an operator. 208 208 - -- Also we see that → can be used in lieu of -> 203 203 + -- We define a product of two types (→ can be used in lieu of ->) 209 204 infixr 1 _,_ _×_ 210 205 data _×_ : U → U → U where 211 206 _,_ : ∀ A B. A → B → A × B ··· 218 213 y <- ys 219 214 pure (x, y) 220 215 216 216 + -- The prelude defines Eq and Show, which can be derived 217 217 + 218 218 + infixl 6 _==_ 219 219 + class Eq a where 220 220 + _==_ : a → a → Bool 221 221 + 222 222 + derive Eq Nat 223 223 + 224 224 + class Show a where 225 225 + show : a → String 226 226 + 227 227 + derive Show Nat 221 228 222 229 data Unit = MkUnit 223 230 ··· 235 242 236 243 pfunc putStrLn uses (MkIORes MkUnit) : String -> IO Unit := `(s) => (w) => { 237 244 console.log(s) 238 238 - return Prelude_MkIORes(null,Prelude_MkUnit,w) 245 245 + return Tour_MkIORes(Tour_MkUnit, w) 239 246 }` 240 247 241 248 main : IO Unit 242 242 - main = putStrLn "Hello, World!" 249 249 + main = do 250 250 + putStrLn "Hello, World!" 251 251 + putStrLn $ show (S (S Z))

+1 -6

src/Lib/Common.newt

··· 25 25 empty (MkBounds 0 0 0 0) = True 26 26 empty _ = False 27 27 28 28 - instance Eq Bounds where 29 29 - (MkBounds sl sc el ec) == (MkBounds sl' sc' el' ec') = 30 30 - sl == sl' 31 31 - && sc == sc' 32 32 - && el == el' 33 33 - && ec == ec' 28 28 + derive Eq Bounds 34 29 35 30 record WithBounds ty where 36 31 constructor MkBounded

+1 -3

src/Lib/Elab.newt

··· 100 100 neutral = MkResult Nil 101 101 102 102 data UnifyMode = UNormal | UPattern 103 103 - instance Show UnifyMode where 104 104 - show UNormal = "UNormal" 105 105 - show UPattern = "UPattern" 103 103 + derive Show UnifyMode 106 104 107 105 check : Context -> Raw -> Val -> M Tm 108 106

+1 -1

src/Lib/Eval.newt

··· 105 105 top <- getTop 106 106 if nm == name 107 107 then do 108 108 - debug $ \ _ => "ECase \{show nm} \{show sp} \{show nms} \{showTm t}" 108 108 + debug $ \ _ => "ECase \{show nm} \{show sp} \{show nms} \{show t}" 109 109 pushArgs env (sp <>> Nil) nms 110 110 else case lookup nm top of 111 111 (Just (MkEntry _ str type (DCon _ _ k str1) _)) => evalCase env sc xs

+1 -1

src/Lib/ProcessDecl.newt

··· 306 306 debug $ \ _ => "dcty \{render 90 $ pprint Nil dcty}" 307 307 let (_,args) = funArgs codomain 308 308 309 309 - debug $ \ _ => "traverse \{show $ map showTm args}" 309 309 + debug $ \ _ => "traverse \{show $ map show args}" 310 310 -- This is a little painful because we're reverse engineering the 311 311 -- individual types back out from the composite type 312 312 args' <- traverse (eval env) args

+9 -60

src/Lib/Syntax.newt

··· 123 123 imports : List Import 124 124 decls : List Decl 125 125 126 126 - foo : List String -> String 127 127 - foo ts = "(" ++ unwords ts ++ ")" 128 128 - 129 126 instance Show Raw 130 127 131 131 - instance Show Clause where 132 132 - show (MkClause fc cons pats expr) = show (fc, cons, pats, expr) 133 133 - 134 134 - instance Show Import where 135 135 - show (MkImport _ str) = foo ("MkImport" :: show str :: Nil) 136 136 - 137 137 - instance Show BindInfo where 138 138 - show (BI _ nm icit quant) = foo ("BI" :: show nm :: show icit :: show quant :: Nil) 139 139 - 140 140 - -- this is for debugging, use pretty when possible 141 141 - 142 142 - instance Show Decl where 143 143 - show (TypeSig _ str x) = foo ("TypeSig" :: show str :: show x :: Nil) 144 144 - show (DDerive _ x y) = foo ("DDerive" :: show x :: show y :: Nil) 145 145 - show (FunDef _ str clauses) = foo ("FunDef" :: show str :: show clauses :: Nil) 146 146 - show (Data _ str xs ys) = foo ("Data" :: show str :: show xs :: show ys :: Nil) 147 147 - show (DCheck _ x y) = foo ("DCheck" :: show x :: show y :: Nil) 148 148 - show (PType _ name ty) = foo ("PType" :: name :: show ty :: Nil) 149 149 - show (ShortData _ lhs sigs) = foo ("ShortData" :: show lhs :: show sigs :: Nil) 150 150 - show (PFunc _ nm used ty src) = foo ("PFunc" :: nm :: show used :: show ty :: show src :: Nil) 151 151 - show (PMixFix _ nms prec fix) = foo ("PMixFix" :: show nms :: show prec :: show fix :: Nil) 152 152 - show (Class _ (_,nm) tele decls) = foo ("Class" :: nm :: "..." :: (show $ map show decls) :: Nil) 153 153 - show (Instance _ nm decls) = foo ("Instance" :: show nm :: (show $ map show decls) :: Nil) 154 154 - show (Record _ nm tele nm1 decls) = foo ("Record" :: show nm :: show tele :: show nm1 :: show decls :: Nil) 155 155 - show (Exports _ nms) = foo ("Exports" :: show nms :: Nil) 156 156 - 157 157 - 158 158 - instance Show Module where 159 159 - show (MkModule name imports decls) = foo ("MkModule" :: show name :: show imports :: show decls :: Nil) 160 160 - 161 161 - 162 162 - instance Show RCaseAlt where 163 163 - show (MkAlt x y)= foo ("MkAlt" :: show x :: show y :: Nil) 164 164 - 165 165 - instance Show UpdateClause where 166 166 - show (ModifyField _ nm tm) = foo ("ModifyField" :: nm :: show tm :: Nil) 167 167 - show (AssignField _ nm tm) = foo ("AssignField" :: nm :: show tm :: Nil) 168 168 - 169 169 - instance Show Raw where 170 170 - show (RImplicit _) = "_" 171 171 - show (RImpossible _) = "()" 172 172 - show (RHole _) = "?" 173 173 - show (RUpdateRec _ clauses tm) = foo ("RUpdateRec" :: show clauses :: show tm :: Nil) 174 174 - show (RVar _ name) = foo ("RVar" :: show name :: Nil) 175 175 - show (RLit _ x) = foo ( "RLit" :: show x :: Nil) 176 176 - show (RLet _ x ty v scope) = foo ( "Let" :: show x :: " : " :: show ty :: " = " :: show v :: " in " :: show scope :: Nil) 177 177 - show (RPi _ bi y z) = foo ( "Pi" :: show bi :: show y :: show z :: Nil) 178 178 - show (RApp _ x y z) = foo ( "App" :: show x :: show y :: show z :: Nil) 179 179 - show (RLam _ bi y) = foo ( "Lam" :: show bi :: show y :: Nil) 180 180 - show (RCase _ x Nothing xs) = foo ( "Case" :: show x :: " of " :: show xs :: Nil) 181 181 - show (RCase _ x (Just ty) xs) = foo ( "Case" :: show x :: " : " :: show ty :: " of " :: show xs :: Nil) 182 182 - show (RDo _ stmts) = foo ( "DO" :: "FIXME" :: Nil) 183 183 - show (RU _) = "U" 184 184 - show (RIf _ x y z) = foo ( "If" :: show x :: show y :: show z :: Nil) 185 185 - show (RWhere _ _ _) = foo ( "Where" :: "FIXME" :: Nil) 186 186 - show (RAs _ nm x) = foo ( "RAs" :: nm :: show x :: Nil) 187 187 - 128 128 + derive Show Clause 129 129 + derive Show Import 130 130 + derive Show BindInfo 131 131 + derive Show DoStmt 132 132 + derive Show Decl 133 133 + derive Show Module 134 134 + derive Show RCaseAlt 135 135 + derive Show UpdateClause 136 136 + derive Show Raw 188 137 189 138 instance Pretty Literal where 190 139 pretty (LString t) = text t

+4 -38

src/Lib/Token.newt

··· 13 13 | StringKind 14 14 | JSLit 15 15 | Symbol 16 16 - | Space 17 17 - | Comment 18 16 | Pragma 19 17 | Projection 20 20 - -- not doing Layout.idr 21 21 - | LBrace 22 22 - | Semi 23 23 - | RBrace 24 24 - | EOI 25 18 | StartQuote 26 19 | EndQuote 27 20 | StartInterp 28 21 | EndInterp 29 22 30 30 - 31 31 - instance Show Kind where 32 32 - show Ident = "Ident" 33 33 - show UIdent = "UIdent" 34 34 - show Keyword = "Keyword" 35 35 - show MixFix = "MixFix" 36 36 - show Number = "Number" 37 37 - show Character = "Character" 38 38 - show Symbol = "Symbol" 39 39 - show Space = "Space" 40 40 - show LBrace = "LBrace" 41 41 - show Semi = "Semi" 42 42 - show RBrace = "RBrace" 43 43 - show Comment = "Comment" 44 44 - show EOI = "EOI" 45 45 - show Pragma = "Pragma" 46 46 - show StringKind = "String" 47 47 - show JSLit = "JSLit" 48 48 - show Projection = "Projection" 49 49 - show StartQuote = "StartQuote" 50 50 - show EndQuote = "EndQuote" 51 51 - show StartInterp = "StartInterp" 52 52 - show EndInterp = "EndInterp" 53 53 - 23 23 + derive Show Kind 54 24 55 25 instance Eq Kind where 56 26 a == b = show a == show b ··· 61 31 kind : Kind 62 32 text : String 63 33 64 64 - 65 65 - 66 34 instance Show Token where 67 35 show (Tok k v) = "<\{show k}:\{show v}>" 68 68 - 69 36 70 37 BTok : U 71 38 BTok = WithBounds Token 72 39 73 73 - 74 74 - value : BTok -> String 40 40 + value : BTok → String 75 41 value (MkBounded (Tok _ s) _) = s 76 42 77 43 78 78 - getStart : BTok -> (Int × Int) 44 44 + getStart : BTok → (Int × Int) 79 45 getStart (MkBounded _ (MkBounds l c _ _)) = (l,c) 80 46 81 81 - getEnd : BTok -> (Int × Int) 47 47 + getEnd : BTok → (Int × Int) 82 48 getEnd (MkBounded _ (MkBounds _ _ el ec)) = (el,ec)

+13 -112

src/Lib/Types.newt

··· 14 14 Name = String 15 15 16 16 data Icit = Implicit | Explicit | Auto 17 17 - 18 18 - instance Show Icit where 19 19 - show Implicit = "Implicit" 20 20 - show Explicit = "Explicit" 21 21 - show Auto = "Auto" 17 17 + derive Show Icit 18 18 + derive Eq Icit 22 19 23 20 data BD = Bound | Defined 24 24 - 25 25 - instance Eq BD where 26 26 - Bound == Bound = True 27 27 - Defined == Defined = True 28 28 - _ == _ = False 29 29 - 30 30 - instance Show BD where 31 31 - show Bound = "bnd" 32 32 - show Defined = "def" 21 21 + derive Eq BD 22 22 + derive Show BD 33 23 34 24 data Quant = Zero | Many 35 35 - 36 36 - instance Show Quant where 37 37 - show Zero = "0 " 38 38 - show Many = "" 39 39 - 40 40 - instance Eq Quant where 41 41 - Zero == Zero = True 42 42 - Many == Many = True 43 43 - _ == _ = False 25 25 + derive Eq Quant 26 26 + derive Show Quant 44 27 45 28 -- We could make this polymorphic and use for environment... 46 29 ··· 130 113 instance Show CaseAlt where 131 114 show = showCaseAlt 132 115 133 133 - 134 134 - showTm : Tm -> String 135 135 - showTm = show 136 136 - 137 137 - -- I can't really show val because it's HOAS... 138 138 - 139 139 - -- TODO derive 140 140 - 141 141 - instance Eq Icit where 142 142 - Implicit == Implicit = True 143 143 - Explicit == Explicit = True 144 144 - Auto == Auto = True 145 145 - _ == _ = False 146 146 - 147 147 - -- Eq on Tm. We've got deBruijn indices, so I'm not comparing names 148 148 - 149 149 - instance Eq (Tm) where 150 150 - -- (Local x) == (Local y) = x == y 151 151 - (Bnd _ x) == (Bnd _ y) = x == y 152 152 - (Ref _ x) == Ref _ y = x == y 153 153 - (Lam _ n _ _ t) == Lam _ n' _ _ t' = t == t' 154 154 - (App _ t u) == App _ t' u' = t == t' && u == u' 155 155 - (UU _) == (UU _) = True 156 156 - (Pi _ n icit rig t u) == (Pi _ n' icit' rig' t' u') = icit == icit' && rig == rig' && t == t' && u == u' 157 157 - _ == _ = False 158 158 - 159 159 - -- TODO App and Lam should have <+/> but we need to fix 160 160 - -- INFO pprint to `nest 2 ...` 161 161 - -- maybe return Doc and have an Interpolation.. 162 162 - -- If we need to flatten, case is going to get in the way. 163 163 - 164 116 pprint' : Int -> List String -> Tm -> Doc 165 117 pprintAlt : Int -> List String -> CaseAlt -> Doc 166 118 pprintAlt p names (CaseDefault t) = text "_" <+> text "=>" <+> pprint' p ("_" :: names) t ··· 282 234 283 235 284 236 showClosure (MkClosure xs t) = "(%cl [\{show $ length xs} env] \{show t})" 285 285 - 286 286 - -- instance Show Closure where 287 287 - -- show = showClosure 288 237 289 238 Context : U 290 239 291 240 data MetaKind = Normal | User | AutoSolve | ErrorHole 292 241 293 293 - instance Show MetaKind where 294 294 - show Normal = "Normal" 295 295 - show User = "User" 296 296 - show AutoSolve = "Auto" 297 297 - show ErrorHole = "ErrorHole" 298 298 - 299 299 - instance Eq MetaKind where 300 300 - Normal == Normal = True 301 301 - User == User = True 302 302 - AutoSolve == AutoSolve = True 303 303 - ErrorHole == ErrorHole = True 304 304 - _ == _ = False 242 242 + derive Show MetaKind 243 243 + derive Eq MetaKind 305 244 306 245 -- constrain meta applied to val to be a val 307 246 ··· 328 267 next : Int 329 268 mcmode : MetaMode 330 269 331 331 - instance Eq MetaMode where 332 332 - CheckAll == CheckAll = True 333 333 - CheckFirst == CheckFirst = True 334 334 - NoCheck == NoCheck = True 335 335 - _ == _ = False 270 270 + derive Eq MetaMode 336 271 337 272 data ConInfo = NormalCon | SuccCon | ZeroCon | EnumCon | TrueCon | FalseCon 338 273 339 339 - instance Eq ConInfo where 340 340 - NormalCon == NormalCon = True 341 341 - SuccCon == SuccCon = True 342 342 - ZeroCon == ZeroCon = True 343 343 - EnumCon == EnumCon = True 344 344 - TrueCon == TrueCon = True 345 345 - FalseCon == FalseCon = True 346 346 - _ == _ = False 274 274 + derive Eq ConInfo 347 275 348 276 instance Show ConInfo where 349 277 show NormalCon = "" ··· 356 284 data Def = Axiom | TCon Int (List QName) | DCon Nat ConInfo (List Quant) QName | Fn Tm | PrimTCon Int 357 285 | PrimFn String Nat (List QName) 358 286 | PrimOp String 359 359 - 360 360 - instance Show Def where 361 361 - show Axiom = "axiom" 362 362 - show (PrimOp op) = "PrimOp \{show op}" 363 363 - show (TCon _ strs) = "TCon \{show strs}" 364 364 - show (DCon ix ci k tyname) = "DCon \{show ix} \{show k} \{show tyname} \{show ci}" 365 365 - show (Fn t) = "Fn \{show t}" 366 366 - show (PrimTCon _) = "PrimTCon" 367 367 - show (PrimFn src arity used) = "PrimFn \{show src} \{show arity} \{show used}" 368 368 - 369 369 - -- entry in the top level context 287 287 + derive Show Def 370 288 371 289 data EFlag = Hint | Inline | Export 372 372 - 373 373 - instance Show EFlag where 374 374 - show Hint = "hint" 375 375 - show Inline = "inline" 376 376 - show Export = "export" 377 377 - 378 378 - instance Eq EFlag where 379 379 - Hint == Hint = True 380 380 - Inline == Inline = True 381 381 - Export == Export = True 382 382 - _ == _ = False 290 290 + derive Show EFlag 291 291 + derive Eq EFlag 383 292 384 293 record TopEntry where 385 294 constructor MkEntry ··· 410 319 modErrors : List Error 411 320 modInfos : List EditorInfo 412 321 413 413 - -- Top level context. 414 414 - -- Most of the reason this is separate is to have a different type 415 415 - -- `Def` for the entries. 416 416 - -- 417 417 - -- The price is that we have names in addition to levels. Do we want to 418 418 - -- expand these during normalization? 419 419 - 420 420 - -- A placeholder while walking through dependencies of a module 421 322 emptyModCtx : String → String → ModContext 422 323 emptyModCtx modName source = MkModCtx modName source emptyMap (MC emptyMap Nil 0 NoCheck) emptyMap Nil Nil Nil 423 324

-2

src/Lib/Util.newt

··· 20 20 data Binder : U where 21 21 MkBinder : FC -> String -> Icit -> Quant -> Tm -> Binder 22 22 23 23 - -- I don't have a show for terms without a name list 24 24 - 25 23 instance Show Binder where 26 24 show (MkBinder _ nm icit quant t) = "[\{show quant}\{nm} \{show icit} : ...]" 27 25

+1 -5

src/Prelude.newt

··· 744 744 tail (x :: xs) = xs 745 745 746 746 data Ordering = LT | EQ | GT 747 747 - instance Eq Ordering where 748 748 - LT == LT = True 749 749 - EQ == EQ = True 750 750 - GT == GT = True 751 751 - _ == _ = False 747 747 + derive Eq Ordering 752 748 753 749 pfunc jsCompare uses (EQ LT GT) : ∀ a. a → a → Ordering := `(_, a, b) => a == b ? Prelude_EQ : a < b ? Prelude_LT : Prelude_GT` 754 750