~jojo/Carth

4d62a178f16bc07a623cf09fe3b90cff4316752b — JoJo 1 year, 10 months ago 2d64043
Allow integer and boolean literals in patterns

Could exploit the existing Match.PCon constructor to represent not
just datatypes, but these other enumerables as well. Didn't have to
make many additions/modifications at all -- quite nice!
6 files changed, 47 insertions(+), 12 deletions(-)

M examples/fizzbuzz.carth
M src/AnnotAst.hs
M src/Ast.hs
M src/Codegen.hs
M src/Infer.hs
M src/Parse.hs
M examples/fizzbuzz.carth => examples/fizzbuzz.carth +11 -7
@@ 19,13 19,17 @@
       (comp display fizzbuzz')))

(define (fizzbuzz' n)
  (if (and (divisible? n 3) (divisible? n 5))
      "Fizzbuzz"
    (if (divisible? n 3)
        "Fizz"
      (if (divisible? n 5)
          "Buzz"
        (show-int n)))))
  (match (Pair (divisible? n 3) (divisible? n 5))
    [(Pair false false) (my-show-int n)]
    [(Pair true false) "Fizz"]
    [(Pair false true) "Buzz"]
    [(Pair true true) "Fizzbuzz"]))

(define my-show-int
  (fun-match
    [1 "one"]
    [2 "two"]
    [n (show-int n)]))

(define (display s)
  (display-inline (str-append s "\n")))

M src/AnnotAst.hs => src/AnnotAst.hs +1 -1
@@ 37,7 37,7 @@ type Id = WithPos String
data TypedVar = TypedVar Id Type
    deriving (Show, Eq, Ord)

type VariantIx = Word64
type VariantIx = Integer

data Access = Obj | As Access Span [Type] | Sel Word32 Span Access
    deriving (Show, Eq, Ord)

M src/Ast.hs => src/Ast.hs +8 -0
@@ 82,6 82,8 @@ makeLenses ''Scheme

data Pat
    = PConstruction SrcPos (Id 'Big) [Pat]
    | PInt SrcPos Int
    | PBool SrcPos Bool
    | PVar (Id 'Small)
    deriving Show



@@ 144,6 146,8 @@ instance HasPos (Id a) where
instance HasPos Pat where
    getPos = \case
        PConstruction p _ _ -> p
        PInt p _ -> p
        PBool p _ -> p
        PVar v -> getPos v

instance Pretty Program where


@@ 197,6 201,8 @@ fvCases = Set.unions . map (\(p, e) -> Set.difference (freeVars e) (bvPat p))
bvPat :: Pat -> Set (Id 'Small)
bvPat = \case
    PConstruction _ _ ps -> Set.unions (map bvPat ps)
    PInt _ _ -> Set.empty
    PBool _ _ -> Set.empty
    PVar x -> Set.singleton x

prettyProg :: Int -> Program -> String


@@ 299,6 305,8 @@ prettyPat :: Pat -> String
prettyPat = \case
    PConstruction _ (Id (WithPos _ c)) ps ->
        if null ps then c else concat ["(", c, " ", spcPretty ps, ")"]
    PInt _ n -> show n
    PBool _ b -> if b then "true" else "false"
    PVar v -> idstr v

prettyConst :: Const -> String

M src/Codegen.hs => src/Codegen.hs +10 -3
@@ 513,6 513,8 @@ genLet ds b = do

genMatch :: Expr -> DecisionTree -> Type -> Gen Val
genMatch m dt tbody = do
    -- TODO: Do we have to convert it to an operand here already? Keeping it as
    --       Val would probably eliminate a needless stack allocation.
    m' <- getLocal =<< genExpr m
    genDecisionTree tbody dt (newSelections m')



@@ 534,9 536,11 @@ genDecisionSwitch selector cs def tbody selections = do
    defaultL <- newName "default"
    nextL <- newName "next"
    (m, selections') <- select genAs genSub selector selections
    mVariantIx <- emitReg' "found_variant_ix" =<< extractvalue m [0]
    mVariantIx <- case typeOf m of
        IntegerType _ -> pure m
        _ -> emitReg' "found_variant_ix" =<< extractvalue m [0]
    let ixBits = getIntBitWidth (typeOf mVariantIx)
    let litIxInt = LLConst.Int ixBits . fromIntegral
    let litIxInt = LLConst.Int ixBits
    let dests' = zip (map litIxInt variantIxs) variantLs
    commitToNewBlock (switch mVariantIx defaultL dests') defaultL
    let genDecisionTree' dt = do


@@ 573,7 577,7 @@ genCtion (i, span', dataType, as) = do
    as' <- mapM genExpr as
    let tag = maybe
            id
            ((:) . VLocal . ConstantOperand . flip LLConst.Int (fromIntegral i))
            ((:) . VLocal . ConstantOperand . flip LLConst.Int i)
            (tagBitWidth span')
    s <- getLocal =<< genStruct (tag as')
    let t = typeOf s


@@ 836,6 840,9 @@ switch x def cs = Switch x def cs []
bitcast :: Operand -> Type -> FunInstruction
bitcast x t = WithRetType (BitCast x t []) t

trunc :: Operand -> Type -> FunInstruction
trunc x t = WithRetType (Trunc x t []) t

insertvalue :: Operand -> Operand -> [Word32] -> FunInstruction
insertvalue s e is = WithRetType (InsertValue s e is []) (typeOf s)


M src/Infer.hs => src/Infer.hs +11 -0
@@ 238,12 238,23 @@ inferCase (p, b) = do
inferPat :: Ast.Pat -> Infer (Type, Pat, Map (Id 'Small) Scheme)
inferPat = \case
    Ast.PConstruction pos c ps -> inferPatConstruction pos c ps
    Ast.PInt _ n -> pure (TPrim TInt, intToPCon n 64, Map.empty)
    Ast.PBool _ b -> pure (TPrim TBool, intToPCon (fromEnum b) 1, Map.empty)
    Ast.PVar (Id (WithPos _ "_")) -> do
        tv <- fresh
        pure (tv, PWild, Map.empty)
    Ast.PVar x@(Id x') -> do
        tv <- fresh
        pure (tv, PVar (TypedVar x' tv), Map.singleton x (Forall Set.empty tv))
  where
    intToPCon n w = PCon
        (Con
            { variant = fromIntegral n
            , span = 2 ^ (w :: Integer)
            , argTs = []
            }
        )
        []

inferPatConstruction
    :: SrcPos

M src/Parse.hs => src/Parse.hs +6 -1
@@ 147,6 147,9 @@ ns_expr = withPos
bool :: Parser Bool
bool = (ns_reserved "true" $> True) <|> (ns_reserved "false" $> False)

int :: Parser Int
int = Lexer.signed empty Lexer.decimal

eConstructor :: Parser Expr'
eConstructor = fmap Ctor ns_big'



@@ 173,8 176,10 @@ pat :: Parser Pat
pat = andSkipSpaceAfter ns_pat

ns_pat :: Parser Pat
ns_pat = patCtor <|> patCtion <|> patVar
ns_pat = choice [patInt, patBool, patCtor, patCtion, patVar]
  where
    patInt = liftA2 PInt getSrcPos int
    patBool = liftA2 PBool getSrcPos bool
    patCtor = fmap (\x -> PConstruction (getPos x) x []) ns_big'
    patVar = fmap PVar ns_small'
    patCtion = do