mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
Adds -c|--emitcname flag to headerparse to always emit the C identifier in `register` definitions (useful when the register will be in a module). Fixes a bug where the kebab case flag would not output C identifiers making the emitted C identifiers not match with the ones in the headers. Adds docs entry about headerparse in CInterop doc. Makes headerparse emit `CChar` instead of `Char` when encountering a signature containing `char`.
382 lines
14 KiB
Haskell
382 lines
14 KiB
Haskell
{-# LANGUAGE DeriveGeneric #-}
|
|
|
|
module Types
|
|
( TypeMappings,
|
|
Ty (..),
|
|
showMaybeTy,
|
|
unifySignatures,
|
|
replaceTyVars,
|
|
areUnifiable,
|
|
typesDeleterFunctionType,
|
|
typesCopyFunctionType,
|
|
doesTypeContainTyVarWithName,
|
|
replaceConflicted,
|
|
lambdaEnvTy,
|
|
typeEqIgnoreLifetimes,
|
|
checkKinds,
|
|
-- SymPath imports
|
|
SymPath (..),
|
|
mangle,
|
|
pathToC,
|
|
consPath,
|
|
Kind,
|
|
tyToKind,
|
|
areKindsConsistent,
|
|
createStructName,
|
|
getStructName,
|
|
getPathFromStructName,
|
|
getNameFromStructName,
|
|
getStructPath,
|
|
promoteNumber,
|
|
)
|
|
where
|
|
|
|
import Data.Hashable
|
|
import Data.List (intercalate)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (pack, splitOn, unpack)
|
|
import GHC.Generics (Generic)
|
|
import qualified Map
|
|
import SymPath
|
|
import Util
|
|
|
|
--import Debug.Trace
|
|
|
|
-- | Carp types.
|
|
data Ty
|
|
= IntTy
|
|
| LongTy
|
|
| ByteTy
|
|
| BoolTy
|
|
| FloatTy
|
|
| DoubleTy
|
|
| StringTy
|
|
| PatternTy
|
|
| CharTy
|
|
| CCharTy
|
|
| FuncTy [Ty] Ty Ty -- In order of appearance: (1) Argument types, (2) Return type, (3) Lifetime
|
|
| VarTy String
|
|
| UnitTy
|
|
| ModuleTy
|
|
| PointerTy Ty
|
|
| RefTy Ty Ty -- second Ty is the lifetime
|
|
| StaticLifetimeTy
|
|
| StructTy Ty [Ty] -- the name (possibly a var) of the struct, and it's type parameters
|
|
| ConcreteNameTy SymPath -- the name of a struct
|
|
| TypeTy -- the type of types
|
|
| MacroTy
|
|
| DynamicTy -- the type of dynamic functions (used in REPL and macros)
|
|
| InterfaceTy
|
|
| CTy -- C literals
|
|
| Universe -- the type of types of types (the type of TypeTy)
|
|
deriving (Eq, Ord, Generic)
|
|
|
|
instance Hashable Ty
|
|
|
|
-- | Kinds checking
|
|
-- Carp's system is simple enough that we do not need to describe kinds by their airty.
|
|
-- After confirming two tys have either base or higher kind
|
|
-- unification checks are sufficient to determine whether their arities are compatible.
|
|
data Kind
|
|
= Base
|
|
| Higher
|
|
deriving (Eq, Ord, Show)
|
|
|
|
tyToKind :: Ty -> Kind
|
|
tyToKind (StructTy _ _) = Higher
|
|
tyToKind FuncTy {} = Higher -- the type of functions, consider the (->) constructor in Haskell
|
|
tyToKind (PointerTy _) = Higher
|
|
tyToKind (RefTy _ _) = Higher -- Refs may also be treated as a data constructor
|
|
tyToKind _ = Base
|
|
|
|
-- | Check whether or not the kinds of type variables are consistent.
|
|
-- This function will return Left as soon as a variable is used inconsistently,
|
|
-- reporting which variable triggered the issue.
|
|
-- If all variables are used consistently, it will process the whole list and
|
|
-- return ().
|
|
--
|
|
-- Kind arity matters; that is, `(f a b)` is not consistent with
|
|
-- `(f b)`. So long as the kind of a variable is the same across its uses,
|
|
-- everything is OK, for example:
|
|
-- ((Foo f a b) [x (f a) y (f b)])
|
|
-- is valid, and so is
|
|
-- ((Foo f a b) [x f y a z b])
|
|
-- But a definition such as:
|
|
-- ((Foo f a b) [x (f a b) y (f a)])
|
|
-- is inconsistent (kind of `f` differs) and so is
|
|
-- ((Foo f a b) [x (f a) y b (b a)])
|
|
-- (kind of `b` is inconsistent.
|
|
areKindsConsistent :: [Ty] -> Either String ()
|
|
areKindsConsistent typeVars =
|
|
assignKinds typeVars Map.empty
|
|
where
|
|
assignKinds :: [Ty] -> Map.Map String Int -> Either String ()
|
|
assignKinds ((StructTy (VarTy name) vars) : rest) arityMap =
|
|
case Map.lookup name arityMap of
|
|
Nothing -> assignKinds next (Map.insert name kind arityMap)
|
|
Just k ->
|
|
if k == kind
|
|
then assignKinds next arityMap
|
|
else Left name
|
|
where
|
|
next = vars ++ rest
|
|
kind = length vars
|
|
assignKinds ((VarTy v) : rest) arityMap =
|
|
case Map.lookup v arityMap of
|
|
Nothing -> assignKinds rest (Map.insert v kind arityMap)
|
|
Just k ->
|
|
if k == kind
|
|
then assignKinds rest arityMap
|
|
else Left v
|
|
where
|
|
kind = 0
|
|
assignKinds (FuncTy args ret _ : rest) arityMap =
|
|
assignKinds (args ++ ret : rest) arityMap
|
|
assignKinds ((PointerTy p) : rest) arityMap =
|
|
assignKinds (p : rest) arityMap
|
|
assignKinds ((RefTy r _) : rest) arityMap =
|
|
assignKinds (r : rest) arityMap
|
|
assignKinds (_ : rest) arityMap = assignKinds rest arityMap
|
|
assignKinds [] _ = pure ()
|
|
|
|
-- Exactly like '==' for Ty, but ignore lifetime parameter
|
|
typeEqIgnoreLifetimes :: Ty -> Ty -> Bool
|
|
typeEqIgnoreLifetimes (RefTy a _) (RefTy b _) = a == b
|
|
typeEqIgnoreLifetimes (FuncTy argsA retA _) (FuncTy argsB retB _) =
|
|
all (== True) (zipWith typeEqIgnoreLifetimes argsA argsB)
|
|
&& typeEqIgnoreLifetimes retA retB
|
|
typeEqIgnoreLifetimes (StructTy a tyVarsA) (StructTy b tyVarsB) =
|
|
a == b
|
|
&& all (== True) (zipWith typeEqIgnoreLifetimes tyVarsA tyVarsB)
|
|
typeEqIgnoreLifetimes a b = a == b
|
|
|
|
data SumTyCase = SumTyCase
|
|
{ caseName :: String,
|
|
caseMembers :: [(String, Ty)]
|
|
}
|
|
deriving (Show, Ord, Eq)
|
|
|
|
fnOrLambda :: String
|
|
fnOrLambda =
|
|
case platform of
|
|
Windows -> "Fn"
|
|
_ -> "Fn" -- "λ"
|
|
|
|
instance Show Ty where
|
|
show IntTy = "Int"
|
|
show FloatTy = "Float"
|
|
show DoubleTy = "Double"
|
|
show LongTy = "Long"
|
|
show ByteTy = "Byte"
|
|
show BoolTy = "Bool"
|
|
show StringTy = "String"
|
|
show PatternTy = "Pattern"
|
|
show CharTy = "Char"
|
|
show CCharTy = "CChar"
|
|
show (FuncTy argTys retTy StaticLifetimeTy) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ ")"
|
|
show (FuncTy argTys retTy lt) = "(" ++ fnOrLambda ++ " [" ++ joinWithComma (map show argTys) ++ "] " ++ show retTy ++ " " ++ show lt ++ ")"
|
|
show (VarTy t) = t
|
|
show UnitTy = "()"
|
|
show ModuleTy = "Module"
|
|
show TypeTy = "Type"
|
|
show InterfaceTy = "Interface"
|
|
show (StructTy s []) = show s
|
|
show (StructTy s typeArgs) = "(" ++ show s ++ " " ++ joinWithSpace (map show typeArgs) ++ ")"
|
|
show (ConcreteNameTy spath) = show spath
|
|
show (PointerTy p) = "(Ptr " ++ show p ++ ")"
|
|
show (RefTy r lt) =
|
|
-- case r of
|
|
-- PointerTy _ -> listView
|
|
-- StructTy _ _ -> listView
|
|
-- FuncTy _ _ -> listView
|
|
-- _ -> "&" ++ show r
|
|
-- where listView = "(Ref " ++ show r ++ ")"
|
|
"(Ref " ++ show r ++ " " ++ show lt ++ ")"
|
|
show StaticLifetimeTy = "StaticLifetime"
|
|
show MacroTy = "Macro"
|
|
show DynamicTy = "Dynamic"
|
|
show Universe = "Universe"
|
|
show CTy = "C"
|
|
|
|
showMaybeTy :: Maybe Ty -> String
|
|
showMaybeTy (Just t) = show t
|
|
showMaybeTy Nothing = "(missing-type)"
|
|
|
|
doesTypeContainTyVarWithName :: String -> Ty -> Bool
|
|
doesTypeContainTyVarWithName name (VarTy n) = name == n
|
|
doesTypeContainTyVarWithName name (FuncTy argTys retTy lt) =
|
|
doesTypeContainTyVarWithName name lt
|
|
|| any (doesTypeContainTyVarWithName name) argTys
|
|
|| doesTypeContainTyVarWithName name retTy
|
|
doesTypeContainTyVarWithName name (StructTy n tyArgs) = doesTypeContainTyVarWithName name n || any (doesTypeContainTyVarWithName name) tyArgs
|
|
doesTypeContainTyVarWithName name (PointerTy p) = doesTypeContainTyVarWithName name p
|
|
doesTypeContainTyVarWithName name (RefTy r lt) =
|
|
doesTypeContainTyVarWithName name r
|
|
|| doesTypeContainTyVarWithName name lt
|
|
doesTypeContainTyVarWithName _ _ = False
|
|
|
|
replaceConflicted :: String -> Ty -> Ty
|
|
replaceConflicted name (VarTy n) =
|
|
if n == name
|
|
then VarTy (n ++ "conflicted")
|
|
else VarTy n
|
|
replaceConflicted name (FuncTy argTys retTy lt) =
|
|
FuncTy
|
|
(map (replaceConflicted name) argTys)
|
|
(replaceConflicted name retTy)
|
|
(replaceConflicted name lt)
|
|
replaceConflicted name (StructTy n tyArgs) = StructTy (replaceConflicted name n) (map (replaceConflicted name) tyArgs)
|
|
replaceConflicted name (PointerTy p) = PointerTy (replaceConflicted name p)
|
|
replaceConflicted name (RefTy r lt) =
|
|
RefTy
|
|
(replaceConflicted name r)
|
|
(replaceConflicted name lt)
|
|
replaceConflicted _ t = t
|
|
|
|
-- | Map type variable names to actual types, eg. t0 => Int, t1 => Float
|
|
type TypeMappings = Map.Map String Ty
|
|
|
|
-- | From two types, one with type variables and one without (e.g. (Fn ["t0"] "t1") and (Fn [Int] Bool))
|
|
-- create mappings that translate from the type variables to concrete types, e.g. "t0" => Int, "t1" => Bool
|
|
unifySignatures :: Ty -> Ty -> TypeMappings
|
|
unifySignatures at ct = Map.fromList (unify at ct)
|
|
where
|
|
unify :: Ty -> Ty -> [(String, Ty)]
|
|
unify (VarTy _) (VarTy _) = [] -- if a == b then [] else error ("Can't unify " ++ show a ++ " with " ++ show b)
|
|
unify (VarTy a) value = [(a, value)]
|
|
unify (StructTy v'@(VarTy _) aArgs) (StructTy n bArgs) = unify v' n ++ concat (zipWith unify aArgs bArgs)
|
|
unify (StructTy a@(ConcreteNameTy _) aArgs) (StructTy b bArgs)
|
|
| a == b = concat (zipWith unify aArgs bArgs)
|
|
| otherwise = [] -- error ("Can't unify " ++ a ++ " with " ++ b)
|
|
unify (StructTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
|
|
unify (PointerTy a) (PointerTy b) = unify a b
|
|
unify (PointerTy _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
|
|
unify (RefTy a ltA) (RefTy b ltB) = unify a b ++ unify ltA ltB
|
|
unify (RefTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
|
|
unify (FuncTy argTysA retTyA ltA) (FuncTy argTysB retTyB ltB) =
|
|
let argToks = concat (zipWith unify argTysA argTysB)
|
|
retToks = unify retTyA retTyB
|
|
ltToks = unify ltA ltB
|
|
in ltToks ++ argToks ++ retToks
|
|
unify FuncTy {} _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
|
|
unify a b
|
|
| a == b = []
|
|
| otherwise = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b)
|
|
|
|
-- | Checks if two types will unify
|
|
areUnifiable :: Ty -> Ty -> Bool
|
|
areUnifiable (VarTy _) (VarTy _) = True
|
|
areUnifiable (VarTy _) _ = True
|
|
areUnifiable _ (VarTy _) = True
|
|
areUnifiable (StructTy a aArgs) (StructTy b bArgs)
|
|
| length aArgs /= length bArgs = False
|
|
| areUnifiable a b =
|
|
let argBools = zipWith areUnifiable aArgs bArgs
|
|
in all (== True) argBools
|
|
| otherwise = False
|
|
areUnifiable (StructTy (VarTy _) aArgs) (FuncTy bArgs _ _)
|
|
| length aArgs /= length bArgs = False
|
|
| otherwise = all (== True) (zipWith areUnifiable aArgs bArgs)
|
|
areUnifiable (StructTy (VarTy _) args) (RefTy _ _)
|
|
| length args == 2 = True
|
|
| otherwise = False
|
|
areUnifiable (StructTy _ _) _ = False
|
|
areUnifiable (PointerTy a) (PointerTy b) = areUnifiable a b
|
|
areUnifiable (PointerTy _) _ = False
|
|
areUnifiable (RefTy a ltA) (RefTy b ltB) = areUnifiable a b && areUnifiable ltA ltB
|
|
areUnifiable RefTy {} _ = False
|
|
areUnifiable (FuncTy argTysA retTyA ltA) (FuncTy argTysB retTyB ltB)
|
|
| length argTysA /= length argTysB = False
|
|
| otherwise =
|
|
let argBools = zipWith areUnifiable argTysA argTysB
|
|
retBool = areUnifiable retTyA retTyB
|
|
ltBool = areUnifiable ltA ltB
|
|
in all (== True) (ltBool : retBool : argBools)
|
|
areUnifiable FuncTy {} _ = False
|
|
areUnifiable CTy _ = True
|
|
areUnifiable _ CTy = True
|
|
areUnifiable a b
|
|
| a == b = True
|
|
| otherwise = False
|
|
|
|
-- Checks whether or not the kindedness of types match
|
|
-- Kinds are polymorphic constructors such as (f a)
|
|
-- Note that this disagrees with the notion of unifiablitity in areUnifiable
|
|
checkKinds :: Ty -> Ty -> Bool
|
|
-- Base < Higher
|
|
checkKinds (FuncTy argTysA retTyA _) (FuncTy argTysB retTyB _) =
|
|
let argKinds = zipWith checkKinds argTysA argTysB
|
|
retKinds = tyToKind retTyA <= tyToKind retTyB
|
|
in all (== True) (retKinds : argKinds)
|
|
checkKinds t t' = tyToKind t <= tyToKind t'
|
|
|
|
-- | Put concrete types into the places where there are type variables.
|
|
-- For example (Fn [a] b) => (Fn [Int] Bool)
|
|
-- NOTE: If a concrete type can't be found, the type variable will stay the same.
|
|
replaceTyVars :: TypeMappings -> Ty -> Ty
|
|
replaceTyVars mappings t =
|
|
case t of
|
|
(VarTy key) -> fromMaybe t (Map.lookup key mappings)
|
|
(FuncTy argTys retTy lt) -> FuncTy (map (replaceTyVars mappings) argTys) (replaceTyVars mappings retTy) (replaceTyVars mappings lt)
|
|
(StructTy name tyArgs) ->
|
|
case replaceTyVars mappings name of
|
|
-- special case, struct (f a b) mapped to (RefTy a lt)
|
|
-- We f in such a case to the full (Ref a lt) in constraints; we also still map
|
|
-- individual members a and b, as these need mappings since they may be
|
|
-- referred to in other places (e.g. (Fn [(f a b)] a)--without a mapping,
|
|
-- a would remain generic here.
|
|
(RefTy a lt) -> replaceTyVars mappings (RefTy a lt)
|
|
_ -> StructTy (replaceTyVars mappings name) (fmap (replaceTyVars mappings) tyArgs)
|
|
(PointerTy x) -> PointerTy (replaceTyVars mappings x)
|
|
(RefTy x lt) -> RefTy (replaceTyVars mappings x) (replaceTyVars mappings lt)
|
|
_ -> t
|
|
|
|
-- | The type of a type's copying function.
|
|
typesCopyFunctionType :: Ty -> Ty
|
|
typesCopyFunctionType memberType = FuncTy [RefTy memberType (VarTy "q")] memberType StaticLifetimeTy
|
|
|
|
-- | The type of a type's deleter function.
|
|
typesDeleterFunctionType :: Ty -> Ty
|
|
typesDeleterFunctionType memberType = FuncTy [memberType] UnitTy StaticLifetimeTy
|
|
|
|
-- | The type of environments sent to Lambdas (used in emitted C code)
|
|
lambdaEnvTy :: Ty
|
|
lambdaEnvTy = StructTy (ConcreteNameTy (SymPath [] "LambdaEnv")) []
|
|
|
|
createStructName :: [String] -> String -> String
|
|
createStructName path name = intercalate "." (path ++ [name])
|
|
|
|
getStructName :: Ty -> String
|
|
getStructName (StructTy (ConcreteNameTy spath) _) = show spath
|
|
getStructName (StructTy (VarTy name) _) = name
|
|
getStructName _ = ""
|
|
|
|
getPathFromStructName :: String -> [String]
|
|
getPathFromStructName structName =
|
|
let path = map unpack (splitOn (pack ".") (pack structName))
|
|
in if length path > 1 then init path else []
|
|
|
|
getNameFromStructName :: String -> String
|
|
getNameFromStructName structName = last (map unpack (splitOn (pack ".") (pack structName)))
|
|
|
|
getStructPath :: Ty -> SymPath
|
|
getStructPath (StructTy (ConcreteNameTy spath) _) = spath
|
|
getStructPath (StructTy (VarTy name) _) = (SymPath [] name)
|
|
getStructPath _ = (SymPath [] "")
|
|
|
|
-- N.B.: promoteNumber is only safe for numeric types!
|
|
promoteNumber :: Ty -> Ty -> Ty
|
|
promoteNumber a b | a == b = a
|
|
promoteNumber ByteTy other = other
|
|
promoteNumber other ByteTy = other
|
|
promoteNumber IntTy other = other
|
|
promoteNumber other IntTy = other
|
|
promoteNumber LongTy other = other
|
|
promoteNumber other LongTy = other
|
|
promoteNumber FloatTy other = other
|
|
promoteNumber other FloatTy = other
|
|
promoteNumber DoubleTy _ = DoubleTy
|
|
promoteNumber _ DoubleTy = DoubleTy
|
|
promoteNumber a b =
|
|
error ("promoteNumber called with non-numbers: " ++ show a ++ ", " ++ show b)
|