diff --git a/examples/25-sum-types.hell b/examples/25-sum-types.hell index 50e1e79..4ec5105 100644 --- a/examples/25-sum-types.hell +++ b/examples/25-sum-types.hell @@ -1,5 +1,7 @@ data Value = Text Text | Number Int +data Rating = Good | Bad | Ugly + main = do let printIt = \x -> Text.putStrLn case x of @@ -8,3 +10,7 @@ main = do printIt $ Main.Number 123 printIt $ Main.Text "abc" Monad.mapM_ printIt [Main.Number 123,Main.Text "abc"] + Text.putStrLn $ case Main.Good of + Good -> "Good!" + Bad -> "Bad!" + Ugly -> "Ugly!" diff --git a/src/Hell.hs b/src/Hell.hs index 854d956..49df716 100644 --- a/src/Hell.hs +++ b/src/Hell.hs @@ -207,11 +207,16 @@ parseSumDecl (HSE.Ident _ tyname) conDecls0 = do -- Note: the constructors are sorted by name, to provide a canonical ordering. pure $ map (makeCons conDecls variantType) $ Map.toList conDecls where l = HSE.noSrcSpan - makeCons conDecls variantType (conName, _) = (conName, expr) where - expr = - HSE.Lambda l [HSE.PVar l (HSE.Ident l "x")] $ - appTagged tyname variantType $ - desugarVariantCon (Map.keys conDecls) conName + makeCons conDecls variantType (conName, typ) + | HSE.TyCon _ (HSE.Qual _ (HSE.ModuleName _ "hell:Hell") (HSE.Ident _ "Nullary")) <- typ + = (conName, appTagged tyname variantType $ + desugarVariantCon True (Map.keys conDecls) conName) + | otherwise = (conName, expr) + where + expr = + HSE.Lambda l [HSE.PVar l (HSE.Ident l "x")] $ + appTagged tyname variantType $ + desugarVariantCon False (Map.keys conDecls) conName appTagged name ty = HSE.App l $ HSE.App l (HSE.App l @@ -223,15 +228,19 @@ parseSumDecl (HSE.Ident _ tyname) conDecls0 = do parseSumDecl _ _ = fail "Sum type declaration not in supported format." -desugarVariantCon :: [String] -> String -> HSE.Exp HSE.SrcSpanInfo -desugarVariantCon cons thisCon = rights $ left where +desugarVariantCon :: Bool -> [String] -> String -> HSE.Exp HSE.SrcSpanInfo +desugarVariantCon nullary cons thisCon = rights $ left where right _ = HSE.Var l (HSE.Qual l (HSE.ModuleName l "Variant") (HSE.Ident l "right")) rights e = foldr (HSE.App l) e $ map right $ takeWhile (/= thisCon) cons left = - HSE.App l (HSE.App l (HSE.Var l (HSE.Qual l (HSE.ModuleName l "Variant") (HSE.Ident l "left"))) - (HSE.TypeApp l (tySym thisCon))) + if nullary then HSE.App l left0 + (HSE.Con l (HSE.Qual l (HSE.ModuleName l "hell:Hell") (HSE.Ident l "Nullary"))) else + HSE.App l left0 (HSE.Var l (HSE.UnQual l (HSE.Ident l "x"))) + where left0 = + (HSE.App l (HSE.Var l (HSE.Qual l (HSE.ModuleName l "Variant") (HSE.Ident l "left"))) + (HSE.TypeApp l (tySym thisCon))) tySym s = HSE.TyPromoted l (HSE.PromotedString l s s) l = HSE.noSrcSpan @@ -250,6 +259,9 @@ desugarVariantType = appRecord . foldr appCons nilL where parseConDecl :: MonadFail f => HSE.QualConDecl l -> f (String, HSE.Type l) parseConDecl (HSE.QualConDecl _ Nothing Nothing (HSE.ConDecl _ (HSE.Ident _ consName) [slot])) = pure (consName, slot) +parseConDecl (HSE.QualConDecl l Nothing Nothing (HSE.ConDecl _ (HSE.Ident _ consName) [])) = + pure (consName, HSE.TyCon l (HSE.Qual l (HSE.ModuleName l "hell:Hell") + (HSE.Ident l "Nullary"))) parseConDecl _ = fail "Unsupported constructor declaration format." parseDataDecl :: (l ~ HSE.SrcSpanInfo) => HSE.Name l -> HSE.QualConDecl l -> HSE.ParseResult (String, HSE.Exp HSE.SrcSpanInfo) @@ -688,6 +700,17 @@ desugarCase l scrutinee xs = do (HSE.Ident l' "cons"))) (HSE.TypeApp l' (tySym name))) (HSE.Lambda l' [HSE.PVar l' (HSE.Ident l' x)] e) + -- Nullary constructor + desugarAlt (HSE.Alt l' (HSE.PApp _ (HSE.UnQual _ (HSE.Ident _ name)) + []) + (HSE.UnGuardedRhs _ e) + _) = + -- Variant.cons @name (\_ -> e) + pure $ (name, ) $ + HSE.App l' (HSE.App l' (HSE.Var l' (HSE.Qual l' (HSE.ModuleName l' "Variant") + (HSE.Ident l' "cons"))) + (HSE.TypeApp l' (tySym name))) + (HSE.Lambda l' [HSE.PVar l' (HSE.Ident l' "_")] e) desugarAlt _ = Left $ UnsupportedSyntax "case alternative syntax" bindingStrings :: Binding -> [String] @@ -768,6 +791,9 @@ desugarSomeType = go where HSE.TyParen _ x -> go x HSE.TyCon _ (HSE.UnQual _ (HSE.Ident _ name)) | Just rep <- Map.lookup name supportedTypeConstructors -> pure rep + HSE.TyCon _ (HSE.Qual _ (HSE.ModuleName _ m) (HSE.Ident _ name)) + | Just rep <- Map.lookup (m <> "." <> name) supportedTypeConstructors + -> pure rep HSE.TyCon _ (HSE.Special _ HSE.UnitCon{}) -> pure $ StarTypeRep $ typeRep @() HSE.TyList _ inner -> do rep <- go inner @@ -942,9 +968,12 @@ supportedTypeConstructors = Map.fromList [ ("Variant", SomeTypeRep $ typeRep @Variant), ("NilL", SomeTypeRep $ typeRep @('NilL)), ("ConsL", SomeTypeRep $ typeRep @('ConsL)), - ("()", SomeTypeRep $ typeRep @()) + ("()", SomeTypeRep $ typeRep @()), + ("hell:Hell.Nullary", SomeTypeRep $ typeRep @Nullary) ] +data Nullary = Nullary + -------------------------------------------------------------------------------- -- Support primitives @@ -1068,7 +1097,9 @@ supportedLits = Map.fromList [ ("Json.Array", lit' (Json.toJSON :: Vector Value -> Value)), ("Json.Object", lit' (Json.toJSON :: Map Text Value -> Value)), -- Records - ("Record.nil", lit' NilR) + ("Record.nil", lit' NilR), + -- Nullary + ("hell:Hell.Nullary", lit' Nullary) ] where lit' :: forall a. Type.Typeable a => a -> (UTerm (), SomeTypeRep) lit' x = (lit x, SomeTypeRep $ Type.typeOf x)