Arrays

wasm-calc13/src/Calc/ExprUtils.hs

@@ -1,21 +1,22 @@
 {-# LANGUAGE RankNTypes #-}
 
-module Calc.ExprUtils
-  ( mapOuterExprAnnotation,
-    getOuterAnnotation,
-    bindExpr,
-    mapExpr,
-    getOuterPatternAnnotation,
-    mapOuterPatternAnnotation,
-    monoidExpr,
-  )
+module Calc.ExprUtils (
+  mapOuterExprAnnotation,
+  getOuterAnnotation,
+  bindExpr,
+  mapExpr,
+  getOuterPatternAnnotation,
+  mapOuterPatternAnnotation,
+  monoidExpr,
+)
 where
 
 import Calc.Types
 import Control.Monad.Identity
 
--- | get the annotation in the first leaf found in an `Expr`.
--- useful for getting the overall type of an expression
+{- | get the annotation in the first leaf found in an `Expr`.
+useful for getting the overall type of an expression
+-}
 getOuterAnnotation :: Expr ann -> ann
 getOuterAnnotation (EAnn ann _ _) = ann
 getOuterAnnotation (EInfix ann _ _ _) = ann
@@ -34,9 +35,11 @@ getOuterAnnotation (ESet ann _ _) = ann
 getOuterAnnotation (EBlock ann _) = ann
 getOuterAnnotation (ELambda ann _ _ _) = ann
 getOuterAnnotation (EReference ann _) = ann
+getOuterAnnotation (EArray ann _) = ann
 
--- | modify the outer annotation of an expression
--- useful for adding line numbers during parsing
+{- | modify the outer annotation of an expression
+useful for adding line numbers during parsing
+-}
 mapOuterExprAnnotation :: (ann -> ann) -> Expr ann -> Expr ann
 mapOuterExprAnnotation f expr' =
   case expr' of
@@ -57,13 +60,15 @@ mapOuterExprAnnotation f expr' =
     EBlock ann a -> EBlock (f ann) a
     ELambda ann a b c -> ELambda (f ann) a b c
     EReference ann a -> EReference (f ann) a
+    EArray ann a -> EArray (f ann) a
 
 mapExpr :: (Expr ann -> Expr ann) -> Expr ann -> Expr ann
 mapExpr f =
   runIdentity . bindExpr (Identity . f)
 
--- | Given a function that changes `Expr` values to `m Expr`, apply it throughout
--- an AST tree
+{- | Given a function that changes `Expr` values to `m Expr`, apply it throughout
+an AST tree
+-}
 bindExpr :: (Applicative m) => (Expr ann -> m (Expr ann)) -> Expr ann -> m (Expr ann)
 bindExpr f (EInfix ann op a b) =
   EInfix ann op <$> f a <*> f b
@@ -91,6 +96,7 @@ bindExpr f (ESet ann a b) = ESet ann a <$> f b
 bindExpr f (EBlock ann a) = EBlock ann <$> f a
 bindExpr f (ELambda ann a b c) = ELambda ann a b <$> f c
 bindExpr _ (EReference ann a) = pure $ EReference ann a
+bindExpr f (EArray ann a) = EArray ann <$> traverse f a
 
 getOuterPatternAnnotation :: Pattern ann -> ann
 getOuterPatternAnnotation (PWildcard ann) = ann
@@ -109,9 +115,9 @@ mapOuterPatternAnnotation f (PBox ann a) = PBox (f ann) a
 mapOuterPatternAnnotation f (PConstructor ann a b) = PConstructor (f ann) a b
 
 monoidExpr :: (Monoid m) => (Expr ann -> m) -> Expr ann -> m
-monoidExpr _ (EVar {}) = mempty
-monoidExpr _ (EReference {}) = mempty
-monoidExpr _ (EPrim {}) = mempty
+monoidExpr _ (EVar{}) = mempty
+monoidExpr _ (EReference{}) = mempty
+monoidExpr _ (EPrim{}) = mempty
 monoidExpr f (ELet _ _ expr body) = f expr <> f body
 monoidExpr f (EMatch _ matchExpr pats) =
   f matchExpr <> foldMap (f . snd) pats
@@ -127,3 +133,4 @@ monoidExpr f (EStore _ _ a) = f a
 monoidExpr f (ESet _ _ a) = f a
 monoidExpr f (EBlock _ a) = f a
 monoidExpr f (ELambda _ _ _ body) = f body
+monoidExpr f (EArray _ as) = foldMap f as

wasm-calc13/src/Calc/Linearity/Decorate.hs

@@ -114,6 +114,7 @@ decorate ::
 decorate (EVar ty@(TReference {}) ident) = do
   recordReference ident ty
   pure (EVar (ty, Nothing) ident)
+decorate (EArray _ty _as) = error "sdfsdf"
 decorate (EVar ty ident) = do
   recordUse ident ty
   pure (EVar (ty, Nothing) ident)

wasm-calc13/src/Calc/Parser/Expr.hs

@@ -42,6 +42,7 @@ exprParserInternal =
         do
           try annotationParser
           <|> referenceParser
+          <|> arrayParser
           <|> try tupleParser
           <|> constructorParser
           <|> boxParser
@@ -272,3 +273,10 @@ patternCaseParser = do
   stringLiteral "->"
   patExpr <- exprParserInternal
   pure (pat, patExpr)
+
+arrayParser :: Parser (Expr Annotation)
+arrayParser = label "array" $ addLocation $ do
+  stringLiteral "["
+  exprs <- sepEndBy exprParserInternal (stringLiteral ",")
+  stringLiteral "]"
+  pure $ EArray mempty exprs

wasm-calc13/src/Calc/Parser/Type.hs

@@ -24,6 +24,7 @@ typeParser :: Parser ParserType
 typeParser =
   tyPrimitiveParser
     <|> tyTupleParser
+    <|> tyArrayParser
     <|> tyFunctionParser
     <|> tyConstructorParser
     <|> tyBoxParser
@@ -100,3 +101,11 @@ tyConstructorParser =
         dtName <- dataNameParser
         args <- try argsParser <|> pure mempty
         pure $ TConstructor mempty dtName args
+
+tyArrayParser :: Parser ParserType
+tyArrayParser = label "array" $
+  addTypeLocation $ do
+    _ <- stringLiteral "["
+    tyInner <- typeParser
+    _ <- stringLiteral "]"
+    pure (TArray mempty tyInner)

wasm-calc13/src/Calc/TypeUtils.hs

@@ -18,6 +18,7 @@ getOuterTypeAnnotation (TVar ann _) = ann
 getOuterTypeAnnotation (TUnificationVar ann _) = ann
 getOuterTypeAnnotation (TConstructor ann _ _) = ann
 getOuterTypeAnnotation (TReference ann _) = ann
+getOuterTypeAnnotation (TArray ann _) = ann
 
 mapOuterTypeAnnotation :: (ann -> ann) -> Type ann -> Type ann
 mapOuterTypeAnnotation f (TPrim ann p) = TPrim (f ann) p
@@ -27,6 +28,7 @@ mapOuterTypeAnnotation f (TVar ann v) = TVar (f ann) v
 mapOuterTypeAnnotation f (TUnificationVar ann v) = TUnificationVar (f ann) v
 mapOuterTypeAnnotation f (TConstructor ann a b) = TConstructor (f ann) a b
 mapOuterTypeAnnotation f (TReference ann ty) = TReference (f ann) ty
+mapOuterTypeAnnotation f (TArray ann ty) = TArray (f ann) ty
 
 mapType :: (Type ann -> Type ann) -> Type ann -> Type ann
 mapType f ty =
@@ -51,6 +53,8 @@ bindType f (TConstructor ann dn args) =
   TConstructor ann dn <$> traverse f args
 bindType f (TReference ann ty) =
   TReference ann <$> f ty
+bindType f (TArray ann ty) =
+  TArray ann <$> f ty
 
 monoidType :: (Monoid m) => (Type ann -> m) -> Type ann -> m
 monoidType _ (TPrim {}) = mempty
@@ -60,3 +64,4 @@ monoidType _ (TVar {}) = mempty
 monoidType _ (TUnificationVar {}) = mempty
 monoidType f (TReference _ ty) = f ty
 monoidType f (TConstructor _ _ args) = foldMap f args
+monoidType f (TArray _ ty) = f ty

wasm-calc13/src/Calc/Typecheck/Error/TypeError.hs

@@ -49,6 +49,7 @@ data TypeError ann
   | ReferenceForPrimitiveValue (Type ann)
   | ReferenceInDataType DataName Constructor (Type ann)
   | DuplicateConstructor Constructor DataName DataName
+  | EmptyArray ann
   deriving stock (Eq, Ord, Show)
 
 positionFromAnnotation ::
@@ -77,6 +78,27 @@ typeErrorDiagnostic input e =
    in case e of
         (PatternMatchError patternMatchError) ->
           patternMatchErrorDiagnostic input patternMatchError
+        (EmptyArray ann) ->
+          Diag.addReport diag $
+            Diag.Err
+              Nothing
+              ( prettyPrint "Can't infer type of an empty array"
+              )
+              ( catMaybes
+                  [ (,)
+                      <$> positionFromAnnotation
+                        filename
+                        input
+                        ann
+                      <*> pure
+                        ( Diag.This
+                            ( prettyPrint
+                                "Consider providing a type annotation"
+                            )
+                        )
+                  ]
+              )
+              []
         (UnknownLoadType ann) ->
           Diag.addReport diag $
             Diag.Err

wasm-calc13/src/Calc/Typecheck/Infer.hs

@@ -518,6 +518,13 @@ infer :: Expr ann -> TypecheckM ann (Expr (Type ann))
 infer (EAnn ann ty expr) = do
   typedExpr <- check ty expr
   pure $ EAnn (getOuterAnnotation typedExpr $> ann) (ty $> ty) typedExpr
+infer (EArray ann exprs) = do
+  typedExprs <- traverse infer exprs
+  neTypedExprs <- case NE.nonEmpty typedExprs of
+    Nothing -> throwError (EmptyArray ann)
+    Just as -> pure as
+  ty <- TArray ann <$> combineMany (getOuterAnnotation <$> neTypedExprs)
+  pure $ EArray ty typedExprs
 infer (EPrim ann prim) =
   case prim of
     PBool _ -> pure (EPrim (TPrim ann TBool) prim)

wasm-calc13/src/Calc/Types/Expr.hs

@@ -33,6 +33,7 @@ data Expr ann
   | EBlock ann (Expr ann)
   | ELambda ann [(Identifier, Type ann)] (Type ann) (Expr ann)
   | EReference ann Identifier
+  | EArray ann [Expr ann]
   deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
 
 -- | this instance defines how to nicely print `Expr`
@@ -43,6 +44,11 @@ instance PP.Pretty (Expr ann) where
     PP.parens (PP.pretty expr <> ":" <+> PP.pretty ty)
   pretty (EReference _ expr) =
     "&" <> PP.pretty expr
+  pretty (EArray _ as) =
+    let pArgs = PP.punctuate ", " (PP.pretty <$> as)
+     in "["
+          <> PP.group (PP.line' <> indentMulti 2 (PP.cat pArgs) <> PP.line')
+          <> "]"
   pretty (ELambda _ fnArgs fnReturnType fnBody) =
     "\\"
       <> PP.group
@@ -54,35 +60,35 @@ instance PP.Pretty (Expr ann) where
               )
         )
       <> ")"
