Add records to the Inferno language

inferno-core/app/Main.hs

@@ -16,15 +16,23 @@ main :: IO ()
 main = do
   file <- head <$> getArgs
   src <- Text.readFile file
-  Interpreter {evalExpr, defaultEnv, parseAndInferTypeReps} <-
+  Interpreter {evalExpr, defaultEnv, parseAndInferTypeReps, parseAndInfer} <-
     mkInferno builtinModules [] :: IO (Interpreter IO ())
-  case parseAndInferTypeReps src of
+  case parseAndInfer src of
     Left err -> do
       hPutStrLn stderr $ show err
       exitFailure
-    Right ast -> do
-      evalExpr defaultEnv Map.empty ast >>= \case
-        Left err -> do
-          hPutStrLn stderr $ show err
-          exitFailure
-        Right res -> showPretty res
+    Right (ast, ty, _, _) -> do
+      putStrLn "Inferred type:"
+      showPretty ty
+
+-- case parseAndInferTypeReps src of
+--   Left err -> do
+--     hPutStrLn stderr $ show err
+--     exitFailure
+--   Right ast -> do
+--     evalExpr defaultEnv Map.empty ast >>= \case
+--       Left err -> do
+--         hPutStrLn stderr $ show err
+--         exitFailure
+--       Right res -> showPretty res

inferno-core/inferno-core.cabal

@@ -46,7 +46,7 @@ library
     , Inferno.Utils.QQ.Common
   hs-source-dirs:
       src
-  ghc-options: -Wall -Wunused-packages -Wincomplete-uni-patterns -Wincomplete-record-updates
+  ghc-options: -Wall -Wunused-packages -Wincomplete-uni-patterns -Wincomplete-record-updates -Wincomplete-patterns
   build-depends:
       base                      >= 4.13 && < 4.17
     , bimap                     >= 0.5.0 && < 0.6

inferno-core/src/Inferno/Eval.hs

@@ -24,24 +24,13 @@ import Inferno.Types.Syntax
     InfernoType (TBase),
     Lit (LDouble, LHex, LInt, LText),
     Pat (..),
+    Scoped (LocalScope),
     tListToList,
     toEitherList,
   )
 import Inferno.Types.Value
   ( ImplEnvM,
-    Value
-      ( VArray,
-        VDouble,
-        VEmpty,
-        VEnum,
-        VFun,
-        VInt,
-        VOne,
-        VText,
-        VTuple,
-        VTypeRep,
-        VWord64
-      ),
+    Value (..),
     runImplEnvM,
   )
 import Inferno.Types.VersionControl (VCObjectHash)
@@ -204,6 +193,16 @@ eval env@(localEnv, pinnedEnv) expr = case expr of
       _ -> throwM $ RuntimeError "failed to match with a bool"
   Tuple_ es ->
     foldrM (\(e, _) vs -> eval env e >>= return . (: vs)) [] (tListToList es) >>= return . VTuple
+  Record_ fs -> do
+    valMap <- foldrM (\(f, e, _) vs -> eval env e >>= \v -> return ((f, v) : vs)) [] fs
+    return $ VRecord $ Map.fromList valMap
+  RecordField_ (Ident r) f -> do
+    eval env (Var undefined Nothing LocalScope $ Expl $ ExtIdent $ Right r) >>= \case
+      VRecord fs -> do
+        case Map.lookup f fs of
+          Just v -> return v
+          Nothing -> throwM $ RuntimeError "record field not found"
+      _ -> throwM $ RuntimeError "failed to match with a record"
   One_ e -> eval env e >>= return . VOne
   Empty_ -> return $ VEmpty
   Assert_ cond e ->

inferno-core/src/Inferno/Infer/Env.hs

