Add support for "number" type which can be either an Int or Float
This commit is contained in:
parent
666d9f8ca3
commit
82ca695dca
4 changed files with 54 additions and 8 deletions
|
@ -53,12 +53,21 @@ makeConstructors types = Map.fromList builtins
|
|||
where
|
||||
list t = (types ! "_List") <| t
|
||||
maybe t = (types ! "Maybe") <| t
|
||||
bool = types ! "Bool"
|
||||
int = types ! "Int"
|
||||
float = types ! "Float"
|
||||
|
||||
inst :: Int -> Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
|
||||
inst kind numTVars tipe = do
|
||||
vars <- forM [1..numTVars] $ \_ -> flexibleVar
|
||||
let (args, result) = tipe (map VarN vars)
|
||||
return (kind, vars, args, result)
|
||||
vars <- forM [1..numTVars] $ \_ -> flexibleVar
|
||||
let (args, result) = tipe (map VarN vars)
|
||||
return (kind, vars, args, result)
|
||||
|
||||
nmbr :: Int -> (Type -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
|
||||
nmbr kind tipe = do
|
||||
var <- number
|
||||
let (args, result) = tipe (VarN var)
|
||||
return (kind, [var], args, result)
|
||||
|
||||
tupleCtor n =
|
||||
let name = "_Tuple" ++ show n
|
||||
|
@ -69,6 +78,12 @@ makeConstructors types = Map.fromList builtins
|
|||
, ("Just" , inst 1 1 $ \ [t] -> ([t], maybe t))
|
||||
, ("[]" , inst 0 1 $ \ [t] -> ([], list t))
|
||||
, ("::" , inst 2 1 $ \ [t] -> ([t, list t], list t))
|
||||
, ("div" , inst 2 0 $ \ [] -> ([int, int], int))
|
||||
, ("/" , inst 2 0 $ \ [] -> ([float, float], float))
|
||||
, ("+" , nmbr 2 $ \t -> ([t, t], t))
|
||||
, ("-" , nmbr 2 $ \t -> ([t, t], t))
|
||||
, ("*" , nmbr 2 $ \t -> ([t, t], t))
|
||||
, ("otherwise", inst 0 0 $ \ [] -> ([], bool))
|
||||
] ++ map tupleCtor [0..9]
|
||||
|
||||
|
||||
|
|
|
@ -138,7 +138,9 @@ makeCopy alreadyCopied variable = do
|
|||
structure = Nothing,
|
||||
rank = maxRank pool,
|
||||
mark = noMark,
|
||||
flex = Flexible,
|
||||
flex = case flex desc of
|
||||
IsIn s -> IsIn s
|
||||
_ -> Flexible,
|
||||
copy = Nothing,
|
||||
name = case flex desc of
|
||||
Rigid -> Nothing
|
||||
|
|
|
@ -69,7 +69,10 @@ outermostRank = 0 :: Int
|
|||
noMark = 0
|
||||
initialMark = 1
|
||||
|
||||
data Flex = Rigid | Flexible | Constant
|
||||
data Flex = Rigid | Flexible | Constant | IsIn SuperType
|
||||
deriving (Show, Eq)
|
||||
|
||||
data SuperType = Number | Comparable | Appendable
|
||||
deriving (Show, Eq)
|
||||
|
||||
infixl 8 /\
|
||||
|
@ -91,6 +94,7 @@ a ==> b = TermN (Fun1 a b)
|
|||
|
||||
f <| a = TermN (App1 f a)
|
||||
|
||||
number = namedVar (IsIn Number) "number"
|
||||
|
||||
namedVar flex name = UF.fresh $ Descriptor {
|
||||
structure = Nothing,
|
||||
|
|
|
@ -70,6 +70,30 @@ actuallyUnify variable1 variable2 = do
|
|||
}
|
||||
TS.register var
|
||||
|
||||
flexAndUnify var = do
|
||||
liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }
|
||||
unify variable1 variable2
|
||||
|
||||
superUnify =
|
||||
case (flex desc1, flex desc2, name desc1, name desc2) of
|
||||
(IsIn Number, IsIn Number, _, _) -> merge
|
||||
(IsIn Number, IsIn Comparable, _, _) -> merge1
|
||||
(IsIn Comparable, IsIn Number, _, _) -> merge2
|
||||
|
||||
(IsIn Number, _, _, Just name)
|
||||
| name == "Int" || name == "Float" -> flexAndUnify variable1
|
||||
|
||||
(_, IsIn Number, Just name, _)
|
||||
| name == "Int" || name == "Float" -> flexAndUnify variable2
|
||||
|
||||
(IsIn Comparable, _, _, Just name)
|
||||
| name == "Int" || name == "Float" -> flexAndUnify variable1
|
||||
|
||||
(_, IsIn Comparable, Just name, _)
|
||||
| name == "Int" || name == "Float" -> flexAndUnify variable2
|
||||
|
||||
_ -> TS.addError "The following types are not equal" variable1 variable2
|
||||
|
||||
case (structure desc1, structure desc2) of
|
||||
(Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
|
||||
(Nothing, _) | flex desc1 == Flexible -> merge2
|
||||
|
@ -78,8 +102,8 @@ actuallyUnify variable1 variable2 = do
|
|||
(Just (Var1 v), _) -> unify v variable2
|
||||
(_, Just (Var1 v)) -> unify v variable1
|
||||
|
||||
(Nothing, _) -> TS.addError "The following types are not equal" variable1 variable2
|
||||
(_, Nothing) -> TS.addError "The following types are not equal" variable1 variable2
|
||||
(Nothing, _) -> superUnify
|
||||
(_, Nothing) -> superUnify
|
||||
|
||||
(Just type1, Just type2) ->
|
||||
case (type1,type2) of
|
||||
|
@ -99,3 +123,4 @@ actuallyUnify variable1 variable2 = do
|
|||
TS.addError "did not write record unification yet" variable1 variable2
|
||||
|
||||
_ -> TS.addError "could not unify types" variable1 variable2
|
||||
|
||||
|
|
Loading…
Reference in a new issue