~jojo/Carth

ea2ad247ea7162928c3717962a1baca4ec837c2a — JoJo 1 year, 5 months ago 2d0bf5b
Impl types Union, Bool using existing data-type mechanics

No more special cases in TPrim, just implement them as normal
data-types instead. They're declared in Check.hs, and we ensure
they're generated in initInsts in Monomorphize.hs. Other than that,
the compiler barely has to know they exist!
M examples/fizzbuzz.carth => examples/fizzbuzz.carth +5 -5
@@ 1,6 1,6 @@
(import std)

(define (main _) (fizzbuzz unit))
(define (main Unit) (fizzbuzz Unit))

(define (fizzbuzz _)
  (for (range 1 100)


@@ 8,10 8,10 @@

(define (fizzbuzz' n)
  (match (Pair (divisible? n 3) (divisible? n 5))
    (case (Pair false false) (my-show-int n))
    (case (Pair true false) "Fizz")
    (case (Pair false true) "Buzz")
    (case (Pair true true) "Fizzbuzz")))
    (case (Pair False False) (my-show-int n))
    (case (Pair True False) "Fizz")
    (case (Pair False True) "Buzz")
    (case (Pair True True) "Fizzbuzz")))

(define my-show-int
  (fun-match

M src/Abi.hs => src/Abi.hs +1 -1
@@ 34,7 34,7 @@ import qualified LLVM.AST.Constant as LLConst
import LLVM.AST.Global (Parameter)
import qualified LLVM.AST.Global as LLGlob
import qualified LLVM.AST.AddrSpace as LLAddr
import Control.Monad.Writer hiding (Sum(..))
import Control.Monad.Writer
import qualified Data.Map as Map
import Data.Word
import Data.Foldable

M src/Check.hs => src/Check.hs +2 -0
@@ 127,6 127,8 @@ builtinDataTypes' =
      , [TVImplicit 0, TVImplicit 1]
      , [("Pair", [Inferred.TVar (TVImplicit 0), Inferred.TVar (TVImplicit 1)])]
      )
    , ("Unit", [], [("Unit", [])])
    , ("Bool", [], [("False", []), ("True", [])])
    ]

assertNoRec

M src/Codegen.hs => src/Codegen.hs +1 -8
@@ 18,7 18,7 @@ import qualified LLVM.AST.Float as LLFloat
import qualified Codec.Binary.UTF8.String as UTF8.String
import Data.String
import System.FilePath
import Control.Monad.Writer hiding (Sum(..))
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Reader
import qualified Data.Map as Map


@@ 433,11 433,9 @@ genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do

genConst :: Monomorphic.Const -> Gen Val
genConst = \case
    Unit -> pure (VLocal litUnit)
    Int n -> pure (VLocal (litI64 n))
    Double x -> pure (VLocal (litDouble x))
    Str s -> genStrLit s
    Bool b -> pure (VLocal (litBool b))

genStrLit :: String -> Gen Val
genStrLit s = do


@@ 758,7 756,6 @@ genType = lift . genType'
genType' :: Monomorphic.Type -> Gen' Type
genType' = \case
    TPrim tc -> pure $ case tc of
        TUnit -> typeUnit
        TNat8 -> i8
        TNat16 -> i16
        TNat32 -> i32


@@ 768,7 765,6 @@ genType' = \case
        TInt32 -> i32
        TInt -> i64
        TDouble -> double
        TBool -> typeBool
    TFun a r -> genClosureType a r
    TBox t -> fmap LLType.ptr (genType' t)
    TConst tc -> lookupEnum tc <&> \case


@@ 987,9 983,6 @@ litI32 = ConstantOperand . LLConst.Int 32 . toInteger
litI8' :: Integral n => n -> LLConst.Constant
litI8' = LLConst.Int 8 . toInteger

litBool :: Bool -> Operand
litBool b = ConstantOperand $ LLConst.Int 8 $ if b then 1 else 0

litDouble :: Double -> Operand
litDouble = ConstantOperand . LLConst.Float . LLFloat.Double


M src/Infer.hs => src/Infer.hs +1 -6
@@ 208,7 208,7 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        (tp, p') <- infer p
        (tc, c') <- infer c
        (ta, a') <- infer a
        unify (Expected (TPrim TBool)) (Found (getPos p) tp)
        unify (Expected tBool) (Found (getPos p) tp)
        unify (Expected tc) (Found (getPos a) ta)
        pure (tc, If p' c' a')
    Parsed.Fun p b -> inferFunMatch (pure (p, b))


@@ 277,9 277,6 @@ inferPat pat = fmap
    inferPat' = \case
        Parsed.PConstruction pos c ps -> inferPatConstruction pos c ps
        Parsed.PInt _ n -> pure (TPrim TInt, intToPCon n 64, Map.empty)
        Parsed.PUnit _ -> pure (TPrim TUnit, PWild, Map.empty)
        Parsed.PBool _ b ->
            pure (TPrim TBool, intToPCon (fromEnum b) 1, Map.empty)
        Parsed.PStr _ s ->
            let
                span' = ice "span of Con with VariantStr"


@@ 357,11 354,9 @@ lookupEnvConstructor (Id (WithPos pos cx)) =

litType :: Const -> Type
litType = \case
    Unit -> TPrim TUnit
    Int _ -> TPrim TInt
    Double _ -> TPrim TDouble
    Str _ -> typeStr
    Bool _ -> TPrim TBool

typeStr :: Type
typeStr = TConst ("Str", [])

M src/Inferred.hs => src/Inferred.hs +6 -2
@@ 27,6 27,7 @@ module Inferred
    , Ctors
    , Externs
    , mainType
    , tBool
    )
where



@@ 35,7 36,7 @@ import Data.Map.Strict (Map)
import Lens.Micro.Platform (makeLenses)

import Misc
import Parsed (TVar(..), TPrim(..), Const(..))
import Parsed (TVar(..), TPrim(..), Const(..), tUnit)
import SrcPos




@@ 112,4 113,7 @@ instance Ord Con where


mainType :: Type
mainType = TFun (TPrim TUnit) (TPrim TUnit)
mainType = TFun (TConst tUnit) (TConst tUnit)

tBool :: Type
tBool = TConst ("Bool", [])

M src/Monomorphic.hs => src/Monomorphic.hs +3 -2
@@ 22,6 22,7 @@ module Monomorphic
    , TypeDefs
    , Program(..)
    , mainType
    , tUnit
    )
where



@@ 35,7 36,7 @@ import Misc
import SrcPos
import Checked (VariantIx, Span)
import FreeVars
import Parsed (Const(..), TPrim(..))
import Parsed (Const(..), TPrim(..), tUnit)

type TConst = (String, [Type])



@@ 122,4 123,4 @@ fvDecisionTree = \case
        Set.unions $ fvDecisionTree def : map fvDecisionTree es

mainType :: Type
mainType = TFun (TPrim TUnit) (TPrim TUnit)
mainType = TFun (TConst tUnit) (TConst tUnit)

M src/Monomorphize.hs => src/Monomorphize.hs +4 -1
@@ 51,8 51,11 @@ monomorphize (Checked.Program defs tdefs externs) = evalMono $ do
evalMono :: Mono a -> a
evalMono ma = runReader (evalStateT ma initInsts) initEnv

-- We must manually add instantiations for types that occur in generated code
-- and is not "detected" by the monomorphization pass, or the types won't be
-- defined.
initInsts :: Insts
initInsts = Insts Map.empty (Set.singleton ("Str", []))
initInsts = Insts Map.empty (Set.fromList [("Str", []), tUnit, ("Bool", [])])

initEnv :: Env
initEnv = Env { _envDefs = Map.empty, _tvBinds = Map.empty }

M src/Parse.hs => src/Parse.hs +2 -15
@@ 178,11 178,9 @@ def' schemeParser topPos = varDef <|> funDef
        pure (name, (WithPos topPos (scm, f)))

expr :: Parser Expr
expr = withPos $ choice [eunit, estr, ebool, var, num, eConstructor, pexpr]
expr = withPos $ choice [estr, var, num, eConstructor, pexpr]
  where
    eunit = unit $> Lit Unit
    estr = fmap (Lit . Str) strlit
    ebool = fmap (Lit . Bool) bool
    eConstructor = fmap Ctor big'
    var = fmap Var small'
    pexpr =


@@ 227,12 225,6 @@ ns_num = do
            a
    pure (Lit e)

unit :: Parser ()
unit = reserved "unit" $> ()

bool :: Parser Bool
bool = (reserved "true" $> True) <|> (reserved "false" $> False)

strlit :: Parser String
strlit = andSkipSpaceAfter ns_strlit



@@ 240,12 232,10 @@ ns_strlit :: Parser String
ns_strlit = char '"' >> manyTill Lexer.charLiteral (char '"')

pat :: Parser Pat
pat = choice [patInt, patUnit, patBool, patStr, patCtor, patVar, ppat]
pat = choice [patInt, patStr, patCtor, patVar, ppat]
  where
    patInt = liftA2 PInt getSrcPos int
    int = andSkipSpaceAfter (Lexer.signed empty Lexer.decimal)
    patUnit = fmap PUnit getSrcPos <* unit
    patBool = liftA2 PBool getSrcPos bool
    patStr = liftA2 PStr getSrcPos strlit
    patCtor = fmap (\x -> PConstruction (getPos x) x []) big'
    patVar = fmap PVar small'


@@ 273,7 263,6 @@ nonptype = choice
    tprim = try $ do
        s <- big
        case s of
            "Unit" -> pure TUnit
            "Nat8" -> pure TNat8
            "Nat16" -> pure TNat16
            "Nat32" -> pure TNat32


@@ 283,7 272,6 @@ nonptype = choice
            "Int32" -> pure TInt32
            "Int" -> pure TInt
            "Double" -> pure TDouble
            "Bool" -> pure TBool
            _ -> fail $ "Undefined type constant " ++ s

ptype :: Parser Type


@@ 370,7 358,6 @@ reserveds =
    , "define:"
    , "extern"
    , "forall"
    , "unit"
    , "true"
    , "false"
    , "fun-match"

M src/Parsed.hs => src/Parsed.hs +7 -13
@@ 21,6 21,7 @@ module Parsed
    , Program(..)
    , isFunLike
    , mainType
    , tUnit
    )
where



@@ 43,8 44,7 @@ data TVar
    deriving (Show, Eq, Ord)

data TPrim
    = TUnit
    | TNat8
    = TNat8
    | TNat16
    | TNat32
    | TNat


@@ 53,7 53,6 @@ data TPrim
    | TInt32
    | TInt
    | TDouble
    | TBool
    deriving (Show, Eq, Ord)

type TConst = (String, [Type])


@@ 75,19 74,15 @@ data Scheme = Forall SrcPos (Set TVar) Type
data Pat
    = PConstruction SrcPos (Id 'Big) [Pat]
    | PInt SrcPos Int
    | PUnit SrcPos
    | PBool SrcPos Bool
    | PStr SrcPos String
    | PVar (Id 'Small)
    | PBox SrcPos Pat
    deriving Show

data Const
    = Unit
    | Int Int
    = Int Int
    | Double Double
    | Str String
    | Bool Bool
    deriving (Show, Eq)

data Expr'


@@ 141,8 136,6 @@ instance HasPos Pat where
    getPos = \case
        PConstruction p _ _ -> p
        PInt p _ -> p
        PUnit p -> p
        PBool p _ -> p
        PStr p _ -> p
        PVar v -> getPos v
        PBox p _ -> p


@@ 176,8 169,6 @@ bvPat :: Pat -> Set (Id 'Small)
bvPat = \case
    PConstruction _ _ ps -> Set.unions (map bvPat ps)
    PInt _ _ -> Set.empty
    PUnit _ -> Set.empty
    PBool _ _ -> Set.empty
    PStr _ _ -> Set.empty
    PVar x -> Set.singleton x
    PBox _ p -> bvPat p


@@ 186,7 177,10 @@ idstr :: Id a -> String
idstr (Id (WithPos _ x)) = x

mainType :: Type
mainType = TFun (TPrim TUnit) (TPrim TUnit)
mainType = TFun (TConst tUnit) (TConst tUnit)

tUnit :: (String, [a])
tUnit = ("Unit", [])

isFunLike :: Expr -> Bool
isFunLike (WithPos _ e) = case e of

M src/Pretty.hs => src/Pretty.hs +0 -6
@@ 158,19 158,15 @@ prettyPat = \case
    Parsed.PConstruction _ (Parsed.Id (WithPos _ c)) ps ->
        if null ps then c else concat ["(", c, " ", spcPretty ps, ")"]
    Parsed.PInt _ n -> show n
    Parsed.PUnit _ -> "unit"
    Parsed.PBool _ b -> if b then "true" else "false"
    Parsed.PStr _ s -> prettyStr s
    Parsed.PVar v -> Parsed.idstr v
    Parsed.PBox _ p -> "(Box " ++ prettyPat p ++ ")"

prettyConst :: Parsed.Const -> String
prettyConst = \case
    Parsed.Unit -> "unit"
    Parsed.Int n -> show n
    Parsed.Double x -> show x
    Parsed.Str s -> prettyStr s
    Parsed.Bool b -> if b then "true" else "false"

prettyStr :: String -> String
prettyStr s = '"' : (s >>= showChar) ++ "\""


@@ 219,7 215,6 @@ prettyTFun a b =

prettyTPrim :: Parsed.TPrim -> String
prettyTPrim = \case
    Parsed.TUnit -> "Unit"
    Parsed.TNat8 -> "Nat8"
    Parsed.TNat16 -> "Nat16"
    Parsed.TNat32 -> "Nat32"


@@ 229,7 224,6 @@ prettyTPrim = \case
    Parsed.TInt32 -> "Int32"
    Parsed.TInt -> "Int"
    Parsed.TDouble -> "Double"
    Parsed.TBool -> "Bool"

prettyTVar :: Parsed.TVar -> String
prettyTVar = \case

M std/std.carth => std/std.carth +5 -5
@@ 7,7 7,7 @@

(extern -panic (Fun Str Unit))
(define (panic msg)
  (seq (-panic msg) (undefined unit)))
  (seq (-panic msg) (undefined Unit)))

(type (Maybe a)
  None


@@ 21,7 21,7 @@
  (Lazy (Fun Unit a)))

(define lively
  (fun-match (case (Lazy f) (f unit))))
  (fun-match (case (Lazy f) (f Unit))))

;;; Math



@@ 57,9 57,9 @@
  (or (> a b) (= a b)))

(define (and p q)
  (if p q false))
  (if p q False))
(define (or p q)
  (if p true q))
  (if p True q))

(define (divisible? n m)
  (= (rem n m) 0))


@@ 102,7 102,7 @@

(define (for xs f)
  (match (next xs)
    (case None unit)
    (case None Unit)
    (case (Some (Pair x xs'))
          (seq (f x) (for xs' f)))))