Support functions on generic types

.github/workflows/cabal-in-nix-shell.yml

@@ -8,7 +8,7 @@ jobs:
   build_init:
     strategy:
       matrix:
-        os: [ubuntu-22.04, ubuntu-20.04, macos-13, macos-14] # TODO: add macos-15 once "Install Nix"-step works
+        os: [ubuntu-22.04, macos-13, macos-14] # TODO: add macos-15 once "Install Nix"-step works
       fail-fast: false
     runs-on: ${{ matrix.os }}
     steps:

.github/workflows/nix-build.yml

@@ -8,14 +8,13 @@ jobs:
   nix-build:
     strategy:
       matrix:
-        os: [ubuntu-22.04, ubuntu-20.04, macos-13, macos-14] # TODO: add macos-15 once "Install Nix"-step works
+        os: [ubuntu-22.04, macos-13, macos-14] # TODO: add macos-15 once "Install Nix"-step works
     runs-on: ${{ matrix.os }}
     permissions:
       contents: read
       id-token: write
     steps:
       - uses: actions/checkout@v3
       - uses: DeterminateSystems/nix-installer-action@main
-      - uses: DeterminateSystems/magic-nix-cache-action@main
       - run: nix-build
 

cabal.project

@@ -8,7 +8,7 @@ test-show-details: direct
 source-repository-package
     type: git
     location: https://github.com/runeksvendsen/dump-decls.git
-    tag: 496fc63c1279aedcdf7143c5ea85970e63a2ba0a
+    tag: c72964b354aa90c66a209f7b62756926877f3bfd
     subdir: dump-decls-lib
 
 source-repository-package

default.nix

@@ -25,7 +25,7 @@ let
   dump-decls-lib =
     let src = builtins.fetchGit {
       url = "https://github.com/runeksvendsen/dump-decls.git";
-      rev = "496fc63c1279aedcdf7143c5ea85970e63a2ba0a";
+      rev = "c72964b354aa90c66a209f7b62756926877f3bfd";
     };
     in import (src + "/dump-decls-lib") { inherit nixpkgs compiler; };
 

function-graph.cabal

@@ -40,6 +40,8 @@ library
                     , transformers
                     -- FunGraph.Util
                     , lucid
+                    -- TMP debugging
+                    , ansi-terminal
     hs-source-dirs:   src/lib
     default-language: Haskell2010
 

src/lib/FunGraph.hs

@@ -29,7 +29,7 @@ module FunGraph
   -- * Re-exports
   , module Types
   , module Export
-  , Json.FunctionType
+  , Types.FunctionType
   , DG.IDigraph, DG.Digraph
   , NE.NonEmpty
   , DG.freeze, DG.thaw
@@ -38,7 +38,6 @@ module FunGraph
 import FunGraph.Types as Types
 import FunGraph.Util
 import FunGraph.Build as Export
-import qualified Json
 import qualified Data.Graph.Digraph as DG
 import qualified Data.Graph.Dijkstra as Dijkstra
 import Control.Monad.ST (ST, RealWorld)
@@ -337,13 +336,13 @@ traceFunDebugGeneric traceFun = \case
           { _function_name = "toStrict"
           , _function_module = "Data.ByteString"
           , _function_package = parsePackageWithVersion' "bytestring-0.11.4.0"
-          , _function_typeSig = Json.FunctionType () ()
+          , _function_typeSig = Types.FunctionType () ()
           }
       , Function
           { _function_name = "encodeUtf16LE"
           , _function_module = "Data.Text.Lazy.Encoding"
           , _function_package = parsePackageWithVersion' "text-2.0.2"
-          , _function_typeSig = Json.FunctionType () ()
+          , _function_typeSig = Types.FunctionType () ()
           }
       ]
 

src/lib/FunGraph/Build.hs

@@ -27,6 +27,12 @@ import qualified Data.List.NonEmpty as NE
 import qualified Data.Set as Set
 import qualified Types
 import qualified Data.Text as T
