very basic typing, extremely wip

src/T.hs

@@ -1,5 +1,5 @@
 module T
-  ( Tmpl
+  ( Tmpl(..)
   , Scope(..)
   , Exp
   , Value
@@ -21,6 +21,8 @@ module T
   , stdlib
   , emptyScope
 
+  , TypeError
+
   , Embed(..)
   , Eject(..)
   ) where
@@ -34,7 +36,7 @@ import T.Error
   )
 import T.Exp (Exp)
 import T.Name (Name(..))
-import T.Tmpl (Tmpl)
+import T.Tmpl (Tmpl(..))
 import T.Parse
   ( ParseError(..)
   , parseFile
@@ -44,6 +46,7 @@ import T.Parse
 import T.Prelude
 import T.Render (Rendered(..), Scope(..), render)
 import T.Stdlib (Stdlib, def)
+import T.Type (TypeError)
 import T.Value (Value, embedAeson)
 
 

src/T/App/IO.hs

@@ -29,6 +29,10 @@ instance Warn T.ParseError where
   warn (T.ParseError err) =
     ppWarn err
 
+instance Warn T.TypeError where
+  warn =
+    ppWarn . fromString . show
+
 die :: Warn t => t -> IO ()
 die err = do
   warn err

src/T/App/Repl.hs

@@ -18,6 +18,7 @@ import T qualified
 import T.SExp (sexp)
 import T.SExp qualified as SExp
 import T.Stdlib qualified as Stdlib
+import T.Type qualified as Type
 
 
 run :: IO ()
@@ -46,6 +47,9 @@ run = do
           ParseTmpl str -> do
             parseTmpl str
             loop scope0
+          InferExp str -> do
+            inferExp str
+            loop scope0
 
 header :: IO ()
 header =
@@ -80,10 +84,25 @@ parseTmpl str = liftIO $
     Right tmpl ->
       Text.Lazy.putStrLn (SExp.renderLazyText (sexp tmpl))
 
+inferExp :: MonadIO m => Text -> m ()
+inferExp str = liftIO $
+  case T.parseText Stdlib.def str of
+    Left err ->
+      warn err
+    Right (T.Exp exp) ->
+      case Type.infer (Stdlib.typingCtx Stdlib.def) exp of
+        Left te ->
+          warn te
+        Right texp ->
+          Text.Lazy.putStrLn (SExp.renderLazyText (sexp (Type.extractType texp)))
+    Right _ ->
+      error "wow"
+
 data Cmd
   = Quit
   | EvalTmpl Text
   | ParseTmpl Text
+  | InferExp Text
     deriving (Show, Eq)
 
 prompt :: IO Text
@@ -100,5 +119,7 @@ parseInput input
     EvalTmpl rest
   | Just rest <- Text.stripPrefix ":parse-tmpl " input =
     ParseTmpl rest
+  | Just rest <- Text.stripPrefix ":infer-exp " input =
+    InferExp rest
   | otherwise =
     EvalTmpl input

src/T/Embed.hs

@@ -58,8 +58,8 @@ instance (Eject a, Embed b) => Embed (a -> b) where
 
 -- Some embeddings do not have a useful annotation to attach to, such as
 -- stdlib definitions. This is a helper for them.
-embed0 :: Embed t => Name -> t -> Value
-embed0 name t =
+embed0 :: Embed t => t -> Name -> Value
+embed0 t name =
   embed (emptyAnn :+ name) t
 
 class Eject t where
@@ -73,46 +73,46 @@ instance Eject Bool where
     Bool b ->
       pure b
     value ->
-      Left (TypeError (varE name) Type.Bool (typeOf value) (sexp value))
+      Left (TagMismatch (varE name) Type.Bool (typeOf value) (sexp value))
 
 instance Eject Int where
   eject name = \case
     Int n ->
       pure n
     value ->
-      Left (TypeError (varE name) Type.Int (typeOf value) (sexp value))
+      Left (TagMismatch (varE name) Type.Int (typeOf value) (sexp value))
 
 instance Eject Double where
   eject name = \case
     Double n ->
       pure n
     value ->
-      Left (TypeError (varE name) Type.Double (typeOf value) (sexp value))
+      Left (TagMismatch (varE name) Type.Double (typeOf value) (sexp value))
 
 instance Eject Text where
   eject name = \case
     String str ->
       pure str
     value ->
-      Left (TypeError (varE name) Type.String (typeOf value) (sexp value))
+      Left (TagMismatch (varE name) Type.String (typeOf value) (sexp value))
 
 instance Eject Pcre.Regex where
   eject name = \case
     Regexp regexp ->
       pure regexp
     value ->
-      Left (TypeError (varE name) Type.Regexp (typeOf value) (sexp value))
+      Left (TagMismatch (varE name) Type.Regexp (typeOf value) (sexp value))
 
 instance (k ~ Name, v ~ Value) => Eject (HashMap k v) where
   eject name = \case
     Record o ->
       pure o
     value ->
-      Left (TypeError (varE name) Type.Record (typeOf value) (sexp value))
+      Left (TagMismatch (varE name) (Type.Record mempty) (typeOf value) (sexp value))
 
 instance Eject a => Eject [a] where
   eject name = \case
     Array xs ->
       map toList (traverse (eject name) xs)
     value ->
-      Left (TypeError (varE name) Type.Array (typeOf value) (sexp value))
+      Left (TagMismatch (varE name) (Type.Array (Type.tyVar 0)) (typeOf value) (sexp value))

src/T/Error.hs

@@ -5,14 +5,15 @@ module T.Error
   , prettyWarning
   ) where
 
