From 3b07bc54ae6404b8da416b324749d28fa326a0b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar=20=C3=93li=20Bjarnason?= Date: Wed, 23 May 2018 13:13:19 -0400 Subject: [PATCH] Added guards to the term language --- parser-typechecker/src/Unison/Hashable.hs | 1 + parser-typechecker/src/Unison/Pattern.hs | 11 +++- parser-typechecker/src/Unison/Term.hs | 50 +++++++++++-------- parser-typechecker/src/Unison/TermParser.hs | 7 ++- .../src/Unison/Typechecker/Context.hs | 3 +- 5 files changed, 46 insertions(+), 26 deletions(-) diff --git a/parser-typechecker/src/Unison/Hashable.hs b/parser-typechecker/src/Unison/Hashable.hs index e5724634a..81a207136 100644 --- a/parser-typechecker/src/Unison/Hashable.hs +++ b/parser-typechecker/src/Unison/Hashable.hs @@ -53,3 +53,4 @@ instance Hashable Text where instance Hashable ByteString where tokens bs = [Bytes bs] + diff --git a/parser-typechecker/src/Unison/Pattern.hs b/parser-typechecker/src/Unison/Pattern.hs index 6a40a9348..13acbc380 100644 --- a/parser-typechecker/src/Unison/Pattern.hs +++ b/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" diff --git a/parser-typechecker/src/Unison/Term.hs b/parser-typechecker/src/Unison/Term.hs index 9a4649ba0..76e8f00f2 100644 --- a/parser-typechecker/src/Unison/Term.hs +++ b/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 ... diff --git a/parser-typechecker/src/Unison/TermParser.hs b/parser-typechecker/src/Unison/TermParser.hs index 1cdf04232..6dbb0b225 100644 --- a/parser-typechecker/src/Unison/TermParser.hs +++ b/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 diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index f4f62ce53..7db4a9778 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/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)]