mirror of
https://github.com/chrisdone/duet.git
synced 2024-10-06 00:08:57 +03:00
Stepping with dictionaries
This commit is contained in:
parent
1bbda943da
commit
c407a8eb26
56
app/Main.hs
56
app/Main.hs
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@ -48,7 +49,7 @@ compileStepText file i text =
|
||||
case parseText file text of
|
||||
Left e -> error (show e)
|
||||
Right decls -> do
|
||||
((specialSigs, specialTypes, bindGroups, signatures, subs, env), supplies) <-
|
||||
((specialSigs, specialTypes, bindGroups, signatures, subs, typeClassEnv), supplies) <-
|
||||
runTypeChecker decls
|
||||
putStrLn "-- Type-checked bindings:"
|
||||
mapM_
|
||||
@ -61,10 +62,42 @@ compileStepText file i text =
|
||||
is)
|
||||
bindGroups
|
||||
{-trace ("Compiled classes: " ++ show env) (return ())-}
|
||||
typeClassEnv' <-
|
||||
catch
|
||||
(evalSupplyT
|
||||
(fmap
|
||||
M.fromList
|
||||
(mapM
|
||||
(\(name, cls) -> do
|
||||
is <-
|
||||
mapM
|
||||
(\inst -> do
|
||||
ms <-
|
||||
mapM
|
||||
(\(nam, alt) ->
|
||||
fmap
|
||||
(nam, )
|
||||
(resolveAlt typeClassEnv specialTypes alt))
|
||||
(M.toList
|
||||
(dictionaryMethods (instanceDictionary inst)))
|
||||
pure
|
||||
inst
|
||||
{ instanceDictionary =
|
||||
(instanceDictionary inst)
|
||||
{dictionaryMethods = M.fromList ms}
|
||||
})
|
||||
(classInstances cls)
|
||||
pure (name, cls {classInstances = is}))
|
||||
(M.toList typeClassEnv)))
|
||||
supplies)
|
||||
(\e ->
|
||||
liftIO
|
||||
(do putStrLn (displayResolveException specialTypes e)
|
||||
exitFailure))
|
||||
bindGroups' <-
|
||||
catch
|
||||
(evalSupplyT
|
||||
(mapM (resolveBindGroup env specialTypes) bindGroups)
|
||||
(mapM (resolveBindGroup typeClassEnv' specialTypes) bindGroups)
|
||||
supplies)
|
||||
(\e ->
|
||||
liftIO
|
||||
@ -86,7 +119,14 @@ compileStepText file i text =
|
||||
when
|
||||
(True || cleanExpression e)
|
||||
(liftIO (putStrLn (printExpression (const Nothing) e)))
|
||||
e' <- expandSeq1 specialSigs signatures e bindGroups subs
|
||||
e' <-
|
||||
expandSeq1
|
||||
typeClassEnv'
|
||||
specialSigs
|
||||
signatures
|
||||
e
|
||||
bindGroups
|
||||
subs
|
||||
if fmap (const ()) e' /= fmap (const ()) e
|
||||
then do
|
||||
renameExpression subs e' >>= loopy
|
||||
@ -313,7 +353,9 @@ runTypeChecker decls =
|
||||
(\typeClass ->
|
||||
typeClass
|
||||
{ classInstances =
|
||||
filter ((== className typeClass) . instanceClassName) allInstances
|
||||
filter
|
||||
((== className typeClass) . instanceClassName)
|
||||
allInstances
|
||||
})
|
||||
typeClasses
|
||||
, signatures
|
||||
@ -345,9 +387,9 @@ runTypeChecker decls =
|
||||
(classMethods typeClass)
|
||||
e0 >>= \e ->
|
||||
foldM
|
||||
(\e1 i@(Instance (Qualified ps p) dict) ->
|
||||
do {-liftIO (putStrLn ("Add instance: " ++ show i))-}
|
||||
addInstance ps p dict e1)
|
||||
(\e1 i@(Instance (Qualified ps p) dict)
|
||||
{-liftIO (putStrLn ("Add instance: " ++ show i))-}
|
||||
-> do addInstance ps p dict e1)
|
||||
e
|
||||
(classInstances typeClass))
|
||||
env0
|
||||
|
@ -1,3 +1,9 @@
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
class Functor f where
|
||||
map :: forall a b. (a -> b) -> f a -> f b
|
||||
class X a where
|
||||
f :: a -> D
|
||||
data D = D | C
|
||||
instance X D where
|
||||
f = \x -> case x of
|
||||
D -> D
|
||||
C -> f D
|
||||
|
||||
demo = f C
|
||||
|
@ -19,13 +19,13 @@ class Eq a => Printable a where
|
||||
instance Printable Name where
|
||||
printit =
|
||||
\case
|
||||
ValueName _ string -> string -- ++ "[value: " ++ show i ++ "]"
|
||||
TypeName _ string -> string -- ++ "[type: " ++ show i ++ "]"
|
||||
ValueName i string -> string -- ++ "[value: " ++ show i ++ "]"
|
||||
TypeName i string -> string -- ++ "[type: " ++ show i ++ "]"
|
||||
ConstructorName _ string -> string
|
||||
ForallName i -> "g" ++ show i
|
||||
DictName i string -> string -- "(" ++ string ++ ":" ++ show i ++")"
|
||||
ClassName _ s -> s
|
||||
MethodName _ s -> s
|
||||
MethodName i s -> s -- ++ "[method: " ++ show i ++ "]"
|
||||
|
||||
instance Printable Identifier where
|
||||
printit =
|
||||
|
@ -35,11 +35,13 @@ class Identifiable i where
|
||||
identifyValue :: MonadThrow m => i -> m Identifier
|
||||
identifyType :: MonadThrow m => i -> m Identifier
|
||||
identifyClass :: MonadThrow m => i -> m Identifier
|
||||
nonrenamableName :: i -> Maybe Name
|
||||
|
||||
instance Identifiable Identifier where
|
||||
identifyValue = pure
|
||||
identifyType = pure
|
||||
identifyClass = pure
|
||||
nonrenamableName _ = Nothing
|
||||
|
||||
instance Identifiable Name where
|
||||
identifyValue =
|
||||
@ -47,6 +49,7 @@ instance Identifiable Name where
|
||||
ValueName _ i -> pure (Identifier i)
|
||||
ConstructorName _ c -> pure (Identifier c)
|
||||
DictName _ i -> pure (Identifier i)
|
||||
MethodName _ i -> pure (Identifier i)
|
||||
n -> throwM (TypeAtValueScope n)
|
||||
identifyType =
|
||||
\case
|
||||
@ -54,7 +57,17 @@ instance Identifiable Name where
|
||||
n -> throwM (RenamerNameMismatch n)
|
||||
identifyClass =
|
||||
\case
|
||||
ClassName _ i -> pure (Identifier i)
|
||||
ClassName _ i -> pure (Identifier i)
|
||||
n -> throwM (RenamerNameMismatch n)
|
||||
nonrenamableName n =
|
||||
case n of
|
||||
ValueName {} -> Nothing
|
||||
ConstructorName {} -> pure n
|
||||
TypeName {} -> pure n
|
||||
ForallName {} -> pure n
|
||||
DictName {} -> pure n
|
||||
ClassName {} -> pure n
|
||||
MethodName {} -> pure n
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Data type renaming (this includes kind checking)
|
||||
@ -458,12 +471,15 @@ renameExpression subs = go
|
||||
|
||||
substituteVar :: (Ord i, Identifiable i, MonadThrow m) => Map Identifier Name -> i -> m Name
|
||||
substituteVar subs i0 =
|
||||
do i <- identifyValue i0
|
||||
case M.lookup i subs of
|
||||
Just name@ValueName{} -> pure name
|
||||
Just name@MethodName{} -> pure name
|
||||
_ -> do s <- identifyValue i
|
||||
throwM (IdentifierNotInVarScope subs s)
|
||||
case nonrenamableName i0 of
|
||||
Nothing -> do i <- identifyValue i0
|
||||
case M.lookup i subs of
|
||||
Just name@ValueName{} -> pure name
|
||||
Just name@MethodName{} -> pure name
|
||||
Just name@DictName {} -> pure name
|
||||
_ -> do s <- identifyValue i
|
||||
throwM (IdentifierNotInVarScope subs s)
|
||||
Just n -> pure n
|
||||
|
||||
substituteClass :: (Ord i, Identifiable i, MonadThrow m) => Map Identifier Name -> i -> m Name
|
||||
substituteClass subs i0 =
|
||||
|
@ -97,7 +97,13 @@ resolveExp classes specialTypes dicts = go
|
||||
ApplicationExpression l f x -> ApplicationExpression l <$> go f <*> go x
|
||||
LambdaExpression l0 (Alternative l vs b) ->
|
||||
LambdaExpression l0 <$> (Alternative l vs <$> go b)
|
||||
e -> pure e
|
||||
CaseExpression l e alts ->
|
||||
CaseExpression l <$> go e <*>
|
||||
mapM (\(p, e') -> fmap (p, ) (go e')) alts
|
||||
e@ConstructorExpression {} -> pure e
|
||||
e@ConstantExpression {} -> pure e
|
||||
IfExpression l a b c -> IfExpression l <$> go a <*> go b <*> go c
|
||||
e@LiteralExpression {} -> pure e
|
||||
lookupDictionary l p =
|
||||
(case byInst classes p of
|
||||
Just (_, dict) -> do
|
||||
|
@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
@ -13,10 +15,10 @@ import Control.Monad.State
|
||||
import Control.Monad.Supply
|
||||
import Data.List
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe
|
||||
import Data.Semigroup
|
||||
import Duet.Renamer
|
||||
import Duet.Types
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -24,13 +26,14 @@ import Duet.Types
|
||||
|
||||
expandSeq1
|
||||
:: (MonadThrow m, MonadSupply Int m)
|
||||
=> SpecialSigs Name
|
||||
=> Map Name (Class Type Name (TypeSignature Name Location))
|
||||
-> SpecialSigs Name
|
||||
-> [TypeSignature Name Name]
|
||||
-> Expression Name (TypeSignature Name Location)
|
||||
-> [BindGroup Name (TypeSignature Name Duet.Types.Location)]
|
||||
-> Map Identifier Name
|
||||
-> m (Expression Name (TypeSignature Name Location))
|
||||
expandSeq1 specialSigs signatures e b subs =
|
||||
expandSeq1 typeClassEnv specialSigs signatures e b _ =
|
||||
evalStateT (go e) False
|
||||
where
|
||||
go =
|
||||
@ -47,22 +50,23 @@ expandSeq1 specialSigs signatures e b subs =
|
||||
if alreadyExpanded
|
||||
then pure e0
|
||||
else do
|
||||
e' <- lift (expandWhnf specialSigs signatures e0 b)
|
||||
e' <- lift (expandWhnf typeClassEnv specialSigs signatures e0 b)
|
||||
put True
|
||||
pure e'
|
||||
|
||||
expandWhnf
|
||||
:: MonadThrow m
|
||||
=> SpecialSigs Name
|
||||
=> Map Name (Class Type Name (TypeSignature Name Location))
|
||||
-> SpecialSigs Name
|
||||
-> [TypeSignature Name Name]
|
||||
-> Expression Name (TypeSignature Name Location)
|
||||
-> [BindGroup Name (TypeSignature Name Duet.Types.Location)]
|
||||
-> m (Expression Name (TypeSignature Name Location))
|
||||
expandWhnf specialSigs signatures e b = go e
|
||||
expandWhnf typeClassEnv specialSigs signatures e b = go e
|
||||
where
|
||||
go x =
|
||||
case x of
|
||||
VariableExpression loc i -> do
|
||||
VariableExpression _ i -> do
|
||||
case find ((== i) . typeSignatureA) signatures of
|
||||
Nothing -> do
|
||||
e' <- lookupName i b
|
||||
@ -83,6 +87,27 @@ expandWhnf specialSigs signatures e b = go e
|
||||
pure
|
||||
(LambdaExpression l0 (Alternative l' params' body'))
|
||||
[] -> error "Unsupported lambda."
|
||||
VariableExpression _ (MethodName _ methodName) ->
|
||||
case arg of
|
||||
VariableExpression _ dictName@DictName {} ->
|
||||
case find
|
||||
((== dictName) . dictionaryName)
|
||||
(concatMap
|
||||
(map instanceDictionary . classInstances)
|
||||
(M.elems typeClassEnv)) of
|
||||
Nothing -> error "Dictionary missing."
|
||||
Just dict ->
|
||||
case M.lookup
|
||||
methodName
|
||||
(M.mapKeys
|
||||
(\(MethodName _ s) -> s)
|
||||
(dictionaryMethods dict)) of
|
||||
Nothing ->
|
||||
error
|
||||
("Missing method " ++
|
||||
show methodName ++ " in dictionary: " ++ show dict)
|
||||
Just (Alternative _ _ e) ->
|
||||
pure e
|
||||
_ -> do
|
||||
func' <- go func
|
||||
pure (ApplicationExpression l func' arg)
|
||||
@ -111,23 +136,24 @@ expandWhnf specialSigs signatures e b = go e
|
||||
expr
|
||||
subs)
|
||||
Just (NeedsMoreEval is, _) -> do
|
||||
e' <- expandAt is specialSigs signatures e0 b
|
||||
e' <- expandAt typeClassEnv is specialSigs signatures e0 b
|
||||
pure (CaseExpression l e' alts)
|
||||
Nothing -> error ("Incomplete pattern match... " ++ show matches)
|
||||
|
||||
expandAt
|
||||
:: MonadThrow m
|
||||
=> [Int]
|
||||
=> Map Name (Class Type Name (TypeSignature Name Location))
|
||||
-> [Int]
|
||||
-> SpecialSigs Name
|
||||
-> [TypeSignature Name Name]
|
||||
-> Expression Name (TypeSignature Name Location)
|
||||
-> [BindGroup Name (TypeSignature Name Duet.Types.Location)]
|
||||
-> m (Expression Name (TypeSignature Name Location))
|
||||
expandAt is specialSigs signatures e0 b = go [0] e0
|
||||
expandAt typeClassEnv is specialSigs signatures e0 b = go [0] e0
|
||||
where
|
||||
go js e =
|
||||
if is == js
|
||||
then expandWhnf specialSigs signatures e b
|
||||
then expandWhnf typeClassEnv specialSigs signatures e b
|
||||
else case e of
|
||||
_
|
||||
| (ce@(ConstructorExpression l _), args) <- fargs e -> do
|
||||
|
Loading…
Reference in New Issue
Block a user