diff --git a/playground/samples/Tour.newt b/playground/samples/Tour.newt index 372a99a..cf5b436 100644 --- a/playground/samples/Tour.newt +++ b/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)) diff --git a/src/Lib/Common.newt b/src/Lib/Common.newt index d5304e2..5e09d33 100644 --- a/src/Lib/Common.newt +++ b/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 diff --git a/src/Lib/Elab.newt b/src/Lib/Elab.newt index bffc9f1..46fb3df 100644 --- a/src/Lib/Elab.newt +++ b/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 diff --git a/src/Lib/Eval.newt b/src/Lib/Eval.newt index f15360e..817d5ed 100644 --- a/src/Lib/Eval.newt +++ b/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 diff --git a/src/Lib/ProcessDecl.newt b/src/Lib/ProcessDecl.newt index af5350a..b64c851 100644 --- a/src/Lib/ProcessDecl.newt +++ b/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 diff --git a/src/Lib/Syntax.newt b/src/Lib/Syntax.newt index 53aaf87..590e696 100644 --- a/src/Lib/Syntax.newt +++ b/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 diff --git a/src/Lib/Token.newt b/src/Lib/Token.newt index 5d7aa0a..6e2de9b 100644 --- a/src/Lib/Token.newt +++ b/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) diff --git a/src/Lib/Types.newt b/src/Lib/Types.newt index 24a22b0..2f712d3 100644 --- a/src/Lib/Types.newt +++ b/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 diff --git a/src/Lib/Util.newt b/src/Lib/Util.newt index 5e0014b..f962cb0 100644 --- a/src/Lib/Util.newt +++ b/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} : ...]" diff --git a/src/Prelude.newt b/src/Prelude.newt index 91c4c4d..155295b 100644 --- a/src/Prelude.newt +++ b/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`