Added guards to the term language

parser-typechecker/src/Unison/Hashable.hs

@@ -53,3 +53,4 @@ instance Hashable Text where
 
 instance Hashable ByteString where
   tokens bs = [Bytes bs]
+

parser-typechecker/src/Unison/Pattern.hs

@@ -15,7 +15,10 @@ data Pattern
   | Int64 !Int64
   | UInt64 !Word64
   | Float !Double
-  | Constructor !Reference !Int [Pattern] deriving (Generic,Eq,Show)
+  | Constructor !Reference !Int [Pattern]
+  | EffectPure Pattern
+  | EffectBind !Reference !Int [Pattern] Pattern
+    deriving (Generic,Eq,Show)
 
 instance H.Hashable Pattern where
   tokens Unbound = [H.Tag 0]
@@ -24,4 +27,8 @@ instance H.Hashable Pattern where
   tokens (Int64 _) = H.Tag 3 : error "need to figure out hashable"
   tokens (UInt64 _) = H.Tag 4 : error "need to figure out hashable"
   tokens (Float f) = H.Tag 5 : H.tokens f
-  tokens (Constructor r n args) = [H.Tag 6, H.accumulateToken r, H.VarInt n, H.accumulateToken args]
+  tokens (Constructor r n args) =
+    [H.Tag 6, H.accumulateToken r, H.VarInt n, H.accumulateToken args]
+  tokens (EffectPure p) = H.Tag 7 : H.tokens p
+  tokens (EffectBind r ctor ps k) =
+    H.Tag 8 : error "need fo figure out hashable"

parser-typechecker/src/Unison/Term.hs

@@ -10,33 +10,37 @@
 
 module Unison.Term where
 
-import Data.Int (Int64)
-import Data.Word (Word64)
-import Data.List (foldl')
-import Data.Map (Map)
-import Data.Set (Set, union)
-import Data.Text (Text)
-import Data.Vector (Vector)
-import GHC.Generics
-import Prelude.Extras (Eq1(..), Show1(..))
-import Text.Show
-import Unison.Hash (Hash)
-import Unison.Hashable (Hashable1, accumulateToken)
-import Unison.Pattern (Pattern)
-import Unison.Reference (Reference(..))
-import Unison.Type (Type)
-import Unison.Var (Var)
-import Unsafe.Coerce
 import qualified Control.Monad.Writer.Strict as Writer
+import           Data.Foldable (toList)
+import           Data.Int (Int64)
+import           Data.List (foldl')
+import           Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.Monoid as Monoid
+import           Data.Set (Set, union)
 import qualified Data.Set as Set
+import           Data.Text (Text)
+import           Data.Vector (Vector)
 import qualified Data.Vector as Vector
+import           Data.Word (Word64)
+import           GHC.Generics
+import           Prelude.Extras (Eq1(..), Show1(..))
+import           Text.Show
 import qualified Unison.ABT as ABT
+import           Unison.Hash (Hash)
 import qualified Unison.Hash as Hash
+import           Unison.Hashable (Hashable1, accumulateToken)
 import qualified Unison.Hashable as Hashable
+import           Unison.Pattern (Pattern)
+import           Unison.Reference (Reference(..))
 import qualified Unison.Reference as Reference
+import           Unison.Type (Type)
 import qualified Unison.Type as Type
+import           Unison.Var (Var)
+import           Unsafe.Coerce
+
+data MatchCase a = MatchCase Pattern (Maybe a) a
+  deriving (Show,Eq,Foldable,Functor,Generic,Generic1,Traversable)
 
 -- | Base functor for terms in the Unison language
 -- We need `typeVar` because the term and type variables may differ.
@@ -76,7 +80,7 @@ data F typeVar a
   --   Match x
   --     [ (Constructor 0 [Var], ABT.abs n rhs1)
   --     , (Constructor 1 [], rhs2) ]
-  | Match a [(Pattern, a)]
+  | Match a [MatchCase a]
   deriving (Eq,Foldable,Functor,Generic,Generic1,Traversable)
 
 -- | Like `Term v`, but with an annotation of type `a` at every level in the tree
@@ -195,7 +199,7 @@ blank = ABT.tm Blank
 app :: Ord v => Term v -> Term v -> Term v
 app f arg = ABT.tm (App f arg)
 
-match :: Ord v => Term v -> [(Pattern, Term v)] -> Term v
+match :: Ord v => Term v -> [MatchCase (Term v)] -> Term v
 match scrutinee branches = ABT.tm (Match scrutinee branches)
 
 handle :: Ord v => Term v -> Term v -> Term v
@@ -355,8 +359,12 @@ instance Var v => Hashable1 (F v) where
         -- here, order is significant, so don't use hashCycle
         Let b a -> [tag 8, hashed (hash b), hashed (hash a)]
         Constructor r n -> [tag 12, accumulateToken r, varint n]
-        Match e branches -> tag 13 : hashed (hash e) : concatMap h branches where
-          h (pat, branch) = [accumulateToken pat, hashed (hash branch)]
+        Match e branches -> tag 13 : hashed (hash e) : concatMap h branches
+          where
+            h (MatchCase pat guard branch) =
+              concat [[accumulateToken pat],
+                      toList (hashed . hash <$> guard),
+                      [hashed (hash branch)]]
 
 -- mostly boring serialization code below ...
 

parser-typechecker/src/Unison/TermParser.hs

@@ -92,12 +92,15 @@ match = do
   cases <- L.vblock (sepBy L.vsemi matchCase)
   pure $ Term.match scrutinee cases
 
-matchCase :: Var v => Parser (S v) (Pattern, Term v)
+matchCase :: Var v => Parser (S v) (Term.MatchCase (Term v))
 matchCase = do
   (p, boundVars) <- pattern
+  guard <- optional $ do
+    token (string "|")
+    block
   token (string "->")
   t <- block
-  pure (p, ABT.absChain boundVars t)
+  pure . Term.MatchCase p guard $ ABT.absChain boundVars t
 
 pattern :: Var v => Parser (S v) (Pattern, [v])
 pattern = traced "pattern" $ constructor <|> leaf

parser-typechecker/src/Unison/Typechecker/Context.hs

@@ -451,9 +451,10 @@ check e t = getContext >>= \ctx -> scope ("check: " ++ show e ++ ":   " ++ show
       go (Term.Match' scrutinee branches) t = do
         scrutineeType <- synthesize scrutinee
         dataDecls <- getDataDeclarations
-        forM_ branches $ \(lhs, rhs) -> do
+        forM_ branches $ \(Term.MatchCase lhs guard rhs) -> do
           checkPattern lhs dataDecls scrutineeType
           check rhs t
+          -- NOTE: Typecheck the guard
           -- XXX retract
 
   -- | Match a [(Pattern, a)]