-      <+> "->"
-      <+> PP.pretty fnReturnType
-      <+> "{"
-      <+> PP.group (newlines $ indentMulti 2 (PP.pretty fnBody))
+        <+> "->"
+        <+> PP.pretty fnReturnType
+        <+> "{"
+        <+> PP.group (newlines $ indentMulti 2 (PP.pretty fnBody))
       <> "}"
-    where
-      prettyArg (ident, ty) = PP.pretty ident <> ":" <> PP.pretty ty
+   where
+    prettyArg (ident, ty) = PP.pretty ident <> ":" <> PP.pretty ty
   pretty (ELet _ (PWildcard _) body rest) =
     PP.pretty body
       <> ";"
-      <+> PP.line
+        <+> PP.line
       <> PP.pretty rest
   pretty (ELet _ ident (EAnn _ ty body) rest) =
     "let"
       <+> PP.pretty ident
       <> ":"
-      <+> PP.pretty ty
-      <+> "="
-      <+> PP.pretty body
+        <+> PP.pretty ty
+        <+> "="
+        <+> PP.pretty body
       <> ";"
-      <+> PP.line
+        <+> PP.line
       <> PP.pretty rest
   pretty (ELet _ ident body rest) =
     "let"
       <+> PP.pretty ident
       <+> "="
       <+> PP.pretty body
       <> ";"
