mirror of
https://github.com/chrisdone/duet.git
synced 2024-10-26 11:30:19 +03:00
Add label to explicit binding id
This commit is contained in:
parent
3f6402c40a
commit
c8aa9a29ff
@ -178,7 +178,7 @@ collectMethods binds =
|
||||
listToMaybe
|
||||
(mapMaybe
|
||||
(\i ->
|
||||
if explicitlyTypedBindingId i == key
|
||||
if fst (explicitlyTypedBindingId i) == key
|
||||
then listToMaybe
|
||||
(explicitlyTypedBindingAlternatives i)
|
||||
else Nothing)
|
||||
@ -205,8 +205,10 @@ classMethodsToGroups specialTypes =
|
||||
sequence
|
||||
(zipWith
|
||||
(\methodScheme (instMethodName, (l, methodAlt)) ->
|
||||
ExplicitlyTypedBinding <$> pure l <*> pure instMethodName <*>
|
||||
instanceMethodScheme specialTypes
|
||||
ExplicitlyTypedBinding <$> pure l <*>
|
||||
pure (instMethodName, l) <*>
|
||||
instanceMethodScheme
|
||||
specialTypes
|
||||
class'
|
||||
methodScheme
|
||||
(instancePredicate inst) <*>
|
||||
@ -316,13 +318,16 @@ inferExplicitlyTypedBindingType
|
||||
-> [TypeSignature Type Name Name]
|
||||
-> (ExplicitlyTypedBinding Type Name l)
|
||||
-> InferT m ([Predicate Type Name], ExplicitlyTypedBinding Type Name (TypeSignature Type Name l))
|
||||
inferExplicitlyTypedBindingType ce as (ExplicitlyTypedBinding l identifier sc alts) = do
|
||||
inferExplicitlyTypedBindingType ce as (ExplicitlyTypedBinding l (identifier, l') sc alts) = do
|
||||
(Qualified qs t) <- freshInst sc
|
||||
(ps, alts') <- inferAltTypes ce as alts t
|
||||
s <- InferT (gets inferStateSubstitutions)
|
||||
let qs' = map (substitutePredicate s) qs
|
||||
t' = substituteType s t
|
||||
fs = getTypeVariablesOf getTypeSignatureTypeVariables (map (substituteTypeSignature s) as)
|
||||
fs =
|
||||
getTypeVariablesOf
|
||||
getTypeSignatureTypeVariables
|
||||
(map (substituteTypeSignature s) as)
|
||||
gs = getTypeTypeVariables t' \\ fs
|
||||
sc' = quantify gs (Qualified qs' t')
|
||||
ps' = filter (not . entail ce qs') (map (substitutePredicate s) ps)
|
||||
@ -331,7 +336,13 @@ inferExplicitlyTypedBindingType ce as (ExplicitlyTypedBinding l identifier sc al
|
||||
then throwM (ExplicitTypeMismatch sc sc')
|
||||
else if not (null rs)
|
||||
then throwM ContextTooWeak
|
||||
else return (ds, ExplicitlyTypedBinding (TypeSignature l sc) identifier sc alts')
|
||||
else return
|
||||
( ds
|
||||
, ExplicitlyTypedBinding
|
||||
(TypeSignature l sc)
|
||||
(identifier, TypeSignature l' sc)
|
||||
sc
|
||||
alts')
|
||||
|
||||
-- | Are two type schemes alpha-equivalent?
|
||||
schemesEquivalent :: Scheme Type Name Type -> Scheme Type Name Type -> Bool
|
||||
@ -424,7 +435,7 @@ inferBindGroupTypes
|
||||
-> (BindGroup Type Name l)
|
||||
-> InferT m ([Predicate Type Name], [(TypeSignature Type Name Name)], BindGroup Type Name (TypeSignature Type Name l))
|
||||
inferBindGroupTypes ce as (BindGroup es iss) = do
|
||||
let as' = [TypeSignature v sc | ExplicitlyTypedBinding _ v sc _alts <- es]
|
||||
let as' = [TypeSignature v sc | ExplicitlyTypedBinding _ (v, _) sc _alts <- es]
|
||||
(ps, as'', iss') <-
|
||||
inferSequenceTypes0 inferImplicitlyTypedBindingsTypes ce (as' ++ as) iss
|
||||
qss <- mapM (inferExplicitlyTypedBindingType ce (as'' ++ as' ++ as)) es
|
||||
|
@ -546,7 +546,7 @@ varfundeclExplicit =
|
||||
loc
|
||||
(ExplicitBinding
|
||||
(ExplicitlyTypedBinding loc
|
||||
(Identifier (T.unpack v))
|
||||
(Identifier (T.unpack v), loc)
|
||||
scheme
|
||||
[makeAlt loc e])))
|
||||
Equals -> do
|
||||
|
@ -121,7 +121,7 @@ printImplicitlyTypedBinding _ _ = ""
|
||||
printExplicitlyTypedBinding
|
||||
:: (Printable i, PrintableType t)
|
||||
=> Print i l -> SpecialTypes i -> ExplicitlyTypedBinding t i l -> String
|
||||
printExplicitlyTypedBinding printer specialTypes (ExplicitlyTypedBinding _ i scheme [alt]) =
|
||||
printExplicitlyTypedBinding printer specialTypes (ExplicitlyTypedBinding _ (i, _) scheme [alt]) =
|
||||
printIdentifier printer i ++ " :: " ++ printScheme printer specialTypes scheme ++ "\n" ++
|
||||
printIdentifier printer i ++ " " ++ printAlternative printer alt
|
||||
printExplicitlyTypedBinding _ _ _ = ""
|
||||
|
@ -467,7 +467,7 @@ renameBindings specials subs types bindings = do
|
||||
((<> subs) . M.fromList)
|
||||
(mapM
|
||||
(\case
|
||||
ExplicitBinding (ExplicitlyTypedBinding _ i _ _) -> do
|
||||
ExplicitBinding (ExplicitlyTypedBinding _ (i, _) _ _) -> do
|
||||
v <- identifyValue i
|
||||
fmap (v, ) (supplyValueName i)
|
||||
ImplicitBinding (ImplicitlyTypedBinding _ (i, _) _) -> do
|
||||
@ -520,7 +520,7 @@ getExplicitSubs subs explicit =
|
||||
fmap
|
||||
((<> subs) . M.fromList)
|
||||
(mapM
|
||||
(\(ExplicitlyTypedBinding _ i _ _) -> do
|
||||
(\(ExplicitlyTypedBinding _ (i, _) _ _) -> do
|
||||
v <- identifyValue i
|
||||
fmap (v, ) (supplyValueName i))
|
||||
explicit)
|
||||
@ -532,9 +532,9 @@ renameExplicit
|
||||
-> [DataType Type Name]
|
||||
-> ExplicitlyTypedBinding t i l
|
||||
-> m (ExplicitlyTypedBinding Type Name l)
|
||||
renameExplicit specials subs types (ExplicitlyTypedBinding l i scheme alts) = do
|
||||
renameExplicit specials subs types (ExplicitlyTypedBinding l (i, l') scheme alts) = do
|
||||
name <- substituteVar subs i
|
||||
ExplicitlyTypedBinding l name <$> renameScheme specials subs types scheme <*>
|
||||
ExplicitlyTypedBinding l (name, l') <$> renameScheme specials subs types scheme <*>
|
||||
mapM (renameAlt specials subs types) alts
|
||||
|
||||
renameImplicit
|
||||
|
@ -20,9 +20,8 @@ import Duet.Printer
|
||||
import Duet.Supply
|
||||
import Duet.Types
|
||||
|
||||
|
||||
resolveTypeClasses
|
||||
:: (Show l, MonadSupply Int f, MonadThrow f)
|
||||
:: (MonadSupply Int f, MonadThrow f)
|
||||
=> Map Name (Class Type Name (TypeSignature Type Name l))
|
||||
-> SpecialTypes Name
|
||||
-> f (Map Name (Class Type Name (TypeSignature Type Name l)))
|
||||
@ -51,7 +50,7 @@ resolveTypeClasses typeClasses specialTypes = go typeClasses
|
||||
M.toList
|
||||
|
||||
resolveBindGroup
|
||||
:: (MonadSupply Int m, MonadThrow m ,Show l)
|
||||
:: (MonadSupply Int m, MonadThrow m)
|
||||
=> Map Name (Class Type Name (TypeSignature Type Name l))
|
||||
-> SpecialTypes Name
|
||||
-> BindGroup Type Name (TypeSignature Type Name l)
|
||||
@ -62,7 +61,7 @@ resolveBindGroup classes specialTypes (BindGroup explicit implicit) = do
|
||||
pure (BindGroup explicits implicits)
|
||||
|
||||
resolveImplicit
|
||||
:: (MonadSupply Int m, MonadThrow m ,Show l)
|
||||
:: (MonadSupply Int m, MonadThrow m)
|
||||
=> Map Name (Class Type Name (TypeSignature Type Name l))
|
||||
-> SpecialTypes Name
|
||||
-> ImplicitlyTypedBinding Type Name (TypeSignature Type Name l)
|
||||
@ -71,7 +70,7 @@ resolveImplicit classes specialTypes (ImplicitlyTypedBinding l name alts) =
|
||||
ImplicitlyTypedBinding l name <$> mapM (resolveAlt classes specialTypes) alts
|
||||
|
||||
resolveExplicit
|
||||
:: (MonadSupply Int m, MonadThrow m ,Show l)
|
||||
:: (MonadSupply Int m, MonadThrow m)
|
||||
=> Map Name (Class Type Name (TypeSignature Type Name l))
|
||||
-> SpecialTypes Name
|
||||
-> ExplicitlyTypedBinding Type Name (TypeSignature Type Name l)
|
||||
|
@ -272,6 +272,7 @@ substitute i arg = go
|
||||
| otherwise -> VariableExpression l i'
|
||||
x@ConstructorExpression {} -> x
|
||||
x@ConstantExpression {} -> x
|
||||
ParensExpression _ e -> go e
|
||||
ApplicationExpression l f x -> ApplicationExpression l (go f) (go x)
|
||||
InfixExpression l x (s, f) y -> InfixExpression l (go x) (s, go f) (go y)
|
||||
LetExpression {} -> error "let expressions unsupported."
|
||||
@ -306,7 +307,7 @@ lookupName identifier binds =
|
||||
listToMaybe
|
||||
(mapMaybe
|
||||
(\case
|
||||
ExplicitlyTypedBinding _ i _ [Alternative _ [] e]
|
||||
ExplicitlyTypedBinding _ (i, _) _ [Alternative _ [] e]
|
||||
| i == identifier -> Just e
|
||||
_ -> Nothing)
|
||||
es)
|
||||
@ -332,7 +333,7 @@ lookupNameByString identifier binds =
|
||||
listToMaybe
|
||||
(mapMaybe
|
||||
(\case
|
||||
ExplicitlyTypedBinding _ (ValueName _ i) _ [Alternative _ [] e]
|
||||
ExplicitlyTypedBinding _ (ValueName _ i, _) _ [Alternative _ [] e]
|
||||
| i == identifier -> Just e
|
||||
_ -> Nothing)
|
||||
es)
|
||||
|
@ -52,7 +52,7 @@ bindingIdentifier :: Binding t i l -> i
|
||||
bindingIdentifier =
|
||||
\case
|
||||
ImplicitBinding i -> fst (implicitlyTypedBindingId i)
|
||||
ExplicitBinding i -> explicitlyTypedBindingId i
|
||||
ExplicitBinding i -> fst (explicitlyTypedBindingId i)
|
||||
|
||||
bindingAlternatives :: Binding t i l -> [Alternative t i l]
|
||||
bindingAlternatives =
|
||||
@ -309,7 +309,7 @@ instance (ToJSON (t i), ToJSON l,ToJSON i) => ToJSON (ExplicitlyTypedBinding t
|
||||
instance (FromJSON (t i), FromJSON l,FromJSON i) => FromJSON (ExplicitlyTypedBinding t i l)
|
||||
data ExplicitlyTypedBinding t i l = ExplicitlyTypedBinding
|
||||
{ explicitlyTypedBindingLabel :: l
|
||||
, explicitlyTypedBindingId :: !i
|
||||
, explicitlyTypedBindingId :: !(i, l)
|
||||
, explicitlyTypedBindingScheme :: !(Scheme t i t)
|
||||
, explicitlyTypedBindingAlternatives :: ![(Alternative t i l)]
|
||||
} deriving (Show, Generic, Data, Typeable, Functor, Traversable, Foldable, Eq)
|
||||
@ -523,6 +523,8 @@ data Dictionary (t :: * -> *) i l = Dictionary
|
||||
, dictionaryMethods :: Map i (l, Alternative t i l)
|
||||
} deriving (Show, Generic, Data, Typeable, Functor, Traversable, Foldable, Eq)
|
||||
|
||||
|
||||
|
||||
-- | A type constructor.
|
||||
instance (NFData i) => NFData (TypeConstructor i)
|
||||
instance (ToJSON i) => ToJSON (TypeConstructor i)
|
||||
|
Loading…
Reference in New Issue
Block a user