module Data.Fortune
( module Data.Fortune.FortuneFile
, module Data.Fortune.Index
, S.FortuneStats
, numFortunes
, minChars
, maxLines
, minLines
, maxChars
, listFortuneFiles
, listFortuneFilesIn
, findFortuneFile
, findFortuneFileIn
, findFortuneFilesIn
, FortuneType(..)
, getFortuneDir
, defaultFortuneFiles
, defaultFortuneSearchPath
, getFortuneSearchPath
, resolveFortuneFile
, resolveFortuneFiles
, randomFortune
, randomFortuneFromRandomFile
, defaultFortuneDistribution
, fortuneDistributionWhere
, withFortuneFile
, withFortuneFiles
, mapFortunesWithIndexM
, mapFortunesWithIndex
, mapFortunesM
, mapFortunes
, filterFortunesWithIndexM
, filterFortunesWithIndex
, filterFortunesM
, filterFortunes
) where
import Data.Fortune.FortuneFile
import Data.Fortune.Index
import qualified Data.Fortune.Stats as S
import Control.Applicative
import Control.Exception
import Control.Monad
import Data.Char
import Data.Function
import Data.Maybe
import Data.Monoid (First(..))
import Data.Random hiding (Normal)
import Data.Random.Distribution.Categorical
import Data.Semigroup hiding (All, First(..))
import qualified Data.Text as T
import qualified Data.Vector as V
import Paths_misfortune
import System.Directory
import System.Environment
import System.FilePath
numFortunes :: S.FortuneStats -> Int
numFortunes = getSum . S.numFortunes
minChars :: S.FortuneStats -> Int
minChars = getMin . S.minChars
maxLines :: S.FortuneStats -> Int
maxLines = getMax . S.maxLines
minLines :: S.FortuneStats -> Int
minLines = getMin . S.minLines
maxChars :: S.FortuneStats -> Int
maxChars = getMax . S.maxChars
listDir dir =
map (dir </>) . filter (not . hidden) <$> getDirectoryContents dir
where hidden name = take 1 name == "."
traverseDir rec onFile = fix $ \search dir ->
let onItem path = do
isDir <- doesDirectoryExist path
if isDir
then if rec
then search path
else return []
else onFile path
in concat <$> (mapM onItem =<< listDir dir)
isIndexPath path = case takeExtension path of
".ix" -> True
".dat" -> True
_ -> False
listFortuneFiles :: Bool -> FilePath -> IO [FilePath]
listFortuneFiles rec = traverseDir rec onFile
where onFile path = return [ path | not (isIndexPath path) ]
listFortuneFilesIn :: [(FilePath, Bool)] -> IO [FilePath]
listFortuneFilesIn = fmap concat . mapM (uncurry (flip listFortuneFiles))
findFortuneFile :: Bool -> FilePath -> String -> IO [FilePath]
findFortuneFile rec dir file = search dir
where
search = traverseDir rec onFile
onFile path = return [ path | takeFileName path == file ]
findFortuneFileIn :: [(String, Bool)] -> String -> IO [FilePath]
findFortuneFileIn dirs file = concat <$> sequence
[ findFortuneFile rec dir file | (dir, rec) <- dirs]
findFortuneFilesIn :: [(String, Bool)] -> [String] -> IO [FilePath]
findFortuneFilesIn dirs files =
concat <$> mapM (findFortuneFileIn dirs) files
data FortuneType
= All
| Normal
| Offensive
deriving (Eq, Ord, Read, Show, Enum, Bounded)
getFortuneDir :: FortuneType -> IO FilePath
getFortuneDir fortuneType = do
dir <- getDataDir
return $! case fortuneType of
All -> dir </> "data"
Normal -> dir </> "data" </> "normal"
Offensive -> dir </> "data" </> "offensive"
defaultFortuneFiles :: FortuneType -> IO [FilePath]
defaultFortuneFiles fortuneType =
getFortuneSearchPath fortuneType >>= listFortuneFilesIn
defaultFortuneSearchPath :: FortuneType -> IO [(FilePath, Bool)]
defaultFortuneSearchPath fortuneType = do
dir <- getFortuneDir fortuneType
return [(dir, True)]
getEnv' typeStr key = do
env <- getEnvironment
let lookup' k = First . lookup k
return $ getFirst (lookup' (key ++ "_" ++ typeStr) env
<> lookup' key env)
getFortuneSearchPath :: FortuneType -> IO [(FilePath, Bool)]
getFortuneSearchPath defaultType
= getEnv' (map toUpper $ show defaultType) "MISFORTUNE_PATH"
>>= maybe (defaultFortuneSearchPath defaultType)
(return . map f . split)
>>= filterM (doesDirectoryExist . fst)
where
f ('+' : it) = (it, True)
f ('-' : it) = (it, False)
f it = (it, False)
split [] = []
split xs = a : split (drop 1 b)
where (a, b) = break (':' ==) xs
resolveFortuneFile :: FortuneType -> String -> IO [FilePath]
resolveFortuneFile defaultType file = do
dirs <- getFortuneSearchPath defaultType
findFortuneFileIn dirs file
resolveFortuneFiles :: FortuneType -> [String] -> IO [FilePath]
resolveFortuneFiles defaultType files = do
dirs <- getFortuneSearchPath defaultType
findFortuneFilesIn dirs files
randomFortune :: [String] -> IO String
randomFortune [] = do
paths <- defaultFortuneFiles Normal
if null paths
then return "Very few profundities can be expressed in less than 80 characters."
else randomFortune paths
randomFortune paths = withFortuneFiles '%' False paths $ \fs -> do
randomFortuneFromRandomFile . rvar =<< defaultFortuneDistribution fs
randomFortuneFromRandomFile :: RVar FortuneFile -> IO String
randomFortuneFromRandomFile file = do
f <- sample file
n <- getNumFortunes f
i <- sample (uniform 0 (n1))
T.unpack <$> getFortune f i
defaultFortuneDistribution :: [FortuneFile] -> IO (Categorical Float FortuneFile)
defaultFortuneDistribution [] = fail "defaultFortuneDistribution: no fortune files"
defaultFortuneDistribution fs = fromWeightedList <$> sequence
[ do
weight <- getNumFortunes f
return (fromIntegral weight, f)
| f <- fs
]
fortuneDistributionWhere
:: (FortuneFile -> Int -> IndexEntry -> IO Bool)
-> [FortuneFile]
-> IO (Categorical Float (FortuneFile, Categorical Float Int))
fortuneDistributionWhere p files =
fromWeightedList <$> sequence
[ do
is <- filterFortunesWithIndexM (p f) f
let iDist = fromObservations is
return (fromIntegral (numEvents iDist), (f, iDist))
| f <- files
]
withFortuneFile :: Char -> Bool -> FilePath -> (FortuneFile -> IO a) -> IO a
withFortuneFile delim writeMode path =
bracket (openFortuneFile delim writeMode path)
closeFortuneFile
withFortuneFiles :: Char -> Bool -> [FilePath] -> ([FortuneFile] -> IO a) -> IO a
withFortuneFiles _ _ [] action = action []
withFortuneFiles delim writeMode (p:ps) action =
withFortuneFile delim writeMode p $ \p ->
withFortuneFiles delim writeMode ps $ \ps ->
action (p:ps)
mapFortunesWithIndexM p f =
mapM (uncurry p) . zip [0..] . V.toList =<< getEntries =<< getIndex f
mapFortunesWithIndex p = mapFortunesWithIndexM (return . p)
mapFortunesM p = mapFortunesWithIndexM (const p)
mapFortunes p = mapFortunesM (return . p)
filterFortunesWithIndexM p = fmap catMaybes . mapFortunesWithIndexM p'
where
p' i e = fmap (toMaybe i) (p i e)
toMaybe i True = Just i
toMaybe _ False = Nothing
filterFortunesWithIndex p = filterFortunesWithIndexM (\i e -> return $! p i e)
filterFortunesM p = filterFortunesWithIndexM (const p)
filterFortunes p = filterFortunesWithIndex (const p)