pursuit-client (empty) → 0.1.0

raw patch · 5 files changed

+222/−0 lines, 5 filesdep +basedep +http-clientdep +lenssetup-changed

Dependencies added: base, http-client, lens, pursuit-client, taggy-lens, text, wreq

Files

LICENSE +30/−0
Setup.hs +2/−0
app/Main.hs +19/−0
pursuit-client.cabal +39/−0
src/Web/Pursuit/Client.hs +132/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Gil Mizrahi (c) 2016++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 Gil Mizrahi 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ app/Main.hs view

@@ -0,0 +1,19 @@+{-# Language OverloadedStrings, LambdaCase #-}++module Main where++import qualified Data.Text as T+import qualified Data.Text.IO as T+import System.Environment (getArgs)+import Web.Pursuit.Client++main :: IO ()+main =+    getArgs >>= \case+        [] -> putStrLn "usage: pursuit-search \"<search-string>\""+        xs -> T.putStrLn . either T.pack showResults =<< search (unwords xs)+++showResults :: [Result] -> T.Text+showResults =+    T.unlines . map showResult

+ pursuit-client.cabal view

@@ -0,0 +1,39 @@+name:                pursuit-client+version:             0.1.0+synopsis:            A cli client for pursuit+description:         Please see README.md+homepage:            https://github.com/soupi/pursuit-client+license:             BSD3+license-file:        LICENSE+author:              Gil Mizrahi+maintainer:          soupiral@gmail.com+copyright:           2016 Gil Mizrahi+category:            Web+build-type:          Simple++cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Web.Pursuit.Client+  build-depends:+      base >= 4.7 && < 5+    , wreq+    , http-client+    , lens+    , taggy-lens+    , text+  default-language:    Haskell2010++executable pursuit-search+  hs-source-dirs:      app+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , text+                     , pursuit-client+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/soupi/pursuit-client

+ src/Web/Pursuit/Client.hs view

@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings, LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}++-- | API for querying pursuit.purescript.org+module Web.Pursuit.Client+    ( Result(..)+    , Content(..)+    , search+    , showResult+    , showContent+    ) where++import Data.Monoid ((<>))+import Control.Exception (catch)+import Network.Wreq+import Network.HTTP.Client (HttpException)+import Text.Taggy.Lens as TTL+import Control.Lens+import qualified Data.Text as T+import Data.Text.Lazy.Encoding (decodeUtf8)+++-- | A single result of a query+data Result = Result+  { rCont :: Content -- ^ content of the result+  , rUrl  :: T.Text  -- ^ url for more info+  } deriving (Show, Eq)++-- | Different types of results+data Content+  = Value T.Text T.Text T.Text -- ^ name, signature, package+  | Type T.Text [T.Text] T.Text T.Text -- ^ name, type args, body, package+  | NewType T.Text [T.Text] T.Text -- ^ name, type args, package+  | Data T.Text [T.Text] T.Text -- ^ name, type args, package+  | Class T.Text [T.Text] T.Text -- ^ name, type args, package+  | Module T.Text T.Text -- ^ name, package+  | Package T.Text -- ^ package+    deriving (Show, Eq)++-- | Pretty print a result+showResult :: Result -> T.Text+showResult res =+    T.unlines $ map ($ res)+        [ showContent . rCont+        , rUrl+        ]++-- | Pretty print the contents of a result+showContent :: Content -> T.Text+showContent = \case+  Value nm sig pkg -> nm <> " :: " <> sig <> "\n" <> pkg+  Type nm args body pkg -> T.intercalate " " (nm:args) <> " = " <> body <> "\n" <> pkg+  Data nm args pkg -> "data " <> T.intercalate " " (nm:args) <> "\n" <> pkg+  NewType nm args pkg -> "newtype " <> T.intercalate " " (nm:args) <> "\n" <> pkg+  Class nm args pkg -> "class " <> T.intercalate " " (nm:args) <> "\n" <> pkg+  Module nm pkg -> "module " <> nm <> "\n" <> pkg+  Package pkg -> "package " <> pkg++-- | search in pursuit+search :: String -> IO (Either String [Result])+search str =+    (results <$> find str) `catchHttp` (pure . Left . show)++catchHttp :: IO a -> (HttpException -> IO a) -> IO a+catchHttp = catch++find :: String -> IO [Element]+find s = do+    r <- get ("https://pursuit.purescript.org/search?q=" ++ s)+    let txt = r ^. responseBody . to decodeUtf8+    let res = txt ^.. html . allAttributed (folded . only "search-result")+    pure res++results :: [Element] -> Either String [Result]+results = traverse result++result :: Element -> Either String Result+result r = do+    url <- maybe (Left "Unable to parse element. please report this.") pure $ getUrl r+    cont <- (parseContent . getContent . NodeElement) r+    pure $ Result cont url++getUrl :: Element -> Maybe T.Text+getUrl r = r ^. attrs . at "href"++getContent :: Node -> [T.Text]+getContent c = c ^.. to universe . traverse . content+++parseContent :: [T.Text] -> Either String Content+parseContent ["package",pkg] = pure $ Package pkg+parseContent (reverse -> pkg:cont)+  | T.take 4 (head cont) == " :: " =+    pure $ Value (mconcat $ reverse $ tail cont) (T.drop 4 $ head cont) pkg++  | last cont == "type" && T.any (=='=') (head cont) =+    pure $ Type+        (mconcat $ reverse $ tail $ init cont)+        (T.words  $ T.takeWhile (/='=') $ head cont)+        (T.drop 2 $ T.dropWhile (/='=') $ head cont)+        pkg++  | T.take 5 (T.reverse (head cont)) == T.reverse "where" && last cont == "class" =+    pure $ Class+        (mconcat $ reverse $ tail $ init cont)+        (init $ T.words $ head cont)+        pkg++  | last cont == "module" =+    pure $ Module+        (mconcat $ reverse $ init cont)+        pkg++  | last cont == "data" =+    pure $ Data+        (mconcat $ reverse $ tail $ init cont)+        (T.words $ head cont)+        pkg+++  | last cont == "newtype" =+    pure $ NewType+        (mconcat $ reverse $ tail $ init cont)+        (T.words $ head cont)+        pkg+++parseContent x =+  Left $ unlines+      ["Error: No rule to parse: " ++ show x+      ,"Please report this."+      ]