~jojo/Carth

6900fcb2aefc605f806fd3652aede2f926d0ffd9 — JoJo 1 year, 3 months ago 07ee889
Define carth type literals only once in TypeAst

Like mainType, tUnit, etc. Use the class TypeAst to allow them to
construct any Type, e.g. Parsed.Type.
M carth.cabal => carth.cabal +1 -0
@@ 45,6 45,7 @@ library
      SrcPos
      Subst
      Err
      TypeAst
  other-modules:
  hs-source-dirs:
      src

M src/Check.hs => src/Check.hs +3 -2
@@ 19,11 19,12 @@ import Misc
import SrcPos
import Subst
import qualified Parsed
import Parsed (Id(..), TVar(..), TPrim(..), idstr)
import Parsed (Id(..), TVar(..), idstr)
import Err
import qualified Inferred
import Match
import Infer
import TypeAst
import qualified Checked
import Checked (withPos, noPos)



@@ 106,7 107,7 @@ builtinDataTypes' =
          )
        ]
      )
    , ("Str", [], [("Str", [Inferred.TConst ("Array", [Inferred.TPrim (TNat 8)])])])
    , ("Str", [], [("Str", [tArray (Inferred.TPrim (TNat 8))])])
    , ( "Pair"
      , [TVImplicit 0, TVImplicit 1]
      , [("Pair", [Inferred.TVar (TVImplicit 0), Inferred.TVar (TVImplicit 1)])]

M src/Checked.hs => src/Checked.hs +1 -2
@@ 20,9 20,9 @@ import Data.Bifunctor

import Misc
import SrcPos
import TypeAst hiding (TConst)
import Inferred
    ( TVar(..)
    , TPrim(..)
    , TConst
    , Type(..)
    , Scheme(..)


@@ 30,7 30,6 @@ import Inferred
    , VariantIx
    , Span
    , Con(..)
    , mainType
    )
import qualified Inferred


M src/Codegen.hs => src/Codegen.hs +2 -1
@@ 35,6 35,7 @@ import SrcPos
import FreeVars
import qualified Monomorphic as M
import Monomorphic hiding (Type, Const)
import TypeAst
import Selections
import Gen
import Extern


@@ 217,7 218,7 @@ genInit :: FilePath -> [VarDef] -> Gen' [Definition]
genInit moduleFp ds = do
    let name = mkName "carth_init"
    let pos = SrcPos moduleFp 1 1
    let param = TypedVar "_" (TConst tUnit)
    let param = TypedVar "_" tUnit
    let genDefs =
            forM_ ds genDefineGlobVar *> commitFinalFuncBlock retVoid $> LLType.void
    fmap (uncurry ((:) . GlobalDefinition)) $ genFunDef (name, [], pos, param, genDefs)

M src/Err.hs => src/Err.hs +2 -1
@@ 4,6 4,7 @@ module Err (module Err, TypeErr(..), GenErr(..)) where

import Misc
import SrcPos
import TypeAst
import qualified Parsed
import Inferred
import Pretty


@@ 66,7 67,7 @@ printTypeErr = \case
    WrongMainType p s ->
        posd p
            $ "Incorrect type of `main`.\n"
            ++ ("Expected: " ++ pretty mainType)
            ++ ("Expected: " ++ pretty (mainType :: Type))
            ++ ("\nFound: " ++ pretty s)
    RecursiveVarDef (WithPos p x) ->
        posd p $ ("Non-function variable definition `" ++ x ++ "` is recursive.")

M src/Gen.hs => src/Gen.hs +3 -2
@@ 44,6 44,7 @@ import qualified LLSubprog

import Misc
import Pretty
import qualified TypeAst
import qualified Monomorphic as M
import Monomorphic (TypedVar(..), TPrim(..))
import qualified Monomorphize


@@ 1199,7 1200,7 @@ litUnit :: Operand
litUnit = ConstantOperand (litStruct [])

typeStr :: Type
typeStr = NamedTypeReference (mkName (mangleTConst ("Str", [])))
typeStr = NamedTypeReference (mkName (mangleTConst TypeAst.tStr'))

typeBool :: Type
typeBool = i8


@@ 1242,7 1243,7 @@ mangleType :: M.Type -> String
mangleType = \case
    M.TPrim c -> pretty c
    M.TFun p r -> mangleTConst ("Fun", [p, r])
    M.TBox t -> mangleTConst ("Box", [t])
    M.TBox t -> mangleTConst (TypeAst.tBox' t)
    M.TConst tc -> mangleTConst tc

mangleTConst :: M.TConst -> String

M src/Infer.hs => src/Infer.hs +3 -2
@@ 25,6 25,7 @@ import qualified Parsed
import Parsed (Id(..), IdCase(..), idstr)
import Err
import Inferred hiding (Id)
import TypeAst hiding (TConst)


newtype ExpectedType = Expected Type


@@ 165,8 166,8 @@ inferRecDefs :: [Parsed.Def] -> Infer RecDefs
checkScheme :: String -> Maybe Parsed.Scheme -> Infer (Maybe Scheme)
checkScheme = curry $ \case
    ("main", Nothing) -> pure (Just (Forall Set.empty mainType))
    ("main", Just s@(Parsed.Forall pos vs t))
        | Set.size vs /= 0 || t /= Parsed.mainType -> throwError (WrongMainType pos s)
    ("main", Just s@(Parsed.Forall pos vs t)) | Set.size vs /= 0 || t /= mainType ->
        throwError (WrongMainType pos s)
    (_, Nothing) -> pure Nothing
    (_, Just (Parsed.Forall pos vs t)) -> do
        t' <- checkType pos t

M src/Inferred.hs => src/Inferred.hs +13 -11
@@ 12,8 12,10 @@ import Lens.Micro.Platform (makeLenses)

import Misc
import qualified Parsed
import Parsed (TVar(..), TPrim(..), Const(..), tUnit)
import Parsed (TVar(..), Const(..))
import SrcPos
import TypeAst hiding (TConst)
import qualified TypeAst


data TypeErr


@@ 40,7 42,7 @@ data TypeErr
    | ConflictingVarDef SrcPos String
    deriving Show

type TConst = (String, [Type])
type TConst = TypeAst.TConst Type

data Type
    = TVar TVar


@@ 114,6 116,12 @@ instance Eq Con where
instance Ord Con where
    compare (Con c1 _ _) (Con c2 _ _) = compare c1 c2

instance TypeAst Type where
    tprim = TPrim
    tconst = TConst
    tfun = TFun
    tbox = TBox


ftv :: Type -> Set TVar
ftv = \case


@@ 126,7 134,7 @@ ftv = \case
builtinExterns :: Map String (Type, SrcPos)
builtinExterns = Map.fromList $ map
    (second (, SrcPos "<builtin>" 0 0))
    [("GC_malloc", TFun (TPrim TIntSize) (TBox (TConst tUnit)))]
    [("GC_malloc", tfun (TPrim TIntSize) (TBox tUnit))]

builtinVirtuals :: Map String Scheme
builtinVirtuals =


@@ 135,9 143,9 @@ builtinVirtuals =
        ta = TVar tva
        tvb = tv "b"
        tb = TVar tvb
        arithScm = Forall (Set.fromList [tva]) (TFun ta (TFun ta ta))
        arithScm = Forall (Set.fromList [tva]) (tfun ta (tfun ta ta))
        bitwiseScm = arithScm
        relScm = Forall (Set.fromList [tva]) (TFun ta (TFun ta tBool))
        relScm = Forall (Set.fromList [tva]) (tfun ta (tfun ta tBool))
    in  Map.fromList
            $ [ ("+", arithScm)
              , ("-", arithScm)


@@ 179,9 187,3 @@ defToVarDefs :: Def -> [(String, WithPos (Scheme, Expr))]
defToVarDefs = \case
    VarDef d -> [d]
    RecDefs ds -> map (second (mapPosd (second (mapPosd FunMatch)))) ds

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

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

M src/Monomorphic.hs => src/Monomorphic.hs +10 -5
@@ 15,9 15,11 @@ import Misc
import SrcPos
import Checked (VariantIx, Span)
import FreeVars
import Parsed (Const(..), TPrim(..), tUnit)
import Parsed (Const(..))
import TypeAst hiding (TConst)
import qualified TypeAst

type TConst = (String, [Type])
type TConst = TypeAst.TConst Type

data Type
    = TPrim TPrim


@@ 77,6 79,12 @@ data Program = Program Defs Datas Externs
    deriving (Show)


instance TypeAst Type where
    tprim = TPrim
    tconst = TConst
    tfun = TFun
    tbox = TBox

instance FreeVars Expr TypedVar where
    freeVars (Expr _ e) = fvExpr' e



@@ 117,6 125,3 @@ funDefFromVarDef :: VarDef -> (TypedVar, WithPos ([Type], Fun))
funDefFromVarDef = second $ mapPosd $ second $ \case
    Fun f -> f
    e -> ice $ "funDefFromVarDef on non-positioned function " ++ show e

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

M src/Monomorphize.hs => src/Monomorphize.hs +2 -1
@@ 21,6 21,7 @@ import SrcPos
import qualified Checked
import Checked (noPos, TVar(..), Scheme(..))
import Monomorphic
import TypeAst hiding (TConst)

type Env = Map TVar Type



@@ 79,7 80,7 @@ monomorphize (Checked.Program (Topo defs) datas externs) =

    -- 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.
    builtinDataInsts = [("Str", []), tUnit, ("Bool", [])]
    builtinDataInsts = [tStr', tUnit', tBool']

builtinExterns :: Map String Type
builtinExterns = fst $ evalMono (mapM monotype Checked.builtinExterns)

M src/Parsed.hs => src/Parsed.hs +9 -22
@@ 1,16 1,16 @@
{-# LANGUAGE LambdaCase, TypeSynonymInstances, FlexibleInstances
           , MultiParamTypeClasses, KindSignatures, DataKinds #-}

module Parsed where
module Parsed (module Parsed, TPrim(..), TConst) where

import qualified Data.Set as Set
import Data.Set (Set)
import Data.Bifunctor
import Control.Arrow ((>>>))
import Data.Word

import SrcPos
import FreeVars
import TypeAst


data IdCase = Big | Small


@@ 23,26 23,13 @@ data TVar
    | TVImplicit Int
    deriving (Show, Eq, Ord)

data TPrim
    = TNat Word32
    | TNatSize
    | TInt Word32
    | TIntSize
    | TF16
    | TF32
    | TF64
    | TF128
    deriving (Show, Eq, Ord)

type TConst = (String, [Type])

-- TODO: Now that AnnotAst.Type is not just an alias to Ast.Type, it makes sense
--       to add SrcPos-itions to Ast.Type! Would simplify / improve error
--       messages quite a bit.
data Type
    = TVar TVar
    | TPrim TPrim
    | TConst TConst
    | TConst (TConst Type)
    | TFun Type Type
    | TBox Type
    deriving (Show, Eq, Ord)


@@ 95,6 82,12 @@ data Program = Program [Def] [TypeDef] [Extern]
    deriving (Show, Eq)


instance TypeAst Type where
    tprim = TPrim
    tconst = TConst
    tfun = TFun
    tbox = TBox

instance Eq Pat where
    (==) = curry $ \case
        (PConstruction _ x ps, PConstruction _ x' ps') -> x == x' && ps == ps'


@@ 150,9 143,3 @@ bvPat = \case

idstr :: Id a -> String
idstr (Id (WithPos _ x)) = x

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

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

A src/TypeAst.hs => src/TypeAst.hs +52 -0
@@ 0,0 1,52 @@
-- | This module mostly exists to expost the builtin types via convenient variables,
--   instead of requiring redefinitions or manually typing the strings of TConst's, which
--   would be prone to typo errors.
module TypeAst where

import Data.Word

data TPrim
    = TNat Word32
    | TNatSize
    | TInt Word32
    | TIntSize
    | TF16
    | TF32
    | TF64
    | TF128
    deriving (Show, Eq, Ord)

type TConst t = (String, [t])

class TypeAst t where
    tprim :: TPrim -> t
    tconst :: TConst t -> t
    tfun :: t -> t -> t
    tbox :: t -> t

mainType :: TypeAst t => t
mainType = tfun tUnit tUnit

tBox' :: t -> TConst t
tBox' t = ("Box", [t])

tStr :: TypeAst t => t
tStr = tconst tStr'

tStr' :: TConst t
tStr' = ("Str", [])

tArray :: TypeAst t => t -> t
tArray a = tconst ("Array", [a])

tUnit :: TypeAst t => t
tUnit = tconst tUnit'

tUnit' :: TConst t
tUnit' = ("Unit", [])

tBool :: TypeAst t => t
tBool = tconst ("Bool", [])

tBool' :: TConst t
tBool' = ("Bool", [])