Polymorphism for wasm-calc5 (#9)

* Add type vars and parse them

* Before we have a bad time

* Good lad

* Nice

* Damn, some sort of polymorphism

* Failing test for using non-boxed generic type{

* Only pass boxed types to polymorphic functions

* Check return type

* Unbox operator

* Fix linties

wasm-calc/wasm-calc.cabal

@@ -23,7 +23,7 @@ extra-source-files: CHANGELOG.md
 
 common shared
   ghc-options:
-    -threaded -rtsopts -with-rtsopts=-N -Wall
+    -threaded -rtsopts -with-rtsopts=-N -Wall -Werror
     -Wno-unticked-promoted-constructors -Wcompat
     -Wincomplete-record-updates -Wincomplete-uni-patterns
     -Wredundant-constraints -Wmissing-deriving-strategies

wasm-calc2/wasm-calc2.cabal

@@ -23,7 +23,7 @@ extra-source-files: CHANGELOG.md
 
 common shared
   ghc-options:
-    -threaded -rtsopts -with-rtsopts=-N -Wall
+    -threaded -rtsopts -with-rtsopts=-N -Wall -Werror
     -Wno-unticked-promoted-constructors -Wcompat
     -Wincomplete-record-updates -Wincomplete-uni-patterns
     -Wredundant-constraints -Wmissing-deriving-strategies

wasm-calc3/wasm-calc3.cabal

@@ -25,7 +25,7 @@ extra-source-files:
 
 common shared
   ghc-options:
-    -threaded -rtsopts -with-rtsopts=-N -Wall
+    -threaded -rtsopts -with-rtsopts=-N -Wall -Werror
     -Wno-unticked-promoted-constructors -Wcompat
     -Wincomplete-record-updates -Wincomplete-uni-patterns
     -Wredundant-constraints -Wmissing-deriving-strategies

wasm-calc4/wasm-calc4.cabal

@@ -25,7 +25,7 @@ extra-source-files:
 
 common shared
   ghc-options:
-    -threaded -rtsopts -with-rtsopts=-N -Wall
+    -threaded -rtsopts -with-rtsopts=-N -Wall -Werror
     -Wno-unticked-promoted-constructors -Wcompat
     -Wincomplete-record-updates -Wincomplete-uni-patterns
     -Wredundant-constraints -Wmissing-deriving-strategies

wasm-calc5/src/Calc/ExprUtils.hs

@@ -3,6 +3,7 @@
 module Calc.ExprUtils
   ( mapOuterExprAnnotation,
     getOuterAnnotation,
+    bindExpr,
   )
 where
 
@@ -17,7 +18,8 @@ getOuterAnnotation (EIf ann _ _ _) = ann
 getOuterAnnotation (EVar ann _) = ann
 getOuterAnnotation (EApply ann _ _) = ann
 getOuterAnnotation (ETuple ann _ _) = ann
-getOuterAnnotation (ETupleAccess ann _ _) = ann
+getOuterAnnotation (EContainerAccess ann _ _) = ann
+getOuterAnnotation (EBox ann _) = ann
 
 -- | modify the outer annotation of an expression
 -- useful for adding line numbers during parsing
@@ -30,4 +32,24 @@ mapOuterExprAnnotation f expr' =
     EVar ann a -> EVar (f ann) a
     EApply ann a b -> EApply (f ann) a b
     ETuple ann a b -> ETuple (f ann) a b
-    ETupleAccess ann a b -> ETupleAccess (f ann) a b
+    EContainerAccess ann a b -> EContainerAccess (f ann) a b
+    EBox ann a -> EBox (f ann) a
+
+-- | 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
+bindExpr _ (EPrim ann a) =
+  pure $ EPrim ann a
+bindExpr _ (EVar ann a) =
+  pure $ EVar ann a
+bindExpr f (EApply ann fn args) =
+  EApply ann fn <$> traverse f args
+bindExpr f (EIf ann predExpr thenExpr elseExpr) =
+  EIf ann <$> f predExpr <*> f thenExpr <*> f elseExpr
+bindExpr f (ETuple ann a as) =
+  ETuple ann <$> f a <*> traverse f as
+bindExpr f (EContainerAccess ann a nat) =
+  EContainerAccess ann <$> f a <*> pure nat
+bindExpr f (EBox ann a) = EBox ann <$> f a

wasm-calc5/src/Calc/Interpreter.hs

@@ -142,7 +142,7 @@ interpret (ETuple ann a as) = do
   aA <- interpret a
   asA <- traverse interpret as
   pure (ETuple ann aA asA)
-interpret (ETupleAccess _ tup index) = do
+interpret (EContainerAccess _ tup index) = do
   aTup <- interpret tup
   interpretTupleAccess aTup index
 interpret (EIf ann predExpr thenExpr elseExpr) = do
@@ -151,13 +151,19 @@ interpret (EIf ann predExpr thenExpr elseExpr) = do
     (EPrim _ (PBool True)) -> interpret thenExpr
     (EPrim _ (PBool False)) -> interpret elseExpr
     other -> throwError (NonBooleanPredicate ann other)
+interpret (EBox ann a) =
+  EBox ann <$> interpret a
 
 interpretTupleAccess :: Expr ann -> Natural -> InterpretM ann (Expr ann)
 interpretTupleAccess wholeExpr@(ETuple _ fstExpr restExpr) index = do
   let items = zip ([0 ..] :: [Natural]) (fstExpr : NE.toList restExpr)
   case lookup (index - 1) items of
     Just expr -> pure expr
     Nothing -> throwError (AccessOutsideTupleBounds wholeExpr index)
+interpretTupleAccess wholeExpr@(EBox _ innerExpr) index = do
+  case index of
+    1 -> interpret innerExpr
+    _ -> throwError (AccessOutsideTupleBounds wholeExpr index)
 interpretTupleAccess expr _ = throwError (AccessNonTuple expr)
 
 interpretModule ::

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

@@ -9,8 +9,9 @@ import Calc.Parser.Types
 import Calc.Types.Annotation
 import Calc.Types.Expr
 import Control.Monad.Combinators.Expr
+import Data.Foldable (foldl')
 import qualified Data.List.NonEmpty as NE
-import Data.Text
+import qualified Data.Text as T
 import GHC.Natural
 import Text.Megaparsec
 
@@ -19,8 +20,10 @@ exprParser = addLocation (makeExprParser exprPart table) <?> "expression"
 
 exprPart :: Parser (Expr Annotation)
 exprPart =
-  try tupleAccessParser
+  try unboxParser
+    <|> try containerAccessParser
     <|> try tupleParser
+    <|> boxParser
     <|> inBrackets (addLocation exprParser)
     <|> primExprParser
     <|> ifParser
@@ -37,7 +40,7 @@ table =
     [binary "==" (EInfix mempty OpEquals)]
   ]
 
-binary :: Text -> (a -> a -> a) -> Operator Parser a
+binary :: T.Text -> (a -> a -> a) -> Operator Parser a
 binary name f = InfixL (f <$ stringLiteral name)
 
 ifParser :: Parser (Expr Annotation)
@@ -71,15 +74,50 @@ tupleParser = label "tuple" $
     _ <- stringLiteral ")"
     pure (ETuple mempty (NE.head neArgs) neTail)
 
-tupleAccessParser :: Parser (Expr Annotation)
-tupleAccessParser =
+unboxParser :: Parser (Expr Annotation)
+unboxParser =
+  let tupParser :: Parser (Expr Annotation)
+      tupParser =
+        try containerAccessParser
+          <|> try tupleParser
+          <|> try applyParser
+          <|> try varParser
+          <|> boxParser
+   in label "unbox" $
+        addLocation $ do
+          tup <- tupParser
+          _ <- stringLiteral "!"
+          pure $
+            EContainerAccess mempty tup 1
+
+containerAccessParser :: Parser (Expr Annotation)
+containerAccessParser =
   let natParser :: Parser Natural
       natParser = myLexeme (fromIntegral <$> intParser)
 
       tupParser :: Parser (Expr Annotation)
-      tupParser = try tupleParser <|> try varParser <|> applyParser
-   in label "tuple access" $
+      tupParser =
+        try tupleParser
+          <|> try applyParser
+          <|> try varParser
+          <|> boxParser
+   in label "container access" $
         addLocation $ do
           tup <- tupParser
-          stringLiteral "."
-          ETupleAccess mempty tup <$> natParser
+          _ <- stringLiteral "."
+          accesses <- sepBy1 natParser (stringLiteral ".")
+          pure $
+            foldl'
+              ( EContainerAccess mempty
+              )
+              tup
+              accesses
+
+boxParser :: Parser (Expr Annotation)
+boxParser = label "box" $
+  addLocation $ do
+    _ <- stringLiteral "Box"
+    _ <- stringLiteral "("
+    inner <- exprParser
+    _ <- stringLiteral ")"
+    pure (EBox mempty inner)

wasm-calc5/src/Calc/Parser/Function.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Calc.Parser.Function (functionParser, functionNameParser) where
@@ -11,6 +12,7 @@ import Calc.Types.Annotation
 import Calc.Types.Function
 import Calc.Types.Identifier
 import Calc.Types.Type
+import Calc.Types.TypeVar
 import Text.Megaparsec
 
 argumentNameParser :: Parser ArgumentName
@@ -20,18 +22,30 @@ argumentNameParser = do
 
 functionParser :: Parser (Function Annotation)
 functionParser =
-  withLocation (\ann (args, fnName, expr) -> Function ann args fnName expr) innerParser
+  withLocation
+    ( \fnAnn (fnFunctionName, fnGenerics, fnArgs, fnBody) ->
+        Function {fnAnn, fnArgs, fnGenerics, fnFunctionName, fnBody}
+    )
+    innerParser
   where
     innerParser = do
       stringLiteral "function"
       fnName <- functionNameParser
+      generics <- try genericsParser <|> pure mempty
       stringLiteral "("
       args <- sepBy argTypeParser (stringLiteral ",")
       stringLiteral ")"
       stringLiteral "{"
       expr <- exprParser
       stringLiteral "}"
-      pure (args, fnName, expr)
+      pure (fnName, generics, args, expr)
+
+genericsParser :: Parser [TypeVar]
+genericsParser = do
+  stringLiteral "<"
+  generics <- sepBy typeVarParser (stringLiteral ",")
+  stringLiteral ">"
+  pure generics
 
 argTypeParser :: Parser (ArgumentName, Type Annotation)
 argTypeParser = do

wasm-calc5/src/Calc/Parser/Identifier.hs

@@ -3,6 +3,7 @@
 module Calc.Parser.Identifier
   ( identifierParser,
     functionNameParser,
+    typeVarParser,
   )
 where
 
@@ -31,8 +32,21 @@ filterProtectedNames tx =
     then Nothing
     else Just tx
 
--- identifier
+protectedTypeNames :: Set Text
+protectedTypeNames =
+  S.fromList
+    [ "Integer",
+      "Float",
+      "Boolean"
+    ]
+
+filterProtectedTypeNames :: Text -> Maybe Text
+filterProtectedTypeNames tx =
+  if S.member tx protectedTypeNames
+    then Nothing
+    else Just tx
 
+-- identifier
 identifierParser :: Parser Identifier
 identifierParser =
   myLexeme identifierParserInternal
@@ -48,3 +62,15 @@ functionNameParser :: Parser FunctionName
 functionNameParser = do
   (Identifier fnName) <- identifierParser
   pure (FunctionName fnName)
+
+-- typeVar
+typeVarParser :: Parser TypeVar
+typeVarParser =
+  myLexeme typeVarParserInternal
+
+-- use this when you are going to wrap myLexeme yourself
+typeVarParserInternal :: Parser TypeVar
+typeVarParserInternal =
+  maybePred
+    (takeWhile1P (Just "type variable name") Char.isAlphaNum)
+    (filterProtectedTypeNames >=> safeMkTypeVar)

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

@@ -2,6 +2,7 @@
 
 module Calc.Parser.Type (typeParser) where
 
+import Calc.Parser.Identifier
 import Calc.Parser.Shared
   ( addTypeLocation,
     myLexeme,
@@ -21,7 +22,7 @@ import Text.Megaparsec
 -- | top-level parser for type signatures
 typeParser :: Parser ParserType
 typeParser =
-  tyPrimitiveParser <|> tyTupleParser
+  tyPrimitiveParser <|> tyTupleParser <|> tyBoxParser <|> tyVarParser
 
 tyPrimitiveParser :: Parser ParserType
 tyPrimitiveParser = myLexeme $ addTypeLocation $ TPrim mempty <$> tyPrimParser
@@ -32,13 +33,28 @@ tyPrimitiveParser = myLexeme $ addTypeLocation $ TPrim mempty <$> tyPrimParser
         <|> stringLiteral "Float"
         $> TFloat
 
+tyBoxParser :: Parser ParserType
+tyBoxParser = label "box" $
+  addTypeLocation $ do
+    _ <- stringLiteral "Box"
+    _ <- stringLiteral "("
+    tyInner <- typeParser
+    _ <- stringLiteral ")"
+    pure (TContainer mempty $ NE.singleton tyInner)
+
+-- | tuples use container, but we parse them distinctly
 tyTupleParser :: Parser ParserType
 tyTupleParser = label "tuple" $
   addTypeLocation $ do
     _ <- stringLiteral "("
     neArgs <- NE.fromList <$> sepBy1 typeParser (stringLiteral ",")
-    neTail <- case NE.nonEmpty (NE.tail neArgs) of
+    _neTail <- case NE.nonEmpty (NE.tail neArgs) of
       Just ne -> pure ne
       _ -> fail "Expected at least two items in a tuple"
     _ <- stringLiteral ")"
-    pure (TTuple mempty (NE.head neArgs) neTail)
+    pure (TContainer mempty neArgs)
+
+tyVarParser :: Parser ParserType
+tyVarParser = label "type variable" $
+  addTypeLocation $ do
+    TVar mempty <$> typeVarParser

wasm-calc5/src/Calc/TypeUtils.hs

@@ -1,13 +1,44 @@
-module Calc.TypeUtils (mapOuterTypeAnnotation, getOuterTypeAnnotation) where
+module Calc.TypeUtils
+  ( bindType,
+    mapType,
+    mapOuterTypeAnnotation,
+    getOuterTypeAnnotation,
+  )
+where
 
 import Calc.Types.Type
+import Control.Monad.Identity
 
 getOuterTypeAnnotation :: Type ann -> ann
 getOuterTypeAnnotation (TPrim ann _) = ann
 getOuterTypeAnnotation (TFunction ann _ _) = ann
-getOuterTypeAnnotation (TTuple ann _ _) = ann
+getOuterTypeAnnotation (TContainer ann _) = ann
+getOuterTypeAnnotation (TVar ann _) = ann
+getOuterTypeAnnotation (TUnificationVar ann _) = ann
 
 mapOuterTypeAnnotation :: (ann -> ann) -> Type ann -> Type ann
 mapOuterTypeAnnotation f (TPrim ann p) = TPrim (f ann) p
 mapOuterTypeAnnotation f (TFunction ann a b) = TFunction (f ann) a b
-mapOuterTypeAnnotation f (TTuple ann a b) = TTuple (f ann) a b
+mapOuterTypeAnnotation f (TContainer ann a) = TContainer (f ann) a
+mapOuterTypeAnnotation f (TVar ann v) = TVar (f ann) v
+mapOuterTypeAnnotation f (TUnificationVar ann v) = TUnificationVar (f ann) v
+
+mapType :: (Type ann -> Type ann) -> Type ann -> Type ann
+mapType f ty =
+  runIdentity (bindType (pure . f) ty)
+
+bindType ::
+  (Applicative m) =>
+  (Type ann -> m (Type ann)) ->
+  Type ann ->
+  m (Type ann)
+bindType _ (TPrim ann p) =
+  pure $ TPrim ann p
+bindType f (TFunction ann a b) =
+  TFunction ann <$> traverse f a <*> f b
+bindType f (TContainer ann as) =
+  TContainer ann <$> traverse f as
+bindType _ (TVar ann a) =
+  pure $ TVar ann a
+bindType _ (TUnificationVar ann a) =
+  pure $ TUnificationVar ann a