From f8cd1ad7be081d2d4158afb612689eeaeb2f6fb4 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Sun, 17 Dec 2017 17:50:02 +0000 Subject: [PATCH] WIP: Dependency analysis --- src/Duet/Context.hs | 6 +-- src/Duet/Infer.hs | 17 +++++-- src/Duet/Parser.hs | 31 ++++++------- src/Duet/Renamer.hs | 41 +++++++++++++++-- src/Duet/Types.hs | 13 +++++- web/Duet/IDE.hs | 36 ++++++--------- web/Duet/IDE/Constructors.hs | 33 ++++++------- web/Duet/IDE/Interpreters.hs | 26 ++++------- web/Duet/IDE/Spec.hs | 89 ++++++++++++++++-------------------- web/Duet/IDE/Types.hs | 2 - web/Duet/IDE/View.hs | 8 ++-- 11 files changed, 157 insertions(+), 145 deletions(-) diff --git a/src/Duet/Context.hs b/src/Duet/Context.hs index c1b9e1a..3d3c5d8 100644 --- a/src/Duet/Context.hs +++ b/src/Duet/Context.hs @@ -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 = diff --git a/src/Duet/Infer.hs b/src/Duet/Infer.hs index df41fad..082063d 100644 --- a/src/Duet/Infer.hs +++ b/src/Duet/Infer.hs @@ -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)] diff --git a/src/Duet/Parser.hs b/src/Duet/Parser.hs index 0802858..7c67734 100644 --- a/src/Duet/Parser.hs +++ b/src/Duet/Parser.hs @@ -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) diff --git a/src/Duet/Renamer.hs b/src/Duet/Renamer.hs index eae6111..5701c51 100644 --- a/src/Duet/Renamer.hs +++ b/src/Duet/Renamer.hs @@ -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) diff --git a/src/Duet/Types.hs b/src/Duet/Types.hs index 686f9ee..822a16d 100644 --- a/src/Duet/Types.hs +++ b/src/Duet/Types.hs @@ -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 diff --git a/web/Duet/IDE.hs b/web/Duet/IDE.hs index 49dbec1..4d89693 100644 --- a/web/Duet/IDE.hs +++ b/web/Duet/IDE.hs @@ -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 diff --git a/web/Duet/IDE/Constructors.hs b/web/Duet/IDE/Constructors.hs index a9a2137..c95e505 100644 --- a/web/Duet/IDE/Constructors.hs +++ b/web/Duet/IDE/Constructors.hs @@ -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 + } + ] + }))) diff --git a/web/Duet/IDE/Interpreters.hs b/web/Duet/IDE/Interpreters.hs index 60053b2..61573d9 100644 --- a/web/Duet/IDE/Interpreters.hs +++ b/web/Duet/IDE/Interpreters.hs @@ -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 diff --git a/web/Duet/IDE/Spec.hs b/web/Duet/IDE/Spec.hs index f99426a..6d3b1bb 100644 --- a/web/Duet/IDE/Spec.hs +++ b/web/Duet/IDE/Spec.hs @@ -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 = "_"}) + } + ] + })) ] }) ] diff --git a/web/Duet/IDE/Types.hs b/web/Duet/IDE/Types.hs index c685421..4b44df1 100644 --- a/web/Duet/IDE/Types.hs +++ b/web/Duet/IDE/Types.hs @@ -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) diff --git a/web/Duet/IDE/View.hs b/web/Duet/IDE/View.hs index 31e0ace..b2e0ace 100644 --- a/web/Duet/IDE/View.hs +++ b/web/Duet/IDE/View.hs @@ -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 ()