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

WIP: infix operators

Browse Source
This commit is contained in:
Chris Done 2017-06-16 11:33:19 +01:00
parent 6609c53604
commit e562d2e8ff
14 changed files with 377 additions and 293 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

324
app/Main.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -29,6 +30,7 @@ import Duet.Printer
import Duet.Renamer
import Duet.Resolver
import Duet.Stepper
import Duet.Supply
import Duet.Tokenizer
import Duet.Types
import System.Environment
@ -60,6 +62,7 @@ compileStepText file i text =
decls
((specialSigs, specialTypes, bindGroups, signatures, subs, typeClassEnv, types), supplies) <-
runTypeChecker decls
let specials = Specials specialSigs specialTypes
putStrLn "-- Type-checked bindings:"
mapM_
(\(BindGroup es is) -> do
@ -168,7 +171,7 @@ compileStepText file i text =
(liftIO (putStrLn (printExpression (defaultPrint) e)))
if fmap (const ()) e' /= fmap (const ()) e
then do
renameExpression specialTypes subs types e' >>= loopy
renameExpression specials subs types e' >>= loopy
else pure ())
e0)
supplies)
@ -357,12 +360,12 @@ runTypeChecker decls =
_ -> Nothing)
decls
in runSupplyT
(do specialTypes <- defaultSpecialTypes
(specialSigs, signatures0) <- builtInSignatures specialTypes
(do (specialTypes, specialSigs, signatures0, env0) <- setupEnv mempty
let specials = Specials specialSigs specialTypes
liftIO (putStrLn "-- Renaming types, classes and instances ...")
(typeClasses, signatures, subs, types) <-
(typeClasses, signatures, subs, dataTypes) <-
catch
(do dataTypes <- renameDataTypes specialTypes types
(do dataTypes <- renameDataTypes specials types
consSigs <-
fmap
concat
@ -370,7 +373,7 @@ runTypeChecker decls =
typeClasses0 <-
mapM
(\c -> do
renamed <- renameClass specialTypes mempty dataTypes c
renamed <- renameClass specials mempty dataTypes c
pure (className c, renamed))
classes
let typeClasses = map snd typeClasses0
@ -378,21 +381,21 @@ runTypeChecker decls =
let signatures = signatures0 <> consSigs <> methodSigs
subs =
M.fromList
(map
(mapMaybe
(\(TypeSignature name _) ->
case name of
ValueName _ ident -> (Identifier ident, name)
ValueName _ ident -> Just (Identifier ident, name)
ConstructorName _ ident ->
(Identifier ident, name)
pure (Identifier ident, name)
MethodName _ ident ->
(Identifier ident, name))
pure (Identifier ident, name)
_ -> Nothing)
signatures) <>
M.fromList (map (second className) typeClasses0)
allInstances <-
mapM
(renameInstance specialTypes subs dataTypes typeClasses)
(renameInstance specials subs dataTypes typeClasses)
instances
{-trace ("Instances: " ++ show allInstances) (return ())-}
pure
( map
(\typeClass ->
@ -416,32 +419,26 @@ runTypeChecker decls =
liftIO (putStrLn "-- Renaming variable/function declarations ...")
(renamedBindings, subs') <-
catch
(renameBindGroups specialTypes subs types bindings)
(renameBindGroups specials subs dataTypes bindings)
(\e ->
liftIO
(do putStrLn (displayRenamerException specialTypes e)
exitFailure))
env0 <- setupEnv specialTypes mempty
env <-
lift
(foldM
(\e0 typeClass ->
addClass
(className typeClass)
(classTypeVariables typeClass)
(classSuperclasses typeClass)
(classMethods typeClass)
typeClass
e0 >>= \e ->
foldM
(\e1 i@(Instance (Qualified ps p) dict)
{-liftIO (putStrLn ("Add instance: " ++ show i))-}
-> do addInstance ps p dict e1)
(\e1 i
-> do addInstance i e1)
e
(classInstances typeClass))
env0
typeClasses)
-- liftIO (putStrLn "-- Type class environment:")
-- liftIO (print env)
liftIO (putStrLn "-- Inferring types ...")
(bindGroups, env') <-
lift
@ -452,51 +449,9 @@ runTypeChecker decls =
(do putStrLn (displayInferException specialTypes e)
exitFailure)))
return
(specialSigs, specialTypes, bindGroups, signatures, subs', env', types))
(specialSigs, specialTypes, bindGroups, signatures, subs', env', dataTypes))
[0 ..]
-- | Built-in pre-defined functions.
builtInSignatures
:: MonadThrow m
=> SpecialTypes Name -> SupplyT Int m (SpecialSigs Name, [TypeSignature Type Name Name])
builtInSignatures specialTypes = do
the_show <- supplyValueName ("show" :: Identifier)
sigs <- dataTypeSignatures specialTypes (specialTypesBool specialTypes)
the_True <- getSig "True" sigs
the_False <- getSig "False" sigs
return
( SpecialSigs
{ specialSigsTrue = the_True
, specialSigsFalse = the_False
, specialSigsShow = the_show
}
, [ {-TypeSignature
the_show
(Forall
[StarKind]
(Qualified
[IsIn (specialTypesShow specialTypes) [(GenericType 0)]]
(GenericType 0 --> ConstructorType (specialTypesString specialTypes))))-}
] ++
sigs)
where
getSig ident sigs =
case listToMaybe
(mapMaybe
(\case
(TypeSignature n@(ValueName _ i) _)
| i == ident -> Just n
(TypeSignature n@(ConstructorName _ i) _)
| i == ident -> Just n
_ -> Nothing)
sigs) of
Nothing -> throwM (BuiltinNotDefined ident)
Just sig -> pure sig
(-->) :: Type Name -> Type Name -> Type Name
a --> b =
ApplicationType (ApplicationType (ConstructorType(specialTypesFunction specialTypes)) a) b
classSignatures :: MonadThrow m => Class Type Name l -> m [TypeSignature Type Name Name]
classSignatures cls =
mapM
@ -513,99 +468,172 @@ dataTypeSignatures specialTypes dt@(DataType _ vs cs) = mapM construct cs
pure
(TypeSignature
cname
(let -- varsGens = map (second GenericType) (zip vs [0 ..])
in Forall
vs
(Qualified
[]
(foldr
makeArrow
(foldl
ApplicationType
(dataTypeConstructor dt)
(map VariableType vs))
fs))))
(Forall
vs
(Qualified
[]
(foldr
makeArrow
(foldl
ApplicationType
(dataTypeConstructor dt)
(map VariableType vs))
fs))))
where
varsToGens :: [(TypeVariable Name, Type Name)] -> Type Name -> Type Name
varsToGens varsGens = go
where
go =
\case
v@(VariableType tyvar) ->
case lookup tyvar varsGens of
Just gen -> gen
Nothing -> v
ApplicationType t1 t2 -> ApplicationType (go t1) (go t2)
-- g@GenericType {} -> g
c@ConstructorType {} -> c
makeArrow :: Type Name -> Type Name -> Type Name
a `makeArrow` b =
ApplicationType
(ApplicationType (ConstructorType(specialTypesFunction specialTypes)) a)
(ApplicationType
(ConstructorType (specialTypesFunction specialTypes))
a)
b
-- | Setup the class environment.
setupEnv
:: MonadThrow m
=> SpecialTypes Name
-> Map Name (Class Type Name l)
-> SupplyT Int m (Map Name (Class Type Name l))
setupEnv specialTypes env = do
show_a <- supplyTypeName "a"
showInt <- supplyDictName "Show Int"
showRational <- supplyDictName "Show Rational"
showChar' <- supplyDictName "Show Char"
let update =
addClass theShow [TypeVariable show_a StarKind] [] mempty >=>
addInstance
[]
(IsIn theShow [ConstructorType(specialTypesInteger specialTypes)])
(Dictionary showInt mempty) >=>
addInstance
[]
(IsIn theShow [ConstructorType(specialTypesRational specialTypes)])
(Dictionary showRational mempty) >=>
addInstance
[]
(IsIn theShow [ConstructorType(specialTypesChar specialTypes)])
(Dictionary showChar' mempty)
lift (update env)
where
theShow = specialTypesShow specialTypes
--------------------------------------------------------------------------------
-- Built-in types
-- | Special types that Haskell uses for pattern matching and literals.
defaultSpecialTypes :: Monad m => SupplyT Int m (SpecialTypes Name)
defaultSpecialTypes = do
boolDataType <-
do name <- supplyTypeName "Bool"
true <- supplyConstructorName "True"
false <- supplyConstructorName "False"
pure
(DataType
name
[]
[DataTypeConstructor true [], DataTypeConstructor false []])
:: (MonadThrow m)
=> Map Name (Class Type Name l)
-> SupplyT Int m (SpecialTypes Name, SpecialSigs Name, [TypeSignature Type Name Name], Map Name (Class Type Name l))
setupEnv env = do
theArrow <- supplyTypeName "(->)"
theChar <- supplyTypeName "Char"
theString <- supplyTypeName "String"
theInteger <- supplyTypeName "Integer"
theRational <- supplyTypeName "Rational"
theShow <- supplyTypeName "Show"
return
(SpecialTypes
{ specialTypesBool = boolDataType
, specialTypesChar = (TypeConstructor theChar StarKind)
, specialTypesString = (TypeConstructor theString StarKind)
, specialTypesFunction =
(TypeConstructor
theArrow
(FunctionKind StarKind (FunctionKind StarKind StarKind)))
, specialTypesInteger =
(TypeConstructor theInteger StarKind)
, specialTypesRational =
(TypeConstructor theRational StarKind)
, specialTypesShow = theShow
(true, false, boolDataType) <-
do name <- supplyTypeName "Bool"
true <- supplyConstructorName "True"
false <- supplyConstructorName "False"
pure
( true
, false
, DataType
name
[]
[DataTypeConstructor true [], DataTypeConstructor false []])
let function =
(TypeConstructor
theArrow
(FunctionKind StarKind (FunctionKind StarKind StarKind)))
let specialTypes =
(SpecialTypes
{ specialTypesBool = boolDataType
, specialTypesChar = TypeConstructor theChar StarKind
, specialTypesString = TypeConstructor theString StarKind
, specialTypesFunction = function
, specialTypesInteger = TypeConstructor theInteger StarKind
, specialTypesRational = TypeConstructor theRational StarKind
})
(numClass, plus, times) <- makeNumClass function
(negClass, subtract') <- makeNegClass function
(fracClass, divide) <- makeFracClass function
boolSigs <- dataTypeSignatures specialTypes boolDataType
classSigs <-
fmap concat (mapM classSignatures [numClass, negClass, fracClass])
let signatures = boolSigs <> classSigs
specialSigs =
SpecialSigs
{ specialSigsTrue = true
, specialSigsFalse = false
, specialSigsPlus = plus
, specialSigsSubtract = subtract'
, specialSigsTimes = times
, specialSigsDivide = divide
}
specials = Specials specialSigs specialTypes
numInt <-
makeInst
specials
(IsIn
(className numClass)
[ConstructorType (specialTypesInteger specialTypes)])
env' <-
let update =
addClass numClass >=>
addClass negClass >=> addClass fracClass >=> addInstance numInt
in lift (update env)
pure (specialTypes, specialSigs, signatures, env')
makeNumClass :: MonadSupply Int m => TypeConstructor Name -> m (Class Type Name l, Name, Name)
makeNumClass function = do
a <- fmap (\n -> TypeVariable n StarKind) (supplyTypeName "a")
let a' = VariableType a
plus <- supplyMethodName "plus"
times <- supplyMethodName "times"
cls <-
makeClass
"Num"
[a]
[ (plus, Forall [a] (Qualified [] (a' --> a' --> a')))
, (times, Forall [a] (Qualified [] (a' --> a' --> a')))
]
pure (cls, plus, times)
where
infixr 1 -->
(-->) :: Type Name -> Type Name -> Type Name
a --> b = ApplicationType (ApplicationType (ConstructorType function) a) b
makeNegClass :: MonadSupply Int m => TypeConstructor Name -> m (Class Type Name l, Name)
makeNegClass function = do
a <- fmap (\n -> TypeVariable n StarKind) (supplyTypeName "a")
let a' = VariableType a
negate' <- supplyMethodName "negate"
subtract' <- supplyMethodName "subtract"
abs' <- supplyMethodName "abs"
cls <-
makeClass
"Neg"
[a]
[ (negate', Forall [a] (Qualified [] (a' --> a' --> a')))
, (subtract', Forall [a] (Qualified [] (a' --> a' --> a')))
, (abs', Forall [a] (Qualified [] (a' --> a')))
]
pure (cls, subtract')
where
infixr 1 -->
(-->) :: Type Name -> Type Name -> Type Name
a --> b = ApplicationType (ApplicationType (ConstructorType function) a) b
makeFracClass :: MonadSupply Int m => TypeConstructor Name -> m (Class Type Name l, Name)
makeFracClass function = do
a <- fmap (\n -> TypeVariable n StarKind) (supplyTypeName "a")
let a' = VariableType a
divide <- supplyMethodName "divide"
recip' <- supplyMethodName "recip"
cls <-
makeClass
"Fractional"
[a]
[ (divide, Forall [a] (Qualified [] (a' --> a' --> a')))
, (recip', Forall [a] (Qualified [] (a' --> a')))
]
pure (cls, divide)
where
infixr 1 -->
(-->) :: Type Name -> Type Name -> Type Name
a --> b = ApplicationType (ApplicationType (ConstructorType function) a) b
makeClass
:: MonadSupply Int m
=> Identifier
-> [TypeVariable Name]
-> [(Name, Scheme t Name)]
-> m (Class t Name l)
makeClass name vars methods = do
name' <- supplyClassName name
pure
(Class
{ className = name'
, classTypeVariables = vars
, classInstances = []
, classMethods = M.fromList methods
, classSuperclasses = mempty
})
makeInst specials pred =
do name <- supplyDictName (predicateToDict specials pred)
pure (Instance
(Qualified
[]
pred)
(Dictionary name mempty))

1
duet.cabal
View File

@ -30,6 +30,7 @@ library
Duet.Renamer
Duet.Resolver
Duet.Stepper
Duet.Supply
Control.Monad.Supply
executable duet

10
examples/ack.duet Normal file
View File

@ -0,0 +1,10 @@
data Tuple a b = Tuple a b
ack :: Int -> Int -> Int
ack = \m n ->
case Tuple m n of
Tuple 0 n -> n + 1
ack 0 n = n+1
ack m 0 = ack (m-1) 1
ack m n = ack (m-1) (ack m (n-1))
main = ack 4 1

1
examples/arith.duet Normal file
View File

@ -0,0 +1 @@
main = 2 + (3 * 5)

5
examples/classes.duet
View File

@ -34,6 +34,11 @@ instance Equal Nat where
not = \b -> case b of
True -> False
False -> True
foo :: Bool
foo = 123
notEqual :: Equal a => a -> a -> Bool
notEqual = \x y -> not (equal x y)
main = equal (reader (shower (Succ Zero))) (Succ Zero)

1
examples/prelude.duet
View File

@ -26,6 +26,7 @@ class Num a where
class Neg a where
negate :: a -> a
abs :: a -> a
subtract :: a -> a -> a
class MinBound b where
minBound :: b

23
src/Duet/Infer.hs
View File

@ -667,18 +667,16 @@ defined Nothing = False
-- Throws 'ReadException' in the case of error.
addClass
:: MonadThrow m
=> Name
-> [TypeVariable Name]
-> [Predicate Type Name]
-> Map Name (Scheme Type Name)
=> Class Type Name l
-> Map Name (Class Type Name l)
-> m (Map Name (Class Type Name l))
addClass i vs ps methods ce
addClass (Class vs ps _ i methods) ce
| defined (M.lookup i ce) = throwM ClassAlreadyDefined
| any (not . defined . flip M.lookup ce . predHead) ps =
throwM UndefinedSuperclass
| otherwise = return (M.insert i (Class vs ps [] i methods) ce)
-- | Add an instance of a class. Example:
--
-- @
@ -688,12 +686,10 @@ addClass i vs ps methods ce
-- Throws 'ReadException' in the case of error.
addInstance
:: MonadThrow m
=> [Predicate Type Name]
-> Predicate Type Name
-> Dictionary Type Name l
=> Instance Type Name l
-> Map Name (Class Type Name l)
-> m (Map Name (Class Type Name l))
addInstance ps p@(IsIn i _) dict ce =
addInstance (Instance (Qualified _ p@(IsIn i _)) dict) ce =
case M.lookup i ce of
Nothing -> throwM NoSuchClassForInstance
Just typeClass
@ -701,6 +697,7 @@ addInstance ps p@(IsIn i _) dict ce =
| otherwise -> return (M.insert i c ce)
where its = classInstances typeClass
qs = [q | Instance (Qualified _ q) _ <- its]
ps = []
c =
(Class
(classTypeVariables typeClass)
@ -822,13 +819,13 @@ inferExpressionType ce as (ApplicationExpression l e f) = do
unify (tf `makeArrow` t) te
let scheme = (Forall [] (Qualified (ps++qs) t))
return (ps ++ qs, t, ApplicationExpression (TypeSignature l scheme) e' f')
inferExpressionType ce as (InfixExpression l x op y) = do
(ps, ts, ApplicationExpression l' (ApplicationExpression _ (VariableExpression _ op') x') y') <-
inferExpressionType ce as (InfixExpression l x (i,op) y) = do
(ps, ts, ApplicationExpression l' (ApplicationExpression _ (op') x') y') <-
inferExpressionType
ce
as
(ApplicationExpression l (ApplicationExpression l (VariableExpression l op) x) y)
pure (ps, ts, InfixExpression l' x' op' y')
(ApplicationExpression l (ApplicationExpression l op x) y)
pure (ps, ts, InfixExpression l' x' (i, op') y')
inferExpressionType ce as (LetExpression l bg e) = do
(ps, as', bg') <- inferBindGroupTypes ce as bg
(qs, t, e') <- inferExpressionType ce (as' ++ as) e

3
src/Duet/Parser.hs
View File

@ -631,7 +631,8 @@ expParser = case' <|> lambda <|> ifParser <|> infix' <|> app <|> atomic
InfixExpression
(Location 0 0 0 0)
left
(Identifier (T.unpack t))
(let i = ((T.unpack t))
in (i, VariableExpression (Location 0 0 0 0) (Identifier i)))
right
maybe
(return ())

6
src/Duet/Printer.hs
View File

@ -176,10 +176,12 @@ printExpression printer e =
printExpressionIfPred printer a ++
" then " ++
printExpression printer b ++ " else " ++ printExpression printer c
InfixExpression _ f o x ->
InfixExpression _ f (o, ov) x ->
printExpressionAppArg printer f ++
" " ++
printIdentifier printer o ++ " " ++ printExpressionAppArg printer x
(if printDictionaries printer
then "`" ++ printExpression printer ov ++ "`"
else o) ++ " " ++ printExpressionAppArg printer x
_ -> "<TODO>")
where
wrapType x =

225
src/Duet/Renamer.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE LambdaCase #-}
@ -18,7 +17,16 @@
--
-- It's as simple as that.
module Duet.Renamer where
module Duet.Renamer
( renameDataTypes
, renameBindGroups
, renameExpression
, renameClass
, renameInstance
, predicateToDict
, operatorTable
, Specials(Specials)
) where
import Control.Arrow
import Control.Monad.Catch
@ -31,17 +39,23 @@ import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Duet.Infer
import Duet.Printer
import Duet.Supply
import Duet.Types
--------------------------------------------------------------------------------
-- Data type renaming (this includes kind checking)
data Specials n = Specials
{ specialSigs :: SpecialSigs n
, specialTypes :: SpecialTypes n
}
renameDataTypes
:: (MonadSupply Int m, MonadThrow m)
=> SpecialTypes Name
=> Specials Name
-> [DataType UnkindedType Identifier]
-> m [DataType Type Name]
renameDataTypes specialTypes types = do
renameDataTypes specials types = do
typeConstructors <-
mapM
(\(DataType name vars cs) -> do
@ -56,30 +70,30 @@ renameDataTypes specialTypes types = do
types
mapM
(\(_, name, vars, cs) -> do
cs' <- mapM (renameConstructor specialTypes typeConstructors vars) cs
cs' <- mapM (renameConstructor specials typeConstructors vars) cs
pure (DataType name (map snd vars) cs'))
typeConstructors
renameConstructor
:: (MonadSupply Int m, MonadThrow m)
=> SpecialTypes Name -> [(Identifier, Name, [(Identifier, TypeVariable Name)], [DataTypeConstructor UnkindedType Identifier])]
=> Specials Name -> [(Identifier, Name, [(Identifier, TypeVariable Name)], [DataTypeConstructor UnkindedType Identifier])]
-> [(Identifier, TypeVariable Name)]
-> DataTypeConstructor UnkindedType Identifier
-> m (DataTypeConstructor Type Name)
renameConstructor specialTypes typeConstructors vars (DataTypeConstructor name fields) = do
renameConstructor specials typeConstructors vars (DataTypeConstructor name fields) = do
name' <- supplyConstructorName name
fields' <- mapM (renameField specialTypes typeConstructors vars name') fields
fields' <- mapM (renameField specials typeConstructors vars name') fields
pure (DataTypeConstructor name' fields')
renameField
:: (MonadThrow m, MonadSupply Int m)
=> SpecialTypes Name
=> Specials Name
-> [(Identifier, Name, [(Identifier, TypeVariable Name)], [DataTypeConstructor UnkindedType Identifier])]
-> [(Identifier, TypeVariable Name)]
-> Name
-> UnkindedType Identifier
-> m (Type Name)
renameField specialTypes typeConstructors vars name fe = do
renameField specials typeConstructors vars name fe = do
ty <- go fe
if typeKind ty == StarKind
then pure ty
@ -111,7 +125,7 @@ renameField specialTypes typeConstructors vars name fe = do
case find ((\(j, _, _, _) -> j == i)) typeConstructors of
Just (_, name', vs, _) -> pure (name', vs)
Nothing ->
case specialTypesBool specialTypes of
case specialTypesBool (specialTypes specials) of
DataType n@(TypeName _ i') vars _
| Identifier i' == i ->
pure
@ -122,7 +136,7 @@ renameField specialTypes typeConstructors vars name fe = do
(Identifier i, TypeVariable n k))
vars)
_ ->
case specialTypesFunction specialTypes of
case specialTypesFunction (specialTypes specials) of
TypeConstructor n@(TypeName _ i') _
| Identifier i' == i -> do
vars <-
@ -135,18 +149,19 @@ renameField specialTypes typeConstructors vars name fe = do
(map Identifier ["a", "b"])
pure (n, vars)
--------------------------------------------------------------------------------
-- Class renaming
renameClass
:: forall m l.
(MonadSupply Int m, MonadThrow m)
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [DataType Type Name]
-> Class UnkindedType Identifier l
-> m (Class Type Name l)
renameClass specialTypes subs types cls = do
renameClass specials subs types cls = do
name <- supplyClassName (className cls)
classVars <-
mapM
@ -156,7 +171,7 @@ renameClass specialTypes subs types cls = do
(classTypeVariables cls)
instances <-
mapM
(renameInstance' specialTypes subs types classVars)
(renameInstance' specials subs types classVars)
(classInstances cls)
methods' <-
fmap
@ -166,12 +181,12 @@ renameClass specialTypes subs types cls = do
name' <- supplyMethodName name
methodVars <- mapM (renameMethodTyVar classVars) vars
let classAndMethodVars = nub (classVars ++ methodVars)
ty' <- renameType specialTypes classAndMethodVars types ty
ty' <- renameType specials classAndMethodVars types ty
preds' <-
mapM
(\(IsIn c tys) ->
IsIn <$> substituteClass subs c <*>
mapM (renameType specialTypes classAndMethodVars types) tys)
mapM (renameType specials classAndMethodVars types) tys)
preds
pure
( name'
@ -202,13 +217,13 @@ renameClass specialTypes subs types cls = do
renameInstance
:: (MonadThrow m, MonadSupply Int m, Show l)
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [DataType Type Name]
-> [Class Type Name l]
-> Instance UnkindedType Identifier l
-> m (Instance Type Name l)
renameInstance specialTypes subs types classes inst@(Instance (Qualified _ (IsIn className' _)) _) = do
renameInstance specials subs types classes inst@(Instance (Qualified _ (IsIn className' _)) _) = do
{-trace ("renameInstance: Classes: " ++ show (map className classes)) (return ())-}
table <- mapM (\c -> fmap (, c) (identifyClass (className c))) classes
{-trace ("renameInstance: Table: " ++ show table) (return ())-}
@ -224,17 +239,17 @@ renameInstance specialTypes subs types classes inst@(Instance (Qualified _ (IsIn
mapM
(\v@(TypeVariable i _) -> fmap (, v) (identifyType i))
(classTypeVariables typeClass)
renameInstance' specialTypes subs types vars inst
renameInstance' specials subs types vars inst
renameInstance'
:: (MonadThrow m, MonadSupply Int m)
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [DataType Type Name]
-> [(Identifier, TypeVariable Name)]
-> Instance UnkindedType Identifier l
-> m (Instance Type Name l)
renameInstance' specialTypes subs types _tyVars (Instance (Qualified preds ty) dict) = do
renameInstance' specials subs types _tyVars (Instance (Qualified preds ty) dict) = do
let vars0 =
nub
(concat
@ -248,9 +263,9 @@ renameInstance' specialTypes subs types _tyVars (Instance (Qualified preds ty) d
n <- supplyTypeName i
pure (i, TypeVariable n k))
vars0
preds' <- mapM (renamePredicate specialTypes subs vars types) preds
ty' <- renamePredicate specialTypes subs vars types ty
dict' <- renameDict specialTypes subs types dict ty'
preds' <- mapM (renamePredicate specials subs vars types) preds
ty' <- renamePredicate specials subs vars types ty
dict' <- renameDict specials subs types dict ty'
pure (Instance (Qualified preds' ty') dict')
where
collectTypeVariables :: UnkindedType i -> [TypeVariable i]
@ -262,30 +277,30 @@ renameInstance' specialTypes subs types _tyVars (Instance (Qualified preds ty) d
renameDict
:: (MonadThrow m, MonadSupply Int m)
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [DataType Type Name]
-> Dictionary UnkindedType Identifier l
-> Predicate Type Name
-> m (Dictionary Type Name l)
renameDict specialTypes subs types (Dictionary _ methods) predicate = do
renameDict specials subs types (Dictionary _ methods) predicate = do
name' <-
supplyDictName'
(Identifier (predicateToDict specialTypes predicate))
(Identifier (predicateToDict specials predicate))
methods' <-
fmap
M.fromList
(mapM
(\(n, alt) -> do
n' <- supplyMethodName n
alt' <- renameAlt specialTypes subs types alt
alt' <- renameAlt specials subs types alt
pure (n', alt'))
(M.toList methods))
pure (Dictionary name' methods')
predicateToDict :: SpecialTypes Name -> ((Predicate Type Name)) -> String
predicateToDict specialTypes (pred) =
"$dict" ++ map normalize (printPredicate defaultPrint specialTypes pred)
predicateToDict :: Specials Name -> ((Predicate Type Name)) -> String
predicateToDict specials pred =
"$dict" ++ map normalize (printPredicate defaultPrint (specialTypes specials) pred)
where
normalize c
| isDigit c || isLetter c = c
@ -294,15 +309,15 @@ predicateToDict specialTypes (pred) =
renamePredicate
:: (MonadThrow m, Typish (t i), Identifiable i, Ord i)
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [(Identifier, TypeVariable Name)]
-> [DataType Type Name]
-> Predicate t i
-> m (Predicate Type Name)
renamePredicate specialTypes subs tyVars types (IsIn className types0) =
renamePredicate specials subs tyVars types (IsIn className types0) =
do className' <- substituteClass subs className
types' <- mapM (renameType specialTypes tyVars types -- >=> forceStarKind
types' <- mapM (renameType specials tyVars types -- >=> forceStarKind
) types0
pure (IsIn className' types')
@ -315,12 +330,12 @@ forceStarKind ty =
renameScheme
:: (MonadSupply Int m, MonadThrow m, Identifiable i, Typish (t i), Ord i)
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [DataType Type Name]
-> Scheme t i
-> m (Scheme Type Name)
renameScheme specialTypes subs types (Forall tyvars (Qualified ps ty)) = do
renameScheme specials subs types (Forall tyvars (Qualified ps ty)) = do
tyvars' <-
mapM
(\(TypeVariable i kind) -> do
@ -333,19 +348,19 @@ renameScheme specialTypes subs types (Forall tyvars (Qualified ps ty)) = do
ident <- identifyType n
(ident, ) <$> (TypeVariable <$> pure n <*> pure kind))
tyvars
ps' <- mapM (renamePredicate specialTypes subs tyvars' types) ps
ty' <- renameType specialTypes tyvars' types ty
ps' <- mapM (renamePredicate specials subs tyvars' types) ps
ty' <- renameType specials tyvars' types ty
pure (Forall (map snd tyvars') (Qualified ps' ty'))
-- | Rename a type, checking kinds, taking names, etc.
renameType
:: (MonadThrow m, Typish (t i))
=> SpecialTypes Name
=> Specials Name
-> [(Identifier, TypeVariable Name)]
-> [DataType Type Name]
-> t i
-> m (Type Name)
renameType specialTypes tyVars types t = either go pure (isType t)
renameType specials tyVars types t = either go pure (isType t)
where
go =
\case
@ -353,8 +368,8 @@ renameType specialTypes tyVars types t = either go pure (isType t)
ms <- mapM (\p -> fmap (, p) (identifyType (dataTypeName p))) types
case lookup i ms of
Nothing -> do
do specials' <- sequence specials
case lookup i specials' of
do specials'' <- sequence specials'
case lookup i specials'' of
Nothing ->
throwM
(TypeNotInScope
@ -378,14 +393,14 @@ renameType specialTypes tyVars types t = either go pure (isType t)
StarKind -> do
a' <- go a
throwM (KindTooManyArgs f' (typeKind f') a')
specials =
[ setup specialTypesFunction
, setup (dataTypeToConstructor . specialTypesBool)
specials' =
[ setup (specialTypesFunction . specialTypes)
, setup (dataTypeToConstructor . specialTypesBool . specialTypes)
]
where
setup f = do
i <- identifyType (typeConstructorIdentifier (f specialTypes))
pure (i, f specialTypes)
i <- identifyType (typeConstructorIdentifier (f specials))
pure (i, f specials)
--------------------------------------------------------------------------------
-- Value renaming
@ -397,12 +412,12 @@ renameBindGroups
, Identifiable i
, Typish (UnkindedType i)
)
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [DataType Type Name]
-> [BindGroup UnkindedType i l]
-> m ([BindGroup Type Name l], Map Identifier Name)
renameBindGroups specialTypes subs types groups = do
renameBindGroups specials subs types groups = do
subs' <-
fmap
mconcat
@ -413,19 +428,19 @@ renameBindGroups specialTypes subs types groups = do
pure (explicit' <> implicit'))
groups
)
fmap (second mconcat . unzip) (mapM (renameBindGroup specialTypes subs' types) groups)
fmap (second mconcat . unzip) (mapM (renameBindGroup specials subs' types) groups)
renameBindGroup
:: (MonadSupply Int m, MonadThrow m, Ord i, Identifiable i, Typish (t i))
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [DataType Type Name]
-> BindGroup t i l
-> m (BindGroup Type Name l, Map Identifier Name)
renameBindGroup specialTypes subs types (BindGroup explicit implicit) = do
renameBindGroup specials subs types (BindGroup explicit implicit) = do
bindGroup' <-
BindGroup <$> mapM (renameExplicit specialTypes subs types) explicit <*>
mapM (mapM (renameImplicit specialTypes subs types)) implicit
BindGroup <$> mapM (renameExplicit specials subs types) explicit <*>
mapM (mapM (renameImplicit specials subs types)) implicit
pure (bindGroup', subs)
getImplicitSubs
@ -459,26 +474,26 @@ getExplicitSubs subs explicit =
renameExplicit
:: (MonadSupply Int m, MonadThrow m, Identifiable i, Ord i, Typish (t i))
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [DataType Type Name]
-> ExplicitlyTypedBinding t i l
-> m (ExplicitlyTypedBinding Type Name l)
renameExplicit specialTypes subs types (ExplicitlyTypedBinding i scheme alts) = do
renameExplicit specials subs types (ExplicitlyTypedBinding i scheme alts) = do
name <- substituteVar subs i
ExplicitlyTypedBinding name <$> renameScheme specialTypes subs types scheme <*>
mapM (renameAlt specialTypes subs types) alts
ExplicitlyTypedBinding name <$> renameScheme specials subs types scheme <*>
mapM (renameAlt specials subs types) alts
renameImplicit
:: (MonadThrow m,MonadSupply Int m,Ord i, Identifiable i, Typish (t i))
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [DataType Type Name]
-> ImplicitlyTypedBinding t i l
-> m (ImplicitlyTypedBinding Type Name l)
renameImplicit specialTypes subs types (ImplicitlyTypedBinding l id' alts) =
renameImplicit specials subs types (ImplicitlyTypedBinding l id' alts) =
do name <- substituteVar subs id'
ImplicitlyTypedBinding l name <$> mapM (renameAlt specialTypes subs types) alts
ImplicitlyTypedBinding l name <$> mapM (renameAlt specials subs types) alts
renameAlt
:: ( MonadSupply Int m
@ -488,15 +503,15 @@ renameAlt
, Identifiable i
, Typish (t i)
)
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [DataType Type Name]
-> Alternative t i l
-> m (Alternative Type Name l)
renameAlt specialTypes subs types (Alternative l ps e) =
renameAlt specials subs types (Alternative l ps e) =
do (ps', subs') <- runWriterT (mapM (renamePattern subs) ps)
let subs'' = M.fromList subs' <> subs
Alternative l <$> pure ps' <*> renameExpression specialTypes subs'' types e
Alternative l <$> pure ps' <*> renameExpression specials subs'' types e
renamePattern
:: (MonadSupply Int m, MonadThrow m, Ord i, Identifiable i)
@ -528,12 +543,12 @@ instance Typish (UnkindedType Identifier) where isType = Left
renameExpression
:: forall t i m l.
(MonadThrow m, MonadSupply Int m, Ord i, Identifiable i, Typish (t i))
=> SpecialTypes Name
=> Specials Name
-> Map Identifier Name
-> [DataType Type Name]
-> Expression t i l
-> m (Expression Type Name l)
renameExpression specialTypes subs types = go
renameExpression specials subs types = go
where
go :: Expression t i l -> m (Expression Type Name l)
go =
@ -544,16 +559,22 @@ renameExpression specialTypes subs types = go
ConstantExpression l i -> pure (ConstantExpression l i)
LiteralExpression l i -> pure (LiteralExpression l i)
ApplicationExpression l f x -> ApplicationExpression l <$> go f <*> go x
InfixExpression l x i y ->
InfixExpression l <$> go x <*> substituteVar subs i <*> go y
InfixExpression l x (orig, VariableExpression l0 i) y -> do
ident <- identifyValue i
i' <-
case lookup ident operatorTable of
Just f -> pure (f (specialSigs specials))
_ -> throwM (IdentifierNotInVarScope subs ident)
InfixExpression l <$> go x <*> pure (orig, VariableExpression l0 i') <*> go y
LetExpression l bindGroup@(BindGroup ex implicit) e -> do
subs0 <- getImplicitSubs subs implicit
subs1 <- getExplicitSubs subs ex
(bindGroup', subs'') <-
renameBindGroup specialTypes (subs0 <> subs1) types bindGroup
renameBindGroup specials (subs0 <> subs1) types bindGroup
LetExpression l <$> pure bindGroup' <*>
renameExpression specialTypes subs'' types e
LambdaExpression l alt -> LambdaExpression l <$> renameAlt specialTypes subs types alt
renameExpression specials subs'' types e
LambdaExpression l alt ->
LambdaExpression l <$> renameAlt specials subs types alt
IfExpression l x y z -> IfExpression l <$> go x <*> go y <*> go z
CaseExpression l e pat_exps ->
CaseExpression l <$> go e <*>
@ -561,11 +582,7 @@ renameExpression specialTypes subs types = go
(\(pat, ex) -> do
(pat', subs') <- runWriterT (renamePattern subs pat)
e' <-
renameExpression
specialTypes
(M.fromList subs' <> subs)
types
ex
renameExpression specials (M.fromList subs' <> subs) types ex
pure (pat', e'))
pat_exps
@ -607,47 +624,11 @@ substituteCons subs i0 =
Just name@ConstructorName{} -> pure name
_ -> do throwM (IdentifierNotInConScope subs i)
--------------------------------------------------------------------------------
-- Provide a new name
supplyValueName :: (MonadSupply Int m, Identifiable i, MonadThrow m) => i -> m Name
supplyValueName s = do
i <- supply
Identifier s <- identifyValue s
return (ValueName i s)
supplyConstructorName :: (MonadSupply Int m) => Identifier -> m Name
supplyConstructorName (Identifier s) = do
i <- supply
return (ConstructorName i s)
supplyDictName :: (MonadSupply Int m) => String -> m Name
supplyDictName s = do
i <- supply
return (DictName i s)
supplyDictName' :: (MonadSupply Int m, MonadThrow m) => Identifier -> m Name
supplyDictName' s = do
i <- supply
Identifier s <- identifyValue s
return (DictName i s)
supplyTypeName :: (MonadSupply Int m) => Identifier -> m Name
supplyTypeName (Identifier s) = do
i <- supply
return (TypeName i s)
supplyTypeVariableName :: (MonadSupply Int m) => Identifier -> m Name
supplyTypeVariableName (Identifier s) = do
i <- supply
return (TypeName i (s ++ show i))
supplyClassName :: (MonadSupply Int m) => Identifier -> m Name
supplyClassName (Identifier s) = do
i <- supply
return (ClassName i s)
supplyMethodName :: (MonadSupply Int m) => Identifier -> m Name
supplyMethodName (Identifier s) = do
i <- supply
return (MethodName i s)
operatorTable =
map
(first Identifier)
[ ("+", specialSigsPlus)
, ("-", specialSigsSubtract)
, ("*", specialSigsTimes)
, ("/", specialSigsDivide)
]

9
src/Duet/Resolver.hs
View File

@ -11,11 +11,12 @@ module Duet.Resolver where
import Control.Monad.Catch
import Control.Monad.Supply
import Data.List
import Data.Map.Strict (Map)
import Data.Maybe
import Duet.Infer
import Duet.Printer
import Duet.Renamer
import Duet.Supply
import Duet.Types
resolveBindGroup
@ -77,7 +78,7 @@ resolveAlt classes specialTypes (Alternative l ps e) = do
predicateToString
:: (Printable i, Show i)
=> SpecialTypes i -> Predicate Type i -> String
predicateToString specialTypes (IsIn name ts) =
predicateToString _specialTypes (IsIn name _ts) =
-- printIdentifier name ++ " " ++ unwords (map (printType specialTypes) ts)
"?dict" ++ printIdentifier defaultPrint name
@ -89,7 +90,7 @@ resolveExp
-> Expression Type Name (TypeSignature Type Name l)
-> m (Expression Type Name (TypeSignature Type Name l))
resolveExp classes specialTypes dicts = go
resolveExp classes _ dicts = go
where
go =
\case
@ -99,6 +100,8 @@ resolveExp classes specialTypes dicts = go
(foldl (ApplicationExpression l) (VariableExpression l i) dictArgs)
where Forall _ (Qualified predicates _) = typeSignatureScheme l
ApplicationExpression l f x -> ApplicationExpression l <$> go f <*> go x
InfixExpression l x (i, op) y ->
InfixExpression l <$> go x <*> fmap (i ,) (go op) <*> go y
LambdaExpression l0 (Alternative l vs b) ->
LambdaExpression l0 <$> (Alternative l vs <$> go b)
CaseExpression l e alts ->

1
src/Duet/Stepper.hs
View File

@ -15,7 +15,6 @@ 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

51
src/Duet/Supply.hs Normal file
View File

@ -0,0 +1,51 @@
{-# LANGUAGE Strict #-}
{-# LANGUAGE FlexibleContexts #-}
-- |
module Duet.Supply where
import Control.Monad.Catch
import Control.Monad.Supply
import Duet.Types
supplyValueName :: (MonadSupply Int m, Identifiable i, MonadThrow m) => i -> m Name
supplyValueName s = do
i <- supply
Identifier s' <- identifyValue s
return (ValueName i s')
supplyConstructorName :: (MonadSupply Int m) => Identifier -> m Name
supplyConstructorName (Identifier s) = do
i <- supply
return (ConstructorName i s)
supplyDictName :: (MonadSupply Int m) => String -> m Name
supplyDictName s = do
i <- supply
return (DictName i s)
supplyDictName' :: (MonadSupply Int m, MonadThrow m) => Identifier -> m Name
supplyDictName' s = do
i <- supply
Identifier s' <- identifyValue s
return (DictName i s')
supplyTypeName :: (MonadSupply Int m) => Identifier -> m Name
supplyTypeName (Identifier s) = do
i <- supply
return (TypeName i s)
supplyTypeVariableName :: (MonadSupply Int m) => Identifier -> m Name
supplyTypeVariableName (Identifier s) = do
i <- supply
return (TypeName i (s ++ show i))
supplyClassName :: (MonadSupply Int m) => Identifier -> m Name
supplyClassName (Identifier s) = do
i <- supply
return (ClassName i s)
supplyMethodName :: (MonadSupply Int m) => Identifier -> m Name
supplyMethodName (Identifier s) = do
i <- supply
return (MethodName i s)

10
src/Duet/Types.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveTraversable #-}
@ -64,14 +66,16 @@ data SpecialTypes i = SpecialTypes
, specialTypesFunction :: TypeConstructor i
, specialTypesInteger :: TypeConstructor i
, specialTypesRational :: TypeConstructor i
, specialTypesShow :: i
} deriving (Show)
-- | Special built-in signatures.
data SpecialSigs i = SpecialSigs
{ specialSigsTrue :: i
, specialSigsFalse :: i
, specialSigsShow :: i
, specialSigsPlus :: i
, specialSigsTimes :: i
, specialSigsSubtract :: i
, specialSigsDivide :: i
}
-- | Type inference monad.
@ -275,7 +279,7 @@ data Expression (t :: * -> *) i l
| ConstantExpression l Identifier
| LiteralExpression l Literal
| ApplicationExpression l (Expression t i l) (Expression t i l)
| InfixExpression l (Expression t i l) i (Expression t i l)
| InfixExpression l (Expression t i l) (String, Expression t i l) (Expression t i l)
| LetExpression l (BindGroup t i l) (Expression t i l)
| LambdaExpression l (Alternative t i l)
| IfExpression l (Expression t i l) (Expression t i l) (Expression t i l)