Commit 4cbc1614 authored by Mart Lubbers's avatar Mart Lubbers Committed by Camil Staps

Make TypeContext a newtype to resolve overlapping instances

parent e18d7492
......@@ -27,7 +27,7 @@ from Text import <+,
import Text.Language
import Text.Parsers.Simple.ParserCombinators
from Clean.Types import :: Type, :: TypeRestriction
from Clean.Types import :: Type, :: TypeRestriction, :: TypeContext
from Clean.Types.Parse import parseType
from Clean.Types.Util import instance toString Type
......@@ -86,7 +86,7 @@ where
toString {ParamDoc | description=Just d} = d
toString _ = ""
derive gDefault Type, TypeRestriction, ModuleDoc, FunctionDoc, InstanceDoc,
derive gDefault Type, TypeRestriction, ModuleDoc, FunctionDoc, InstanceDoc, TypeContext,
ClassMemberDoc, ConstructorDoc, ClassDoc, TypeDoc, Property,
PropertyVarInstantiation, MultiLineString, PropertyTestGenerator, ParamDoc
......
......@@ -47,7 +47,7 @@ from StdMaybe import :: Maybe
/**
* A type context.
*/
:: TypeContext :== [TypeRestriction]
:: TypeContext =: TypeContext [TypeRestriction]
/**
* A restriction on a type.
......@@ -261,6 +261,13 @@ constructorsToFunctions :: !TypeDef -> [(String,Type,Maybe Priority)]
*/
selectorsToFunctions :: !TypeDef -> [(String,Type)]
/**
* Constructor for {{`TypeContext`}}.
*
* @type [TypeRestriction] -> TypeContext
*/
typeContext x :== TypeContext x
/**
* Wrapper around the {{`td_name`}} field of the {{`TypeDef`}} record.
*/
......
......@@ -60,6 +60,10 @@ where
KArrow a` b` -> a==a` && b==b`
_ -> False
instance == TypeContext
where
== (TypeContext a) (TypeContext b) = a == b
subtypes :: !Type -> [Type]
subtypes t=:(Type s ts) = removeDup [t : flatten (map subtypes ts)]
subtypes t=:(Func is r tc) = removeDup [t : flatten (map subtypes [r:is])]
......@@ -72,10 +76,10 @@ subtypes t=:(Strict t`) = [t:subtypes t`]
allRestrictions :: !Type -> [TypeRestriction]
allRestrictions (Type _ ts) = concatMap allRestrictions ts
allRestrictions (Func is r tc) = tc ++ concatMap allRestrictions [r:is]
allRestrictions (Func is r (TypeContext tc)) = tc ++ concatMap allRestrictions [r:is]
allRestrictions (Cons _ ts) = concatMap allRestrictions ts
allRestrictions (Uniq t) = allRestrictions t
allRestrictions (Forall _ t tc) = tc ++ allRestrictions t
allRestrictions (Forall _ t (TypeContext tc)) = tc ++ allRestrictions t
allRestrictions (Var _) = []
allRestrictions (Arrow t) = fromMaybe [] (allRestrictions <$> t)
allRestrictions (Strict t) = allRestrictions t
......@@ -171,11 +175,11 @@ arity (Arrow _) = abort "what is the arity of Arrow?\n" // TODO
removeTypeContexts :: !Type -> Type
removeTypeContexts (Type s ts) = Type s $ map removeTypeContexts ts
removeTypeContexts (Func is r _) = Func (map removeTypeContexts is) (removeTypeContexts r) []
removeTypeContexts (Func is r _) = Func (map removeTypeContexts is) (removeTypeContexts r) (TypeContext [])
removeTypeContexts (Var v) = Var v
removeTypeContexts (Cons v ts) = Cons v $ map removeTypeContexts ts
removeTypeContexts (Uniq t) = Uniq $ removeTypeContexts t
removeTypeContexts (Forall ts t _) = Forall (map removeTypeContexts ts) (removeTypeContexts t) []
removeTypeContexts (Forall ts t _) = Forall (map removeTypeContexts ts) (removeTypeContexts t) (TypeContext [])
removeTypeContexts (Arrow t) = Arrow (removeTypeContexts <$> t)
removeTypeContexts (Strict t) = Strict (removeTypeContexts t)
......@@ -192,7 +196,7 @@ where
selectorsToFunctions :: !TypeDef -> [(String,Type)]
selectorsToFunctions {td_name,td_uniq,td_args,td_rhs=TDRRecord _ _ fields}
= [(f.rf_name, Func [strict arg] (unStrict f.rf_type) []) \\ f <- fields]
= [(f.rf_name, Func [strict arg] (unStrict f.rf_type) (TypeContext [])) \\ f <- fields]
where
arg = if td_uniq Uniq id $ Type td_name td_args
unStrict t = case t of
......@@ -231,9 +235,9 @@ removeDupTypedefs [td:tds]
= [td:removeDupTypedefs $ filter (\d -> d.td_name <> td.td_name) tds]
typeRhsRestrictions :: !TypeDefRhs -> [TypeRestriction]
typeRhsRestrictions (TDRCons _ cs) = flatten [c.cons_context \\ c <- cs]
typeRhsRestrictions (TDRNewType c) = c.cons_context
typeRhsRestrictions (TDRMoreConses cs) = flatten [c.cons_context \\ c <- cs]
typeRhsRestrictions (TDRCons _ cs) = flatten [c \\ {cons_context=TypeContext c} <- cs]
typeRhsRestrictions (TDRNewType {cons_context=TypeContext c}) = c
typeRhsRestrictions (TDRMoreConses cs) = flatten [c \\ {cons_context=TypeContext c} <- cs]
typeRhsRestrictions (TDRRecord _ _ _) = []
typeRhsRestrictions (TDRSynonym _) = []
typeRhsRestrictions (TDRAbstract _) = []
......
......@@ -160,20 +160,20 @@ where
uniq parser = pToken TStar >>| parser
optContext :: Parser Token TypeContext
optContext = liftM2 (++) (context <|> pure []) (uniquenessEqualities <|> pure [])
optContext = liftM2 (\(TypeContext a) (TypeContext b)->TypeContext (a ++ b)) (context <|> pure (TypeContext [])) (uniquenessEqualities <|> pure (TypeContext []))
addContextAsConstFunction :: (Parser Token Type) -> Parser Token Type
addContextAsConstFunction parser =
parser >>= \t -> pPeek >>= \tks -> case tks of
[TPipe:_] -> (pure [] <|> optContext) >>= \c -> case c of
[] -> pure t
c -> pure $ Func [] t c
[TPipe:_] -> (pure (TypeContext []) <|> optContext) >>= \c -> case c of
TypeContext [] -> pure t
c -> pure $ Func [] t c
_ -> pure t
context :: Parser Token TypeContext
context = pToken TPipe >>| flatten <$> pSepBy context` (pToken TAmpersand)
context = pToken TPipe >>| typeContext o flatten <$> pSepBy context` (pToken TAmpersand)
where
context` :: Parser Token TypeContext
context` :: Parser Token [TypeRestriction]
context` = pSepBy classOrGeneric (pToken TComma) >>= \restrictions ->
some argtype >>= \ts ->
mapM (flip ($) ts) restrictions
......@@ -201,7 +201,7 @@ where
_ -> False
uniquenessEqualities :: Parser Token TypeContext
uniquenessEqualities = pToken TComma >>| bracked (pSepBy inequality (pToken TComma)) $> []
uniquenessEqualities = pToken TComma >>| bracked (pSepBy inequality (pToken TComma)) $> TypeContext []
where
inequality = unqvar >>| pToken TLtEq >>| unqvar
......
......@@ -21,11 +21,11 @@ import Text.GenJSON
instance zero (TypeTree v) where zero = Node (Var "ra") [] []
instance < (TypeTree v) where < (Node a _ _) (Node b _ _) = a < b
derive gLexOrd Type, Maybe, TypeRestriction
derive gLexOrd Type, Maybe, TypeRestriction, TypeContext
instance < Type where < t u = (t =?= u) =: LT
derive JSONEncode TypeTree, Type, TypeRestriction
derive JSONDecode TypeTree, Type, TypeRestriction
derive JSONEncode TypeTree, Type, TypeRestriction, TypeContext
derive JSONDecode TypeTree, Type, TypeRestriction, TypeContext
typeTreeNodes :: !(TypeTree v) -> Int
typeTreeNodes (Node _ _ cs) = 1 + sum (map typeTreeNodes cs)
......
......@@ -20,7 +20,7 @@ import Data.List
from Data.Map import :: Map, newMap
import Data.Maybe
derive gEq Type, TypeRestriction, Kind
derive gEq Type, TypeRestriction, Kind, TypeContext
isGeneralisingUnifier :: ![TVAssignment] -> Bool
isGeneralisingUnifier tvas = all isOk $ groupVars tvas []
......@@ -74,7 +74,7 @@ where
renameAndRemoveStrictness (Var v) = Var (prep +++ v)
renameAndRemoveStrictness (Cons c ts) = Cons (prep +++ c) $ map renameAndRemoveStrictness ts
renameAndRemoveStrictness (Type t ts) = Type t $ map renameAndRemoveStrictness ts
renameAndRemoveStrictness (Func is r tc) = Func (map renameAndRemoveStrictness is) (renameAndRemoveStrictness r) (map (inTC renameAndRemoveStrictness) tc)
renameAndRemoveStrictness (Func is r (TypeContext tc)) = Func (map renameAndRemoveStrictness is) (renameAndRemoveStrictness r) (TypeContext (map (inTC renameAndRemoveStrictness) tc))
renameAndRemoveStrictness (Uniq t) = Uniq $ renameAndRemoveStrictness t
renameAndRemoveStrictness (Arrow t) = Arrow (renameAndRemoveStrictness <$> t)
renameAndRemoveStrictness (Forall vs t tc) = fromJust $
......
......@@ -57,8 +57,8 @@ where
instance print TypeContext
where
print _ [] = []
print _ crs = printersperse False " & "
print _ (TypeContext []) = []
print _ (TypeContext crs) = printersperse False " & "
[printersperse False ", " (map corg gr) -- " " -- printersperse False " " (types $ hd gr) \\ gr <- grps]
where
grps = groupBy (\a b -> types a == types b && length (types a) == 1) crs
......@@ -69,16 +69,16 @@ instance print Type
where
print ia (Type s vs) = typeConstructorName True ia s vs
print _ (Var v) = [v]
print ia (Func [] r []) = print ia r
print ia (Func [] r (TypeContext [])) = print ia r
print _ (Func [] r tc) = r -- " | " -- tc
print ia (Func ts r []) = parens ia (printersperse True " " ts -- " -> " -- r)
print _ (Func ts r tc) = (Func ts r []) -- " | " -- tc
print ia (Func ts r (TypeContext [])) = parens ia (printersperse True " " ts -- " -> " -- r)
print _ (Func ts r tc) = (Func ts r (TypeContext [])) -- " | " -- tc
print ia (Cons tv []) = print ia tv
print ia (Cons tv ats) = parens ia (tv -- " " -- printersperse True " " ats)
print _ (Uniq t) = case t of
Type _ _ -> "*" -- t
_ -> "*" -+ t
print _ (Forall tvs t []) = "(A." -- printersperse True " " tvs -- ": " -- t -- ")"
print _ (Forall tvs t (TypeContext [])) = "(A." -- printersperse True " " tvs -- ": " -- t -- ")"
print _ (Forall tvs t tc) = "(A." -- printersperse True " " tvs -- ": " -- t -- " | " -- tc -- ")"
print _ (Arrow Nothing) = ["(->)"]
print _ (Arrow (Just t)) = "((->) " -+ t +- ")"
......@@ -161,10 +161,10 @@ where
instance print Constructor
where
print _ {cons_name,cons_args,cons_exi_vars=evars,cons_context,cons_priority}
print _ {cons_name,cons_args,cons_exi_vars=evars,cons_context=TypeContext c,cons_priority}
= if (isEmpty evars) [] ("E." -- printersperse False " " evars -- ": ") --
name -- " " -- prio -- printersperse True " " cons_args --
if (isEmpty cons_context) [] (" & " -- cons_context)
if (isEmpty c) [] (" & " -- c)
where
(name,prio) = case cons_priority of
Nothing -> ([cons_name], [])
......@@ -264,7 +264,7 @@ assign va (Arrow Nothing) = Just $ Arrow Nothing
assign va (Strict t) = Strict <$> assign va t
reduceArities :: !Type -> Type
reduceArities (Func [] r []) = r
reduceArities (Func [] r (TypeContext [])) = r
reduceArities (Func ts r tc)
| length ts > 1 = Func [reduceArities $ hd ts] (reduceArities $ Func (tl ts) r tc) tc
| otherwise = Func (map reduceArities ts) (reduceArities r) tc
......@@ -272,7 +272,7 @@ reduceArities (Type s ts) = Type s $ map reduceArities ts
reduceArities (Cons v ts) = Cons v $ map reduceArities ts
reduceArities (Uniq t) = Uniq $ reduceArities t
reduceArities (Var v) = Var v
reduceArities (Forall [] t []) = reduceArities t
reduceArities (Forall [] t (TypeContext [])) = reduceArities t
reduceArities (Forall tvs t tc) = Forall tvs (reduceArities t) tc
reduceArities (Arrow mt) = Arrow (reduceArities <$> mt)
reduceArities (Strict t) = Strict $ reduceArities t
......@@ -293,14 +293,14 @@ where
renames = [(o, "v" +++ toString n) \\ o <- removeDup $ allVars t & n <- [1..]]
renameVars :: !Type -> Type
renameVars (Type s ts) = Type s $ map renameVars ts
renameVars (Func is r tc) = Func (map renameVars is) (renameVars r) $ map renameVarsInTC tc
renameVars (Var tv) = Var $ fromJust $ lookup tv renames
renameVars (Cons cv ts) = Cons (fromJust $ lookup cv renames) $ map renameVars ts
renameVars (Uniq t) = Uniq $ renameVars t
renameVars (Forall vs t tc) = Forall (map renameVars vs) (renameVars t) $ map renameVarsInTC tc
renameVars (Arrow t) = Arrow $ renameVars <$> t
renameVars (Strict t) = Strict $ renameVars t
renameVars (Type s ts) = Type s $ map renameVars ts
renameVars (Func is r (TypeContext tc)) = Func (map renameVars is) (renameVars r) $ TypeContext (map renameVarsInTC tc)
renameVars (Var tv) = Var $ fromJust $ lookup tv renames
renameVars (Cons cv ts) = Cons (fromJust $ lookup cv renames) $ map renameVars ts
renameVars (Uniq t) = Uniq $ renameVars t
renameVars (Forall vs t (TypeContext tc)) = Forall (map renameVars vs) (renameVars t) $ TypeContext (map renameVarsInTC tc)
renameVars (Arrow t) = Arrow $ renameVars <$> t
renameVars (Strict t) = Strict $ renameVars t
renameVarsInTC :: !TypeRestriction -> TypeRestriction
renameVarsInTC (Instance c ts) = Instance c $ map renameVars ts
......@@ -321,15 +321,15 @@ where
allVars` = concatMap allVars
optConses :: !Type -> Type
optConses (Type s ts) = Type s $ map optConses ts
optConses (Func is r tc) = Func (map optConses is) (optConses r) $ map optConsesInTR tc
optConses (Var v) = Var v
optConses (Cons c []) = Var c
optConses (Cons c ts) = Cons c $ map optConses ts
optConses (Uniq t) = Uniq $ optConses t
optConses (Forall vs t tc) = Forall (map optConses vs) (optConses t) $ map optConsesInTR tc
optConses (Arrow t) = Arrow $ optConses <$> t
optConses (Strict t) = Strict $ optConses t
optConses (Type s ts) = Type s $ map optConses ts
optConses (Func is r (TypeContext tc)) = Func (map optConses is) (optConses r) $ TypeContext (map optConsesInTR tc)
optConses (Var v) = Var v
optConses (Cons c []) = Var c
optConses (Cons c ts) = Cons c $ map optConses ts
optConses (Uniq t) = Uniq $ optConses t
optConses (Forall vs t (TypeContext tc)) = Forall (map optConses vs) (optConses t) $ TypeContext (map optConsesInTR tc)
optConses (Arrow t) = Arrow $ optConses <$> t
optConses (Strict t) = Strict $ optConses t
optConsesInTR :: !TypeRestriction -> TypeRestriction
optConsesInTR (Instance c ts) = Instance c $ map optConses ts
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment