diff --git a/src/T.hs b/src/T.hs index c573f43..e1bc949 100644 --- a/src/T.hs +++ b/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) diff --git a/src/T/App/IO.hs b/src/T/App/IO.hs index 80ee120..7e32310 100644 --- a/src/T/App/IO.hs +++ b/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 diff --git a/src/T/App/Repl.hs b/src/T/App/Repl.hs index 40dc2b4..cae3fa9 100644 --- a/src/T/App/Repl.hs +++ b/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 diff --git a/src/T/Embed.hs b/src/T/Embed.hs index 738099a..133817e 100644 --- a/src/T/Embed.hs +++ b/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)) diff --git a/src/T/Error.hs b/src/T/Error.hs index 3a887e0..f34142c 100644 --- a/src/T/Error.hs +++ b/src/T/Error.hs @@ -5,6 +5,7 @@ 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) @@ -12,7 +13,7 @@ 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) = diff --git a/src/T/Exp.hs b/src/T/Exp.hs index aeef2bc..ab81ea2 100644 --- a/src/T/Exp.hs +++ b/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) = diff --git a/src/T/Parse.hs b/src/T/Parse.hs index b7fa150..f61dd92 100644 --- a/src/T/Parse.hs +++ b/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(..)) diff --git a/src/T/Parse/Macro.hs b/src/T/Parse/Macro.hs index 50f007c..649d0fc 100644 --- a/src/T/Parse/Macro.hs +++ b/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 , (:+)(..) diff --git a/src/T/Prelude.hs b/src/T/Prelude.hs index e57951a..7eed0a7 100644 --- a/src/T/Prelude.hs +++ b/src/T/Prelude.hs @@ -1,10 +1,15 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module T.Prelude ( Alternative(..) , Applicative(..) , Eq(..) - , Fractional , Eq1(..) + , Foldable(..) + , Fractional + , Functor , Generic1 , Hashable , Integral @@ -17,14 +22,17 @@ module T.Prelude , Ord(..) , Semigroup(..) , Show(..) + , Traversable , Bool(..) , ByteString , Char + , Cofree(..) , Double , Either(..) , FilePath , HashMap + , Identity , Int , IO , Maybe(..) @@ -38,10 +46,13 @@ module T.Prelude , ($) , (<$) , (&&) + , (||) , (+) , (-) , (*) , (/) + , all + , any , asum , bool , concatMap @@ -53,10 +64,8 @@ module T.Prelude , filter , first , flip - , foldl' - , foldr , foldM_ - , foldr1 + , for , for_ , fromIntegral , impossible @@ -67,9 +76,10 @@ module T.Prelude , notElem , otherwise , reverse + , runIdentity , second , seq - , toList + , sequence , traverse , traverse_ , T.Prelude.traceShow @@ -80,24 +90,32 @@ module T.Prelude ) where import Control.Applicative (Alternative(..)) -import Control.Monad ((<=<), foldM_, when, unless) +import Control.Monad ((<=<), foldM_, sequence, when, unless) import Control.Monad.IO.Class (MonadIO(..)) import Data.Bool (bool) import Data.Bifunctor (first, second) import Data.ByteString (ByteString) import Data.Foldable - ( asum + ( Foldable + , all + , any + , asum , for_ , toList , traverse_ ) import Data.Functor.Classes (Eq1(..), eq1) +import Data.Functor.Identity (Identity, runIdentity) +import Data.Traversable (Traversable) import Data.HashMap.Strict (HashMap) import Data.Hashable (Hashable) import Data.List (foldl') import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (mapMaybe) import Data.Text (Text) +import Data.Traversable + ( for + ) import Data.String (IsString(..)) import Data.Vector (Vector) import Debug.Trace (traceShow) @@ -129,6 +147,7 @@ import Prelude , ($) , (<$) , (&&) + , (||) , (+) , (-) , (*) @@ -140,6 +159,7 @@ import Prelude , error , filter , flip + , foldMap , foldr , foldr1 , fromIntegral @@ -155,6 +175,15 @@ import Prelude , zipWith ) +data Cofree f a = a :< f (Cofree f a) + deriving (Functor) + +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 + map :: Functor f => (a -> b) -> f a -> f b map = fmap diff --git a/src/T/Render.hs b/src/T/Render.hs index c756529..5ab7716 100644 --- a/src/T/Render.hs +++ b/src/T/Render.hs @@ -26,7 +26,7 @@ import Data.Text.Lazy.Builder qualified as Builder import Data.HashMap.Strict qualified as HashMap import Data.Vector ((!?), (//)) -import T.Exp (Cofree(..), Exp, ExpF(..), Literal(..), (:+)(..), Ann) +import T.Exp (Exp, ExpF(..), Literal(..), (:+)(..), Ann) import T.Exp.Ann (emptyAnn) import T.Error (Error(..), Warning(..)) import T.Name (Name(..)) @@ -131,7 +131,7 @@ renderTmpl = \case (HashMap.toList o)) pure (bool (Just xs) Nothing (List.null xs)) _ -> - throwError (TypeError exp Type.Iterable (Value.typeOf value) (sexp value)) + throwError (TagMismatch exp (Type.Var 0 (Set.fromList [Type.Iterable])) (Value.typeOf value) (sexp value)) case itemsQ of Nothing -> maybe (pure ()) renderTmpl elseTmpl @@ -169,7 +169,7 @@ renderExp exp = do Value.String str -> pure str _ -> - throwError (TypeError exp Type.Renderable (Value.typeOf value) (sexp value)) + throwError (TagMismatch exp (Type.Var 0 (Set.fromList [Type.Render])) (Value.typeOf value) (sexp value)) evalExp :: (Ctx m, MonadError Error m) => Exp -> m Value evalExp = \case @@ -223,7 +223,7 @@ evalExp = \case r <- enforceRecord exp case HashMap.lookup key r of Nothing -> - throwError (MissingProperty exp (sexp r) (sexp key)) + throwError (MissingField exp (sexp r) (sexp key)) Just x -> pure x @@ -234,7 +234,7 @@ enforceInt exp = do Value.Int xs -> pure xs _ -> - throwError (TypeError exp Type.Int (Value.typeOf v) (sexp v)) + throwError (TagMismatch exp Type.Int (Value.typeOf v) (sexp v)) enforceArray :: (Ctx m, MonadError Error m) => Exp -> m (Vector Value) enforceArray exp = do @@ -243,7 +243,7 @@ enforceArray exp = do Value.Array xs -> pure xs _ -> - throwError (TypeError exp Type.Array (Value.typeOf v) (sexp v)) + throwError (TagMismatch exp (Type.Array (Type.tyVar 0)) (Value.typeOf v) (sexp v)) enforceRecord :: (Ctx m, MonadError Error m) => Exp -> m (HashMap Name Value) enforceRecord exp = do @@ -252,7 +252,7 @@ enforceRecord exp = do Value.Record r -> pure r _ -> - throwError (TypeError exp Type.Record (Value.typeOf v) (sexp v)) + throwError (TagMismatch exp (Type.Record mempty) (Value.typeOf v) (sexp v)) evalApp :: (Ctx m, MonadError Error m) @@ -273,7 +273,7 @@ evalApp name@(ann0 :+ _) = go g exps -- in every other case something went wrong :-( go v _ = - throwError (TypeError (ann0 :< Var name) Type.Fun (Value.typeOf v) (sexp v)) + throwError (TagMismatch (ann0 :< Var name) (Type.tyVar 0 `Type.fun1` Type.tyVar 1) (Value.typeOf v) (sexp v)) data Path = Path { var :: Ann :+ Name @@ -320,7 +320,7 @@ evalLValue = Just v -> (Right v, path) Right v -> - throwError (TypeError exp Type.Record (Value.typeOf v) (sexp v)) + throwError (TagMismatch exp (Type.Array (Type.tyVar 0)) (Value.typeOf v) (sexp v)) Left name -> throwError (NotInScope name) _ :< Key exp0 key@(_ :+ key0) -> do @@ -336,7 +336,7 @@ evalLValue = Just v -> (Right v, path) Right v -> - throwError (TypeError exp Type.Record (Value.typeOf v) (sexp v)) + throwError (TagMismatch exp (Type.Record mempty) (Value.typeOf v) (sexp v)) Left name -> throwError (NotInScope name) @@ -393,9 +393,9 @@ insertVar Path {var = (ann :+ name), lookups} v = do [] -> pure (Value.Record (HashMap.insert (fromString (Name.toString key)) v r)) _ -> - throwError (MissingProperty (ann0 :< Lit Null) (sexp r) (sexp key)) + throwError (MissingField (ann0 :< Lit Null) (sexp r) (sexp key)) go v0 (K (ann0 :+ _key) : _path) = - throwError (TypeError (ann0 :< Lit Null) Type.Record (Value.typeOf v0) (sexp v0)) + throwError (TagMismatch (ann0 :< Lit Null) (Type.Record mempty) (Value.typeOf v0) (sexp v0)) go (Value.Array xs) (I (ann0 :+ idx) : path) = -- this is pretty similar to records except the lack of the aforementioned special -- treatment. @@ -406,7 +406,7 @@ insertVar Path {var = (ann :+ name), lookups} v = do Nothing -> throwError (OutOfBounds (ann0 :< Lit Null) (sexp xs) (sexp idx)) go v0 (I (ann0 :+ _idx) : _path) = - throwError (TypeError (ann0 :< Lit Null) Type.Record (Value.typeOf v0) (sexp v0)) + throwError (TagMismatch (ann0 :< Lit Null) (Type.Record mempty) (Value.typeOf v0) (sexp v0)) go _v0 [] = pure v diff --git a/src/T/Stdlib.hs b/src/T/Stdlib.hs index e730438..070c56b 100644 --- a/src/T/Stdlib.hs +++ b/src/T/Stdlib.hs @@ -13,12 +13,11 @@ module T.Stdlib , with , def , bindings + , typingCtx , Macro.macroFun , Macro.macroOp ) where -import Data.HashMap.Strict qualified as HashMap - import T.Name (Name) import T.Prelude import T.Stdlib.Fun (Fun(..)) @@ -27,6 +26,7 @@ import T.Stdlib.Macro (Macro(..)) import T.Stdlib.Macro qualified as Macro import T.Stdlib.Op (Op(..)) import T.Stdlib.Op qualified as Op +import T.Type (Γ) import T.Value (Value) @@ -45,4 +45,8 @@ with ops funs macros = Stdlib {..} bindings :: Stdlib -> HashMap Name Value bindings stdlib = - HashMap.fromList (Op.bindings stdlib.ops <> Fun.bindings stdlib.funs) + Op.bindings stdlib.ops <> Fun.bindings stdlib.funs + +typingCtx :: Stdlib -> Γ +typingCtx stdlib = + Op.typingCtx stdlib.ops <> Fun.typingCtx stdlib.funs diff --git a/src/T/Stdlib/Fun.hs b/src/T/Stdlib/Fun.hs index ebcd4f4..5029b53 100644 --- a/src/T/Stdlib/Fun.hs +++ b/src/T/Stdlib/Fun.hs @@ -4,6 +4,7 @@ module T.Stdlib.Fun ( Fun(..) , bindings + , typingCtx , functions ) where @@ -18,41 +19,80 @@ import T.Error (Error(..)) import T.Exp.Ann ((:+)(..), unann) import T.Name (Name) import T.Prelude +import T.Type (Γ, forAll, forAll_, fun1, fun2, tyVar) +import T.Type qualified as Type import T.Value (Value(..), display, displayWith) data Fun = Fun - { name :: Name - , binding :: Name -> Value + { name :: Name + , ascribed :: Type.Scheme + , binding :: Name -> Value } -bindings :: [Fun] -> [(Name, Value)] +bindings :: [Fun] -> HashMap Name Value bindings = - map (\fun -> (fun.name, fun.binding fun.name)) + HashMap.fromList . map (\fun -> (fun.name, fun.binding fun.name)) + +typingCtx :: [Fun] -> Γ +typingCtx = + HashMap.fromList . map (\fun -> (fun.name, fun.ascribed)) functions :: [Fun] functions = - [ Fun "empty?" nullB - , Fun "length" lengthB - - , Fun "floor" (flip embed0 (floor @Double @Int)) - , Fun "ceiling" (flip embed0 (ceiling @Double @Int)) - , Fun "round" (flip embed0 (round @Double @Int)) - , Fun "int->double" (flip embed0 (fromIntegral @Int @Double)) - - , Fun "upper-case" (flip embed0 Text.toUpper) - , Fun "lower-case" (flip embed0 Text.toLower) - , Fun "title-case" (flip embed0 Text.toTitle) - - , Fun "split" (flip embed0 Text.splitOn) - , Fun "join" (flip embed0 Text.intercalate) - , Fun "concat" (flip embed0 Text.concat) - , Fun "chunks-of" (flip embed0 Text.chunksOf) - - , Fun "die" dieB - - , Fun "show" (\_ -> showB) - , Fun "pp" (\_ -> ppB) + [ Fun "empty?" + (forAll [0] [(0, Type.Sizeable)] (tyVar 0 `fun1` Type.Bool)) + nullB + , Fun "length" + (forAll [0] [(0, Type.Sizeable)] (tyVar 0 `fun1` Type.Int)) + lengthB + + , Fun "floor" + (forAll_ (Type.Double `fun1` Type.Int)) + (embed0 (floor @Double @Int)) + , Fun "ceiling" + (forAll_ (Type.Double `fun1` Type.Int)) + (embed0 (ceiling @Double @Int)) + , Fun "round" + (forAll_ (Type.Double `fun1` Type.Int)) + (embed0 (round @Double @Int)) + , Fun "int->double" + (forAll_ (Type.Int `fun1` Type.Double)) + (embed0 (fromIntegral @Int @Double)) + + , Fun "upper-case" + (forAll_ (Type.String `fun1` Type.String)) + (embed0 Text.toUpper) + , Fun "lower-case" + (forAll_ (Type.String `fun1` Type.String)) + (embed0 Text.toLower) + , Fun "title-case" + (forAll_ (Type.String `fun1` Type.String)) + (embed0 Text.toTitle) + + , Fun "split" + (forAll_ ((Type.String, Type.String) `fun2` Type.Array Type.String)) + (embed0 Text.splitOn) + , Fun "join" + (forAll_ ((Type.String, Type.Array Type.String) `fun2` Type.String)) + (embed0 Text.intercalate) + , Fun "concat" + (forAll_ (Type.Array Type.String `fun1` Type.String)) + (embed0 Text.concat) + , Fun "chunks-of" + (forAll_ ((Type.Int, Type.String) `fun2` Type.Array Type.String)) + (embed0 Text.chunksOf) + + , Fun "die" + (forAll [0] [] (Type.String `fun1` tyVar 0)) + dieB + + , Fun "show" + (forAll [0] [(0, Type.Display)] (tyVar 0 `fun1` Type.String)) + (embed0 showB) + , Fun "pp" + (forAll [0] [(0, Type.Display)] (tyVar 0 `fun1` Type.String)) + (embed0 ppB) ] nullB :: Name -> Value diff --git a/src/T/Stdlib/Macro.hs b/src/T/Stdlib/Macro.hs index 190c372..0fc64c0 100644 --- a/src/T/Stdlib/Macro.hs +++ b/src/T/Stdlib/Macro.hs @@ -19,8 +19,7 @@ import Data.List qualified as List import Data.Map.Strict qualified as Map import T.Exp - ( Cofree(..) - , ExpF(..) + ( ExpF(..) , appE , appE_ , ifE @@ -93,8 +92,8 @@ or _ann args = -- function application macro: -- --- {{ x || f }} -> {{ f(x) }} --- {{ y || f(x) }} -> {{ f(x, y) }} +-- {{ x | f }} -> {{ f(x) }} +-- {{ y | f(x) }} -> {{ f(x, y) }} legacyApp :: Expansion legacyApp _ann = \case [expl, annf :< Var name] -> diff --git a/src/T/Stdlib/Op.hs b/src/T/Stdlib/Op.hs index 77ec7d7..e2c9a72 100644 --- a/src/T/Stdlib/Op.hs +++ b/src/T/Stdlib/Op.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeApplications #-} @@ -6,6 +7,7 @@ module T.Stdlib.Op , PriorityMap , Fixity(..) , bindings + , typingCtx , priorities , operators ) where @@ -25,12 +27,14 @@ import T.Exp.Ann ((:+)(..)) import T.Name (Name) import T.Prelude import T.SExp (sexp) +import T.Type (Γ, forAll, forAll_, fun1, fun2, tyVar) import T.Type qualified as Type import T.Value (Value(..), typeOf) data Op = Op { name :: Name + , ascribed :: Type.Scheme , binding :: Name -> Value , fixity :: Fixity , priority :: Int @@ -45,9 +49,13 @@ data Fixity | Infixr deriving (Show, Eq) -bindings :: [Op] -> [(Name, Value)] +bindings :: [Op] -> HashMap Name Value bindings = - map (\op -> (op.name, op.binding op.name)) + HashMap.fromList . map (\op -> (op.name, op.binding op.name)) + +typingCtx :: [Op] -> Γ +typingCtx = + HashMap.fromList . map (\op -> (op.name, op.ascribed)) priorities :: [Op] -> PriorityMap priorities = @@ -55,23 +63,49 @@ priorities = operators :: [Op] operators = - [ Op "!" (flip embed0 not) Prefix 8 - - , Op "==" (flip embed0 eq) Infix 4 - , Op "!=" (flip embed0 neq) Infix 4 - , Op "=~" (flip embed0 match) Infix 4 - - , Op "+" add Infixl 6 - , Op "-" subtract Infixl 6 - , Op "*" multiply Infixl 7 - , Op "/" divide Infixl 7 - - , Op "<" lt Infix 4 - , Op "<=" le Infix 4 - , Op ">" gt Infix 4 - , Op ">=" ge Infix 4 - - , Op "<>" (flip embed0 ((<>) @Text)) Infixr 6 + [ Op "!" + (forAll_ (Type.Bool `fun1` Type.Bool)) + (embed0 not) Prefix 8 + + , Op "==" + (forAll [0] [(0, Type.Eq)] ((tyVar 0, tyVar 0) `fun2` Type.Bool)) + (embed0 eq) Infix 4 + , Op "!=" + (forAll [0] [(0, Type.Eq)] ((tyVar 0, tyVar 0) `fun2` Type.Bool)) + (embed0 neq) Infix 4 + , Op "=~" + (forAll_ ((Type.String, Type.Regexp) `fun2` Type.Bool)) + (embed0 match) Infix 4 + + , Op "+" + (forAll [0] [(0, Type.Num)] ((tyVar 0, tyVar 0) `fun2` tyVar 0)) + add Infixl 6 + , Op "-" + (forAll [0] [(0, Type.Num)] ((tyVar 0, tyVar 0) `fun2` tyVar 0)) + subtract Infixl 6 + , Op "*" + (forAll [0] [(0, Type.Num)] ((tyVar 0, tyVar 0) `fun2` tyVar 0)) + multiply Infixl 7 + , Op "/" + (forAll [0] [(0, Type.Num)] ((tyVar 0, tyVar 0) `fun2` tyVar 0)) + divide Infixl 7 + + , Op "<" + (forAll [0] [(0, Type.Num)] ((tyVar 0, tyVar 0) `fun2` Type.Bool)) + lt Infix 4 + , Op "<=" + (forAll [0] [(0, Type.Num)] ((tyVar 0, tyVar 0) `fun2` Type.Bool)) + le Infix 4 + , Op ">" + (forAll [0] [(0, Type.Num)] ((tyVar 0, tyVar 0) `fun2` Type.Bool)) + gt Infix 4 + , Op ">=" + (forAll [0] [(0, Type.Num)] ((tyVar 0, tyVar 0) `fun2` Type.Bool)) + ge Infix 4 + + , Op "<>" + (forAll_ ((Type.String, Type.String) `fun2` Type.String)) + (embed0 ((<>) @Text)) Infixr 6 ] combineNumbers :: (Int -> Int -> Int) -> (Double -> Double -> Double) -> Name -> Value @@ -82,15 +116,15 @@ combineNumbers intOp doubleOp name = _ann :+ Int n1 -> pure (Int (n0 `intOp` n1)) ann :+ n -> - Left (TypeError (varE (ann :+ name)) Type.Int (typeOf n) (sexp n)) + Left (TagMismatch (varE (ann :+ name)) Type.Int (typeOf n) (sexp n)) _ann :+ Double n0 -> pure . Lam $ \case _ann :+ Double n1 -> pure (Double (n0 `doubleOp` n1)) ann :+ n -> - Left (TypeError (varE (ann :+ name)) Type.Double (typeOf n) (sexp n)) + Left (TagMismatch (varE (ann :+ name)) Type.Double (typeOf n) (sexp n)) ann :+ n -> - Left (TypeError (varE (ann :+ name)) Type.Number (typeOf n) (sexp n)) + Left (TagMismatch (varE (ann :+ name)) (Type.Var 0 [Type.Num]) (typeOf n) (sexp n)) add :: Name -> Value add = @@ -116,15 +150,15 @@ predicateNumbers intOp doubleOp name = _ann :+ Int n1 -> pure (Bool (n0 `intOp` n1)) ann :+ n -> - Left (TypeError (varE (ann :+ name)) Type.Int (typeOf n) (sexp n)) + Left (TagMismatch (varE (ann :+ name)) Type.Int (typeOf n) (sexp n)) _ann :+ Double n0 -> pure . Lam $ \case _ann :+ Double n1 -> pure (Bool (n0 `doubleOp` n1)) ann :+ n -> - Left (TypeError (varE (ann :+ name)) Type.Double (typeOf n) (sexp n)) + Left (TagMismatch (varE (ann :+ name)) Type.Double (typeOf n) (sexp n)) ann :+ n -> - Left (TypeError (varE (ann :+ name)) Type.Number (typeOf n) (sexp n)) + Left (TagMismatch (varE (ann :+ name)) (Type.Var 0 [Type.Num]) (typeOf n) (sexp n)) lt :: Name -> Value lt = diff --git a/src/T/Type.hs b/src/T/Type.hs index c077d0f..c12bb2c 100644 --- a/src/T/Type.hs +++ b/src/T/Type.hs @@ -1,27 +1,82 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedRecordDot #-} module T.Type - ( Type(..) + ( Γ + , Type(..) + , Scheme(..) + , Constraint(..) + , infer + , TypeError(..) + -- * stdlib helpers + , forAll + , forAll_ + , fun1 + , fun2 + , tyVar ) where +import Data.HashMap.Strict qualified as HashMap +import Data.Set (Set) +import Data.Set qualified as Set + import T.Prelude +import T.Type.Vocab + ( InferenceT(..) + , Γ + , TypeError(..) + , Type(..) + , freeVarsType + , Scheme(..) + , freeVarsScheme + , Constraint(..) + ) +import T.Type.Infer (infer) + + +forAll :: [Int] -> [(Int, Constraint)] -> Type -> Scheme +forAll qs cs t = do + let + cm = + HashMap.fromListWith Set.union (map (\(i, c) -> (i, Set.singleton c)) cs) + Forall (Set.fromList qs) (injectConstraints cm t) + +injectConstraints :: HashMap Int (Set Constraint) -> Type -> Type +injectConstraints cm t = case t of + Var n cs -> + Var n (cs <> HashMap.findWithDefault Set.empty n cm) + Array arr -> + Array (injectConstraints cm arr) + Record r -> + Record (map (injectConstraints cm) r) + Fun args r -> + Fun (map (injectConstraints cm) args) (injectConstraints cm r) + _ -> + t + +forAll_ :: Type -> Scheme +forAll_ = + forAll [] [] + +fun1 :: Type -> Type -> Type +fun1 a1 r = + Fun (a1 :| []) r + +fun2 :: (Type, Type) -> Type -> Type +fun2 (a1, a2) r = + Fun (a1 :| a2 : []) r +tyVar :: Int -> Type +tyVar n = + Var n mempty -data Type - -- real types first - = Null - | Bool - | Int - | Double - | String - | Regexp - | Array - | Record - | Fun - -- then pseudo-types - -- used in numeric operators - | Number - -- used in `for` and stdlib functions, polymorphic over - -- all containers - | Iterable - -- used in rendering values into text - | Renderable - deriving (Show, Eq) +generalize :: Monad m => Γ -> Type -> InferenceT m Scheme +generalize ctx t = do + let + fvs = + freeVarsType t + ctxvs = + foldMap freeVarsScheme ctx + qs = + Set.difference fvs ctxvs + pure (Forall qs t) diff --git a/src/T/Type/Infer.hs b/src/T/Type/Infer.hs new file mode 100644 index 0000000..de4cab0 --- /dev/null +++ b/src/T/Type/Infer.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE OverloadedRecordDot #-} +module T.Type.Infer + ( infer + ) where + +import Control.Monad (foldM) +import Control.Monad.Reader (ask) +import Control.Monad.Except (throwError) +import Data.HashMap.Strict qualified as HashMap + +import T.Exp (Exp, (:+)(..)) +import T.Exp qualified as Exp +import T.Name (Name) +import T.Prelude +import T.Tmpl (Tmpl(..)) +import T.Type.Vocab + ( InferenceT + , runInferenceT + , Γ + , Σ(..) + , emptyΣ + , freshVar + , TypeError(..) + , TypedExp + , Ann(..) + , Type(..) + , Scheme(..) + ) +import T.Type.Unify + ( unify + , replaceOnce + , finalize + ) + + +infer :: Γ -> Exp -> Either TypeError TypedExp +infer ctx exp = do + (te, finalΣ) <- runIdentity (runInferenceT ctx emptyΣ (inferExp exp)) + pure (finalize finalΣ.subst te) + +inferTmpl :: Monad m => Tmpl -> InferenceT m () +inferTmpl = \case + Raw _text -> + pure () + Comment _text -> + pure () + Exp exp -> do + _texp <- inferExp exp + pure () + +inferExp :: Monad m => Exp -> InferenceT m TypedExp +inferExp (ann0 :< e) = + case e of + Exp.Lit l -> do + t <- inferLiteral l + pure (annOf t :< Exp.Lit l) + + Exp.Var (ann :+ name) -> do + t <- lookupCtx name + pure (annOf t :< Exp.Var (Ann {spanned = ann, typed = t} :+ name)) + + Exp.If b0 t0 f0 -> do + b1@(tb :< _) <- inferExp b0 + _ <- unify tb.typed Bool + t1@(tt :< _) <- inferExp t0 + f1@(tf :< _) <- inferExp f0 + tu <- unify tt.typed tf.typed + pure (annOf tu :< Exp.If b1 t1 f1) + + Exp.App (ann :+ name) args0 -> do + args1 <- traverse inferExp args0 + t <- checkApp name args1 + pure (annOf t :< Exp.App (Ann {spanned = ann, typed = t} :+ name) args1) + + Exp.Idx arr0 idx0 -> do + arr1 <- inferExp arr0 + idx1 <- inferExp idx0 + t <- checkIdx arr1 idx1 + pure (annOf t :< Exp.Idx arr1 idx1) + + Exp.Key r0 (ann :+ name) -> do + r1 <- inferExp r0 + t <- checkKey r1 name + pure (annOf t :< Exp.Key r1 (Ann {spanned = ann, typed = t} :+ name)) + where + annOf inferred = + Ann {spanned = ann0, typed = inferred} + +checkApp :: Monad m => Name -> NonEmpty TypedExp -> InferenceT m Type +checkApp name args = do + ft <- lookupCtx name + r <- freshVar + _ <- unify ft (Fun (map extractType args) r) + pure r + +checkIdx :: Monad m => TypedExp -> TypedExp -> InferenceT m Type +checkIdx arr idx = do + e <- freshVar + _ <- unify (extractType arr) (Array e) + _ <- unify (extractType idx) Int + pure e + +checkKey :: Monad m => TypedExp -> Name -> InferenceT m Type +checkKey r name = do + case extractType r of + Record fields -> + case HashMap.lookup name fields of + Just t -> + pure t + Nothing -> + throwError (MissingField name) + var@(Var _n _cs) -> do + v <- freshVar + _ <- unify var (Record (HashMap.singleton name v)) + pure v + t -> + throwError (TypeMismatch (Record mempty) t) + +inferLiteral :: Monad m => Exp.Literal -> InferenceT m Type +inferLiteral = \case + Exp.Null -> pure Unit + Exp.Bool _ -> pure Bool + Exp.Int _ -> pure Int + Exp.Double _ -> pure Double + Exp.String _ -> pure String + Exp.Regexp _ -> pure Regexp + Exp.Array xs -> do + ys <- traverse inferExp xs + t <- case toList (map extractType ys) of + [] -> + freshVar + z : zs -> + foldM unify z zs + pure (Array t) + Exp.Record r -> do + ts <- traverse inferExp r + pure (Record (map extractType ts)) + +lookupCtx :: Monad m => Name -> InferenceT m Type +lookupCtx name = do + ctx <- ask + maybe (throwError (NotInScope name)) instantiate (HashMap.lookup name ctx) + +instantiate :: Monad m => Scheme -> InferenceT m Type +instantiate (Forall qs t) = do + fvs <- for (toList qs) $ \q -> do + fv <- freshVar + pure (q, fv) + pure (replaceOnce (HashMap.fromList fvs) t) + +extractType :: TypedExp -> Type +extractType (ann :< _e) = ann.typed diff --git a/src/T/Type/Unify.hs b/src/T/Type/Unify.hs new file mode 100644 index 0000000..ec491fb --- /dev/null +++ b/src/T/Type/Unify.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedRecordDot #-} +module T.Type.Unify + ( unify + , replace + , replaceOnce + , finalize + ) where + +import Control.Monad.Except (throwError) +import Control.Monad.State (gets, modify) +import Data.HashMap.Strict qualified as HashMap +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set (Set) +import Data.Set qualified as Set + +import T.Prelude +import T.Type.Vocab + ( InferenceT + , Σ(..) + , Subst + , TypedExp + , Ann(..) + , Type(..) + , TypeError(..) + , Constraint + , satisfies + ) + + +unify :: Monad m => Type -> Type -> InferenceT m Type +unify t1 t2 = do + s <- gets (.subst) + case (replace s t1, replace s t2) of + (a, b) + | a == b -> + pure a + (Var n cs, t) -> do + unifyVar s n cs t + (t, Var n cs) -> do + unifyVar s n cs t + (Array a, Array b) -> + map Array (unify a b) + (Record m1, Record m2) -> do + map Record (sequence (HashMap.intersectionWith unify m1 m2)) + (Fun args1 ret1, Fun args2 ret2) + | NonEmpty.length args1 == NonEmpty.length args2 -> + liftA2 Fun (sequence (NonEmpty.zipWith unify args1 args2)) (unify ret1 ret2) + (a, b) -> + throwError (TypeMismatch a b) + +unifyVar :: Monad m => Subst -> Int -> Set Constraint -> Type -> InferenceT m Type +unifyVar s n cs t0 = do + when (occurs n t0 s) (throwError (OccursCheck n t0)) + checkConstraints cs t0 + let + t = + applyConstraints cs t0 + extendSubst n t + pure t + +replace :: Subst -> Type -> Type +replace subst t = + case t of + Array arr -> + Array (replace subst arr) + Record r -> + Record (map (replace subst) r) + Fun args r -> + Fun (map (replace subst) args) (replace subst r) + Var n cs -> + case HashMap.lookup n subst of + Nothing -> + Var n cs + Just nt -> + applyConstraints cs (replace subst nt) + _ -> + t + +-- | 'replaceOnce' is a variant of 'replace' that doesn't +-- do deep substitution; this is necessary separate the namespaces +-- of quantified variables and unitification variables which is +-- useful for e.g. stdlib definitions +replaceOnce :: Subst -> Type -> Type +replaceOnce subst t = + case t of + Array arr -> + Array (replaceOnce subst arr) + Record r -> + Record (map (replaceOnce subst) r) + Fun args r -> + Fun (map (replaceOnce subst) args) (replaceOnce subst r) + Var n cs -> + case HashMap.lookup n subst of + Nothing -> + Var n cs + Just (Var m ds) -> + Var m (Set.union cs ds) + Just x -> + applyConstraints cs x + _ -> + t + +occurs :: Int -> Type -> Subst -> Bool +occurs n t subst = + case replace subst t of + Var m _cs -> + n == m + Array arr -> + occurs n arr subst + Record r -> + any (\t' -> occurs n t' subst) r + Fun args r -> + any (\a -> occurs n a subst) args || occurs n r subst + _ -> + False + +checkConstraints :: Monad m => Set Constraint -> Type -> InferenceT m () +checkConstraints cs t = do + for_ cs $ \c -> + unless (satisfies c t) (throwError (ConstraintViolation c t)) + +applyConstraints :: Set Constraint -> Type -> Type +applyConstraints cs = \case + Var n vcs -> + Var n (Set.union vcs cs) + t -> + t + +extendSubst :: Monad m => Int -> Type -> InferenceT m () +extendSubst n t = + modify (\s -> s {subst = HashMap.insert n t s.subst}) + +finalize :: Subst -> TypedExp -> TypedExp +finalize subst = + map (\ann -> ann {typed = defaultType (replace subst ann.typed)}) + +defaultType :: Type -> Type +defaultType = \case + Var {} -> + Unit + Array t -> + Array (defaultType t) + Record r -> + Record (map defaultType r) + t -> + t diff --git a/src/T/Type/Vocab.hs b/src/T/Type/Vocab.hs new file mode 100644 index 0000000..7771a54 --- /dev/null +++ b/src/T/Type/Vocab.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedRecordDot #-} +module T.Type.Vocab + ( InferenceT(..) + , runInferenceT + , Γ + , Σ(..) + , Subst + , emptyΣ + , freshVar + , TypeError(..) + , TypedExp + , Ann(..) + , Type(..) + , freeVarsType + , Scheme(..) + , freeVarsScheme + , Constraint(..) + , satisfies + ) where + +import Control.Monad.Reader (ReaderT, MonadReader, runReaderT) +import Control.Monad.State (StateT, MonadState, runStateT, gets, modify) +import Control.Monad.Except (ExceptT, MonadError, runExceptT) +import Data.HashMap.Strict qualified as HashMap +import Data.List qualified as List +import Data.Set (Set) +import Data.Set qualified as Set +import Text.Printf (printf) +import Text.Trifecta (Span) + +import T.Exp qualified as Exp +import T.Name (Name) +import T.Prelude +import T.SExp (sexp) +import T.SExp qualified as SExp + + +newtype InferenceT m a = InferenceT (ReaderT Γ (StateT Σ (ExceptT TypeError m)) a) + deriving (Functor, Applicative, Monad, MonadReader Γ, MonadState Σ, MonadError TypeError) + +runInferenceT :: Γ -> Σ -> InferenceT m a -> m (Either TypeError (a, Σ)) +runInferenceT ctx subst (InferenceT m) = + runExceptT (runStateT (runReaderT m ctx) subst) + +type Γ = HashMap Name Scheme + +data Σ = Σ + { subst :: Subst + , counter :: Int + } deriving (Show, Eq) + +type Subst = HashMap Int Type + +emptyΣ :: Σ +emptyΣ = Σ + { subst = mempty + , counter = 0 + } + +freshVar :: Monad m => InferenceT m Type +freshVar = do + n <- gets (.counter) + modify (\s -> s { counter = s.counter + 1 }) + pure (Var n mempty) + +data TypeError + = NotInScope Name + | MissingField Name + | TypeMismatch Type Type + | ConstraintViolation Constraint Type + | OccursCheck Int Type + deriving (Show, Eq) + +type TypedExp = Cofree (Exp.ExpF Ann) Ann + +data Ann = Ann + { spanned :: Span + , typed :: Type + } deriving (Show, Eq) + +data Type + = Unit + | Bool + | Int + | Double + | String + | Regexp + | Array Type + | Record (HashMap Name Type) + | Fun (NonEmpty Type) Type + | Var Int (Set Constraint) + deriving (Show, Eq) + +instance SExp.To Type where + sexp = \case + Unit -> + "unit" + Bool -> + "bool" + Int -> + "int" + Double -> + "double" + String -> + "string" + Regexp -> + "regexp" + Array t -> + SExp.square [sexp t] + Record fs -> + SExp.curly (concatMap (\(k, v) -> [sexp k, sexp v]) (HashMap.toList fs)) + Fun args r -> + SExp.round ["->", SExp.square (toList (map sexp args)), sexp r] + Var n cs + | Set.null cs -> + fromString (printf "#%d" n) + | otherwise -> + fromString (printf "#%d{%s}" n (List.intercalate ", " (map showConstraint (toList cs)))) + where + showConstraint = \case + Num -> "num" :: String + Eq -> "eq" + Render -> "render" + Display -> "display" + Sizeable -> "sizeable" + Iterable -> "iterable" + + +data Scheme = Forall (Set Int) Type + deriving (Show, Eq) + +freeVarsType :: Type -> Set Int +freeVarsType = \case + Var n _cs -> + Set.singleton n + Array t -> + freeVarsType t + Record r -> + foldMap freeVarsType r + Fun args r -> + foldMap freeVarsType args <> freeVarsType r + _ -> + Set.empty + +freeVarsScheme :: Scheme -> Set Int +freeVarsScheme (Forall qs t) = + Set.difference (freeVarsType t) qs + +data Constraint + = Num + | Eq + | Render -- can be rendered directly as the value of a {{ }} chunk + | Display -- i.e. Show + | Sizeable + | Iterable + deriving (Show, Eq, Ord) + +satisfies :: Constraint -> Type -> Bool +satisfies = \case + Num -> \case + Int -> True + Double -> True + Var _n cs -> Num `Set.member` cs + _ -> False + Eq -> \case + Unit -> True + Bool -> True + Int -> True + Double -> True + String -> True + Regexp -> True + Array t -> + satisfies Eq t + Record fs -> + all (satisfies Eq) fs + Var _n cs -> Eq `Set.member` cs + _ -> False + Render -> \case + Unit -> True + Bool -> True + Int -> True + Double -> True + String -> True + Var _n cs -> Render `Set.member` cs + _ -> False + Display -> \case + Unit -> True + Bool -> True + Int -> True + Double -> True + String -> True + Array t -> + satisfies Display t + Record fs -> + all (satisfies Display) fs + Var _n cs -> Display `Set.member` cs + _ -> False + Sizeable -> \case + String -> True + Array _ -> True + Record _ -> True + Var _n cs -> Sizeable `Set.member` cs + _ -> False + Iterable -> \case + Array _ -> True + Record _ -> True + Var _n cs -> Iterable `Set.member` cs + _ -> False diff --git a/src/T/Value.hs b/src/T/Value.hs index ff13f5e..10d9a93 100644 --- a/src/T/Value.hs +++ b/src/T/Value.hs @@ -95,15 +95,22 @@ displayWith f = typeOf :: Value -> Type typeOf = \case - Null -> Type.Null + Null -> Type.Unit Bool _ -> Type.Bool Int _ -> Type.Int Double _ -> Type.Double String _ -> Type.String Regexp _ -> Type.Regexp - Array _ -> Type.Array - Record _ -> Type.Record - Lam _ -> Type.Fun + Array xs -> + case toList xs of + [] -> + Type.Array (Type.tyVar 0) + x : _xs -> + Type.Array (typeOf x) + Record fields -> + Type.Record (map typeOf fields) + Lam _ -> + Type.Fun (error "args") (error "result") embedAeson :: Aeson.Value -> Value embedAeson = \case diff --git a/t.cabal b/t.cabal index 1332462..f21477c 100644 --- a/t.cabal +++ b/t.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack @@ -63,6 +63,9 @@ library T.Stdlib.Op T.Tmpl T.Type + T.Type.Infer + T.Type.Unify + T.Type.Vocab T.Value Meta_t other-modules: diff --git a/test/T/Parse/AnnSpec.hs b/test/T/Parse/AnnSpec.hs index 587ea76..d2b1cae 100644 --- a/test/T/Parse/AnnSpec.hs +++ b/test/T/Parse/AnnSpec.hs @@ -12,74 +12,74 @@ spec = context "literals" $ do it "null" $ errorOf "{{ null + 1 }}" `shouldBe` - "(interactive):1:4: error: mismatched types in +: \n\ - \ expected: Number\n\ - \ but got: null : Null\n\ + "(interactive):1:4: error: mismatched [rendertime] types in +: \n\ + \ expected: #0{num}\n\ + \ but got: null : unit\n\ \1 | {{ null + 1 }} \n\ \ | ~~~~ " it "bool" $ errorOf "{{ true + 1 }}" `shouldBe` - "(interactive):1:4: error: mismatched types in +: \n\ - \ expected: Number\n\ - \ but got: true : Bool\n\ + "(interactive):1:4: error: mismatched [rendertime] types in +: \n\ + \ expected: #0{num}\n\ + \ but got: true : bool\n\ \1 | {{ true + 1 }} \n\ \ | ~~~~ " it "int" $ errorOf "{{ 1 <> \"foo\" }}" `shouldBe` - "(interactive):1:4: error: mismatched types in <>: \n\ - \ expected: String\n\ - \ but got: 1 : Int\n\ + "(interactive):1:4: error: mismatched [rendertime] types in <>: \n\ + \ expected: string\n\ + \ but got: 1 : int\n\ \1 | {{ 1 <> \"foo\" }} \n\ \ | ~ " it "double" $ errorOf "{{ 1.0 <> \"foo\" }}" `shouldBe` - "(interactive):1:4: error: mismatched types in <>: \n\ - \ expected: String\n\ - \ but got: 1.0 : Double\n\ + "(interactive):1:4: error: mismatched [rendertime] types in <>: \n\ + \ expected: string\n\ + \ but got: 1.0 : double\n\ \1 | {{ 1.0 <> \"foo\" }} \n\ \ | ~~~ " it "string" $ errorOf "{{ \"foo\" + 1 }}" `shouldBe` - "(interactive):1:4: error: mismatched types in +: \n\ - \ expected: Number\n\ - \ but got: \"foo\" : String\n\ + "(interactive):1:4: error: mismatched [rendertime] types in +: \n\ + \ expected: #0{num}\n\ + \ but got: \"foo\" : string\n\ \1 | {{ \"foo\" + 1 }} \n\ \ | ~~~~~ " it "regexp" $ do errorOf "{{ /foo/ + 1 }}" `shouldBe` - "(interactive):1:4: error: mismatched types in +: \n\ - \ expected: Number\n\ - \ but got: (regexp \"foo\") : Regexp\n\ + "(interactive):1:4: error: mismatched [rendertime] types in +: \n\ + \ expected: #0{num}\n\ + \ but got: (regexp \"foo\") : regexp\n\ \1 | {{ /foo/ + 1 }} \n\ \ | ~~~~~ " it "array" $ do errorOf "{{ [1,2,3] + 1 }}" `shouldBe` - "(interactive):1:4: error: mismatched types in +: \n\ - \ expected: Number\n\ - \ but got: [1 2 3] : Array\n\ + "(interactive):1:4: error: mismatched [rendertime] types in +: \n\ + \ expected: #0{num}\n\ + \ but got: [1 2 3] : [int]\n\ \1 | {{ [1,2,3] + 1 }} \n\ \ | ~~~~~~~ " it "record" $ do errorOf "{{ {foo:4} + 1 }}" `shouldBe` - "(interactive):1:4: error: mismatched types in +: \n\ - \ expected: Number\n\ - \ but got: {foo 4} : Record\n\ + "(interactive):1:4: error: mismatched [rendertime] types in +: \n\ + \ expected: #0{num}\n\ + \ but got: {foo 4} : {foo int}\n\ \1 | {{ {foo:4} + 1 }} \n\ \ | ~~~~~~~ " context "property access" $ do it "record" $ do errorOf "{% set foo = {} foo.bar = [] %}{{ foo.bar }}" `shouldBe` - "(interactive):1:38: error: mismatched types:\n\ - \ expected: Renderable\n\ - \ but got: [] : Array\n\ + "(interactive):1:38: error: mismatched [rendertime] types:\n\ + \ expected: #0{render}\n\ + \ but got: [] : [#0]\n\ \1 | {% set foo = {} foo.bar = [] %}{{ foo.bar }} \n\ \ | ~~~~ " diff --git a/test/T/RenderSpec.hs b/test/T/RenderSpec.hs index 1219d12..f21fd31 100644 --- a/test/T/RenderSpec.hs +++ b/test/T/RenderSpec.hs @@ -24,6 +24,7 @@ import T.Stdlib (def) import T.Stdlib qualified as Stdlib import T.Stdlib.Op qualified as Op import T.SExp (sexp) +import T.Type (forAll_, fun1, fun2) import T.Type qualified as Type import T.Value (embedAeson) @@ -64,9 +65,9 @@ spec = r_ "{{ [1,2,3][0] }}" `shouldRender` "1" r_ "{{ [[1,2],[3]][0][1] }}" `shouldRender` "2" r_ "{{ 4[0] }}" `shouldRaise` - TypeError (litE_ (Int 4)) Type.Array Type.Int "4" + TagMismatch (litE_ (Int 4)) (Type.Array (Type.tyVar 0)) Type.Int "4" r_ "{{ [1,2,3][\"foo\"] }}" `shouldRaise` - TypeError (litE_ (String "foo")) Type.Int Type.String "\"foo\"" + TagMismatch (litE_ (String "foo")) Type.Int Type.String "\"foo\"" r_ "{{ [1,2,3][-1] }}" `shouldRaise` OutOfBounds (int (-1)) (sexp (array [int 1, int 2, int 3])) "-1" context "keying" $ @@ -75,8 +76,8 @@ spec = r_ "{{ {foo: [1,2,3]}.foo[0] }}" `shouldRender` "1" r_ "{{ {foo: [1,{bar: 7},3]}.foo[1].bar }}" `shouldRender` "7" r_ "{{ 4.foo }}" `shouldRaise` - TypeError (litE_ (Int 4)) Type.Record Type.Int "4" - r_ "{{ {}.foo }}" `shouldRaise` MissingProperty (record mempty) (sexp (record mempty)) "foo" + TagMismatch (litE_ (Int 4)) (Type.Record mempty) Type.Int "4" + r_ "{{ {}.foo }}" `shouldRaise` MissingField (record mempty) (sexp (record mempty)) "foo" context "line blocks" $ it "examples" $ do @@ -266,16 +267,20 @@ spec = r_ "{{ \"Foo\" =~ /foo/i }}" `shouldRender` "true" it "not-iterable" $ - r_ "{% for x in 4 %}{% endfor %}" `shouldRaise` TypeError (litE_ (Int 4)) Type.Iterable Type.Int "4" + r_ "{% for x in 4 %}{% endfor %}" `shouldRaise` + TagMismatch (litE_ (Int 4)) (Type.Var 0 [Type.Iterable]) Type.Int "4" it "not-renderable" $ - r_ "{{ [] }}" `shouldRaise` TypeError (array []) Type.Renderable Type.Array (sexp (array [])) + r_ "{{ [] }}" `shouldRaise` + TagMismatch (array []) (Type.Var 0 [Type.Render]) (Type.Array (Type.tyVar 0)) (sexp (array [])) it "not-a-function" $ - rWith [aesonQQ|{f: "foo"}|] "{{ f(4) }}" `shouldRaise` TypeError (varE "f") Type.Fun Type.String "\"foo\"" + rWith [aesonQQ|{f: "foo"}|] "{{ f(4) }}" `shouldRaise` + TagMismatch (varE "f") (Type.tyVar 0 `Type.fun1` Type.tyVar 1) Type.String "\"foo\"" it "type errors" $ - r_ "{{ bool01(\"foo\") }}" `shouldRaise` TypeError (varE "bool01") Type.Bool Type.String "\"foo\"" + r_ "{{ bool01(\"foo\") }}" `shouldRaise` + TagMismatch (varE "bool01") Type.Bool Type.String "\"foo\"" it "defined?" $ rWith [aesonQQ|{foo: {}}|] "{{ defined?(foo.bar.baz) }}" `shouldRender` "false" @@ -406,13 +411,19 @@ rWith json tmplStr = do opExt :: [Stdlib.Op] opExt = - [ Stdlib.Op "<+>" (flip embed0 (\str0 str1 -> str0 <> "+" <> str1 :: Text)) Stdlib.Infixr 6 + [ Stdlib.Op "<+>" + (forAll_ ((Type.String, Type.String) `fun2` Type.String)) + (embed0 (\str0 str1 -> str0 <> "+" <> str1 :: Text)) Stdlib.Infixr 6 ] funExt :: [Stdlib.Fun] funExt = - [ Stdlib.Fun "bool01" (flip embed0 (bool @Int 0 1)) - , Stdlib.Fun "const" (flip embed0 (const @Bool @Text)) + [ Stdlib.Fun "bool01" + (forAll_ (Type.Bool `fun1` Type.Int)) + (embed0 (bool @Int 0 1)) + , Stdlib.Fun "const" + (forAll_ (Type.Bool `fun1` Type.String)) + (embed0 (const @Bool @Text)) ] macroExt :: [Stdlib.Macro]