+import Data.Text.Internal.Builder qualified as Builder
 import Prettyprinter (Doc)
 import Prettyprinter qualified as PP
 import Prettyprinter.Render.Terminal (AnsiStyle)
 import Prettyprinter.Render.Terminal qualified as PP (Color(..), color)
 import Text.Trifecta qualified as Tri
 import Text.Trifecta.Delta qualified as Tri
 
-import T.Exp (Cofree((:<)), Exp, ExpF(..), (:+)(..), Ann)
+import T.Exp (Exp, ExpF(..), (:+)(..), Ann)
 import T.Exp.Ann (emptyAnn)
 import T.Name (Name)
 import T.Prelude
@@ -24,9 +25,9 @@ import T.SExp qualified as SExp
 data Error
   = NotInScope (Ann :+ Name)
   | OutOfBounds Exp SExp SExp
-  | MissingProperty Exp SExp SExp
+  | MissingField Exp SExp SExp
   | UserError (Ann :+ Name) Text
-  | TypeError Exp Type Type SExp
+  | TagMismatch Exp Type Type SExp
   | NotLValue Exp
     deriving (Show, Eq)
 
@@ -41,7 +42,7 @@ prettyError = \case
     "index: " <> PP.pretty idx <> PP.line <>
     "is out of bounds for array: " <> PP.pretty array <> PP.line <>
     excerpt ann
-  MissingProperty (ann :< _) r key ->
+  MissingField (ann :< _) r key ->
     header ann <>
     "key: " <> PP.pretty key <> PP.line <>
     "is missing from the record: " <> PP.pretty r <> PP.line <>
@@ -50,21 +51,21 @@ prettyError = \case
     header ann <>
     PP.pretty name <> ": " <> PP.pretty text <> PP.line <>
     excerpt ann
-  TypeError (ann :< Var (_ann :+ name)) expected actual value ->
+  TagMismatch (ann :< Var (_ann :+ name)) expected actual value ->
     header ann <>
-    "mismatched types in " <> PP.pretty name <> ": " <> PP.line <>
-      PP.indent 2 "expected: " <> PP.pretty (show expected) <> PP.line <>
-      PP.indent 2 " but got: " <> PP.pretty value <> " : " <> PP.pretty (show actual) <> PP.line <>
+    "mismatched [rendertime] types in " <> PP.pretty name <> ": " <> PP.line <>
+      PP.indent 2 "expected: " <> PP.pretty (Builder.toLazyText (SExp.render expected)) <> PP.line <>
+      PP.indent 2 " but got: " <> PP.pretty value <> " : " <> PP.pretty (Builder.toLazyText (SExp.render actual)) <> PP.line <>
     excerpt ann