-      <+> PP.line
+        <+> PP.line
       <> PP.pretty rest
   pretty (EMatch _ expr pats) =
     "case"
@@ -95,22 +101,22 @@ instance PP.Pretty (Expr ann) where
               ( PP.cat
                   (PP.punctuate ", " (prettyPat <$> NE.toList pats))
               )
-            <+> PP.line'
+              <+> PP.line'
         )
       <> "}"
-    where
-      prettyPat (pat, patExpr) =
-        PP.pretty pat <+> "->" <+> PP.pretty patExpr
+   where
+    prettyPat (pat, patExpr) =
+      PP.pretty pat <+> "->" <+> PP.pretty patExpr
   pretty (EConstructor _ constructor []) =
     PP.pretty constructor
   pretty (EConstructor _ constructor args) =
     PP.pretty constructor
       <> "("
       <> PP.group (PP.line' <> indentMulti 2 (PP.cat pArgs) <> PP.line')
       <> ")"
-    where
-      pArgs =
-        PP.punctuate ", " (PP.pretty <$> args)
+   where
+    pArgs =
+      PP.punctuate ", " (PP.pretty <$> args)
   pretty (EInfix _ op a b) =
     PP.pretty a <+> PP.pretty op <+> PP.pretty b
   pretty (EIf _ predExpr thenExpr elseExpr) =
