rascal (empty) → 1.1.4

raw patch · 12 files changed

+860/−0 lines, 12 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changedbinary-added

Dependencies added: HUnit, QuickCheck, aeson, ansi-terminal, base, containers, curl, curl-aeson, directory, filepath, mtl, process, tasty, tasty-hunit, tasty-quickcheck, vector

Files

• LICENSE +21/−0
• README.md +70/−0
• Setup.hs +2/−0
• rascal.cabal +49/−0
• screenshot.png binary
• src/Main.hs +263/−0
• src/Rascal/Conf.hs +55/−0
• src/Rascal/Constants.hs +48/−0
• src/Rascal/Types.hs +119/−0
• src/Rascal/Utils.hs +110/−0
• src/Test.hs +123/−0
• threads.png binary

@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2013 Sylvain Soliman++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.

@@ -0,0 +1,70 @@+```+                              __ +.----.---.-.-----.----.---.-.|  |+|   _|  _  |__ --|  __|  _  ||  |+|__| |___._|_____|____|___._||__|+                                 +```++[![Build Status](https://travis-ci.org/soli/rascal.png)](https://travis-ci.org/soli/rascal)++rascal is a command-line client for [reddit](http://www.reddit.com/).++It should work on any platform where Haskell runs (Linux, Mac OSX and Windows+through MinGW), and aims at making available the whole reddit API (we're not+there yet…).++It sports colors, that should soon become configurable, and might not work+under Windows (based on ANSI escape sequences, through+[ansi-terminal](https://github.com/batterseapower/ansi-terminal)).++By default it will open [/r/haskell](http://www.reddit.com/r/haskell/new)+sorted by "new", but you can provide another subreddit as argument on the+command line++```+$ rascal python+```++It is also possible to define the default subreddit and the default sort+option in an INI-style configuration file named `.rascalrc` in your HOME+directory. For instance, it might contain the following (case-sensitive!):++```+subreddit: programming+linkSort = controversial+commentSort: new+pageComments = True+```++Here is what rascal looks like when started, and when a _self_ link (marked+with a '♦') is chosen (`N` was pressed in this case). Non-self links and links+detected in posts will be opened in your default browser.++![screenshot](https://github.com/soli/rascal/raw/master/screenshot.png)++Comments are shown threaded, with the order defined in the configuration file+(defaulting to `new`), and one page at a time if `pageComments` is true+(default). Comments, like posts, are formatted to avoid cutting words when+possible.++![threads](https://github.com/soli/rascal/raw/master/threads.png)++### Notes++In case you wonder, my iTerm2 is using the dark+[solarized](https://github.com/altercation/solarized) color scheme. The ASCII+title was generated with `figlet -f chunky`. And the name comes from my own+pronunciation of `/r/haskell`.++### Planned Features++* Configuration for colors+* OAuth2 login to reddit (subscribed/saved/etc.)+* more tests++## Disclaimer++Please note that rascal is my first Haskell project. As such, it is as much a+fun experiment for me to discover the ecosystem and the idioms, than a really+useful project. TL;DR: YMMV.

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

@@ -0,0 +1,49 @@+name:                rascal++-- The package version.  See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             1.1.4+synopsis:            A command-line client for Reddit+description:         Rascal is a command-line client for Reddit with colors,+                     configurable sorting, threaded comments, and some day+                     most of Reddit's API available.+license:             MIT+license-file:        LICENSE+author:              Sylvain Soliman+maintainer:          Sylvain.Soliman@gmail.com+category:            Web+build-type:          Simple+extra-source-files:  README.md, screenshot.png, threads.png+cabal-version:       >=1.10+stability:           experimental+homepage:            http://soli.github.io/rascal/++source-repository head+  type:              git+  location:          git://github.com/soli/rascal.git++executable rascal+  hs-source-dirs:    src+  main-is:           Main.hs+  other-modules:     Paths_rascal, Rascal.Utils, Rascal.Conf, Rascal.Types+                   , Rascal.Constants+  ghc-options:       -Wall+  build-depends:     base >=4.6 && <4.7, curl-aeson, curl, aeson+                   , process >= 1.2, ansi-terminal, vector+                   , filepath, directory, containers, mtl+  default-language:  Haskell2010++test-suite Tests+  hs-source-dirs:    src+  main-is:           Test.hs+  type:              exitcode-stdio-1.0+  build-depends:     base >=4.6 && <4.7, curl-aeson, curl, aeson+                   , process >= 1.2, ansi-terminal, vector+                   , filepath, directory, containers, mtl+                   , QuickCheck, tasty, tasty-quickcheck+                   , HUnit, tasty-hunit+  default-language:  Haskell2010

binary file changed (absent → 220715 bytes)

@@ -0,0 +1,263 @@+--+-- RASCAL, a Haskell cli reddit client+-- Copyright (c) 2013 Sylvain Soliman <Sylvain.Soliman@gmail.com>+-- MIT License, see LICENSE+--++import Control.Monad          (when, unless)+import Control.Monad.Reader   (ReaderT, ask, runReaderT)+import Control.Monad.Trans    (liftIO)+import Control.Applicative    ((<$>))+import Text.Printf            (printf)+import System.Environment     (getArgs)+import Data.Char              (ord)+import Data.List              (intercalate, elemIndices)+import Data.Maybe             (isJust)+import System.IO+import Control.Exception      (handle)++import Data.Aeson             (parseJSON, FromJSON)+import Network.Curl.Aeson     (curlAeson, noData, CurlAesonException, errorMsg, curlCode)+import Network.Curl.Opts      (CurlOption(CurlUserAgent))+import Network.Curl.Code      (CurlCode(CurlOK))+import System.Process         (readProcess)+import System.Console.ANSI    (clearLine)+import Data.Map               ((!))++import Rascal.Constants+import Rascal.Utils+import Rascal.Types+import Rascal.Conf++-- we do not use Show because we depend on (an IO generated) width+showLink :: Link -> Int -> String+showLink l width =+   let titlewidth = width - 34+       self | isSelf l = green ++ "♦"+            | otherwise = " "+       color | score l == 0 = blue+             | otherwise = red+       format = printf " %%s%%3d%%s%%s %%-%d.%ds  %%20.20s  %%s%%3d%%s "+                titlewidth titlewidth+   in printf format color (score l) self reset (title l) (author l)+      magenta (numComments l) reset++showListing :: NamedListing -> Int -> String+showListing l width =+   let lnks = links $ listing l+   in bold ++ "\n--=| /r/" ++ name l ++ " |=--\n\n" ++ reset +++      -- the -4 comes from letterizeLines+      letterizeLines (map (`showLink` (width - 4)) lnks)++showComment :: Int -> String -> String -> String -> String -> Comment -> [String]+showComment width prefix addedPrefix futurePrefix op+   (Comment cauthor ups downs _ body children) =+   let prefix' = prefix ++ futurePrefix+       author' | cauthor == op = green ++ cauthor ++ reset+               | otherwise = cauthor+       header = printf "%s─ %.20s (%s%d%s|%s%d%s)" addedPrefix author' red+         ups reset blue downs reset+       headerBlock = indentString width prefix header+       commentBlock = indentString width prefix' (unescape body)+   in (prefix ++ "│ "):(headerBlock ++ init commentBlock):+      showCommentListing width prefix' op children++showComment _ _ _ _ _ OriginalArticle =+   []++showCommentListing :: Int -> String -> String -> CommentListing -> [String]+showCommentListing width prefix op (CommentListing cl) =+   case cl of+      [] -> []+      _ -> concatMap (showComment width prefix "├" "│ " op) (init cl) +++          showComment width prefix "└" "  " op (last cl)++-- |print a listing on screen and ask for a command+displayListing :: NamedListing -> ReaderT RuntimeConf IO ()+displayListing l = do+   conf <- ask+   let w = textWidth conf+   liftIO $ do+      putStrLn $ showListing l w+      displayCommands w++-- |get posts according to selection in argument's subreddit as a listing+getListing :: String -> String -> Int -> Maybe String -> IO NamedListing+getListing select subreddit cnt aftr =+   let apiurl = "http://www.reddit.com/r/" ++ subreddit ++ "/%s.json?count="+                ++ show cnt ++ maybe "" ("&after=" ++) aftr+   in NamedListing (subreddit ++ " -- " ++ select) cnt <$>+      getThing apiurl select emptyListing++-- |get posts or comments from an apiurl, a sort order and a default in case+-- of error+getThing :: FromJSON a => String -> String -> a -> IO a+getThing apiurl sort emptyThing =+   let sort' = if sort `notElem` map snd availableSorts+               then snd . head $ availableSorts+               else sort+       apiurl' = printf apiurl sort'+   in handle (handleCurlAesonException emptyThing) $ do+      l <- curlAeson parseJSON "GET" apiurl' [CurlUserAgent userAgent] noData+      return $! l++-- |print error message if there is a cURL exception+handleCurlAesonException :: a -> CurlAesonException -> IO a+handleCurlAesonException x e = do+   putStrLn $ red ++ "Caught exception: " ++ reset ++ errorMsg e+   putStrLn $ if curlCode e == CurlOK+              then "(Might indicate a non-existing subreddit)"+              else "cURL code: " ++ (drop 4 . show . curlCode) e+   return x++-- |open nth link in a listing in given width+open :: NamedListing -> Int -> ReaderT RuntimeConf IO ()+open nl@(NamedListing _ _ (Listing l _)) n = do+   conf <- ask+   -- n >= 0 by construction on call of open, but...+   when (0 <= n && n < length l) $+      let ln = (l !! n)+          w = textWidth conf+          subreddit = takeWhile (/=' ') (name nl)+      in do+         if isSelf ln+         then openSelf ln+         else liftIO $ openUrl (link ln) w+         openComments subreddit ln+         displayListing nl++-- |display a self link, with its contained hrefs+openSelf :: Link -> ReaderT RuntimeConf IO ()+openSelf ln = do+   conf <- ask+   let refs = hrefs (selfHtml ln)+       w = textWidth conf+   liftIO $ do+      message "" w+      putStrLn $ cleanUp (selfText ln) w+      if null refs+      then waitKey w+      else do+         putStr "\n"+         mapM_ (putStrLn . showRef) $ zip [1..] refs+         message "press link number to open or a key to continue" w+         openRefs refs w++-- |display all comments of an article in a subreddit+openComments :: String -> Link -> ReaderT RuntimeConf IO ()+openComments subreddit ln = do+   conf <- ask+   let w = textWidth conf+       csort = commentSort conf+   when (numComments ln > 0) $ liftIO $ do+      (Comments cll) <- getComments subreddit (drop 3 (uid ln)) csort+      putStrLn ""+       -- the first is OriginalArticle, the length is always 2+      unless (null cll) $ do+         let allComments = showCommentListing w "" (author ln) (cll !! 1)+         if pageComments conf+         then doPageComments (textHeight conf - 2) 0 w allComments+         else mapM_ putStrLn allComments+      waitKey w++doPageComments :: Int -> Int -> Int -> [String] -> IO ()+doPageComments _ _ _ [] = return ()+doPageComments _ _ _ [_] = return ()   -- should never happen...+doPageComments height shown w allComments@(a:b:remaining)+   | shown > height = waitKey w >> doPageComments height 0 w allComments+   | otherwise = do+      let nbLines = 2 + sum (map (length . elemIndices '\n') [a, b])+          empty = height - shown+      shown' <- if empty > nbLines+               then return shown+               else do+                  waitKey w+                  -- '\b' is backspace, since even clearLine does not enforce+                  -- clearing the key typed for input+                  putStr "\b"+                  return 0+      putStrLn a+      putStrLn b+      doPageComments height (shown' + nbLines) w remaining++-- |request comments for a given article+getComments :: String -> String -> String -> IO Comments+getComments subreddit article csort =+   let apiurl = "http://www.reddit.com/r/" ++ subreddit +++                "/comments/" ++ article ++ ".json?sort=%s"+   in getThing apiurl csort emptyComments++-- |open requested hrefs as urls and stop if anything else+openRefs :: [String] -> Int -> IO ()+openRefs l w = do+   c <- getChar+   clearLine+   let n = ord c - ord '1'+   when (0 <= n && n < length l) $ do+      openUrl (l !! n) w+      openRefs l w++main ::  IO ()+main = do+   hSetBuffering stdin NoBuffering+   args <- getArgs+   columns <- readProcess "tput" ["cols"] []+   nbLines <- readProcess "tput" ["lines"] []+   conf <- getUserConfig ".rascalrc" defaultConf+   let width = read columns+       height = read nbLines+       subreddit | null args = conf ! "subreddit"+                 | otherwise = head args+       lSort  = conf ! "linkSort"+       cSort  = conf ! "commentSort"+       pComments = reads (conf ! "pageComments")+       pComments' | null pComments = True    -- TODO get from defaultConf+                  | otherwise = fst $ head pComments+       conf' = RuntimeConf width height cSort lSort pComments'+   list <- getListing lSort subreddit 0 Nothing+   runReaderT (displayListing list >> loop list) conf'++-- |show possible commands+displayCommands :: Int -> IO ()+displayCommands =+   message $ intercalate "/" (map makeCmd availableSorts) +++      "/⟨m⟩ore links/⟨s⟩witch subreddit/open ⟨A-Y⟩"++-- |main event loop+loop :: NamedListing -> ReaderT RuntimeConf IO ()+loop l = do+   cmd <- liftIO getChar+   liftIO clearLine+   conf <- ask+   case cmd of+      's' -> do+         subreddit <- liftIO $ do+            putStr "\nsubreddit to switch to: "+            hFlush stdout+            getLine+         list <- liftIO $ getListing (linkSort conf) subreddit 0 Nothing+         displayListing list+         loop list+      'm' -> if isJust (after (listing l))+            then do+               let subreddit = takeWhile (/= ' ') (name l)+                   sort = drop 4 (dropWhile (/= ' ') (name l))+                   cnt = count l + length (links (listing l))+                   aftr = after $ listing l+               list <- liftIO $ getListing sort subreddit cnt aftr+               displayListing list+               loop list+            else do+               liftIO $ message "no more posts…" (textWidth conf)+               loop l+      -- is this one of the sort options?+      x | isJust (getFullSort x) -> do+         list <- let (Just sort) = getFullSort x+                in liftIO $ getListing sort (takeWhile (/=' ') (name l)) 0 Nothing+         displayListing list+         loop list+      -- 25 elements displayed max+        | x `elem` ['A'..'Y'] -> do+         open l (ord x - ord 'A')+         loop l+      _ -> return ()

@@ -0,0 +1,55 @@+--+-- Looked at the several existing config-file parsing libs+-- they were all overkill+-- |This module does the strict minimum needed parsing INI-style+-- config files+--++{-# LANGUAGE ScopedTypeVariables #-}++module Rascal.Conf where++import Data.Map            (Map, union, fromList)+import Data.Char           (isSpace)+import Data.List           (dropWhileEnd)+import Control.Exception   (handle)+import Control.Monad       (liftM)++import System.Directory    (getHomeDirectory)+import System.FilePath     ((</>))++type Key   = String+type Value = String+type Conf  = Map Key Value++-- |Parses a string into a Map String String+parseConfig :: String -> Conf+parseConfig = fromList . map getKeyValue . filter configLine . lines++-- |keep only lines that will lead to some configuration element+-- stripping out comments, empty lines, etc.+configLine :: String -> Bool+configLine l =+   not (null l) && head l /= '#' && (':' `elem` l || '=' `elem` l)++-- |Turns a line into a key, value pair+getKeyValue :: String -> (Key, Value)+getKeyValue line =+   let (key, _:value) = break (`elem` ":=") line+   in (stripWhite key, stripWhite value)++-- |drop leading and ending white space+stripWhite :: String -> String+stripWhite =+   dropWhile isSpace . dropWhileEnd isSpace++-- |search for fileName in the user's home directory and combine it with+-- default options to provide a Conf map+getUserConfig :: String -> [(String, String)] -> IO Conf+getUserConfig fileName defaultOptions = do+   home <- getHomeDirectory+   let userConfFile = home </> fileName+       defaultConf = fromList defaultOptions+   handle (\(_ :: IOError) -> return defaultConf) $+      -- union will take left over right if key is defined twice+      liftM ((`union` defaultConf) . parseConfig) (readFile userConfFile)

@@ -0,0 +1,48 @@+-- |Various constants for rascal+module Rascal.Constants where++import Data.Version        (showVersion)++import System.Console.ANSI++import Paths_rascal        (version)++-- |user_agent for cURL built with version string+userAgent :: String+userAgent = "rascal/" ++ showVersion version ++ " by soli"++-- |colors and more+red :: String+red  = setSGRCode [SetColor Foreground Dull Red]+green :: String+green = setSGRCode [SetColor Foreground Dull Green]+yellow :: String+yellow  = setSGRCode [SetColor Foreground Dull Yellow]+blue :: String+blue  = setSGRCode [SetColor Foreground Dull Blue]+magenta :: String+magenta  = setSGRCode [SetColor Foreground Dull Magenta]+cyan :: String+cyan  = setSGRCode [SetColor Foreground Dull Cyan]+reset :: String+reset = setSGRCode [Reset]+bold :: String+bold = setSGRCode [SetConsoleIntensity BoldIntensity]++-- |available sort options+availableSorts :: [(Char, String)]+availableSorts = [+     ('n', "new")+   , ('h', "hot")+   , ('t', "top")+   , ('c', "controversial")+   ]++-- |default configuration options as an association list+defaultConf :: [(String, String)]+defaultConf = [+     ("subreddit", "haskell")+   , ("linkSort", "new")+   , ("commentSort", "new")+   , ("pageComments", "true")+   ]

@@ -0,0 +1,119 @@+{-# LANGUAGE OverloadedStrings #-}+-- allow Text objects directly as strings, used for JSON parsing++module Rascal.Types where++import Control.Applicative (empty, (<$>), (<*>), (<|>))++import Data.Aeson+import Data.Vector         (toList)++import Rascal.Utils        (unescape)++-- | a reddit post, called Link in reddit's API documentation+data Link = Link {+   title :: String,+   author :: String,+   score :: Int,+   isSelf :: Bool,+   link :: String,+   -- created :: Int,+   uid :: String,+   numComments :: Int,+   selfHtml :: String,+   selfText :: String+}++data Listing = Listing+   { links :: [Link]+   , after :: Maybe String+   }++emptyListing :: Listing+emptyListing = Listing [] Nothing++data NamedListing = NamedListing+   { name :: String+   , count :: Int+   , listing :: Listing+}++newtype Comments = Comments [CommentListing] deriving (Show)++emptyComments :: Comments+emptyComments = Comments []++newtype CommentListing = CommentListing [Comment] deriving (Show)++data Comment = Comment+   { _cauthor :: String+   , _ups :: Int+   , _downs :: Int+   -- , created :: Int+   -- , edited :: Int (or false)+   , __bodyHtml :: String+   , _body :: String+   , _children :: CommentListing+   }+   | OriginalArticle deriving (Show)++-- |json parser for 'Link'+instance FromJSON Link where+   parseJSON (Object o) = do+      datum <- o .: "data"+      etitle <- datum .: "title"+      Link (unescape etitle)+           <$> datum .: "author"+           <*> datum .: "score"+           <*> datum .: "is_self"+           <*> datum .: "url"+           -- <*> datum .: "created_utc"+           <*> datum .: "name"+           <*> datum .: "num_comments"+           <*> datum .:? "selftext_html" .!= ""+           <*> datum .: "selftext"+   parseJSON _ = empty++-- |json parser for 'Listing'+instance FromJSON Listing where+   parseJSON (Object o) = do+      datum <- o .: "data"+      Listing <$> datum .: "children"+              <*> datum .: "after"+   parseJSON _ = empty++-- |json parser for 'Comments'+instance FromJSON Comments where+   parseJSON (Array a) = Comments <$> mapM parseJSON (toList a)+   parseJSON _ = empty++instance FromJSON CommentListing where+   parseJSON (Object o) = do+      datum <- o .: "data"+      a <- datum .: "children"+      CommentListing <$> mapM parseJSON (toList a)+   parseJSON _ = empty++instance FromJSON Comment where+   parseJSON (Object o) =  do+      kind <- o .: "kind"+      if (kind :: String) == "t1"+      then do+         datum <- o .: "data"+         Comment <$> datum .: "author"+                 <*> datum .: "ups"+                 <*> datum .: "downs"+                 <*> datum .: "body_html"+                 <*> datum .: "body"+                 <*> (datum .: "replies" <|> return (CommentListing []))+      else+         return OriginalArticle+   parseJSON _ = empty++data RuntimeConf = RuntimeConf+   { textWidth :: Int+   , textHeight :: Int+   , commentSort :: String+   , linkSort :: String+   , pageComments :: Bool+   }

@@ -0,0 +1,110 @@+-- |Various utilities for rascal+module Rascal.Utils where++import System.Info         (os)+import Control.Exception   (handle)+import Data.List           (elemIndices)++import System.Process      (callProcess)+import System.Console.ANSI (clearLine)++import Rascal.Constants++-- |add capital letter and separate by newlines at most 25 strings+-- for a total of 4 chars+letterizeLines :: [String] -> String+letterizeLines l =+   unlines $ zipWith (\c s -> ' ':c:" |" ++ s) ['A'..'Y'] l++-- |Poor man's HTML entities unescaping+unescape :: String -> String+unescape [] = []+unescape ('&':'a':'m':'p':';':xs) = '&':unescape xs+unescape ('&':'l':'t':';':xs) = '<':unescape xs+unescape ('&':'g':'t':';':xs) = '>':unescape xs+unescape (x:xs) = x:unescape xs++-- |extract links from some HTML+hrefs :: String -> [String]+hrefs ('h':'r':'e':'f':'=':'"':s) =+   let (u, r) = break (== '"') s+   in (u:hrefs r)+hrefs (_:xs) = hrefs xs+hrefs "" = []++-- |pretty print sort name with initial or selected letter highlighted+makeCmd :: (Char, String) -> String+makeCmd (c, cmd) | c `notElem` cmd = '⟨':c:'⟩':tail cmd+                 | otherwise = let (hd, _:tl) = break (== c) cmd+                               in hd ++ '⟨':c:'⟩':tl++-- |get full sort name from initial+getFullSort :: Char -> Maybe String+getFullSort = (`lookup` availableSorts)++-- |add a prefix (e.g. indent) on the left for a string to be printed in given+-- width note, because of unlines, a \n ends each line+indentString :: Int -> String -> String -> String+indentString width prefix s =+   let lineLength = width - length prefix+       strings = concatMap (splitAt' lineLength) (lines s)+   in unlines $ map (prefix ++) strings++-- |split a string to a list of substring of length <= n+splitAt' :: Int -> String -> [String]+splitAt' 0 s = [s]+splitAt' n s =+   let (s1, s2) = splitAt n s+   in if null s2+      then [s1]+      else let (s1', s2') = splitAtLastSpace s1 s2+           in s1':splitAt' n s2'++splitAtLastSpace :: String -> String -> (String, String)+splitAtLastSpace s1 s2 =+   let spaces = elemIndices ' ' s1+   in if null spaces+      then (s1, s2)+      else let (s1', _:s2') = splitAt (last spaces) s1+           in (s1', s2' ++ s2)++-- | unescape and add newlines in order not to cut words+cleanUp :: String -> Int -> String+cleanUp s w =+      unlines (concatMap (splitAt' w) ((lines . unescape) s))++-- |display an informative message+message :: String -> Int -> IO ()+message s w =+   let col = cyan ++ reset+       msg = if null s+             then col+             else "--[" ++ cyan ++ s ++ reset ++ "]"+       l = length msg - length col+   in do+      putStrLn ""+      putStr msg+      putStrLn $ replicate (w - l) '-'++-- |wait for a key press+waitKey :: Int -> IO ()+waitKey width = do+   message "press a key to continue" width+   _ <- getChar+   clearLine+   return ()++-- |open an url in a platform independent way+openUrl :: String -> Int -> IO ()+openUrl u w = do+   message ("opening '" ++ u ++ "'…") w+   handle (\e -> print (e :: IOError)) $+      case os of+       "darwin"  -> callProcess "open" ["-g", u] -- open in the background+       "linux"   -> callProcess "xdg-open" [u, "&"] -- getEnv BROWSER ???+       "mingw32" -> callProcess "start" ["", u]+       _         -> return ()++showRef :: (Int, String) -> String+showRef (n, u) =+   " [" ++ yellow ++ show n ++ reset ++ "] " ++ blue ++ u ++ reset

@@ -0,0 +1,123 @@+module Main where++import Data.List                 (elemIndices, findIndices, union, isPrefixOf)+import Test.Tasty+import Test.Tasty.QuickCheck     (testProperty)+import Test.Tasty.HUnit+import Test.QuickCheck+import Data.Map                  (assocs)+import Control.Applicative       ((<$>))++import Rascal.Utils+import Rascal.Conf++data Lines = Lines [String] deriving (Show)++instance Arbitrary Lines where+   arbitrary =+      Lines <$> listOf1 (listOf (choose ('!', '~')))++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [properties, unitTests]++properties :: TestTree+properties = testGroup "Invariants checked with QuickCheck"+   [ testProperty "letterizeLines introduces the correct number of newlines"+      prop_letterizedLinesUnlines+   , testProperty "letterizeLines adds 4 chars per line"+      prop_letterizedLinesLength+   , testProperty "cleanUp only add lines"+      prop_cleanUpLines+   , testProperty "cleanUp only replaces spaces by newlines"+      prop_cleanUpSpacesToLines+   , testProperty "indentLines keeps lines under width"+      prop_indentStringHasWidth+   , testProperty "indentLines properly adds prefix"+      prop_indentStringInsertsPrefix+   ]++prop_letterizedLinesUnlines :: Lines -> Property+prop_letterizedLinesUnlines (Lines l) =+   length l <= 25 ==>+      (length . lines . letterizeLines) l == length l++prop_letterizedLinesLength :: Lines -> Bool+prop_letterizedLinesLength (Lines l) =+   length (head l) + 4 == length (head (lines (letterizeLines l)))++data WordList = WordList+   { wrds :: String+   , len :: Int+   } deriving (Show)++instance Arbitrary WordList where+   arbitrary = do+      Lines w <- arbitrary+      -- |don't want words that span the entire line length+      l <- choose (maximum (map length w) + 1, 200)+      return $ WordList (toStrLn w) l++toStrLn :: [String] -> String+toStrLn wl =+   unwords wl ++ "\n"++prop_cleanUpLines :: WordList -> Property+prop_cleanUpLines wl =+   let s = wrds wl+       l = len wl+       initialNewLines = elemIndices '\n' s+       cleanedNewLines = elemIndices '\n' (cleanUp s l)+   -- | if there are HTML entities to be escaped, it will introduce a shift+   in unescape s == s ==>+      cleanedNewLines `union` initialNewLines == cleanedNewLines++prop_cleanUpSpacesToLines :: WordList -> Property+prop_cleanUpSpacesToLines wl =+   let s = wrds wl+       l = len wl+   -- | if there are HTML entities to be escaped, it will introduce a shift+   in unescape s == s ==>+      findIndices (`elem` " \n") (cleanUp s l) == findIndices (`elem` " \n") s++prop_indentStringHasWidth :: Int -> String -> String -> Property+prop_indentStringHasWidth w prefix s =+   length prefix < w ==>+      all (\l -> length l <= w) $ lines (indentString w prefix s)++prop_indentStringInsertsPrefix :: Int -> String -> String -> Property+prop_indentStringInsertsPrefix w p s =+   length p < w && '\n' `notElem` p ==>+      all (isPrefixOf p) $ lines (indentString w p s)++unitTests :: TestTree+unitTests = testGroup "Unit tests" [unescapeTests, hrefsTests, parseConfigTests]++unescapeTests :: TestTree+unescapeTests = testGroup "unescape"+   [ testCase "unescapes empty" $+      unescape "" @?= ""+   , testCase "unescapes nothing" $+      unescape "& unescape amp nothing;" @?= "& unescape amp nothing;"+   , testCase "unescapes &amp;" $+      unescape "& unescape &amp; me;" @?= "& unescape & me;"+   , testCase "unescapes &lt; and &gt;" $+      unescape "& unescape &lt;me&gt;;" @?= "& unescape <me>;"+   ]++hrefsTests :: TestTree+hrefsTests =+   testGroup "hrefs" [testCase "no hrefs in empty" $ hrefs "" @?= []]++parseConfigTests :: TestTree+parseConfigTests = testGroup "parseConfig"+   [ testCase "parseConfig empty" $+      assocs (parseConfig "") @?= []+   , testCase "parseConfig dummy" $+      assocs (parseConfig "foo: bar\nstupid is stupid") @?= [("foo", "bar")]+   , testCase "parseConfig spaces" $+      assocs (parseConfig " foo : bar \n  stupid = really stupid  ") @?=+      [("foo", "bar"), ("stupid", "really stupid")]+   ]

binary file changed (absent → 186797 bytes)