-  TypeError (ann :< _) expected actual value ->
+  TagMismatch (ann :< _) expected actual value ->
     header ann <>
-    "mismatched types:" <> PP.line <>
-      PP.indent 2 "expected: " <> PP.pretty (show expected) <> PP.line <>
-      PP.indent 2 " but got: " <> PP.pretty value <> " : " <> PP.pretty (show actual) <> PP.line <>
+    "mismatched [rendertime] types:" <> PP.line <>
+      PP.indent 2 "expected: " <> PP.pretty (Builder.toLazyText (SExp.render expected)) <> PP.line <>
+      PP.indent 2 " but got: " <> PP.pretty value <> " : " <> PP.pretty (Builder.toLazyText (SExp.render actual)) <> PP.line <>
     excerpt ann
   NotLValue exp@(ann :< _) ->
     header ann <>
-      "expected an L-Value, but got something else: " <> fromString (show (SExp.render (SExp.sexp exp))) <>
+      "expected an L-Value, but got something else: " <> fromString (show (SExp.render exp)) <>
     excerpt ann
  where
   header (Tri.Span from _to _line) =

src/T/Exp.hs

@@ -1,4 +1,6 @@
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -7,7 +9,6 @@
 {-# LANGUAGE UndecidableInstances #-}
 module T.Exp
   ( Exp
-  , Cofree(..)
   , ExpF(..)
   , Literal(..)
   , (:+)(..)
@@ -40,30 +41,22 @@ import T.SExp (sexp)
 import T.SExp qualified as SExp
 
 
-data Cofree f a = a :< f (Cofree f a)
+type Exp = Cofree (ExpF Ann) Ann
 
-deriving instance (Show a, Show (f (Cofree f a))) => Show (Cofree f a)
-
-instance Eq1 f => Eq (Cofree f a) where
-  (_ :< f) == (_ :< g) =
-    eq1 f g
-
-type Exp = Cofree ExpF Ann
-
-data ExpF a
+data ExpF ann a
   = Lit Literal
     -- ^ literals: 4, [1,2,3], {foo: 4}
-  | Var (Ann :+ Name)
+  | Var (ann :+ Name)
     -- ^ variable lookup: foo
   | If a a a
     -- ^ if-expression: if ... then ... else ...
-  | App (Ann :+ Name) (NonEmpty a)
+  | App (ann :+ Name) (NonEmpty a)
     -- ^ application: f(x)
   | Idx a a
     -- ^ array index access: xs[0]
-  | Key a (Ann :+ Name)
+  | Key a (ann :+ Name)
     -- ^ record property access: foo.bar
-    deriving (Show, Eq, Generic1)
+    deriving (Show, Eq, Generic1, Functor, Foldable, Traversable)
 
 instance SExp.To Exp where
   sexp = \case
@@ -80,7 +73,7 @@ instance SExp.To Exp where
     _ :< Key exp key ->
       SExp.round ["at-key", sexp key, sexp exp]
 
-instance Eq1 ExpF where
+instance Eq1 (ExpF ann) where
   liftEq _ (Lit l0) (Lit l1) =
     l0 == l1
   liftEq _ (Var v0) (Var v1) =

src/T/Parse.hs

@@ -26,8 +26,7 @@ import Text.Parser.Token.Style (emptyOps)
 import Text.Regex.PCRE.Light qualified as Pcre
 
 import T.Exp
-  ( Cofree(..)
-  , Exp
+  ( Exp
   , ExpF(..)
   , Literal(..)
   , (:+)(..)
@@ -43,7 +42,7 @@ import T.Exp.Ann (anning, anned)
 import T.Name (Name(..))
 import T.Name qualified as Name
 import T.Parse.Macro qualified as Macro
-import T.Prelude
+import T.Prelude hiding (for)
 import T.Tmpl (Tmpl)
 import T.Tmpl qualified as Tmpl
 import T.Stdlib (Stdlib(..))

src/T/Parse/Macro.hs

@@ -11,8 +11,7 @@ module T.Parse.Macro
 import Data.List qualified as List
 
 import T.Exp
-  ( Cofree(..)
-  , Exp
+  ( Exp
   , ExpF(..)
   , Ann
   , (:+)(..)