chrisdone/duet
1
1
Fork 0
mirror of https://github.com/chrisdone/duet.git synced 2024-10-26 11:30:19 +03:00
Code Issues Projects Releases Wiki Activity

Add label to explicit binding id

Browse Source
This commit is contained in:
Chris Done 2017-12-18 15:49:34 +00:00
parent 3f6402c40a
commit c8aa9a29ff
7 changed files with 35 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/Duet/Infer.hs
View File

@ -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

2
src/Duet/Parser.hs
View File

@ -546,7 +546,7 @@ varfundeclExplicit =
loc
(ExplicitBinding
(ExplicitlyTypedBinding loc
(Identifier (T.unpack v))
(Identifier (T.unpack v), loc)
scheme
[makeAlt loc e])))
Equals -> do

2
src/Duet/Printer.hs
View File

@ -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 _ _ _ = ""

8
src/Duet/Renamer.hs
View File

@ -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

9
src/Duet/Resolver.hs
View File

@ -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)

5
src/Duet/Stepper.hs
View File

@ -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)

6
src/Duet/Types.hs
View File

@ -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)