WIP: Dependency analysis

2024-10-26 11:30:19 +03:00 · 2017-12-17 17:50:02 +00:00 · 2017-12-17 17:50:02 +00:00 · f8cd1ad7be
commit f8cd1ad7be
parent 44e699c198
11 changed files with 157 additions and 145 deletions
--- 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 =
--- 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)]
--- 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)


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

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

--- 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
--- 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
+                  }
+                ]
+            })))
--- 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
--- 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 = "_"})
+                           }
+                         ]
+                     }))
             ]
       })
  ]
--- 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)
--- 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 ()