{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-- louse - distributed bugtracker
-- Copyright (c) 2015, Peter Harpending.
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or (at
-- your option) any later version.
--
-- This program is distributed in the hope that it will be useful, but
-- WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see .
-- |
-- Module : Development.Louse
-- Description : The louse library
-- Copyright : Copyright (c) 2015, Peter Harpending.
-- License : GPL-3
-- Maintainer : Peter Harpending
-- Stability : experimental
-- Portability : UNIX/GHC
--
-- This is the top-level module for the louse library. You only need to
-- import this module, everything else will automatically be
-- re-exported.
--
-- Since: 0.1.0.0
module Development.Louse
(-- *** Convenience re-exports
module Control.Exceptional
-- * Creating pure-ish bugs
,Bug(..)
-- *** Bug titles
,Title
,mkTitle
,unTitle
-- *** Bug descriptions
,Description
,mkDescription
,unDescription
-- ** People
,Person(..)
,Author
,Reporter
-- ** Comments
,Comment(..)
-- *** Comment text
,CommentText
,mkCommentText
,unCommentText
-- *** Comment trees
,CommentTree
,unCommentTree
-- * Converting to & from bugs
,ToBug(..)
,FromBug(..)
-- * Converting to & from trees
,ToTree(..)
,FromTree(..)
-- ** Forests are just lists of trees
,ToForest(..)
,FromForest(..))
where
import Control.Exceptional
import Crypto.Hash.SHA1
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Foldable (Foldable(..))
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as H
#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid
#endif
import Data.String (IsString(..))
import Data.Ord (comparing)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time
import Data.Tree
-- |The type for a bug
--
-- Since: 0.1.0.0
data Bug =
Bug {bugTitle :: Title
,bugDescription :: Description
,bugAuthor :: Author
,bugTime :: UTCTime
,bugComments :: CommentTree}
deriving (Eq,Show)
-- |'Bug' is trivially an instance of 'FromBug'
--
-- Since: 0.1.0.0
instance FromBug Bug where
fromBug = id
-- |'Bug' is trivially an instance of 'ToBug'
instance ToBug Bug where
toBug = id
-- |A newtype over 'Text'. Haskell doesn't have dependent types, so I
-- have to use a hack called "smart constructors" to make sure
--
-- > 0 < title_length <= 64
--
-- Use 'mkTitle' to make a title. Alternatively, you could turn on
-- OverloadedStrings, and use 'Title''s 'IsString' instance:
--
-- >>> :set -XOverloadedStrings
-- >>> "hello" :: Title
-- Title {unTitle = "hello"}
-- it :: Title
--
-- Note that if you give invalid input, then there will be an error:
--
-- >>> "" :: Title
-- *** Exception: Title mustn't be empty.
-- >>> fromString (mconcat (replicate 50 "foo")) :: Title
-- *** Exception: Title mustn't be >64 characters long.
--
-- Since: 0.1.0.0
newtype Title =
Title {unTitle :: Text}
deriving (Eq)
-- |Compares by the value of @unTitle@.
--
-- Since: 0.1.0.0
instance Ord Title where
compare = comparing unTitle
-- |Since: 0.1.0.0
instance Show Title where
show = T.unpack . unTitle
-- |Note that this will throw an error if you give it an invalid value.
--
-- Since: 0.1.0.0
instance IsString Title where
fromString s =
case mkTitle (T.pack s) of
Failure err -> error err
Success s -> s
-- |Attempt to make a title, returning an error message if the length is
-- longer than 64 characters, or if the title is empty.
--
-- Since: 0.1.0.0
mkTitle :: Text -> Exceptional Title
mkTitle t
| T.null t = fail "Title mustn't be empty."
| 64 < T.length t = fail "Title mustn't be >64 characters long."
| otherwise = return (Title t)
-- |Yet another newtype over 'Text'. This is to make sure the
-- description is less than (or equal to) 8192 characters.
--
-- Use 'mkDescription' to make a description. This is an instance of
-- 'IsString', too, so, in pure code, you can just write plain strings,
-- and turn on the OverloadedStrings extension.
--
-- >>> :set -XOverloadedStrings
-- >>> "hello" :: Description
-- Description {unDescription = "hello"}
-- it :: Description
--
-- If you give invalid input, then there will be an error:
--
-- >>> "" :: Description
-- *** Exception: Description mustn't be empty.
--
-- Since: 0.1.0.0
newtype Description =
Description {unDescription :: Text}
deriving (Eq)
-- |Compares by the value of 'unDescription'.
--
-- Since: 0.1.0.0
instance Ord Description where
compare = comparing unDescription
-- |Since: 0.1.0.0
instance Show Description where
show = T.unpack . unDescription
-- |Note that this will throw an error if given invalid input.
--
-- Since: 0.1.0.0
instance IsString Description where
fromString s =
case mkDescription (T.pack s) of
Failure foo -> error foo
Success bar -> bar
-- |Attempt to make a description from a pure 'Text' value. This returns
-- an error if the description is empty.
--
-- Since: 0.1.0.0
mkDescription :: Text -> Exceptional Description
mkDescription t
| T.null t = fail "Description mustn't be empty."
| otherwise = return (Description t)
-- |Type for a person. Just has email and name
--
-- Since: 0.1.0.0
data Person =
Person {personName :: Text
,personEmail :: Text}
deriving (Eq)
-- |
-- >>> Person "Joe Q. Public" "jqp@foo.bar.baz"
-- Joe Q. Public
-- it :: Person
--
-- Since: 0.1.0.0
instance Show Person where
show (Person n e) = T.unpack (mconcat [n," <",e,">"])
-- |Alias for 'Person'
--
-- Since: 0.1.0.0
type Author = Person
-- |Alias for 'Person'
--
-- Since: 0.1.0.0
type Reporter = Person
-- |The type for a comment
--
-- Since: 0.1.0.0
data Comment =
Comment
{commentAuthor :: Author
,commentText :: CommentText
,subComments :: CommentTree}
deriving (Eq,Show)
-- |Comment text has the same requirements as a 'Description', so alias
-- the two
--
-- Since: 0.1.0.0
type CommentText = Description
-- |Alias for 'mkDescription'
--
-- Since: 0.1.0.0
mkCommentText :: Text -> Exceptional CommentText
mkCommentText = mkDescription
-- |Alias for 'unDescription'
--
-- Since: 0.1.0.0
unCommentText :: CommentText -> Text
unCommentText = unDescription
-- |This is similar to a Tree from containers, except it's implemented
-- using lazy 'HashMap's.
--
-- Specifically, this is a newtype over 'HashMap' 'ByteString' 'Comment'. The idea being that the key
--
-- Since: 0.1.0.0
newtype CommentTree =
CommentTree {unCommentTree :: HashMap ByteString Comment}
deriving (Eq,Show)
-- |Since: 0.1.0.0
instance ToForest CommentTree (Author,CommentText) where
toForest commentTree =
do (_,Comment auth txt subcomments) <-
H.toList (unCommentTree commentTree)
return (Node (auth,txt)
(toForest subcomments))
-- |Typeclass to convert something to a 'Bug'
class ToBug a where
toBug :: a -> Bug
-- |Convert something from a 'Bug'
--
-- Since: 0.1.0.0
class FromBug a where
fromBug :: Bug -> a
-- |Convert something of type @foo@ to a 'Tree' of type @bar@.
--
-- Since: 0.1.0.0
class ToTree foo bar where
toTree :: foo -> Tree bar
-- |Convert a 'Tree' of type @bar@s to something of type @foo@.
--
-- Since: 0.1.0.0
class FromTree bar foo where
fromTree :: Tree bar -> foo
-- |Convert something of type @foo@ to a 'Forest' of @bar@s.
--
-- Since: 0.1.0.0
class ToForest foo bar where
toForest :: foo -> Forest bar
-- |Since: 0.1.0.0
instance (ToTree foo bar,Foldable t) => ToForest (t foo) bar where
toForest = foldMap (\baz -> [toTree baz])
-- |Convert a 'Forest' of type @bar@ to something of type @foo@.
--
-- Since: 0.1.0.0
class FromForest bar foo where
fromForest :: Forest bar -> foo
-- |Since: 0.1.0.0
instance (FromTree bar foo) => FromForest bar [foo] where
fromForest = map fromTree