diff --git a/grin/src/Grin/ExtendedSyntax/Lint.hs b/grin/src/Grin/ExtendedSyntax/Lint.hs index 645a5741..de84bbc5 100644 --- a/grin/src/Grin/ExtendedSyntax/Lint.hs +++ b/grin/src/Grin/ExtendedSyntax/Lint.hs @@ -248,6 +248,7 @@ annotate te = cata builder where :< SFetchF var -- Fetch returns a value based on its arguments that is associated in its binded variable SAppF name params -> (te ^? function . at name . _Just . _1) :< SAppF name params AltF cpat body -> extract body :< AltF cpat body + NAltF cpat n body -> extract body :< NAltF cpat n body ECaseF var alts -> (do case catMaybes $ map extract alts of [] -> Nothing @@ -446,6 +447,10 @@ lint warningKinds mTypeEnv exp@(Program exts _) = -- Alt (_ :< AltF cpat _) -> checkWithChild ExpCtx $ do syntaxE AltCtx + -- TODO: Define some checks for the alt name. + -- For example, that it is a fresh variable. + (_ :< NAltF cpat n _) -> checkWithChild ExpCtx $ do + syntaxE AltCtx where syntaxE = syntaxExp ctx diff --git a/grin/src/Grin/ExtendedSyntax/Nametable.hs b/grin/src/Grin/ExtendedSyntax/Nametable.hs index 242cb8a6..c066b05e 100644 --- a/grin/src/Grin/ExtendedSyntax/Nametable.hs +++ b/grin/src/Grin/ExtendedSyntax/Nametable.hs @@ -95,6 +95,7 @@ convert = second (view nametable) . flip runState emptyNS . cata build where SUpdateF ptr var -> SUpdate <$> nameToIdx ptr <*> nameToIdx var SBlockF body -> SBlock <$> body AltF cp e -> Alt <$> cpat cp <*> e + NAltF cp n e -> NAlt <$> cpat cp <*> nameToIdx n <*> e -- * Restore @@ -116,6 +117,7 @@ restore (exp, nt) = cata build exp where SUpdateF ptr var -> SUpdate (rname ptr) (rname var) SBlockF body -> SBlock body AltF cp e -> Alt (rcpat cp) e + NAltF cp n e -> NAlt (rcpat cp) (rname n) e rname :: Name -> Name rname (NI i) = maybe (error $ show i ++ " is not found") NM $ Map.lookup i nt diff --git a/grin/src/Grin/ExtendedSyntax/Parse/AST.hs b/grin/src/Grin/ExtendedSyntax/Parse/AST.hs index 0287277c..b8175b6f 100644 --- a/grin/src/Grin/ExtendedSyntax/Parse/AST.hs +++ b/grin/src/Grin/ExtendedSyntax/Parse/AST.hs @@ -49,7 +49,7 @@ ifThenElse i = do simpleExp :: Pos -> Parser SimpleExp simpleExp i = SReturn <$ kw "pure" <*> value <|> - ECase <$ kw "case" <*> var <* kw "of" <*> (L.indentGuard sc GT i >>= some . alternative) <|> + ECase <$ kw "case" <*> var <* kw "of" <*> (L.indentGuard sc GT i >>= some . (\pos -> try (alternative pos) <|> nAlternative pos)) <|> SStore <$ kw "store" <*> var <|> SFetch <$ kw "fetch" <*> var <|> SUpdate <$ kw "update" <*> var <*> var <|> @@ -64,6 +64,9 @@ primNameOrDefName = nMap ("_"<>) <$ char '_' <*> var <|> var alternative :: Pos -> Parser Alt alternative i = Alt <$> try (L.indentGuard sc EQ i *> altPat) <* op "->" <*> (L.indentGuard sc GT i >>= expr) +nAlternative :: Pos -> Parser NAlt +nAlternative i = NAlt <$> try (L.indentGuard sc EQ i *> altPat) <*> (op "@" *> var) <* op "->" <*> (L.indentGuard sc GT i >>= expr) + -- NOTE: The parser `value` already handles the parentheses around "complex" values, -- and we don't want to parenthesize variables, literals and units. bindingPat :: Parser BPat diff --git a/grin/src/Grin/ExtendedSyntax/Pretty.hs b/grin/src/Grin/ExtendedSyntax/Pretty.hs index ee2431a9..4660a910 100644 --- a/grin/src/Grin/ExtendedSyntax/Pretty.hs +++ b/grin/src/Grin/ExtendedSyntax/Pretty.hs @@ -118,7 +118,8 @@ prettyHighlightExternals externals exp = cata prettyExpAlgebra exp where SUpdateF name v -> keywordR "update" <+> pretty name <+> pretty v SBlockF exp -> text "do" <$$> indent 2 exp -- Alt - AltF cpat exp -> pretty cpat <+> text "->" <$$> indent 2 exp + AltF cpat exp -> pretty cpat <+> text "->" <$$> indent 2 exp + NAltF cpat scrut exp -> pretty cpat <+> pretty '@' <+> pretty scrut <+> text "->" <$$> indent 2 exp instance Pretty Exp where diff --git a/grin/src/Grin/ExtendedSyntax/PrettyLint.hs b/grin/src/Grin/ExtendedSyntax/PrettyLint.hs index 3f8822b7..3630d9c6 100644 --- a/grin/src/Grin/ExtendedSyntax/PrettyLint.hs +++ b/grin/src/Grin/ExtendedSyntax/PrettyLint.hs @@ -51,4 +51,5 @@ prettyAnnExp exp = cata folder exp where SUpdateF ptr var -> keywordR "update" <+> pretty ptr <+> pretty var SBlockF exp -> text "do" <$$> indent 2 (pretty exp) -- Alt - AltF cpat exp -> pretty cpat <+> text "->" <$$> indent 2 (pretty exp) + AltF cpat exp -> pretty cpat <+> text "->" <$$> indent 2 (pretty exp) + NAltF cpat n exp -> pretty cpat <+> pretty '@' <+> pretty n <+> text "->" <$$> indent 2 (pretty exp) diff --git a/grin/src/Grin/ExtendedSyntax/Statistics.hs b/grin/src/Grin/ExtendedSyntax/Statistics.hs index b76e064a..aad745bb 100644 --- a/grin/src/Grin/ExtendedSyntax/Statistics.hs +++ b/grin/src/Grin/ExtendedSyntax/Statistics.hs @@ -63,6 +63,7 @@ statistics = cata $ \case SBlockF s -> s <> mempty { sBlock = 1 } -- Alt AltF p s -> s <> mempty { alt = 1, vars = foldNames Set.singleton p, tags = tagInCPat p } + NAltF p n s -> s <> mempty { alt = 1, vars = foldNames Set.singleton p <> Set.singleton n, tags = tagInCPat p } -- general case e -> Data.Foldable.fold e diff --git a/grin/src/Grin/ExtendedSyntax/Syntax.hs b/grin/src/Grin/ExtendedSyntax/Syntax.hs index 3becc721..7e92b4ef 100644 --- a/grin/src/Grin/ExtendedSyntax/Syntax.hs +++ b/grin/src/Grin/ExtendedSyntax/Syntax.hs @@ -99,6 +99,7 @@ makeLenses ''BPat type SimpleExp = Exp type Alt = Exp +type NAlt = Exp type Def = Exp type Program = Exp @@ -117,6 +118,7 @@ data Exp | SBlock Exp -- Alt | Alt CPat Exp + | NAlt CPat Name Exp deriving (Generic, Data, NFData, Binary, Eq, Ord, Show) externals :: Exp -> [External] @@ -142,6 +144,14 @@ _AltFCPat :: Traversal' (ExpF a) CPat _AltFCPat f (AltF p e) = (`AltF` e) <$> f p _AltFCPat _ other = pure other +_NAltCPat :: Traversal' Exp CPat +_NAltCPat f (NAlt p n e) = NAlt <$> f p <*> pure n <*> pure e +_NAltCPat _ other = pure other + +_NAltFCPat :: Traversal' (ExpF a) CPat +_NAltFCPat f (NAltF p n e) = NAltF <$> f p <*> pure n <*> pure e +_NAltFCPat _ other = pure other + _ValVar :: Traversal' Val Name _ValVar f (Var name) = Var <$> f name _ValVar _ other = pure other diff --git a/grin/src/Transformations/ExtendedSyntax/Conversion.hs b/grin/src/Transformations/ExtendedSyntax/Conversion.hs index ee26e03f..a26cbec5 100644 --- a/grin/src/Transformations/ExtendedSyntax/Conversion.hs +++ b/grin/src/Transformations/ExtendedSyntax/Conversion.hs @@ -12,6 +12,7 @@ import qualified Data.Map as M import qualified Data.Vector as V import Control.Monad +import Control.Monad.Identity import Lens.Micro.Extra import Lens.Micro.Platform @@ -27,15 +28,12 @@ import qualified Grin.ExtendedSyntax.Syntax as New import qualified Grin.ExtendedSyntax.SyntaxDefs as New import qualified Grin.ExtendedSyntax.TypeEnvDefs as New +import Transformations.Util import Transformations.Names import Transformations.BindNormalisation import Transformations.Simplifying.ProducerNameIntroduction import Transformations.Simplifying.BindingPatternSimplification --- TODO: remove these -import Test.QuickCheck -import Test.ExtendedSyntax.Old.Test() -import qualified Test.ExtendedSyntax.Old.Grammar as OG class Convertible a b where convert :: a -> b @@ -109,7 +107,7 @@ instance Convertible CPat New.CPat where NodePat t args -> New.NodePat (convert t) (map convert args) LitPat l -> New.LitPat (convert l) DefaultPat -> New.DefaultPat - TagPat _ -> error "covnert: Tag patterns are not supported in the new syntax." + TagPat _ -> error "convert: Tag patterns are not supported in the new syntax." instance Convertible Val New.Val where convert n@(ConstTagNode t vals) @@ -123,38 +121,42 @@ instance Convertible Val New.Val where convert (Undefined t) = New.Undefined (convert t) instance Convertible Exp New.Exp where - convert (Program exts defs) = New.Program (map convert exts) (map convert defs) - convert (Def name args body) = New.Def (convert name) (map convert args) (convert body) - {- NOTE: we assume Binding Pattern Simplification has been run - v.0 <- pure - <- pure v.0 - - -} - convert (EBind lhs1 (Var var) rhs1) - | EBind (SReturn (Var var')) pat rhs2 <- rhs1 - , isn't _Var pat - , var == var' - = New.EBind (convert lhs1) (New.AsPat (convert var) (convert pat)) (convert rhs2) - convert (EBind lhs (Var var) rhs) - = New.EBind (convert lhs) (New.VarPat $ convert var) (convert rhs) - convert (ECase scrut alts) - | isn't _Var scrut = error $ "Non-variable pattern in case scrutinee: " ++ show (PP scrut) - | (Var var) <- scrut = New.ECase (convert var) (map convert alts) - convert e@(SApp f vals) - | any (isn't _Var) vals = error $ "Non-variable value in application: " ++ show (PP e) - | otherwise = New.SApp (convert f) $ map (convert . view _Var) vals - convert e@(SStore val) - | isn't _Var val = error $ "Non-variable value in store: " ++ show (PP e) - | (Var var) <- val = New.SStore (convert var) - convert e@(SFetchI ptr mIx) - | Nothing <- mIx = New.SFetch (convert ptr) - | otherwise = error $ "Indexed fetch is no longer supported: " ++ show (PP e) - convert e@(SUpdate ptr val) - | isn't _Var val = error $ "Non-variable value in update: " ++ show (PP e) - | (Var var) <- val = New.SUpdate (convert ptr) (convert var) - convert (SReturn val) = New.SReturn (convert val) - convert (SBlock exp) = New.SBlock (convert exp) - convert (Alt cpat exp) = New.Alt (convert cpat) (convert exp) + convert exp = fst $ evalNameM exp $ flip anaM exp $ \case + (Program exts defs) -> pure $ New.ProgramF (map convert exts) defs + (Def name args body) -> pure $ New.DefF (convert name) (map convert args) body + {- NOTE: we assume Binding Pattern Simplification has been run + v.0 <- pure + <- pure v.0 + + -} + (EBind lhs1 (Var var) rhs1) + | EBind (SReturn (Var var')) pat rhs2 <- rhs1 + , isn't _Var pat + , var == var' + -> pure $ New.EBindF lhs1 (New.AsPat (convert var) (convert pat)) rhs2 + (EBind lhs (Var var) rhs) + -> pure $ New.EBindF lhs (New.VarPat $ convert var) rhs + (ECase scrut alts) + | isn't _Var scrut -> error $ "Non-variable pattern in case scrutinee: " ++ show (PP scrut) + | (Var var) <- scrut -> pure $ New.ECaseF (convert var) alts + e@(SApp f vals) + | any (isn't _Var) vals -> error $ "Non-variable value in application: " ++ show (PP e) + | otherwise -> pure $ New.SAppF (convert f) $ map (convert . view _Var) vals + e@(SStore val) + | isn't _Var val -> error $ "Non-variable value in store: " ++ show (PP e) + | (Var var) <- val -> pure $ New.SStoreF (convert var) + e@(SFetchI ptr mIx) + | Nothing <- mIx -> pure $ New.SFetchF (convert ptr) + | otherwise -> error $ "Indexed fetch is no longer supported: " ++ show (PP e) + e@(SUpdate ptr val) + | isn't _Var val -> error $ "Non-variable value in update: " ++ show (PP e) + | (Var var) <- val -> pure $ New.SUpdateF (convert ptr) (convert var) + (SReturn val) -> pure $ New.SReturnF (convert val) + (SBlock exp) -> pure $ New.SBlockF exp + -- TODO: to NAlt + (Alt cpat exp) -> do + altName <- deriveNewName "alt" + pure $ New.NAltF (convert cpat) (convert altName) exp instance Convertible New.TagType TagType where convert = \case @@ -248,6 +250,8 @@ instance Convertible New.Exp Exp where convert (New.SReturn val) = SReturn (convert val) convert (New.SBlock exp) = SBlock (convert exp) convert (New.Alt cpat exp) = Alt (convert cpat) (convert exp) + -- TODO: This transformation is not sound if the body contains a reference to the alt name. + convert (New.NAlt cpat _ exp) = Alt (convert cpat) (convert exp) convertToNew :: Exp -> New.Exp convertToNew = convert . nameEverything diff --git a/grin/src/Transformations/ExtendedSyntax/Util.hs b/grin/src/Transformations/ExtendedSyntax/Util.hs index 9aa068ca..ee42e0d9 100644 --- a/grin/src/Transformations/ExtendedSyntax/Util.hs +++ b/grin/src/Transformations/ExtendedSyntax/Util.hs @@ -55,6 +55,8 @@ foldNameDefExpF f = \case DefF name args _ -> mconcat $ (f FunName name) : map (f FunParam) args EBindF _ bPat _ -> f BindVar (_bPatVar bPat) AltF cpat _ -> foldNames (f AltVar) cpat + -- QUESTION: What should be the alt name's DefRole? Now it is BindVar, because it rebinds the scrutinee. + NAltF cpat n _ -> f BindVar n <> foldNames (f AltVar) cpat _ -> mempty mapNamesCPat :: (Name -> Name) -> CPat -> CPat @@ -197,6 +199,7 @@ collectTagInfo = flip execState (TagInfo Map.empty) . cataM alg alg = \case SReturnF val -> goVal val AltF cpat _ -> goCPat cpat + NAltF cpat _ _ -> goCPat cpat _ -> pure () goVal :: Val -> State TagInfo () diff --git a/grin/test/ExtendedSyntax/ParserSpec.hs b/grin/test/ExtendedSyntax/ParserSpec.hs index f1672386..c4f74255 100644 --- a/grin/test/ExtendedSyntax/ParserSpec.hs +++ b/grin/test/ExtendedSyntax/ParserSpec.hs @@ -112,16 +112,16 @@ spec = do let before = [prog| test p = _unit@() <- case p of - #default -> + #default @ _1 -> pure () case p of - #default -> + #default @ _2 -> pure p |] let after = Program [] [ Def "test"[ "p" ] - ( EBind ( ECase "p" [ Alt DefaultPat ( SReturn Unit ) ] ) (AsPat "_unit" Unit) - ( ECase "p" [ Alt DefaultPat ( SReturn (Var "p") ) ] ) + ( EBind ( ECase "p" [ NAlt DefaultPat "_1" ( SReturn Unit ) ] ) (AsPat "_unit" Unit) + ( ECase "p" [ NAlt DefaultPat "_2" ( SReturn (Var "p") ) ] ) ) ] before `sameAs` after @@ -163,29 +163,29 @@ spec = do let before = [prog| grinMain = case scrut of - 13.1415 -> pure () - +14.1415 -> pure () - -14.1415 -> pure () - 42 -> pure () - +43 -> pure () - -42 -> pure () - 64u -> pure () - (CNode a1 a2 a3 a4 a5) -> pure () - #default -> pure () - #True -> pure () - #False -> pure () + 13.1415 @ _1 -> pure () + +14.1415 @ _2 -> pure () + -14.1415 @ _3 -> pure () + 42 @ _4 -> pure () + +43 @ _5 -> pure () + -42 @ _6 -> pure () + 64u @ _7 -> pure () + (CNode a1 a2 a3 a4 a5) @ _8 -> pure () + #default @ _9 -> pure () + #True @ _10 -> pure () + #False @ _11 -> pure () |] let after = Program [] [ Def "grinMain"[] ( ECase "scrut" - [ Alt ( LitPat ( LFloat 13.1415 ) ) ( SReturn Unit ) - , Alt ( LitPat ( LFloat 14.1415 ) ) ( SReturn Unit ) - , Alt ( LitPat ( LFloat ( -14.1415 ) ) ) ( SReturn Unit ) - , Alt ( LitPat ( LInt64 42 ) ) ( SReturn Unit ) - , Alt ( LitPat ( LInt64 43 ) ) ( SReturn Unit ) - , Alt ( LitPat ( LInt64 ( -42 ) ) ) ( SReturn Unit ) - , Alt ( LitPat ( LWord64 64 ) ) ( SReturn Unit ) - , Alt + [ NAlt ( LitPat ( LFloat 13.1415 ) ) "_1" ( SReturn Unit ) + , NAlt ( LitPat ( LFloat 14.1415 ) ) "_2" ( SReturn Unit ) + , NAlt ( LitPat ( LFloat ( -14.1415 ) ) ) "_3" ( SReturn Unit ) + , NAlt ( LitPat ( LInt64 42 ) ) "_4" ( SReturn Unit ) + , NAlt ( LitPat ( LInt64 43 ) ) "_5" ( SReturn Unit ) + , NAlt ( LitPat ( LInt64 ( -42 ) ) ) "_6" ( SReturn Unit ) + , NAlt ( LitPat ( LWord64 64 ) ) "_7" ( SReturn Unit ) + , NAlt ( NodePat ( Tag { tagType = C @@ -198,10 +198,10 @@ spec = do , "a4" , "a5" ] - ) ( SReturn Unit ) - , Alt DefaultPat ( SReturn Unit ) - , Alt ( LitPat ( LBool True ) ) ( SReturn Unit ) - , Alt ( LitPat ( LBool False ) ) ( SReturn Unit ) + ) "_8" ( SReturn Unit ) + , NAlt DefaultPat "_9" ( SReturn Unit ) + , NAlt ( LitPat ( LBool True ) ) "_10" ( SReturn Unit ) + , NAlt ( LitPat ( LBool False ) ) "_11" ( SReturn Unit ) ] ) ] @@ -294,9 +294,9 @@ spec = do v1 <- pure #"" v2 <- pure #"a" v3 <- case v1 of - #"" -> pure 1 - #"a" -> pure 2 - #default -> pure 3 + #"" @ _1 -> pure 1 + #"a" @ _2 -> pure 2 + #default @ _3 -> pure 3 _x@#"a" <- pure v2 pure () |] @@ -305,9 +305,9 @@ spec = do EBind (SReturn (Lit (LString ""))) (VarPat "v1") $ EBind (SReturn (Lit (LString "a"))) (VarPat "v2") $ EBind (ECase "v1" $ - [Alt (LitPat (LString "")) (SReturn (Lit (LInt64 1))) - ,Alt (LitPat (LString "a")) (SReturn (Lit (LInt64 2))) - ,Alt DefaultPat (SReturn (Lit (LInt64 3))) + [NAlt (LitPat (LString "")) "_1" (SReturn (Lit (LInt64 1))) + ,NAlt (LitPat (LString "a")) "_2" (SReturn (Lit (LInt64 2))) + ,NAlt DefaultPat "_3" (SReturn (Lit (LInt64 3))) ]) (VarPat "v3") $ EBind (SReturn $ Var "v2") (AsPat "_x" $ (Lit (LString "a"))) $ SReturn Unit @@ -319,9 +319,9 @@ spec = do grinMain = v2 <- pure #'a' v3 <- case v2 of - #'b' -> pure 1 - #'c' -> pure 2 - #default -> pure 3 + #'b' @ _1 -> pure 1 + #'c' @ _2 -> pure 2 + #default @ _3 -> pure 3 _c@#'a' <- pure v2 pure () |] @@ -329,9 +329,9 @@ spec = do [Def "grinMain" [] $ EBind (SReturn (Lit (LChar 'a'))) (VarPat "v2") $ EBind (ECase "v2" $ - [Alt (LitPat (LChar 'b')) (SReturn (Lit (LInt64 1))) - ,Alt (LitPat (LChar 'c')) (SReturn (Lit (LInt64 2))) - ,Alt DefaultPat (SReturn (Lit (LInt64 3))) + [NAlt (LitPat (LChar 'b')) "_1" (SReturn (Lit (LInt64 1))) + ,NAlt (LitPat (LChar 'c')) "_2" (SReturn (Lit (LInt64 2))) + ,NAlt DefaultPat "_3" (SReturn (Lit (LInt64 3))) ]) (VarPat "v3") $ EBind (SReturn $ Var "v2") (AsPat "_c" $ Lit (LChar 'a')) $ SReturn Unit