wasm-calc5 (#7)

* Add float type

* Adding floats works

* Broken test

* CI

* Format

* Bump Ormolu

* Get it working with F32

* Use F64

* Absolutely fix those tuples

* Nice

* Fix test command

.github/workflows/lint-haskell.yml

@@ -14,13 +14,14 @@ jobs:
     runs-on: ubuntu-latest
     steps:
       - uses: actions/checkout@b4ffde65f46336ab88eb53be808477a3936bae11 # v4
-      - uses: mrkkrp/ormolu-action@v11
+      - uses: haskell-actions/run-ormolu@v14
         with:
           pattern: |
             wasm-calc/**/*.hs
             wasm-calc2/**/*.hs
             wasm-calc3/**/*.hs
             wasm-calc4/**/*.hs
+            wasm-calc5/**/*.hs
 
   hlint:
     runs-on: ubuntu-latest
@@ -35,6 +36,6 @@ jobs:
       - name: "Run HLint"
         uses: rwe/actions-hlint-run@v2
         with:
-          path: '["wasm-calc/", "wasm-calc2/", "wasm-calc3/", "wasm-calc4/"]'
+          path: '["wasm-calc/", "wasm-calc2/", "wasm-calc3/", "wasm-calc4/", "wasm-calc5/"]'
           fail-on: warning
 

.github/workflows/wasm-calc-haskell.yml

@@ -53,3 +53,6 @@ jobs:
       - name: Test wasm-calc4
         run: make test-wasm-calc4
 
+      - name: Test wasm-calc5
+        run: make test-wasm-calc5
+

Makefile

@@ -49,6 +49,17 @@ test-wasm-calc4:
 run-wasm-calc4:
 	cabal run wasm-calc4
 
+# calculator 5
+
+.PHONY: test-wasm-calc5
+test-wasm-calc5:
+	cabal run wasm-calc5:tests
+
+.PHONY: run-wasm-calc5
+run-wasm-calc5:
+	cabal run wasm-calc5
+
+
 .PHONY: freeze
 freeze:
 	cabal freeze --enable-tests --enable-benchmarks

cabal.project

@@ -2,7 +2,8 @@ packages:
   wasm-calc/wasm-calc.cabal,
   wasm-calc2/wasm-calc2.cabal,
   wasm-calc3/wasm-calc3.cabal,
-  wasm-calc4/wasm-calc4.cabal
+  wasm-calc4/wasm-calc4.cabal,
+  wasm-calc5/wasm-calc5.cabal
 
 with-compiler: ghc-9.6.3
 

wasm-calc5/.gitignore

@@ -0,0 +1,2 @@
+dist-newstyle
+.direnv

wasm-calc5/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for nix-basic
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

wasm-calc5/app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Calc (repl)
+
+main :: IO ()
+main = repl

wasm-calc5/src/Calc.hs

@@ -0,0 +1,14 @@
+module Calc
+  ( module Calc.Types,
+    module Calc.Parser,
+    module Calc.ExprUtils,
+    module Calc.Interpreter,
+    module Calc.Repl,
+  )
+where
+
+import Calc.ExprUtils
+import Calc.Interpreter
+import Calc.Parser
+import Calc.Repl
+import Calc.Types

wasm-calc5/src/Calc/ExprUtils.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Calc.ExprUtils
+  ( mapOuterExprAnnotation,
+    getOuterAnnotation,
+  )
+where
+
+import Calc.Types
+
+-- | 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 (EInfix ann _ _ _) = ann
+getOuterAnnotation (EPrim ann _) = ann
+getOuterAnnotation (EIf ann _ _ _) = ann
+getOuterAnnotation (EVar ann _) = ann
+getOuterAnnotation (EApply ann _ _) = ann
+getOuterAnnotation (ETuple ann _ _) = ann
+getOuterAnnotation (ETupleAccess ann _ _) = ann
+
+-- | 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
+    EInfix ann a b c -> EInfix (f ann) a b c
+    EPrim ann a -> EPrim (f ann) a
+    EIf ann a b c -> EIf (f ann) a b c
+    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

wasm-calc5/src/Calc/Interpreter.hs

@@ -0,0 +1,169 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Calc.Interpreter
+  ( runInterpreter,
+    interpret,
+    interpretModule,
+    InterpreterError (..),
+    InterpreterState (..),
+    InterpreterEnv (..),
+  )
+where
+
+import Calc.Types
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Coerce
+import qualified Data.List.NonEmpty as NE
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import GHC.Natural
+
+-- | type for interpreter state
+newtype InterpreterState ann = InterpreterState
+  { isFunctions :: Map FunctionName (Function ann)
+  }
+
+-- | type of errors that can occur
+data InterpreterError ann
+  = NonBooleanPredicate ann (Expr ann)
+  | FunctionNotFound FunctionName [FunctionName]
+  | VarNotFound Identifier [Identifier]
+  | AccessNonTuple (Expr ann)
+  | AccessOutsideTupleBounds (Expr ann) Natural
+  deriving stock (Eq, Ord, Show)
+
+-- | type of Reader env for interpreter state
+-- we use this for scoped temporary state
+newtype InterpreterEnv ann = InterpreterEnv
+  { ieVars :: Map Identifier (Expr ann)
+  }
+
+newtype InterpretM ann a = InterpretM {runInterpretM :: ReaderT (InterpreterEnv ann) (StateT (InterpreterState ann) (Either (InterpreterError ann))) a}
+  deriving newtype
+    ( Functor,
+      Applicative,
+      Monad,
+      MonadError (InterpreterError ann),
+      MonadState (InterpreterState ann),
+      MonadReader (InterpreterEnv ann)
+    )
+
+runInterpreter ::
+  InterpretM ann a ->
+  Either (InterpreterError ann) a
+runInterpreter = flip evalStateT initialState . flip runReaderT initialEnv . runInterpretM
+  where
+    initialEnv = InterpreterEnv mempty
+    initialState = InterpreterState mempty
+
+-- | run an `InterpretM` action, after adding some arguments into the
+-- Reader environment
+-- we use the Reader env here because the vars disappear after we use them,
+-- say, in a function
+withVars ::
+  [ArgumentName] ->
+  [Expr ann] ->
+  InterpretM ann a ->
+  InterpretM ann a
+withVars fnArgs inputs =
+  let newVars = M.fromList $ zip (coerce <$> fnArgs) inputs
+   in local
+        ( \(InterpreterEnv ieVars) ->
+            InterpreterEnv $ ieVars <> newVars
+        )
+
+-- | lookup a variable in the Reader environment
+lookupVar :: Identifier -> InterpretM ann (Expr ann)
+lookupVar identifier = do
+  maybeValue <- asks (M.lookup identifier . ieVars)
+  case maybeValue of
+    Just expr -> pure expr
+    Nothing -> do
+      allVars <- asks (M.keys . ieVars)
+      throwError (VarNotFound identifier allVars)
+
+interpretInfix ::
+  ann ->
+  Op ->
+  Expr ann ->
+  Expr ann ->
+  InterpretM ann (Expr ann)
+-- ints
+interpretInfix ann OpAdd (EPrim _ (PInt a)) (EPrim _ (PInt b)) =
+  pure $ EPrim ann (PInt $ a + b)
+interpretInfix ann OpSubtract (EPrim _ (PInt a)) (EPrim _ (PInt b)) =
+  pure $ EPrim ann (PInt $ a - b)
+interpretInfix ann OpMultiply (EPrim _ (PInt a)) (EPrim _ (PInt b)) =
+  pure $ EPrim ann (PInt $ a * b)
+-- float
+interpretInfix ann OpAdd (EPrim _ (PFloat a)) (EPrim _ (PFloat b)) =
+  pure $ EPrim ann (PFloat $ a + b)
+interpretInfix ann OpSubtract (EPrim _ (PFloat a)) (EPrim _ (PFloat b)) =
+  pure $ EPrim ann (PFloat $ a - b)
+interpretInfix ann OpMultiply (EPrim _ (PFloat a)) (EPrim _ (PFloat b)) =
+  pure $ EPrim ann (PFloat $ a * b)
+interpretInfix ann OpEquals (EPrim _ a) (EPrim _ b) =
+  pure $ EPrim ann (PBool $ a == b)
+interpretInfix ann op a b = do
+  iA <- interpret a
+  iB <- interpret b
+  interpretInfix ann op iA iB
+
+-- | look up the function, adds the arguments into the Reader environment
+-- then interpret the function body
+interpretApply :: FunctionName -> [Expr ann] -> InterpretM ann (Expr ann)
+interpretApply fnName args = do
+  fn <- gets (M.lookup fnName . isFunctions)
+  case fn of
+    Just (Function {fnArgs, fnBody}) ->
+      withVars (fst <$> fnArgs) args (interpret fnBody)
+    Nothing -> do
+      allFnNames <- gets (M.keys . isFunctions)
+      throwError (FunctionNotFound fnName allFnNames)
+
+-- | just keep reducing the thing until the smallest thing
+interpret ::
+  Expr ann ->
+  InterpretM ann (Expr ann)
+interpret (EPrim ann p) =
+  pure (EPrim ann p)
+interpret (EVar _ ident) =
+  lookupVar ident
+interpret (EApply _ fnName args) =
+  interpretApply fnName args
+interpret (EInfix ann op a b) =
+  interpretInfix ann op a b
+interpret (ETuple ann a as) = do
+  aA <- interpret a
+  asA <- traverse interpret as
+  pure (ETuple ann aA asA)
+interpret (ETupleAccess _ tup index) = do
+  aTup <- interpret tup
+  interpretTupleAccess aTup index
+interpret (EIf ann predExpr thenExpr elseExpr) = do
+  predA <- interpret predExpr
+  case predA of
+    (EPrim _ (PBool True)) -> interpret thenExpr
+    (EPrim _ (PBool False)) -> interpret elseExpr
+    other -> throwError (NonBooleanPredicate ann other)
+
+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 expr _ = throwError (AccessNonTuple expr)
+
+interpretModule ::
+  Module ann ->
+  InterpretM ann (Expr ann)
+interpretModule (Module {mdExpr, mdFunctions}) = do
+  let fnMap = M.fromList $ (\fn -> (fnFunctionName fn, fn)) <$> mdFunctions
+  put (InterpreterState fnMap)
+  interpret mdExpr

wasm-calc5/src/Calc/Parser.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Calc.Parser
+  ( parseExpr,
+    parseExprAndFormatError,
+    parseType,
+    parseTypeAndFormatError,
+    parseFunction,
+    parseFunctionAndFormatError,
+    parseModule,
+    parseModuleAndFormatError,
+    replFilename,
+  )
+where
+
+import Calc.Parser.Expr
+import Calc.Parser.Function
+import Calc.Parser.Module
+import Calc.Parser.Type
+import Calc.Parser.Types
+import Data.Bifunctor (first)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.Megaparsec
+import Text.Megaparsec.Char
+
+-- | which file are we parsing?
+-- we use this to show the right text in errors
+replFilename :: FilePath
+replFilename = "repl"
+
+parseAndFormat :: Parser a -> Text -> Either Text a
+parseAndFormat p =
+  first (T.pack . errorBundlePretty)
+    . parse (p <* eof) replFilename
+
+-- parse expr, using it all up
+parseExpr :: Text -> Either ParseErrorType ParserExpr
+parseExpr = parse (space *> exprParser <* eof) replFilename
+
+-- | `parseExpr`, but format error to text
+parseExprAndFormatError :: Text -> Either Text ParserExpr
+parseExprAndFormatError = parseAndFormat (space *> exprParser <* eof)
+
+-- parse type, using it all up
+parseType :: Text -> Either ParseErrorType ParserType
+parseType = parse (space *> typeParser <* eof) replFilename
+
+-- | `parseType`, but format error to text
+parseTypeAndFormatError :: Text -> Either Text ParserType
+parseTypeAndFormatError = parseAndFormat (space *> typeParser <* eof)
+
+-- parse function, using it all up
+parseFunction :: Text -> Either ParseErrorType ParserFunction
+parseFunction = parse (space *> functionParser <* eof) replFilename
+
+-- | `parseType`, but format error to text
+parseFunctionAndFormatError :: Text -> Either Text ParserFunction
+parseFunctionAndFormatError = parseAndFormat (space *> functionParser <* eof)
+
+-- parse module, using it all up
+parseModule :: Text -> Either ParseErrorType ParserModule
+parseModule = parse (space *> moduleParser <* eof) replFilename
+
+-- | `parseModule`, but format error to text
+parseModuleAndFormatError :: Text -> Either Text ParserModule
+parseModuleAndFormatError = parseAndFormat (space *> moduleParser <* eof)