Wow

wasm-calc4/src/Calc/ExprUtils.hs

@@ -8,7 +8,6 @@ module Calc.ExprUtils
 where
 
 import Calc.Types
-import Data.Bifunctor (second)
 
 -- | get the annotation in the first leaf found in an `Expr`.
 -- useful for getting the overall type of an expression
@@ -19,7 +18,7 @@ getOuterAnnotation (EIf ann _ _ _) = ann
 getOuterAnnotation (EVar ann _) = ann
 getOuterAnnotation (EApply ann _ _) = ann
 getOuterAnnotation (ETuple ann _ _) = ann
-getOuterAnnotation (EPatternMatch ann _ _) = ann
+getOuterAnnotation (ETupleAccess ann _ _) = ann
 
 -- | modify the outer annotation of an expression
 -- useful for adding line numbers during parsing
@@ -32,7 +31,7 @@ mapOuterExprAnnotation f expr' =
     EVar ann a -> EVar (f ann) a
     EApply ann a b -> EApply (f ann) a b
     ETuple ann a b -> ETuple (f ann) a b
-    EPatternMatch ann a b -> EPatternMatch (f ann) a b
+    ETupleAccess ann a b -> ETupleAccess (f ann) a b
 
 -- | Given a function that changes `Expr` values, apply it throughout
 -- an AST tree
@@ -44,5 +43,5 @@ mapExpr f (EApply ann fn args) = EApply ann fn (f <$> args)
 mapExpr f (EIf ann predExpr thenExpr elseExpr) =
   EIf ann (f predExpr) (f thenExpr) (f elseExpr)
 mapExpr f (ETuple ann a as) = ETuple ann (f a) (f <$> as)
-mapExpr f (EPatternMatch ann matchExpr patterns) =
-  EPatternMatch ann (f matchExpr) (fmap (second f) patterns)
+mapExpr f (ETupleAccess ann tup nat) =
+  ETupleAccess ann (f tup) nat

wasm-calc4/src/Calc/Interpreter.hs

@@ -13,15 +13,15 @@ module Calc.Interpreter
   )
 where
 
+import GHC.Natural
+import qualified Data.List.NonEmpty as NE
 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 Data.Monoid (First (..))
 
 -- | type for interpreter state
 newtype InterpreterState ann = InterpreterState
@@ -33,7 +33,8 @@ data InterpreterError ann
   = NonBooleanPredicate ann (Expr ann)
   | FunctionNotFound FunctionName [FunctionName]
   | VarNotFound Identifier [Identifier]
-  | NoPatternsMatched (Expr ann) (NE.NonEmpty (Pattern ann))
+  | AccessNonTuple (Expr ann)
+  | AccessOutsideTupleBounds (Expr ann) Natural
   deriving stock (Eq, Ord, Show)
 
 -- | type of Reader env for interpreter state
@@ -133,52 +134,23 @@ interpret (ETuple ann a as) = do
   aA <- interpret a
   asA <- traverse interpret as
   pure (ETuple ann aA asA)
-interpret (EPatternMatch _ expr pats) = do
-  exprA <- interpret expr
-  interpretPatternMatch exprA pats
+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)
 
-interpretPatternMatch ::
-  Expr ann ->
-  NE.NonEmpty (Pattern ann, Expr ann) ->
-  InterpretM ann (Expr ann)
-interpretPatternMatch expr' patterns = do
-  -- interpret match expression
-  intExpr <- interpret expr'
-  let foldF (pat, patExpr) = case patternMatches pat intExpr of
-        Just bindings -> First (Just (patExpr, bindings))
-        _ -> First Nothing
-
-  -- get first matching pattern
-  case getFirst (foldMap foldF patterns) of
-    Just (patExpr, bindings) ->
-      let vars = fmap (coerce . fst) bindings
-          exprs = fmap snd bindings
-       in withVars vars exprs (interpret patExpr)
-    _ -> throwError (NoPatternsMatched expr' (fst <$> patterns))
-
--- pull vars out of expr to match patterns
-patternMatches ::
-  Pattern ann ->
-  Expr ann ->
-  Maybe [(Identifier, Expr ann)]
-patternMatches (PWildcard _) _ = pure []
-patternMatches (PVar _ name) expr = pure [(name, expr)]
-patternMatches (PTuple _ pA pAs) (ETuple _ a as) = do
-  matchA <- patternMatches pA a
-  matchAs <-
-    traverse
-      (uncurry patternMatches)
-      (zip (NE.toList pAs) (NE.toList as))
-  pure $ matchA <> mconcat matchAs
-patternMatches (PLiteral _ pB) (EPrim _ b)
-  | pB == b = pure mempty
-patternMatches _ _ = Nothing
+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 ->

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

@@ -3,7 +3,6 @@
 module Calc.Parser.Expr (exprParser) where
 
 import Calc.Parser.Identifier
-import Calc.Parser.Pattern
 import Calc.Parser.Primitives
 import Calc.Parser.Shared
 import Calc.Parser.Types
@@ -12,16 +11,17 @@ 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 tupleParser
+  try tupleAccessParser
+    <|> try tupleParser
     <|> inBrackets (addLocation exprParser)
-    <|> patternMatchParser
     <|> primExprParser
     <|> ifParser
     <|> try applyParser
@@ -71,35 +71,15 @@ tupleParser = label "tuple" $
     _ <- stringLiteral ")"
     pure (ETuple mempty (NE.head neArgs) neTail)
 
------
+tupleAccessParser :: Parser (Expr Annotation)
+tupleAccessParser =
+  let natParser :: Parser Natural
+      natParser = myLexeme (fromIntegral <$> intParser)
 
-patternMatchParser :: Parser ParserExpr
-patternMatchParser = addLocation $ do
-  matchExpr <- matchExprWithParser
-  patterns <-
-    try patternMatchesParser
-      <|> pure
-      <$> patternCaseParser
-  case NE.nonEmpty patterns of
-    (Just nePatterns) -> pure $ EPatternMatch mempty matchExpr nePatterns
-    _ -> error "need at least one pattern"
-
-matchExprWithParser :: Parser ParserExpr
-matchExprWithParser = do
-  stringLiteral "case"
-  sumExpr <- exprParser
-  stringLiteral "of"
-  pure sumExpr
-
-patternMatchesParser :: Parser [(ParserPattern, ParserExpr)]
-patternMatchesParser =
-  sepBy
-    patternCaseParser
-    (stringLiteral "|")
-
-patternCaseParser :: Parser (ParserPattern, ParserExpr)
-patternCaseParser = do
-  pat <- orInBrackets patternParser
-  stringLiteral "->"
-  patExpr <- exprParser
-  pure (pat, patExpr)
+      tupParser :: Parser (Expr Annotation)
+      tupParser = try tupleParser <|> try varParser <|> applyParser
+   in label "tuple access" $
+        addLocation $ do
+          tup <- tupParser
+          stringLiteral "."
+          ETupleAccess mempty tup <$> natParser