+import qualified Types.Doodle
+import qualified Debug.Trace
+import qualified Data.Map as Map
+import Data.Maybe (mapMaybe)
+import Data.Foldable (foldl')
+import qualified System.Console.ANSI as ANSI
 
 type FrozenGraph = DG.IDigraph FullyQualifiedType (NE.NonEmpty TypedFunction)
 type Graph s = DG.Digraph s FullyQualifiedType (NE.NonEmpty TypedFunction)
@@ -97,8 +103,87 @@ buildGraphMut cfg =
         . nubOrdOn functionIdentity -- remove duplicates
         . filter (not . isExcludedFunction) -- remove excluded functions
         . concatMap declarationMapJsonToFunctions
+        . tmpPrintExtendedFunctions
         . filter (not . isExcludedPackage) -- remove excluded packages
 
+tmpPrintExtendedFunctions
+  :: [Json.DeclarationMapJson T.Text]
+  -> [Json.DeclarationMapJson T.Text]
+tmpPrintExtendedFunctions declarationMapJsonLst =
+  traceIt
+    (Types.Doodle.extendFrom monoFuns polyFuns)
+    declarationMapJsonLst
+  where
+    extract
+      :: Json.DeclarationMapJson T.Text
+      -> [(T.Text, Types.Doodle.SomeFunction)] -- (fully qualified name, type). e.g. ("Data.List.head", "[a] -> a")
+    extract =
+        concatMap
+          (\(moduleName, nameToTypeMap) ->
+            let assocs = Map.assocs nameToTypeMap
+                funMetaData (funName, funType) = T.pack $ unlines
+                  [ ("\t" <>) $ color ANSI.Red $ T.unpack $ moduleName <> "." <> funName
+                  , "\t\t" <> " :: " <> color ANSI.Blue (T.unpack $ Types.Doodle.renderSomeFunctionType funType)
+                  ]
+            in map (\(funName, funType) -> (funMetaData (funName, funType), funType)) assocs
+          )
+      . Map.assocs
+      . Json.moduleDeclarations_map
+      . Json.declarationMapJson_moduleDeclarations
+
+    someFunctions = concatMap extract declarationMapJsonLst
+
+    monoFuns :: [(T.Text, Types.FunctionType (FgType (Types.FgTyCon T.Text)))]
+    monoFuns =
+      Data.Maybe.mapMaybe (traverse Types.Doodle.someFunctionMonomorphic) someFunctions
+
+    polyFuns :: [(T.Text, Types.Doodle.FunctionTypeForall T.Text T.Text)]
+    polyFuns =
+      Data.Maybe.mapMaybe (traverse Types.Doodle.someFunctionPolymorphic) someFunctions
+
+    traceIt
+      :: [((T.Text, T.Text), Either String (Types.FunctionType (FgType (Types.FgTyCon T.Text))))]
+      -> ret
+      -> ret
+    traceIt ftl ret = "" `Debug.Trace.trace` foldl'
+      (\() blah -> mkTraceString blah `Debug.Trace.trace` ())
+      ()
+      ftl `seq` ret
+
+    mkTraceString ((monoName, polyName), eTypedFunction) =
+      let resultType =
+            either
+              ("ERROR: " <>)
+              (\ft -> ":: " <> color ANSI.Blue (T.unpack (renderFunctionType ft)))
+              eTypedFunction
+      in
+      unlines
+        [ "Extending from"
+        , T.unpack monoName
+        , "\t" <> "with"
+        , T.unpack polyName
+        , "\t" <> "resulting in"
+        , "\t\t" <> resultType
+        , ""
+        ]
+
+    color :: ANSI.Color -> String -> String
+    color color' str = concat
+      [ ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull color']
+      , str
+      , ANSI.setSGRCode [ANSI.Reset]
+      ]
+
+    renderFunctionType
+      :: Types.FunctionType (FgType (Types.FgTyCon T.Text))
+      -> T.Text
+    renderFunctionType ft =
+      T.unwords
+        [ Types.renderFgTypeFgTyConQualifiedNoPackage $ Types.functionType_arg ft
+        , "->"
+        , Types.renderFgTypeFgTyConQualifiedNoPackage $ Types.functionType_ret ft
+        ]
+
 -- | Excludes various preludes and internal modules
 defaultBuildConfig :: BuildConfig
 defaultBuildConfig = BuildConfig

src/lib/FunGraph/Examples.hs

@@ -29,5 +29,5 @@ string =
   (str, "String")
   where
     str = FunGraph.parsePprTyConMulti $
-      FunGraph.FgType_List $
+      FunGraph.FgType_List $ Just $
         FunGraph.FgType_TyConApp "ghc-prim-0.10.0:GHC.Types.Char" []

src/lib/FunGraph/Types.hs

@@ -14,7 +14,7 @@ module FunGraph.Types
   , renderComposedFunctions
   , renderComposedFunctionsStr
   , parseComposedFunctions, parseComposedFunctionsNoPackage
-  , renderFunction, renderFunctionNoPackage, functionToHackageDocsUrl
+  , renderFunction, renderFunctionNoPackage, renderTypedFunction, renderFunctionTypeSig, functionToHackageDocsUrl
   , typedFunctionFromToTypes
   , parseIdentifier, parseFunction, parseFunctionNoPackage
   , fqtPackage
@@ -38,7 +38,6 @@ import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
 import Control.DeepSeq (NFData)
 import qualified Types
-import Data.Maybe (fromMaybe)
 import GHC.Stack (HasCallStack)
 import qualified Data.Hashable.Generic
 
@@ -126,6 +125,22 @@ renderFunctionNoPackage :: Function typeSig -> T.Text
 renderFunctionNoPackage fn =
   _function_module fn <> "." <> _function_name fn
 
+renderTypedFunction
+  :: TypedFunction
+  -> T.Text
+renderTypedFunction tp =
+  renderFunctionTypeSig $ _function_typeSig tp
+
+renderFunctionTypeSig
+  :: Types.FunctionType FullyQualifiedType
+  -> T.Text
+renderFunctionTypeSig typeSig =
+  T.unwords
+    [ renderFullyQualifiedType $ Types.functionType_arg typeSig
+    , "->"
+    , renderFullyQualifiedType $ Types.functionType_ret typeSig
+    ]
+
 -- | Render as URL to Hackage documentation.
 --
 -- Examples:
@@ -165,7 +180,7 @@ typedFunctionFromToTypes
   -> (FullyQualifiedType, FullyQualifiedType)
   -- ^ (FROM type, TO type)
 typedFunctionFromToTypes fn =
-  (Json.functionType_arg sig, Json.functionType_ret sig)
+  (Types.functionType_arg sig, Types.functionType_ret sig)
   where
     sig = _function_typeSig fn
 
@@ -207,7 +222,7 @@ parseIdentifier txt = do
   pure (name, moduleName, package)
 
 -- | A typed 'Function'
-type TypedFunction = Function (Json.FunctionType FullyQualifiedType)
+type TypedFunction = Function (Types.FunctionType FullyQualifiedType)
 
 -- | A untyped 'Function'
 type UntypedFunction = Function ()
@@ -227,10 +242,7 @@ instance Show PrettyTypedFunction where
           , "."
           , _function_name fun
           ] ++
