diff --git a/.github/workflows/lint-haskell.yml b/.github/workflows/lint-haskell.yml index 0ef2f96d..17c78a9c 100644 --- a/.github/workflows/lint-haskell.yml +++ b/.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 diff --git a/.github/workflows/wasm-calc-haskell.yml b/.github/workflows/wasm-calc-haskell.yml index 17e3743a..fa2b5849 100644 --- a/.github/workflows/wasm-calc-haskell.yml +++ b/.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 + diff --git a/Makefile b/Makefile index 98a5d304..4ded2e08 100644 --- a/Makefile +++ b/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 diff --git a/cabal.project b/cabal.project index 3e788872..c54efad8 100644 --- a/cabal.project +++ b/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 diff --git a/wasm-calc5/.gitignore b/wasm-calc5/.gitignore new file mode 100644 index 00000000..39dffb9e --- /dev/null +++ b/wasm-calc5/.gitignore @@ -0,0 +1,2 @@ +dist-newstyle +.direnv diff --git a/wasm-calc5/CHANGELOG.md b/wasm-calc5/CHANGELOG.md new file mode 100644 index 00000000..fcf2589c --- /dev/null +++ b/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. diff --git a/wasm-calc5/app/Main.hs b/wasm-calc5/app/Main.hs new file mode 100644 index 00000000..1bebf3ea --- /dev/null +++ b/wasm-calc5/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Calc (repl) + +main :: IO () +main = repl diff --git a/wasm-calc5/src/Calc.hs b/wasm-calc5/src/Calc.hs new file mode 100644 index 00000000..1bab2591 --- /dev/null +++ b/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 diff --git a/wasm-calc5/src/Calc/ExprUtils.hs b/wasm-calc5/src/Calc/ExprUtils.hs new file mode 100644 index 00000000..07881981 --- /dev/null +++ b/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 diff --git a/wasm-calc5/src/Calc/Interpreter.hs b/wasm-calc5/src/Calc/Interpreter.hs new file mode 100644 index 00000000..944eb85e --- /dev/null +++ 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 diff --git a/wasm-calc5/src/Calc/Parser.hs b/wasm-calc5/src/Calc/Parser.hs new file mode 100644 index 00000000..5837346a --- /dev/null +++ b/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) diff --git a/wasm-calc5/src/Calc/Parser/Expr.hs b/wasm-calc5/src/Calc/Parser/Expr.hs new file mode 100644 index 00000000..1adf2ec8 --- /dev/null +++ b/wasm-calc5/src/Calc/Parser/Expr.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Parser.Expr (exprParser) where + +import Calc.Parser.Identifier +import Calc.Parser.Primitives +import Calc.Parser.Shared +import Calc.Parser.Types +import Calc.Types.Annotation +import Calc.Types.Expr +import Control.Monad.Combinators.Expr +import qualified Data.List.NonEmpty as NE +import Data.Text +import GHC.Natural +import Text.Megaparsec + +exprParser :: Parser (Expr Annotation) +exprParser = addLocation (makeExprParser exprPart table) "expression" + +exprPart :: Parser (Expr Annotation) +exprPart = + try tupleAccessParser + <|> try tupleParser + <|> inBrackets (addLocation exprParser) + <|> primExprParser + <|> ifParser + <|> try applyParser + <|> varParser + "term" + +table :: [[Operator Parser (Expr Annotation)]] +table = + [ [binary "*" (EInfix mempty OpMultiply)], + [ binary "+" (EInfix mempty OpAdd), + binary "-" (EInfix mempty OpSubtract) + ], + [binary "==" (EInfix mempty OpEquals)] + ] + +binary :: Text -> (a -> a -> a) -> Operator Parser a +binary name f = InfixL (f <$ stringLiteral name) + +ifParser :: Parser (Expr Annotation) +ifParser = addLocation $ do + stringLiteral "if" + predExpr <- exprParser + stringLiteral "then" + thenExpr <- exprParser + stringLiteral "else" + EIf mempty predExpr thenExpr <$> exprParser + +varParser :: Parser (Expr Annotation) +varParser = addLocation $ EVar mempty <$> identifierParser + +applyParser :: Parser (Expr Annotation) +applyParser = addLocation $ do + fnName <- functionNameParser + stringLiteral "(" + args <- sepBy exprParser (stringLiteral ",") + stringLiteral ")" + pure (EApply mempty fnName args) + +tupleParser :: Parser (Expr Annotation) +tupleParser = label "tuple" $ + addLocation $ do + _ <- stringLiteral "(" + neArgs <- NE.fromList <$> sepBy1 exprParser (stringLiteral ",") + neTail <- case NE.nonEmpty (NE.tail neArgs) of + Just ne -> pure ne + _ -> fail "Expected at least two items in a tuple" + _ <- stringLiteral ")" + pure (ETuple mempty (NE.head neArgs) neTail) + +tupleAccessParser :: Parser (Expr Annotation) +tupleAccessParser = + let natParser :: Parser Natural + natParser = myLexeme (fromIntegral <$> intParser) + + tupParser :: Parser (Expr Annotation) + tupParser = try tupleParser <|> try varParser <|> applyParser + in label "tuple access" $ + addLocation $ do + tup <- tupParser + stringLiteral "." + ETupleAccess mempty tup <$> natParser diff --git a/wasm-calc5/src/Calc/Parser/Function.hs b/wasm-calc5/src/Calc/Parser/Function.hs new file mode 100644 index 00000000..508ccb5c --- /dev/null +++ b/wasm-calc5/src/Calc/Parser/Function.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Parser.Function (functionParser, functionNameParser) where + +import Calc.Parser.Expr +import Calc.Parser.Identifier +import Calc.Parser.Shared +import Calc.Parser.Type +import Calc.Parser.Types +import Calc.Types.Annotation +import Calc.Types.Function +import Calc.Types.Identifier +import Calc.Types.Type +import Text.Megaparsec + +argumentNameParser :: Parser ArgumentName +argumentNameParser = do + (Identifier fnName) <- identifierParser + pure (ArgumentName fnName) + +functionParser :: Parser (Function Annotation) +functionParser = + withLocation (\ann (args, fnName, expr) -> Function ann args fnName expr) innerParser + where + innerParser = do + stringLiteral "function" + fnName <- functionNameParser + stringLiteral "(" + args <- sepBy argTypeParser (stringLiteral ",") + stringLiteral ")" + stringLiteral "{" + expr <- exprParser + stringLiteral "}" + pure (args, fnName, expr) + +argTypeParser :: Parser (ArgumentName, Type Annotation) +argTypeParser = do + arg <- argumentNameParser + stringLiteral ":" + (,) arg <$> typeParser diff --git a/wasm-calc5/src/Calc/Parser/Identifier.hs b/wasm-calc5/src/Calc/Parser/Identifier.hs new file mode 100644 index 00000000..01c04f2e --- /dev/null +++ b/wasm-calc5/src/Calc/Parser/Identifier.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Parser.Identifier + ( identifierParser, + functionNameParser, + ) +where + +import Calc.Parser.Shared +import Calc.Parser.Types +import Calc.Types +import Control.Monad +import qualified Data.Char as Char +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import Text.Megaparsec + +protectedNames :: Set Text +protectedNames = + S.fromList + [ "if", + "then", + "else", + "function" + ] + +filterProtectedNames :: Text -> Maybe Text +filterProtectedNames tx = + if S.member tx protectedNames + then Nothing + else Just tx + +-- identifier + +identifierParser :: Parser Identifier +identifierParser = + myLexeme identifierParserInternal + +-- use this when you are going to wrap myLexeme yourself +identifierParserInternal :: Parser Identifier +identifierParserInternal = + maybePred + (takeWhile1P (Just "variable name") Char.isAlphaNum) + (filterProtectedNames >=> safeMkIdentifier) + +functionNameParser :: Parser FunctionName +functionNameParser = do + (Identifier fnName) <- identifierParser + pure (FunctionName fnName) diff --git a/wasm-calc5/src/Calc/Parser/Module.hs b/wasm-calc5/src/Calc/Parser/Module.hs new file mode 100644 index 00000000..92687bc7 --- /dev/null +++ b/wasm-calc5/src/Calc/Parser/Module.hs @@ -0,0 +1,13 @@ +module Calc.Parser.Module (moduleParser) where + +import Calc.Parser.Expr +import Calc.Parser.Function +import Calc.Parser.Types +import Calc.Types.Annotation +import Calc.Types.Module +import Text.Megaparsec + +moduleParser :: Parser (Module Annotation) +moduleParser = do + funcs <- many functionParser + Module funcs <$> exprParser diff --git a/wasm-calc5/src/Calc/Parser/Pattern.hs b/wasm-calc5/src/Calc/Parser/Pattern.hs new file mode 100644 index 00000000..a959ce8f --- /dev/null +++ b/wasm-calc5/src/Calc/Parser/Pattern.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Parser.Pattern + ( patternParser, + ParserPattern, + ) +where + +import Calc.Parser.Identifier +import Calc.Parser.Primitives +import Calc.Parser.Shared +import Calc.Parser.Types +import Calc.Types +import qualified Data.List.NonEmpty as NE +import Text.Megaparsec +import Text.Megaparsec.Char + +type ParserPattern = Pattern Annotation + +patternParser :: Parser ParserPattern +patternParser = + label + "pattern match" + ( orInBrackets + ( try patTupleParser + <|> try patWildcardParser + <|> try patVariableParser + <|> patLitParser + ) + ) + +---- + +patWildcardParser :: Parser ParserPattern +patWildcardParser = + myLexeme $ + withLocation + (\loc _ -> PWildcard loc) + (string "_") + +---- + +patVariableParser :: Parser ParserPattern +patVariableParser = + myLexeme $ withLocation PVar identifierParser + +---- + +patTupleParser :: Parser ParserPattern +patTupleParser = label "tuple" $ + withLocation (\loc (pHead, pTail) -> PTuple loc pHead pTail) $ do + _ <- stringLiteral "(" + neArgs <- NE.fromList <$> sepBy1 patternParser (stringLiteral ",") + neTail <- case NE.nonEmpty (NE.tail neArgs) of + Just ne -> pure ne + _ -> fail "Expected at least two items in a tuple" + _ <- stringLiteral ")" + pure (NE.head neArgs, neTail) + +---- + +patLitParser :: Parser ParserPattern +patLitParser = myLexeme $ withLocation PLiteral primParser diff --git a/wasm-calc5/src/Calc/Parser/Primitives.hs b/wasm-calc5/src/Calc/Parser/Primitives.hs new file mode 100644 index 00000000..df755fe4 --- /dev/null +++ b/wasm-calc5/src/Calc/Parser/Primitives.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Parser.Primitives + ( primExprParser, + primParser, + intParser, + ) +where + +import Calc.Parser.Shared +import Calc.Parser.Types +import Calc.Types.Expr +import Calc.Types.Prim +import Control.Applicative +import Data.Functor (($>)) +import Text.Megaparsec (try) +import qualified Text.Megaparsec.Char.Lexer as L + +---- + +intParser :: Parser Integer +intParser = + L.signed (pure ()) L.decimal + +--- + +floatParser :: Parser Float +floatParser = + L.signed (pure ()) L.float + +--- + +truePrimParser :: Parser Prim +truePrimParser = PBool <$> trueParser + +trueParser :: Parser Bool +trueParser = stringLiteral "True" $> True + +falsePrimParser :: Parser Prim +falsePrimParser = PBool <$> falseParser + +falseParser :: Parser Bool +falseParser = stringLiteral "False" $> False + +--- + +primExprParser :: Parser ParserExpr +primExprParser = + myLexeme $ + addLocation $ + try (EPrim mempty . PFloat <$> floatParser) + <|> EPrim mempty . PInt <$> intParser + <|> EPrim mempty <$> truePrimParser + <|> EPrim mempty <$> falsePrimParser + +---- + +primParser :: Parser Prim +primParser = + try (PFloat <$> floatParser) + <|> PInt <$> intParser + <|> truePrimParser + <|> falsePrimParser diff --git a/wasm-calc5/src/Calc/Parser/Shared.hs b/wasm-calc5/src/Calc/Parser/Shared.hs new file mode 100644 index 00000000..0f3a8c4e --- /dev/null +++ b/wasm-calc5/src/Calc/Parser/Shared.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Parser.Shared + ( orInBrackets, + inBrackets, + myLexeme, + withLocation, + stringLiteral, + addLocation, + addTypeLocation, + maybePred, + ) +where + +import Calc.ExprUtils +import Calc.Parser.Types +import Calc.TypeUtils +import Calc.Types.Annotation +import Data.Functor (($>)) +import Data.Text (Text) +import qualified Data.Text as T +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +between2 :: Char -> Char -> Parser a -> Parser a +between2 a b parser = do + _ <- myLexeme (char a) + val <- parser + _ <- myLexeme (char b) + pure val + +withLocation :: (Annotation -> a -> b) -> Parser a -> Parser b +withLocation withP p = do + start <- getOffset + value <- p + end <- getOffset + pure (withP (Location start end) value) + +-- | wraps any parser of Exprs and adds location information +addLocation :: Parser ParserExpr -> Parser ParserExpr +addLocation = withLocation (mapOuterExprAnnotation . const) + +-- | wraps any parser of Type and adds location information +addTypeLocation :: Parser ParserType -> Parser ParserType +addTypeLocation = withLocation (mapOuterTypeAnnotation . const) + +inBrackets :: Parser a -> Parser a +inBrackets = between2 '(' ')' + +orInBrackets :: Parser a -> Parser a +orInBrackets parser = try parser <|> try (inBrackets parser) + +myLexeme :: Parser a -> Parser a +myLexeme = L.lexeme (L.space space1 empty empty) + +stringLiteral :: Text -> Parser () +stringLiteral s = myLexeme (string s) $> () + +maybePred :: (Show a) => Parser a -> (a -> Maybe b) -> Parser b +maybePred parser predicate' = try $ do + a <- parser + case predicate' a of + Just b -> pure b + _ -> fail $ T.unpack $ "Predicate did not hold for " <> T.pack (show a) diff --git a/wasm-calc5/src/Calc/Parser/Type.hs b/wasm-calc5/src/Calc/Parser/Type.hs new file mode 100644 index 00000000..e14dbd88 --- /dev/null +++ b/wasm-calc5/src/Calc/Parser/Type.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Parser.Type (typeParser) where + +import Calc.Parser.Shared + ( addTypeLocation, + myLexeme, + stringLiteral, + ) +import Calc.Parser.Types +import Calc.Types.Type +import Data.Functor (($>)) +import qualified Data.List.NonEmpty as NE +import Text.Megaparsec + ( MonadParsec (try), + label, + sepBy1, + (<|>), + ) + +-- | top-level parser for type signatures +typeParser :: Parser ParserType +typeParser = + tyPrimitiveParser <|> tyTupleParser + +tyPrimitiveParser :: Parser ParserType +tyPrimitiveParser = myLexeme $ addTypeLocation $ TPrim mempty <$> tyPrimParser + where + tyPrimParser = + try (stringLiteral "Boolean" $> TBool) + <|> try (stringLiteral "Integer" $> TInt) + <|> stringLiteral "Float" + $> TFloat + +tyTupleParser :: Parser ParserType +tyTupleParser = label "tuple" $ + addTypeLocation $ do + _ <- stringLiteral "(" + neArgs <- NE.fromList <$> sepBy1 typeParser (stringLiteral ",") + 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) diff --git a/wasm-calc5/src/Calc/Parser/Types.hs b/wasm-calc5/src/Calc/Parser/Types.hs new file mode 100644 index 00000000..8d82da38 --- /dev/null +++ b/wasm-calc5/src/Calc/Parser/Types.hs @@ -0,0 +1,30 @@ +module Calc.Parser.Types + ( Parser, + ParseErrorType, + ParserExpr, + ParserType, + ParserFunction, + ParserModule, + ) +where + +import Calc.Types.Annotation +import Calc.Types.Expr +import Calc.Types.Function +import Calc.Types.Module +import Calc.Types.Type +import Data.Text (Text) +import Data.Void +import Text.Megaparsec + +type Parser = Parsec Void Text + +type ParseErrorType = ParseErrorBundle Text Void + +type ParserExpr = Expr Annotation + +type ParserType = Type Annotation + +type ParserFunction = Function Annotation + +type ParserModule = Module Annotation diff --git a/wasm-calc5/src/Calc/Repl.hs b/wasm-calc5/src/Calc/Repl.hs new file mode 100644 index 00000000..ddf31bdc --- /dev/null +++ b/wasm-calc5/src/Calc/Repl.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS -Wno-orphans #-} + +module Calc.Repl + ( repl, + ) +where + +import Calc.Parser +import Calc.Parser.Types +import Calc.Typecheck.Elaborate +import Calc.Typecheck.Error +import Calc.Wasm.FromExpr +import Calc.Wasm.Run +import Calc.Wasm.ToWasm +import Calc.Wasm.Types +import Control.Monad.IO.Class +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void +import qualified Error.Diagnose as Diag +import Error.Diagnose.Compat.Megaparsec +import qualified Language.Wasm.Interpreter as Wasm +import System.Console.Haskeline + +instance HasHints Void msg where + hints _ = mempty + +repl :: IO () +repl = do + putStrLn "Welcome to llvm-calc" + putStrLn "Exit with :quit" + runInputT defaultSettings loop + where + loop :: InputT IO () + loop = do + minput <- getInputLine ":> " + case minput of + Nothing -> return () + Just ":quit" -> return () + Just input -> do + case parseModule (T.pack input) of + Left bundle -> do + printDiagnostic (fromErrorBundle bundle input) + loop + Right expr -> case elaborateModule expr of + Left typeErr -> do + printDiagnostic (typeErrorDiagnostic (T.pack input) typeErr) + loop + Right typedMod -> do + case fromModule typedMod of + Left _fromWasmError -> do + -- printDiagnostic "From Wasm Error" + loop + Right wasmMod -> do + resp <- liftIO $ runWasmModule wasmMod + liftIO $ putStrLn resp + loop + +runWasmModule :: WasmModule -> IO String +runWasmModule mod' = + do + maybeValues <- runWasm (moduleToWasm mod') + case maybeValues of + Just [Wasm.VI32 i] -> pure $ show i + Just [Wasm.VI64 i] -> pure $ show i + Just [Wasm.VF32 f] -> pure $ show f + Just [Wasm.VF64 f] -> pure $ show f + other -> error $ "Expected a single return value but got " <> show other + +printDiagnostic :: (MonadIO m) => Diag.Diagnostic Text -> m () +printDiagnostic = + Diag.printDiagnostic + Diag.stderr + Diag.WithUnicode + (Diag.TabSize 4) + Diag.defaultStyle + +-- | turn Megaparsec error + input into a Diagnostic +fromErrorBundle :: ParseErrorType -> String -> Diag.Diagnostic Text +fromErrorBundle bundle input = + let diag = + errorDiagnosticFromBundle + Nothing + "Parse error on input" + Nothing + bundle + in Diag.addFile diag replFilename input diff --git a/wasm-calc5/src/Calc/SourceSpan.hs b/wasm-calc5/src/Calc/SourceSpan.hs new file mode 100644 index 00000000..bcab9f5a --- /dev/null +++ b/wasm-calc5/src/Calc/SourceSpan.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +module Calc.SourceSpan (sourceSpan, SourceSpan (..)) where + +import Calc.Types.Annotation +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +data SourceSpan = SourceSpan + { ssRowStart :: Int, + ssRowEnd :: Int, + ssColStart :: Int, + ssColEnd :: Int + } + deriving stock (Eq, Ord, Show, Generic) + +lineLengths :: Text -> [Int] +lineLengths tx = T.length <$> T.lines tx + +toColumnAndRow :: [Int] -> Int -> (Int, Int) +toColumnAndRow = go 1 + where + go row [] col = + (row, col) + go row (line : rest) col + | (col - 1) >= line = + go (row + 1) rest (col - line - 1) + go row _ col = (row, col) + +sourceSpan :: Text -> Annotation -> Maybe SourceSpan +sourceSpan tx (Location start end) = + let (startRow, startCol) = + toColumnAndRow (lineLengths tx) start + (endRow, endCol) = + toColumnAndRow (lineLengths tx) end + in Just + ( SourceSpan + { ssRowStart = startRow, + ssRowEnd = endRow, + ssColStart = startCol + 1, + ssColEnd = endCol + 1 + } + ) diff --git a/wasm-calc5/src/Calc/TypeUtils.hs b/wasm-calc5/src/Calc/TypeUtils.hs new file mode 100644 index 00000000..53825e4f --- /dev/null +++ b/wasm-calc5/src/Calc/TypeUtils.hs @@ -0,0 +1,13 @@ +module Calc.TypeUtils (mapOuterTypeAnnotation, getOuterTypeAnnotation) where + +import Calc.Types.Type + +getOuterTypeAnnotation :: Type ann -> ann +getOuterTypeAnnotation (TPrim ann _) = ann +getOuterTypeAnnotation (TFunction ann _ _) = ann +getOuterTypeAnnotation (TTuple 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 diff --git a/wasm-calc5/src/Calc/Typecheck/Elaborate.hs b/wasm-calc5/src/Calc/Typecheck/Elaborate.hs new file mode 100644 index 00000000..f090be8c --- /dev/null +++ b/wasm-calc5/src/Calc/Typecheck/Elaborate.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Calc.Typecheck.Elaborate + ( elaborate, + elaborateFunction, + elaborateModule, + ) +where + +import Calc.ExprUtils +import Calc.TypeUtils +import Calc.Typecheck.Error +import Calc.Typecheck.Types +import Calc.Types.Expr +import Calc.Types.Function +import Calc.Types.Module +import Calc.Types.Prim +import Calc.Types.Type +import Control.Monad (when, zipWithM) +import Control.Monad.Except +import Data.Bifunctor (second) +import Data.Functor +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE + +elaborateModule :: + forall ann. + Module ann -> + Either (TypeError ann) (Module (Type ann)) +elaborateModule (Module {mdFunctions, mdExpr}) = runTypecheckM (TypecheckEnv mempty) $ do + fns <- + traverse + ( \fn -> do + elabFn <- elaborateFunction fn + storeFunction (fnFunctionName elabFn) (fnAnn elabFn) + pure elabFn + ) + mdFunctions + + Module fns <$> infer mdExpr + +elaborateFunction :: + Function ann -> + TypecheckM ann (Function (Type ann)) +elaborateFunction (Function ann args name expr) = do + exprA <- withFunctionArgs args (infer expr) + let argsA = fmap (second (\ty -> fmap (const ty) ty)) args + let tyFn = TFunction ann (snd <$> args) (getOuterAnnotation exprA) + pure (Function tyFn argsA name exprA) + +elaborate :: Expr ann -> Either (TypeError ann) (Expr (Type ann)) +elaborate = runTypecheckM (TypecheckEnv mempty) . infer + +check :: Type ann -> Expr ann -> TypecheckM ann (Expr (Type ann)) +check ty expr = do + exprA <- infer expr + _ <- checkTypeIsEqual ty (getOuterAnnotation exprA) + pure (mapOuterExprAnnotation (const ty) exprA) + +-- simple check for now +checkTypeIsEqual :: Type ann -> Type ann -> TypecheckM ann (Type ann) +checkTypeIsEqual tyA tyB = + if void tyA == void tyB + then pure tyA + else throwError (TypeMismatch tyA tyB) + +inferIf :: + ann -> + Expr ann -> + Expr ann -> + Expr ann -> + TypecheckM ann (Expr (Type ann)) +inferIf ann predExpr thenExpr elseExpr = do + predA <- infer predExpr + case getOuterAnnotation predA of + (TPrim _ TBool) -> pure () + otherType -> throwError (PredicateIsNotBoolean ann otherType) + thenA <- infer thenExpr + elseA <- check (getOuterAnnotation thenA) elseExpr + pure (EIf (getOuterAnnotation elseA) predA thenA elseA) + +inferInfix :: + ann -> + Op -> + Expr ann -> + Expr ann -> + TypecheckM ann (Expr (Type ann)) +inferInfix ann OpEquals a b = do + elabA <- infer a + elabB <- infer b + ty <- case (getOuterAnnotation elabA, getOuterAnnotation elabB) of + (TPrim _ tA, TPrim _ tB) + | tA == tB -> + -- if the types are the same, then great! it's a bool! + pure (TPrim ann TBool) + (otherA, otherB) -> + -- otherwise, error! + throwError (TypeMismatch otherA otherB) + pure (EInfix ty OpEquals elabA elabB) +inferInfix ann op a b = do + elabA <- infer a + elabB <- infer b + -- all the other infix operators need to be Int -> Int -> Int + ty <- case (getOuterAnnotation elabA, getOuterAnnotation elabB) of + (TPrim _ TInt, TPrim _ TInt) -> + -- if the types are the same, then great! it's an int! + pure (TPrim ann TInt) + (TPrim _ TFloat, TPrim _ TFloat) -> + -- if the types are the same, then great! it's a float! + pure (TPrim ann TFloat) + (otherA, otherB) -> + let filterSame (tA, tB) = void tA /= void tB + in -- otherwise, error! + throwError + ( InfixTypeMismatch + op + $ filter + filterSame + [ (TPrim (getOuterTypeAnnotation otherA) TInt, otherA), + (TPrim (getOuterTypeAnnotation otherB) TInt, otherB) + ] + ) + pure (EInfix ty op elabA elabB) + +infer :: Expr ann -> TypecheckM ann (Expr (Type ann)) +infer (EPrim ann prim) = + pure (EPrim (typeFromPrim ann prim) prim) +infer (EIf ann predExpr thenExpr elseExpr) = + inferIf ann predExpr thenExpr elseExpr +infer (ETuple ann fstExpr restExpr) = do + typedFst <- infer fstExpr + typedRest <- traverse infer restExpr + let typ = + TTuple + ann + (getOuterAnnotation typedFst) + (getOuterAnnotation <$> typedRest) + pure $ ETuple typ typedFst typedRest +infer (ETupleAccess ann tup index) = do + tyTup <- infer tup + case getOuterAnnotation tyTup of + TTuple _ tyFst tyRest -> + let tyAll = zip ([0 ..] :: [Int]) (tyFst : NE.toList tyRest) + in case List.lookup (fromIntegral $ index - 1) tyAll of + Just ty -> + pure (ETupleAccess ty tyTup index) + Nothing -> throwError $ AccessingOutsideTupleBounds ann (getOuterAnnotation tyTup) index + otherTy -> throwError $ AccessingNonTuple ann otherTy +infer (EApply ann fnName args) = do + fn <- lookupFunction ann fnName + (ty, elabArgs) <- case fn of + TFunction _ tArgs tReturn -> do + when + (length args /= length tArgs) + (throwError $ FunctionArgumentLengthMismatch ann (length tArgs) (length args)) + elabArgs <- zipWithM check tArgs args -- check each arg against type + pure (tReturn, elabArgs) + _ -> throwError $ NonFunctionTypeFound ann fn + pure (EApply (ty $> ann) fnName elabArgs) +infer (EVar ann var) = do + ty <- lookupVar ann var + pure (EVar ty var) +infer (EInfix ann op a b) = + inferInfix ann op a b + +typePrimFromPrim :: Prim -> TypePrim +typePrimFromPrim (PInt _) = TInt +typePrimFromPrim (PBool _) = TBool +typePrimFromPrim (PFloat _) = TFloat + +typeFromPrim :: ann -> Prim -> Type ann +typeFromPrim ann prim = TPrim ann (typePrimFromPrim prim) diff --git a/wasm-calc5/src/Calc/Typecheck/Error.hs b/wasm-calc5/src/Calc/Typecheck/Error.hs new file mode 100644 index 00000000..83ecff6c --- /dev/null +++ b/wasm-calc5/src/Calc/Typecheck/Error.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Typecheck.Error (TypeError (..), typeErrorDiagnostic) where + +import Calc.SourceSpan +import Calc.TypeUtils +import Calc.Types.Annotation +import Calc.Types.Expr +import Calc.Types.FunctionName +import Calc.Types.Identifier +import Calc.Types.Type +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS +import Data.Maybe (catMaybes, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Error.Diagnose as Diag +import GHC.Natural +import qualified Prettyprinter as PP +import qualified Prettyprinter.Render.Text as PP + +data TypeError ann + = PredicateIsNotBoolean ann (Type ann) + | InfixTypeMismatch Op [(Type ann, Type ann)] + | TypeMismatch (Type ann) (Type ann) + | VarNotFound ann Identifier (HashSet Identifier) + | FunctionNotFound ann FunctionName (HashSet FunctionName) + | FunctionArgumentLengthMismatch ann Int Int -- expected, actual + | NonFunctionTypeFound ann (Type ann) + | AccessingNonTuple ann (Type ann) + | AccessingOutsideTupleBounds ann (Type ann) Natural + deriving stock (Eq, Ord, Show) + +positionFromAnnotation :: + String -> + Text -> + Annotation -> + Maybe Diag.Position +positionFromAnnotation path input ann = + let toPos ss = + Diag.Position + (ssRowStart ss, ssColStart ss) + (ssRowEnd ss, ssColEnd ss) + path + in toPos <$> sourceSpan input ann + +prettyPrint :: PP.Doc doc -> Text +prettyPrint = renderWithWidth 40 + +typeErrorDiagnostic :: + Text -> + TypeError Annotation -> + Diag.Diagnostic Text +typeErrorDiagnostic input e = + let filename = "" + diag = Diag.addFile mempty filename (T.unpack input) + report = case e of + (NonFunctionTypeFound _ ty) -> + Diag.Err + Nothing + ( prettyPrint "Function type expected but not found." + ) + ( catMaybes + [ (,) + <$> positionFromAnnotation + filename + input + (getOuterTypeAnnotation ty) + <*> pure + ( Diag.This + ( prettyPrint $ + "This has type " + <> PP.pretty ty + <> "." + ) + ) + ] + ) + [] + (FunctionArgumentLengthMismatch ann expected actual) -> + Diag.Err + Nothing + ( prettyPrint "Wrong number of arguments passed to function!" + ) + ( catMaybes + [ (,) + <$> positionFromAnnotation + filename + input + ann + <*> pure + ( Diag.This + ( prettyPrint $ + "Expected " + <> PP.pretty expected + <> " but found " + <> PP.pretty actual + <> "." + ) + ) + ] + ) + [] + (PredicateIsNotBoolean _ foundType) -> + Diag.Err + Nothing + ( prettyPrint $ + "Predicate for an if statement should be a Boolean type, but instead found " + <> PP.pretty foundType + <> "." + ) + ( catMaybes + [ (,) + <$> positionFromAnnotation + filename + input + (getOuterTypeAnnotation foundType) + <*> pure + ( Diag.This (prettyPrint $ "This has type " <> PP.pretty foundType <> " but should have type Boolean") + ) + ] + ) + [] + (TypeMismatch a b) -> + Diag.Err + Nothing + ( prettyPrint $ + "Unification error! Expected matching types but found " + <> PP.pretty a + <> " and " + <> PP.pretty b + <> "." + ) + ( catMaybes + [ (,) + <$> positionFromAnnotation + filename + input + (getOuterTypeAnnotation a) + <*> pure + ( Diag.This (prettyPrint $ "This has type " <> PP.pretty a) + ), + (,) + <$> positionFromAnnotation + filename + input + (getOuterTypeAnnotation b) + <*> pure (Diag.Where (prettyPrint $ "This has type " <> PP.pretty b)) + ] + ) + ["These two values should be of the same type"] + (InfixTypeMismatch _op pairs) -> + let makeThis (expect, actual) = + (,) + <$> positionFromAnnotation + filename + input + (getOuterTypeAnnotation actual) + <*> pure + ( Diag.This (prettyPrint $ "This has type " <> PP.pretty actual <> " but should have type " <> PP.pretty expect) + ) + in Diag.Err + Nothing + "Type mismatch for infix operator" + ( mapMaybe makeThis pairs + ) + [] + (AccessingNonTuple ann ty) -> + Diag.Err + Nothing + "Accessing non-tuple" + ( catMaybes + [ (,) + <$> positionFromAnnotation + filename + input + ann + <*> pure + ( Diag.This (prettyPrint $ "Expected a tuple type here but found " <> PP.pretty ty) + ) + ] + ) + [] + (AccessingOutsideTupleBounds ann ty index) -> + Diag.Err + Nothing + "Accessing item outside tuple" + ( catMaybes + [ (,) + <$> positionFromAnnotation + filename + input + ann + <*> pure + ( Diag.This (prettyPrint $ "Index " <> PP.pretty index <> " cannot be found in tuple " <> PP.pretty ty) + ) + ] + ) + [] + (VarNotFound ann identifier existing) -> + Diag.Err + Nothing + "Variable not found!" + ( catMaybes + [ (,) + <$> positionFromAnnotation + filename + input + ann + <*> pure + ( Diag.This (prettyPrint $ "Could not find identifier " <> PP.pretty identifier) + ) + ] + ) + [Diag.Note $ "Available in scope: " <> prettyPrint (prettyHashset existing)] + (FunctionNotFound ann fnName existing) -> + Diag.Err + Nothing + "Function not found!" + ( catMaybes + [ (,) + <$> positionFromAnnotation + filename + input + ann + <*> pure + ( Diag.This (prettyPrint $ "Could not find function " <> PP.pretty fnName) + ) + ] + ) + [Diag.Note $ "Available in scope: " <> prettyPrint (prettyHashset existing)] + in Diag.addReport diag report + +-- | becomes "a, b, c, d" +prettyHashset :: (PP.Pretty a) => HashSet a -> PP.Doc ann +prettyHashset hs = + PP.concatWith + (PP.surround PP.comma) + (PP.pretty <$> HS.toList hs) + +renderWithWidth :: Int -> PP.Doc ann -> Text +renderWithWidth w doc = PP.renderStrict (PP.layoutPretty layoutOptions (PP.unAnnotate doc)) + where + layoutOptions = PP.LayoutOptions {PP.layoutPageWidth = PP.AvailablePerLine w 1} diff --git a/wasm-calc5/src/Calc/Typecheck/Types.hs b/wasm-calc5/src/Calc/Typecheck/Types.hs new file mode 100644 index 00000000..c28cdcf2 --- /dev/null +++ b/wasm-calc5/src/Calc/Typecheck/Types.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +module Calc.Typecheck.Types + ( TypecheckM (..), + runTypecheckM, + TypecheckEnv (..), + lookupVar, + withVar, + withVars, + lookupFunction, + withFunctionArgs, + storeFunction, + ) +where + +import Calc.Typecheck.Error +import Calc.Types.Function +import Calc.Types.Identifier +import Calc.Types.Type +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Bifunctor (first) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM + +newtype TypecheckEnv ann = TypecheckEnv + { tceVars :: HashMap Identifier (Type ann) + } + deriving stock (Eq, Ord, Show) + +newtype TypecheckState ann = TypecheckState + {tcsFunctions :: HashMap FunctionName (Type ann)} + deriving stock (Eq, Ord, Show) + +newtype TypecheckM ann a = TypecheckM + { getTypecheckM :: + ReaderT (TypecheckEnv ann) (StateT (TypecheckState ann) (Either (TypeError ann))) a + } + deriving newtype + ( Functor, + Applicative, + Monad, + MonadReader (TypecheckEnv ann), + MonadError (TypeError ann), + MonadState (TypecheckState ann) + ) + +runTypecheckM :: + TypecheckEnv ann -> + TypecheckM ann a -> + Either (TypeError ann) a +runTypecheckM env action = + evalStateT (runReaderT (getTypecheckM action) env) (TypecheckState mempty) + +storeFunction :: + FunctionName -> + Type ann -> + TypecheckM ann () +storeFunction fnName ty = + modify + ( \tcs -> + tcs + { tcsFunctions = + HM.insert fnName ty (tcsFunctions tcs) + } + ) + +-- | look up a saved identifier "in the environment" +lookupFunction :: ann -> FunctionName -> TypecheckM ann (Type ann) +lookupFunction ann fnName = do + maybeType <- gets (HM.lookup fnName . tcsFunctions) + case maybeType of + Just found -> pure found + Nothing -> do + allFunctions <- gets (HM.keysSet . tcsFunctions) + throwError (FunctionNotFound ann fnName allFunctions) + +-- | look up a saved identifier "in the environment" +lookupVar :: ann -> Identifier -> TypecheckM ann (Type ann) +lookupVar ann identifier = do + maybeType <- asks (HM.lookup identifier . tceVars) + case maybeType of + Just found -> pure found + Nothing -> do + allIdentifiers <- asks (HM.keysSet . tceVars) + throwError (VarNotFound ann identifier allIdentifiers) + +-- | add an identifier to the environment +withVar :: Identifier -> Type ann -> TypecheckM ann a -> TypecheckM ann a +withVar identifier ty = + local + ( \tce -> + tce + { tceVars = + HM.insert identifier ty (tceVars tce) + } + ) + +withVars :: [(Identifier, Type ann)] -> TypecheckM ann a -> TypecheckM ann a +withVars args = + local + ( \tce -> + tce + { tceVars = tceVars tce <> HM.fromList args + } + ) + +withFunctionArgs :: + [(ArgumentName, Type ann)] -> + TypecheckM ann a -> + TypecheckM ann a +withFunctionArgs = + withVars + . fmap (first (\(ArgumentName arg) -> Identifier arg)) diff --git a/wasm-calc5/src/Calc/Types.hs b/wasm-calc5/src/Calc/Types.hs new file mode 100644 index 00000000..2e4bf622 --- /dev/null +++ b/wasm-calc5/src/Calc/Types.hs @@ -0,0 +1,18 @@ +module Calc.Types + ( module Calc.Types.Annotation, + module Calc.Types.Identifier, + module Calc.Types.Expr, + module Calc.Types.Function, + module Calc.Types.Module, + module Calc.Types.Prim, + module Calc.Types.Type, + ) +where + +import Calc.Types.Annotation +import Calc.Types.Expr +import Calc.Types.Function +import Calc.Types.Identifier +import Calc.Types.Module +import Calc.Types.Prim +import Calc.Types.Type diff --git a/wasm-calc5/src/Calc/Types/Annotation.hs b/wasm-calc5/src/Calc/Types/Annotation.hs new file mode 100644 index 00000000..28992bdc --- /dev/null +++ b/wasm-calc5/src/Calc/Types/Annotation.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Calc.Types.Annotation + ( Annotation (..), + ) +where + +-- | `Annotation` is used to track source code location +-- it is added to parts of `Expr` during parsing and used to +-- make errors nicer +data Annotation = Location Int Int + deriving stock (Eq, Ord, Show) + +-- | when combining two `Annotation`, combine to make one big annotation +instance Semigroup Annotation where + (Location start end) <> (Location start' end') = + Location (min start start') (max end end') + +-- | Default to an empty `Annotation` +instance Monoid Annotation where + mempty = Location 0 0 diff --git a/wasm-calc5/src/Calc/Types/Expr.hs b/wasm-calc5/src/Calc/Types/Expr.hs new file mode 100644 index 00000000..71f84425 --- /dev/null +++ b/wasm-calc5/src/Calc/Types/Expr.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Types.Expr (Expr (..), Op (..)) where + +import Calc.Types.FunctionName +import Calc.Types.Identifier +import Calc.Types.Prim +import qualified Data.List.NonEmpty as NE +import GHC.Natural +import Prettyprinter ((<+>)) +import qualified Prettyprinter as PP + +data Expr ann + = EPrim ann Prim + | EInfix ann Op (Expr ann) (Expr ann) + | EIf ann (Expr ann) (Expr ann) (Expr ann) + | EVar ann Identifier + | EApply ann FunctionName [Expr ann] + | ETuple ann (Expr ann) (NE.NonEmpty (Expr ann)) + | ETupleAccess ann (Expr ann) Natural + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + +-- when on multilines, indent by `i`, if not then nothing +indentMulti :: Integer -> PP.Doc style -> PP.Doc style +indentMulti i doc = + PP.flatAlt (PP.indent (fromIntegral i) doc) doc + +-- | this instance defines how to nicely print `Expr` +instance PP.Pretty (Expr ann) where + pretty (EPrim _ prim) = + PP.pretty prim + pretty (EInfix _ op a b) = + PP.pretty a <+> PP.pretty op <+> PP.pretty b + pretty (EIf _ predExpr thenExpr elseExpr) = + "if" <+> PP.pretty predExpr <+> "then" <+> indentMulti 2 (PP.pretty thenExpr) <+> "else" <+> indentMulti 2 (PP.pretty elseExpr) + pretty (EVar _ ident) = PP.pretty ident + pretty (EApply _ fn args) = PP.pretty fn <> "(" <> PP.cat pArgs <> ")" + where + pArgs = PP.punctuate "," (PP.pretty <$> args) + pretty (ETuple _ a as) = + "(" <> PP.cat (PP.punctuate "," (PP.pretty <$> tupleItems a as)) <> ")" + where + tupleItems :: a -> NE.NonEmpty a -> [a] + tupleItems b bs = b : NE.toList bs + pretty (ETupleAccess _ tup nat) = + PP.pretty tup <> "." <> PP.pretty nat + +data Op + = OpAdd + | OpMultiply + | OpSubtract + | OpEquals + deriving stock (Eq, Ord, Show) + +-- how to print `Op` values +instance PP.Pretty Op where + pretty OpAdd = "+" + pretty OpMultiply = "*" + pretty OpSubtract = "-" + pretty OpEquals = "==" diff --git a/wasm-calc5/src/Calc/Types/Function.hs b/wasm-calc5/src/Calc/Types/Function.hs new file mode 100644 index 00000000..d4ead514 --- /dev/null +++ b/wasm-calc5/src/Calc/Types/Function.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +module Calc.Types.Function + ( ArgumentName (..), + FunctionName (..), + Function (..), + ) +where + +import Calc.Types.Expr +import Calc.Types.FunctionName +import Calc.Types.Type +import Data.String +import Data.Text (Text) +import qualified Data.Text as T + +newtype ArgumentName = ArgumentName Text + deriving newtype (Eq, Ord, Show) + +instance IsString ArgumentName where + fromString = ArgumentName . T.pack + +data Function ann = Function + { fnAnn :: ann, + fnArgs :: [(ArgumentName, Type ann)], + fnFunctionName :: FunctionName, + fnBody :: Expr ann + } + deriving stock (Eq, Ord, Show, Functor) diff --git a/wasm-calc5/src/Calc/Types/FunctionName.hs b/wasm-calc5/src/Calc/Types/FunctionName.hs new file mode 100644 index 00000000..94213134 --- /dev/null +++ b/wasm-calc5/src/Calc/Types/FunctionName.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +module Calc.Types.FunctionName + ( FunctionName (..), + ) +where + +import Data.Hashable +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import qualified Prettyprinter as PP + +newtype FunctionName = FunctionName Text + deriving newtype (Eq, Ord, Show, Hashable) + +instance IsString FunctionName where + fromString = FunctionName . T.pack + +instance PP.Pretty FunctionName where + pretty (FunctionName fn) = PP.pretty fn diff --git a/wasm-calc5/src/Calc/Types/Identifier.hs b/wasm-calc5/src/Calc/Types/Identifier.hs new file mode 100644 index 00000000..f8a99b07 --- /dev/null +++ b/wasm-calc5/src/Calc/Types/Identifier.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +module Calc.Types.Identifier (Identifier (..), safeMkIdentifier) where + +import qualified Data.Char as Ch +import Data.Hashable +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import qualified Prettyprinter as PP + +newtype Identifier = Identifier Text + deriving newtype (Eq, Ord, Show, Hashable) + +instance IsString Identifier where + fromString = Identifier . T.pack + +instance PP.Pretty Identifier where + pretty (Identifier ident) = PP.pretty ident + +validIdentifier :: Text -> Bool +validIdentifier a = + T.length a > 0 + && T.filter Ch.isAlphaNum a == a + && not (Ch.isDigit (T.head a)) + && Ch.isLower (T.head a) + +safeMkIdentifier :: Text -> Maybe Identifier +safeMkIdentifier a = + if validIdentifier a + then Just (Identifier a) + else Nothing diff --git a/wasm-calc5/src/Calc/Types/Module.hs b/wasm-calc5/src/Calc/Types/Module.hs new file mode 100644 index 00000000..d0415c36 --- /dev/null +++ b/wasm-calc5/src/Calc/Types/Module.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} + +module Calc.Types.Module where + +import Calc.Types.Expr +import Calc.Types.Function + +data Module ann = Module + { mdFunctions :: [Function ann], + mdExpr :: Expr ann + } + deriving stock (Eq, Ord, Show, Functor) diff --git a/wasm-calc5/src/Calc/Types/Prim.hs b/wasm-calc5/src/Calc/Types/Prim.hs new file mode 100644 index 00000000..33dcaa35 --- /dev/null +++ b/wasm-calc5/src/Calc/Types/Prim.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Calc.Types.Prim + ( Prim (..), + ) +where + +import qualified Prettyprinter as PP + +data Prim + = PInt Integer + | PFloat Float + | PBool Bool + deriving stock (Eq, Ord, Show) + +instance PP.Pretty Prim where + pretty (PInt i) = PP.pretty i + pretty (PFloat f) = PP.pretty f + pretty (PBool b) = PP.pretty b diff --git a/wasm-calc5/src/Calc/Types/Type.hs b/wasm-calc5/src/Calc/Types/Type.hs new file mode 100644 index 00000000..134dcedf --- /dev/null +++ b/wasm-calc5/src/Calc/Types/Type.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Types.Type (Type (..), TypePrim (..)) where + +import qualified Data.List.NonEmpty as NE +import qualified Prettyprinter as PP + +data TypePrim = TBool | TInt | TFloat + deriving stock (Eq, Ord, Show) + +instance PP.Pretty TypePrim where + pretty TBool = "Boolean" + pretty TInt = "Integer" + pretty TFloat = "Float" + +data Type ann + = TPrim ann TypePrim + | TFunction ann [Type ann] (Type ann) + | TTuple ann (Type ann) (NE.NonEmpty (Type ann)) + deriving stock (Eq, Ord, Show, Functor) + +instance PP.Pretty (Type ann) where + pretty (TPrim _ prim) = PP.pretty prim + pretty (TFunction _ args ret) = + "(" <> prettyArgs <> ") -> " <> PP.pretty ret + where + prettyArgs = PP.concatWith (PP.surround PP.comma) (PP.pretty <$> args) + pretty (TTuple _ a as) = + "(" <> PP.cat (PP.punctuate "," (PP.pretty <$> tupleItems a as)) <> ")" + where + tupleItems :: a -> NE.NonEmpty a -> [a] + tupleItems b bs = b : NE.toList bs diff --git a/wasm-calc5/src/Calc/Utils.hs b/wasm-calc5/src/Calc/Utils.hs new file mode 100644 index 00000000..a06ff4a9 --- /dev/null +++ b/wasm-calc5/src/Calc/Utils.hs @@ -0,0 +1,25 @@ +module Calc.Utils (ltrace, neZipWithM, neUnzip) where + +-- useful junk goes here + +import Control.Monad (zipWithM) +import Data.Bifunctor +import qualified Data.List.NonEmpty as NE +import qualified Data.Text.Lazy as TL +import qualified Debug.Trace as Debug +import qualified Text.Pretty.Simple as PS + +neZipWithM :: + (Applicative m) => + (a -> b -> m c) -> + NE.NonEmpty a -> + NE.NonEmpty b -> + m (NE.NonEmpty c) +neZipWithM f as bs = + NE.fromList <$> zipWithM f (NE.toList as) (NE.toList bs) + +neUnzip :: NE.NonEmpty (a, b) -> (NE.NonEmpty a, NE.NonEmpty b) +neUnzip = bimap NE.fromList NE.fromList . unzip . NE.toList + +ltrace :: (Show a) => String -> a -> a +ltrace lbl x = Debug.trace (lbl <> ": " <> TL.unpack (PS.pShow x)) x diff --git a/wasm-calc5/src/Calc/Wasm/Allocator.hs b/wasm-calc5/src/Calc/Wasm/Allocator.hs new file mode 100644 index 00000000..c9101097 --- /dev/null +++ b/wasm-calc5/src/Calc/Wasm/Allocator.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Calc.Wasm.Allocator (moduleWithAllocator) where + +import qualified Data.ByteString.Lazy as LB +import Data.FileEmbed +import qualified Language.Wasm as Wasm + +-- these are saved in a file that is included in compilation +allocatorSource :: LB.ByteString +allocatorSource = + LB.fromStrict $(makeRelativeToProject "static/bump-allocator.wat" >>= embedFile) + +-- we have an allocator, we need to import it +moduleWithAllocator :: Wasm.Module +moduleWithAllocator = case Wasm.parse allocatorSource of + Right mod' -> mod' + Left e -> error (show e) diff --git a/wasm-calc5/src/Calc/Wasm/FromExpr.hs b/wasm-calc5/src/Calc/Wasm/FromExpr.hs new file mode 100644 index 00000000..f07c4c76 --- /dev/null +++ b/wasm-calc5/src/Calc/Wasm/FromExpr.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Wasm.FromExpr (fromModule) where + +import Calc.ExprUtils +import Calc.Types.Expr +import Calc.Types.Function +import Calc.Types.Identifier +import Calc.Types.Module +import Calc.Types.Type +import Calc.Wasm.Helpers +import Calc.Wasm.Types +import Control.Monad.Except +import Control.Monad.State +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M +import Data.Monoid +import GHC.Natural + +-- | take our regular module and do the book keeping to get it ready for Wasm +-- town +data FromWasmError + = FunctionTypeNotScalar + | IdentifierNotFound Identifier + | FunctionNotFound FunctionName + deriving stock (Eq, Ord, Show) + +data FromExprState = FromExprState + { fesIdentifiers :: M.Map Identifier Natural, + fesFunctions :: M.Map FunctionName Natural, + fesItems :: [WasmType] + } + +addLocal :: + (MonadState FromExprState m) => + Maybe Identifier -> + WasmType -> + m Natural +addLocal maybeIdent ty = do + len <- gets (fromIntegral . (\fes -> length (fesIdentifiers fes) + length (fesItems fes))) + modify (\fes -> fes {fesItems = fesItems fes <> [ty]}) + case maybeIdent of + Just ident -> modify (\fes -> fes {fesIdentifiers = fesIdentifiers fes <> M.singleton ident len}) + Nothing -> pure () + pure len + +lookupIdent :: + (MonadState FromExprState m, MonadError FromWasmError m) => + Identifier -> + m Natural +lookupIdent ident = do + maybeNat <- gets (M.lookup ident . fesIdentifiers) + case maybeNat of + Just nat -> pure nat + Nothing -> throwError $ IdentifierNotFound ident + +lookupFunction :: + (MonadState FromExprState m, MonadError FromWasmError m) => + FunctionName -> + m Natural +lookupFunction functionName = do + maybeNat <- gets (M.lookup functionName . fesFunctions) + case maybeNat of + Just nat -> pure nat + Nothing -> throwError $ FunctionNotFound functionName + +scalarFromType :: Type ann -> Either FromWasmError WasmType +scalarFromType (TPrim _ TInt) = pure I64 +scalarFromType (TPrim _ TBool) = pure I32 +scalarFromType (TPrim _ TFloat) = pure F64 +scalarFromType (TFunction {}) = Left FunctionTypeNotScalar +scalarFromType (TTuple {}) = pure Pointer + +fromExpr :: + ( MonadError FromWasmError m, + MonadState FromExprState m, + Show ann + ) => + Expr (Type ann) -> + m WasmExpr +fromExpr (EPrim _ prim) = + pure $ WPrim prim +fromExpr (EInfix _ op a b) = do + -- we're assuming that the types of `a` and `b` are the same + -- we want the type of the args, not the result + scalar <- liftEither $ scalarFromType (getOuterAnnotation a) + WInfix scalar op <$> fromExpr a <*> fromExpr b +fromExpr (EIf _ predE thenE elseE) = + WIf <$> fromExpr predE <*> fromExpr thenE <*> fromExpr elseE +fromExpr (EVar _ ident) = + WVar <$> lookupIdent ident +fromExpr (EApply _ funcName args) = + WApply + <$> lookupFunction funcName + <*> traverse fromExpr args -- need to look up the function name in some sort of state +fromExpr (ETuple ty a as) = do + wasmType <- liftEither $ scalarFromType ty + index <- addLocal Nothing wasmType + let allItems = zip [0 ..] (a : NE.toList as) + tupleLength = memorySizeForType ty + allocate = WAllocate (fromIntegral tupleLength) + offsetList = getOffsetList ty + WSet index allocate + <$> traverse + ( \(i, item) -> + (,,) (offsetList !! i) + <$> liftEither (scalarFromType (getOuterAnnotation item)) + <*> fromExpr item + ) + allItems +fromExpr (ETupleAccess ty tup nat) = + let offset = getOffsetList (getOuterAnnotation tup) !! fromIntegral (nat - 1) + in WTupleAccess + <$> liftEither (scalarFromType ty) + <*> fromExpr tup + <*> pure offset + +getOffsetList :: Type ann -> [Natural] +getOffsetList (TTuple _ a as) = + let items = a : NE.toList as + in drop 1 (scanl (\offset item -> offset + memorySizeForType item) 0 items) +getOffsetList _ = [] + +memorySizeForType :: Type ann -> Natural +memorySizeForType (TPrim _ TInt) = + memorySize I64 +memorySizeForType (TPrim _ TFloat) = + memorySize F64 +memorySizeForType (TPrim _ TBool) = + memorySize I32 +memorySizeForType (TTuple _ a as) = + memorySizeForType a + getSum (foldMap (Sum . memorySizeForType) as) +memorySizeForType (TFunction {}) = + memorySize Pointer + +fromFunction :: + (Show ann) => + M.Map FunctionName Natural -> + Function (Type ann) -> + Either FromWasmError WasmFunction +fromFunction funcMap (Function {fnBody, fnArgs, fnFunctionName}) = do + args <- traverse (scalarFromType . snd) fnArgs + let argMap = + M.fromList $ + ( \(i, (ArgumentName ident, _)) -> + (Identifier ident, i) + ) + <$> zip [0 ..] fnArgs + + (expr, fes) <- runStateT (fromExpr fnBody) (FromExprState argMap funcMap mempty) + + retType <- scalarFromType (getOuterAnnotation fnBody) + + pure $ + WasmFunction + { wfName = fnFunctionName, + wfExpr = expr, + wfPublic = False, + wfArgs = args, + wfReturnType = retType, + wfLocals = fesItems fes + } + +fromModule :: (Show ann) => Module (Type ann) -> Either FromWasmError WasmModule +fromModule (Module {mdExpr, mdFunctions}) = do + let funcMap = + M.fromList $ + ( \(i, Function {fnFunctionName}) -> + (fnFunctionName, i + 1) + ) + <$> zip [0 ..] mdFunctions + + (expr, fes) <- runStateT (fromExpr mdExpr) (FromExprState mempty funcMap mempty) + + retType <- scalarFromType (getOuterAnnotation mdExpr) + + let mainFunction = + WasmFunction + { wfName = "main", + wfExpr = expr, + wfPublic = True, + wfArgs = mempty, + wfReturnType = retType, + wfLocals = fesItems fes + } + + wasmFunctions <- traverse (fromFunction funcMap) mdFunctions + pure $ + WasmModule + { wmFunctions = mainFunction : wasmFunctions + } diff --git a/wasm-calc5/src/Calc/Wasm/Helpers.hs b/wasm-calc5/src/Calc/Wasm/Helpers.hs new file mode 100644 index 00000000..416b092b --- /dev/null +++ b/wasm-calc5/src/Calc/Wasm/Helpers.hs @@ -0,0 +1,11 @@ +module Calc.Wasm.Helpers (memorySize) where + +import Calc.Wasm.Types +import GHC.Natural + +-- our memory is bits of i32s +memorySize :: WasmType -> Natural +memorySize I32 = 8 +memorySize I64 = 16 +memorySize F64 = 16 +memorySize Pointer = memorySize I32 diff --git a/wasm-calc5/src/Calc/Wasm/Run.hs b/wasm-calc5/src/Calc/Wasm/Run.hs new file mode 100644 index 00000000..ea55f9e8 --- /dev/null +++ b/wasm-calc5/src/Calc/Wasm/Run.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Calc.Wasm.Run (runWasm) where + +import qualified Language.Wasm as Wasm +import qualified Language.Wasm.Interpreter as Wasm + +runWasm :: Wasm.Module -> IO (Maybe [Wasm.Value]) +runWasm wasmModule = do + case Wasm.validate wasmModule of + Right validModule -> do + (result, store) <- Wasm.instantiate Wasm.emptyStore mempty validModule + case result of + Right moduleInstance -> + Wasm.invokeExport store moduleInstance "main" mempty + Left e -> error e + Left e -> do + print wasmModule + error $ "invalid module: " <> show e diff --git a/wasm-calc5/src/Calc/Wasm/ToWasm.hs b/wasm-calc5/src/Calc/Wasm/ToWasm.hs new file mode 100644 index 00000000..955a0ce5 --- /dev/null +++ b/wasm-calc5/src/Calc/Wasm/ToWasm.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Calc.Wasm.ToWasm (moduleToWasm) where + +import Calc.Types.Expr +import Calc.Types.FunctionName +import Calc.Types.Prim +import Calc.Wasm.Allocator +import Calc.Wasm.Types +import Data.Maybe (catMaybes) +import qualified Data.Text.Lazy as TL +import GHC.Natural +import qualified Language.Wasm.Structure as Wasm + +mapWithIndex :: ((Int, a) -> b) -> [a] -> [b] +mapWithIndex f = fmap f . zip [0 ..] + +fromType :: WasmType -> Wasm.ValueType +fromType I32 = Wasm.I32 +fromType I64 = Wasm.I64 +fromType F64 = Wasm.F64 +fromType Pointer = Wasm.I32 + +fromFunction :: Int -> WasmFunction -> Wasm.Function +fromFunction wfIndex (WasmFunction {wfExpr, wfArgs, wfLocals}) = + let args = fromType <$> wfArgs + locals = fromType <$> wfLocals + in Wasm.Function + (fromIntegral $ wfIndex + 1) + (locals <> args) + (fromExpr wfExpr) + +typeFromFunction :: WasmFunction -> Wasm.FuncType +typeFromFunction (WasmFunction {wfArgs, wfReturnType}) = + Wasm.FuncType (fromType <$> wfArgs) [fromType wfReturnType] + +exportFromFunction :: Int -> WasmFunction -> Maybe Wasm.Export +exportFromFunction wfIndex (WasmFunction {wfName = FunctionName fnName, wfPublic = True}) = + Just $ Wasm.Export (TL.fromStrict fnName) (Wasm.ExportFunc (fromIntegral wfIndex + 1)) +exportFromFunction _ _ = Nothing + +bitsizeFromType :: WasmType -> Wasm.BitSize +bitsizeFromType I32 = Wasm.BS32 +bitsizeFromType I64 = Wasm.BS64 +bitsizeFromType F64 = Wasm.BS64 +bitsizeFromType Pointer = Wasm.BS32 + +instructionFromOp :: WasmType -> Op -> Wasm.Instruction Natural +instructionFromOp F64 OpAdd = Wasm.FBinOp (bitsizeFromType F64) Wasm.FAdd +instructionFromOp F64 OpMultiply = Wasm.FBinOp (bitsizeFromType F64) Wasm.FMul +instructionFromOp F64 OpSubtract = Wasm.FBinOp (bitsizeFromType F64) Wasm.FSub +instructionFromOp F64 OpEquals = Wasm.FRelOp (bitsizeFromType F64) Wasm.FEq +instructionFromOp ty OpAdd = Wasm.IBinOp (bitsizeFromType ty) Wasm.IAdd +instructionFromOp ty OpMultiply = Wasm.IBinOp (bitsizeFromType ty) Wasm.IMul +instructionFromOp ty OpSubtract = Wasm.IBinOp (bitsizeFromType ty) Wasm.ISub +instructionFromOp ty OpEquals = Wasm.IRelOp (bitsizeFromType ty) Wasm.IEq + +fromExpr :: WasmExpr -> [Wasm.Instruction Natural] +fromExpr (WPrim (PInt i)) = + [Wasm.I64Const $ fromIntegral i] +fromExpr (WPrim (PFloat f)) = + [Wasm.F64Const $ realToFrac f] +fromExpr (WPrim (PBool True)) = + [Wasm.I32Const 1] +fromExpr (WPrim (PBool False)) = + [Wasm.I32Const 0] +fromExpr (WInfix ty op a b) = + fromExpr a <> fromExpr b <> [instructionFromOp ty op] +fromExpr (WIf predExpr thenExpr elseExpr) = + fromExpr thenExpr <> fromExpr elseExpr <> fromExpr predExpr <> [Wasm.Select] +fromExpr (WVar i) = [Wasm.GetLocal i] +fromExpr (WApply fnIndex args) = + foldMap fromExpr args <> [Wasm.Call $ fnIndex + 1] +-- we need to store the return value so we can refer to it in multiple places +fromExpr (WAllocate i) = + [Wasm.I32Const (fromIntegral i), Wasm.Call 0] +fromExpr (WSet index container items) = + let fromItem (offset, ty, value) = + let storeInstruction = case ty of + F64 -> Wasm.F64Store (Wasm.MemArg offset 0) + I64 -> Wasm.I64Store (Wasm.MemArg offset 0) + I32 -> Wasm.I32Store (Wasm.MemArg offset 0) + Pointer -> Wasm.I32Store (Wasm.MemArg offset 0) + in [Wasm.GetLocal index] <> fromExpr value <> [storeInstruction] + in fromExpr container + <> [Wasm.SetLocal index] + <> foldMap fromItem items + <> [Wasm.GetLocal index] +fromExpr (WTupleAccess ty tup offset) = + let loadInstruction = case ty of + F64 -> Wasm.F64Load (Wasm.MemArg offset 0) + I64 -> Wasm.I64Load (Wasm.MemArg offset 0) + I32 -> Wasm.I32Load (Wasm.MemArg offset 0) + Pointer -> Wasm.I32Load (Wasm.MemArg offset 0) + in fromExpr tup <> [loadInstruction] + +-- | we load the bump allocator module and build on top of it +moduleToWasm :: WasmModule -> Wasm.Module +moduleToWasm (WasmModule {wmFunctions}) = + let functions = mapWithIndex (uncurry fromFunction) wmFunctions + types = typeFromFunction <$> wmFunctions + exports = catMaybes $ mapWithIndex (uncurry exportFromFunction) wmFunctions + in moduleWithAllocator + { Wasm.types = head (Wasm.types moduleWithAllocator) : types, + Wasm.functions = head (Wasm.functions moduleWithAllocator) : functions, + Wasm.tables = mempty, + Wasm.elems = mempty, + Wasm.datas = mempty, + Wasm.start = Nothing, + Wasm.imports = mempty, + Wasm.exports = exports + } diff --git a/wasm-calc5/src/Calc/Wasm/Types.hs b/wasm-calc5/src/Calc/Wasm/Types.hs new file mode 100644 index 00000000..ce646d54 --- /dev/null +++ b/wasm-calc5/src/Calc/Wasm/Types.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Calc.Wasm.Types + ( WasmType (..), + WasmModule (..), + WasmFunction (..), + WasmExpr (..), + ) +where + +import Calc.Types.Expr +import Calc.Types.Function +import Calc.Types.Prim +import GHC.Natural + +data WasmType + = I32 + | I64 + | F64 + | Pointer -- an I64 really + deriving stock (Eq, Ord, Show) + +newtype WasmModule = WasmModule + { -- | the functions themselves, their index comes from the list placement + wmFunctions :: [WasmFunction] + } + deriving stock (Eq, Ord, Show) + +data WasmFunction = WasmFunction + { wfName :: FunctionName, + wfExpr :: WasmExpr, + wfPublic :: Bool, + wfArgs :: [WasmType], + wfReturnType :: WasmType, + wfLocals :: [WasmType] + } + deriving stock (Eq, Ord, Show) + +data WasmExpr + = WPrim Prim + | WInfix WasmType Op WasmExpr WasmExpr + | WIf WasmExpr WasmExpr WasmExpr + | WVar Natural + | WApply Natural [WasmExpr] + | WAllocate Natural + | WSet Natural WasmExpr [(Natural, WasmType, WasmExpr)] -- `(1,2)` is WSet 3 (WAllocate 2) [(0, 1),(1, 2)] + | WTupleAccess WasmType WasmExpr Natural + deriving stock (Eq, Ord, Show) diff --git a/wasm-calc5/static/bump-allocator.wat b/wasm-calc5/static/bump-allocator.wat new file mode 100644 index 00000000..54d7896d --- /dev/null +++ b/wasm-calc5/static/bump-allocator.wat @@ -0,0 +1,65 @@ +;; taken entirely from https://gist.github.com/bryanburgers/2b0f08fd583cf0401a958d7e8edc7552#file-figure-06-wat +(module + ;; Create memory with at least 1 page of 64k of memory + (memory $mem 1) + + ;; the pointer of the next allocation + (global $alloc.offset (mut i32) (i32.const 32)) + (func $alloc (param $size i32) (result (;pointer;) i32) + (local $this_alloc_ptr i32) + (local $next_alloc_ptr i32) + (local $current_capacity i32) + + ;; If the requested size is more than a 64k page, fail. + local.get $size + i32.const 65536 + i32.gt_u + (if + (then + i32.const 0x01 + unreachable + ) + ) + + ;; calculate the current ptr and the next ptr + global.get $alloc.offset + local.tee $this_alloc_ptr + local.get $size + i32.add + local.set $next_alloc_ptr + + ;; If this allocation extends into a page of memory we haven't reserved + ;; we need to reserve more memory + memory.size + i32.const 65536 + i32.mul + local.set $current_capacity + + local.get $next_alloc_ptr + local.get $current_capacity + i32.gt_u + (if + (then + i32.const 1 + memory.grow + + ;; if memory couldn't grow, panic + i32.const -1 + i32.eq + (if + (then + i32.const 0x02 + unreachable + ) + ) + ) + ) + + ;; store the ptr to the next allocation + local.get $next_alloc_ptr + global.set $alloc.offset + + ;; and return the current pointer + local.get $this_alloc_ptr + ) +) diff --git a/wasm-calc5/test/Main.hs b/wasm-calc5/test/Main.hs new file mode 100644 index 00000000..c6f18536 --- /dev/null +++ b/wasm-calc5/test/Main.hs @@ -0,0 +1,14 @@ +module Main (main) where + +import Test.Hspec +import qualified Test.Interpreter.InterpreterSpec +import qualified Test.Parser.ParserSpec +import qualified Test.Typecheck.TypecheckSpec +import qualified Test.Wasm.WasmSpec + +main :: IO () +main = hspec $ do + Test.Parser.ParserSpec.spec + Test.Interpreter.InterpreterSpec.spec + Test.Typecheck.TypecheckSpec.spec + Test.Wasm.WasmSpec.spec diff --git a/wasm-calc5/test/Test/Helpers.hs b/wasm-calc5/test/Test/Helpers.hs new file mode 100644 index 00000000..f31cd3d3 --- /dev/null +++ b/wasm-calc5/test/Test/Helpers.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE LambdaCase #-} + +module Test.Helpers + ( int, + bool, + float, + var, + tuple, + tyInt, + tyFloat, + tyBool, + tyTuple, + ) +where + +import Calc +import qualified Data.List.NonEmpty as NE +import Data.String + +int :: (Monoid ann) => Integer -> Expr ann +int = EPrim mempty . PInt + +float :: (Monoid ann) => Float -> Expr ann +float = EPrim mempty . PFloat + +bool :: (Monoid ann) => Bool -> Expr ann +bool = EPrim mempty . PBool + +var :: (Monoid ann) => String -> Expr ann +var = EVar mempty . Identifier . fromString + +tuple :: (Monoid ann) => [Expr ann] -> Expr ann +tuple = \case + (a : b : rest) -> ETuple mempty a (b NE.:| rest) + _ -> error "not enough items for tuple" + +tyInt :: (Monoid ann) => Type ann +tyInt = TPrim mempty TInt + +tyFloat :: (Monoid ann) => Type ann +tyFloat = TPrim mempty TFloat + +tyBool :: (Monoid ann) => Type ann +tyBool = TPrim mempty TBool + +tyTuple :: (Monoid ann) => [Type ann] -> Type ann +tyTuple = \case + (a : b : rest) -> TTuple mempty a (b NE.:| rest) + _ -> error "not enough items for tyTuple" diff --git a/wasm-calc5/test/Test/Interpreter/InterpreterSpec.hs b/wasm-calc5/test/Test/Interpreter/InterpreterSpec.hs new file mode 100644 index 00000000..55077567 --- /dev/null +++ b/wasm-calc5/test/Test/Interpreter/InterpreterSpec.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Interpreter.InterpreterSpec (spec) where + +import Calc +import Control.Monad (void) +import Data.Foldable (traverse_) +import Data.Functor (($>)) +import Data.Text (Text) +import Test.Hspec + +-- | try parsing the input, exploding if it's invalid +unsafeParseExpr :: Text -> Expr () +unsafeParseExpr input = case parseExprAndFormatError input of + Right a -> a $> () + Left e -> error (show e) + +-- | try parsing the input, exploding if it's invalid +unsafeParseModule :: Text -> Module () +unsafeParseModule input = case parseModuleAndFormatError input of + Right a -> a $> () + Left e -> error (show e) + +-- | function for testing the interpreter +testInterpret :: Text -> Either (InterpreterError ()) (Expr ()) +testInterpret = + fmap void -- throw away the `Annotation`s and replace with `()` + . runInterpreter -- unwrap the InterpretM monad + . interpret -- run the actual function + . unsafeParseExpr -- parse the input (and explode if it's invalid) + +-- | function for testing the interpreter +testInterpretModule :: Text -> Either (InterpreterError ()) (Expr ()) +testInterpretModule = + fmap void -- throw away the `Annotation`s and replace with `()` + . runInterpreter -- unwrap the InterpretM monad + . interpretModule -- run the actual function + . unsafeParseModule -- parse the input (and explode if it's invalid) + +spec :: Spec +spec = do + describe "InterpreterSpec" $ do + describe "Modules" $ do + let cases = + [ ("1 + 1", "2"), + ("function increment(a: Integer) { a + 1 } increment(-11)", "-10"), + ("function swap(pair: (Integer,Boolean)) { (pair.2, pair.1) } swap((1,True))", "(True, 1)") + ] + traverse_ + ( \(input, expect) -> + it (show input <> " = " <> show expect) $ do + testInterpretModule input + `shouldBe` Right (unsafeParseExpr expect) + ) + cases + describe "Expressions" $ do + let cases = + [ ("1 + 1", "2"), + ("-11 + 1", "-10"), + ("3 * 3 + 1", "10"), + ("(3 * 3) + (6 * 6)", "45"), + ("1 + 1 == 2", "True"), + ("2 + 2 == 5", "False"), + ("1.0 * 1.0", "1.0"), + ("if False then True else False", "False"), + ("if 1 == 1 then 6 else 5", "6"), + ("(1, True).2", "True") + ] + traverse_ + ( \(input, expect) -> + it (show input <> " = " <> show expect) $ do + testInterpret input + `shouldBe` Right (unsafeParseExpr expect) + ) + cases diff --git a/wasm-calc5/test/Test/Parser/ParserSpec.hs b/wasm-calc5/test/Test/Parser/ParserSpec.hs new file mode 100644 index 00000000..5b740533 --- /dev/null +++ b/wasm-calc5/test/Test/Parser/ParserSpec.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Parser.ParserSpec (spec) where + +import Calc +import Data.Foldable (traverse_) +import Data.Functor +import qualified Data.Text as T +import Test.Helpers +import Test.Hspec + +spec :: Spec +spec = do + describe "ParserSpec" $ do + describe "Type" $ do + let strings = + [ ("Boolean", tyBool), + ("Integer", tyInt), + ("(Boolean, Boolean, Integer)", tyTuple [tyBool, tyBool, tyInt]) + ] + traverse_ + ( \(str, expr) -> it (T.unpack str) $ do + case parseTypeAndFormatError str of + Right parsedExp -> parsedExp $> () `shouldBe` expr + Left e -> error (T.unpack e) + ) + strings + + describe "Module" $ do + let strings = + [ ("42", Module [] (int 42)), + ( "function increment(a: Integer) { a + 1 } 42", + Module [Function () [("a", TPrim () TInt)] "increment" (EInfix () OpAdd (var "a") (int 1))] (int 42) + ), + ( "function increment(a: Integer) { a + 1 } function decrement(a: Integer) { a - 1} 42", + Module + [ Function () [("a", TPrim () TInt)] "increment" (EInfix () OpAdd (var "a") (int 1)), + Function () [("a", TPrim () TInt)] "decrement" (EInfix () OpSubtract (var "a") (int 1)) + ] + (int 42) + ) + ] + + traverse_ + ( \(str, module') -> it (T.unpack str) $ do + case parseModuleAndFormatError str of + Right parsedMod -> parsedMod $> () `shouldBe` module' + Left e -> error (T.unpack e) + ) + strings + + describe "Function" $ do + let strings = + [ ("function one() { 1 }", Function () [] "one" (int 1)), + ( "function sum (a: Integer, b: Integer) { a + b }", + Function + () + [("a", TPrim () TInt), ("b", TPrim () TInt)] + "sum" + ( EInfix () OpAdd (var "a") (var "b") + ) + ) + ] + traverse_ + ( \(str, fn) -> it (T.unpack str) $ do + case parseFunctionAndFormatError str of + Right parsedFn -> parsedFn $> () `shouldBe` fn + Left e -> error (T.unpack e) + ) + strings + + describe "Expr" $ do + let strings = + [ ("-1", int (-1)), + ("1 + 2", EInfix () OpAdd (int 1) (int 2)), + ("True", EPrim () (PBool True)), + ("False", EPrim () (PBool False)), + ("(1,2,True)", tuple [int 1, int 2, bool True]), + ( "1 + 2 + 3", + EInfix + () + OpAdd + ( EInfix + () + OpAdd + (int 1) + (int 2) + ) + (int 3) + ), + ("1 == 2", EInfix () OpEquals (int 1) (int 2)), + ("1.0 + 1.0", EInfix () OpAdd (float 1.0) (float 1.0)), + ("if True then 1 else 2", EIf () (bool True) (int 1) (int 2)), + ("a + 1", EInfix () OpAdd (var "a") (int 1)), + ("add(1,2)", EApply () "add" [int 1, int 2]), + ("go()", EApply () "go" []), + ("tuple.1", ETupleAccess () (var "tuple") 1) + ] + traverse_ + ( \(str, expr) -> it (T.unpack str) $ do + case parseExprAndFormatError str of + Right parsedExp -> parsedExp $> () `shouldBe` expr + Left e -> error (T.unpack e) + ) + strings + + describe "Expr with Annotation" $ do + it "Parses an infix operation with annotations" $ do + parseExprAndFormatError "20 + 22" + `shouldBe` Right + ( EInfix + (Location 0 7) + OpAdd + (EPrim (Location 0 2) (PInt 20)) + (EPrim (Location 5 7) (PInt 22)) + ) diff --git a/wasm-calc5/test/Test/Typecheck/TypecheckSpec.hs b/wasm-calc5/test/Test/Typecheck/TypecheckSpec.hs new file mode 100644 index 00000000..31ff0e9a --- /dev/null +++ b/wasm-calc5/test/Test/Typecheck/TypecheckSpec.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Typecheck.TypecheckSpec (spec) where + +import Calc.ExprUtils +import Calc.Parser +import Calc.Typecheck.Elaborate +import Calc.Typecheck.Error +import Calc.Typecheck.Types +import Calc.Types.Expr +import Calc.Types.Function +import Calc.Types.Module +import Calc.Types.Type +import Control.Monad +import Data.Either (isLeft) +import Data.Foldable (traverse_) +import Data.Text (Text) +import Test.Helpers +import Test.Hspec + +runTC :: TypecheckM ann a -> Either (TypeError ann) a +runTC = runTypecheckM (TypecheckEnv mempty) + +testTypecheck :: (Text, Text) -> Spec +testTypecheck (input, result) = it (show input) $ do + case (,) <$> parseExprAndFormatError input <*> parseTypeAndFormatError result of + Left e -> error (show e) + Right (expr, tyResult) -> do + getOuterAnnotation <$> elaborate (void expr) + `shouldBe` Right (void tyResult) + +testFailing :: (Text, TypeError ()) -> Spec +testFailing (input, result) = it (show input) $ do + case parseExprAndFormatError input of + Left e -> error (show e) + Right expr -> do + getOuterAnnotation <$> elaborate (void expr) + `shouldBe` Left result + +testSucceedingFunction :: (Text, Type ()) -> Spec +testSucceedingFunction (input, fn) = + it (show input) $ do + case parseFunctionAndFormatError input of + Left e -> error (show e) + Right parsedFn -> + fnAnn <$> runTC (elaborateFunction (void parsedFn)) + `shouldBe` Right fn + +testSucceedingModule :: (Text, Type ()) -> Spec +testSucceedingModule (input, md) = + it (show input) $ do + case parseModuleAndFormatError input of + Left e -> error (show e) + Right parsedMod -> + getOuterAnnotation . mdExpr <$> elaborateModule (void parsedMod) + `shouldBe` Right md + +testFailingModule :: Text -> Spec +testFailingModule input = + it (show input) $ do + case parseModuleAndFormatError input of + Left e -> error (show e) + Right parsedMod -> + elaborateModule (void parsedMod) + `shouldSatisfy` isLeft + +spec :: Spec +spec = do + describe "TypecheckSpec" $ do + describe "Function" $ do + let succeeding = + [ ("function one () { 1 }", TFunction () [] tyInt), + ( "function not (bool: Boolean) { if bool then False else True }", + TFunction () [tyBool] tyBool + ) + ] + + describe "Successfully typechecking functions" $ do + traverse_ testSucceedingFunction succeeding + + describe "Module" $ do + let succeeding = + [ ("function ignore() { 1 } 42", tyInt), + ("function increment(a: Integer) { a + 1 } increment(41)", tyInt), + ("function inc(a: Integer) { a + 1 } function inc2(a: Integer) { inc(a) } inc2(41)", TPrim () TInt) + ] + describe "Successfully typechecking modules" $ do + traverse_ testSucceedingModule succeeding + + let failing = + [ "function increment(b: Boolean) { a + 1 } increment(41)" + ] + describe "Failing typechecking modules" $ do + traverse_ testFailingModule failing + + describe "Expr" $ do + let succeeding = + [ ("42", "Integer"), + ("True", "Boolean"), + ("1 + 1", "Integer"), + ("6 * 9", "Integer"), + ("1 - 10", "Integer"), + ("2 == 2", "Boolean"), + ("1.0 + 2.0", "Float"), + ("10.0 * 10.0", "Float"), + ("if True then 1 else 2", "Integer"), + ("if False then True else False", "Boolean"), + ("(1,2,True)", "(Integer,Integer,Boolean)"), + ("(1,2,3).2", "Integer") + ] + + describe "Successfully typechecking expressions" $ do + traverse_ testTypecheck succeeding + + let failing = + [ ("if 1 then 1 else 2", PredicateIsNotBoolean () tyInt), + ("if True then 1 else True", TypeMismatch tyInt tyBool), + ("1 + 1.0", InfixTypeMismatch OpAdd [(tyInt, tyFloat)]), + ("1 + True", InfixTypeMismatch OpAdd [(tyInt, tyBool)]), + ("True + False", InfixTypeMismatch OpAdd [(tyInt, tyBool), (tyInt, tyBool)]), + ("1 * False", InfixTypeMismatch OpMultiply [(TPrim () TInt, TPrim () TBool)]), + ("True - 1", InfixTypeMismatch OpSubtract [(TPrim () TInt, TPrim () TBool)]) + ] + + describe "Failing typechecking expressions" $ do + traverse_ testFailing failing diff --git a/wasm-calc5/test/Test/Wasm/WasmSpec.hs b/wasm-calc5/test/Test/Wasm/WasmSpec.hs new file mode 100644 index 00000000..9adee7bf --- /dev/null +++ b/wasm-calc5/test/Test/Wasm/WasmSpec.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Wasm.WasmSpec (spec) where + +import Calc.Parser +import Calc.Typecheck.Elaborate +import Calc.Wasm.FromExpr +import Calc.Wasm.Run +import Calc.Wasm.ToWasm +import Data.Foldable (traverse_) +import Data.Text (Text) +import qualified Language.Wasm.Interpreter as Wasm +import Test.Hspec + +testCompileExpr :: (Text, Wasm.Value) -> Spec +testCompileExpr (input, result) = it (show input) $ do + case parseModuleAndFormatError input of + Left e -> error (show e) + Right expr -> case elaborateModule expr of + Left typeErr -> error (show typeErr) + Right mod' -> + case fromModule mod' of + Left e -> error (show e) + Right wasmMod -> do + resp <- runWasm (moduleToWasm wasmMod) + resp `shouldBe` Just [result] + +joinLines :: [Text] -> Text +joinLines = foldr (\a b -> a <> "\n" <> b) "" + +spec :: Spec +spec = do + describe "WasmSpec" $ do + let testVals = + [ ("42", Wasm.VI64 42), + ("(1 + 1)", Wasm.VI64 2), + ("1 + 2 + 3 + 4 + 5 + 6", Wasm.VI64 21), + ("6 * 6", Wasm.VI64 36), + ("100 - 1", Wasm.VI64 99), + ("100.0 + 1.0", Wasm.VF64 101.0), + ("if False then 1 else 2", Wasm.VI64 2), + ("if 1 == 1 then 7 else 10", Wasm.VI64 7), + ("if 2 == 1 then True else False", Wasm.VI32 0), + ( joinLines + [ "function one() { 1 }", + "function two() { 2 }", + "one() + two()" + ], + Wasm.VI64 3 + ), + ("function increment(a: Integer) { a + 1 } increment(41)", Wasm.VI64 42), + ("function sum(a: Integer, b: Integer) { a + b } sum(20,22)", Wasm.VI64 42), + ("function inc(a: Integer) { a + 1 } inc(inc(inc(inc(0))))", Wasm.VI64 4), + ( joinLines + [ "function ignoreTuple(pair: (Integer, Boolean)) { True }", + "ignoreTuple((1,True))" + ], + Wasm.VI32 1 + ), + ( joinLines + [ "(10,True).2" + ], + Wasm.VI32 1 -- note we cannot make polymorphic versions of these functions yet, although we will + ), + ( joinLines + [ "function swapIntAndBool(pair: (Integer, Boolean)) { (pair.2, pair.1) }", + "function fst(pair: (Boolean, Integer)) { pair.1 }", + "fst(swapIntAndBool((1,True)))" + ], + Wasm.VI32 1 -- note we cannot make polymorphic versions of these functions yet, although we will + ), + ( joinLines + [ "function sumTuple(pair: (Float, Float)) { pair.1 + pair.2 }", + "sumTuple((100.0,200.0))" + ], + Wasm.VF64 300.0 + ), + ( joinLines + [ "function fst(pair: (Integer,Integer)) { pair.1 }", + "fst(((10,2),(3,4)).1)" + ], + Wasm.VI64 10 + ) + ] + + describe "From expressions" $ do + traverse_ testCompileExpr testVals diff --git a/wasm-calc5/wasm-calc5.cabal b/wasm-calc5/wasm-calc5.cabal new file mode 100644 index 00000000..4005575b --- /dev/null +++ b/wasm-calc5/wasm-calc5.cabal @@ -0,0 +1,144 @@ +cabal-version: 2.4 +name: wasm-calc5 +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: +author: Daniel Harvey +maintainer: danieljamesharvey@gmail.com + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: + CHANGELOG.md + static/runtime.c + +common shared + ghc-options: + -threaded -rtsopts -with-rtsopts=-N -Wall + -Wno-unticked-promoted-constructors -Wcompat + -Wincomplete-record-updates -Wincomplete-uni-patterns + -Wredundant-constraints -Wmissing-deriving-strategies + + build-depends: + , base + , bytestring + , containers + , diagnose + , directory + , file-embed + , hashable + , haskeline + , megaparsec + , mtl + , parser-combinators + , pretty-simple + , prettyprinter + , process + , string-conversions + , text + , unix + , unordered-containers + , wasm + + other-modules: + Calc + Calc.ExprUtils + Calc.Interpreter + Calc.Parser + Calc.Parser.Expr + Calc.Parser.Function + Calc.Parser.Identifier + Calc.Parser.Module + Calc.Parser.Primitives + Calc.Parser.Shared + Calc.Parser.Type + Calc.Parser.Types + Calc.Repl + Calc.SourceSpan + Calc.Typecheck.Elaborate + Calc.Typecheck.Error + Calc.Typecheck.Types + Calc.Types + Calc.Types.Annotation + Calc.Types.Expr + Calc.Types.Function + Calc.Types.FunctionName + Calc.Types.Identifier + Calc.Types.Module + Calc.Types.Prim + Calc.Types.Type + Calc.TypeUtils + Calc.Utils + Calc.Wasm.Allocator + Calc.Wasm.FromExpr + Calc.Wasm.Helpers + Calc.Wasm.Run + Calc.Wasm.ToWasm + Calc.Wasm.Types + +library + import: shared + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + hs-source-dirs: src + default-language: Haskell2010 + +test-suite wasm-calc5-tests + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + hs-source-dirs: src + build-depends: + , hspec >=2.8.3 && <3 + , hspec-core >=2.8.3 && <3 + + main-is: Main.hs + default-language: Haskell2010 + other-modules: + Test.Helpers + Test.Interpreter.InterpreterSpec + Test.Parser.ParserSpec + Test.Typecheck.TypecheckSpec + Test.Wasm.WasmSpec + +executable wasm-calc5 + import: shared + main-is: Main.hs + hs-source-dirs: app + hs-source-dirs: src + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , base + , containers + , diagnose + , directory + , file-embed + , hashable + , haskeline + , megaparsec + , mtl + , parser-combinators + , prettyprinter + , process + , string-conversions + , text + , unix + , unordered-containers + , wasm-calc5 + + default-language: Haskell2010