├── assets ├── robots.txt ├── favicon.ico ├── favicon.svg └── style.css ├── test ├── Spec.hs ├── hoogleres.json └── VisualSpec.hs ├── cabal.project.local ├── svg.sh ├── doc └── Visual.png ├── .vscode └── settings.json ├── .gitignore ├── release.nix ├── CHANGELOG.md ├── nix ├── nixpkgs.nix └── docker.nix ├── default.nix ├── hie.yaml ├── README.md ├── shell.nix ├── app └── Main.hs ├── LICENSE ├── .github └── workflows │ └── heroku.yml ├── src ├── Hoogle.hs ├── Parser.hs └── Visual.hs ├── index.html ├── type-depict.cabal └── webserver └── Main.hs /assets/robots.txt: -------------------------------------------------------------------------------- 1 | User-agent: * 2 | Allow: / 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} -------------------------------------------------------------------------------- /cabal.project.local: -------------------------------------------------------------------------------- 1 | ignore-project: False 2 | tests: True 3 | -------------------------------------------------------------------------------- /svg.sh: -------------------------------------------------------------------------------- 1 | rm index.html 2 | cabal run type-depict 3 | open index.html -------------------------------------------------------------------------------- /doc/Visual.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mariatsji/type-depict/HEAD/doc/Visual.png -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "nixEnvSelector.nixFile": "${workspaceRoot}/shell.nix" 3 | } -------------------------------------------------------------------------------- /assets/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mariatsji/type-depict/HEAD/assets/favicon.ico -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | result 3 | sjur.nix 4 | nix/tvbox.sh 5 | nix/ping.sh 6 | nix/remotebuild.sh 7 | -------------------------------------------------------------------------------- /release.nix: -------------------------------------------------------------------------------- 1 | let pkgs = import ./nix/nixpkgs.nix; 2 | in pkgs.haskellPackages.callCabal2nix "type-depict" ./. {} 3 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for expression-visualizer 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /nix/nixpkgs.nix: -------------------------------------------------------------------------------- 1 | let 2 | pkgs = import (builtins.fetchTarball { 3 | url = "https://github.com/NixOS/nixpkgs/archive/6c309ef9ae51fd4ebdcb3b19ab6acea5ba66983e.tar.gz"; 4 | }) {}; 5 | 6 | in pkgs -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | let 2 | nixpkgs = import ./nix/nixpkgs.nix; 3 | 4 | in nixpkgs.haskell.lib.justStaticExecutables 5 | (nixpkgs.haskell.lib.disableLibraryProfiling (nixpkgs.haskell.lib.dontHaddock 6 | (nixpkgs.haskellPackages.callCabal2nix "type-depict" ./. { }))) 7 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "src" 4 | component: "lib:type-depict" 5 | 6 | - path: "app/Main.hs" 7 | component: "type-depict:exe:type-depict" 8 | 9 | - path: "webserver/Main.hs" 10 | component: "type-depict:exe:type-depict-ws" 11 | 12 | - path: "test" 13 | component: "type-depict:test:type-depict-test" 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # type-depict.io 2 | 3 | A repository for visualizing Haskell type signatures 4 | 5 | That is, it can [draw a visualization of a Haskell type](https://www.type-depict.io) 6 | 7 | The core idea is representing any Haskell type level signature as a combination of Connections, Embellishments, Groups and Dots 8 | 9 | ![visualizations](https://github.com/mariatsji/type-depict/blob/main/doc/Visual.png?raw=true) 10 | 11 | ## Known limitations: 12 | Cant parse PolyKinds or FunDeps signatures 13 | -------------------------------------------------------------------------------- /nix/docker.nix: -------------------------------------------------------------------------------- 1 | { artifact }: 2 | 3 | let 4 | nixpkgs = import ./nixpkgs.nix; 5 | artifactName = "type-depict"; 6 | extraFiles = ../assets; 7 | 8 | # builds a base image to extend with a stack-built binary 9 | in with nixpkgs; dockerTools.buildLayeredImage { 10 | name = artifactName; 11 | tag = "latest"; 12 | created = "now"; 13 | # runtime system deps and binary tools in the docker image goes here 14 | contents = [ 15 | artifact 16 | cacert 17 | libiconv 18 | libffi 19 | gmp 20 | busybox 21 | bash 22 | curl 23 | zlib 24 | tzdata 25 | ]; 26 | 27 | extraCommands = '' 28 | cp -rf ${extraFiles} assets 29 | ''; 30 | 31 | config = { 32 | Env = [ 33 | "TZ=Europe/Oslo" 34 | "PATH=${bash}/bin:${busybox}/bin:${curl}/bin" 35 | ]; 36 | Cmd = [ "${artifact}/bin/type-depict-ws" ]; 37 | }; 38 | } -------------------------------------------------------------------------------- /assets/favicon.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import ./nix/nixpkgs.nix, herokuSecret ? null }: 2 | 3 | let haskellStuff = with pkgs; 4 | [ 5 | haskellPackages.haskell-language-server 6 | ghc 7 | haskellPackages.cabal-install 8 | haskellPackages.cabal2nix 9 | haskellPackages.implicit-hie 10 | ghcid 11 | haskellPackages.fourmolu 12 | ]; 13 | tools = with pkgs; 14 | [ 15 | nixfmt 16 | git 17 | curl 18 | # heroku 19 | graphviz 20 | ]; 21 | all = haskellStuff ++ tools; 22 | 23 | 24 | in pkgs.mkShell { 25 | # specify which packages to add to the shell environment 26 | packages = all; 27 | # add all the dependencies, of the given packages, to the shell environment 28 | inputsFrom = with pkgs; all; 29 | HEROKU_API_KEY = herokuSecret; 30 | shellHook = 31 | if isNull herokuSecret then "" else '' 32 | heroku container:login 33 | docker login --username=_ --password=$(heroku auth:token) registry.heroku.com 34 | ''; 35 | } 36 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad.Trans.State.Lazy 6 | import qualified Data.Text as T 7 | import qualified Data.Text.IO as TIO 8 | import Graphics.Svg 9 | import qualified Parser 10 | import Visual 11 | 12 | main :: IO () 13 | main = do 14 | let (Right visual) = Parser.parse "(a -> b -> c) -> (a -> b -> c)" 15 | container = [Version_ <<- "1.1", Width_ <<- "2500", Height_ <<- "500"] 16 | blobble = Blobble{x = 5, y = 5, w = 2000, r = 50} 17 | s = renderSvg blobble visual 18 | svg = evalState s initEnv 19 | res = doctype <> with (svg11_ svg) container 20 | renderToFile "index.html" res 21 | 22 | favicon :: IO () 23 | favicon = do 24 | let (Right visual) = Parser.parse "( f a b -> f a b ) -> f a b" 25 | container = [Version_ <<- "1.1", Width_ <<- "100", Height_ <<- "100"] 26 | blobble = Blobble{x = 5, y = 5, w = 5, r = 30} 27 | s = renderSvg blobble visual 28 | svg = evalState s initEnv 29 | res = doctype <> with (svg11_ svg) container 30 | renderToFile "assets/favicon.svg" res -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Sjur Millidahl 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /test/hoogleres.json: -------------------------------------------------------------------------------- 1 | [ 2 | { 3 | "docs": "Map each element of a structure to an action, evaluate these actions\nfrom left to right, and collect the results. For a version that\nignores the results see traverse_.\n\nExamples\n\nBasic usage:\n\nIn the first two examples we show each evaluated action mapping to the\noutput structure.\n\n\n>>> traverse Just [1,2,3,4]\nJust [1,2,3,4]\n\n\n\n>>> traverse id [Right 1, Right 2, Right 3, Right 4]\nRight [1,2,3,4]\n\n\nIn the next examples, we show that Nothing and Left\nvalues short circuit the created structure.\n\n\n>>> traverse (const Nothing) [1,2,3,4]\nNothing\n\n\n\n>>> traverse (\\x -> if odd x then Just x else Nothing) [1,2,3,4]\nNothing\n\n\n\n>>> traverse id [Right 1, Right 2, Right 3, Right 4, Left 0]\nLeft 0\n\n", 4 | "item": "traverse :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b)", 5 | "module": { 6 | "name": "Prelude", 7 | "url": "https://hackage.haskell.org/package/base/docs/Prelude.html" 8 | }, 9 | "package": { 10 | "name": "base", 11 | "url": "https://hackage.haskell.org/package/base" 12 | }, 13 | "type": "", 14 | "url": "https://hackage.haskell.org/package/base/docs/Prelude.html#v:traverse" 15 | } 16 | ] -------------------------------------------------------------------------------- /.github/workflows/heroku.yml: -------------------------------------------------------------------------------- 1 | name: "Build and release to Heroku" 2 | on: 3 | push: 4 | branches: [ main ] 5 | jobs: 6 | tests: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v2.4.0 10 | - uses: cachix/install-nix-action@v15 11 | with: 12 | nix_path: nixpkgs=channel:nixos-unstable 13 | - name: Build nix docker base image 14 | run: | 15 | nix-build nix/docker.nix --arg artifact 'import ./default.nix' -o dockerImage 16 | echo "loading resulting nix-built docker image" 17 | docker load -i dockerImage 18 | - name: Login to Heroku Container registry 19 | env: 20 | HEROKU_API_KEY: ${{ secrets.HEROKU_API_KEY }} 21 | run: | 22 | heroku container:login 23 | docker login --username=_ --password=$(heroku auth:token) registry.heroku.com 24 | - name: Tag docker to Heroku 25 | env: 26 | HEROKU_API_KEY: ${{ secrets.HEROKU_API_KEY }} 27 | run: docker tag type-depict:latest registry.heroku.com/type-depict/web 28 | - name: Inspect tagged 29 | run: docker inspect -s registry.heroku.com/type-depict/web 30 | - name: Push docker to Heroku 31 | env: 32 | HEROKU_API_KEY: ${{ secrets.HEROKU_API_KEY }} 33 | run: docker push registry.heroku.com/type-depict/web 34 | - name: Heroku container release 35 | env: 36 | HEROKU_API_KEY: ${{ secrets.HEROKU_API_KEY }} 37 | run: heroku container:release web -a type-depict -------------------------------------------------------------------------------- /src/Hoogle.hs: -------------------------------------------------------------------------------- 1 | module Hoogle (search) where 2 | 3 | import Data.Aeson (FromJSON, eitherDecode) 4 | 5 | import Data.ByteString.Lazy (fromStrict) 6 | import Data.Text (Text) 7 | import qualified Data.Text as T 8 | import GHC.Generics 9 | import qualified NeatInterpolation as NI 10 | import Network.HTTP.Client 11 | import Network.HTTP.Client.TLS (tlsManagerSettings) 12 | import Network.HTTP.Types.Status (statusCode) 13 | 14 | newtype HoogleRes = HoogleRes 15 | { item :: Text 16 | } 17 | deriving stock (Show, Eq, Generic) 18 | 19 | instance FromJSON HoogleRes 20 | 21 | search :: Manager -> Text -> IO (Either String Text) 22 | search manager needle = do 23 | let needle' = case T.split (== ' ') needle of 24 | x : _ -> x 25 | _ -> "id" 26 | url = searchUrl needle' 27 | request <- parseRequest url 28 | withResponse request manager $ do 29 | \responseBodyR -> do 30 | bs <- responseBody responseBodyR 31 | case eitherDecode @[HoogleRes] (fromStrict bs) of 32 | Right (HoogleRes{..} : _) -> pure $ Right item 33 | Right [] -> pure $ Left "no results" 34 | Left s -> pure $ Left s 35 | 36 | searchUrl :: Text -> String 37 | searchUrl t = 38 | T.unpack [NI.text|https://hoogle.haskell.org?mode=json&format=text&hoogle=$t&start=1&count=1|] 39 | 40 | testIt :: IO () 41 | testIt = do 42 | manager <- newManager tlsManagerSettings{managerModifyRequest = \r -> pure $ r{requestHeaders = [("User-Agent", "type-depict.io/0.0.1")]}} 43 | res <- search manager "traverse" 44 | print res -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /assets/style.css: -------------------------------------------------------------------------------- 1 | * { 2 | font-family: American Typewriter, serif; 3 | } 4 | .azure { 5 | background-color: azure; 6 | } 7 | .red { 8 | color: rgb(182, 63, 63); 9 | } 10 | .bluebg { 11 | background-color: lightskyblue; 12 | color: black; 13 | } 14 | .greenbg { 15 | background-color: lightgreen; 16 | color: black; 17 | } 18 | .snowbg { 19 | background-color: lightpink; 20 | color: black; 21 | } 22 | .content { 23 | overflow-x: auto; 24 | overflow-y: auto; 25 | scrollbar-width: none; 26 | } 27 | 28 | } 29 | .credits { 30 | font-size: 16px; 31 | color: lightslategrey; 32 | } 33 | button:disabled, 34 | button[disabled]{ 35 | background-color: #cccccc; 36 | color: #666666; 37 | } 38 | /* mobile device */ 39 | @media only screen and (max-width:445px){ 40 | h1 { 41 | font-size: 24px; 42 | } 43 | p { 44 | font-size: 16px; 45 | } 46 | body { 47 | background-color: antiquewhite; 48 | } 49 | a { 50 | margin: 0px; 51 | } 52 | form { 53 | width: 100%; 54 | } 55 | input { 56 | padding: 10px; 57 | font-size: 16px; 58 | max-width: 90%; 59 | overflow: scroll; 60 | } 61 | button { 62 | padding: 4px; 63 | margin-top: 8px; 64 | margin-right: 8px; 65 | margin-bottom: 8px; 66 | } 67 | svg { 68 | margin-top: 20px; 69 | max-width: 3000px; 70 | } 71 | .credits { 72 | font-size: 13px; 73 | margin-top: 60px; 74 | } 75 | } 76 | /* desktop */ 77 | @media only screen and not (max-width:445px) { 78 | * { 79 | font-family: American Typewriter, serif; 80 | } 81 | h1 { 82 | margin-left: 16px; 83 | } 84 | p { 85 | margin-left: 16px; 86 | } 87 | body { 88 | background-color: antiquewhite; 89 | } 90 | a { 91 | margin: 0px; 92 | } 93 | form { 94 | width: 100%; 95 | margin-left: 16px; 96 | } 97 | input { 98 | padding: 10px; 99 | font-size: 16px; 100 | } 101 | button { 102 | padding: 4px; 103 | margin-top: 8px; 104 | margin-right: 8px; 105 | margin-bottom: 8px; 106 | } 107 | svg { 108 | margin-top: 20px; 109 | margin-left: 16px; 110 | max-width: 3000px; 111 | } 112 | .sharelink { 113 | margin-left: 16px; 114 | } 115 | } 116 | -------------------------------------------------------------------------------- /type-depict.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: type-depict 3 | version: 0.1.0.0 4 | 5 | -- A short (one-line) description of the package. 6 | -- synopsis: 7 | 8 | -- A longer description of the package. 9 | -- description: 10 | 11 | -- A URL where users can report bugs. 12 | -- bug-reports: 13 | 14 | -- The license under which the package is released. 15 | -- license: 16 | author: Sjur Millidahl 17 | maintainer: sjur.millidahl@gmail.com 18 | 19 | -- A copyright notice. 20 | -- copyright: 21 | -- category: 22 | extra-source-files: CHANGELOG.md 23 | 24 | 25 | library 26 | hs-source-dirs: src 27 | default-language: Haskell2010 28 | build-depends: 29 | base ^>=4.14.3.0, 30 | aeson, 31 | attoparsec, 32 | bytestring, 33 | http-client, 34 | http-client-tls, 35 | http-types, 36 | neat-interpolation, 37 | svg-builder, 38 | text, 39 | transformers, 40 | unordered-containers 41 | exposed-modules: 42 | Hoogle 43 | Parser 44 | Visual 45 | default-extensions: 46 | DeriveGeneric 47 | DerivingStrategies 48 | LambdaCase 49 | OverloadedStrings 50 | RankNTypes 51 | RecordWildCards 52 | QuasiQuotes 53 | TypeApplications 54 | 55 | executable type-depict 56 | main-is: Main.hs 57 | ghc-options: -threaded -rtsopts -with-rtsopts=-N1 58 | build-depends: 59 | base ^>=4.14.3.0, 60 | type-depict, 61 | svg-builder, 62 | text, 63 | transformers 64 | hs-source-dirs: app 65 | default-language: Haskell2010 66 | default-extensions: 67 | DerivingStrategies 68 | LambdaCase 69 | OverloadedStrings 70 | RankNTypes 71 | RecordWildCards 72 | 73 | executable type-depict-ws 74 | main-is: Main.hs 75 | ghc-options: -threaded -rtsopts -with-rtsopts=-N1 76 | build-depends: 77 | base ^>=4.14.3.0, 78 | binary, 79 | bytestring, 80 | http-client, 81 | http-client-tls, 82 | http-types, 83 | neat-interpolation, 84 | scotty, 85 | type-depict, 86 | svg-builder, 87 | text, 88 | transformers 89 | hs-source-dirs: webserver 90 | default-language: Haskell2010 91 | default-extensions: 92 | DerivingStrategies 93 | GeneralizedNewtypeDeriving 94 | LambdaCase 95 | OverloadedStrings 96 | RankNTypes 97 | RecordWildCards 98 | QuasiQuotes 99 | TypeApplications 100 | 101 | Test-Suite type-depict-test 102 | type: exitcode-stdio-1.0 103 | main-is: Spec.hs 104 | ghc-options: -O2 -fwarn-incomplete-patterns -fwarn-redundant-constraints -fwarn-unused-imports -fwarn-unused-packages 105 | hs-source-dirs: test 106 | build-depends: 107 | type-depict, 108 | base ^>=4.14.3.0, 109 | hspec 110 | other-modules: 111 | VisualSpec 112 | default-language: Haskell2010 113 | -------------------------------------------------------------------------------- /test/VisualSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, OverloadedLists #-} 2 | 3 | module VisualSpec where 4 | 5 | import Parser 6 | import Visual 7 | 8 | import Test.Hspec 9 | 10 | spec :: Spec 11 | spec = describe "Parser" $ do 12 | it "should have a working dot parser" $ do 13 | Parser.parse "a" `shouldBe` Right (Dot "a") 14 | it "should visualize f a as (.)" $ do 15 | Parser.parse "f a" `shouldBe` Right (Embellish (Just "f") [Dot "a"]) 16 | it "should visualize >>=" $ do 17 | fmap Visual.render (Parser.parse "m a -> (a -> m b) -> m b") `shouldBe` Right "(.)--{.--(.)}--(.)" 18 | it "should visualize fix" $ do 19 | Parser.parse "(a -> a) -> a" `shouldBe` Right (Fix (Dot "a")) 20 | it "should visualize bitraverse" $ do 21 | fmap Visual.render (Parser.parse "(a -> f c) -> (b -> f d) -> t a b -> f (t c d)") `shouldBe` Right "{.--(.)}--{.--(.)}--(..)--({(..)})" 22 | it "should allow explicit existential quantification with forall keyword" $ do 23 | Parser.parse "forall a b. a -> b" `shouldBe` Right (Connect [Dot "a", Dot "b"]) 24 | it "should tolerate forall and contraints in forall a b. Functor f => f a" $ do 25 | Parser.parse "forall a b. Functor f => f a" `shouldBe` Right (Embellish (Just "f") [Dot "a"]) 26 | it "should tolerate a function name in pure :: forall a b. Functor f => f a" $ do 27 | Parser.parse "pure :: forall a b. Functor f => f a" `shouldBe` Right (Embellish (Just "f") [Dot "a"]) 28 | it "should tolerate only function name in f :: a" $ do 29 | Parser.parse "f :: a" `shouldBe` Right (Dot "a") 30 | it "should accept non-polymorphic types maybe :: Decoder a -> Decoder (Maybe a)" $ do 31 | fmap Visual.render (Parser.parse "maybe :: Decoder a -> Decoder (Maybe a)") `shouldBe` Right "(.)--({(.)})" 32 | it "should accept non-polymorphic types in e.g. String -> String" $ do 33 | Parser.parse "String -> String" `shouldBe` Right (Connect [Dot "String", Dot "String"]) 34 | it "understand e.g. non-polymorphic Either functions either :: (String -> Text) -> (Int -> Float) -> Either String Int -> Text" $ do 35 | fmap Visual.render (Parser.parse "either :: (String -> Text) -> (Int -> Float) -> Either String Int -> Text") `shouldBe` Right "{.--.}--{.--.}--(..)--." 36 | it "understand lists as embellishments" $ do 37 | Parser.parse "[a]" `shouldBe` Right (Embellish Nothing [Dot "a"]) 38 | it "understands applicative" $ do 39 | fmap Visual.render (Parser.parse "f ( a -> b ) -> f a -> f b") `shouldBe` Right "({.--.})--(.)--(.)" 40 | it "understand complicated list embellishments" $ do 41 | fmap Visual.render (Parser.parse "[(a -> b)] -> [a] -> [b]") `shouldBe` Right "({.--.})--(.)--(.)" 42 | it "understands a simple tuple (a,b)" $ do 43 | fmap Visual.render (Parser.parse "(a,b)") `shouldBe` Right "(..)" 44 | it "understands a complicated tuple (a,(a,(c,d)))" $ do 45 | fmap Visual.render (Parser.parse "(a,(a,(c,d)))") `shouldBe` Right "(.(.(..)))" 46 | it "understands a tuple with a connectable (a, f -> (m [a]))" $ do 47 | fmap Visual.render (Parser.parse "(a, f -> (m [a]))") `shouldBe` Right "(..--{((.))})" 48 | it "parses (a,b,c)" $ do 49 | Parser.parse "(a,b,c)" `shouldBe` Right (Embellish Nothing [Dot "a", Dot "b", Dot "c"]) 50 | it "parses f (b, a)" $ do 51 | Parser.parse "f (b, a)" `shouldBe` Right (Embellish (Just "f") [Embellish Nothing [Dot "b", Dot "a"]]) 52 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | {-#language OverloadedLists #-} 2 | module Parser where 3 | 4 | import Control.Applicative ((<|>)) 5 | import Data.Attoparsec.Text (Parser) 6 | import qualified Data.Attoparsec.Text as A 7 | import qualified Data.List.NonEmpty as NE 8 | import Data.List.NonEmpty (NonEmpty((:|))) 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | import Visual 12 | import Data.Text.Encoding (decodeUtf32BE) 13 | 14 | parse :: Text -> Either String Visual 15 | parse = A.parseOnly visParser . strip 16 | 17 | visParser :: Parser Visual 18 | visParser = fixParser <|> connectParser <|> embellishParser <|> groupParser <|> dotParser <|> listParser <|> tupleParser 19 | 20 | strip :: Text -> Text 21 | strip t = 22 | if T.null t 23 | then t 24 | else T.strip $ dropSignature $ dropForall $ dropConstraints t 25 | where 26 | dropSignature t' = maybeOnlyAfter t' "::" 27 | dropConstraints t' = maybeOnlyAfter t' "." 28 | dropForall t' = maybeOnlyAfter t' " =>" 29 | 30 | maybeOnlyAfter :: Text -> Text -> Text 31 | maybeOnlyAfter t needle = case T.splitOn needle t of 32 | [x] -> x 33 | (_ : ts) -> T.intercalate "" ts 34 | [] -> t 35 | 36 | fixParser :: Parser Visual 37 | fixParser = do 38 | c <- A.try connectParser 39 | case c of 40 | (Connect [Connect [a, b], c]) -> if b == c then pure (Fix a) else fail "" 41 | (Connect [Group (Connect [a, b]), c]) -> if b == c then pure (Fix a) else fail "" 42 | _ -> fail "" 43 | 44 | connectParser :: Parser Visual 45 | connectParser = do 46 | a <- A.skipSpace *> A.try connectable 47 | bs <- A.many1 $ do 48 | _ <- A.skipSpace >> A.string "->" >> A.skipSpace 49 | connectable 50 | pure $ Connect (a :| bs) 51 | where 52 | connectable = tupleParser <|> groupParser <|> embellishParser <|> dotParser <|> listParser 53 | 54 | embellishParser :: Parser Visual 55 | embellishParser = do 56 | _ <- A.skipSpace 57 | w <- wordspace 58 | e <- A.many1 $ do 59 | _ <- A.skipSpace 60 | embellishable 61 | pure . Embellish (Just w) . NE.fromList $ e 62 | where 63 | embellish1 = wordspace >> embellishable 64 | embellishable = groupParser <|> dotParser <|> listParser <|> tupleParser 65 | wordspace = word <* A.space 66 | 67 | listParser :: Parser Visual 68 | listParser = 69 | Embellish Nothing <$> do 70 | _ <- A.skipSpace 71 | _ <- A.char '[' *> A.many' A.space 72 | x <- listable 73 | _ <- A.many' A.space <* A.char ']' 74 | pure (NE.fromList [x]) 75 | where 76 | listable = connectParser <|> embellishParser <|> dotParser <|> groupParser <|> tupleParser 77 | 78 | word :: Parser String 79 | word = A.many1 A.letter 80 | 81 | tupleParser :: Parser Visual 82 | tupleParser = do 83 | _ <- A.skipSpace 84 | _ <- A.char '(' 85 | _ <- A.skipSpace 86 | ts <- A.many1 $ tupable <* A.skipSpace <* A.char ',' <* A.skipSpace 87 | t <- tupable 88 | _ <- A.skipSpace 89 | _ <- A.char ')' 90 | pure $ Embellish Nothing (NE.fromList (ts <> [t])) 91 | where 92 | tupable = connectParser <|> embellishParser <|> tupleParser <|> listParser <|> dotParser 93 | 94 | groupParser :: Parser Visual 95 | groupParser = 96 | Group <$> do 97 | _ <- A.skipSpace 98 | _ <- A.char '(' *> A.many' A.space 99 | x <- groupable 100 | _ <- A.many' A.space <* A.char ')' 101 | pure x 102 | where 103 | groupable = fixParser <|> connectParser <|> embellishParser <|> dotParser <|> listParser <|> tupleParser 104 | 105 | dotParser :: Parser Visual 106 | dotParser = do 107 | _ <- A.skipSpace 108 | ws <- word <|> T.unpack <$> A.string "()" 109 | pure $ Dot ws 110 | 111 | -------------------------------------------------------------------------------- /src/Visual.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module Visual where 4 | 5 | import Control.Monad.Trans.State.Lazy 6 | import Data.Foldable (fold) 7 | import Data.Functor (($>)) 8 | import Data.HashMap.Lazy (HashMap) 9 | import qualified Data.HashMap.Lazy as HML 10 | import Data.List (uncons) 11 | import Data.List.NonEmpty (NonEmpty ((:|))) 12 | import qualified Data.List.NonEmpty as NE 13 | import Data.Maybe (fromMaybe) 14 | import Data.Monoid 15 | import Data.Text (Text) 16 | import qualified Data.Text as T 17 | import Data.Word 18 | import Debug.Trace 19 | import Graphics.Svg ( 20 | AttrTag ( 21 | Cx_, 22 | Cy_, 23 | D_, 24 | Fill_, 25 | Height_, 26 | R_, 27 | Rx_, 28 | Stroke_, 29 | Stroke_dasharray_, 30 | Stroke_width_, 31 | Width_, 32 | X_, 33 | Y_ 34 | ), 35 | Element, 36 | circle_, 37 | lA, 38 | lR, 39 | mA, 40 | path_, 41 | rect_, 42 | (<<-), 43 | ) 44 | import Numeric (showHex) 45 | 46 | data Visual 47 | = Fix Visual 48 | | Connect (NonEmpty Visual) 49 | | Embellish (Maybe String) (NonEmpty Visual) 50 | | Group Visual 51 | | Dot String 52 | deriving stock (Eq, Show) 53 | 54 | render :: Visual -> Text 55 | render = \case 56 | Dot xs -> "." 57 | Connect xs -> T.intercalate "--" $ NE.toList $ fmap render xs 58 | Embellish _ as -> "(" <> foldMap render as <> ")" 59 | Fix a -> "@" <> render a 60 | Group a -> "{" <> render a <> "}" 61 | 62 | data Blobble = Blobble 63 | { w :: Float -- the width (without 2r) 64 | , r :: Float -- radius of this bubble 65 | , x :: Float -- absolute offset x in a larger Blobble 66 | , y :: Float -- absolute offset y in a larger Blobble 67 | } 68 | deriving (Show) 69 | 70 | data Color = Color {_r :: Word8, _g :: Word8, _b :: Word8} deriving stock (Eq) 71 | 72 | data Env = Env 73 | { colors :: HashMap String Color 74 | , idx :: Int 75 | } 76 | 77 | initEnv :: Env 78 | initEnv = 79 | Env 80 | { colors = HML.fromList [("a", Color 50 100 200), ("b", Color 110 210 20), ("f", Color 10 10 150), ("m", Color 150 10 10)] 81 | , idx = 0 82 | } 83 | 84 | renderSvg :: Blobble -> Visual -> State Env Element 85 | renderSvg blobble@Blobble{..} = \case 86 | Dot word -> do 87 | s@Env{..} <- get 88 | let (newEnv, c) = case HML.lookup word colors of 89 | Nothing -> 90 | let pickedColor = newColor !! idx 91 | in (s{colors = HML.insert word pickedColor colors, idx = succ idx}, pickedColor) 92 | Just c -> (s, c) 93 | midX = x + r + w / 2 + 2 94 | el = circle_ [Cx_ <<- cT midX, Cy_ <<- cT (y + r), R_ <<- "5", Fill_ <<- hex c] 95 | put newEnv $> traceShow blobble el 96 | Embellish ms xs -> do 97 | s@Env{..} <- get 98 | let (newEnv, c) = case ms of 99 | Nothing -> (s, Color 0 0 0) 100 | Just word -> case HML.lookup word colors of 101 | Nothing -> 102 | let pickedColor = newColor !! idx 103 | in (s{colors = HML.insert word pickedColor colors, idx = succ idx}, pickedColor) 104 | Just c' -> (s, c') 105 | let rect = rect_ [X_ <<- cT x, Y_ <<- cT y, Width_ <<- cT (r + r + w), Height_ <<- cT (2 * r), Rx_ <<- cT r, Fill_ <<- "none", Stroke_ <<- hex c, Stroke_width_ <<- "3"] 106 | put newEnv -- store new state before recursive call! 107 | let blobbles = splitV (length xs) (shrink blobble) 108 | zipped = zip blobbles (NE.toList xs) 109 | res = 110 | traverse 111 | (uncurry renderSvg) 112 | zipped 113 | mconcat . (rect :) <$> res 114 | Group a@(Connect _) -> do 115 | let rect = rect_ [X_ <<- cT x, Y_ <<- cT y, Width_ <<- cT (r + r + w), Height_ <<- cT (2 * r), Rx_ <<- cT r, Fill_ <<- "none", Stroke_ <<- "black", Stroke_width_ <<- "3", Stroke_dasharray_ <<- "4"] 116 | el <- renderSvg (shrink blobble) a 117 | pure $ rect <> el 118 | Group a -> renderSvg blobble a 119 | Fix a -> do 120 | let arr = 121 | path_ [D_ <<- mA (x + r + w / 2 + 20) (y + 2 * r) <> lR (-20) 20, Stroke_ <<- "black", Stroke_width_ <<- "3"] 122 | <> path_ [D_ <<- mA (x + r + w / 2 + 20) (y + 2 * r) <> lR (-20) (-20), Stroke_ <<- "black", Stroke_width_ <<- "3"] 123 | el <- renderSvg blobble (Embellish Nothing (NE.fromList [a])) 124 | el2 <- renderSvg (shrink blobble) a 125 | pure $ el <> el2 <> arr 126 | Connect xs -> do 127 | let blobbles = splitH (length xs) blobble 128 | zipped = zip blobbles (NE.toList xs) 129 | lines = connectLines zipped 130 | res = 131 | traverse 132 | (uncurry renderSvg) 133 | zipped 134 | mconcat . (lines :) <$> res 135 | 136 | dotV :: Blobble -> NonEmpty Float -- get y coords 137 | dotV Blobble{..} = 138 | let factors = 0 : ([1 ..] >>= (\i -> [i, i])) :: [Float] 139 | gameplan = zip (cycle [\f -> r + y - f * 10, \f -> r + y + f * 10]) factors 140 | in NE.fromList $ (\(f, a) -> f a) <$> gameplan 141 | 142 | splitV :: Int -> Blobble -> [Blobble] 143 | splitV n parent = 144 | if n < 2 145 | then [parent] 146 | else fmap (go parent n) [0 .. pred n] 147 | where 148 | go :: Blobble -> Int -> Int -> Blobble 149 | go Blobble{..} total idx = 150 | let n = fromIntegral total 151 | i = fromIntegral idx 152 | r' = r / n - 2 153 | in Blobble 154 | { x = x + r 155 | , y = i * 2 * r' + y + 4 156 | , r = r' 157 | , w = w - r 158 | } 159 | 160 | splitH :: Int -> Blobble -> [Blobble] 161 | splitH n parent = 162 | if n < 2 163 | then [parent] 164 | else fmap (go parent n) [1 .. n] 165 | where 166 | go :: Blobble -> Int -> Int -> Blobble 167 | go Blobble{..} total idx = 168 | let r' = r 169 | c = if idx == 1 then 0 else r' 170 | n = fromIntegral total 171 | w' = (w - 3 * n * r + 3 * r) / n 172 | in Blobble 173 | { x = x + ((r' + w' + r' + c) * fromIntegral (pred idx)) 174 | , y = y 175 | , r = r 176 | , w = w' 177 | } 178 | 179 | connectLines :: [(Blobble, Visual)] -> Element 180 | connectLines [b1, b2] = path_ [D_ <<- rightEdge mA b1 <> leftEdge lA b2, Stroke_ <<- "black", Stroke_width_ <<- "4"] 181 | connectLines (b1 : xs) = 182 | case uncons xs of 183 | Nothing -> mempty 184 | Just (t, xs') -> connectLines [b1, t] <> connectLines (t : xs') 185 | connectLines _ = mempty 186 | 187 | rightEdge :: (Float -> Float -> Text) -> (Blobble, Visual) -> Text 188 | rightEdge svgOp (Blobble{..}, Dot _) = svgOp (x + r + (w / 2)) (y + r) 189 | rightEdge svgOp (Blobble{..}, _) = svgOp (x + w + (2 * r)) (y + r) 190 | 191 | leftEdge :: (Float -> Float -> Text) -> (Blobble, Visual) -> Text 192 | leftEdge svgOp (Blobble{..}, Dot _) = svgOp (x + r + (w / 2)) (y + r) 193 | leftEdge svgOp (Blobble{..}, _) = svgOp x (y + r) 194 | 195 | cT :: Float -> Text 196 | cT = T.pack . show 197 | 198 | shrink :: Blobble -> Blobble 199 | shrink Blobble{..} = Blobble{x = x + 8, y = y + 8, w = w - 1, r = r - 8} 200 | 201 | hex :: Color -> Text 202 | hex Color{..} = "#" <> foldMap showHex2 [_r, _g, _b] 203 | where 204 | showHex2 :: forall a. (Integral a, Show a) => a -> Text 205 | showHex2 a = T.pack $ if a < 17 then "0" <> showHex a "" else showHex a "" 206 | 207 | newColor :: [Color] 208 | newColor = cycle [Color 0 0 0, Color 224 123 57, Color 105 189 210, Color 128 57 30, Color 204 231 232, Color 25 94 131] 209 | 210 | estimateWidth :: Visual -> Float 211 | estimateWidth vis = 212 | let l = vlength vis 213 | in if l == 1 214 | then 100 * min 1 (fromIntegral (succ (vdepth vis))) 215 | else 100 * fromIntegral (vlength vis) + 150 * fromIntegral (vdepth vis) 216 | 217 | vlength :: Visual -> Int 218 | vlength = go 1 219 | where 220 | go acc = 221 | \case 222 | Fix a -> go acc a 223 | Embellish _ l -> nonEmptyMax $ go acc <$> l 224 | Group a -> go acc a 225 | Dot _ -> acc 226 | Connect l -> nonEmptyMax $ go (max acc (NE.length l)) <$> l 227 | 228 | vdepth :: Visual -> Int 229 | vdepth = go 0 230 | where 231 | go acc = 232 | \case 233 | Fix a -> go (succ acc) a 234 | Embellish _ l -> nonEmptyMax $ go (succ acc) <$> l 235 | Group a -> go (succ acc) a 236 | Dot _ -> acc 237 | Connect l -> nonEmptyMax $ go acc <$> l 238 | 239 | nonEmptyMax :: Ord a => NonEmpty a -> a 240 | nonEmptyMax = maximum . NE.toList 241 | -------------------------------------------------------------------------------- /webserver/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad.IO.Class (liftIO) 4 | import qualified Control.Monad.Trans.State.Lazy as State 5 | import Data.Binary.Builder (toLazyByteString) 6 | import qualified Data.ByteString.Lazy as BSL 7 | import Data.Foldable (fold) 8 | import Data.String (IsString) 9 | import qualified Data.Text as StrictText 10 | import qualified Data.Text.Encoding as TE 11 | import Data.Text.Lazy (Text, fromStrict, toStrict) 12 | import qualified Data.Text.Lazy.Encoding as LTE 13 | import Debug.Trace (traceShowId) 14 | import Graphics.Svg 15 | import qualified Hoogle 16 | import qualified NeatInterpolation as NI 17 | import Network.HTTP.Client 18 | import Network.HTTP.Client.TLS (tlsManagerSettings) 19 | import Network.HTTP.Types.URI as Uri 20 | import qualified Parser 21 | import System.Environment (lookupEnv) 22 | import System.IO ( 23 | BufferMode (LineBuffering), 24 | hSetBuffering, 25 | stdout, 26 | ) 27 | import qualified Visual 28 | import Web.Scotty 29 | import Data.Text.Lazy.Encoding (encodeUtf8) 30 | 31 | -- heroku provides PORT 32 | readPort :: IO Int 33 | readPort = do 34 | maybe 3000 (read @Int) <$> lookupEnv "PORT" 35 | 36 | container :: [Attribute] 37 | container = [Version_ <<- "1.1", Width_ <<- "1500", Height_ <<- "140"] 38 | 39 | blobble :: Float -> Visual.Blobble 40 | blobble width = Visual.Blobble{x = 3, y = 3, w = width, r = 50} 41 | 42 | main :: IO () 43 | main = do 44 | hSetBuffering stdout LineBuffering 45 | manager <- newManager tlsManagerSettings{managerModifyRequest = \r -> pure $ r{requestHeaders = [("User-Agent", "type-depict.io/0.0.1")]}} 46 | putStrLn "Hello world, lets see what port" 47 | port <- readPort 48 | print port 49 | putStrLn "scotty webserver going up" 50 | scotty port $ do 51 | get "/" $ do 52 | html $ mainHtml Nothing (Expr "") (Content "") 53 | post "/" $ do 54 | redirect "/" 55 | get "/style.css" $ do 56 | setHeader "Content-Type" "text/css; charset=utf-8" 57 | file "assets/style.css" 58 | get "/favicon.ico" $ do 59 | setHeader "Content-Type" "image/vnd.microsoft.icon" 60 | file "assets/favicon.ico" 61 | get "/robots.txt" $ do 62 | setHeader "Content-Type" "text/plain" 63 | file "assets/robots.txt" 64 | post "/submit" $ do 65 | liftIO $ putStrLn "submit" 66 | txt <- param "signature" 67 | let lazyBSEnc = toLazyByteString $ Uri.encodePathSegments [txt] 68 | redirect (traceShowId $ LTE.decodeUtf8 lazyBSEnc) 69 | post "/hoogle" $ do 70 | needleP <- param "hoogle" 71 | liftIO $ print "hooglin for" 72 | let needle = toStrict $ LTE.decodeUtf8 (traceShowId needleP) 73 | hoogleRes <- liftIO $ Hoogle.search manager needle 74 | liftIO $ print "hoogleRes:" 75 | liftIO $ print hoogleRes 76 | either 77 | (\s -> html (mainHtml (Just (Hoogle (fromStrict needle))) "a -> b" "