-            let sig = _function_typeSig fun
-                arg = unFullyQualifiedType $ Json.functionType_arg sig
-                ret = unFullyQualifiedType $ Json.functionType_ret sig
-            in [" :: ", Types.renderFgTypeFgTyConQualified arg, " -> ", Types.renderFgTypeFgTyConQualified ret]
+          [" :: ", renderTypedFunction fun]
 
 newtype FullyQualifiedType = FullyQualifiedType
   { unFullyQualifiedType :: Types.FgType (Types.FgTyCon T.Text) }
@@ -293,16 +305,15 @@ declarationMapJsonToFunctions
   -> [TypedFunction]
 declarationMapJsonToFunctions dmj = concat $
   Map.toList moduleDeclarations <&> \(moduleName, nameMap) ->
-    Map.toList nameMap <&> \(functionName, typeInfo) ->
-      Function functionName moduleName package (FullyQualifiedType <$> typeInfoToFunctionType typeInfo)
+    Map.toList nameMap <&> \(functionName, functionType) ->
+      Function functionName moduleName package (FullyQualifiedType <$> error "WIP" ) -- functionType
   where
-    typeInfoToFunctionType ti = fromMaybe (Json.typeInfo_unexpanded ti) (Json.typeInfo_expanded ti)
     moduleDeclarations = Json.moduleDeclarations_map (Json.declarationMapJson_moduleDeclarations dmj)
     package = Json.declarationMapJson_package dmj
 
 instance DG.DirectedEdge TypedFunction FullyQualifiedType TypedFunction where
