diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8bf4b7b --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +.stack-work/ +chards.cabal +*~ \ No newline at end of file diff --git a/Cards.hs b/Cards.hs deleted file mode 100644 index f5e6d2c..0000000 --- a/Cards.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Cards - ( module Cards.Card - , Element - , Comment - , toCard - , fromCard - , testElements - ) where - -import Cards.Card -import Data.Time - -testElements :: [Element] -testElements = - [ card ["first card", "really"] - , card ["second card", "really"] - , comment "first comment" - , card ["third card", "really"] - , comment "second comment" - ] - where card = ECard . createCard someutctime - comment = EComment . Comment - someutctime = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) - -data Element = ECard Card | EComment Comment - deriving (Show) - -data Comment = Comment String - deriving (Show) - -{- - - Basic utility functions - -} - -toCard :: Element -> Maybe Card -toCard (ECard c) = Just c -toCard _ = Nothing - -fromCard :: Card -> Element -fromCard = ECard - diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..cc3d0d7 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for chards + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..5714ffc --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Joscha Mennicken (c) 2018 + +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 Joscha Mennicken 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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..de802f7 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# chards diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Main.hs b/app/Main.hs similarity index 73% rename from Main.hs rename to app/Main.hs index 0741c94..769bbb1 100644 --- a/Main.hs +++ b/app/Main.hs @@ -4,13 +4,15 @@ module Main import Cards import Control.Monad -import Control.Monad.Trans +import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Data.Char import Data.Maybe import Data.Time import System.Console.Haskeline +type Input = InputT IO + inputSettings :: Settings IO inputSettings = Settings { complete = noCompletion @@ -18,11 +20,15 @@ inputSettings = Settings , autoAddHistory = True } +{- + - Helper functions + -} + -- The prompt functions use a MaybeT wrapper because they can fail at any time. -- This happens when the user presses ctrl+D (EOF). -- Simple yes/no prompt (defaults to yes) -promptYesNo :: String -> MaybeT (InputT IO) Bool +promptYesNo :: String -> MaybeT Input Bool promptYesNo question = do i <- MaybeT $ getInputLine $ question ++ " [Y/n] " case map toLower i of @@ -34,7 +40,7 @@ promptYesNo question = do promptYesNo question -- Wait until user pressed Enter -promptContinue :: String -> MaybeT (InputT IO) () +promptContinue :: String -> MaybeT Input () promptContinue question = void $ MaybeT $ getInputLine $ question ++ "[Enter] " -- Just span, but with monads. @@ -49,37 +55,35 @@ spanM f l@(x:xs) = do else do return ([], l) -{- - - Dealing with Elements/Cards. - -} - --- Generic card counting function -countCardsBy :: (Card -> Bool) -> [Element] -> Int -countCardsBy f = length . filter elmF - where elmF e = fromMaybe False (f <$> toCard e) - --- Ask all cards in the list of elements which are due. --- When askNthCard fails, don't modify the rest of the list. --- This bit uses two MaybeTs inside each other, so beware :P -askCountdown :: UTCTime -> [Element] -> InputT IO [Element] -askCountdown _ [] = return [] -askCountdown time elms@(e:es) = - defaultTo elms $ do - result <- runMaybeT $ do - card <- MaybeT $ return $ toCard e - guard $ isDue time card - card' <- lift $ askCardWithInfo time card (countCardsBy (isDue time) es) - lift $ lift $ (fromCard card' :) <$> askCountdown time es - case result of - Nothing -> lift $ continue - Just r -> return r - where defaultTo what monad = fromMaybe what <$> runMaybeT monad - continue = (e :) <$> askCountdown time es +-- A few inefficient string formatting functions -- A simple right justify rjust :: Char -> Int -> String -> String rjust c l s = replicate (max 0 $ l - length s) c ++ s +-- Trims characters from the front and back of a string. +trim :: Char -> String -> String +trim c = dropWhile (== c) . reverse . dropWhile (== c) . reverse + +{- + - Dealing with Elements/Cards. + -} + +askElements :: UTCTime -> Elements -> Input Elements +askElements time elms = do + let l = toDueCards time elms + -- TODO: Randomize order + newCards <- askCountdown time l + return $ updateElements elms (fromCards newCards) + +askCountdown :: UTCTime -> [(Integer, Card)] -> Input [(Integer, Card)] +askCountdown _ [] = return [] +askCountdown time l@((key, card):xs) = do + result <- runMaybeT $ askCardWithInfo time card (length xs) + case result of + Nothing -> return l + Just card' -> ((key, card') :) <$> askCountdown time xs + -- These functions use a MaybeT wrapper because they can fail at any time, -- because they use the prompt functions. @@ -119,18 +123,15 @@ displaySide side = lift (putStrLn side) - User prompt. -} -learn :: [Element] -> InputT IO [Element] +learn :: Elements -> InputT IO Elements learn elms = do time <- lift $ getCurrentTime - askCountdown time elms + askElements time elms -stats :: [Element] -> InputT IO () +stats :: Elements -> InputT IO () stats = undefined -- TODO: Use tierName -trim :: Char -> String -> String -trim c = dropWhile (== c) . reverse . dropWhile (== c) . reverse - -run :: [Element] -> InputT IO [Element] +run :: Elements -> InputT IO Elements run elms = do cmd <- getInputLine "%> " case trim ' ' . map toLower <$> cmd of @@ -150,4 +151,4 @@ run elms = do main :: IO () main = do elms <- runInputT inputSettings $ run testElements - mapM_ (putStrLn . show) elms + putStrLn $ show elms diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..41cd4d0 --- /dev/null +++ b/package.yaml @@ -0,0 +1,52 @@ +name: chards +version: 0.1.0.0 +github: "Garmelon/chards" +license: BSD3 +author: "Joscha Mennicken" +maintainer: "joscha@migejolise.de" +copyright: "Joscha Mennicken" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on Github at + +dependencies: +- base >= 4.7 && < 5 +- containers +- time +- transformers +- haskeline + +library: + source-dirs: src + +executables: + chards-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - chards + +tests: + chards-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - chards diff --git a/Cards/Card.hs b/src/Cards.hs similarity index 60% rename from Cards/Card.hs rename to src/Cards.hs index 19f83d3..7a65a15 100644 --- a/Cards/Card.hs +++ b/src/Cards.hs @@ -1,7 +1,9 @@ -module Cards.Card - ( Tier -- Tier stuff - , tierDiff - , tierName +module Cards + ( Elements -- Elements stuff + , updateElements + , toCards + , toDueCards + , fromCards , Card -- Card stuff , sides , tier @@ -11,9 +13,21 @@ module Cards.Card , reset , update , createCard + , Tier -- Tier stuff + , tierDiff + , tierName + , testElements ) where -import Data.Time +import qualified Data.Map.Strict as Map +import Data.Time + +data Elements = Elements (Map.Map Integer Element) + deriving (Show) + +data Element = ECard Card + | EComment String + deriving (Show) data Card = Card { sides :: [String] @@ -28,35 +42,48 @@ data Tier = Unrevised | SixteenDays | ThirtyTwoDays | SixtyFourDays deriving (Show, Eq, Ord, Enum, Bounded) +testElements :: Elements +testElements = Elements . Map.fromList. zip [1..] $ + [ card ["first card", "really"] + , card ["second card", "really"] + , comment "first comment" + , card ["third card", "really"] + , comment "second comment" + ] + where card = ECard . createCard someutctime + comment = EComment + someutctime = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) + {- - - Tier stuff + - Elements stuff -} -tierDiff :: Tier -> NominalDiffTime -tierDiff Unrevised = 0 -tierDiff TenMin = 60 * 10 -tierDiff TwentyMin = 60 * 20 -tierDiff FortyMin = 60 * 40 -tierDiff OneDay = 3600 * ( 1 * 24 - 8) -tierDiff TwoDays = 3600 * ( 2 * 24 - 8) -tierDiff FourDays = 3600 * ( 4 * 24 - 8) -tierDiff EightDays = 3600 * ( 8 * 24 - 8) -tierDiff SixteenDays = 3600 * (16 * 24 - 8) -tierDiff ThirtyTwoDays = 3600 * (32 * 24 - 8) -tierDiff SixtyFourDays = 3600 * (64 * 24 - 8) +updateElements :: Elements -> Elements -> Elements +updateElements (Elements old) (Elements new) = Elements $ Map.union new old -tierName :: Tier -> String -tierName Unrevised = "unrevised" -tierName TenMin = "10min" -tierName TwentyMin = "20min" -tierName FortyMin = "40min" -tierName OneDay = "1d" -tierName TwoDays = "2d" -tierName FourDays = "4d" -tierName EightDays = "8d" -tierName SixteenDays = "16d" -tierName ThirtyTwoDays = "32d" -tierName SixtyFourDays = "64d" +toCards :: Elements -> [(Integer, Card)] +toCards (Elements elms) = + [(key, card) | (key, Just card) <- mapSnd toCard $ Map.toList elms] + +toDueCards :: UTCTime -> Elements -> [(Integer, Card)] +toDueCards time = filter (isDue time . snd) . toCards + +fromCards :: [(Integer, Card)] -> Elements +fromCards = Elements . Map.fromList . mapSnd fromCard + +mapSnd :: (b -> c) -> [(a, b)] -> [(a, c)] +mapSnd f l = [(a, f b) | (a, b) <- l] + +{- + - Element stuff + -} + +toCard :: Element -> Maybe Card +toCard (ECard c) = Just c +toCard _ = Nothing + +fromCard :: Card -> Element +fromCard = ECard {- - Card stuff @@ -91,7 +118,43 @@ createCard time s = Card{sides=s, tier=minBound, lastChecked=time, offset=0} {- - - Parsing Cards + - Tier stuff + -} + +tierDiff :: Tier -> NominalDiffTime +tierDiff Unrevised = 0 +tierDiff TenMin = 60 * 10 +tierDiff TwentyMin = 60 * 20 +tierDiff FortyMin = 60 * 40 +tierDiff OneDay = 3600 * ( 1 * 24 - 8) +tierDiff TwoDays = 3600 * ( 2 * 24 - 8) +tierDiff FourDays = 3600 * ( 4 * 24 - 8) +tierDiff EightDays = 3600 * ( 8 * 24 - 8) +tierDiff SixteenDays = 3600 * (16 * 24 - 8) +tierDiff ThirtyTwoDays = 3600 * (32 * 24 - 8) +tierDiff SixtyFourDays = 3600 * (64 * 24 - 8) + +tierName :: Tier -> String +tierName Unrevised = "unrevised" +tierName TenMin = "10min" +tierName TwentyMin = "20min" +tierName FortyMin = "40min" +tierName OneDay = "1d" +tierName TwoDays = "2d" +tierName FourDays = "4d" +tierName EightDays = "8d" +tierName SixteenDays = "16d" +tierName ThirtyTwoDays = "32d" +tierName SixtyFourDays = "64d" + +{- + - Converting to String + -} + +-- TODO + +{- + - Parsing -} -- TODO diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..1de6a19 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-10.2 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.6" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"