@@ -131,16 +137,16 @@ instance PP.Pretty (Expr ann) where
       <> "("
       <> PP.group (PP.line' <> indentMulti 2 (PP.cat pArgs) <> PP.line')
       <> ")"
-    where
-      pArgs = PP.punctuate ", " (PP.pretty <$> args)
+   where
+    pArgs = PP.punctuate ", " (PP.pretty <$> args)
   pretty (ETuple _ a as) =
     "(" <> PP.group (PP.line' <> indentMulti 2 (PP.cat prettyItems) <> PP.line') <> ")"
-    where
-      prettyItems =
-        PP.punctuate ", " (PP.pretty <$> tupleItems a as)
+   where
+    prettyItems =
+      PP.punctuate ", " (PP.pretty <$> tupleItems a as)
 
-      tupleItems :: a -> NE.NonEmpty a -> [a]
-      tupleItems b bs = b : NE.toList bs
+    tupleItems :: a -> NE.NonEmpty a -> [a]
+    tupleItems b bs = b : NE.toList bs
   pretty (EBox _ inner) =
     "Box(" <> PP.pretty inner <> ")"
   pretty (ELoad _ index) =

wasm-calc13/src/Calc/Types/Prim.hs

@@ -1,8 +1,8 @@
 {-# LANGUAGE DerivingStrategies #-}
 
-module Calc.Types.Prim
-  ( Prim (..),
-  )
+module Calc.Types.Prim (
+  Prim (..),
+)
 where
 
 import Data.Word

wasm-calc13/src/Calc/Types/Type.hs

@@ -41,6 +41,7 @@ data Type ann
   | TVar ann TypeVar
   | TUnificationVar ann Natural
   | TReference ann (Type ann)
+  | TArray ann (Type ann)
   deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
 
 instance PP.Pretty (Type ann) where
@@ -59,6 +60,7 @@ instance PP.Pretty (Type ann) where
     "(" <> PP.cat (PP.punctuate "," (PP.pretty <$> NE.toList as)) <> ")"
   pretty (TConstructor _ dataName []) =
     PP.pretty dataName
+  pretty (TArray _ ty) = "[" <> PP.pretty ty <> "]"
   pretty (TConstructor _ dataName args) =
     PP.pretty dataName
       <> "("

wasm-calc13/src/Calc/Wasm/FromExpr/Expr.hs

@@ -439,6 +439,7 @@ fromExpr ::
   m WasmExpr
 fromExpr (EPrim (ty, _) prim) =
   WPrim <$> fromPrim ty prim
+fromExpr (EArray {}) = error "fromExpr EArray"
 fromExpr (EMatch _ expr pats) =
   fromMatch expr pats
 fromExpr (ELambda _ args returnTy body) = do