-  fromNode = Json.functionType_arg . _function_typeSig
-  toNode = Json.functionType_ret . _function_typeSig
+  fromNode = Types.functionType_arg . _function_typeSig
+  toNode = Types.functionType_ret . _function_typeSig
   metaData = id
 
 -- | Parse a type constructor of zero arity, ie. one that is not applied to any type(s).

src/lib/FunGraph/Util.hs

@@ -14,7 +14,6 @@ module FunGraph.Util
   where
 
 import FunGraph.Types
-import qualified Json
 import qualified Data.Graph.Digraph as DG
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BSC8
@@ -47,8 +46,8 @@ toPathTypes getTo getFrom = \case
 -- | 'toPathTypes' specialized to 'TypedFunction'
 typedFunctionsPathTypes :: [TypedFunction] -> [FullyQualifiedType]
 typedFunctionsPathTypes = toPathTypes
-  (Json.functionType_ret . _function_typeSig)
-  (Json.functionType_arg . _function_typeSig)
+  (Types.functionType_ret . _function_typeSig)
+  (Types.functionType_arg . _function_typeSig)
 
 -- | 'toPathTypes' specialized to 'DG.IdxEdge FullyQualifiedType (NE.NonEmpty TypedFunction)'
 idxEdgePathTypes

src/server/Server/Pages/Search.hs

@@ -358,13 +358,10 @@ page cfg searchEnv src dst maxCount' mNoGraph = do
     renderResult :: ([FunGraph.TypedFunction], Word) -> Html ()
     renderResult (fns, resultNumber) =
       let renderSingleFn fn =
-            let (fromTy, toTy) = FunGraph.typedFunctionFromToTypes fn
-                typeSig = T.unwords
+            let typeSig = T.unwords
                   [ FunGraph.renderFunction fn
                   , "::"
-                  , FunGraph.fullyQualifiedTypeToText fromTy
-                  , "->"
-                  , FunGraph.fullyQualifiedTypeToText toTy
+                  , FunGraph.renderTypedFunction fn
                   ]
                 functionNameWithLink :: Html ()
                 functionNameWithLink = a_

src/test/FunGraph/Test.hs

@@ -197,7 +197,7 @@ case5 =
     stringTemplate = FunGraph.parsePprTyConMulti $
       FunGraph.FgType_TyConApp
         "HStringTemplate-0.8.8:Text.StringTemplate.Base.StringTemplate"
-        [FunGraph.FgType_List $ FunGraph.FgType_TyConApp "ghc-prim-0.10.0:GHC.Types.Char" []]
+        [FunGraph.FgType_List $ Just $ FunGraph.FgType_TyConApp "ghc-prim-0.10.0:GHC.Types.Char" []]
 
 -- Also a slow web query (~20s) with maxCount=100
 case6 :: QueryTest

src/test/FunGraph/Test/Util.hs

@@ -42,7 +42,7 @@ import Test.Hspec.Expectations.Pretty (shouldBe)
 import Lucid.Base (Html)
 
 testDataFileName :: FilePath
-testDataFileName = "data/all3.json"
+testDataFileName = "data/new-forall.json"
 
 isSupersetOf :: (Show a, Ord a) => Set.Set a -> Set.Set a -> IO ()
 isSupersetOf actual expected =

test/prop/Spec/PrioTrie.hs

@@ -22,7 +22,7 @@ import Test.QuickCheck (arbitrary, forAll)
 setup :: IO (Data.PrioTrie.PrioTrie Word FunGraph.FullyQualifiedType)
 setup = do
   putStrLn "Constructing priority trie..."
-  graphData <- getDataFileName "data/all3.json" >>= FunGraph.fileReadDeclarationMap >>= either fail pure
+  graphData <- getDataFileName "data/new-forall.json" >>= FunGraph.fileReadDeclarationMap >>= either fail pure
   graph <- ST.stToIO $ FunGraph.buildGraphMut FunGraph.defaultBuildConfig graphData
   prioTrie <- Server.Pages.Typeahead.mkPrioTrie Nothing graph >>= maybe (fail "empty graph data file") pure
   prioTrie' <- Ex.evaluate $ Control.DeepSeq.force prioTrie