🌅

.github/workflows/haskell-ci.yml

@@ -0,0 +1,212 @@
+# This GitHub workflow config has been generated by a script via
+#
+#   haskell-ci 'github' 'cabal.project'
+#
+# To regenerate the script (for example after adjusting tested-with) run
+#
+#   haskell-ci regenerate
+#
+# For more information, see https://github.com/haskell-CI/haskell-ci
+#
+# version: 0.13.20211226
+#
+# REGENDATA ("0.13.20211226",["github","cabal.project"])
+#
+name: Haskell-CI
+on:
+  push:
+    branches:
+      - master
+  pull_request:
+    branches:
+      - master
+jobs:
+  linux:
+    name: Haskell-CI - Linux - ${{ matrix.compiler }}
+    runs-on: ubuntu-18.04
+    timeout-minutes:
+      60
+    container:
+      image: buildpack-deps:bionic
+    continue-on-error: ${{ matrix.allow-failure }}
+    strategy:
+      matrix:
+        include:
+          - compiler: ghc-9.0.1
+            compilerKind: ghc
+            compilerVersion: 9.0.1
+            setup-method: hvr-ppa
+            allow-failure: false
+          - compiler: ghc-8.10.7
+            compilerKind: ghc
+            compilerVersion: 8.10.7
+            setup-method: ghcup
+            allow-failure: false
+      fail-fast: false
+    steps:
+      - name: apt
+        run: |
+          apt-get update
+          apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
+          if [ "${{ matrix.setup-method }}" = ghcup ]; then
+            mkdir -p "$HOME/.ghcup/bin"
+            curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"
+            chmod a+x "$HOME/.ghcup/bin/ghcup"
+            "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER"
+            "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
+          else
+            apt-add-repository -y 'ppa:hvr/ghc'
+            apt-get update
+            apt-get install -y "$HCNAME"
+            mkdir -p "$HOME/.ghcup/bin"
+            curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup"
+            chmod a+x "$HOME/.ghcup/bin/ghcup"
+            "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0
+          fi
+        env:
+          HCKIND: ${{ matrix.compilerKind }}
+          HCNAME: ${{ matrix.compiler }}
+          HCVER: ${{ matrix.compilerVersion }}
+      - name: Set PATH and environment variables
+        run: |
+          echo "$HOME/.cabal/bin" >> $GITHUB_PATH
+          echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
+          echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
+          echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
+          HCDIR=/opt/$HCKIND/$HCVER
+          if [ "${{ matrix.setup-method }}" = ghcup ]; then
+            HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
+            echo "HC=$HC" >> "$GITHUB_ENV"
+            echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
+            echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
+            echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+          else
+            HC=$HCDIR/bin/$HCKIND
+            echo "HC=$HC" >> "$GITHUB_ENV"
+            echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
+            echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
+            echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+          fi
+
+          HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
+          echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
+          echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
+          echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
+          echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
+          echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
+          echo "GHCJSARITH=0" >> "$GITHUB_ENV"
+        env:
+          HCKIND: ${{ matrix.compilerKind }}
+          HCNAME: ${{ matrix.compiler }}
+          HCVER: ${{ matrix.compilerVersion }}
+      - name: env
+        run: |
+          env
+      - name: write cabal config
+        run: |
+          mkdir -p $CABAL_DIR
+          cat >> $CABAL_CONFIG <<EOF
+          remote-build-reporting: anonymous
+          write-ghc-environment-files: never
+          remote-repo-cache: $CABAL_DIR/packages
+          logs-dir:          $CABAL_DIR/logs
+          world-file:        $CABAL_DIR/world
+          extra-prog-path:   $CABAL_DIR/bin
+          symlink-bindir:    $CABAL_DIR/bin
+          installdir:        $CABAL_DIR/bin
+          build-summary:     $CABAL_DIR/logs/build.log
+          store-dir:         $CABAL_DIR/store
+          install-dirs user
+            prefix: $CABAL_DIR
+          repository hackage.haskell.org
+            url: http://hackage.haskell.org/
+          EOF
+          cat >> $CABAL_CONFIG <<EOF
+          program-default-options
+            ghc-options: $GHCJOBS +RTS -M3G -RTS
+          EOF
+          cat $CABAL_CONFIG
+      - name: versions
+        run: |
+          $HC --version || true
+          $HC --print-project-git-commit-id || true
+          $CABAL --version || true
+      - name: update cabal index
+        run: |
+          $CABAL v2-update -v
+      - name: install cabal-plan
+        run: |
+          mkdir -p $HOME/.cabal/bin
+          curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz
+          echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc  cabal-plan.xz' | sha256sum -c -
+          xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
+          rm -f cabal-plan.xz
+          chmod a+x $HOME/.cabal/bin/cabal-plan
+          cabal-plan --version
+      - name: checkout
+        uses: actions/checkout@v2
+        with:
+          path: source
+      - name: initial cabal.project for sdist
+        run: |
+          touch cabal.project
+          echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
+          cat cabal.project
+      - name: sdist
+        run: |
+          mkdir -p sdist
+          $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
+      - name: unpack
+        run: |
+          mkdir -p unpacked
+          find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
+      - name: generate cabal.project
+        run: |
+          PKGDIR_hooglite="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/hooglite-[0-9.]*')"
+          echo "PKGDIR_hooglite=${PKGDIR_hooglite}" >> "$GITHUB_ENV"
+          rm -f cabal.project cabal.project.local
+          touch cabal.project
+          touch cabal.project.local
+          echo "packages: ${PKGDIR_hooglite}" >> cabal.project
+          echo "package hooglite" >> cabal.project
+          echo "    ghc-options: -Werror=missing-methods" >> cabal.project
+          cat >> cabal.project <<EOF
+          constraints: ghc-lib-parser-ex -no-ghc-lib -auto
+          EOF
+          $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(Cabal|hooglite)$/; }' >> cabal.project.local
+          cat cabal.project
+          cat cabal.project.local
+      - name: dump install plan
+        run: |
+          $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
+          cabal-plan
+      - name: cache
+        uses: actions/cache@v2
+        with:
+          key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
+          path: ~/.cabal/store
+          restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
+      - name: install dependencies
+        run: |
+          $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
+          $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
+      - name: build w/o tests
+        run: |
+          $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
+      - name: build
+        run: |
+          $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
+      - name: tests
+        run: |
+          $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
+      - name: cabal check
+        run: |
+          cd ${PKGDIR_hooglite} || false
+          ${CABAL} -vnormal check
+      - name: haddock
+        run: |
+          $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
+      - name: unconstrained build
+        run: |
+          rm -f cabal.project.local
+          $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all

.stylish-haskell.yaml

@@ -0,0 +1,18 @@
+steps:
+  - imports:
+      align: group
+      list_align: after_alias
+      long_list_align: new_line
+      empty_list_align: right_after
+      list_padding: module_name
+  - language_pragmas:
+      style: vertical
+      remove_redundant: true
+  - trailing_whitespace: {}
+columns: 120
+language_extensions:
+  - DataKinds
+  - EmptyCase
+  - ExplicitForAll
+  - FlexibleContexts
+  - MultiParamTypeClasses

