chrisdone/duet
1
1
Fork 0
mirror of https://github.com/chrisdone/duet.git synced 2024-10-06 00:08:57 +03:00
Code Issues Projects Releases Wiki Activity

Stepping with dictionaries

Browse Source
This commit is contained in:
Chris Done 2017-06-06 20:48:38 +01:00
parent 1bbda943da
commit c407a8eb26
6 changed files with 128 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
app/Main.hs
View File

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

12
examples/X.hs
View File

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

6
src/Duet/Printer.hs
View File

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

30
src/Duet/Renamer.hs
View File

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

8
src/Duet/Resolver.hs
View File

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

48
src/Duet/Stepper.hs
View File

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