mirror of
https://github.com/chrisdone/duet.git
synced 2024-10-26 11:30:19 +03:00
WIP: Dependency analysis
This commit is contained in:
parent
44e699c198
commit
f8cd1ad7be
@ -122,7 +122,7 @@ makeScope typeClasses signatures =
|
||||
signatures) <>
|
||||
M.map className typeClasses)
|
||||
|
||||
renameEverything :: (Show l1, MonadThrow m, MonadSupply Int m) => [Decl UnkindedType Identifier l1] -> Specials Name -> Builtins Type Name l -> m (M.Map Identifier (Class Type Name l1), [TypeSignature Type Name Name], [BindGroup Type Name l1], M.Map Identifier Name, [DataType Type Name])
|
||||
renameEverything :: (MonadThrow m, MonadSupply Int m) => [Decl UnkindedType Identifier l1] -> Specials Name -> Builtins Type Name l -> m (M.Map Identifier (Class Type Name l1), [TypeSignature Type Name Name], [Binding Type Name l1], M.Map Identifier Name, [DataType Type Name])
|
||||
renameEverything decls specials builtins = do
|
||||
dataTypes <- renameDataTypes specials (declsDataTypes decls)
|
||||
(typeClasses, signatures, subs) <-
|
||||
@ -152,7 +152,7 @@ renameEverything decls specials builtins = do
|
||||
typeClasses
|
||||
, signatures
|
||||
, scope)
|
||||
(renamedBindings, subs') <- renameBindGroups specials subs dataTypes bindings
|
||||
(renamedBindings, subs') <- renameBindings specials subs dataTypes bindings
|
||||
pure (typeClasses, signatures, renamedBindings, subs', dataTypes)
|
||||
where declsDataTypes =
|
||||
mapMaybe
|
||||
@ -162,7 +162,7 @@ renameEverything decls specials builtins = do
|
||||
bindings =
|
||||
mapMaybe
|
||||
(\case
|
||||
BindGroupDecl _ d -> Just d
|
||||
BindDecl _ d -> Just d
|
||||
_ -> Nothing)
|
||||
decls
|
||||
classes =
|
||||
|
@ -75,15 +75,16 @@ import Duet.Types
|
||||
-- ["id :: forall a0. a0 -> a0"]
|
||||
--
|
||||
-- Throws 'InferException' in case of a type error.
|
||||
typeCheckModule
|
||||
:: (MonadThrow m, Show l)
|
||||
typeCheckModule ::
|
||||
(MonadThrow m, Show l)
|
||||
=> Map Name (Class Type Name l) -- ^ Set of defined type-classes.
|
||||
-> [(TypeSignature Type Name Name)] -- ^ Pre-defined type signatures e.g. for built-ins or FFI.
|
||||
-> SpecialTypes Name -- ^ Special types that Haskell uses for pattern matching and literals.
|
||||
-> [BindGroup Type Name l] -- ^ Bindings in the module.
|
||||
-> m ([BindGroup Type Name (TypeSignature Type Name l)], Map Name (Class Type Name (TypeSignature Type Name l)))
|
||||
-> [Binding Type Name l] -- ^ Bindings in the module.
|
||||
-> m ( [BindGroup Type Name (TypeSignature Type Name l)]
|
||||
, Map Name (Class Type Name (TypeSignature Type Name l)))
|
||||
typeCheckModule ce as specialTypes bgs0 = do
|
||||
(bgs, classes) <- runTypeChecker bgs0
|
||||
(bgs, classes) <- runTypeChecker (dependencyAnalysis bgs0)
|
||||
pure (bgs, classes)
|
||||
where
|
||||
runTypeChecker bgs =
|
||||
@ -100,6 +101,12 @@ typeCheckModule ce as specialTypes bgs0 = do
|
||||
return (bgsFinal, ce'))
|
||||
(InferState nullSubst 0 specialTypes)
|
||||
|
||||
-- | Sort the list of bindings by order of no-dependencies first
|
||||
-- followed by things that depend on them. Group bindings that are
|
||||
-- mutually recursive.
|
||||
dependencyAnalysis :: [Binding t Name l] -> [BindGroup t Name l]
|
||||
dependencyAnalysis = undefined
|
||||
|
||||
collectMethods
|
||||
:: MonadThrow m
|
||||
=> [BindGroup Type Name (TypeSignature Type Name l)]
|
||||
|
@ -542,27 +542,24 @@ varfundeclExplicit =
|
||||
e <- expParser
|
||||
_ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
|
||||
pure
|
||||
( BindGroupDecl loc
|
||||
(BindGroup
|
||||
[ (ExplicitlyTypedBinding
|
||||
(Identifier (T.unpack v))
|
||||
scheme
|
||||
[makeAlt loc e])
|
||||
]
|
||||
[[]]))
|
||||
(BindDecl
|
||||
loc
|
||||
(ExplicitBinding
|
||||
(ExplicitlyTypedBinding
|
||||
(Identifier (T.unpack v))
|
||||
scheme
|
||||
[makeAlt loc e])))
|
||||
Equals -> do
|
||||
e <- expParser
|
||||
_ <- (pure () <* satisfyToken (== NonIndentedNewline)) <|> endOfTokens
|
||||
pure
|
||||
(BindGroupDecl loc
|
||||
(BindGroup
|
||||
[]
|
||||
[ [ ImplicitlyTypedBinding
|
||||
loc
|
||||
(Identifier (T.unpack v0), loc)
|
||||
[makeAlt loc e]
|
||||
]
|
||||
]))
|
||||
(BindDecl
|
||||
loc
|
||||
(ImplicitBinding
|
||||
(ImplicitlyTypedBinding
|
||||
loc
|
||||
(Identifier (T.unpack v0), loc)
|
||||
[makeAlt loc e])))
|
||||
t -> unexpected (tokenStr t)
|
||||
|
||||
|
||||
|
@ -19,6 +19,7 @@
|
||||
|
||||
module Duet.Renamer
|
||||
( renameDataTypes
|
||||
, renameBindings
|
||||
, renameBindGroups
|
||||
, renameExpression
|
||||
, renameClass
|
||||
@ -439,7 +440,7 @@ renameBindGroups
|
||||
-> [DataType Type Name]
|
||||
-> [BindGroup UnkindedType i l]
|
||||
-> m ([BindGroup Type Name l], Map Identifier Name)
|
||||
renameBindGroups specials subs types groups = do
|
||||
renameBindGroups specials subs types groups = do
|
||||
subs' <-
|
||||
fmap
|
||||
mconcat
|
||||
@ -448,9 +449,40 @@ renameBindGroups specials subs types groups = do
|
||||
implicit' <- getImplicitSubs subs implicit
|
||||
explicit' <- getExplicitSubs subs explicit
|
||||
pure (explicit' <> implicit'))
|
||||
groups
|
||||
)
|
||||
fmap (second mconcat . unzip) (mapM (renameBindGroup specials subs' types) groups)
|
||||
groups)
|
||||
fmap
|
||||
(second mconcat . unzip)
|
||||
(mapM (renameBindGroup specials subs' types) groups)
|
||||
|
||||
renameBindings
|
||||
:: (MonadSupply Int m, MonadThrow m, Ord i, Identifiable i, Typish (t i))
|
||||
=> Specials Name
|
||||
-> Map Identifier Name
|
||||
-> [DataType Type Name]
|
||||
-> [Binding t i l]
|
||||
-> m ([Binding Type Name l], Map Identifier Name)
|
||||
renameBindings specials subs types bindings = do
|
||||
subs' <-
|
||||
fmap
|
||||
((<> subs) . M.fromList)
|
||||
(mapM
|
||||
(\case
|
||||
ExplicitBinding (ExplicitlyTypedBinding i _ _) -> do
|
||||
v <- identifyValue i
|
||||
fmap (v, ) (supplyValueName i)
|
||||
ImplicitBinding (ImplicitlyTypedBinding _ (i, _) _) -> do
|
||||
v <- identifyValue i
|
||||
fmap (v, ) (supplyValueName i))
|
||||
bindings)
|
||||
bindings' <-
|
||||
mapM
|
||||
(\case
|
||||
ExplicitBinding e ->
|
||||
ExplicitBinding <$> renameExplicit specials subs' types e
|
||||
ImplicitBinding i ->
|
||||
ImplicitBinding <$> renameImplicit specials subs' types i)
|
||||
bindings
|
||||
pure (bindings', subs')
|
||||
|
||||
renameBindGroup
|
||||
:: (MonadSupply Int m, MonadThrow m, Ord i, Identifiable i, Typish (t i))
|
||||
@ -490,7 +522,6 @@ getExplicitSubs subs explicit =
|
||||
(mapM
|
||||
(\(ExplicitlyTypedBinding i _ _) -> do
|
||||
v <- identifyValue i
|
||||
|
||||
fmap (v, ) (supplyValueName i))
|
||||
explicit)
|
||||
|
||||
|
@ -34,16 +34,25 @@ instance ( ToJSON l, ToJSON i, ToJSON (t i)) => ToJSON (Decl t i l)
|
||||
instance (Ord i, ToJSON i, FromJSON l, FromJSON i, FromJSON (t i)) => FromJSON (Decl t i l)
|
||||
data Decl t i l
|
||||
= DataDecl l (DataType t i)
|
||||
| BindGroupDecl l (BindGroup t i l)
|
||||
-- | BindGroupDecl l (BindGroup t i l)
|
||||
| BindDecl l (Binding t i l)
|
||||
| ClassDecl l (Class t i l)
|
||||
| InstanceDecl l (Instance t i l)
|
||||
deriving (Show, Generic, Data, Typeable)
|
||||
|
||||
instance (NFData l, NFData i, NFData (t i)) => NFData (Binding t i l)
|
||||
instance (ToJSON l, ToJSON i, ToJSON (t i)) => ToJSON (Binding t i l)
|
||||
instance (Ord i, ToJSON i, FromJSON l, FromJSON i, FromJSON (t i)) => FromJSON (Binding t i l)
|
||||
data Binding t i l
|
||||
= ImplicitBinding (ImplicitlyTypedBinding t i l)
|
||||
| ExplicitBinding (ExplicitlyTypedBinding t i l)
|
||||
deriving (Show, Generic, Data, Typeable)
|
||||
|
||||
declLabel :: Decl t i l -> l
|
||||
declLabel =
|
||||
\case
|
||||
DataDecl l _ -> l
|
||||
BindGroupDecl l _ -> l
|
||||
BindDecl l _ -> l
|
||||
ClassDecl l _ -> l
|
||||
InstanceDecl l _ -> l
|
||||
|
||||
|
@ -56,28 +56,22 @@ makeState ident expr =
|
||||
, stateAST =
|
||||
ModuleNode
|
||||
(Label (Flux.Persist.UUID "STARTER-MODULE"))
|
||||
[ BindGroupDecl
|
||||
[ BindDecl
|
||||
(Label {labelUUID = uuidD})
|
||||
(BindGroup
|
||||
{ bindGroupImplicitlyTypedBindings =
|
||||
[ [ ImplicitlyTypedBinding
|
||||
{ implicitlyTypedBindingLabel =
|
||||
Label (Flux.Persist.UUID "STARTER-BINDING")
|
||||
, implicitlyTypedBindingId =
|
||||
(Identifier ident, Label uuidI)
|
||||
, implicitlyTypedBindingAlternatives =
|
||||
[ Alternative
|
||||
{ alternativeLabel =
|
||||
Label (Flux.Persist.UUID "STARTER-ALT")
|
||||
, alternativePatterns = []
|
||||
, alternativeExpression = expr
|
||||
}
|
||||
]
|
||||
}
|
||||
]
|
||||
]
|
||||
, bindGroupExplicitlyTypedBindings = []
|
||||
})
|
||||
(ImplicitBinding
|
||||
(ImplicitlyTypedBinding
|
||||
{ implicitlyTypedBindingLabel =
|
||||
Label (Flux.Persist.UUID "STARTER-BINDING")
|
||||
, implicitlyTypedBindingId = (Identifier ident, Label uuidI)
|
||||
, implicitlyTypedBindingAlternatives =
|
||||
[ Alternative
|
||||
{ alternativeLabel =
|
||||
Label (Flux.Persist.UUID "STARTER-ALT")
|
||||
, alternativePatterns = []
|
||||
, alternativeExpression = expr
|
||||
}
|
||||
]
|
||||
}))
|
||||
]
|
||||
}
|
||||
where
|
||||
|
@ -88,23 +88,18 @@ newBindDecl = do
|
||||
expr <- newExpression
|
||||
pure
|
||||
( implicitBindingId
|
||||
, BindGroupDecl
|
||||
, BindDecl
|
||||
bgd
|
||||
(BindGroup
|
||||
{ bindGroupImplicitlyTypedBindings =
|
||||
[ [ ImplicitlyTypedBinding
|
||||
{ implicitlyTypedBindingLabel = implicitBinding
|
||||
, implicitlyTypedBindingId =
|
||||
(Identifier "_", Label implicitBindingId)
|
||||
, implicitlyTypedBindingAlternatives =
|
||||
[ Alternative
|
||||
{ alternativeLabel = alternativeId
|
||||
, alternativePatterns = []
|
||||
, alternativeExpression = expr
|
||||
}
|
||||
]
|
||||
}
|
||||
]
|
||||
]
|
||||
, bindGroupExplicitlyTypedBindings = []
|
||||
}))
|
||||
(ImplicitBinding
|
||||
(ImplicitlyTypedBinding
|
||||
{ implicitlyTypedBindingLabel = implicitBinding
|
||||
, implicitlyTypedBindingId =
|
||||
(Identifier "_", Label implicitBindingId)
|
||||
, implicitlyTypedBindingAlternatives =
|
||||
[ Alternative
|
||||
{ alternativeLabel = alternativeId
|
||||
, alternativePatterns = []
|
||||
, alternativeExpression = expr
|
||||
}
|
||||
]
|
||||
})))
|
||||
|
@ -308,7 +308,7 @@ interpretBackspace cursor ast = do
|
||||
l
|
||||
(filter
|
||||
(\case
|
||||
BindGroupDecl _ (BindGroup _ [[ImplicitlyTypedBinding _ (_, il) _]]) ->
|
||||
BindDecl _ (ImplicitBinding (ImplicitlyTypedBinding _ (_, il) _)) ->
|
||||
labelUUID il /= cursorUUID cursor
|
||||
_ -> False)
|
||||
decls))
|
||||
@ -811,16 +811,12 @@ findNodeParent uuid = goNode Nothing
|
||||
if labelUUID (declLabel d) == uuid
|
||||
then mparent
|
||||
else case d of
|
||||
BindGroupDecl _ (BindGroup _ im) ->
|
||||
foldr
|
||||
(<|>)
|
||||
Nothing
|
||||
(map (foldr (<|>) Nothing) (map (map (goIm (Just (DeclNode d)))) im))
|
||||
BindDecl _ (ImplicitBinding im) -> goIm (Just (DeclNode d)) im
|
||||
_ -> Nothing
|
||||
goIm mparent (ImplicitlyTypedBinding l _ alts) =
|
||||
if labelUUID l == uuid
|
||||
then mparent
|
||||
else foldr (<|>) Nothing (map (goAlt mparent) alts)
|
||||
then mparent
|
||||
else foldr (<|>) Nothing (map (goAlt mparent) alts)
|
||||
goAlt mparent (Alternative _ _ e) = go mparent e
|
||||
goCaseAlt mparent ca@(CaseAlt l p e) =
|
||||
if labelUUID l == uuid
|
||||
@ -946,15 +942,11 @@ transformNode uuid f = goNode Nothing
|
||||
DeclNode d' -> pure d'
|
||||
_ -> pure d
|
||||
else case d of
|
||||
BindGroupDecl l (BindGroup ex im) ->
|
||||
BindGroupDecl l <$>
|
||||
(BindGroup ex <$>
|
||||
mapM
|
||||
(mapM
|
||||
(\(ImplicitlyTypedBinding l' i alts) ->
|
||||
ImplicitlyTypedBinding l' <$> goBinding (Just l') i <*>
|
||||
mapM (goAlt (Just l')) alts))
|
||||
im)
|
||||
BindDecl l (ImplicitBinding (ImplicitlyTypedBinding l' i alts)) ->
|
||||
BindDecl l <$>
|
||||
(ImplicitBinding <$>
|
||||
(ImplicitlyTypedBinding l' <$> goBinding (Just l') i <*>
|
||||
mapM (goAlt (Just l')) alts))
|
||||
_ -> pure d
|
||||
goAlt mparent (Alternative l ps e) =
|
||||
Alternative l <$> mapM (goPat mparent) ps <*> go mparent e
|
||||
|
@ -41,58 +41,47 @@ lhsTests =
|
||||
, stateAST =
|
||||
ModuleNode
|
||||
(Label {labelUUID = UUID "STARTER-MODULE"})
|
||||
[ BindGroupDecl
|
||||
[ BindDecl
|
||||
(Label {labelUUID = UUID "STARTER-DECL"})
|
||||
(BindGroup
|
||||
{ bindGroupExplicitlyTypedBindings = []
|
||||
, bindGroupImplicitlyTypedBindings =
|
||||
[ [ ImplicitlyTypedBinding
|
||||
{ implicitlyTypedBindingLabel =
|
||||
Label {labelUUID = UUID "STARTER-BINDING"}
|
||||
, implicitlyTypedBindingId =
|
||||
( Identifier {identifierString = "_"}
|
||||
, Label {labelUUID = UUID "STARTER-BINDING-ID"})
|
||||
, implicitlyTypedBindingAlternatives =
|
||||
[ Alternative
|
||||
{ alternativeLabel =
|
||||
Label {labelUUID = UUID "STARTER-ALT"}
|
||||
, alternativePatterns = []
|
||||
, alternativeExpression =
|
||||
ConstantExpression
|
||||
(Label {labelUUID = UUID "STARTER-EXPR"})
|
||||
(Identifier {identifierString = "_"})
|
||||
}
|
||||
]
|
||||
}
|
||||
]
|
||||
]
|
||||
})
|
||||
, BindGroupDecl
|
||||
(ImplicitBinding
|
||||
(ImplicitlyTypedBinding
|
||||
{ implicitlyTypedBindingLabel =
|
||||
Label {labelUUID = UUID "STARTER-BINDING"}
|
||||
, implicitlyTypedBindingId =
|
||||
( Identifier {identifierString = "_"}
|
||||
, Label {labelUUID = UUID "STARTER-BINDING-ID"})
|
||||
, implicitlyTypedBindingAlternatives =
|
||||
[ Alternative
|
||||
{ alternativeLabel =
|
||||
Label {labelUUID = UUID "STARTER-ALT"}
|
||||
, alternativePatterns = []
|
||||
, alternativeExpression =
|
||||
ConstantExpression
|
||||
(Label {labelUUID = UUID "STARTER-EXPR"})
|
||||
(Identifier {identifierString = "_"})
|
||||
}
|
||||
]
|
||||
}))
|
||||
, BindDecl
|
||||
(Label {labelUUID = UUID "1"})
|
||||
(BindGroup
|
||||
{ bindGroupExplicitlyTypedBindings = []
|
||||
, bindGroupImplicitlyTypedBindings =
|
||||
[ [ ImplicitlyTypedBinding
|
||||
{ implicitlyTypedBindingLabel =
|
||||
Label {labelUUID = UUID "2"}
|
||||
, implicitlyTypedBindingId =
|
||||
( Identifier {identifierString = "_"}
|
||||
, Label {labelUUID = UUID "3"})
|
||||
, implicitlyTypedBindingAlternatives =
|
||||
[ Alternative
|
||||
{ alternativeLabel =
|
||||
Label {labelUUID = UUID "4"}
|
||||
, alternativePatterns = []
|
||||
, alternativeExpression =
|
||||
ConstantExpression
|
||||
(Label {labelUUID = UUID "5"})
|
||||
(Identifier {identifierString = "_"})
|
||||
}
|
||||
]
|
||||
}
|
||||
]
|
||||
]
|
||||
})
|
||||
(ImplicitBinding
|
||||
(ImplicitlyTypedBinding
|
||||
{ implicitlyTypedBindingLabel =
|
||||
Label {labelUUID = UUID "2"}
|
||||
, implicitlyTypedBindingId =
|
||||
( Identifier {identifierString = "_"}
|
||||
, Label {labelUUID = UUID "3"})
|
||||
, implicitlyTypedBindingAlternatives =
|
||||
[ Alternative
|
||||
{ alternativeLabel = Label {labelUUID = UUID "4"}
|
||||
, alternativePatterns = []
|
||||
, alternativeExpression =
|
||||
ConstantExpression
|
||||
(Label {labelUUID = UUID "5"})
|
||||
(Identifier {identifierString = "_"})
|
||||
}
|
||||
]
|
||||
}))
|
||||
]
|
||||
})
|
||||
]
|
||||
|
@ -5,10 +5,8 @@
|
||||
module Duet.IDE.Types where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Exception
|
||||
import Data.Aeson
|
||||
import Data.Data
|
||||
import Duet.Context
|
||||
import Duet.Types
|
||||
import GHC.Generics
|
||||
import React.Flux.Persist (UUID)
|
||||
|
@ -28,7 +28,7 @@ renderModule cursor node = do
|
||||
(Flux.elemText
|
||||
(T.pack
|
||||
(case node of
|
||||
DeclNode (BindGroupDecl _ (BindGroup _ [[i]])) ->
|
||||
DeclNode (BindDecl _ (ImplicitBinding i)) ->
|
||||
printImplicitlyTypedBinding defaultPrint i
|
||||
_ -> "Nothing available to print.")))))
|
||||
when
|
||||
@ -62,12 +62,12 @@ renderOperator mcursor l op =
|
||||
renderDecl :: Cursor -> Decl UnkindedType Identifier Label -> ReactElementM ViewEventHandler ()
|
||||
renderDecl cursor =
|
||||
\case
|
||||
BindGroupDecl label (BindGroup _ex implicit) ->
|
||||
BindDecl label (ImplicitBinding implicit) ->
|
||||
renderWrap
|
||||
cursor
|
||||
label
|
||||
"duet-bind-group duet-declaration"
|
||||
(mapM_ (mapM_ (renderImplicitBinding cursor)) implicit)
|
||||
"duet-declaration"
|
||||
(renderImplicitBinding cursor implicit)
|
||||
_ -> pure ()
|
||||
|
||||
renderImplicitBinding :: Cursor -> ImplicitlyTypedBinding UnkindedType Identifier Label -> ReactElementM ViewEventHandler ()
|
||||
|
Loading…
Reference in New Issue
Block a user