Sorry, hoogle did not respond ok

")) 78 | (redirect . fromStrict) 79 | hoogleRes 80 | get "/api/:xpr" $ do 81 | p <- param "xpr" 82 | case Uri.decodePathSegments p of 83 | [] -> mempty 84 | (x : _) -> do 85 | setHeader "Content-Type" "image/svg+xml" 86 | drawSvgOnly x 87 | get "/:xpr" $ do 88 | p <- param "xpr" 89 | case Uri.decodePathSegments p of 90 | [] -> html (mainHtml Nothing "" "

Sorry, expression query param did not decode

") 91 | (x : _) -> draw x 92 | 93 | drawSvgOnly :: StrictText.Text -> ActionM () 94 | drawSvgOnly txt = 95 | case Parser.parse txt of 96 | Left _ -> html "

Sorry, expression did not parse

" 97 | Right vis -> do 98 | let initWidth = Visual.estimateWidth vis 99 | s = Visual.renderSvg (blobble initWidth) vis 100 | svg = State.evalState s Visual.initEnv 101 | res = doctype <> with (svg11_ svg) container 102 | raw . encodeUtf8 $ prettyText res 103 | 104 | draw :: StrictText.Text -> ActionM () 105 | draw txt = 106 | case Parser.parse txt of 107 | Left _ -> html (mainHtml Nothing "" "

