From 170e4e36aee7344324f3fc8bbb27b857cab41a8d Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 24 Jan 2024 11:30:34 -0700 Subject: [PATCH] new tag syntax; preparing for Core patterns new tag syntax; preparing for data names --- CHANGELOG.md | 17 +++++++++++++++++ examples/factorial.hs | 4 ++-- examples/sumList.hs | 4 ++-- src/Core/Examples.hs | 14 +++++++------- src/Core/Lex.x | 5 +++++ src/Core/Parse.y | 3 ++- src/Core/Syntax.hs | 15 ++++++--------- src/GM.hs | 2 +- 8 files changed, 42 insertions(+), 22 deletions(-) create mode 100644 CHANGELOG.md diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..9921c0c --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,17 @@ +# unreleased + +* New tag syntax: + ```hs + case x of + { 1 -> something + ; 2 -> another + } + ``` + is now written as + ```hs + case x of + { <1> -> something + ; <2> -> another + } + ``` + diff --git a/examples/factorial.hs b/examples/factorial.hs index cc235ab..1080c7b 100644 --- a/examples/factorial.hs +++ b/examples/factorial.hs @@ -1,6 +1,6 @@ fac n = case (==#) n 0 of - { 1 -> 1 - ; 0 -> (*#) n (fac ((-#) n 1)) + { <1> -> 1 + ; <0> -> (*#) n (fac ((-#) n 1)) }; main = fac 3; diff --git a/examples/sumList.hs b/examples/sumList.hs index fd46a60..5193a67 100644 --- a/examples/sumList.hs +++ b/examples/sumList.hs @@ -2,8 +2,8 @@ nil = Pack{0 0}; cons x y = Pack{1 2} x y; list = cons 1 (cons 2 (cons 3 nil)); sum l = case l of - { 0 -> 0 - ; 1 x xs -> (+#) x (sum xs) + { <0> -> 0 + ; <1> x xs -> (+#) x (sum xs) }; main = sum list; diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index 2ca54e3..0b741e9 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -147,8 +147,8 @@ simple1 = [coreProg| caseBool1 :: Program' caseBool1 = [coreProg| _if c x y = case c of - { 1 -> x - ; 0 -> y + { <1> -> x + ; <0> -> y }; false = Pack{0 0}; @@ -160,8 +160,8 @@ caseBool1 = [coreProg| fac3 :: Program' fac3 = [coreProg| fac n = case (==#) n 0 of - { 1 -> 1 - ; 0 -> (*#) n (fac ((-#) n 1)) + { <1> -> 1 + ; <0> -> (*#) n (fac ((-#) n 1)) }; main = fac 3; @@ -175,8 +175,8 @@ sumList = [coreProg| cons x y = Pack{1 2} x y; list = cons 1 (cons 2 (cons 3 nil)); sum l = case l of - { 0 -> 0 - ; 1 x xs -> (+#) x (sum xs) + { <0> -> 0 + ; <1> x xs -> (+#) x (sum xs) }; main = sum list; |] @@ -192,7 +192,7 @@ idCase = [coreProg| id x = x; main = id (case Pack{1 0} of - { 1 -> (+#) 2 3 + { <1> -> (+#) 2 3 }) |] diff --git a/src/Core/Lex.x b/src/Core/Lex.x index f939258..ba62996 100644 --- a/src/Core/Lex.x +++ b/src/Core/Lex.x @@ -65,6 +65,8 @@ $white_no_nl = $white # $nl @decimal = $digit+ +@alttag = "<" $digit+ ">" + rlp :- <0> @@ -92,6 +94,8 @@ rlp :- "=" { constTok TokenEquals } "->" { constTok TokenArrow } + @alttag { lexWith ( TokenAltTag . read @Int . T.unpack + . T.drop 1 . T.init ) } @varname { lexWith TokenVarName } @conname { lexWith TokenConName } @varsym { lexWith TokenVarSym } @@ -135,6 +139,7 @@ data CoreToken = TokenLet | TokenConName Name | TokenVarSym Name | TokenConSym Name + | TokenAltTag Tag | TokenEquals | TokenLParen | TokenRParen diff --git a/src/Core/Parse.y b/src/Core/Parse.y index b8a0cf3..6d2e5ef 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -49,6 +49,7 @@ import Data.HashMap.Strict qualified as H varsym { Located _ _ _ (TokenVarSym $$) } conname { Located _ _ _ (TokenConName $$) } consym { Located _ _ _ (TokenConSym $$) } + alttag { Located _ _ _ (TokenAltTag $$) } word { Located _ _ _ (TokenWord $$) } 'λ' { Located _ _ _ TokenLambda } '->' { Located _ _ _ TokenArrow } @@ -149,7 +150,7 @@ Alters : Alter ';' Alters { $1 : $3 } | Alter { [$1] } Alter :: { Alter Name } -Alter : litint ParList '->' Expr { Alter (AltData $1) $2 $4 } +Alter : alttag ParList '->' Expr { Alter (AltTag $1) $2 $4 } Expr1 :: { Expr Name } Expr1 : litint { Lit $ IntL $1 } diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index f4785c6..f48d2da 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -42,6 +42,7 @@ import Data.Pretty import Data.List (intersperse) import Data.Function ((&)) import Data.String +import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as H import Data.Hashable import Data.Text qualified as T @@ -105,7 +106,8 @@ data Rec = Rec | NonRec deriving (Show, Read, Eq, Lift) -data AltCon = AltData Tag +data AltCon = AltData Name + | AltTag Tag | AltLit Lit | Default deriving (Show, Read, Eq, Lift) @@ -127,7 +129,9 @@ data Module b = Module (Maybe (Name, [Name])) (Program b) data Program b = Program { _programScDefs :: [ScDef b] - , _programTypeSigs :: H.HashMap b Type + , _programTypeSigs :: HashMap b Type + -- map constructors to their tag and arity + , _programDataTags :: HashMap b (Tag, Int) } deriving (Show, Lift, Generic) deriving (Semigroup, Monoid) @@ -152,13 +156,6 @@ instance IsString Type where | otherwise = TyVar . fromString $ s where (c:_) = s --- instance (Hashable b) => Semigroup (Program b) where --- p <> q = Program --- { _programScDefs = _programScDefs p <> _programScDefs q } - --- instance (Hashable b) => Monoid (Program b) where --- mempty = Program mempty mempty - ---------------------------------------------------------------------------------- class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where diff --git a/src/GM.hs b/src/GM.hs index 8b91393..46bf3a9 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -724,7 +724,7 @@ buildInitialHeap (view programScDefs -> ss) = mapAccumL allocateSc mempty compil compileD g as = fmap (compileA g) as compileA :: Env -> Alter' -> (Tag, Code) - compileA g (Alter (AltData t) as e) = (t, [Split n] <> c <> [Slide n]) + compileA g (Alter (AltTag t) as e) = (t, [Split n] <> c <> [Slide n]) where n = length as binds = (NameKey <$> as) `zip` [0..]