@@ -30,7 +30,7 @@ import Data.Foldable (Foldable (foldl'))
 import Data.List (nub)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import Inferno.Types.Syntax (ExtIdent)
+import Inferno.Types.Syntax (ExtIdent, RestOfRecord (RowAbsent, RowVar))
 import Inferno.Types.Type
   ( ImplType (..),
     InfernoType (..),
@@ -131,6 +131,8 @@ fv (TArray t) = fv t
 fv (TSeries t) = fv t
 fv (TOptional t) = fv t
 fv (TTuple ts) = foldr ((++) . fv) [] ts
+fv (TRecord ts RowAbsent) = concatMap fv ts
+fv (TRecord ts (RowVar a)) = foldr ((++) . fv) [a] ts
 fv (TRep t) = fv t
 
 normtype :: Map.Map TV TV -> InfernoType -> InfernoType
@@ -140,6 +142,11 @@ normtype ord (TArray a) = TArray $ normtype ord a
 normtype ord (TSeries a) = TSeries $ normtype ord a
 normtype ord (TOptional a) = TOptional $ normtype ord a
 normtype ord (TTuple as) = TTuple $ fmap (normtype ord) as
+normtype ord (TRecord as RowAbsent) = TRecord (fmap (normtype ord) as) RowAbsent
+normtype ord (TRecord as (RowVar a)) =
+  case Map.lookup a ord of
+    Just x -> TRecord (fmap (normtype ord) as) (RowVar x)
+    Nothing -> TRecord (fmap (normtype ord) as) (RowVar a)
 normtype ord (TRep a) = TRep $ normtype ord a
 normtype ord (TVar a) =
   case Map.lookup a ord of

inferno-core/src/Inferno/Infer/Pinned.hs

@@ -152,6 +152,11 @@ pinExpr m expr =
         InterpolatedString p1 xs p2 -> do
           xs' <- mapM (\(p3, e, p4) -> (\e' -> (p3, e', p4)) <$> pinExpr m e) xs
           pure $ InterpolatedString p1 xs' p2
+        Record p1 es p2 -> do
+          es' <- mapM (\(f, e, p3) -> (f,,p3) <$> pinExpr m e) es
+          pure $ Record p1 es' p2
+        RecordField p1 r p2 f ->
+          pure $ RecordField p1 r p2 f
         Array p1 es p2 -> do
           es' <- mapM (\(e, p3) -> (,p3) <$> pinExpr m e) es
           pure $ Array p1 es' p2

inferno-core/src/Inferno/Instances/Arbitrary.hs

@@ -49,6 +49,7 @@ import Inferno.Types.Syntax
     ModuleName (..),
     OpsTable,
     Pat (..),
+    RestOfRecord,
     Scoped (..),
     SomeIStr (..),
     TList (..),
@@ -105,9 +106,9 @@ baseOpsTable :: OpsTable
 baseOpsTable = Prelude.baseOpsTable @IO @() $ Prelude.builtinModules @IO @()
 
 -- | Arbitrary and ToADTArbitrary instances for Inferno.Types.Module
-deriving instance Arbitrary objs => ToADTArbitrary (Module.Module objs)
+deriving instance (Arbitrary objs) => ToADTArbitrary (Module.Module objs)
 
-deriving via (GenericArbitrary (Module.Module objs)) instance Arbitrary objs => Arbitrary (Module.Module objs)
+deriving via (GenericArbitrary (Module.Module objs)) instance (Arbitrary objs) => Arbitrary (Module.Module objs)
 
 -- | Arbitrary and ToADTArbitrary instances for Inferno.Types.Syntax
 deriving instance ToADTArbitrary TV
@@ -137,6 +138,10 @@ instance Arbitrary BaseType where
               ]
           )
 
+deriving instance ToADTArbitrary RestOfRecord
+
+deriving via (GenericArbitrary RestOfRecord) instance Arbitrary RestOfRecord
+
 deriving instance ToADTArbitrary InfernoType
 
 instance Arbitrary InfernoType where
@@ -227,7 +232,7 @@ deriving instance ToADTArbitrary Fixity
 
 deriving via (GenericArbitrary Fixity) instance Arbitrary Fixity
 
-instance Arbitrary pos => Arbitrary (Comment pos) where
+instance (Arbitrary pos) => Arbitrary (Comment pos) where
   shrink = shrinkNothing
   arbitrary =
     oneof
@@ -252,26 +257,26 @@ instance Arbitrary Lit where
         LHex <$> arbitrary
       ]
 
-deriving instance Arbitrary a => ToADTArbitrary (TList a)
+deriving instance (Arbitrary a) => ToADTArbitrary (TList a)
 
-instance Arbitrary a => Arbitrary (TList a) where
+instance (Arbitrary a) => Arbitrary (TList a) where
   arbitrary =
     oneof
       [ pure TNil,
         TCons <$> arbitrary <*> arbitrary <*> listOf arbitrary
       ]
 
-instance Arbitrary a => Arbitrary (SomeIStr a) where
+instance (Arbitrary a) => Arbitrary (SomeIStr a) where
   arbitrary = sized $ \n -> do
     k <- choose (0, n)
     oneof [SomeIStr <$> goT k, SomeIStr <$> goF k]
     where
-      goT :: Arbitrary a => Int -> Gen (IStr 'True a)
+      goT :: (Arbitrary a) => Int -> Gen (IStr 'True a)
       goT = \case
         0 -> pure ISEmpty
         n -> oneof [ISExpr <$> arbitrary <*> goT (n - 1), ISExpr <$> arbitrary <*> goF (n - 1)]
 
-      goF :: Arbitrary a => Int -> Gen (IStr 'False a)
+      goF :: (Arbitrary a) => Int -> Gen (IStr 'False a)
       goF = \case
         0 -> ISStr <$> arbitrary <*> pure ISEmpty
         n -> ISStr <$> arbitrary <*> goT (n - 1)
@@ -299,7 +304,7 @@ instance Arbitrary a => Arbitrary (SomeIStr a) where
 --   Perhaps the best way would be to use a size bound on the recursive constructors like "ICommentAbove"
 -- deriving instance Arbitrary pos => ToADTArbitrary (Import pos)
 -- deriving via (GenericArbitrary (Import pos)) instance Arbitrary pos => Arbitrary (Import pos)
-instance Arbitrary pos => Arbitrary (Import pos) where
+instance (Arbitrary pos) => Arbitrary (Import pos) where
   shrink = shrinkNothing
   arbitrary =
     oneof
@@ -308,9 +313,9 @@ instance Arbitrary pos => Arbitrary (Import pos) where
         IEnum <$> arbitrary <*> arbitrary <*> arbitrary
       ]
 
-deriving instance Arbitrary a => ToADTArbitrary (Scoped a)
+deriving instance (Arbitrary a) => ToADTArbitrary (Scoped a)
 
-deriving via (GenericArbitrary (Scoped a)) instance Arbitrary a => Arbitrary (Scoped a)
+deriving via (GenericArbitrary (Scoped a)) instance (Arbitrary a) => Arbitrary (Scoped a)
 
 -- NOTE: this instance doesn't generate all Exprs, it only generates some valid ones
 -- This is because the parser tests use this. However, golden tests in theory should
@@ -362,7 +367,7 @@ instance (Arbitrary hash, Arbitrary pos) => Arbitrary (Expr hash pos) where
           <*> (arbitrarySized $ n `div` 3)
         where
           -- Don't generate implicit vars. Sorry, there must be a nicer way to do this
-          arbitraryLamVars :: Arbitrary pos => Gen (NonEmpty (pos, Maybe ExtIdent))
+          arbitraryLamVars :: (Arbitrary pos) => Gen (NonEmpty (pos, Maybe ExtIdent))
           arbitraryLamVars = arbitrary `suchThat` (all isSomeRight . snd . NonEmpty.unzip)
           isSomeRight (Just (ExtIdent (Right _))) = True
           isSomeRight _ = False
@@ -626,9 +631,9 @@ deriving instance ToADTArbitrary VersionControl.VCObjectHash
 instance Arbitrary VersionControl.VCObjectHash where
   arbitrary = VersionControl.VCObjectHash . hash . Char8.pack <$> arbitrary
 
-deriving instance Arbitrary a => ToADTArbitrary (VersionControl.Pinned a)
+deriving instance (Arbitrary a) => ToADTArbitrary (VersionControl.Pinned a)
 
-deriving via (GenericArbitrary (VersionControl.Pinned a)) instance Arbitrary a => Arbitrary (VersionControl.Pinned a)
+deriving via (GenericArbitrary (VersionControl.Pinned a)) instance (Arbitrary a) => Arbitrary (VersionControl.Pinned a)
 
 -- | Arbitrary and ToADTArbitrary instances for Inferno.VersionControl.Types
 deriving instance ToADTArbitrary VersionControl.VCObject

inferno-core/src/Inferno/Parse.hs

@@ -215,7 +215,7 @@ enumConstructor =
     <?> "an enum constructor\nfor example: #true, #false"
 
 -- | 'signedInteger' parses an integer with an optional sign (with no space)
-signedInteger :: Num a => Parser a
+signedInteger :: (Num a) => Parser a
 signedInteger = Lexer.signed (takeWhileP Nothing isHSpace *> pure ()) Lexer.decimal
 
 -- | 'signedInteger' parses a float/double with an optional sign (with no space)
@@ -336,7 +336,7 @@ arrayComprE = label "array builder\nfor example: [n * 2 + 1 | n <- range 0 10, i
       ifPos <- getSourcePos
       (ifPos,) <$> (rword "if" *> expr)
 
-array :: SomeParser r a -> SomeParser r (SourcePos, [(a, Maybe SourcePos)], SourcePos)
+array :: Parser a -> Parser (SourcePos, [(a, Maybe SourcePos)], SourcePos)
 array p = label "array\nfor example: [1,2,3,4,5]" $
   lexeme $ do
     startPos <- getSourcePos
@@ -362,6 +362,36 @@ array p = label "array\nfor example: [1,2,3,4,5]" $
           )
         <|> pure []
 
+record :: Parser a -> Parser (SourcePos, [(Ident, a, Maybe SourcePos)], SourcePos)
+record p = label "record\nfor example: {name: \"Zaphod\", age: 391}" $
+  lexeme $ do
+    startPos <- getSourcePos
+    symbol "{"
+    args <- argsE
+    endPos <- getSourcePos
+    char '}'
+    return (startPos, args, endPos)
+  where
+    argsE =
+      try
+        ( do
+            f <- lexeme $ Ident <$> variable
+            symbol ":"
+            e <- p
+            commaPos <- getSourcePos
+            symbol ","
+            es <- argsE
+            return ((f, e, Just commaPos) : es)
+        )
+        <|> try
+          ( do
+              f <- lexeme $ Ident <$> variable
+              symbol ":"
+              e1 <- p
+              return [(f, e1, Nothing)]
+          )
+        <|> pure []
+
 mkInterpolatedString :: [Either Text e] -> [Either Text e]
 mkInterpolatedString [] = []
 mkInterpolatedString (Left x : Left y : xs) = mkInterpolatedString (Left (x <> y) : xs)
@@ -647,13 +677,23 @@ bracketedE = do
         [(e, _)] -> Bracketed startPos e endPos
         _ -> Tuple startPos (tListFromList es) endPos
 
+recordFieldE :: Parser (Expr () SourcePos)
+recordFieldE = label "a record field access expression\nfor example: rec.field" $ do
+  startPos <- getSourcePos
+  r <- Ident <$> variable
+  char ':'
+  fieldPos <- getSourcePos
+  f <- lexeme $ Ident <$> variable
+  return $ RecordField startPos r fieldPos f
+
 term :: Parser (Expr () SourcePos)
 term =
   bracketedE
     <|> try (hexadecimal Lit)
     <|> try doubleE
     <|> intE
     <|> enumE Enum
+    <|> try recordFieldE -- Try record:field first so that record isn't parsed as Var
     <|> do
       -- Variable: foo or Mod.foo or Mod.(+)
       startPos <- getSourcePos
@@ -687,6 +727,7 @@ term =
     <|> stringE Lit
     <|> interpolatedStringE
     <|> (try (uncurry3 Array <$> array expr))
+    <|> try (uncurry3 Record <$> record expr)
     <|> arrayComprE
 
 app :: Parser (Expr () SourcePos)

inferno-core/test/Eval/Spec.hs

@@ -389,6 +389,9 @@ evalTests = describe "evaluate" $
     shouldEvaluateTo "zip [1, 2] [\"a\"] == [(1,\"a\")]" $ vTrue
     shouldEvaluateTo "zip [] [1, 2] == []" $ vTrue
     shouldEvaluateTo "zip [1, 2] [] == []" $ vTrue
+    -- Records
+    shouldEvaluateTo "let r = {x: 2, y: 3} in r:x" $ VDouble 2
+    shouldEvaluateTo "let r = {x: 2, y: 3} in r:y" $ VDouble 3
     -- Type annotations
     shouldEvaluateTo "let x : int = 2 in x" $ VInt 2
     shouldEvaluateTo "let x : double = 2 in x" $ VDouble 2

inferno-core/test/Infer/Spec.hs

@@ -21,7 +21,7 @@ import Inferno.Infer.Exhaustiveness
 import Inferno.Module.Builtin (enumBoolHash)
 import qualified Inferno.Module.Prelude as Prelude
 import Inferno.Parse.Error (prettyError)
-import Inferno.Types.Syntax (ExtIdent (..), Ident (..))
+import Inferno.Types.Syntax (ExtIdent (..), Ident (..), RestOfRecord (RowAbsent), typeText)
 import Inferno.Types.Type (ImplType (..), InfernoType (..), TCScheme (..), TV (..), TypeClass (..), typeBool, typeDouble, typeInt, typeWord64)
 import Inferno.Types.VersionControl (vcHash)
 import Test.Hspec (Spec, describe, expectationFailure, it, runIO, shouldBe, shouldNotBe)
@@ -124,6 +124,14 @@ inferTests = describe "infer" $
     shouldFailToInferTypeFor "round -1425"
     shouldInferTypeFor "round (-1425)" $ simpleType typeInt
 
+    -- Records: TODO
+    shouldInferTypeFor "{}" $ simpleType $ TRecord Map.empty RowAbsent
+    shouldInferTypeFor "{name: \"Zaphod\", age: 391.4}" $ simpleType $ TRecord (Map.fromList [(Ident "name", typeText), (Ident "age", typeDouble)]) RowAbsent
+    shouldInferTypeFor "let r = {name: \"Zaphod\", age: 391.4} in r:age" $ simpleType typeDouble
+    shouldInferTypeFor "let r = {name: \"Zaphod\", age: 391.4} in let f = fun r -> r:age in f r + 1" $ simpleType typeDouble
+    shouldFailToInferTypeFor "let r = {name: \"Zaphod\", age: 391.4} in r:age + \" is too old\""
+    -- TODO try in functions
+
     -- Type annotations:
     shouldInferTypeFor "let xBoo : double = 1 in truncateTo 2 xBoo" $ simpleType typeDouble
     shouldFailToInferTypeFor "let xBoo : double = 1 in truncateTo xBoo 3.14"

inferno-core/test/Parse/Spec.hs

@@ -165,6 +165,13 @@ parsingTests = describe "pretty printing/parsing" $ do
     shouldSucceedFor "[]" $ Array () [] ()
     shouldSucceedFor "[None, None]" $ Array () [(Empty (), Just ()), (Empty (), Nothing)] ()
 
+  describe "parsing records" $ do
+    let r = Record () [(Ident "name", Lit () (LText "Zaphod"), Just ()), (Ident "age", Lit () (LInt 391), Nothing)] ()
+    shouldSucceedFor "{}" $ Record () [] ()
+    shouldSucceedFor "{name: \"Zaphod\", age: 391}" $ r
+    shouldSucceedFor "let r = {name: \"Zaphod\", age: 391} in r:age" $
+      Let () () (Expl $ ExtIdent $ Right "r") () r () (RecordField () (Ident "r") () (Ident "age"))
+
   describe "parsing infix operators" $ do
     shouldSucceedFor "2*3+7/2" $
       Op