Sorry, expression did not parse

") 108 | Right vis -> do 109 | let initWidth = Visual.estimateWidth vis 110 | s = Visual.renderSvg (blobble initWidth) vis 111 | svg = State.evalState s Visual.initEnv 112 | res = doctype <> with (svg11_ svg) container 113 | html (mainHtml Nothing (Expr . fromStrict $ txt) (Content $ prettyText res)) 114 | 115 | newtype Expr = Expr Text 116 | deriving stock (Eq, Show) 117 | deriving newtype (IsString) 118 | 119 | newtype Hoogle = Hoogle Text 120 | deriving stock (Eq, Show) 121 | deriving newtype (IsString) 122 | 123 | newtype Content = Content Text 124 | deriving stock (Eq, Show) 125 | deriving newtype (IsString) 126 | 127 | type Html = Text 128 | 129 | mainHtml :: Maybe Hoogle -> Expr -> Content -> Html 130 | mainHtml hoogleM expr content = fold ["", "", htmlHead, htmlBody hoogleM expr content, ""] 131 | 132 | htmlHead :: Html 133 | htmlHead = 134 | fold 135 | [ "" 136 | , "" 137 | , "type-depict.io" 138 | , "" 139 | , "" 140 | , "" 141 | ] 142 | 143 | htmlBody :: Maybe Hoogle -> Expr -> Content -> Html 144 | htmlBody hoogleM expr (Content content) = fold ["", "

", "Haskell Type Visualizer", "

", htmlForm hoogleM expr, "
", content, "
", shareLink, credits, ""] 145 | 146 | htmlForm :: Maybe Hoogle -> Expr -> Html 147 | htmlForm mh (Expr expr) = 148 | let strictT = toStrict expr 149 | strictH = maybe "" (\(Hoogle hoogle) -> toStrict hoogle) mh 150 | disableS = if StrictText.null strictT then "disabled" else "" 151 | in fromStrict 152 | [NI.text| 153 |
154 |
155 |
163 |
169 |
170 |
178 | 179 | 180 |
181 | |] 182 | 183 | credits :: Html 184 | credits = 185 | fromStrict 186 | [NI.text| 187 |

Created by Sjur Millidahl, published at GitHub

188 | |] 189 | 190 | shareLinkJs :: Html 191 | shareLinkJs = 192 | fromStrict 193 | [NI.text| 194 | 209 | |] 210 | 211 | shareLink :: Html 212 | shareLink = 213 | shareLinkJs 214 | <> fromStrict 215 | [NI.text| 216 | 224 | |] --------------------------------------------------------------------------------