LICENSE

@@ -0,0 +1,31 @@
+Copyright (c) 2021 Oleg Grenrus
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Don Stewart nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

cabal.haskell-ci

@@ -0,0 +1,2 @@
+branches: master
+installed: +all -Cabal

cabal.project

@@ -0,0 +1,4 @@
+with-compiler: ghc-8.10.4
+packages: .
+
+constraints: ghc-lib-parser-ex -no-ghc-lib -auto

hooglite.cabal

@@ -0,0 +1,105 @@
+cabal-version:      2.4
+name:               hooglite
+version:            0.20211229
+license:            BSD-3-Clause
+license-file:       LICENSE
+category:           Development
+synopsis:           A lite implementation of hoogle
+description:
+  This is like hoogle, but is smaller, containing only core functionality.
+  Uses @ghc-lib-parser@ for parsing.
+
+author:             Oleg Grenrus <oleg.grenrus@iki.fi>
+maintainer:         Oleg Grenrus <oleg.grenrus@iki.fi>
+build-type:         Simple
+tested-with:        GHC ==8.10.7 || ==9.0.1
+extra-source-files: test-data/*.txt
+
+source-repository head
+  type:     git
+  location: https://github.com/phadej/hooglite.git
+
+library
+  default-language:   Haskell2010
+  ghc-options:        -Wall -Wno-unticked-promoted-constructors
+  hs-source-dirs:     src
+
+  -- GHC-boot libraries
+  build-depends:
+    , base        ^>=4.14.1.0 || ^>=4.15.0.0
+    , bytestring  ^>=0.10.12.0 || ^>=0.11.1.0
+    , containers  ^>=0.6.2.1
+    , pretty      ^>=1.1.3.6
+
+  -- Cabal is special
+  build-depends:      Cabal ^>=3.6.2.0
+
+  -- rest of the dependencies
+  build-depends:
+    , bifunctors         ^>=5.5.11
+    , edit-distance      ^>=0.2.2.1
+    , fin                ^>=0.2
+    , ghc-lib-parser     ^>=9.0.1.20210324
+    , ghc-lib-parser-ex  ^>=9.0.0.4
+    , mtl                ^>=2.2.2
+    , text-short         ^>=0.1.4
+    , unification-fd     ^>=0.11.1
+
+  -- Main module
+  exposed-modules:    Hooglite
+  exposed-modules:
+    Hooglite.Database
+    Hooglite.Declaration
+    Hooglite.GHC.Utils
+    Hooglite.Haddock
+    Hooglite.Query
+    Hooglite.Ty
+
+  exposed-modules:
+    Hooglite.MonoPoly
+    Hooglite.MonoPoly.Name
+    Hooglite.MonoPoly.Pretty
+    Hooglite.MonoPoly.Var
+
+  cpp-options:        -DSAFE
+  default-extensions:
+    BangPatterns
+    DataKinds
+    DeriveGeneric
+    DeriveTraversable
+    DerivingStrategies
+    EmptyCase
+    GADTs
+    GeneralizedNewtypeDeriving
+    OverloadedStrings
+    PatternSynonyms
+    QuantifiedConstraints
+    RankNTypes
+    RoleAnnotations
+    ScopedTypeVariables
+    StandaloneDeriving
+    StandaloneKindSignatures
+    TypeApplications
+
+test-suite hooglite-tests
+  default-language: Haskell2010
+  type:             exitcode-stdio-1.0
+  ghc-options:      -Wall -Wno-unticked-promoted-constructors
+  hs-source-dirs:   test
+  main-is:          hooglite-tests.hs
+  other-modules:
+    Hooglite.Test.Database
+    Hooglite.Test.Haddock
+    Hooglite.Test.Query
+
+  build-depends:
+    , base
+    , Cabal
+    , containers
+    , hooglite
+    , mtl
+
+  build-depends:
+    , tasty         ^>=1.4.2.1
+    , tasty-golden  ^>=2.3.4
+    , tasty-hunit   ^>=0.10.0.3

src/Hooglite.hs

@@ -0,0 +1,25 @@
+module Hooglite (
+    -- * Database
+    Database,
+    Entry (..),
+    apiToDatabase,
+    query,
+    -- * Queries
+    Query (..),
+    parseQuery,
+    -- * Parsing hoogle.txt files
+    API (..),
+    apiPackageId,
+    parseHoogleFile,
+    -- * Declarations
+    Declaration (..),
+    declarationSrc,
+    -- * Extras
+    pretty,
+) where
+
+import Hooglite.Database
+import Hooglite.Declaration
+import Hooglite.Haddock
+import Hooglite.MonoPoly.Pretty
+import Hooglite.Query

src/Hooglite/Database.hs

@@ -0,0 +1,114 @@
+module Hooglite.Database (
+    Database,
+    Entry (..),
+    apiToDatabase,
+    query,
+) where
+
+import Control.Monad.EitherK          (EitherKT, runEitherKT)
+import Control.Monad.Trans            (lift)
+import Control.Unification            (UTerm (..), applyBindings, freeVar, unify)
+import Control.Unification.IntVar     (IntBindingT, IntVar, evalIntBindingT)
+import Control.Unification.Types      (UFailure)
+import Data.Char                      (toLower)
+import Data.Either                    (isRight)
+import Data.Functor.Identity          (Identity (..))
+import Data.List                      (isInfixOf)
+import Distribution.ModuleName        (ModuleName)
+import Distribution.Types.PackageName (PackageName)
+import Distribution.Types.Version     (Version)
+
+import qualified Data.Map.Strict     as Map
+import qualified Data.Text.Short     as ST
+import qualified Distribution.Pretty as C
+
+import Hooglite.Declaration
+import Hooglite.Haddock
+import Hooglite.MonoPoly
+import Hooglite.MonoPoly.Name
+import Hooglite.MonoPoly.Pretty
+import Hooglite.MonoPoly.Var
+import Hooglite.Query
+import Hooglite.Ty
+
+-- | Database for query performing.
+data Database = DB
+    { _dbEntries :: [Entry]
+    }
+
+instance Semigroup Database where
+    DB xs <> DB ys = DB (xs <> ys)
+
+instance Monoid Database where
+    mempty = DB []
+
+entriesToDB :: [Entry] -> Database
+entriesToDB = DB
+
+apiToDatabase :: API -> Database
+apiToDatabase (API pn ver modules) = entriesToDB
+    [ Entry pn ver mn name decl
+    | (mn, decls) <- Map.toList modules
+    , (name, decl) <- Map.toList decls
+    ]
+
+data Entry = Entry !PackageName !Version !ModuleName !Name !Declaration
+  deriving Show
+
+instance Pretty Entry where
+    ppr (Entry pn ver mn name decl) =
+        C.pretty pn <+> C.pretty ver <+> C.pretty mn <+> ppr name <+> ppr decl
+
+query :: Database -> Query -> [Entry]
+query (DB _entries) QueryInvalid  =
+    []
+query (DB entries) (QueryName n) =
+    [ e
+    | e@(Entry _pn _ver _mn name _decl) <- entries
+    , let n' = ST.toString (unName name)
+    , map toLower n `isInfixOf` map toLower n'
+    ]
+query (DB entries) (QueryType qty _) =
+    [ e
+    | e@(Entry _pn _ver _mn _name decl) <- entries
+    , case decl of
+        SigD (Just ty) _ -> subsumesTy qty ty
+        ConD (Just ty) _ -> subsumesTy qty ty
+        _                -> False
+    ]
+
+-------------------------------------------------------------------------------
+-- Unification
+-------------------------------------------------------------------------------
+
+type Unify = EitherKT (UFailure (MonoF Z Name) IntVar) (IntBindingT (MonoF Z Name) Identity)
+
+runUnify :: Unify a -> Either (UFailure (MonoF Z Name) IntVar) a
+runUnify m = runIdentity (evalIntBindingT (runEitherKT m))
+
+subsumesTy :: Ty -> Ty -> Bool
+subsumesTy a b = isRight $ runUnify $ do
+    a' <- unwrap  (Left <$> a)
+    b' <- unwrap' (Left <$> b)
+
+    ab <- unify (unroll a') (unroll b')
+    _ab <- applyBindings ab
+    return ()
+
+unwrap :: Poly n (Either f IntVar) -> Unify (Mono n (Either f IntVar) )
+unwrap (Mono a)    = return a
+unwrap (Poly _n a) = do
+    x <- lift freeVar
+    unwrap (instantiate (Free (Right x)) a)
+
+unwrap' :: Poly n (Either Name v) -> Unify (Mono n (Either Name v))
+unwrap' (Mono a)           = return a
+unwrap' (Poly (IName n) a) = do
+    unwrap' (instantiate (Free (Left n)) a)
+
+unroll :: Mono n (Either f IntVar) -> UTerm (MonoF n f) IntVar
+unroll (Var x)          = UTerm (VarF x)
+unroll (Free (Left f))  = UTerm (FreeF f)
+unroll (Free (Right v)) = UVar v
+unroll (App a b)        = UTerm (AppF (unroll a) (unroll b))
+unroll (Arr a b)        = UTerm (ArrF (unroll a) (unroll b))

src/Hooglite/Declaration.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Hooglite.Declaration where
+
+import Control.Monad    (join)
+import GHC.Hs.Extension (GhcPs)
+import GHC.Types.SrcLoc (GenLocated (L))
+
+import qualified GHC.Hs.Binds          as GHC
+import qualified GHC.Hs.Decls          as GHC
+import qualified GHC.Hs.Type           as GHC
+
+import Hooglite.GHC.Utils
+import Hooglite.MonoPoly.Name
+import Hooglite.MonoPoly.Pretty
+import Hooglite.Ty
+
+data Declaration
+    = DataD           String
+    | ClassD          String
+    | SynD            String
+    | FamD            String
+    | ConD (Maybe Ty) String
+    | SigD (Maybe Ty) String
+  deriving Show
+
+instance Pretty Declaration where
+    ppr DataD {}     = "data"
+    ppr ClassD {}    = "class"
+    ppr SynD {}      = "type"
+    ppr FamD {}      = "type family" -- TODO: maybe data family
+    ppr (ConD ty _ ) = "constructor ::" <+> ppr ty
+    ppr (SigD ty _ ) = "signature ::" <+> ppr ty
+
+-- | How GHC's pretty printer thinks about this declaration.
+declarationSrc :: Declaration -> String
+declarationSrc (DataD src)  = src
+declarationSrc (ClassD src) = src
+declarationSrc (SynD src)   = src
+declarationSrc (FamD src)   = src
+declarationSrc (ConD _ src) = src
+declarationSrc (SigD _ src) = src
+
+toDeclaration :: GHC.LHsDecl GhcPs -> (Name -> Declaration -> r) -> Either String [r]
+toDeclaration (L _ (GHC.TyClD _ tycld)) mk = tyclToDeclaration tycld mk
+toDeclaration (L _ (GHC.SigD _ sigd))   mk = sigToDeclaration sigd mk
+toDeclaration (L _ decl)                _  = Left $ "unimplemented" ++ showAstData decl
+
+tyclToDeclaration :: GHC.TyClDecl GhcPs -> (Name -> Declaration -> r) -> Either String [r]
+tyclToDeclaration d@GHC.DataDecl  { GHC.tcdLName = L _ name } mk = Right [mk (toName name) $ DataD  $ fakeShowPpr d ]
+tyclToDeclaration d@GHC.SynDecl   { GHC.tcdLName = L _ name } mk = Right [mk (toName name) $ SynD   $ fakeShowPpr d ]
+tyclToDeclaration d@GHC.ClassDecl { GHC.tcdLName = L _ name } mk = Right [mk (toName name) $ ClassD $ fakeShowPpr d ]
+tyclToDeclaration (GHC.FamDecl _ familyDecl)                mk = famToDeclaration familyDecl mk
+
+famToDeclaration :: GHC.FamilyDecl GhcPs -> (Name -> Declaration -> r) -> Either String [r]
+famToDeclaration d@GHC.FamilyDecl { GHC.fdLName = L _ name } mk = Right [mk (toName name) $ FamD $ fakeShowPpr d ]
+
+sigToDeclaration :: GHC.Sig GhcPs -> (Name -> Declaration -> r) -> Either String [r]
+sigToDeclaration (GHC.TypeSig x names ty) mk = Right
+    [ mk (toName name) $ SigD (fmap genType $ convType ty') $ fakeShowPpr $ GHC.TypeSig x [L l name] ty
+    | L l name <- names
+    , let ty' = GHC.hsib_body $ GHC.hswc_body ty
+    ]
+sigToDeclaration sig _ = Left $ "sigToDeclaration " ++ showAstData sig
+
+conToDeclaration :: GHC.ConDecl GhcPs -> (Name -> Declaration -> r) -> Either String [r]
+conToDeclaration d@GHC.ConDeclGADT { GHC.con_names = names, GHC.con_args = details, GHC.con_res_ty = ty } mk = Right
+    [ mk (toName name) $ ConD (fmap genType $ join $ apps_ <$> convType ty <*> details') (fakeShowPpr (d { GHC.con_names = [L l name] } ))
+    | L l name <- names
+    ]
+  where
+    details' :: Maybe [Ty]
+    details' = sequence
+        [ convType arg
+        | GHC.HsScaled _ arg <- GHC.hsConDeclArgTys details
+        ]
+conToDeclaration d@GHC.ConDeclH98 {} _mk = Left $ "Haskell98 data decl" ++ showAstData d

src/Hooglite/GHC/Utils.hs

@@ -0,0 +1,63 @@
+module Hooglite.GHC.Utils where
+
+import Data.Data            (Data)
+import Data.List            (foldl')
+import GHC.Driver.Session   (DynFlags, defaultDynFlags, xopt_set)
+import GHC.Parser.Lexer     (ParseResult (..), getMessages)
+import GHC.Utils.Error      (pprErrMsgBagWithLoc)
+import GHC.Utils.Outputable (Outputable, showPpr)
+
+import Language.Haskell.GhclibParserEx.GHC.Settings.Config (fakeLlvmConfig, fakeSettings)
+
+import qualified GHC.Hs.Dump
+import qualified GHC.LanguageExtensions.Type as LangExt
+
+-------------------------------------------------------------------------------
+-- General helpers
+-------------------------------------------------------------------------------
+
+fakeDynFlags :: DynFlags
+fakeDynFlags = defaultDynFlags fakeSettings fakeLlvmConfig
+
+fakeShowPpr :: Outputable a => a -> String
+fakeShowPpr = showPpr fakeDynFlags
+
+showAstData :: Data a => a -> String
+showAstData = fakeShowPpr . GHC.Hs.Dump.showAstData GHC.Hs.Dump.BlankSrcSpan
+
+-------------------------------------------------------------------------------
+-- More dynflags
+-------------------------------------------------------------------------------
+
+dynFlags :: DynFlags
+dynFlags = foldl' xopt_set fakeDynFlags
+    [ LangExt.ConstraintKinds
+    , LangExt.DataKinds
+    , LangExt.EmptyDataDecls
+    , LangExt.ExplicitForAll
+    , LangExt.FlexibleContexts
+    , LangExt.FunctionalDependencies
+    , LangExt.GADTs
+    , LangExt.ImplicitParams
+    , LangExt.KindSignatures
+    , LangExt.MagicHash
+    , LangExt.MultiParamTypeClasses
+    , LangExt.ParallelArrays
+    , LangExt.PatternSynonyms
+    , LangExt.PolyKinds
+    , LangExt.TypeFamilies
+    , LangExt.TypeOperators
+    , LangExt.UnboxedTuples
+    , LangExt.UnicodeSyntax
+    ]
+
+-------------------------------------------------------------------------------
+-- Parsing related
+-------------------------------------------------------------------------------
+
+parse :: (String -> DynFlags -> ParseResult a) -> String -> Either [String] a
+parse p s = case p s dynFlags of
+    POk _ x       -> Right x
+    PFailed state -> do
+        let (_warns, errors) = getMessages state dynFlags
+        Left $ map fakeShowPpr $ pprErrMsgBagWithLoc errors

src/Hooglite/Haddock.hs

@@ -0,0 +1,162 @@
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ViewPatterns         #-}
+module Hooglite.Haddock (
+    API (..),
+    apiPackageId,
+    parseHoogleFile,
+) where
+
+import Data.Bifunctor                 (first)
+import Data.Char                      (isAlpha, isSpace)
+import Data.Either                    (partitionEithers)
+import Data.List                      (dropWhileEnd, isPrefixOf, stripPrefix)
+import Data.Map                       (Map)
+import Data.String                    (fromString)
+import Distribution.ModuleName        (ModuleName)
+import Distribution.Parsec            (eitherParsec)
+import Distribution.Types.PackageId   (PackageIdentifier (..))
+import Distribution.Types.PackageName (PackageName)
+import Distribution.Types.Version     (Version)
+
+import GHC.Hs.Decls     (HsDataDefn (..), HsDecl (..), TyClDecl (..))
+import GHC.Types.SrcLoc (GenLocated (L))
+
+import Language.Haskell.GhclibParserEx.GHC.Parser (parseDeclaration)
+
+import qualified Data.Map.Strict as Map
+
+import Hooglite.Declaration
+import Hooglite.GHC.Utils
+import Hooglite.MonoPoly.Name
+import Hooglite.MonoPoly.Pretty
+
+-- | API of a package.
+data API = API
+    { apiPackage :: !PackageName
+    , apiVersion :: !Version
+    , apiModules :: !(Map ModuleName (Map Name Declaration))
+    }
+  deriving Show
+
+apiPackageId :: API -> PackageIdentifier
+apiPackageId (API pn ver _) = PackageIdentifier pn ver
+
+parseHoogleFile :: String -> Either String API
+parseHoogleFile input = do
+    ls <- parseLines input
+    case ls of
+        LPackage pkg : LVersion ver : LModule mn : ls' -> return API
+            { apiPackage = pkg
+            , apiVersion = ver
+            , apiModules = parseModules mn ls'
+            }
+        _ -> Left "api file doesn't start with package and version information"
+
+parseModules :: ModuleName -> [Line] -> Map ModuleName (Map Name Declaration)
+parseModules = aux Map.empty Map.empty where
+    aux :: Map ModuleName (Map Name Declaration)
+        -> Map Name Declaration
+        -> ModuleName
+        -> [Line]
+        -> Map ModuleName (Map Name Declaration)
+    aux !res !_ !_  []                     = res
+    aux !res !m !mn (LPackage _ : ls)      = aux res m mn ls
+    aux !res !m !mn (LVersion _ : ls)      = aux res m mn ls
+    aux !res !m !mn (LModule mn' : ls)     = aux (Map.insert mn m res) Map.empty mn' ls
+    aux !res !m !mn (LDecl name decl : ls) = aux res (Map.insert name decl m) mn ls
+
+parseLines :: String -> Either String [Line]
+parseLines input
+    | strict    = fmap concat $ sequence ls
+    | otherwise = Right $ concat $ snd $ partitionEithers ls
+  where
+    ls :: [Either String [Line]]
+    ls = map (parseLine . cleanUpLine) (lines input)
+
+    strict = False
+
+-- | An entry in the Hoogle DB
+data Line
+    = LPackage PackageName
+    | LVersion Version
+    | LModule ModuleName
+    | LDecl Name Declaration
+  deriving Show
+
+instance Pretty Line where
+    ppr (LDecl n decl) = ppr n <+> ppr decl
+    ppr d = fromString (show d)
+
+singleton :: a -> [a]
+singleton x = [x]
+
+cleanUpLine :: String -> String
+cleanUpLine = dropWhile isSpace . dropWhileEnd (\c -> c == ';' || isSpace c)
+
+parseLine :: String -> Either String [Line]
+parseLine ('-' : '-' : _)                       = return []
+parseLine line | all isSpace line               = return []
+parseLine line@(stripPrefix "@package " -> Just rest) = reportLine line $
+    singleton . LPackage <$> eitherParsec (dropWhile isSpace rest)
+parseLine line@(stripPrefix "@version " -> Just rest) = reportLine line $
+    singleton . LVersion <$> eitherParsec (dropWhile isSpace rest)
+parseLine line@(stripPrefix "module " -> Just rest) = reportLine line $
+    singleton . LModule <$> eitherParsec (dropWhile isSpace rest)
+parseLine "}"  = return []
+parseLine line = reportLine line $ parseItem (fixLine line)
+
+reportLine :: String -> Either String a -> Either String a
+reportLine line = first (\err -> line ++ "\n" ++ err)
+
+parseItem :: String -> Either String [Line]
+parseItem str = first unlines $
+    parseDefault `orElse`
+    parseConstructor `orElse`
+    -- parseNewtype `orElse`
+    parseAssociateTF
+  where
+    parseDefault = do
+        decl <- parse parseDeclaration str
+        first singleton $ toDeclaration decl LDecl
+
+    parseConstructor
+        | Right (L _ (TyClD _ (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = [L _ d]}}))) <- parse parseDeclaration $ "data Data where " ++ str
+        = first singleton $ conToDeclaration d LDecl
+
+        | otherwise
+        = Left ["Not a constructor"]
+
+    parseAssociateTF
+        | Just rest <- stripPrefix "type " str
+        , Right (decl@(L _ TyClD {})) <- parse parseDeclaration $ "type family " ++ rest
+        = first singleton $ toDeclaration decl LDecl
+
+        | otherwise
+        = Left ["Not an associated type family"]
+
+    orElse :: Either [a] b -> Either [a] b -> Either [a] b
+    orElse r@Right {} _           = r
+    orElse   _        l@Right {}  = l
+    orElse (Left err) (Left err') = Left (err ++ err')
+
+-- | Fix lines prior parsing, to make them look like normal Haskell.
+fixLine :: String -> String
+fixLine (stripPrefix "instance [incoherent] " -> Just x)  = fixLine $ "instance " ++ x
+fixLine (stripPrefix "instance [overlap ok] " -> Just x)  = fixLine $ "instance " ++ x
+fixLine (stripPrefix "instance [overlapping] " -> Just x) = fixLine $ "instance " ++ x
+fixLine (stripPrefix "instance [safe] " -> Just x)        = fixLine $ "instance " ++ x
+fixLine (stripPrefix "(#) " -> Just x)                    = "( # ) " ++ x
+fixLine ('[':x:xs)
+    | isAlpha x || x `elem` ("_(" :: String)
+    , (a,']':b) <- break (== ']') xs                      = x : a ++ b
+fixLine ('[':':':xs)
+    | (a,']':b)
+    <- break (== ']') xs                                  = "(:" ++ a ++ ")" ++ b
+fixLine x | "class " `isPrefixOf` x                       = fst $ breakOn " where " x
+fixLine x = x
+
+breakOn :: Eq a => [a] -> [a] -> ([a], [a])
+breakOn  needle haystack | needle `isPrefixOf` haystack = ([], haystack)
+breakOn _needle []                                      = ([], [])
+breakOn  needle (x:xs)                                  = first (x:) $ breakOn needle xs

src/Hooglite/MonoPoly.hs

@@ -0,0 +1,137 @@
+module Hooglite.MonoPoly where
+
+import Control.Monad       (ap)
+import Control.Unification (Unifiable (..))
+import GHC.Generics        (Generic1)
+import Data.String (IsString (..))
+
+import qualified Text.PrettyPrint as PP
+
+import Hooglite.MonoPoly.Name
+import Hooglite.MonoPoly.Pretty
+import Hooglite.MonoPoly.Var
+
+-------------------------------------------------------------------------------
+-- Mono
+-------------------------------------------------------------------------------
+
+-- | Mono-types.
+data Mono n a
+    = Var (Var n)
+    | Free a
+    | Arr (Mono n a) (Mono n a)
+    | App (Mono n a) (Mono n a)
+  deriving (Eq, Show, Functor, Foldable, Traversable)
+
+instance Applicative (Mono n) where
+    pure = Free
+    (<*>) = ap
+
+instance Monad (Mono n) where
+    return = Free
+
+    Var x   >>= _ = Var x
+    Free x  >>= k = k x
+    Arr a b >>= k = Arr (a >>= k) (b >>= k)
+    App f a >>= k = App (f >>= k) (a >>= k)
+
+substMono :: (Var n -> Mono m a) -> Mono n a -> Mono m a
+substMono s (Var x)   = s x
+substMono _ (Free x)  = Free x
+substMono s (Arr a b) = Arr (substMono s a) (substMono s b)
+substMono s (App f a) = App (substMono s f) (substMono s a)
+
+instance Renamable Mono where
+    r <@> m = substMono (Var . renameVar r) m
+
+instance IsString a => IsString (Mono n a) where
+    fromString = Free . fromString
+
+-------------------------------------------------------------------------------
+-- Poly
+-------------------------------------------------------------------------------
+
+data Poly n a
+    = Mono (Mono n a)             -- ^ monotypes
+    | Poly IName (Poly (S n) a)   -- ^ forall.
+  deriving (Eq, Show, Functor, Foldable, Traversable)
+
+substPoly :: (Var n -> Mono m a) -> Poly n a -> Poly m a
+substPoly s (Mono a)   = Mono (substMono s a)
+substPoly s (Poly n a) = Poly n (substPoly (unvar (Var VZ) ((weaken <@>) . s)) a)
+
+infixl 4 >>==
+(>>==) :: Poly n a -> (a -> Mono n b) -> Poly n b
+Mono a   >>== k = Mono (a >>= k)
+Poly n a >>== k = Poly n (a >>== (weaken <@>) . k)
+
+instance Renamable Poly where
+    r <@> Mono a   = Mono (r <@> a)
+    r <@> Poly n a = Poly n (liftRen r <@> a)
+
+forall_ :: Name -> Poly n Name -> Poly n Name
+forall_ n p = Poly (IName n) $ weaken <@> p >>== \n' ->
+    if n == n'
+    then Var VZ
+    else Free n'
+
+instantiate :: Mono n a -> Poly (S n) a -> Poly n a
+instantiate x = substPoly (unvar x Var)
+
+
+instance IsString a => IsString (Poly n a) where
+    fromString = Mono . fromString
+
+-------------------------------------------------------------------------------
+-- MonoF
+-------------------------------------------------------------------------------
+
+-- | Base-functor of 'Mono'.
+data MonoF n a b
+    = VarF (Var n)
+    | FreeF a
+    | ArrF b b
+    | AppF b b
+  deriving (Eq, Show, Functor, Foldable, Traversable, Generic1)
+
+instance Eq a => Unifiable (MonoF n a) where
+
+
+-------------------------------------------------------------------------------
+-- Pretty
+-------------------------------------------------------------------------------
+
+instance ToName a => Pretty (Mono n a) where
+    ppr t = runNameM $ do
+        let t' = fmap toName t
+        usedNames t'
+        pprMono 0 t' 
+
+pprMono :: Int -> Mono n Name -> NameM PP.Doc
+pprMono _ (Var x)   = return $ ppr x
+pprMono _ (Free x)  = return $ PP.text (pretty x)
+pprMono d (App f t) = ppParen (d >= 11) $ do
+    f' <- pprMono 10 f
+    t' <- pprMono 11 t
+    return $ f' <+> t'
+pprMono d (Arr a b)  = ppParen (d >= 2) $ do
+    a' <- pprMono 2 a
+    b' <- pprMono 1 b
+    return $ a' <+> PP.text "->" <+> b'
+
+instance ToName a => Pretty (Poly n a) where
+    ppr t = runNameM $ do
+        let t' = fmap toName t
+        usedNames t'
+        pprPoly 0 t' 
+
+pprPoly :: Int -> Poly n Name -> NameM PP.Doc
+pprPoly d = go [] where
+    go [] (Mono a) = pprMono d a
+    go ns (Mono a) = do
+        a' <- pprMono 0 a
+        return $ "forall" <+> PP.hsep (reverse ns) PP.<> "." <+> a'
+
+    go ns (Poly (IName n) a) = do
+        n' <- freshName n
+        go (ppr n' : ns) (instantiate (Free n') a)

src/Hooglite/MonoPoly/Name.hs

@@ -0,0 +1,116 @@
+module Hooglite.MonoPoly.Name (
+    -- * Name
+    Name (..),
+    unName,
+    ToName (..),
+    -- * Irrelevant name
+    IName (..),
+    -- * Fresh name generation monad
+    NameM (..),
+    runNameM,
+    usedNames,
+    freshName,
+) where
+
+import Control.Monad.State   (State, evalState, get, modify', put)
+import Data.ByteString.Short (ShortByteString)
+import Data.Char             (isDigit)
+import Data.Foldable         (traverse_)
+import Data.Maybe            (fromMaybe)
+import Data.Set              (Set)
+import Data.String           (IsString (..))
+import Data.Text.Short       (ShortText)
+import Text.Read             (readMaybe)
+
+import qualified Data.Set                  as Set
+import qualified Data.Text.Short           as ST
+import qualified GHC.Data.FastString       as FS
+import qualified GHC.Types.Name.Occurrence as OccName
+import qualified GHC.Types.Name.Reader     as RdrName
+
+-------------------------------------------------------------------------------
+-- Name
+-------------------------------------------------------------------------------
+
+newtype Name = Name ShortText
+  deriving newtype (Eq, Ord, Show)
+
+unName :: Name -> ShortText
+unName (Name n) = n
+
+instance IsString Name where
+    fromString = Name . fromString
+
+-------------------------------------------------------------------------------
+-- Conversion to Name
+-------------------------------------------------------------------------------
+
+class ToName n where
+    toName :: n -> Name
+
+instance ToName Name where
+    toName = id
+
+instance ToName FS.FastString where
+    toName = Name . lenientFromSBS . FS.fs_sbs
+
+instance ToName OccName.OccName where
+    toName = toName . OccName.occNameFS
+
+instance ToName RdrName.RdrName where
+    toName = toName .  RdrName.rdrNameOcc
+
+-------------------------------------------------------------------------------
+-- Irrelevant name
+-------------------------------------------------------------------------------
+
+newtype IName = IName Name
+  deriving newtype Show
+
+instance Eq IName where
+    _ == _ = True
+
+instance IsString IName where
+    fromString = IName . fromString
+
+-------------------------------------------------------------------------------
+-- Name monad
+-------------------------------------------------------------------------------
+
+newtype NameM a = NameM { unNameM :: State (Set Name) a }
+  deriving newtype (Functor, Applicative, Monad)
+
+runNameM :: NameM a -> a
+runNameM (NameM m) = evalState m Set.empty
+
+usedNames :: (Foldable f, ToName a) => f a -> NameM ()
+usedNames xs = NameM (traverse_ (\n -> modify' (Set.insert (toName n))) xs)
+
+freshName :: Name -> NameM Name
+freshName n = NameM $ do
+    s <- get
+    if Set.notMember n s
+    then do
+        put (Set.insert n s)
+        return n
+    else go s (fromMaybe (0 :: Int) (readMaybe (ST.toString sfx)))
+  where
+    (pfx, sfx) = ST.spanEnd isDigit (unName n)
+
+    go s !idx = do
+        let n' = Name (pfx <> fromString (show idx))
+        if Set.notMember n' s
+        then do
+            put (Set.insert n s)
+            return n
+        else
+            go s (idx + 1)
+
+-------------------------------------------------------------------------------
+-- internal
+-------------------------------------------------------------------------------
+
+lenientFromSBS :: ShortByteString -> ShortText
+lenientFromSBS sbs = fromMaybe
+    (error "invalid UTF-8 SBS")
+    (ST.fromShortByteString sbs)

src/Hooglite/MonoPoly/Pretty.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Hooglite.MonoPoly.Pretty (
+    Pretty (..),
+    pretty,
+    (<+>),
+    ppParen,
+) where
+
+import Data.Void        (Void, absurd)
+import Text.PrettyPrint ((<+>))
+
+import qualified Data.Text.Short  as ST
+import qualified Text.PrettyPrint as PP
+
+import Hooglite.MonoPoly.Name
+import Hooglite.MonoPoly.Var
+
+-------------------------------------------------------------------------------
+-- Pretty class
+-------------------------------------------------------------------------------
+
+pretty :: Pretty a => a -> String
+pretty = show . ppr
+
+class Pretty a where
+    ppr :: a -> PP.Doc
+
+instance a ~ Char => Pretty [a] where
+    ppr = PP.text
+
+instance Pretty (Var n) where
+    ppr x = "$" <> PP.int (indexVar x)
+
+instance Pretty Void where
+    ppr = absurd
+
+instance Pretty Int where
+    ppr i = "?" <> PP.int i
+
+instance Pretty Name where
+    ppr (Name t) = PP.text (ST.toString t)
+
+instance Pretty () where
+    ppr _ = "_"
+
+instance Pretty a => Pretty (Maybe a) where
+    ppr = maybe "?" ppr
+
+ppParen :: Bool -> NameM PP.Doc -> NameM PP.Doc
+ppParen False = id
+ppParen True  = fmap PP.parens

src/Hooglite/MonoPoly/Var.hs

@@ -0,0 +1,230 @@
+{-# LANGUAGE CPP #-}
+-- | Variables for well-scoped terms.
+module Hooglite.MonoPoly.Var (
+    -- * Variables
+    Nat (..),
+    Var (VZ,VS),
+    absurdVar,
+    unvar,
+    indexVar,
+    -- ** Common patterns
+    unusedVar,
+    unusedVar2,
+    unusedVar3,
+    -- * Renamings
+    Renaming,
+    mkRenaming,
+    renameVar,
+    idRenaming,
+    liftRen,
+    (>>>),
+    bump,
+    swap,
+    weaken,
+    absurdRen,
+    -- * Renamable things
+    Renamable (..),
+    Renamable0 (..),
+    NoCtx (..),
+) where
+
+import Data.Bifunctor.Clown (Clown (..))
+import Data.Bifunctor.Flip  (Flip (..))
+import Data.Kind            (Type)
+import Data.Nat             (Nat (..))
+
+import qualified Control.Category as C
+
+#ifdef SAFE
+#else
+import Unsafe.Coerce (unsafeCoerce)
+#endif
+
+-- | Variables index the context size.
+type Var :: Nat -> Type
+type role Var nominal
+
+#ifdef SAFE
+
+data Var n where
+    VZ :: Var (S n)
+    VS :: Var n -> Var (S n)
+
+indexVar :: Var n -> Int
+indexVar = go 0 where
+    go :: Int -> Var j -> Int
+    go !acc VZ = acc
+    go acc (VS n) = go (acc + 1) n
+
+-- | Derive anything from variable in empty scope.
+--
+-- Note: don't use @EmptyCase@ as it doesn't work for unsafe representation.
+absurdVar :: Var Z -> a
+absurdVar x = case x of {}
+
+#else
+
+-- Vars which are just 'Int's.
+
+newtype Var j = UnsafeVar { indexVar :: Int }
+
+-- | Derive anything from variable in empty scope.
+--
+-- Note: don't use @EmptyCase@ as it doesn't work for unsafe representation.
+absurdVar :: Var Z -> a
+absurdVar x = x `seq` error "absurd: Var Z"
+
+-- We need a GADT to implement pattern synonyms.
+type Var' :: Nat -> Type
+type role Var' nominal
+data Var' n where
+    VZ' :: Var' (S n)
+    VS' :: Var n -> Var' (S n)
+
+upVar :: Var n -> Var' n
+upVar (UnsafeVar 0) = unsafeCoerce VZ'
+upVar (UnsafeVar n) = unsafeCoerce (VS' (UnsafeVar (n - 1)))
+
+pattern VZ :: () => (m ~ S n) => Var n
+pattern VZ <- (upVar -> VZ') where
+    VZ = UnsafeVar 0
+
+pattern VS :: () => (m ~ S n) => Var n -> Var m
+pattern VS n <- (upVar -> VS' n) where
+    VS n = UnsafeVar (indexVar n + 1)
+
+{-# COMPLETE VZ, VS #-}
+
+#endif
+
+-------------------------------------------------------------------------------
+-- Common
+-------------------------------------------------------------------------------
+
+deriving instance Eq (Var n)
+deriving instance Ord (Var n)
+
+instance Show (Var j) where
+    showsPrec d = showsPrec d . indexVar
+
+-- | Case on 'Var'. (compare to 'maybe').
+unvar :: a -> (Var n -> a) -> Var (S n) -> a
+unvar z _ VZ     = z
+unvar _ s (VS x) = s x
+
+-- | Is variable unused?
+unusedVar :: Var (S n) -> Maybe (Var n)
+unusedVar (VS x) = Just x
+unusedVar _      = Nothing
+
+-- | Are two variables unused?
+unusedVar2 :: Var (S (S n)) -> Maybe (Var n)
+unusedVar2 (VS (VS x)) = Just x
+unusedVar2 _           = Nothing
+
+-- | Are three variables unused?
+unusedVar3 :: Var (S (S (S n))) -> Maybe (Var n)
+unusedVar3 (VS (VS (VS x))) = Just x
+unusedVar3 _                = Nothing
+
+-------------------------------------------------------------------------------
+-- Renamings
+-------------------------------------------------------------------------------
+
+-- | Renamings are mappings of variable.
+type Renaming :: Nat -> Nat -> Type
+newtype Renaming n m = Renaming
+    { renameVar :: Var n -> Var m -- ^ Apply 'Renaming' to a variable.
+    }
+
+-- | Identity renamings.
+idRenaming :: Renaming n n
+idRenaming = Renaming id
+
+-- | Make a 'Renaming' from a fuinction.
+mkRenaming :: (Var n -> Var m) -> Renaming n m
+mkRenaming = Renaming
+
+-- | Lift renaming (used when going under a binder).
+liftRen :: Renaming n m -> Renaming (S n) (S m)
+liftRen (Renaming f) = Renaming (go f)
+  where
+    go :: (Var n -> Var m) -> Var (S n) -> Var (S m)
+    go _ VZ     = VZ
+    go g (VS x) = VS (g x)
+
+-- we need to bind tighter then <@>
+infixr 9 >>>
+
+-- | Renaming composition.
+(>>>) :: Renaming a b -> Renaming b c -> Renaming a c
+Renaming r >>> Renaming r' = Renaming (r' . r)
+
+instance C.Category Renaming where
+    id  = idRenaming
+    (.) = flip (>>>)
+
+-- | Weakening of a context.
+weaken :: Renaming n (S n)
+weaken = Renaming VS
+
+-- | Common renaming weakening under one variable.
+--
+-- @
+-- 'bump' = 'liftRen' 'weaken'
+-- @
+bump :: Renaming (S n) (S (S n))
+bump = liftRen weaken
+
+-- | Swap two top variables in the context.
+--
+-- /Note:/ this is one case why we cannot use thinnings.
+swap :: Renaming (S (S n)) (S (S n))
+swap = Renaming swap' where
+    swap' :: Var (S (S n)) -> Var (S (S n))
+    swap' VZ      = VS VZ
+    swap' (VS VZ) = VZ
+    swap' v       = v
+
+-- | Zero variables can be renamed to any number of variables.
+absurdRen :: Renaming Z m
+absurdRen = Renaming absurdVar
+
+-------------------------------------------------------------------------------
+-- Renamable
+-------------------------------------------------------------------------------
+
+-- | Renamable things.
+class Renamable t where
+    (<@>) :: Renaming n m -> t n a -> t m a
+
+-- | Renamable things.
+--
+-- A more correct type-class.
+-- However 'Renamable' is more convenient as the kinds much the term.
+-- You can use 'Flip' and 'Clown' to convert between these.
+class Renamable0 t where
+    (<@@>) :: Renaming n m -> t n -> t m
+
+infixl 4 <@>, <@@>
+
+instance Renamable0 t =>  Renamable (Clown t) where
+    f <@> Clown x = Clown (f <@@> x)
+
+instance Renamable t => Renamable0 (Flip t a) where
+    f <@@> Flip x = Flip (f <@> x)
+
+-- | No context.
+--
+-- Used to implement 'rewrite' in terms of 'rewriteWith' etc.
+type NoCtx :: Nat -> Type -> Type
+data NoCtx n a = NoCtx
+
+instance Renamable NoCtx where
+    _ <@> _ = NoCtx
+
+instance Renamable0 Var where
+    r <@@> x = renameVar r x
+
+instance Renamable0 (Renaming n) where
+    f <@@> g = g >>> f

src/Hooglite/Query.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Hooglite.Query (
+    Query (..),
+    parseQuery,
+) where
+
+import Data.Char (isAlphaNum)
+
+import Language.Haskell.GhclibParserEx.GHC.Parser (parseType)
+
+import qualified Text.PrettyPrint as PP
+
+import Hooglite.GHC.Utils
+import Hooglite.MonoPoly.Pretty
+import Hooglite.Ty
+
+-- | Query type.
+data Query
+    = QueryName String      -- ^ query by (part of the name)
+    | QueryType Ty String   -- ^ query by type
+    | QueryInvalid
+  deriving (Eq, Show)
+
+instance Pretty Query where
+    ppr (QueryName n)       = "name:" <+> PP.text n
+    ppr (QueryType ty _str) = "type:" <+> ppr ty
+    ppr QueryInvalid        = "<invalid>"
+
+-- | Parse query.
+--
+-- If query is a single word, then we query by name.
+-- Otherwise we try to parse a type.
+--
+parseQuery :: String -> Query
+parseQuery str
+    | all isAlphaNum str || all isOperator str
+    = QueryName str
+
+    | Right t <- parse parseType str
+    , Just ty <- genType <$> convType t
+    = QueryType ty (fakeShowPpr t)
+
+    | otherwise
+    = QueryInvalid
+  where
+    isOperator c = c `elem` ("!#$%&*+./<=>?@" :: String)

src/Hooglite/Ty.hs

@@ -0,0 +1,76 @@
+module Hooglite.Ty where
+
+import Control.Monad    (join)
+import Data.Char        (isLower)
+import Data.List        (nub)
+import Data.Maybe       (mapMaybe)
+import Data.String      (fromString)
+import GHC.Hs.Extension (GhcPs)
+import GHC.Types.SrcLoc (GenLocated (L))
+
+import qualified Data.Text.Short as ST
+import qualified GHC.Hs.Type     as GHC
+
+import Hooglite.GHC.Utils
+import Hooglite.MonoPoly
+import Hooglite.MonoPoly.Name
+import Hooglite.MonoPoly.Var
+
+-------------------------------------------------------------------------------
+-- Our representation for types
+-------------------------------------------------------------------------------
+
+type Ty = Poly Z Name
+
+genType :: Ty -> Ty
+genType ty = foldr forall_ ty xs where
+    xs :: [Name]
+    xs = nub $ foldMap (\x -> if nameLooksLikeTyVar x then [x] else []) ty
+
+nameLooksLikeTyVar :: Name -> Bool
+nameLooksLikeTyVar (Name n) = case ST.uncons n of
+    Just (c, _) -> isLower c
+    _           -> False
+
+arr_ :: Ty -> Ty -> Maybe Ty
+arr_  (Mono a) (Mono b) = Just (Mono (Arr a b))
+arr_  _        _        = Nothing
+
+app_ :: Ty -> Ty -> Maybe Ty
+app_  (Mono a) (Mono b) = Just (Mono (App a b))
+app_  _        _        = Nothing
+
+apps_ :: Ty -> [Ty] -> Maybe Ty
+apps_ a []     = Just a
+apps_ a (b:bs) = app_ a b >>= (`apps_` bs)
+
+convType :: GHC.LHsType GhcPs -> Maybe Ty
+convType = go where
+    -- look at
+    -- https://hackage.haskell.org/package/ghc-lib-parser-9.0.2.20211226/docs/GHC-Hs-Type.html#t:HsType
+    go :: GHC.LHsType GhcPs -> Maybe Ty
+    go (L _ (GHC.HsParTy _ a))         = go a
+    go (L _ (GHC.HsFunTy _ _ a b))     = join $ arr_ <$> go a <*> go b
+    go (L _ (GHC.HsAppTy _ a b))       = join $ app_ <$> go a <*> go b
+    go (L _ (GHC.HsAppKindTy _ a b))   = join $ app_ <$> go a <*> go b
+    go (L _ (GHC.HsStarTy _ _))        = Just "*"
+    go (L _ (GHC.HsKindSig _ a _))     = go a
+    go (L _ (GHC.HsTyVar _ _ (L _ n))) = Just (Mono (Free (toName n)))
+    go (L _ (GHC.HsQualTy _ _ b))      = go b -- we forget about constraints.
+    go (L _ (GHC.HsForAllTy _ xs y))   = forallTeles xs <$> go y
+    go (L _ (GHC.HsListTy _ a))        = join $ app_ "List" <$> go a
+    go (L _ (GHC.HsTupleTy _ _ xs))    = apps_ (fromString (tupleName (length xs))) (mapMaybe go xs)
+    go (L _ ty)                        = Just (fromString (fakeShowPpr ty))
+
+    tupleName :: Int -> String
+    tupleName 0 = "Unit"
+    tupleName 1 = "Solo"
+    tupleName n = "Tuple" ++ show n
+
+    forallTeles :: GHC.HsForAllTelescope GhcPs -> Ty -> Ty
+    forallTeles (GHC.HsForAllVis _ xs)   y = foldr forallTeles' y xs
+    forallTeles (GHC.HsForAllInvis _ xs) y = foldr forallTeles' y xs
+
+    forallTeles' :: GHC.LHsTyVarBndr flag GhcPs -> Ty -> Ty
+    forallTeles' (L _ (GHC.UserTyVar _ _ (L _ n))) b       = forall_ n' b where n' = toName n
+    forallTeles' (L _ (GHC.KindedTyVar _ _ (L _ n) _ki)) b = forall_ n' b where n' = toName n

test/Hooglite/Test/Database.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Hooglite.Test.Database (
+    databaseTests,
+) where
+
+import Test.Tasty       (TestTree, testGroup, withResource)
+import Test.Tasty.HUnit (testCaseInfo, (@=?))
+
+import Hooglite.Database
+import Hooglite.Haddock
+import Hooglite.MonoPoly.Pretty
+import Hooglite.Query
+
+databaseTests :: TestTree
+databaseTests =
+    withResource (database "extra.txt") (\_ -> return ()) $ \loadDb ->
+    testGroup "database-queries"
+        [ queryTest loadDb "fst3" 2
+        , queryTest loadDb "dropEnd" 4
+        , queryTest loadDb "Int -> Double" 2
+        , queryTest loadDb "Int -> a" 18
+        , queryTest loadDb "(a,b,c) -> a" 2
+        ]
+  where
+    database :: String -> IO Database
+    database name = do
+        contents <- readFile $ "test-data/" ++ name
+        api <- either fail return $ parseHoogleFile contents
+        return $! apiToDatabase api
+
+    queryTest :: IO Database -> String -> Int -> TestTree
+    queryTest loadDb q expected = testCaseInfo q $ do
+        db <- loadDb
+        let result = query db $ parseQuery q
+        expected @=? length result
+        return $ case result of
+            []    -> "no results"
+            _     -> unlines $ take 10 $ map pretty result

test/Hooglite/Test/Haddock.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Hooglite.Test.Haddock (
+    haddockTests,
+) where
+
+import Distribution.PackageDescription (PackageName)
+import Distribution.Pretty             (prettyShow)
+import Distribution.Version            (Version, mkVersion)
+import Test.Tasty                      (TestTree, testGroup)
+import Test.Tasty.HUnit                (assertFailure, testCaseInfo, (@=?))
+
+import Hooglite.Haddock
+
+haddockTests :: TestTree
+haddockTests = testGroup "haddock"
+    [ haddockTest "base.txt"  "base"  (mkVersion [4,16,0,0]) 220
+    , haddockTest "extra.txt" "extra" (mkVersion [1,7,10]) 19
+    ]
+  where
+    haddockTest :: String -> PackageName -> Version -> Int -> TestTree
+    haddockTest name pn ver ms = testCaseInfo name $ do
+        contents <- readFile $ "test-data/" ++ name
+        API pn' ver' ms' <- either assertFailure return $ parseHoogleFile contents
+        pn @=? pn'
+        ver @=? ver'
+        ms @=? length ms'
+        return $ prettyShow pn' ++ " " ++ prettyShow ver'

test/Hooglite/Test/Query.hs

@@ -0,0 +1,21 @@
+module Hooglite.Test.Query (
+    queryTests,
+) where
+
+import Test.Tasty       (TestTree, testGroup)
+import Test.Tasty.HUnit (testCaseInfo, (@=?))
+
+import Hooglite.MonoPoly.Pretty
+import Hooglite.Query
+
+queryTests :: TestTree
+queryTests = testGroup "query"
+    [ queryTest "a -> b" "type: forall a b. a -> b"
+    , queryTest ">>>"    "name: >>>"
+    ]
+  where
+    queryTest :: String -> String -> TestTree
+    queryTest str expected = testCaseInfo str $ do
+        let q = parseQuery str
+        expected @=? pretty q
+        return expected

test/hooglite-tests.hs

@@ -0,0 +1,14 @@
+module Main (main) where
+
+import Test.Tasty (defaultMain, testGroup)
+
+import Hooglite.Test.Query
+import Hooglite.Test.Haddock
+import Hooglite.Test.Database
+
+main :: IO ()
+main = defaultMain $ testGroup "hooglite"
+    [ queryTests
+    , haddockTests
+    , databaseTests
+    ]