diff --git a/Penny.hs b/Penny.hs --- a/Penny.hs +++ b/Penny.hs @@ -15,12 +15,15 @@ , E.EvenAndOdd(..) , Sw.switchForeground , Sw.switchBackground - , module Penny.Cabin.Chunk + , module Penny.Steel.Chunk -- ** Sorting , Z.SortField(..) , CabP.SortOrder(..) + -- ** Expression type + , Exp.ExprDesc(..) + -- ** Formatting quantities , defaultQtyFormat @@ -67,9 +70,15 @@ -- "Penny.Lincoln" - the Penny core. Depends on no other Penny -- components. -- - -- "Penny.Shield" the Penny runtime environment. Depends on + -- "Penny.Shield" - the Penny runtime environment. Depends on -- Lincoln. -- + -- "Penny.Steel" - independent utilities. Depends on no other + -- Penny components. + -- + -- "Penny.Wheat" - tools to use with + -- "Penny.Steel.Prednote". Depends on Steel, Lincoln, and Copper. + -- -- "Penny.Zinc" - the Penny command-line interface. Depends on -- Cabin, Copper, Liberty, and Lincoln. -- @@ -83,8 +92,8 @@ import qualified Penny.Cabin.Balance.Convert.Options as ConvOpts import qualified Penny.Cabin.Balance.MultiCommodity as MC import qualified Penny.Cabin.Balance.MultiCommodity.Parser as MP -import Penny.Cabin.Chunk -import qualified Penny.Cabin.Chunk.Switch as Sw +import Penny.Steel.Chunk +import qualified Penny.Steel.Chunk.Switch as Sw import qualified Penny.Cabin.Interface as I import qualified Penny.Cabin.Options as CO import qualified Penny.Cabin.Parsers as CabP @@ -94,9 +103,10 @@ import qualified Penny.Cabin.Posts.Meta as M import qualified Penny.Cabin.Scheme as E import qualified Penny.Lincoln as L +import qualified Penny.Steel.Expressions as Exp import qualified Penny.Zinc as Z import qualified Penny.Shield as S -import qualified Text.Matchers.Text as Mr +import qualified Text.Matchers as Mr -- | This type contains settings for all the reports, as well as -- default settings for the global options. Some of these can be @@ -111,6 +121,10 @@ , colorToFile :: Bool -- ^ Use colors when standard output is not a terminal? + , expressionType :: Exp.ExprDesc + -- ^ Use RPN or infix expressions? This affects both the posting + -- filter and the filter for the Postings report. + , defaultScheme :: Maybe E.Scheme -- ^ Default color scheme. If Nothing, there is no default color -- scheme. If there is no default color scheme and the user does @@ -277,6 +291,7 @@ , Z.defaultScheme = defaultScheme d , Z.moreSchemes = additionalSchemes d , Z.sorter = sorter d + , Z.exprDesc = expressionType d } toBalanceDefaults :: Defaults -> MP.ParseOpts @@ -284,7 +299,6 @@ { MP.showZeroBalances = CO.ShowZeroBalances . balanceShowZeroBalances $ d , MP.order = balanceOrder d - , MP.needsHelp = False } toConvertDefaults :: Defaults -> ConvOpts.DefaultOpts diff --git a/Penny/Brenner.hs b/Penny/Brenner.hs --- a/Penny/Brenner.hs +++ b/Penny/Brenner.hs @@ -30,104 +30,51 @@ import Control.Applicative ((<*>)) import qualified System.Console.MultiArg as MA import qualified Control.Monad.Exception.Synchronous as Ex -import System.Exit (exitFailure) -import qualified System.IO as IO brennerMain :: Config -> IO () brennerMain cf = do - as <- MA.getArgs - pr <- MA.getProgName let cf' = convertConfig cf - r = MA.modes globalOpts (preProcessor cf') whatMode as - processParseResult pr cf' r + ioAction <- MA.modesWithHelp (help cf') globalOpts + (preProcessor cf') + ioAction -data Arg - = AHelp - | AFitAcct String +data Arg = AFitAcct String deriving (Eq, Show) toFitAcctOpt :: Arg -> Maybe String -toFitAcctOpt a = case a of { AFitAcct s -> Just s; _ -> Nothing } +toFitAcctOpt a = case a of { AFitAcct s -> Just s } globalOpts :: [MA.OptSpec Arg] globalOpts = - [ MA.OptSpec ["help"] "h" (MA.NoArg AHelp) - , MA.OptSpec ["fit-account"] "f" (MA.OneArg AFitAcct) - ] - -data PreProc - = NeedsHelp - | DoIt (Maybe Y.FitAcct) - -preProcessor :: Y.Config -> [Arg] -> Ex.Exceptional String PreProc -preProcessor cf as = - if any (== AHelp) as - then return NeedsHelp - else do - let cardOpt = case mapMaybe toFitAcctOpt as of - [] -> Nothing - xs -> Just . last $ xs - card <- case cardOpt of - Nothing -> return $ Y.defaultFitAcct cf - Just o -> - let pdct (Y.Name n, _) = n == X.pack o - in case filter pdct (Y.moreFitAccts cf) of - [] -> Ex.throw $ "financial institution account " - ++ o ++ " not configured." - (_, c):[] -> return $ Just c - _ -> Ex.throw $ "more than one financial institution account " - ++ "named " ++ o ++ " configured." - return $ DoIt card - -whatMode - :: PreProc - -> Either (String -> String) - [MA.Mode (Ex.Exceptional String (IO ()))] -whatMode pp = case pp of - NeedsHelp -> Left id - DoIt mayCd -> - Right $ [C.mode, I.mode, M.mode, P.mode, D.mode] <*> [mayCd] - - -processParseResult - :: String - -- ^ Program name - -> Y.Config - - -> Ex.Exceptional MA.Error - (a, Either b (Ex.Exceptional String (IO ()))) - -> IO () -processParseResult pr cf ex = - case ex of - Ex.Exception err -> do - IO.hPutStr IO.stderr $ MA.formatError pr err - exitFailure - Ex.Success g -> processResult pr cf g - - -processResult - :: String - -- ^ Program name + [ MA.OptSpec ["fit-account"] "f" (MA.OneArg AFitAcct) ] - -> Y.Config - -> (a, Either b (Ex.Exceptional String (IO ()))) - -> IO () -processResult pr cf (_, ei) = - case ei of - Left _ -> putStr (help pr cf) - Right ex -> case ex of - Ex.Exception e -> do - putStrLn $ pr ++ ": error: " ++ e - exitFailure - Ex.Success g -> g +preProcessor + :: Y.Config -> [Arg] -> Either (a -> IO ()) [MA.Mode (IO ())] +preProcessor cf as = Ex.toEither . Ex.mapException (const . fail) $ do + let mayFiStr = case mapMaybe toFitAcctOpt as of + [] -> Nothing + xs -> Just . last $ xs + fi <- case mayFiStr of + Nothing -> return $ Y.defaultFitAcct cf + Just s -> + let pdct (Y.Name n, _) = n == X.pack s + in case filter pdct (Y.moreFitAccts cf) of + [] -> Ex.throw $ + "financial institution account " + ++ s ++ " not configured." + (_, c):[] -> return $ Just c + _ -> Ex.throw $ + "more than one financial institution account " + ++ "named " ++ s ++ " configured." + return $ [C.mode, I.mode, M.mode, P.mode, D.mode] <*> [fi] -help :: - String +help + :: Y.Config + -> String -- ^ Program name - -> Y.Config -> String -help n c = unlines ls ++ cs +help c n = unlines ls ++ cs where ls = [ "usage: " ++ n ++ " [global-options]" ++ " COMMAND [local-options]" @@ -193,7 +140,7 @@ ++ "\n\n" --- | Information to configure a single card account. +-- | Information to configure a single financial institution account. data FitAcct = FitAcct { dbLocation :: String -- ^ Path and filename to where the database is kept. You can use @@ -252,8 +199,8 @@ convertFitAcct :: FitAcct -> Y.FitAcct convertFitAcct (FitAcct db ax df cy gs tl sd sb ps) = Y.FitAcct { Y.dbLocation = Y.DbLocation . X.pack $ db - , Y.pennyAcct = Y.PennyAcct . Bd.account $ ax - , Y.defaultAcct = Y.DefaultAcct . Bd.account $ df + , Y.pennyAcct = Y.PennyAcct . Bd.account . X.pack $ ax + , Y.defaultAcct = Y.DefaultAcct . Bd.account . X.pack $ df , Y.currency = Y.Currency . L.Commodity . X.pack $ cy , Y.groupSpecs = gs , Y.translator = tl diff --git a/Penny/Brenner/Clear.hs b/Penny/Brenner/Clear.hs --- a/Penny/Brenner/Clear.hs +++ b/Penny/Brenner/Clear.hs @@ -17,16 +17,14 @@ import qualified Penny.Copper.Types as Y import qualified Penny.Copper as C import qualified Penny.Copper.Render as R -import System.Exit (exitFailure) -import qualified System.IO as IO import Text.Show.Pretty (ppShow) import qualified Penny.Brenner.Types as Y import qualified Penny.Brenner.Util as U -help :: String -help = unlines - [ "usage: penny-fit clear clear [options] FIT_FILE LEDGER_FILE..." +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " clear clear [options] FIT_FILE LEDGER_FILE..." , "Parses all postings that are in FIT_FILE. Then marks all" , "postings that are in the FILEs given that correspond to one" , "of the postings in the FIT_FILE as being cleared." @@ -43,12 +41,11 @@ ] data Arg - = AHelp - | APosArg String + = APosArg String deriving (Eq, Show) toPosArg :: Arg -> Maybe String -toPosArg a = case a of { APosArg s -> Just s; _ -> Nothing } +toPosArg a = case a of { APosArg s -> Just s } data Opts = Opts { csvLocation :: Y.FitFileLocation @@ -56,56 +53,48 @@ } deriving Show -mode :: Maybe Y.FitAcct -> MA.Mode (Ex.Exceptional String (IO ())) +mode :: Maybe Y.FitAcct -> MA.Mode (IO ()) mode c = MA.Mode { MA.mName = "clear" , MA.mIntersperse = MA.Intersperse - , MA.mOpts = [ MA.OptSpec ["help"] "h" (MA.NoArg AHelp) ] + , MA.mOpts = [ ] , MA.mPosArgs = APosArg , MA.mProcess = process c + , MA.mHelp = help } -process :: Maybe Y.FitAcct -> [Arg] -> Ex.Exceptional String (IO ()) -process mayC as = - if any (== AHelp) as - then return $ putStrLn help - else do - c <- case mayC of - Just cd -> return cd - Nothing -> Ex.throw $ "no financial institution account given" - ++ " on command line, and no default financial" - ++ " institution configured." - (csv, ls) <- case mapMaybe toPosArg as of - [] -> Ex.throw $ "clear: you must provide a postings file." - x:xs -> return (Y.FitFileLocation x, xs) - let os = Opts csv ls - return $ runClear c os - -fatal :: String -> IO a -fatal s = do - IO.hPutStrLn IO.stderr $ "penny-fit clear: error: " ++ s - exitFailure +process :: Maybe Y.FitAcct -> [Arg] -> IO () +process mayC as = do + c <- case mayC of + Just cd -> return cd + Nothing -> fail $ "no financial institution account given" + ++ " on command line, and no default financial" + ++ " institution configured." + (csv, ls) <- case mapMaybe toPosArg as of + [] -> fail "clear: you must provide a postings file." + x:xs -> return (Y.FitFileLocation x, xs) + let os = Opts csv ls + runClear c os runClear :: Y.FitAcct -> Opts -> IO () runClear c os = do - dbList <- U.quitOnError - $ U.loadDb (Y.AllowNew False) (Y.dbLocation c) + dbList <- U.loadDb (Y.AllowNew False) (Y.dbLocation c) let db = M.fromList dbList (_, prsr) = Y.parser c - txns <- U.quitOnError $ prsr (csvLocation os) - leds <- C.openStdin (ledgerLocations os) - toClear <- case mapM (findUNumber db) txns of - Nothing -> fatal $ "at least one posting was not found in the" + txns <- fmap (Ex.switch fail return) $ prsr (csvLocation os) + leds <- C.open (ledgerLocations os) + toClear <- case mapM (findUNumber db) (concat txns) of + Nothing -> fail $ "at least one posting was not found in the" ++ " database. Ensure all postings have " ++ "been imported and merged." Just ls -> return $ Set.fromList ls let (led', left) = changeLedger (Y.pennyAcct c) toClear leds when (not (Set.null left)) - (fatal $ "some postings were not cleared. " + (fail $ "some postings were not cleared. " ++ "Those not cleared:\n" ++ ppShow left) case R.ledger (Y.groupSpecs c) led' of Nothing -> - fatal "could not render resulting ledger." + fail "could not render resulting ledger." Just txt -> TIO.putStr txt diff --git a/Penny/Brenner/Database.hs b/Penny/Brenner/Database.hs --- a/Penny/Brenner/Database.hs +++ b/Penny/Brenner/Database.hs @@ -3,11 +3,10 @@ import qualified Penny.Brenner.Types as Y import qualified Penny.Brenner.Util as U import qualified System.Console.MultiArg as MA -import qualified Control.Monad.Exception.Synchronous as Ex -help :: String -help = unlines - [ "penny-fit [global-options] database [local-options]" +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " [global-options] database [local-options]" , "Shows the database of financial institution transactions." , "Does not accept any non-option arguments." , "" @@ -15,37 +14,36 @@ , " --help, -h Show this help and exit." ] -data Arg = ArgHelp | ArgPos String deriving (Eq, Show) +data Arg = ArgPos String deriving (Eq, Show) mode :: Maybe Y.FitAcct - -> MA.Mode (Ex.Exceptional String (IO ())) + -> MA.Mode (IO ()) mode mayFa = MA.Mode { MA.mName = "database" , MA.mIntersperse = MA.Intersperse - , MA.mOpts = [MA.OptSpec ["help"] "h" (MA.NoArg ArgHelp)] + , MA.mOpts = [ ] , MA.mPosArgs = ArgPos , MA.mProcess = processor mayFa + , MA.mHelp = help } processor :: Maybe Y.FitAcct -> [Arg] - -> Ex.Exceptional String (IO ()) + -> IO () processor mayFa ls - | any (== ArgHelp) ls = return (putStrLn help) - | any isArgPos ls = Ex.throw $ + | any isArgPos ls = fail $ "penny-fit database: error: this command does" ++ " not accept non-option arguments." | otherwise = case mayFa of - Nothing -> Ex.throw $ "no financial institution account" + Nothing -> fail $ "no financial institution account" ++ " selected on command line, and no default" ++ " financial instititution account configured." - Just fa -> return $ do + Just fa -> do let dbLoc = Y.dbLocation fa - db <- U.quitOnError $ U.loadDb (Y.AllowNew False) dbLoc + db <- U.loadDb (Y.AllowNew False) dbLoc mapM_ putStr . map U.showDbPair $ db isArgPos :: Arg -> Bool isArgPos (ArgPos _) = True -isArgPos _ = False diff --git a/Penny/Brenner/Import.hs b/Penny/Brenner/Import.hs --- a/Penny/Brenner/Import.hs +++ b/Penny/Brenner/Import.hs @@ -5,13 +5,10 @@ import qualified System.Console.MultiArg as MA import qualified Penny.Brenner.Types as Y import qualified Penny.Brenner.Util as U -import qualified System.IO as IO -import qualified System.Exit as E data Arg - = AHelp - | AFitFile String + = AFitFile String | AAllowNew deriving (Eq, Show) @@ -27,58 +24,35 @@ -> IO (Ex.Exceptional String [Y.Posting]) } -{- mode - :: Y.DbLocation - -> ( Y.FitFileLocation - -> IO (Ex.Exceptional String [Y.Posting])) - -> MA.Mode (Ex.Exceptional String (IO ())) -mode dbLoc prsr = MA.Mode - { MA.mName = "import" - , MA.mIntersperse = MA.Intersperse - , MA.mOpts = - [ MA.OptSpec ["help"] "h" (MA.NoArg AHelp) - , MA.OptSpec ["new"] "n" (MA.NoArg AAllowNew) - ] - , MA.mPosArgs = AFitFile - , MA.mProcess = processor dbLoc prsr - } --} - -mode :: Maybe Y.FitAcct - -> MA.Mode (Ex.Exceptional String (IO ())) + -> MA.Mode (IO ()) mode mayFa = MA.Mode { MA.mName = "import" , MA.mIntersperse = MA.Intersperse , MA.mOpts = - [ MA.OptSpec ["help"] "h" (MA.NoArg AHelp) - , MA.OptSpec ["new"] "n" (MA.NoArg AAllowNew) - ] + [ MA.OptSpec ["new"] "n" (MA.NoArg AAllowNew) ] , MA.mPosArgs = AFitFile , MA.mProcess = processor mayFa + , MA.mHelp = help } processor :: Maybe Y.FitAcct -> [Arg] - -> Ex.Exceptional String (IO ()) + -> IO () processor mayFa as = do - let err s = Ex.throw $ "import: " ++ s - if any (== AHelp) as - then return $ putStrLn help - else do - (dbLoc, prsr) <- case mayFa of - Nothing -> err $ "no financial institution account provided" - ++ " on command line, and no default financial institution" - ++ " account is configured." - Just fa -> return (Y.dbLocation fa, snd . Y.parser $ fa) - loc <- case mapMaybe toFitFile as of - [] -> err "you must provide a postings file to read" - x:[] -> return (Y.FitFileLocation x) - _ -> err "you cannot provide more than one postings file to read" - let aNew = Y.AllowNew $ any (== AAllowNew) as - return $ doImport dbLoc (ImportOpts loc aNew prsr) + (dbLoc, prsr) <- case mayFa of + Nothing -> fail $ "no financial institution account provided" + ++ " on command line, and no default financial institution" + ++ " account is configured." + Just fa -> return (Y.dbLocation fa, snd . Y.parser $ fa) + loc <- case mapMaybe toFitFile as of + [] -> fail "you must provide a postings file to read" + x:[] -> return (Y.FitFileLocation x) + _ -> fail "you cannot provide more than one postings file to read" + let aNew = Y.AllowNew $ any (== AAllowNew) as + doImport dbLoc (ImportOpts loc aNew prsr) -- | Appends new Amex transactions to the existing list. @@ -106,20 +80,18 @@ doImport :: Y.DbLocation -> ImportOpts -> IO () doImport dbLoc os = do - txnsOld <- U.quitOnError $ U.loadDb (allowNew os) dbLoc + txnsOld <- U.loadDb (allowNew os) dbLoc parseResult <- parser os (fitFile os) ins <- case parseResult of - Ex.Exception e -> do - IO.hPutStrLn IO.stderr $ "penny-fit: error: " ++ e - E.exitFailure + Ex.Exception e -> fail e Ex.Success g -> return g let (new, len) = appendNew txnsOld ins U.saveDb dbLoc new putStrLn $ "imported " ++ show len ++ " new transactions." -help :: String -help = unlines - [ "penny-fit [global-options] import [local-options] FIT_FILE" +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " [global-options] import [local-options] FIT_FILE" , "where FIT_FILE is the file downloaded from the financial" , "institution." , "" diff --git a/Penny/Brenner/Merge.hs b/Penny/Brenner/Merge.hs --- a/Penny/Brenner/Merge.hs +++ b/Penny/Brenner/Merge.hs @@ -1,78 +1,70 @@ module Penny.Brenner.Merge (mode) where -import Control.Applicative (pure) +import Control.Applicative (pure, (<|>)) import Control.Monad (guard) import qualified Control.Monad.Trans.State as St -import Data.List (find) +import Data.List (find, sortBy, foldl') import qualified Data.Map as M -import Data.Maybe (mapMaybe, isNothing) +import Data.Maybe (mapMaybe, isNothing, fromMaybe) import Data.Monoid (First(..), mconcat) import qualified Data.Text as X import qualified Data.Text.IO as TIO import qualified System.Console.MultiArg as MA -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified System.IO as IO import qualified Penny.Copper as C import qualified Penny.Copper.Render as R import qualified Penny.Lincoln as L import qualified Penny.Lincoln.Transaction.Unverified as U import qualified Penny.Lincoln.Queries as Q -import System.Exit (exitFailure) import qualified Penny.Brenner.Types as Y import qualified Penny.Brenner.Util as U +type NoAuto = Bool + data Arg - = AHelp - | APos String + = APos String + | ANoAuto deriving (Eq, Show) toPosArg :: Arg -> Maybe String toPosArg a = case a of { APos s -> Just s; _ -> Nothing } -mode :: Maybe Y.FitAcct -> MA.Mode (Ex.Exceptional String (IO ())) +mode :: Maybe Y.FitAcct -> MA.Mode (IO ()) mode maybeC = MA.Mode { MA.mName = "merge" , MA.mIntersperse = MA.Intersperse - , MA.mOpts = - [ MA.OptSpec ["help"] "h" (MA.NoArg AHelp) - ] + , MA.mOpts = [MA.OptSpec ["no-auto"] "n" (MA.NoArg ANoAuto)] , MA.mPosArgs = APos , MA.mProcess = processor maybeC + , MA.mHelp = help } -processor :: Maybe Y.FitAcct -> [Arg] -> Ex.Exceptional a (IO ()) -processor maybeC as = return $ - if any (== AHelp) as - then putStrLn help - else doMerge maybeC (mapMaybe toPosArg as) +processor :: Maybe Y.FitAcct -> [Arg] -> IO () +processor maybeC as = + doMerge maybeC (ANoAuto `elem` as) (mapMaybe toPosArg as) -doMerge :: Maybe Y.FitAcct -> [String] -> IO () -doMerge maybeAcct ss = do +doMerge :: Maybe Y.FitAcct -> NoAuto -> [String] -> IO () +doMerge maybeAcct noAuto ss = do acct <- case maybeAcct of Nothing -> do - IO.hPutStrLn IO.stderr $ "merge: error: no financial" + fail $ "no financial" ++ " institution account provided on command line, and" ++ " no default account configured." - exitFailure Just ac -> return ac - dbLs <- U.quitOnError - $ U.loadDb (Y.AllowNew False) (Y.dbLocation acct) - l <- C.openStdin ss + dbLs <- U.loadDb (Y.AllowNew False) (Y.dbLocation acct) + l <- C.open ss let dbWithEntry = fmap (pairWithEntry acct) . M.fromList $ dbLs (l', db') = changeItems acct l (filterDb (Y.pennyAcct acct) dbWithEntry l) - newTxns = createTransactions acct db' + newTxns = createTransactions noAuto acct l dbLs db' final = C.Ledger (C.unLedger l' ++ newTxns) case R.ledger (Y.groupSpecs acct) final of - Nothing -> do - IO.hPutStrLn IO.stderr "Could not render final ledger." - exitFailure + Nothing -> fail "Could not render final ledger." Just x -> TIO.putStr x -help :: String -help = unlines - [ "penny-fit merge: merges new transactions from database" +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " merge: merges new transactions from database" , "to ledger file." , "usage: penny-fit merge [options] FILE..." , "Results are printed to standard output. If no FILE, or if FILE is -," @@ -80,6 +72,7 @@ , "" , "Options:" , " -h, --help - show help and exit" + , " -n, --no-auto - do not automatically assign payees and accounts" ] -- | Removes all Brenner postings that already have a Penny posting @@ -234,10 +227,13 @@ -- the Amex payee if that string is non empty; otherwise, uses the -- Amex description for the payee. newTransaction - :: Y.FitAcct + :: NoAuto + -> Y.FitAcct + -> UNumberLookupMap + -> PyeLookupMap -> (Y.UNumber, (Y.Posting, L.Entry)) -> L.Transaction -newTransaction acct (u, (a, e)) = L.rTransaction rt +newTransaction noAuto acct mu mp (u, (a, e)) = L.rTransaction rt where rt = L.RTransaction { L.rtCommodity = Y.unCurrency . Y.currency $ acct @@ -251,24 +247,109 @@ } tl = (U.emptyTopLine ( L.dateTimeMidnightUTC . Y.unDate . Y.date $ a)) - { U.tPayee = Just (L.Payee pa) } - pa = if X.null . Y.unPayee . Y.payee $ a - then Y.unDesc . Y.desc $ a - else Y.unPayee . Y.payee $ a + { U.tPayee = Just pa } + (guessedPye, guessedAcct) = guessInfo mu mp a + dfltPye = L.Payee $ if X.null . Y.unPayee . Y.payee $ a + then Y.unDesc . Y.desc $ a + else Y.unPayee . Y.payee $ a + dfltAcct = Y.unDefaultAcct . Y.defaultAcct $ acct + (pa, ac) = + if noAuto + then (dfltPye, dfltAcct) + else ( fromMaybe dfltPye guessedPye, + fromMaybe dfltAcct guessedAcct) pennyAcct = Y.unPennyAcct . Y.pennyAcct $ acct p1 = (U.emptyRPosting pennyAcct (L.qty . L.amount $ e)) { U.rTags = L.Tags [newLincolnUNumber u] } - p2 = U.emptyIPosting (Y.unDefaultAcct . Y.defaultAcct $ acct) + p2 = U.emptyIPosting ac -- | Creates new transactions for all the items remaining in the -- DbMap. Appends a blank line after each one. createTransactions - :: Y.FitAcct + :: NoAuto + -> Y.FitAcct + -> C.Ledger + -> Y.DbList -> DbWithEntry -> [C.Item] -createTransactions acct = +createTransactions noAuto acct led dbLs db = concatMap (\i -> [i, C.BlankLine]) . map C.Transaction - . map (newTransaction acct) + . map (newTransaction noAuto acct mu mp) . M.assocs + $ db + where + mu = makeUNumberLookup dbLs + mp = makePyeLookupMap (Y.pennyAcct acct) led +-- | Maps financial institution postings to UNumbers. The key is the +-- Payee of the financial institution posting, if it has one; +-- otherwise, it is the description if it has one. The UNumbers are in +-- a list, with UNumbers from most recent financial institution +-- postings first. +type UNumberLookupMap = M.Map X.Text [Y.UNumber] + +-- | Create a UNumberLookupMap from a DbWithEntry. Financial +-- institution postings with higher U-numbers will come first. +makeUNumberLookup :: Y.DbList -> UNumberLookupMap +makeUNumberLookup = foldl' ins M.empty . mapMaybe f . sortBy g + where + ins m (k, v) = M.alter alterer k m + where alterer Nothing = Just [v] + alterer (Just ls) = Just $ v:ls + f (u, p) = fmap (\k -> (k, u)) $ getBestPayee p + g (_, p1) (_, p2) = compare (Y.date p1) (Y.date p2) + +-- | Given a list of keys, find the first key that is in the +-- map. Returns Nothing if no key is in the map. +findFirstKey :: Ord k => M.Map k v -> [k] -> Maybe v +findFirstKey _ [] = Nothing +findFirstKey m (k:ks) = case M.lookup k m of + Nothing -> findFirstKey m ks + Just v -> Just v + +-- | Given a Posting, gets the Text that will work best as a payee +-- name. Uses the Payee field if there is one, or the Desc field if +-- there is one; otherwise Nothing. +getBestPayee :: Y.Posting -> Maybe X.Text +getBestPayee p = fromPayee <|> fromDesc + where + fromPayee = let pye = Y.unPayee . Y.payee $ p + in if X.null pye then Nothing else Just pye + fromDesc = let dsc = Y.unDesc . Y.desc $ p + in if X.null dsc then Nothing else Just dsc + +-- | Maps UNumbers to payees and accounts from the ledger. +type PyeLookupMap = M.Map Y.UNumber (Maybe L.Payee, Maybe L.Account) + +-- | Makes a payee lookup map. Puts those postings which match the +-- PennyAcct and have a UNumber into the map. (If two postings match +-- the PennyAcct and have the same UNumber, the one that appears later +-- in the ledger file will be in the map.) +makePyeLookupMap :: Y.PennyAcct -> C.Ledger -> PyeLookupMap +makePyeLookupMap a l + = M.fromList . mapMaybe f . concatMap L.postFam . mapMaybe toPstg + . C.unLedger $ l + where + f pstg = do + guard $ (Q.account pstg) == Y.unPennyAcct a + u <- getUNumberFromTags . Q.tags $ pstg + let (L.Child _ sib sibs _) = L.unPostFam pstg + ac = if null sibs + then Just (L.pAccount sib) + else Nothing + return (u, (Q.payee pstg, ac)) + toPstg i = case i of { C.Transaction t -> Just t; _ -> Nothing } + +-- | Given a UNumber and the maps, looks up the payee and account +-- information from previous transactions if this information is +-- available. +guessInfo + :: UNumberLookupMap + -> PyeLookupMap + -> Y.Posting + -> (Maybe L.Payee, Maybe L.Account) +guessInfo mu mp p = fromMaybe (Nothing, Nothing) $ do + pye <- getBestPayee p + unums <- M.lookup pye mu + findFirstKey mp unums diff --git a/Penny/Brenner/Print.hs b/Penny/Brenner/Print.hs --- a/Penny/Brenner/Print.hs +++ b/Penny/Brenner/Print.hs @@ -7,14 +7,12 @@ import qualified Penny.Brenner.Types as Y import qualified Penny.Brenner.Util as U import qualified System.Console.MultiArg as MA -import qualified System.IO as IO -import qualified System.Exit as E import qualified Control.Monad.Exception.Synchronous as Ex import Data.Maybe (mapMaybe) -help :: String -help = unlines - [ "penny-fit [global-options] print [local-options] FILE..." +help :: String -> String +help pn = unlines + [ "usage: " ++ pn ++ " [global-options] print [local-options] FILE..." , "Parses the transactions in each FILE using the appropriate parser" , "and prints the parse result to standard output." , "" @@ -23,34 +21,32 @@ ] data Arg - = ArgHelp - | ArgFile String + = ArgFile String deriving (Eq, Show) mode :: Maybe Y.FitAcct - -> MA.Mode (Ex.Exceptional String (IO ())) + -> MA.Mode (IO ()) mode mayFa = MA.Mode { MA.mName = "print" , MA.mIntersperse = MA.Intersperse - , MA.mOpts = [MA.OptSpec ["help"] "h" (MA.NoArg ArgHelp)] + , MA.mOpts = [] , MA.mPosArgs = ArgFile , MA.mProcess = processor mayFa + , MA.mHelp = help } processor :: Maybe Y.FitAcct -> [Arg] - -> Ex.Exceptional String (IO ()) + -> IO () processor mayFa ls = - if any (== ArgHelp) ls - then return (putStrLn help) - else case mayFa of - Nothing -> Ex.throw $ - "no financial institution account" - ++ " provided on command line, and no account" - ++ " configured by default." - Just fa -> return $ doPrint (snd . Y.parser $ fa) ls + case mayFa of + Nothing -> fail $ + "no financial institution account" + ++ " provided on command line, and no account" + ++ " configured by default." + Just fa -> doPrint (snd . Y.parser $ fa) ls doPrint :: (Y.FitFileLocation -> IO (Ex.Exceptional String [Y.Posting])) @@ -62,10 +58,8 @@ r <- prsr file case r of Ex.Exception s -> do - IO.hPutStrLn IO.stderr $ "penny-fit print: error: " ++ s - E.exitFailure + fail $ "penny-fit print: error: " ++ s Ex.Success ps -> mapM putStr . map U.showPosting $ ps toFile a = case a of ArgFile s -> Just (Y.FitFileLocation s) - _ -> Nothing diff --git a/Penny/Brenner/Util.hs b/Penny/Brenner/Util.hs --- a/Penny/Brenner/Util.hs +++ b/Penny/Brenner/Util.hs @@ -9,9 +9,6 @@ import qualified Penny.Copper.Parsec as CP import qualified Text.Parsec as P import qualified Penny.Lincoln as L -import Control.Monad (join) -import qualified System.IO as IO -import qualified System.Exit as E -- | Loads the database from disk. If allowNew is True, then does not -- fail if the file was not found. @@ -22,15 +19,17 @@ -> Y.DbLocation -- ^ DB location - -> IO (Ex.Exceptional String Y.DbList) + -> IO Y.DbList loadDb (Y.AllowNew allowNew) (Y.DbLocation dbLoc) = do eiStr <- IOE.tryIOError (BS.readFile . X.unpack $ dbLoc) case eiStr of Left e -> if allowNew && IOE.isDoesNotExistError e - then return (return []) + then return [] else IOE.ioError e - Right g -> return . readDbTuple $ g + Right g -> case readDbTuple g of + Ex.Exception e -> fail e + Ex.Success good -> return good -- | File version. Increment this when anything in the file format -- changes. @@ -65,15 +64,6 @@ Left e -> error $ "could not parse quantity from string: " ++ (X.unpack . Y.unAmount $ a) ++ ": " ++ show e Right g -> g - -quitOnError - :: IO (Ex.Exceptional String a) - -> IO a -quitOnError = join . fmap (Ex.switch err return) - where - err s = do - IO.hPutStrLn IO.stderr $ "penny-fit: error: " ++ s - E.exitFailure label :: String -> X.Text -> String label s x = s ++ ": " ++ X.unpack x ++ "\n" diff --git a/Penny/Cabin/Balance/Convert.hs b/Penny/Cabin/Balance/Convert.hs --- a/Penny/Cabin/Balance/Convert.hs +++ b/Penny/Cabin/Balance/Convert.hs @@ -163,35 +163,35 @@ -> I.Report cmdLineReport o rt = (help o, mkMode) where - mkMode _ _ fsf = MA.Mode + mkMode _ _ _ fsf = MA.Mode { MA.mName = "convert" , MA.mIntersperse = MA.Intersperse , MA.mOpts = map (fmap Right) P.allOptSpecs , MA.mPosArgs = Left - , MA.mProcess = process rt o fsf } + , MA.mProcess = process rt o fsf + , MA.mHelp = const (help o) + } process :: S.Runtime -> O.DefaultOpts -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) -> [Either String (P.Opts -> Ex.Exceptional String P.Opts)] - -> Ex.Exceptional String (Either I.HelpStr I.ArgsAndReport) + -> Ex.Exceptional X.Text I.ArgsAndReport process rt defaultOpts fsf ls = do let (posArgs, parsed) = Ei.partitionEithers ls op' = foldl (>>=) (return (O.toParserOpts defaultOpts rt)) parsed case op' of - Ex.Exception s -> Ex.throw s + Ex.Exception s -> Ex.throw . X.pack $ s Ex.Success g -> return $ let noDefault = X.pack "no default price found" - in case fromParsedOpts g of - NeedsHelp -> Left $ help defaultOpts - DoReport f -> - let pr ts pps = do - rptOpts <- Ex.fromMaybe noDefault $ - f pps (O.format defaultOpts) - let boxes = fsf ts - report rptOpts pps boxes - in Right (posArgs, pr) + f = fromParsedOpts g + pr ts pps = do + rptOpts <- Ex.fromMaybe noDefault $ + f pps (O.format defaultOpts) + let boxes = fsf ts + fmap (map Right) $ report rptOpts pps boxes + in (posArgs, pr) -- | Sums the balances from the bottom to the top of the tree (so that @@ -220,22 +220,18 @@ mostFrequent = U.lastMode . map (L.to . L.price) -data HelpOrOpts - = NeedsHelp - | DoReport ( [L.PricePoint] +type DoReport = [L.PricePoint] -> (L.Commodity -> L.Qty -> X.Text) - -> (Maybe Opts)) + -> (Maybe Opts) -- | Get options for the report, depending on what options were parsed -- from the command line. Fails if the user did not specify a -- commodity and mostFrequent fails. fromParsedOpts :: P.Opts - -> HelpOrOpts -fromParsedOpts (P.Opts szb tgt dt so sb hlp) = - if hlp - then NeedsHelp - else DoReport $ \pps fmt -> case tgt of + -> DoReport +fromParsedOpts (P.Opts szb tgt dt so sb) = + \pps fmt -> case tgt of P.ManualTarget to -> Just $ Opts fmt szb (getSorter so sb) to dt P.AutoTarget -> diff --git a/Penny/Cabin/Balance/Convert/Chunker.hs b/Penny/Cabin/Balance/Convert/Chunker.hs --- a/Penny/Cabin/Balance/Convert/Chunker.hs +++ b/Penny/Cabin/Balance/Convert/Chunker.hs @@ -12,7 +12,7 @@ import Control.Applicative (Applicative (pure), (<$>), (<*>)) import qualified Penny.Cabin.Scheme as E -import qualified Penny.Cabin.Chunk as Chunk +import qualified Penny.Steel.Chunk as Chunk import qualified Penny.Cabin.Meta as Meta import qualified Penny.Cabin.Row as R import qualified Penny.Lincoln as L diff --git a/Penny/Cabin/Balance/Convert/Options.hs b/Penny/Cabin/Balance/Convert/Options.hs --- a/Penny/Cabin/Balance/Convert/Options.hs +++ b/Penny/Cabin/Balance/Convert/Options.hs @@ -29,7 +29,6 @@ , P.dateTime = S.currentTime rt , P.sortOrder = sortOrder d , P.sortBy = sortBy d - , P.showHelp = False } defaultOptions :: DefaultOpts diff --git a/Penny/Cabin/Balance/Convert/Parser.hs b/Penny/Cabin/Balance/Convert/Parser.hs --- a/Penny/Cabin/Balance/Convert/Parser.hs +++ b/Penny/Cabin/Balance/Convert/Parser.hs @@ -31,7 +31,6 @@ , dateTime :: L.DateTime , sortOrder :: P.SortOrder , sortBy :: SortBy - , showHelp :: Bool } -- | Do not be tempted to change the setup in this module so that the @@ -45,8 +44,7 @@ , fmap toExc parseAuto , parseDate , fmap toExc parseSort - , fmap toExc parseOrder - , fmap toExc parseHelp ] + , fmap toExc parseOrder ] where toExc f = return . f @@ -87,8 +85,3 @@ parseOrder = fmap f P.order where f x o = o { sortOrder = x } - -parseHelp :: C.OptSpec (Opts -> Opts) -parseHelp = fmap f P.help - where - f _ o = o { showHelp = True } diff --git a/Penny/Cabin/Balance/MultiCommodity.hs b/Penny/Cabin/Balance/MultiCommodity.hs --- a/Penny/Cabin/Balance/MultiCommodity.hs +++ b/Penny/Cabin/Balance/MultiCommodity.hs @@ -48,14 +48,13 @@ defaultParseOpts = P.ParseOpts { P.showZeroBalances = CO.ShowZeroBalances False , P.order = CP.Ascending - , P.needsHelp = False } fromParseOpts :: (L.Commodity -> L.Qty -> X.Text) -> P.ParseOpts -> Opts -fromParseOpts fmt (P.ParseOpts szb o _) = Opts fmt szb o' +fromParseOpts fmt (P.ParseOpts szb o) = Opts fmt szb o' where o' = case o of CP.Ascending -> compare @@ -108,12 +107,13 @@ -> I.Report parseReport fmt o rt = (help o, makeMode) where - makeMode _ _ fsf = MA.Mode + makeMode _ _ _ fsf = MA.Mode { MA.mName = "balance" , MA.mIntersperse = MA.Intersperse , MA.mOpts = map (fmap Right) P.allSpecs , MA.mPosArgs = Left , MA.mProcess = process fmt o rt fsf + , MA.mHelp = const (help o) } process @@ -123,16 +123,14 @@ -> a -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) -> [Either String (P.ParseOpts -> P.ParseOpts)] - -> f (Either I.HelpStr I.ArgsAndReport) + -> f I.ArgsAndReport process fmt o _ fsf ls = let (posArgs, fns) = Ei.partitionEithers ls mkParsedOpts = foldl (flip (.)) id fns os' = mkParsedOpts o mcOpts = fromParseOpts fmt os' - pr txns _ = return $ report mcOpts (fsf txns) - in pure $ if P.needsHelp os' - then Left $ help o - else Right (posArgs, pr) + pr txns _ = return . map Right $ report mcOpts (fsf txns) + in pure (posArgs, pr) -- | The MultiCommodity report, with default options. diff --git a/Penny/Cabin/Balance/MultiCommodity/Chunker.hs b/Penny/Cabin/Balance/MultiCommodity/Chunker.hs --- a/Penny/Cabin/Balance/MultiCommodity/Chunker.hs +++ b/Penny/Cabin/Balance/MultiCommodity/Chunker.hs @@ -9,7 +9,7 @@ import Control.Applicative (Applicative (pure), (<$>), (<*>)) -import qualified Penny.Cabin.Chunk as Chunk +import qualified Penny.Steel.Chunk as Chunk import qualified Penny.Cabin.Meta as Meta import qualified Penny.Cabin.Row as R import qualified Penny.Cabin.Scheme as E diff --git a/Penny/Cabin/Balance/MultiCommodity/Parser.hs b/Penny/Cabin/Balance/MultiCommodity/Parser.hs --- a/Penny/Cabin/Balance/MultiCommodity/Parser.hs +++ b/Penny/Cabin/Balance/MultiCommodity/Parser.hs @@ -12,15 +12,9 @@ data ParseOpts = ParseOpts { showZeroBalances :: CO.ShowZeroBalances , order :: P.SortOrder - , needsHelp :: Bool } -parseHelp :: MA.OptSpec (ParseOpts -> ParseOpts) -parseHelp = fmap f P.help - where - f _ o = o { needsHelp = True } - zeroBalances :: MA.OptSpec (ParseOpts -> ParseOpts) zeroBalances = fmap toResult P.zeroBalances where @@ -32,4 +26,4 @@ toResult x o = o { order = x } allSpecs :: [MA.OptSpec (ParseOpts -> ParseOpts)] -allSpecs = [parseHelp, zeroBalances, parseOrder] +allSpecs = [zeroBalances, parseOrder] diff --git a/Penny/Cabin/Balance/Util.hs b/Penny/Cabin/Balance/Util.hs --- a/Penny/Cabin/Balance/Util.hs +++ b/Penny/Cabin/Balance/Util.hs @@ -19,7 +19,7 @@ import qualified Penny.Cabin.Options as CO import qualified Penny.Lincoln as L -import qualified Penny.Lincoln.NestedMap as NM +import qualified Penny.Steel.NestedMap as NM import qualified Data.Foldable as Fdbl import qualified Data.Map as M import Data.Ord (comparing) diff --git a/Penny/Cabin/Chunk.hs b/Penny/Cabin/Chunk.hs deleted file mode 100644 --- a/Penny/Cabin/Chunk.hs +++ /dev/null @@ -1,2469 +0,0 @@ --- | Handles colors and special effects for text. Internally this --- module uses the Haskell terminfo library, which links against the --- UNIX library of the same name, so it should work with a wide --- variety of UNIX terminals. This module is a layer between terminfo --- and the rest of Penny, allowing the Chunk internals to be swapped --- out and replaced. (I know this because this module previously used --- a home-grown implementation written based on the Xterm --- configuration; that implementation was swapped out and replaced --- with terminfo with minimal disruption.) --- --- However, terminfo is a UNIX thing, so at this time Penny probably --- would not work on a Windows based system. --- --- There is an ansi-terminal library on Hackage, which does support --- Windows. One problem with that though is that ansi-terminal does --- not appear to support more than 8 colors; Chunk supports 256 --- colors, which is very helpful for Penny. -module Penny.Cabin.Chunk ( - -- * Colors - Term(..), - autoTerm, - termFromEnv, - Background8, - Background256, - Foreground8, - Foreground256, - - -- * Chunks - Chunk, - chunk, - Width(Width, unWidth), - chunkWidth, - printChunks, - - -- * Effects - Bold(Bold, unBold), - Underline(Underline, unUnderline), - Flash(Flash, unFlash), - Inverse(Inverse, unInverse), - - -- * Style and TextSpec - - -- | A style is a bundle of attributes that describes text - -- attributes, such as its color and whether it is bold. - StyleCommon (StyleCommon, bold, underline, flash, inverse), - Style8 (Style8, foreground8, background8, common8), - Style256 (Style256, foreground256, background256, common256), - defaultStyleCommon, - defaultStyle8, - defaultStyle256, - - TextSpec (TextSpec, style8, style256), - defaultTextSpec, - - -- * Specific colors - -- * 8 color foreground colors - color8_f_default, - color8_f_black, - color8_f_red, - color8_f_green, - color8_f_yellow, - color8_f_blue, - color8_f_magenta, - color8_f_cyan, - color8_f_white, - - -- ** 8 color background colors - color8_b_default, - color8_b_black, - color8_b_red, - color8_b_green, - color8_b_yellow, - color8_b_blue, - color8_b_magenta, - color8_b_cyan, - color8_b_white, - - -- * 256 color foreground colors - color256_f_default, - color256_f_0, - color256_f_1, - color256_f_2, - color256_f_3, - color256_f_4, - color256_f_5, - color256_f_6, - color256_f_7, - color256_f_8, - color256_f_9, - color256_f_10, - color256_f_11, - color256_f_12, - color256_f_13, - color256_f_14, - color256_f_15, - color256_f_16, - color256_f_17, - color256_f_18, - color256_f_19, - color256_f_20, - color256_f_21, - color256_f_22, - color256_f_23, - color256_f_24, - color256_f_25, - color256_f_26, - color256_f_27, - color256_f_28, - color256_f_29, - color256_f_30, - color256_f_31, - color256_f_32, - color256_f_33, - color256_f_34, - color256_f_35, - color256_f_36, - color256_f_37, - color256_f_38, - color256_f_39, - color256_f_40, - color256_f_41, - color256_f_42, - color256_f_43, - color256_f_44, - color256_f_45, - color256_f_46, - color256_f_47, - color256_f_48, - color256_f_49, - color256_f_50, - color256_f_51, - color256_f_52, - color256_f_53, - color256_f_54, - color256_f_55, - color256_f_56, - color256_f_57, - color256_f_58, - color256_f_59, - color256_f_60, - color256_f_61, - color256_f_62, - color256_f_63, - color256_f_64, - color256_f_65, - color256_f_66, - color256_f_67, - color256_f_68, - color256_f_69, - color256_f_70, - color256_f_71, - color256_f_72, - color256_f_73, - color256_f_74, - color256_f_75, - color256_f_76, - color256_f_77, - color256_f_78, - color256_f_79, - color256_f_80, - color256_f_81, - color256_f_82, - color256_f_83, - color256_f_84, - color256_f_85, - color256_f_86, - color256_f_87, - color256_f_88, - color256_f_89, - color256_f_90, - color256_f_91, - color256_f_92, - color256_f_93, - color256_f_94, - color256_f_95, - color256_f_96, - color256_f_97, - color256_f_98, - color256_f_99, - color256_f_100, - color256_f_101, - color256_f_102, - color256_f_103, - color256_f_104, - color256_f_105, - color256_f_106, - color256_f_107, - color256_f_108, - color256_f_109, - color256_f_110, - color256_f_111, - color256_f_112, - color256_f_113, - color256_f_114, - color256_f_115, - color256_f_116, - color256_f_117, - color256_f_118, - color256_f_119, - color256_f_120, - color256_f_121, - color256_f_122, - color256_f_123, - color256_f_124, - color256_f_125, - color256_f_126, - color256_f_127, - color256_f_128, - color256_f_129, - color256_f_130, - color256_f_131, - color256_f_132, - color256_f_133, - color256_f_134, - color256_f_135, - color256_f_136, - color256_f_137, - color256_f_138, - color256_f_139, - color256_f_140, - color256_f_141, - color256_f_142, - color256_f_143, - color256_f_144, - color256_f_145, - color256_f_146, - color256_f_147, - color256_f_148, - color256_f_149, - color256_f_150, - color256_f_151, - color256_f_152, - color256_f_153, - color256_f_154, - color256_f_155, - color256_f_156, - color256_f_157, - color256_f_158, - color256_f_159, - color256_f_160, - color256_f_161, - color256_f_162, - color256_f_163, - color256_f_164, - color256_f_165, - color256_f_166, - color256_f_167, - color256_f_168, - color256_f_169, - color256_f_170, - color256_f_171, - color256_f_172, - color256_f_173, - color256_f_174, - color256_f_175, - color256_f_176, - color256_f_177, - color256_f_178, - color256_f_179, - color256_f_180, - color256_f_181, - color256_f_182, - color256_f_183, - color256_f_184, - color256_f_185, - color256_f_186, - color256_f_187, - color256_f_188, - color256_f_189, - color256_f_190, - color256_f_191, - color256_f_192, - color256_f_193, - color256_f_194, - color256_f_195, - color256_f_196, - color256_f_197, - color256_f_198, - color256_f_199, - color256_f_200, - color256_f_201, - color256_f_202, - color256_f_203, - color256_f_204, - color256_f_205, - color256_f_206, - color256_f_207, - color256_f_208, - color256_f_209, - color256_f_210, - color256_f_211, - color256_f_212, - color256_f_213, - color256_f_214, - color256_f_215, - color256_f_216, - color256_f_217, - color256_f_218, - color256_f_219, - color256_f_220, - color256_f_221, - color256_f_222, - color256_f_223, - color256_f_224, - color256_f_225, - color256_f_226, - color256_f_227, - color256_f_228, - color256_f_229, - color256_f_230, - color256_f_231, - color256_f_232, - color256_f_233, - color256_f_234, - color256_f_235, - color256_f_236, - color256_f_237, - color256_f_238, - color256_f_239, - color256_f_240, - color256_f_241, - color256_f_242, - color256_f_243, - color256_f_244, - color256_f_245, - color256_f_246, - color256_f_247, - color256_f_248, - color256_f_249, - color256_f_250, - color256_f_251, - color256_f_252, - color256_f_253, - color256_f_254, - color256_f_255, - - -- ** 256 color background colors - color256_b_default, - color256_b_0, - color256_b_1, - color256_b_2, - color256_b_3, - color256_b_4, - color256_b_5, - color256_b_6, - color256_b_7, - color256_b_8, - color256_b_9, - color256_b_10, - color256_b_11, - color256_b_12, - color256_b_13, - color256_b_14, - color256_b_15, - color256_b_16, - color256_b_17, - color256_b_18, - color256_b_19, - color256_b_20, - color256_b_21, - color256_b_22, - color256_b_23, - color256_b_24, - color256_b_25, - color256_b_26, - color256_b_27, - color256_b_28, - color256_b_29, - color256_b_30, - color256_b_31, - color256_b_32, - color256_b_33, - color256_b_34, - color256_b_35, - color256_b_36, - color256_b_37, - color256_b_38, - color256_b_39, - color256_b_40, - color256_b_41, - color256_b_42, - color256_b_43, - color256_b_44, - color256_b_45, - color256_b_46, - color256_b_47, - color256_b_48, - color256_b_49, - color256_b_50, - color256_b_51, - color256_b_52, - color256_b_53, - color256_b_54, - color256_b_55, - color256_b_56, - color256_b_57, - color256_b_58, - color256_b_59, - color256_b_60, - color256_b_61, - color256_b_62, - color256_b_63, - color256_b_64, - color256_b_65, - color256_b_66, - color256_b_67, - color256_b_68, - color256_b_69, - color256_b_70, - color256_b_71, - color256_b_72, - color256_b_73, - color256_b_74, - color256_b_75, - color256_b_76, - color256_b_77, - color256_b_78, - color256_b_79, - color256_b_80, - color256_b_81, - color256_b_82, - color256_b_83, - color256_b_84, - color256_b_85, - color256_b_86, - color256_b_87, - color256_b_88, - color256_b_89, - color256_b_90, - color256_b_91, - color256_b_92, - color256_b_93, - color256_b_94, - color256_b_95, - color256_b_96, - color256_b_97, - color256_b_98, - color256_b_99, - color256_b_100, - color256_b_101, - color256_b_102, - color256_b_103, - color256_b_104, - color256_b_105, - color256_b_106, - color256_b_107, - color256_b_108, - color256_b_109, - color256_b_110, - color256_b_111, - color256_b_112, - color256_b_113, - color256_b_114, - color256_b_115, - color256_b_116, - color256_b_117, - color256_b_118, - color256_b_119, - color256_b_120, - color256_b_121, - color256_b_122, - color256_b_123, - color256_b_124, - color256_b_125, - color256_b_126, - color256_b_127, - color256_b_128, - color256_b_129, - color256_b_130, - color256_b_131, - color256_b_132, - color256_b_133, - color256_b_134, - color256_b_135, - color256_b_136, - color256_b_137, - color256_b_138, - color256_b_139, - color256_b_140, - color256_b_141, - color256_b_142, - color256_b_143, - color256_b_144, - color256_b_145, - color256_b_146, - color256_b_147, - color256_b_148, - color256_b_149, - color256_b_150, - color256_b_151, - color256_b_152, - color256_b_153, - color256_b_154, - color256_b_155, - color256_b_156, - color256_b_157, - color256_b_158, - color256_b_159, - color256_b_160, - color256_b_161, - color256_b_162, - color256_b_163, - color256_b_164, - color256_b_165, - color256_b_166, - color256_b_167, - color256_b_168, - color256_b_169, - color256_b_170, - color256_b_171, - color256_b_172, - color256_b_173, - color256_b_174, - color256_b_175, - color256_b_176, - color256_b_177, - color256_b_178, - color256_b_179, - color256_b_180, - color256_b_181, - color256_b_182, - color256_b_183, - color256_b_184, - color256_b_185, - color256_b_186, - color256_b_187, - color256_b_188, - color256_b_189, - color256_b_190, - color256_b_191, - color256_b_192, - color256_b_193, - color256_b_194, - color256_b_195, - color256_b_196, - color256_b_197, - color256_b_198, - color256_b_199, - color256_b_200, - color256_b_201, - color256_b_202, - color256_b_203, - color256_b_204, - color256_b_205, - color256_b_206, - color256_b_207, - color256_b_208, - color256_b_209, - color256_b_210, - color256_b_211, - color256_b_212, - color256_b_213, - color256_b_214, - color256_b_215, - color256_b_216, - color256_b_217, - color256_b_218, - color256_b_219, - color256_b_220, - color256_b_221, - color256_b_222, - color256_b_223, - color256_b_224, - color256_b_225, - color256_b_226, - color256_b_227, - color256_b_228, - color256_b_229, - color256_b_230, - color256_b_231, - color256_b_232, - color256_b_233, - color256_b_234, - color256_b_235, - color256_b_236, - color256_b_237, - color256_b_238, - color256_b_239, - color256_b_240, - color256_b_241, - color256_b_242, - color256_b_243, - color256_b_244, - color256_b_245, - color256_b_246, - color256_b_247, - color256_b_248, - color256_b_249, - color256_b_250, - color256_b_251, - color256_b_252, - color256_b_253, - color256_b_254, - color256_b_255 - - ) where - - -import Data.Monoid (Monoid, mempty, mappend, mconcat) -import Data.Text (Text) -import Data.Maybe (fromMaybe) -import qualified Data.Text as X -import qualified System.Console.Terminfo as T -import qualified Penny.Shield as S - --- --- Colors --- - --- | Which terminal definition to use. -data Term - = Dumb - -- ^ Using this terminal should always succeed. This suppresses all - -- colors. Uesful if output is not going to a TTY, or if you just do - -- not like colors. - - | TermName String - -- ^ Use the terminal with this given name. You might get this from - -- the TERM environment variable, or set it explicitly. A runtime - -- error will result if the terminfo database does not have a - -- definition for this terminal. If this terminal supports 256 - -- colors, then 256 colors are used. If this terminal supports less - -- than 256 colors, but at least 8 colors, then 8 colors are - -- used. Otherwise, no colors are used. - deriving (Eq, Show) - - --- | Determines which Term to use based on the TERM environment --- variable, regardless of whether standard output is a --- terminal. Uses Dumb if TERM is not set. -termFromEnv :: S.Runtime -> Term -termFromEnv rt = case S.term rt of - Just t -> TermName . S.unTerm $ t - Nothing -> Dumb - --- | Determines which Term to use based on whether standard output is --- a terminal. Uses Dumb if standard output is not a terminal; --- otherwise, uses the TERM environment variable. -autoTerm :: S.Runtime -> Term -autoTerm rt = case S.output rt of - S.IsTTY -> termFromEnv rt - S.NotTTY -> Dumb - --- For Background8, Background256, Foreground8, Foreground256: the --- newtype wraps a Terminfo Color. If Nothing, use the default color. - --- | Background color in an 8 color setting. -newtype Background8 = Background8 { unBackground8 :: Maybe T.Color } - deriving (Eq, Show, Ord) - --- | Background color in a 256 color setting. -newtype Background256 = Background256 { unBackground256 :: Maybe T.Color } - deriving (Eq, Show, Ord) - --- | Foreground color in an 8 color setting. -newtype Foreground8 = Foreground8 { unForeground8 :: Maybe T.Color } - deriving (Eq, Show, Ord) - --- | Foreground color in a 256 color setting. -newtype Foreground256 = Foreground256 { unForeground256 :: Maybe T.Color } - deriving (Eq, Show, Ord) - - --- --- Chunks --- - --- | A chunk is some textual data coupled with a description of what --- color the text is, attributes like whether it is bold or --- underlined, etc. The chunk knows what foreground and background --- colors and what attributes to use for both an 8 color terminal and --- a 256 color terminal. To change these attributes and colors, you --- must make a new chunk. --- --- There is no way to combine chunks. To print large numbers of --- chunks, lazily build a list of them and then print them using --- 'printChunks'. - -data Chunk = Chunk TextSpec Text - deriving (Eq, Show, Ord) - --- | Makes new Chunks. -chunk :: TextSpec -> Text -> Chunk -chunk = Chunk - --- | How wide the text of a chunk is. -newtype Width = Width { unWidth :: Int } - deriving (Show, Eq, Ord) - -instance Monoid Width where - mempty = Width 0 - mappend (Width w1) (Width w2) = Width $ w1 + w2 - -chunkWidth :: Chunk -> Width -chunkWidth (Chunk _ t) = Width . X.length $ t - --- | Sends a list of chunks to standard output for printing. Sets up --- the terminal (this only needs to be done once.) Lazily processes --- the list of Chunk. -printChunks :: Term -> [Chunk] -> IO () -printChunks t cs = do - let setup = case t of - Dumb -> T.setupTerm "dumb" - TermName s -> T.setupTerm s - term <- setup - mapM_ (printChunk term) cs - T.runTermOutput term (defaultColors term) - T.runTermOutput term - $ case T.getCapability term T.allAttributesOff of - Nothing -> error $ "Penny.Cabin.Chunk.printChunks: error: " - ++ "allAttributesOff failed" - Just s -> s - -printChunk :: T.Terminal -> Chunk -> IO () -printChunk t (Chunk ts x) = - T.runTermOutput t - . mconcat - $ [defaultColors t, codes, txt] - where - codes = getTermCodes t ts - txt = T.termText . X.unpack $ x - -defaultColors :: T.Terminal -> T.TermOutput -defaultColors term = - fromMaybe mempty (T.getCapability term T.restoreDefaultColors) - --- --- Effects --- -newtype Bold = Bold { unBold :: Bool } - deriving (Show, Eq, Ord) - -newtype Underline = Underline { unUnderline :: Bool } - deriving (Show, Eq, Ord) - -newtype Flash = Flash { unFlash :: Bool } - deriving (Show, Eq, Ord) - -newtype Inverse = Inverse { unInverse :: Bool } - deriving (Show, Eq, Ord) - --- --- Styles --- - --- | Style elements that apply in both 8 and 256 color --- terminals. However, the elements are described separately for 8 and --- 256 color terminals, so that the text appearance can change --- depending on how many colors a terminal has. -data StyleCommon = StyleCommon - { bold :: Bold - , underline :: Underline - , flash :: Flash - , inverse :: Inverse - } deriving (Show, Eq, Ord) - --- | Describes text appearance (foreground and background colors, as --- well as other attributes such as bold) for an 8 color terminal. -data Style8 = Style8 - { foreground8 :: Foreground8 - , background8 :: Background8 - , common8 :: StyleCommon - } deriving (Show, Eq, Ord) - --- | Describes text appearance (foreground and background colors, as --- well as other attributes such as bold) for a 256 color terminal. -data Style256 = Style256 - { foreground256 :: Foreground256 - , background256 :: Background256 - , common256 :: StyleCommon - } deriving (Show, Eq, Ord) - --- | Has all bold, flash, underline, and inverse turned off. -defaultStyleCommon :: StyleCommon -defaultStyleCommon = StyleCommon - { bold = Bold False - , underline = Underline False - , flash = Flash False - , inverse = Inverse False - } - --- | Uses the default terminal colors (which will vary depending on --- the terminal). -defaultStyle8 :: Style8 -defaultStyle8 = Style8 - { foreground8 = color8_f_default - , background8 = color8_b_default - , common8 = defaultStyleCommon - } - --- | Uses the default terminal colors (which will vary depending on --- the terminal). -defaultStyle256 :: Style256 -defaultStyle256 = Style256 - { foreground256 = color256_f_default - , background256 = color256_b_default - , common256 = defaultStyleCommon - } - --- --- TextSpec --- - --- | The TextSpec bundles together the styles for the 8 and 256 color --- terminals, so that the text can be portrayed on any terminal. -data TextSpec = TextSpec - { style8 :: Style8 - , style256 :: Style256 - } deriving (Show, Eq, Ord) - --- | A TextSpec with the default colors on 8 and 256 color terminals, --- with all attributes turned off. -defaultTextSpec :: TextSpec -defaultTextSpec = TextSpec - { style8 = defaultStyle8 - , style256 = defaultStyle256 - } - --- --- Internal --- - -commonAttrs :: T.Terminal -> StyleCommon -> T.TermOutput -commonAttrs t s = - let a = T.Attributes - { T.standoutAttr = False - , T.underlineAttr = unUnderline . underline $ s - , T.reverseAttr = unInverse . inverse $ s - , T.blinkAttr = unFlash . flash $ s - , T.dimAttr = False - , T.boldAttr = unBold . bold $ s - , T.invisibleAttr = False - , T.protectedAttr = False - } - in case T.getCapability t (T.setAttributes) of - Nothing -> error $ "Penny.Cabin.Chunk: commonAttrs: " - ++ "capability failed; should never happen" - Just f -> f a - - --- | Gets the right set of terminal codes to apply the desired --- highlighting, bold, underlining, etc. Be sure to apply the --- attributes first (bold, underlining, etc) and then the --- colors. Setting the colors first and then the attributes seems to --- reset the colors, giving blank output. -getTermCodes - :: T.Terminal - -> TextSpec - -> T.TermOutput -getTermCodes t ts = fromMaybe mempty $ do - cols <- T.getCapability t T.termColors - let TextSpec s8 s256 = ts - Style8 f8 b8 c8 = s8 - Style256 f256 b256 c256 = s256 - setFg <- T.getCapability t T.setForegroundColor - setBg <- T.getCapability t T.setBackgroundColor - (fg, bg, cm) <- case () of - _ | cols >= 256 -> Just $ ( unForeground256 f256 - , unBackground256 b256 - , c256 ) - | cols >= 8 -> Just ( unForeground8 f8 - , unBackground8 b8 - , c8) - | otherwise -> Nothing - let oFg = maybe mempty setFg fg - oBg = maybe mempty setBg bg - oCm = commonAttrs t cm - return $ mconcat [oCm, oFg, oBg] - - --- --- Color basement --- -color8_f_default :: Foreground8 -color8_f_default = Foreground8 Nothing - -color8_f_black :: Foreground8 -color8_f_black = Foreground8 $ Just T.Black - -color8_f_red :: Foreground8 -color8_f_red = Foreground8 $ Just T.Red - -color8_f_green :: Foreground8 -color8_f_green = Foreground8 $ Just T.Green - -color8_f_yellow :: Foreground8 -color8_f_yellow = Foreground8 $ Just T.Yellow - -color8_f_blue :: Foreground8 -color8_f_blue = Foreground8 $ Just T.Blue - -color8_f_magenta :: Foreground8 -color8_f_magenta = Foreground8 $ Just T.Magenta - -color8_f_cyan :: Foreground8 -color8_f_cyan = Foreground8 $ Just T.Cyan - -color8_f_white :: Foreground8 -color8_f_white = Foreground8 $ Just T.White - -color8_b_default :: Background8 -color8_b_default = Background8 Nothing - -color8_b_black :: Background8 -color8_b_black = Background8 $ Just T.Black - -color8_b_red :: Background8 -color8_b_red = Background8 $ Just T.Red - -color8_b_green :: Background8 -color8_b_green = Background8 $ Just T.Green - -color8_b_yellow :: Background8 -color8_b_yellow = Background8 $ Just T.Yellow - -color8_b_blue :: Background8 -color8_b_blue = Background8 $ Just T.Blue - -color8_b_magenta :: Background8 -color8_b_magenta = Background8 $ Just T.Magenta - -color8_b_cyan :: Background8 -color8_b_cyan = Background8 $ Just T.Cyan - -color8_b_white :: Background8 -color8_b_white = Background8 $ Just T.White - -color256_f_default :: Foreground256 -color256_f_default = Foreground256 Nothing - -color256_f_0 :: Foreground256 -color256_f_0 = Foreground256 (Just (T.ColorNumber 0)) - -color256_f_1 :: Foreground256 -color256_f_1 = Foreground256 (Just (T.ColorNumber 1)) - -color256_f_2 :: Foreground256 -color256_f_2 = Foreground256 (Just (T.ColorNumber 2)) - -color256_f_3 :: Foreground256 -color256_f_3 = Foreground256 (Just (T.ColorNumber 3)) - -color256_f_4 :: Foreground256 -color256_f_4 = Foreground256 (Just (T.ColorNumber 4)) - -color256_f_5 :: Foreground256 -color256_f_5 = Foreground256 (Just (T.ColorNumber 5)) - -color256_f_6 :: Foreground256 -color256_f_6 = Foreground256 (Just (T.ColorNumber 6)) - -color256_f_7 :: Foreground256 -color256_f_7 = Foreground256 (Just (T.ColorNumber 7)) - -color256_f_8 :: Foreground256 -color256_f_8 = Foreground256 (Just (T.ColorNumber 8)) - -color256_f_9 :: Foreground256 -color256_f_9 = Foreground256 (Just (T.ColorNumber 9)) - -color256_f_10 :: Foreground256 -color256_f_10 = Foreground256 (Just (T.ColorNumber 10)) - -color256_f_11 :: Foreground256 -color256_f_11 = Foreground256 (Just (T.ColorNumber 11)) - -color256_f_12 :: Foreground256 -color256_f_12 = Foreground256 (Just (T.ColorNumber 12)) - -color256_f_13 :: Foreground256 -color256_f_13 = Foreground256 (Just (T.ColorNumber 13)) - -color256_f_14 :: Foreground256 -color256_f_14 = Foreground256 (Just (T.ColorNumber 14)) - -color256_f_15 :: Foreground256 -color256_f_15 = Foreground256 (Just (T.ColorNumber 15)) - -color256_f_16 :: Foreground256 -color256_f_16 = Foreground256 (Just (T.ColorNumber 16)) - -color256_f_17 :: Foreground256 -color256_f_17 = Foreground256 (Just (T.ColorNumber 17)) - -color256_f_18 :: Foreground256 -color256_f_18 = Foreground256 (Just (T.ColorNumber 18)) - -color256_f_19 :: Foreground256 -color256_f_19 = Foreground256 (Just (T.ColorNumber 19)) - -color256_f_20 :: Foreground256 -color256_f_20 = Foreground256 (Just (T.ColorNumber 20)) - -color256_f_21 :: Foreground256 -color256_f_21 = Foreground256 (Just (T.ColorNumber 21)) - -color256_f_22 :: Foreground256 -color256_f_22 = Foreground256 (Just (T.ColorNumber 22)) - -color256_f_23 :: Foreground256 -color256_f_23 = Foreground256 (Just (T.ColorNumber 23)) - -color256_f_24 :: Foreground256 -color256_f_24 = Foreground256 (Just (T.ColorNumber 24)) - -color256_f_25 :: Foreground256 -color256_f_25 = Foreground256 (Just (T.ColorNumber 25)) - -color256_f_26 :: Foreground256 -color256_f_26 = Foreground256 (Just (T.ColorNumber 26)) - -color256_f_27 :: Foreground256 -color256_f_27 = Foreground256 (Just (T.ColorNumber 27)) - -color256_f_28 :: Foreground256 -color256_f_28 = Foreground256 (Just (T.ColorNumber 28)) - -color256_f_29 :: Foreground256 -color256_f_29 = Foreground256 (Just (T.ColorNumber 29)) - -color256_f_30 :: Foreground256 -color256_f_30 = Foreground256 (Just (T.ColorNumber 30)) - -color256_f_31 :: Foreground256 -color256_f_31 = Foreground256 (Just (T.ColorNumber 31)) - -color256_f_32 :: Foreground256 -color256_f_32 = Foreground256 (Just (T.ColorNumber 32)) - -color256_f_33 :: Foreground256 -color256_f_33 = Foreground256 (Just (T.ColorNumber 33)) - -color256_f_34 :: Foreground256 -color256_f_34 = Foreground256 (Just (T.ColorNumber 34)) - -color256_f_35 :: Foreground256 -color256_f_35 = Foreground256 (Just (T.ColorNumber 35)) - -color256_f_36 :: Foreground256 -color256_f_36 = Foreground256 (Just (T.ColorNumber 36)) - -color256_f_37 :: Foreground256 -color256_f_37 = Foreground256 (Just (T.ColorNumber 37)) - -color256_f_38 :: Foreground256 -color256_f_38 = Foreground256 (Just (T.ColorNumber 38)) - -color256_f_39 :: Foreground256 -color256_f_39 = Foreground256 (Just (T.ColorNumber 39)) - -color256_f_40 :: Foreground256 -color256_f_40 = Foreground256 (Just (T.ColorNumber 40)) - -color256_f_41 :: Foreground256 -color256_f_41 = Foreground256 (Just (T.ColorNumber 41)) - -color256_f_42 :: Foreground256 -color256_f_42 = Foreground256 (Just (T.ColorNumber 42)) - -color256_f_43 :: Foreground256 -color256_f_43 = Foreground256 (Just (T.ColorNumber 43)) - -color256_f_44 :: Foreground256 -color256_f_44 = Foreground256 (Just (T.ColorNumber 44)) - -color256_f_45 :: Foreground256 -color256_f_45 = Foreground256 (Just (T.ColorNumber 45)) - -color256_f_46 :: Foreground256 -color256_f_46 = Foreground256 (Just (T.ColorNumber 46)) - -color256_f_47 :: Foreground256 -color256_f_47 = Foreground256 (Just (T.ColorNumber 47)) - -color256_f_48 :: Foreground256 -color256_f_48 = Foreground256 (Just (T.ColorNumber 48)) - -color256_f_49 :: Foreground256 -color256_f_49 = Foreground256 (Just (T.ColorNumber 49)) - -color256_f_50 :: Foreground256 -color256_f_50 = Foreground256 (Just (T.ColorNumber 50)) - -color256_f_51 :: Foreground256 -color256_f_51 = Foreground256 (Just (T.ColorNumber 51)) - -color256_f_52 :: Foreground256 -color256_f_52 = Foreground256 (Just (T.ColorNumber 52)) - -color256_f_53 :: Foreground256 -color256_f_53 = Foreground256 (Just (T.ColorNumber 53)) - -color256_f_54 :: Foreground256 -color256_f_54 = Foreground256 (Just (T.ColorNumber 54)) - -color256_f_55 :: Foreground256 -color256_f_55 = Foreground256 (Just (T.ColorNumber 55)) - -color256_f_56 :: Foreground256 -color256_f_56 = Foreground256 (Just (T.ColorNumber 56)) - -color256_f_57 :: Foreground256 -color256_f_57 = Foreground256 (Just (T.ColorNumber 57)) - -color256_f_58 :: Foreground256 -color256_f_58 = Foreground256 (Just (T.ColorNumber 58)) - -color256_f_59 :: Foreground256 -color256_f_59 = Foreground256 (Just (T.ColorNumber 59)) - -color256_f_60 :: Foreground256 -color256_f_60 = Foreground256 (Just (T.ColorNumber 60)) - -color256_f_61 :: Foreground256 -color256_f_61 = Foreground256 (Just (T.ColorNumber 61)) - -color256_f_62 :: Foreground256 -color256_f_62 = Foreground256 (Just (T.ColorNumber 62)) - -color256_f_63 :: Foreground256 -color256_f_63 = Foreground256 (Just (T.ColorNumber 63)) - -color256_f_64 :: Foreground256 -color256_f_64 = Foreground256 (Just (T.ColorNumber 64)) - -color256_f_65 :: Foreground256 -color256_f_65 = Foreground256 (Just (T.ColorNumber 65)) - -color256_f_66 :: Foreground256 -color256_f_66 = Foreground256 (Just (T.ColorNumber 66)) - -color256_f_67 :: Foreground256 -color256_f_67 = Foreground256 (Just (T.ColorNumber 67)) - -color256_f_68 :: Foreground256 -color256_f_68 = Foreground256 (Just (T.ColorNumber 68)) - -color256_f_69 :: Foreground256 -color256_f_69 = Foreground256 (Just (T.ColorNumber 69)) - -color256_f_70 :: Foreground256 -color256_f_70 = Foreground256 (Just (T.ColorNumber 70)) - -color256_f_71 :: Foreground256 -color256_f_71 = Foreground256 (Just (T.ColorNumber 71)) - -color256_f_72 :: Foreground256 -color256_f_72 = Foreground256 (Just (T.ColorNumber 72)) - -color256_f_73 :: Foreground256 -color256_f_73 = Foreground256 (Just (T.ColorNumber 73)) - -color256_f_74 :: Foreground256 -color256_f_74 = Foreground256 (Just (T.ColorNumber 74)) - -color256_f_75 :: Foreground256 -color256_f_75 = Foreground256 (Just (T.ColorNumber 75)) - -color256_f_76 :: Foreground256 -color256_f_76 = Foreground256 (Just (T.ColorNumber 76)) - -color256_f_77 :: Foreground256 -color256_f_77 = Foreground256 (Just (T.ColorNumber 77)) - -color256_f_78 :: Foreground256 -color256_f_78 = Foreground256 (Just (T.ColorNumber 78)) - -color256_f_79 :: Foreground256 -color256_f_79 = Foreground256 (Just (T.ColorNumber 79)) - -color256_f_80 :: Foreground256 -color256_f_80 = Foreground256 (Just (T.ColorNumber 80)) - -color256_f_81 :: Foreground256 -color256_f_81 = Foreground256 (Just (T.ColorNumber 81)) - -color256_f_82 :: Foreground256 -color256_f_82 = Foreground256 (Just (T.ColorNumber 82)) - -color256_f_83 :: Foreground256 -color256_f_83 = Foreground256 (Just (T.ColorNumber 83)) - -color256_f_84 :: Foreground256 -color256_f_84 = Foreground256 (Just (T.ColorNumber 84)) - -color256_f_85 :: Foreground256 -color256_f_85 = Foreground256 (Just (T.ColorNumber 85)) - -color256_f_86 :: Foreground256 -color256_f_86 = Foreground256 (Just (T.ColorNumber 86)) - -color256_f_87 :: Foreground256 -color256_f_87 = Foreground256 (Just (T.ColorNumber 87)) - -color256_f_88 :: Foreground256 -color256_f_88 = Foreground256 (Just (T.ColorNumber 88)) - -color256_f_89 :: Foreground256 -color256_f_89 = Foreground256 (Just (T.ColorNumber 89)) - -color256_f_90 :: Foreground256 -color256_f_90 = Foreground256 (Just (T.ColorNumber 90)) - -color256_f_91 :: Foreground256 -color256_f_91 = Foreground256 (Just (T.ColorNumber 91)) - -color256_f_92 :: Foreground256 -color256_f_92 = Foreground256 (Just (T.ColorNumber 92)) - -color256_f_93 :: Foreground256 -color256_f_93 = Foreground256 (Just (T.ColorNumber 93)) - -color256_f_94 :: Foreground256 -color256_f_94 = Foreground256 (Just (T.ColorNumber 94)) - -color256_f_95 :: Foreground256 -color256_f_95 = Foreground256 (Just (T.ColorNumber 95)) - -color256_f_96 :: Foreground256 -color256_f_96 = Foreground256 (Just (T.ColorNumber 96)) - -color256_f_97 :: Foreground256 -color256_f_97 = Foreground256 (Just (T.ColorNumber 97)) - -color256_f_98 :: Foreground256 -color256_f_98 = Foreground256 (Just (T.ColorNumber 98)) - -color256_f_99 :: Foreground256 -color256_f_99 = Foreground256 (Just (T.ColorNumber 99)) - -color256_f_100 :: Foreground256 -color256_f_100 = Foreground256 (Just (T.ColorNumber 100)) - -color256_f_101 :: Foreground256 -color256_f_101 = Foreground256 (Just (T.ColorNumber 101)) - -color256_f_102 :: Foreground256 -color256_f_102 = Foreground256 (Just (T.ColorNumber 102)) - -color256_f_103 :: Foreground256 -color256_f_103 = Foreground256 (Just (T.ColorNumber 103)) - -color256_f_104 :: Foreground256 -color256_f_104 = Foreground256 (Just (T.ColorNumber 104)) - -color256_f_105 :: Foreground256 -color256_f_105 = Foreground256 (Just (T.ColorNumber 105)) - -color256_f_106 :: Foreground256 -color256_f_106 = Foreground256 (Just (T.ColorNumber 106)) - -color256_f_107 :: Foreground256 -color256_f_107 = Foreground256 (Just (T.ColorNumber 107)) - -color256_f_108 :: Foreground256 -color256_f_108 = Foreground256 (Just (T.ColorNumber 108)) - -color256_f_109 :: Foreground256 -color256_f_109 = Foreground256 (Just (T.ColorNumber 109)) - -color256_f_110 :: Foreground256 -color256_f_110 = Foreground256 (Just (T.ColorNumber 110)) - -color256_f_111 :: Foreground256 -color256_f_111 = Foreground256 (Just (T.ColorNumber 111)) - -color256_f_112 :: Foreground256 -color256_f_112 = Foreground256 (Just (T.ColorNumber 112)) - -color256_f_113 :: Foreground256 -color256_f_113 = Foreground256 (Just (T.ColorNumber 113)) - -color256_f_114 :: Foreground256 -color256_f_114 = Foreground256 (Just (T.ColorNumber 114)) - -color256_f_115 :: Foreground256 -color256_f_115 = Foreground256 (Just (T.ColorNumber 115)) - -color256_f_116 :: Foreground256 -color256_f_116 = Foreground256 (Just (T.ColorNumber 116)) - -color256_f_117 :: Foreground256 -color256_f_117 = Foreground256 (Just (T.ColorNumber 117)) - -color256_f_118 :: Foreground256 -color256_f_118 = Foreground256 (Just (T.ColorNumber 118)) - -color256_f_119 :: Foreground256 -color256_f_119 = Foreground256 (Just (T.ColorNumber 119)) - -color256_f_120 :: Foreground256 -color256_f_120 = Foreground256 (Just (T.ColorNumber 120)) - -color256_f_121 :: Foreground256 -color256_f_121 = Foreground256 (Just (T.ColorNumber 121)) - -color256_f_122 :: Foreground256 -color256_f_122 = Foreground256 (Just (T.ColorNumber 122)) - -color256_f_123 :: Foreground256 -color256_f_123 = Foreground256 (Just (T.ColorNumber 123)) - -color256_f_124 :: Foreground256 -color256_f_124 = Foreground256 (Just (T.ColorNumber 124)) - -color256_f_125 :: Foreground256 -color256_f_125 = Foreground256 (Just (T.ColorNumber 125)) - -color256_f_126 :: Foreground256 -color256_f_126 = Foreground256 (Just (T.ColorNumber 126)) - -color256_f_127 :: Foreground256 -color256_f_127 = Foreground256 (Just (T.ColorNumber 127)) - -color256_f_128 :: Foreground256 -color256_f_128 = Foreground256 (Just (T.ColorNumber 128)) - -color256_f_129 :: Foreground256 -color256_f_129 = Foreground256 (Just (T.ColorNumber 129)) - -color256_f_130 :: Foreground256 -color256_f_130 = Foreground256 (Just (T.ColorNumber 130)) - -color256_f_131 :: Foreground256 -color256_f_131 = Foreground256 (Just (T.ColorNumber 131)) - -color256_f_132 :: Foreground256 -color256_f_132 = Foreground256 (Just (T.ColorNumber 132)) - -color256_f_133 :: Foreground256 -color256_f_133 = Foreground256 (Just (T.ColorNumber 133)) - -color256_f_134 :: Foreground256 -color256_f_134 = Foreground256 (Just (T.ColorNumber 134)) - -color256_f_135 :: Foreground256 -color256_f_135 = Foreground256 (Just (T.ColorNumber 135)) - -color256_f_136 :: Foreground256 -color256_f_136 = Foreground256 (Just (T.ColorNumber 136)) - -color256_f_137 :: Foreground256 -color256_f_137 = Foreground256 (Just (T.ColorNumber 137)) - -color256_f_138 :: Foreground256 -color256_f_138 = Foreground256 (Just (T.ColorNumber 138)) - -color256_f_139 :: Foreground256 -color256_f_139 = Foreground256 (Just (T.ColorNumber 139)) - -color256_f_140 :: Foreground256 -color256_f_140 = Foreground256 (Just (T.ColorNumber 140)) - -color256_f_141 :: Foreground256 -color256_f_141 = Foreground256 (Just (T.ColorNumber 141)) - -color256_f_142 :: Foreground256 -color256_f_142 = Foreground256 (Just (T.ColorNumber 142)) - -color256_f_143 :: Foreground256 -color256_f_143 = Foreground256 (Just (T.ColorNumber 143)) - -color256_f_144 :: Foreground256 -color256_f_144 = Foreground256 (Just (T.ColorNumber 144)) - -color256_f_145 :: Foreground256 -color256_f_145 = Foreground256 (Just (T.ColorNumber 145)) - -color256_f_146 :: Foreground256 -color256_f_146 = Foreground256 (Just (T.ColorNumber 146)) - -color256_f_147 :: Foreground256 -color256_f_147 = Foreground256 (Just (T.ColorNumber 147)) - -color256_f_148 :: Foreground256 -color256_f_148 = Foreground256 (Just (T.ColorNumber 148)) - -color256_f_149 :: Foreground256 -color256_f_149 = Foreground256 (Just (T.ColorNumber 149)) - -color256_f_150 :: Foreground256 -color256_f_150 = Foreground256 (Just (T.ColorNumber 150)) - -color256_f_151 :: Foreground256 -color256_f_151 = Foreground256 (Just (T.ColorNumber 151)) - -color256_f_152 :: Foreground256 -color256_f_152 = Foreground256 (Just (T.ColorNumber 152)) - -color256_f_153 :: Foreground256 -color256_f_153 = Foreground256 (Just (T.ColorNumber 153)) - -color256_f_154 :: Foreground256 -color256_f_154 = Foreground256 (Just (T.ColorNumber 154)) - -color256_f_155 :: Foreground256 -color256_f_155 = Foreground256 (Just (T.ColorNumber 155)) - -color256_f_156 :: Foreground256 -color256_f_156 = Foreground256 (Just (T.ColorNumber 156)) - -color256_f_157 :: Foreground256 -color256_f_157 = Foreground256 (Just (T.ColorNumber 157)) - -color256_f_158 :: Foreground256 -color256_f_158 = Foreground256 (Just (T.ColorNumber 158)) - -color256_f_159 :: Foreground256 -color256_f_159 = Foreground256 (Just (T.ColorNumber 159)) - -color256_f_160 :: Foreground256 -color256_f_160 = Foreground256 (Just (T.ColorNumber 160)) - -color256_f_161 :: Foreground256 -color256_f_161 = Foreground256 (Just (T.ColorNumber 161)) - -color256_f_162 :: Foreground256 -color256_f_162 = Foreground256 (Just (T.ColorNumber 162)) - -color256_f_163 :: Foreground256 -color256_f_163 = Foreground256 (Just (T.ColorNumber 163)) - -color256_f_164 :: Foreground256 -color256_f_164 = Foreground256 (Just (T.ColorNumber 164)) - -color256_f_165 :: Foreground256 -color256_f_165 = Foreground256 (Just (T.ColorNumber 165)) - -color256_f_166 :: Foreground256 -color256_f_166 = Foreground256 (Just (T.ColorNumber 166)) - -color256_f_167 :: Foreground256 -color256_f_167 = Foreground256 (Just (T.ColorNumber 167)) - -color256_f_168 :: Foreground256 -color256_f_168 = Foreground256 (Just (T.ColorNumber 168)) - -color256_f_169 :: Foreground256 -color256_f_169 = Foreground256 (Just (T.ColorNumber 169)) - -color256_f_170 :: Foreground256 -color256_f_170 = Foreground256 (Just (T.ColorNumber 170)) - -color256_f_171 :: Foreground256 -color256_f_171 = Foreground256 (Just (T.ColorNumber 171)) - -color256_f_172 :: Foreground256 -color256_f_172 = Foreground256 (Just (T.ColorNumber 172)) - -color256_f_173 :: Foreground256 -color256_f_173 = Foreground256 (Just (T.ColorNumber 173)) - -color256_f_174 :: Foreground256 -color256_f_174 = Foreground256 (Just (T.ColorNumber 174)) - -color256_f_175 :: Foreground256 -color256_f_175 = Foreground256 (Just (T.ColorNumber 175)) - -color256_f_176 :: Foreground256 -color256_f_176 = Foreground256 (Just (T.ColorNumber 176)) - -color256_f_177 :: Foreground256 -color256_f_177 = Foreground256 (Just (T.ColorNumber 177)) - -color256_f_178 :: Foreground256 -color256_f_178 = Foreground256 (Just (T.ColorNumber 178)) - -color256_f_179 :: Foreground256 -color256_f_179 = Foreground256 (Just (T.ColorNumber 179)) - -color256_f_180 :: Foreground256 -color256_f_180 = Foreground256 (Just (T.ColorNumber 180)) - -color256_f_181 :: Foreground256 -color256_f_181 = Foreground256 (Just (T.ColorNumber 181)) - -color256_f_182 :: Foreground256 -color256_f_182 = Foreground256 (Just (T.ColorNumber 182)) - -color256_f_183 :: Foreground256 -color256_f_183 = Foreground256 (Just (T.ColorNumber 183)) - -color256_f_184 :: Foreground256 -color256_f_184 = Foreground256 (Just (T.ColorNumber 184)) - -color256_f_185 :: Foreground256 -color256_f_185 = Foreground256 (Just (T.ColorNumber 185)) - -color256_f_186 :: Foreground256 -color256_f_186 = Foreground256 (Just (T.ColorNumber 186)) - -color256_f_187 :: Foreground256 -color256_f_187 = Foreground256 (Just (T.ColorNumber 187)) - -color256_f_188 :: Foreground256 -color256_f_188 = Foreground256 (Just (T.ColorNumber 188)) - -color256_f_189 :: Foreground256 -color256_f_189 = Foreground256 (Just (T.ColorNumber 189)) - -color256_f_190 :: Foreground256 -color256_f_190 = Foreground256 (Just (T.ColorNumber 190)) - -color256_f_191 :: Foreground256 -color256_f_191 = Foreground256 (Just (T.ColorNumber 191)) - -color256_f_192 :: Foreground256 -color256_f_192 = Foreground256 (Just (T.ColorNumber 192)) - -color256_f_193 :: Foreground256 -color256_f_193 = Foreground256 (Just (T.ColorNumber 193)) - -color256_f_194 :: Foreground256 -color256_f_194 = Foreground256 (Just (T.ColorNumber 194)) - -color256_f_195 :: Foreground256 -color256_f_195 = Foreground256 (Just (T.ColorNumber 195)) - -color256_f_196 :: Foreground256 -color256_f_196 = Foreground256 (Just (T.ColorNumber 196)) - -color256_f_197 :: Foreground256 -color256_f_197 = Foreground256 (Just (T.ColorNumber 197)) - -color256_f_198 :: Foreground256 -color256_f_198 = Foreground256 (Just (T.ColorNumber 198)) - -color256_f_199 :: Foreground256 -color256_f_199 = Foreground256 (Just (T.ColorNumber 199)) - -color256_f_200 :: Foreground256 -color256_f_200 = Foreground256 (Just (T.ColorNumber 200)) - -color256_f_201 :: Foreground256 -color256_f_201 = Foreground256 (Just (T.ColorNumber 201)) - -color256_f_202 :: Foreground256 -color256_f_202 = Foreground256 (Just (T.ColorNumber 202)) - -color256_f_203 :: Foreground256 -color256_f_203 = Foreground256 (Just (T.ColorNumber 203)) - -color256_f_204 :: Foreground256 -color256_f_204 = Foreground256 (Just (T.ColorNumber 204)) - -color256_f_205 :: Foreground256 -color256_f_205 = Foreground256 (Just (T.ColorNumber 205)) - -color256_f_206 :: Foreground256 -color256_f_206 = Foreground256 (Just (T.ColorNumber 206)) - -color256_f_207 :: Foreground256 -color256_f_207 = Foreground256 (Just (T.ColorNumber 207)) - -color256_f_208 :: Foreground256 -color256_f_208 = Foreground256 (Just (T.ColorNumber 208)) - -color256_f_209 :: Foreground256 -color256_f_209 = Foreground256 (Just (T.ColorNumber 209)) - -color256_f_210 :: Foreground256 -color256_f_210 = Foreground256 (Just (T.ColorNumber 210)) - -color256_f_211 :: Foreground256 -color256_f_211 = Foreground256 (Just (T.ColorNumber 211)) - -color256_f_212 :: Foreground256 -color256_f_212 = Foreground256 (Just (T.ColorNumber 212)) - -color256_f_213 :: Foreground256 -color256_f_213 = Foreground256 (Just (T.ColorNumber 213)) - -color256_f_214 :: Foreground256 -color256_f_214 = Foreground256 (Just (T.ColorNumber 214)) - -color256_f_215 :: Foreground256 -color256_f_215 = Foreground256 (Just (T.ColorNumber 215)) - -color256_f_216 :: Foreground256 -color256_f_216 = Foreground256 (Just (T.ColorNumber 216)) - -color256_f_217 :: Foreground256 -color256_f_217 = Foreground256 (Just (T.ColorNumber 217)) - -color256_f_218 :: Foreground256 -color256_f_218 = Foreground256 (Just (T.ColorNumber 218)) - -color256_f_219 :: Foreground256 -color256_f_219 = Foreground256 (Just (T.ColorNumber 219)) - -color256_f_220 :: Foreground256 -color256_f_220 = Foreground256 (Just (T.ColorNumber 220)) - -color256_f_221 :: Foreground256 -color256_f_221 = Foreground256 (Just (T.ColorNumber 221)) - -color256_f_222 :: Foreground256 -color256_f_222 = Foreground256 (Just (T.ColorNumber 222)) - -color256_f_223 :: Foreground256 -color256_f_223 = Foreground256 (Just (T.ColorNumber 223)) - -color256_f_224 :: Foreground256 -color256_f_224 = Foreground256 (Just (T.ColorNumber 224)) - -color256_f_225 :: Foreground256 -color256_f_225 = Foreground256 (Just (T.ColorNumber 225)) - -color256_f_226 :: Foreground256 -color256_f_226 = Foreground256 (Just (T.ColorNumber 226)) - -color256_f_227 :: Foreground256 -color256_f_227 = Foreground256 (Just (T.ColorNumber 227)) - -color256_f_228 :: Foreground256 -color256_f_228 = Foreground256 (Just (T.ColorNumber 228)) - -color256_f_229 :: Foreground256 -color256_f_229 = Foreground256 (Just (T.ColorNumber 229)) - -color256_f_230 :: Foreground256 -color256_f_230 = Foreground256 (Just (T.ColorNumber 230)) - -color256_f_231 :: Foreground256 -color256_f_231 = Foreground256 (Just (T.ColorNumber 231)) - -color256_f_232 :: Foreground256 -color256_f_232 = Foreground256 (Just (T.ColorNumber 232)) - -color256_f_233 :: Foreground256 -color256_f_233 = Foreground256 (Just (T.ColorNumber 233)) - -color256_f_234 :: Foreground256 -color256_f_234 = Foreground256 (Just (T.ColorNumber 234)) - -color256_f_235 :: Foreground256 -color256_f_235 = Foreground256 (Just (T.ColorNumber 235)) - -color256_f_236 :: Foreground256 -color256_f_236 = Foreground256 (Just (T.ColorNumber 236)) - -color256_f_237 :: Foreground256 -color256_f_237 = Foreground256 (Just (T.ColorNumber 237)) - -color256_f_238 :: Foreground256 -color256_f_238 = Foreground256 (Just (T.ColorNumber 238)) - -color256_f_239 :: Foreground256 -color256_f_239 = Foreground256 (Just (T.ColorNumber 239)) - -color256_f_240 :: Foreground256 -color256_f_240 = Foreground256 (Just (T.ColorNumber 240)) - -color256_f_241 :: Foreground256 -color256_f_241 = Foreground256 (Just (T.ColorNumber 241)) - -color256_f_242 :: Foreground256 -color256_f_242 = Foreground256 (Just (T.ColorNumber 242)) - -color256_f_243 :: Foreground256 -color256_f_243 = Foreground256 (Just (T.ColorNumber 243)) - -color256_f_244 :: Foreground256 -color256_f_244 = Foreground256 (Just (T.ColorNumber 244)) - -color256_f_245 :: Foreground256 -color256_f_245 = Foreground256 (Just (T.ColorNumber 245)) - -color256_f_246 :: Foreground256 -color256_f_246 = Foreground256 (Just (T.ColorNumber 246)) - -color256_f_247 :: Foreground256 -color256_f_247 = Foreground256 (Just (T.ColorNumber 247)) - -color256_f_248 :: Foreground256 -color256_f_248 = Foreground256 (Just (T.ColorNumber 248)) - -color256_f_249 :: Foreground256 -color256_f_249 = Foreground256 (Just (T.ColorNumber 249)) - -color256_f_250 :: Foreground256 -color256_f_250 = Foreground256 (Just (T.ColorNumber 250)) - -color256_f_251 :: Foreground256 -color256_f_251 = Foreground256 (Just (T.ColorNumber 251)) - -color256_f_252 :: Foreground256 -color256_f_252 = Foreground256 (Just (T.ColorNumber 252)) - -color256_f_253 :: Foreground256 -color256_f_253 = Foreground256 (Just (T.ColorNumber 253)) - -color256_f_254 :: Foreground256 -color256_f_254 = Foreground256 (Just (T.ColorNumber 254)) - -color256_f_255 :: Foreground256 -color256_f_255 = Foreground256 (Just (T.ColorNumber 255)) - -color256_b_default :: Background256 -color256_b_default = Background256 Nothing - -color256_b_0 :: Background256 -color256_b_0 = Background256 (Just (T.ColorNumber 0)) - -color256_b_1 :: Background256 -color256_b_1 = Background256 (Just (T.ColorNumber 1)) - -color256_b_2 :: Background256 -color256_b_2 = Background256 (Just (T.ColorNumber 2)) - -color256_b_3 :: Background256 -color256_b_3 = Background256 (Just (T.ColorNumber 3)) - -color256_b_4 :: Background256 -color256_b_4 = Background256 (Just (T.ColorNumber 4)) - -color256_b_5 :: Background256 -color256_b_5 = Background256 (Just (T.ColorNumber 5)) - -color256_b_6 :: Background256 -color256_b_6 = Background256 (Just (T.ColorNumber 6)) - -color256_b_7 :: Background256 -color256_b_7 = Background256 (Just (T.ColorNumber 7)) - -color256_b_8 :: Background256 -color256_b_8 = Background256 (Just (T.ColorNumber 8)) - -color256_b_9 :: Background256 -color256_b_9 = Background256 (Just (T.ColorNumber 9)) - -color256_b_10 :: Background256 -color256_b_10 = Background256 (Just (T.ColorNumber 10)) - -color256_b_11 :: Background256 -color256_b_11 = Background256 (Just (T.ColorNumber 11)) - -color256_b_12 :: Background256 -color256_b_12 = Background256 (Just (T.ColorNumber 12)) - -color256_b_13 :: Background256 -color256_b_13 = Background256 (Just (T.ColorNumber 13)) - -color256_b_14 :: Background256 -color256_b_14 = Background256 (Just (T.ColorNumber 14)) - -color256_b_15 :: Background256 -color256_b_15 = Background256 (Just (T.ColorNumber 15)) - -color256_b_16 :: Background256 -color256_b_16 = Background256 (Just (T.ColorNumber 16)) - -color256_b_17 :: Background256 -color256_b_17 = Background256 (Just (T.ColorNumber 17)) - -color256_b_18 :: Background256 -color256_b_18 = Background256 (Just (T.ColorNumber 18)) - -color256_b_19 :: Background256 -color256_b_19 = Background256 (Just (T.ColorNumber 19)) - -color256_b_20 :: Background256 -color256_b_20 = Background256 (Just (T.ColorNumber 20)) - -color256_b_21 :: Background256 -color256_b_21 = Background256 (Just (T.ColorNumber 21)) - -color256_b_22 :: Background256 -color256_b_22 = Background256 (Just (T.ColorNumber 22)) - -color256_b_23 :: Background256 -color256_b_23 = Background256 (Just (T.ColorNumber 23)) - -color256_b_24 :: Background256 -color256_b_24 = Background256 (Just (T.ColorNumber 24)) - -color256_b_25 :: Background256 -color256_b_25 = Background256 (Just (T.ColorNumber 25)) - -color256_b_26 :: Background256 -color256_b_26 = Background256 (Just (T.ColorNumber 26)) - -color256_b_27 :: Background256 -color256_b_27 = Background256 (Just (T.ColorNumber 27)) - -color256_b_28 :: Background256 -color256_b_28 = Background256 (Just (T.ColorNumber 28)) - -color256_b_29 :: Background256 -color256_b_29 = Background256 (Just (T.ColorNumber 29)) - -color256_b_30 :: Background256 -color256_b_30 = Background256 (Just (T.ColorNumber 30)) - -color256_b_31 :: Background256 -color256_b_31 = Background256 (Just (T.ColorNumber 31)) - -color256_b_32 :: Background256 -color256_b_32 = Background256 (Just (T.ColorNumber 32)) - -color256_b_33 :: Background256 -color256_b_33 = Background256 (Just (T.ColorNumber 33)) - -color256_b_34 :: Background256 -color256_b_34 = Background256 (Just (T.ColorNumber 34)) - -color256_b_35 :: Background256 -color256_b_35 = Background256 (Just (T.ColorNumber 35)) - -color256_b_36 :: Background256 -color256_b_36 = Background256 (Just (T.ColorNumber 36)) - -color256_b_37 :: Background256 -color256_b_37 = Background256 (Just (T.ColorNumber 37)) - -color256_b_38 :: Background256 -color256_b_38 = Background256 (Just (T.ColorNumber 38)) - -color256_b_39 :: Background256 -color256_b_39 = Background256 (Just (T.ColorNumber 39)) - -color256_b_40 :: Background256 -color256_b_40 = Background256 (Just (T.ColorNumber 40)) - -color256_b_41 :: Background256 -color256_b_41 = Background256 (Just (T.ColorNumber 41)) - -color256_b_42 :: Background256 -color256_b_42 = Background256 (Just (T.ColorNumber 42)) - -color256_b_43 :: Background256 -color256_b_43 = Background256 (Just (T.ColorNumber 43)) - -color256_b_44 :: Background256 -color256_b_44 = Background256 (Just (T.ColorNumber 44)) - -color256_b_45 :: Background256 -color256_b_45 = Background256 (Just (T.ColorNumber 45)) - -color256_b_46 :: Background256 -color256_b_46 = Background256 (Just (T.ColorNumber 46)) - -color256_b_47 :: Background256 -color256_b_47 = Background256 (Just (T.ColorNumber 47)) - -color256_b_48 :: Background256 -color256_b_48 = Background256 (Just (T.ColorNumber 48)) - -color256_b_49 :: Background256 -color256_b_49 = Background256 (Just (T.ColorNumber 49)) - -color256_b_50 :: Background256 -color256_b_50 = Background256 (Just (T.ColorNumber 50)) - -color256_b_51 :: Background256 -color256_b_51 = Background256 (Just (T.ColorNumber 51)) - -color256_b_52 :: Background256 -color256_b_52 = Background256 (Just (T.ColorNumber 52)) - -color256_b_53 :: Background256 -color256_b_53 = Background256 (Just (T.ColorNumber 53)) - -color256_b_54 :: Background256 -color256_b_54 = Background256 (Just (T.ColorNumber 54)) - -color256_b_55 :: Background256 -color256_b_55 = Background256 (Just (T.ColorNumber 55)) - -color256_b_56 :: Background256 -color256_b_56 = Background256 (Just (T.ColorNumber 56)) - -color256_b_57 :: Background256 -color256_b_57 = Background256 (Just (T.ColorNumber 57)) - -color256_b_58 :: Background256 -color256_b_58 = Background256 (Just (T.ColorNumber 58)) - -color256_b_59 :: Background256 -color256_b_59 = Background256 (Just (T.ColorNumber 59)) - -color256_b_60 :: Background256 -color256_b_60 = Background256 (Just (T.ColorNumber 60)) - -color256_b_61 :: Background256 -color256_b_61 = Background256 (Just (T.ColorNumber 61)) - -color256_b_62 :: Background256 -color256_b_62 = Background256 (Just (T.ColorNumber 62)) - -color256_b_63 :: Background256 -color256_b_63 = Background256 (Just (T.ColorNumber 63)) - -color256_b_64 :: Background256 -color256_b_64 = Background256 (Just (T.ColorNumber 64)) - -color256_b_65 :: Background256 -color256_b_65 = Background256 (Just (T.ColorNumber 65)) - -color256_b_66 :: Background256 -color256_b_66 = Background256 (Just (T.ColorNumber 66)) - -color256_b_67 :: Background256 -color256_b_67 = Background256 (Just (T.ColorNumber 67)) - -color256_b_68 :: Background256 -color256_b_68 = Background256 (Just (T.ColorNumber 68)) - -color256_b_69 :: Background256 -color256_b_69 = Background256 (Just (T.ColorNumber 69)) - -color256_b_70 :: Background256 -color256_b_70 = Background256 (Just (T.ColorNumber 70)) - -color256_b_71 :: Background256 -color256_b_71 = Background256 (Just (T.ColorNumber 71)) - -color256_b_72 :: Background256 -color256_b_72 = Background256 (Just (T.ColorNumber 72)) - -color256_b_73 :: Background256 -color256_b_73 = Background256 (Just (T.ColorNumber 73)) - -color256_b_74 :: Background256 -color256_b_74 = Background256 (Just (T.ColorNumber 74)) - -color256_b_75 :: Background256 -color256_b_75 = Background256 (Just (T.ColorNumber 75)) - -color256_b_76 :: Background256 -color256_b_76 = Background256 (Just (T.ColorNumber 76)) - -color256_b_77 :: Background256 -color256_b_77 = Background256 (Just (T.ColorNumber 77)) - -color256_b_78 :: Background256 -color256_b_78 = Background256 (Just (T.ColorNumber 78)) - -color256_b_79 :: Background256 -color256_b_79 = Background256 (Just (T.ColorNumber 79)) - -color256_b_80 :: Background256 -color256_b_80 = Background256 (Just (T.ColorNumber 80)) - -color256_b_81 :: Background256 -color256_b_81 = Background256 (Just (T.ColorNumber 81)) - -color256_b_82 :: Background256 -color256_b_82 = Background256 (Just (T.ColorNumber 82)) - -color256_b_83 :: Background256 -color256_b_83 = Background256 (Just (T.ColorNumber 83)) - -color256_b_84 :: Background256 -color256_b_84 = Background256 (Just (T.ColorNumber 84)) - -color256_b_85 :: Background256 -color256_b_85 = Background256 (Just (T.ColorNumber 85)) - -color256_b_86 :: Background256 -color256_b_86 = Background256 (Just (T.ColorNumber 86)) - -color256_b_87 :: Background256 -color256_b_87 = Background256 (Just (T.ColorNumber 87)) - -color256_b_88 :: Background256 -color256_b_88 = Background256 (Just (T.ColorNumber 88)) - -color256_b_89 :: Background256 -color256_b_89 = Background256 (Just (T.ColorNumber 89)) - -color256_b_90 :: Background256 -color256_b_90 = Background256 (Just (T.ColorNumber 90)) - -color256_b_91 :: Background256 -color256_b_91 = Background256 (Just (T.ColorNumber 91)) - -color256_b_92 :: Background256 -color256_b_92 = Background256 (Just (T.ColorNumber 92)) - -color256_b_93 :: Background256 -color256_b_93 = Background256 (Just (T.ColorNumber 93)) - -color256_b_94 :: Background256 -color256_b_94 = Background256 (Just (T.ColorNumber 94)) - -color256_b_95 :: Background256 -color256_b_95 = Background256 (Just (T.ColorNumber 95)) - -color256_b_96 :: Background256 -color256_b_96 = Background256 (Just (T.ColorNumber 96)) - -color256_b_97 :: Background256 -color256_b_97 = Background256 (Just (T.ColorNumber 97)) - -color256_b_98 :: Background256 -color256_b_98 = Background256 (Just (T.ColorNumber 98)) - -color256_b_99 :: Background256 -color256_b_99 = Background256 (Just (T.ColorNumber 99)) - -color256_b_100 :: Background256 -color256_b_100 = Background256 (Just (T.ColorNumber 100)) - -color256_b_101 :: Background256 -color256_b_101 = Background256 (Just (T.ColorNumber 101)) - -color256_b_102 :: Background256 -color256_b_102 = Background256 (Just (T.ColorNumber 102)) - -color256_b_103 :: Background256 -color256_b_103 = Background256 (Just (T.ColorNumber 103)) - -color256_b_104 :: Background256 -color256_b_104 = Background256 (Just (T.ColorNumber 104)) - -color256_b_105 :: Background256 -color256_b_105 = Background256 (Just (T.ColorNumber 105)) - -color256_b_106 :: Background256 -color256_b_106 = Background256 (Just (T.ColorNumber 106)) - -color256_b_107 :: Background256 -color256_b_107 = Background256 (Just (T.ColorNumber 107)) - -color256_b_108 :: Background256 -color256_b_108 = Background256 (Just (T.ColorNumber 108)) - -color256_b_109 :: Background256 -color256_b_109 = Background256 (Just (T.ColorNumber 109)) - -color256_b_110 :: Background256 -color256_b_110 = Background256 (Just (T.ColorNumber 110)) - -color256_b_111 :: Background256 -color256_b_111 = Background256 (Just (T.ColorNumber 111)) - -color256_b_112 :: Background256 -color256_b_112 = Background256 (Just (T.ColorNumber 112)) - -color256_b_113 :: Background256 -color256_b_113 = Background256 (Just (T.ColorNumber 113)) - -color256_b_114 :: Background256 -color256_b_114 = Background256 (Just (T.ColorNumber 114)) - -color256_b_115 :: Background256 -color256_b_115 = Background256 (Just (T.ColorNumber 115)) - -color256_b_116 :: Background256 -color256_b_116 = Background256 (Just (T.ColorNumber 116)) - -color256_b_117 :: Background256 -color256_b_117 = Background256 (Just (T.ColorNumber 117)) - -color256_b_118 :: Background256 -color256_b_118 = Background256 (Just (T.ColorNumber 118)) - -color256_b_119 :: Background256 -color256_b_119 = Background256 (Just (T.ColorNumber 119)) - -color256_b_120 :: Background256 -color256_b_120 = Background256 (Just (T.ColorNumber 120)) - -color256_b_121 :: Background256 -color256_b_121 = Background256 (Just (T.ColorNumber 121)) - -color256_b_122 :: Background256 -color256_b_122 = Background256 (Just (T.ColorNumber 122)) - -color256_b_123 :: Background256 -color256_b_123 = Background256 (Just (T.ColorNumber 123)) - -color256_b_124 :: Background256 -color256_b_124 = Background256 (Just (T.ColorNumber 124)) - -color256_b_125 :: Background256 -color256_b_125 = Background256 (Just (T.ColorNumber 125)) - -color256_b_126 :: Background256 -color256_b_126 = Background256 (Just (T.ColorNumber 126)) - -color256_b_127 :: Background256 -color256_b_127 = Background256 (Just (T.ColorNumber 127)) - -color256_b_128 :: Background256 -color256_b_128 = Background256 (Just (T.ColorNumber 128)) - -color256_b_129 :: Background256 -color256_b_129 = Background256 (Just (T.ColorNumber 129)) - -color256_b_130 :: Background256 -color256_b_130 = Background256 (Just (T.ColorNumber 130)) - -color256_b_131 :: Background256 -color256_b_131 = Background256 (Just (T.ColorNumber 131)) - -color256_b_132 :: Background256 -color256_b_132 = Background256 (Just (T.ColorNumber 132)) - -color256_b_133 :: Background256 -color256_b_133 = Background256 (Just (T.ColorNumber 133)) - -color256_b_134 :: Background256 -color256_b_134 = Background256 (Just (T.ColorNumber 134)) - -color256_b_135 :: Background256 -color256_b_135 = Background256 (Just (T.ColorNumber 135)) - -color256_b_136 :: Background256 -color256_b_136 = Background256 (Just (T.ColorNumber 136)) - -color256_b_137 :: Background256 -color256_b_137 = Background256 (Just (T.ColorNumber 137)) - -color256_b_138 :: Background256 -color256_b_138 = Background256 (Just (T.ColorNumber 138)) - -color256_b_139 :: Background256 -color256_b_139 = Background256 (Just (T.ColorNumber 139)) - -color256_b_140 :: Background256 -color256_b_140 = Background256 (Just (T.ColorNumber 140)) - -color256_b_141 :: Background256 -color256_b_141 = Background256 (Just (T.ColorNumber 141)) - -color256_b_142 :: Background256 -color256_b_142 = Background256 (Just (T.ColorNumber 142)) - -color256_b_143 :: Background256 -color256_b_143 = Background256 (Just (T.ColorNumber 143)) - -color256_b_144 :: Background256 -color256_b_144 = Background256 (Just (T.ColorNumber 144)) - -color256_b_145 :: Background256 -color256_b_145 = Background256 (Just (T.ColorNumber 145)) - -color256_b_146 :: Background256 -color256_b_146 = Background256 (Just (T.ColorNumber 146)) - -color256_b_147 :: Background256 -color256_b_147 = Background256 (Just (T.ColorNumber 147)) - -color256_b_148 :: Background256 -color256_b_148 = Background256 (Just (T.ColorNumber 148)) - -color256_b_149 :: Background256 -color256_b_149 = Background256 (Just (T.ColorNumber 149)) - -color256_b_150 :: Background256 -color256_b_150 = Background256 (Just (T.ColorNumber 150)) - -color256_b_151 :: Background256 -color256_b_151 = Background256 (Just (T.ColorNumber 151)) - -color256_b_152 :: Background256 -color256_b_152 = Background256 (Just (T.ColorNumber 152)) - -color256_b_153 :: Background256 -color256_b_153 = Background256 (Just (T.ColorNumber 153)) - -color256_b_154 :: Background256 -color256_b_154 = Background256 (Just (T.ColorNumber 154)) - -color256_b_155 :: Background256 -color256_b_155 = Background256 (Just (T.ColorNumber 155)) - -color256_b_156 :: Background256 -color256_b_156 = Background256 (Just (T.ColorNumber 156)) - -color256_b_157 :: Background256 -color256_b_157 = Background256 (Just (T.ColorNumber 157)) - -color256_b_158 :: Background256 -color256_b_158 = Background256 (Just (T.ColorNumber 158)) - -color256_b_159 :: Background256 -color256_b_159 = Background256 (Just (T.ColorNumber 159)) - -color256_b_160 :: Background256 -color256_b_160 = Background256 (Just (T.ColorNumber 160)) - -color256_b_161 :: Background256 -color256_b_161 = Background256 (Just (T.ColorNumber 161)) - -color256_b_162 :: Background256 -color256_b_162 = Background256 (Just (T.ColorNumber 162)) - -color256_b_163 :: Background256 -color256_b_163 = Background256 (Just (T.ColorNumber 163)) - -color256_b_164 :: Background256 -color256_b_164 = Background256 (Just (T.ColorNumber 164)) - -color256_b_165 :: Background256 -color256_b_165 = Background256 (Just (T.ColorNumber 165)) - -color256_b_166 :: Background256 -color256_b_166 = Background256 (Just (T.ColorNumber 166)) - -color256_b_167 :: Background256 -color256_b_167 = Background256 (Just (T.ColorNumber 167)) - -color256_b_168 :: Background256 -color256_b_168 = Background256 (Just (T.ColorNumber 168)) - -color256_b_169 :: Background256 -color256_b_169 = Background256 (Just (T.ColorNumber 169)) - -color256_b_170 :: Background256 -color256_b_170 = Background256 (Just (T.ColorNumber 170)) - -color256_b_171 :: Background256 -color256_b_171 = Background256 (Just (T.ColorNumber 171)) - -color256_b_172 :: Background256 -color256_b_172 = Background256 (Just (T.ColorNumber 172)) - -color256_b_173 :: Background256 -color256_b_173 = Background256 (Just (T.ColorNumber 173)) - -color256_b_174 :: Background256 -color256_b_174 = Background256 (Just (T.ColorNumber 174)) - -color256_b_175 :: Background256 -color256_b_175 = Background256 (Just (T.ColorNumber 175)) - -color256_b_176 :: Background256 -color256_b_176 = Background256 (Just (T.ColorNumber 176)) - -color256_b_177 :: Background256 -color256_b_177 = Background256 (Just (T.ColorNumber 177)) - -color256_b_178 :: Background256 -color256_b_178 = Background256 (Just (T.ColorNumber 178)) - -color256_b_179 :: Background256 -color256_b_179 = Background256 (Just (T.ColorNumber 179)) - -color256_b_180 :: Background256 -color256_b_180 = Background256 (Just (T.ColorNumber 180)) - -color256_b_181 :: Background256 -color256_b_181 = Background256 (Just (T.ColorNumber 181)) - -color256_b_182 :: Background256 -color256_b_182 = Background256 (Just (T.ColorNumber 182)) - -color256_b_183 :: Background256 -color256_b_183 = Background256 (Just (T.ColorNumber 183)) - -color256_b_184 :: Background256 -color256_b_184 = Background256 (Just (T.ColorNumber 184)) - -color256_b_185 :: Background256 -color256_b_185 = Background256 (Just (T.ColorNumber 185)) - -color256_b_186 :: Background256 -color256_b_186 = Background256 (Just (T.ColorNumber 186)) - -color256_b_187 :: Background256 -color256_b_187 = Background256 (Just (T.ColorNumber 187)) - -color256_b_188 :: Background256 -color256_b_188 = Background256 (Just (T.ColorNumber 188)) - -color256_b_189 :: Background256 -color256_b_189 = Background256 (Just (T.ColorNumber 189)) - -color256_b_190 :: Background256 -color256_b_190 = Background256 (Just (T.ColorNumber 190)) - -color256_b_191 :: Background256 -color256_b_191 = Background256 (Just (T.ColorNumber 191)) - -color256_b_192 :: Background256 -color256_b_192 = Background256 (Just (T.ColorNumber 192)) - -color256_b_193 :: Background256 -color256_b_193 = Background256 (Just (T.ColorNumber 193)) - -color256_b_194 :: Background256 -color256_b_194 = Background256 (Just (T.ColorNumber 194)) - -color256_b_195 :: Background256 -color256_b_195 = Background256 (Just (T.ColorNumber 195)) - -color256_b_196 :: Background256 -color256_b_196 = Background256 (Just (T.ColorNumber 196)) - -color256_b_197 :: Background256 -color256_b_197 = Background256 (Just (T.ColorNumber 197)) - -color256_b_198 :: Background256 -color256_b_198 = Background256 (Just (T.ColorNumber 198)) - -color256_b_199 :: Background256 -color256_b_199 = Background256 (Just (T.ColorNumber 199)) - -color256_b_200 :: Background256 -color256_b_200 = Background256 (Just (T.ColorNumber 200)) - -color256_b_201 :: Background256 -color256_b_201 = Background256 (Just (T.ColorNumber 201)) - -color256_b_202 :: Background256 -color256_b_202 = Background256 (Just (T.ColorNumber 202)) - -color256_b_203 :: Background256 -color256_b_203 = Background256 (Just (T.ColorNumber 203)) - -color256_b_204 :: Background256 -color256_b_204 = Background256 (Just (T.ColorNumber 204)) - -color256_b_205 :: Background256 -color256_b_205 = Background256 (Just (T.ColorNumber 205)) - -color256_b_206 :: Background256 -color256_b_206 = Background256 (Just (T.ColorNumber 206)) - -color256_b_207 :: Background256 -color256_b_207 = Background256 (Just (T.ColorNumber 207)) - -color256_b_208 :: Background256 -color256_b_208 = Background256 (Just (T.ColorNumber 208)) - -color256_b_209 :: Background256 -color256_b_209 = Background256 (Just (T.ColorNumber 209)) - -color256_b_210 :: Background256 -color256_b_210 = Background256 (Just (T.ColorNumber 210)) - -color256_b_211 :: Background256 -color256_b_211 = Background256 (Just (T.ColorNumber 211)) - -color256_b_212 :: Background256 -color256_b_212 = Background256 (Just (T.ColorNumber 212)) - -color256_b_213 :: Background256 -color256_b_213 = Background256 (Just (T.ColorNumber 213)) - -color256_b_214 :: Background256 -color256_b_214 = Background256 (Just (T.ColorNumber 214)) - -color256_b_215 :: Background256 -color256_b_215 = Background256 (Just (T.ColorNumber 215)) - -color256_b_216 :: Background256 -color256_b_216 = Background256 (Just (T.ColorNumber 216)) - -color256_b_217 :: Background256 -color256_b_217 = Background256 (Just (T.ColorNumber 217)) - -color256_b_218 :: Background256 -color256_b_218 = Background256 (Just (T.ColorNumber 218)) - -color256_b_219 :: Background256 -color256_b_219 = Background256 (Just (T.ColorNumber 219)) - -color256_b_220 :: Background256 -color256_b_220 = Background256 (Just (T.ColorNumber 220)) - -color256_b_221 :: Background256 -color256_b_221 = Background256 (Just (T.ColorNumber 221)) - -color256_b_222 :: Background256 -color256_b_222 = Background256 (Just (T.ColorNumber 222)) - -color256_b_223 :: Background256 -color256_b_223 = Background256 (Just (T.ColorNumber 223)) - -color256_b_224 :: Background256 -color256_b_224 = Background256 (Just (T.ColorNumber 224)) - -color256_b_225 :: Background256 -color256_b_225 = Background256 (Just (T.ColorNumber 225)) - -color256_b_226 :: Background256 -color256_b_226 = Background256 (Just (T.ColorNumber 226)) - -color256_b_227 :: Background256 -color256_b_227 = Background256 (Just (T.ColorNumber 227)) - -color256_b_228 :: Background256 -color256_b_228 = Background256 (Just (T.ColorNumber 228)) - -color256_b_229 :: Background256 -color256_b_229 = Background256 (Just (T.ColorNumber 229)) - -color256_b_230 :: Background256 -color256_b_230 = Background256 (Just (T.ColorNumber 230)) - -color256_b_231 :: Background256 -color256_b_231 = Background256 (Just (T.ColorNumber 231)) - -color256_b_232 :: Background256 -color256_b_232 = Background256 (Just (T.ColorNumber 232)) - -color256_b_233 :: Background256 -color256_b_233 = Background256 (Just (T.ColorNumber 233)) - -color256_b_234 :: Background256 -color256_b_234 = Background256 (Just (T.ColorNumber 234)) - -color256_b_235 :: Background256 -color256_b_235 = Background256 (Just (T.ColorNumber 235)) - -color256_b_236 :: Background256 -color256_b_236 = Background256 (Just (T.ColorNumber 236)) - -color256_b_237 :: Background256 -color256_b_237 = Background256 (Just (T.ColorNumber 237)) - -color256_b_238 :: Background256 -color256_b_238 = Background256 (Just (T.ColorNumber 238)) - -color256_b_239 :: Background256 -color256_b_239 = Background256 (Just (T.ColorNumber 239)) - -color256_b_240 :: Background256 -color256_b_240 = Background256 (Just (T.ColorNumber 240)) - -color256_b_241 :: Background256 -color256_b_241 = Background256 (Just (T.ColorNumber 241)) - -color256_b_242 :: Background256 -color256_b_242 = Background256 (Just (T.ColorNumber 242)) - -color256_b_243 :: Background256 -color256_b_243 = Background256 (Just (T.ColorNumber 243)) - -color256_b_244 :: Background256 -color256_b_244 = Background256 (Just (T.ColorNumber 244)) - -color256_b_245 :: Background256 -color256_b_245 = Background256 (Just (T.ColorNumber 245)) - -color256_b_246 :: Background256 -color256_b_246 = Background256 (Just (T.ColorNumber 246)) - -color256_b_247 :: Background256 -color256_b_247 = Background256 (Just (T.ColorNumber 247)) - -color256_b_248 :: Background256 -color256_b_248 = Background256 (Just (T.ColorNumber 248)) - -color256_b_249 :: Background256 -color256_b_249 = Background256 (Just (T.ColorNumber 249)) - -color256_b_250 :: Background256 -color256_b_250 = Background256 (Just (T.ColorNumber 250)) - -color256_b_251 :: Background256 -color256_b_251 = Background256 (Just (T.ColorNumber 251)) - -color256_b_252 :: Background256 -color256_b_252 = Background256 (Just (T.ColorNumber 252)) - -color256_b_253 :: Background256 -color256_b_253 = Background256 (Just (T.ColorNumber 253)) - -color256_b_254 :: Background256 -color256_b_254 = Background256 (Just (T.ColorNumber 254)) - -color256_b_255 :: Background256 -color256_b_255 = Background256 (Just (T.ColorNumber 255)) - diff --git a/Penny/Cabin/Chunk/Switch.hs b/Penny/Cabin/Chunk/Switch.hs deleted file mode 100644 --- a/Penny/Cabin/Chunk/Switch.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Penny.Cabin.Chunk.Switch where - -import qualified Penny.Cabin.Chunk as C - --- | Switch the foreground colors for new ones. -switchForeground :: - C.Foreground8 - -> C.Foreground256 - -> C.TextSpec - -> C.TextSpec -switchForeground c8 c256 ts = ts' where - ts' = C.TextSpec s8' s256' - s8' = (C.style8 ts) { C.foreground8 = c8 } - s256' = (C.style256 ts) { C.foreground256 = c256 } - --- | Switch the background colors for new ones. -switchBackground :: - C.Background8 - -> C.Background256 - -> C.TextSpec - -> C.TextSpec -switchBackground c8 c256 ts = ts' where - ts' = C.TextSpec s8' s256' - s8' = (C.style8 ts) { C.background8 = c8 } - s256' = (C.style256 ts) { C.background256 = c256 } - diff --git a/Penny/Cabin/Interface.hs b/Penny/Cabin/Interface.hs --- a/Penny/Cabin/Interface.hs +++ b/Penny/Cabin/Interface.hs @@ -2,10 +2,13 @@ -- anything that is a 'Report'. module Penny.Cabin.Interface where +import qualified Penny.Steel.Chunk as C +import qualified Penny.Steel.Expressions as Exp import qualified Penny.Cabin.Scheme as S import Control.Monad.Exception.Synchronous (Exceptional) import qualified Data.Text as X -import Text.Matchers.Text (CaseSensitive) +import Text.Matchers (CaseSensitive) +import qualified Text.Matchers as TM import qualified System.Console.MultiArg as MA import qualified Penny.Lincoln as L @@ -23,8 +26,13 @@ type PosArg = String type HelpStr = String type ArgsAndReport = ([PosArg], PrintReport) -type ParseResult = Exceptional String (Either HelpStr ArgsAndReport) +-- | The result of parsing the arguments to a report. Failures are +-- indicated with a Text. The name of the executable and the word +-- @error@ will be prepended to this Text; otherwise, it is printed +-- as-is, so be sure to include any trailing newline if needed. +type ParseResult = Exceptional X.Text ArgsAndReport + type PrintReport = [L.Transaction] -- ^ All transactions; the report must sort and filter them @@ -33,11 +41,14 @@ -- ^ PricePoints to be included in the report - -> Exceptional X.Text [S.PreChunk] + -> Exceptional X.Text [Either C.Chunk S.PreChunk] -- ^ The exception type is a strict Text, containing the error - -- message. The success type is a list of PreChunks containing the - -- resulting report. This allows for errors after the list of - -- transactions has been seen. +-- message. The success type is a list of either a Chunk or a PreChunk +-- containing the resulting report. This allows for errors after the +-- list of transactions has been seen. The name of the executable and +-- the word @error@ will be prepended to this Text; otherwise, it is +-- printed as-is, so be sure to include any trailing newline if +-- needed. type Report = Runtime -> (HelpStr, MkReport) @@ -47,9 +58,13 @@ -- case sensitivity (this may have been changed in the filtering -- options) - -> (CaseSensitive -> X.Text -> Exceptional X.Text (X.Text -> Bool)) + -> (CaseSensitive -> X.Text -> Exceptional X.Text TM.Matcher) -- ^ Result from previous parsers indicating the matcher factory the -- user wishes to use + + -> Exp.ExprDesc + -- ^ Result from previous parsers indicating whether the user wants + -- RPN or infix -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) -- ^ Result from previous parsers that will sort and filter incoming diff --git a/Penny/Cabin/Posts.hs b/Penny/Cabin/Posts.hs --- a/Penny/Cabin/Posts.hs +++ b/Penny/Cabin/Posts.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | The Penny Postings report -- -- The Postings report displays postings in a tabular format designed @@ -54,7 +56,9 @@ import Control.Applicative ((<$>), (<*>)) import qualified Control.Monad.Exception.Synchronous as Ex +import Data.List.Split (chunksOf) import qualified Data.Either as Ei +import Data.Monoid ((<>)) import qualified Data.Text as X import qualified Penny.Cabin.Interface as I import qualified Penny.Cabin.Options as CO @@ -72,6 +76,9 @@ import qualified Penny.Lincoln.Queries as Q import qualified Penny.Liberty as Ly import qualified Penny.Shield as Sh +import qualified Penny.Steel.Expressions as Exp +import qualified Penny.Steel.Pdct as Pe +import qualified Penny.Steel.Chunk as Chk import Data.List (intersperse) import Data.Maybe (catMaybes) @@ -79,13 +86,13 @@ import Data.Time as Time import qualified System.Console.MultiArg as MA import System.Locale (defaultTimeLocale) -import Text.Matchers.Text (CaseSensitive) +import Text.Matchers (CaseSensitive) -- | All information needed to make a Posts report. This function -- never fails. postsReport :: CO.ShowZeroBalances - -> (L.Box Ly.LibertyMeta -> Bool) + -> (Pe.Pdct (L.Box Ly.LibertyMeta)) -- ^ Removes posts from the report if applying this function to the -- post returns False. Posts removed still affect the running -- balance. @@ -107,24 +114,32 @@ zincReport :: ZincOpts -> I.Report zincReport opts rt = (helpStr opts, md) where - md cs fty fsf = MA.Mode + md cs fty expr fsf = MA.Mode { MA.mName = "postings" , MA.mIntersperse = MA.Intersperse - , MA.mOpts = map (fmap Right) (P.allSpecs rt) + , MA.mOpts = specs rt , MA.mPosArgs = Left - , MA.mProcess = process opts cs fty fsf + , MA.mProcess = process opts cs fty expr fsf + , MA.mHelp = const (helpStr opts) } +specs + :: Sh.Runtime + -> [MA.OptSpec (Either String (P.State -> Ex.Exceptional X.Text P.State))] +specs = map (fmap Right) . P.allSpecs + + process :: ZincOpts -> CaseSensitive -> L.Factory + -> Exp.ExprDesc -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) - -> [Either String (P.State -> Ex.Exceptional String P.State)] - -> Ex.Exceptional String (Either I.HelpStr I.ArgsAndReport) -process os cs fty fsf ls = + -> [Either String (P.State -> Ex.Exceptional X.Text P.State)] + -> Ex.Exceptional X.Text I.ArgsAndReport +process os cs fty expr fsf ls = let (posArgs, clOpts) = Ei.partitionEithers ls - pState = newParseState cs fty os + pState = newParseState cs fty expr os exState' = foldl (>>=) (return pState) clOpts in fmap (mkPrintReport posArgs os fsf) exState' @@ -133,21 +148,61 @@ -> ZincOpts -> ([L.Transaction] -> [L.Box Ly.LibertyMeta]) -> P.State - -> Either I.HelpStr I.ArgsAndReport -mkPrintReport posArgs zo fsf st = r + -> I.ArgsAndReport +mkPrintReport posArgs zo fsf st = (posArgs, f) where - r = if P.showHelp st then Left $ helpStr zo else Right pr - pr = (posArgs, f) - f txns _ = fmap mkChunks exPdct - where - exPdct = getPredicate (P.tokens st) - mkChunks pdct = chks - where - chks = postsReport (P.showZeroBalances st) pdct - (P.postFilter st) (chunkOpts st zo) boxes - boxes = fsf txns + f txns _ = do + pdct <- getPredicate (P.exprDesc st) (P.tokens st) + let boxes = fsf txns + rptChks = postsReport (P.showZeroBalances st) pdct + (P.postFilter st) (chunkOpts st zo) boxes + expChks = showExpression (P.showExpression st) pdct + verbChks = showVerboseFilter (P.verboseFilter st) pdct boxes + chks = map Left expChks + ++ map Left verbChks + ++ map Right rptChks + return chks +indentAmt :: Pe.IndentAmt +indentAmt = 4 +blankLine :: Chk.Chunk +blankLine = Chk.chunk Chk.defaultTextSpec "\n" + +showExpression + :: P.ShowExpression + -> Pe.Pdct (L.Box Ly.LibertyMeta) + -> [Chk.Chunk] +showExpression (P.ShowExpression b) pdct = + if not b then [] else info : blankLine : (chks ++ [blankLine]) + where + info = Chk.chunk Chk.defaultTextSpec "Postings filter expression:\n" + chks = Pe.showPdct indentAmt 0 pdct + +showVerboseFilter + :: P.VerboseFilter + -> Pe.Pdct (L.Box Ly.LibertyMeta) + -> [L.Box Ly.LibertyMeta] + -> [Chk.Chunk] +showVerboseFilter (P.VerboseFilter b) pdct bs = + if not b then [] else info : blankLine : (chks ++ [blankLine]) + where + pdcts = map (makeLabeledPdct pdct) bs + chks = concat . map snd $ zipWith doEval bs pdcts + doEval subj pd = Pe.evaluate indentAmt False subj 0 pd + info = Chk.chunk Chk.defaultTextSpec "Postings report filter:\n" + +-- | Creates a Pdct and prepends a one-line description of the PostFam +-- to the Pdct's label so it can be easily identified in the output. +makeLabeledPdct + :: Pe.Pdct (L.Box Ly.LibertyMeta) + -> L.Box Ly.LibertyMeta + -> Pe.Pdct (L.Box Ly.LibertyMeta) +makeLabeledPdct pd box = Pe.rename f pd + where + f old = old <> " - " <> L.display pf + pf = L.boxPostFam box + defaultOptions :: Sh.Runtime -> ZincOpts @@ -161,19 +216,20 @@ , subAccountLength = A.SubAccountLength 2 , payeeAllocation = A.alloc 60 , accountAllocation = A.alloc 40 - , spacers = defaultSpacerWidth } + , spacers = defaultSpacerWidth + } -getPredicate :: - [Ly.Token (L.Box Ly.LibertyMeta -> Bool)] - -> Ex.Exceptional X.Text (L.Box Ly.LibertyMeta -> Bool) -getPredicate ts = +type Error = X.Text + +getPredicate + :: Exp.ExprDesc + -> [Exp.Token (L.Box Ly.LibertyMeta)] + -> Ex.Exceptional Error (Pe.Pdct (L.Box Ly.LibertyMeta)) +getPredicate d ts = case ts of - [] -> return $ const True - ls -> - Ex.fromMaybe - (X.pack "posts report: bad posting filter expression") - (Ly.parseTokenList ls) + [] -> return $ Pe.always + _ -> Exp.parseExpression d ts -- | All the information to configure the postings report if the @@ -250,9 +306,10 @@ newParseState :: CaseSensitive -> L.Factory + -> Exp.ExprDesc -> ZincOpts -> P.State -newParseState cs fty o = P.State +newParseState cs fty expr o = P.State { P.sensitive = cs , P.factory = fty , P.tokens = [] @@ -260,7 +317,9 @@ , P.fields = fields o , P.width = width o , P.showZeroBalances = showZeroBalances o - , P.showHelp = False + , P.exprDesc = expr + , P.verboseFilter = P.VerboseFilter False + , P.showExpression = P.ShowExpression False } -- | Shows the date of a posting in YYYY-MM-DD format. @@ -375,13 +434,6 @@ ifDefault :: Bool -> String ifDefault b = if b then " (default)" else "" -bundles :: Int -> [a] -> [[a]] -bundles c ls - | c < 1 = error "bundles: argument must be positive" - | otherwise = case splitAt c ls of - (r, []) -> [r] - (r, rs) -> r : bundles c rs - helpStr :: ZincOpts -> String helpStr o = unlines $ [ "postings" @@ -460,9 +512,15 @@ , "--qty cmp number" , " Entry quantity must fall within given range" , "" - , "Operators - from highest to lowest precedence" + , "Infix or RPN selection" + , "----------------------" + , "--infix - use infix notation" + , "--rpn - use reverse polish notation" + , " (default: use what was used in the filtering options)" + , "" + , "Infix Operators - from highest to lowest precedence" , "(all are left associative)" - , "==========================" + , "--------------------------" , "--open expr --close" , " Force precedence (as in \"open\" and \"close\" parentheses)" , "--not expr" @@ -472,6 +530,15 @@ , "expr1 --or expr2" , " True if either expr1 or expr2 is true" , "" + , "RPN Operators" + , "-------------" + , "expr --not" + , " True if expr is false" + , "expr1 expr2 --and" + , " True if expr and expr2 are both true" + , "expr1 expr2 --or" + , " True if either expr1 or expr2 is true" + , "" , "Options affecting patterns" , "==========================" , "" @@ -543,7 +610,7 @@ map (" " ++) . map concat . map (intersperse ", ") - . bundles 3 + . chunksOf 3 . catMaybes . Fdbl.toList . toMaybes diff --git a/Penny/Cabin/Posts/Allocated.hs b/Penny/Cabin/Posts/Allocated.hs --- a/Penny/Cabin/Posts/Allocated.hs +++ b/Penny/Cabin/Posts/Allocated.hs @@ -63,7 +63,7 @@ import qualified Data.Sequence as Seq import qualified Data.Traversable as T import qualified Data.Text as X -import qualified Penny.Cabin.Chunk as C +import qualified Penny.Steel.Chunk as C import qualified Penny.Cabin.Row as R import qualified Penny.Cabin.Posts.Growers as G import qualified Penny.Cabin.Posts.Meta as M diff --git a/Penny/Cabin/Posts/BottomRows.hs b/Penny/Cabin/Posts/BottomRows.hs --- a/Penny/Cabin/Posts/BottomRows.hs +++ b/Penny/Cabin/Posts/BottomRows.hs @@ -31,7 +31,7 @@ import qualified Data.Sequence as Seq import qualified Data.Text as X import qualified Data.Traversable as T -import qualified Penny.Cabin.Chunk as C +import qualified Penny.Steel.Chunk as C import qualified Penny.Cabin.Scheme as E import qualified Penny.Cabin.Row as R import qualified Penny.Cabin.TextFormat as TF diff --git a/Penny/Cabin/Posts/Chunk.hs b/Penny/Cabin/Posts/Chunk.hs --- a/Penny/Cabin/Posts/Chunk.hs +++ b/Penny/Cabin/Posts/Chunk.hs @@ -10,7 +10,7 @@ import qualified Penny.Cabin.Posts.Spacers as S import qualified Penny.Cabin.Row as R import qualified Penny.Cabin.Scheme as E -import qualified Penny.Cabin.Chunk as C +import qualified Penny.Steel.Chunk as C import Penny.Cabin.Posts.Meta (Box) import qualified Penny.Lincoln as L import qualified Data.Text as X diff --git a/Penny/Cabin/Posts/Meta.hs b/Penny/Cabin/Posts/Meta.hs --- a/Penny/Cabin/Posts/Meta.hs +++ b/Penny/Cabin/Posts/Meta.hs @@ -11,6 +11,7 @@ import qualified Penny.Liberty as Ly import qualified Penny.Cabin.Meta as M import qualified Penny.Cabin.Options as CO +import qualified Penny.Steel.Pdct as Pe import Data.Monoid (mempty, mappend) -- | The Box type that is used throughout the Posts modules. @@ -39,11 +40,11 @@ -- the VisibleNum. toBoxList :: CO.ShowZeroBalances - -> (L.Box Ly.LibertyMeta -> Bool) + -> Pe.Pdct (L.Box Ly.LibertyMeta) -- ^ Removes posts from the report if applying this function to the - -- post returns False. Posts removed still affect the running - -- balance. - + -- post returns a value other than Just True. Posts removed still + -- affect the running balance. + -> [Ly.PostFilterFn] -- ^ Applies these post-filters to the list of posts that results -- from applying the predicate above. Might remove more @@ -54,7 +55,7 @@ toBoxList szb pdct pff = addMetadata . Ly.processPostFilters pff - . filter (pdct . fmap fst) + . filter (maybe False id . Pe.eval pdct . fmap fst) . addBalances szb addBalances :: diff --git a/Penny/Cabin/Posts/Parser.hs b/Penny/Cabin/Posts/Parser.hs --- a/Penny/Cabin/Posts/Parser.hs +++ b/Penny/Cabin/Posts/Parser.hs @@ -1,11 +1,20 @@ -module Penny.Cabin.Posts.Parser (State(..), - allSpecs) where +{-# LANGUAGE OverloadedStrings #-} +module Penny.Cabin.Posts.Parser + ( State(..) + , allSpecs + , VerboseFilter(..) + , ShowExpression(..) + ) where + import Control.Applicative ((<$>), pure, (<*>), Applicative) import qualified Control.Monad.Exception.Synchronous as Ex import Data.Char (toLower) import qualified Data.Foldable as Fdbl +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as X import qualified System.Console.MultiArg.Combinator as C import qualified System.Console.MultiArg as MA @@ -14,100 +23,113 @@ import qualified Penny.Cabin.Posts.Types as Ty import qualified Penny.Cabin.Options as CO import qualified Penny.Liberty as Ly -import qualified Penny.Liberty.Expressions as Exp +import qualified Penny.Steel.Expressions as Exp +import qualified Penny.Steel.Pdct as Pt import qualified Penny.Lincoln as L +import qualified Penny.Lincoln.Predicates as Pd import qualified Penny.Shield as S -import qualified Text.Matchers.Text as M +import qualified Text.Matchers as M +newtype VerboseFilter = VerboseFilter { unVerboseFilter :: Bool } + deriving (Eq, Show) + +newtype ShowExpression = ShowExpression { unShowExpression :: Bool } + deriving (Eq, Show) + data State = State { sensitive :: M.CaseSensitive , factory :: L.Factory - , tokens :: [Ly.Token (L.Box Ly.LibertyMeta -> Bool)] + , tokens :: [Exp.Token (L.Box Ly.LibertyMeta)] , postFilter :: [Ly.PostFilterFn] , fields :: F.Fields Bool , width :: Ty.ReportWidth , showZeroBalances :: CO.ShowZeroBalances - , showHelp :: Bool + , exprDesc :: Exp.ExprDesc + , verboseFilter :: VerboseFilter + , showExpression :: ShowExpression } +type Error = X.Text + allSpecs - :: S.Runtime -> [MA.OptSpec (State -> Ex.Exceptional String State)] + :: S.Runtime -> [MA.OptSpec (State -> Ex.Exceptional Error State)] allSpecs rt = operand rt ++ boxFilters ++ parsePostFilter - ++ matcherSelect - ++ caseSelect - ++ operator + ++ (map (fmap (pure .)) matcherSelect) + ++ (map (fmap (pure .)) caseSelect) + ++ (map (fmap (pure .)) operator) + ++ map (fmap (pure .)) parseExprType ++ [ parseWidth , showField , hideField - , showAllFields - , hideAllFields - , parseZeroBalances - , optHelp + , fmap (pure .) showAllFields + , fmap (pure .) hideAllFields + , fmap (pure .) parseZeroBalances + , fmap (pure .) parseShowExpression + , fmap (pure .) parseVerboseFilter ] operand :: S.Runtime - -> [MA.OptSpec (State -> Ex.Exceptional String State)] + -> [MA.OptSpec (State -> Ex.Exceptional Error State)] operand rt = map (fmap f) (Ly.operandSpecs (S.currentTime rt)) where f lyFn st = do let cs = sensitive st fty = factory st - (Exp.Operand g) <- lyFn cs fty - let g' = g . L.boxPostFam - ts' = tokens st ++ [Exp.TokOperand g'] + g <- lyFn cs fty + let g' = Pt.boxPdct L.boxPostFam g + ts' = tokens st ++ [Exp.operand g'] return $ st { tokens = ts' } -- | Processes a option for box-level serials. -optBoxSerial :: - [String] - -- ^ Long options - - -> [Char] - -- ^ Short options +optBoxSerial + :: String + -- ^ Serial name -> (Ly.LibertyMeta -> Int) -- ^ Pulls the serial from the PostMeta - -> C.OptSpec (State -> Ex.Exceptional String State) + -> C.OptSpec (State -> Ex.Exceptional Error State) -optBoxSerial ls ss f = C.OptSpec ls ss (C.TwoArg g) +optBoxSerial nm f = C.OptSpec [nm] "" (C.TwoArg g) where g a1 a2 st = do cmp <- Ly.parseComparer a1 i <- Ly.parseInt a2 - let h box = - let ser = f . L.boxMeta $ box - in ser `cmp` i - tok = Exp.TokOperand h + let (cmpDesc, cmpFn) = Pd.descComp cmp + desc = "serial " <> X.pack nm <> " is " <> cmpDesc + <> " " <> X.pack (show i) + pdct box = (f . L.boxMeta $ box) `cmpFn` i + opnd = Pt.operand desc pdct + tok = Exp.operand opnd return $ st { tokens = tokens st ++ [tok] } -optFilteredNum :: C.OptSpec (State -> Ex.Exceptional String State) -optFilteredNum = optBoxSerial ["filtered"] "" f +optFilteredNum :: C.OptSpec (State -> Ex.Exceptional Error State) +optFilteredNum = optBoxSerial "filtered" f where f = L.forward . Ly.unFilteredNum . Ly.filteredNum -optRevFilteredNum :: C.OptSpec (State -> Ex.Exceptional String State) -optRevFilteredNum = optBoxSerial ["revFiltered"] "" f +optRevFilteredNum :: C.OptSpec (State -> Ex.Exceptional Error State) +optRevFilteredNum = optBoxSerial "revFiltered" f where f = L.backward . Ly.unFilteredNum . Ly.filteredNum -optSortedNum :: C.OptSpec (State -> Ex.Exceptional String State) -optSortedNum = optBoxSerial ["sorted"] "" f +optSortedNum :: C.OptSpec (State -> Ex.Exceptional Error State) +optSortedNum = optBoxSerial "sorted" f where f = L.forward . Ly.unSortedNum . Ly.sortedNum -optRevSortedNum :: C.OptSpec (State -> Ex.Exceptional String State) -optRevSortedNum = optBoxSerial ["revSorted"] "" f +optRevSortedNum :: C.OptSpec (State -> Ex.Exceptional Error State) +optRevSortedNum = optBoxSerial "revSorted" f where f = L.backward . Ly.unSortedNum . Ly.sortedNum -boxFilters :: [C.OptSpec (State -> Ex.Exceptional String State)] +boxFilters :: [C.OptSpec (State -> Ex.Exceptional Error State)] boxFilters = [ optFilteredNum , optRevFilteredNum @@ -116,41 +138,39 @@ ] -parsePostFilter :: [C.OptSpec (State -> Ex.Exceptional String State)] +parsePostFilter :: [C.OptSpec (State -> Ex.Exceptional Error State)] parsePostFilter = [fmap f optH, fmap f optT] where (optH, optT) = Ly.postFilterSpecs - f exc = case exc of - Ex.Exception s -> const $ Ex.throw s - Ex.Success pf -> - let g st = return $ st { postFilter = postFilter st ++ [pf] } - in g + f exc st = fmap g exc + where + g pff = st { postFilter = postFilter st ++ [pff] } -matcherSelect :: Applicative f => [C.OptSpec (State -> f State)] +matcherSelect :: [C.OptSpec (State -> State)] matcherSelect = map (fmap f) Ly.matcherSelectSpecs where - f mf st = pure $ st { factory = mf } + f mf st = st { factory = mf } -caseSelect :: Applicative f => [C.OptSpec (State -> f State)] +caseSelect :: [C.OptSpec (State -> State)] caseSelect = map (fmap f) Ly.caseSelectSpecs where - f cs st = pure $ st { sensitive = cs } + f cs st = st { sensitive = cs } -operator :: Applicative f => [C.OptSpec (State -> f State)] +operator :: [C.OptSpec (State -> State)] operator = map (fmap f) Ly.operatorSpecs where - f oo st = pure $ st { tokens = tokens st ++ [oo] } + f oo st = st { tokens = tokens st ++ [oo] } -parseWidth :: C.OptSpec (State -> Ex.Exceptional String State) +parseWidth :: C.OptSpec (State -> Ex.Exceptional Error State) parseWidth = C.OptSpec ["width"] "" (C.OneArg f) where f a1 st = do i <- Ly.parseInt a1 return $ st { width = Ty.ReportWidth i } -parseField :: String -> Ex.Exceptional String (F.Fields Bool) +parseField :: String -> Ex.Exceptional Error (F.Fields Bool) parseField str = let lower = map toLower str checkField s = @@ -158,7 +178,18 @@ then (s, True) else (s, False) flds = checkField <$> F.fieldNames - in checkFields flds + in case checkFields flds of + Ex.Exception e -> case e of + NoMatchingFields -> Ex.throw + $ "no field matches the name \"" <> X.pack str <> "\"\n" + MultipleMatchingFields ts -> Ex.throw + $ "multiple fields match the name \"" <> X.pack str + <> "\" matches: " <> mtchs <> "\n" + where + mtchs = X.intercalate " " + . map (\x -> "\"" <> x <> "\"") + $ ts + Ex.Success g -> return g -- | Turns a field on if it is True. @@ -192,7 +223,7 @@ f o False = o f _ True = False -showField :: C.OptSpec (State -> Ex.Exceptional String State) +showField :: C.OptSpec (State -> Ex.Exceptional Error State) showField = C.OptSpec ["show"] "" (C.OneArg f) where f a1 st = do @@ -200,7 +231,7 @@ let newFl = fieldOn (fields st) fl return $ st { fields = newFl } -hideField :: C.OptSpec (State -> Ex.Exceptional String State) +hideField :: C.OptSpec (State -> Ex.Exceptional Error State) hideField = C.OptSpec ["hide"] "" (C.OneArg f) where f a1 st = do @@ -208,35 +239,50 @@ let newFl = fieldOff (fields st) fl return $ st { fields = newFl } -showAllFields :: Applicative f => C.OptSpec (State -> f State) +showAllFields :: C.OptSpec (State -> State) showAllFields = C.OptSpec ["show-all"] "" (C.NoArg f) where - f st = pure $ st {fields = pure True} + f st = st {fields = pure True} -hideAllFields :: Applicative f => C.OptSpec (State -> f State) +hideAllFields :: C.OptSpec (State -> State) hideAllFields = C.OptSpec ["hide-all"] "" (C.NoArg f) where - f st = pure $ st {fields = pure False} + f st = st {fields = pure False} -optHelp :: Applicative f => C.OptSpec (State -> f State) -optHelp = fmap f P.help +parseZeroBalances :: C.OptSpec (State -> State) +parseZeroBalances = fmap f P.zeroBalances where - f _ st = pure $ st { showHelp = True } + f szb st = st { showZeroBalances = szb } -parseZeroBalances :: Applicative f => C.OptSpec (State -> f State) -parseZeroBalances = fmap f P.zeroBalances +parseExprType :: [C.OptSpec (State -> State)] +parseExprType = map (fmap f) [Ly.parseInfix, Ly.parseRPN] where - f szb st = pure $ st { showZeroBalances = szb } + f d st = st { exprDesc = d } +parseShowExpression :: C.OptSpec (State -> State) +parseShowExpression = fmap f Ly.showExpression + where + f _ st = st { showExpression = ShowExpression True } + +parseVerboseFilter :: C.OptSpec (State -> State) +parseVerboseFilter = fmap f Ly.verboseFilter + where + f _ st = st { verboseFilter = VerboseFilter True } + +data BadFieldError + = NoMatchingFields + | MultipleMatchingFields [Text] + deriving Show + -- | Checks the fields with the True value to ensure there is only one. checkFields :: F.Fields (String, Bool) - -> Ex.Exceptional String (F.Fields Bool) + -> Ex.Exceptional BadFieldError (F.Fields Bool) checkFields fs = let f (s, b) ls = if b then s:ls else ls in case Fdbl.foldr f [] fs of - [] -> Ex.throw "no matching field names" + [] -> Ex.throw NoMatchingFields _:[] -> return (snd <$> fs) - _ -> Ex.throw "multiple matching field names" + ms -> Ex.throw . MultipleMatchingFields . map X.pack $ ms diff --git a/Penny/Cabin/Row.hs b/Penny/Cabin/Row.hs --- a/Penny/Cabin/Row.hs +++ b/Penny/Cabin/Row.hs @@ -30,7 +30,7 @@ import Data.List (transpose) import qualified Data.Text as X -import qualified Penny.Cabin.Chunk as C +import qualified Penny.Steel.Chunk as C import qualified Penny.Cabin.Scheme as E -- | How to justify cells. LeftJustify leaves the right side diff --git a/Penny/Cabin/Scheme.hs b/Penny/Cabin/Scheme.hs --- a/Penny/Cabin/Scheme.hs +++ b/Penny/Cabin/Scheme.hs @@ -8,7 +8,7 @@ module Penny.Cabin.Scheme where -import qualified Penny.Cabin.Chunk as C +import qualified Penny.Steel.Chunk as C import qualified Penny.Cabin.Meta as M import qualified Penny.Lincoln as L import qualified Data.Text as X diff --git a/Penny/Cabin/Scheme/Schemes.hs b/Penny/Cabin/Scheme/Schemes.hs --- a/Penny/Cabin/Scheme/Schemes.hs +++ b/Penny/Cabin/Scheme/Schemes.hs @@ -3,8 +3,8 @@ module Penny.Cabin.Scheme.Schemes where import qualified Penny.Cabin.Scheme as E -import qualified Penny.Cabin.Chunk as C -import qualified Penny.Cabin.Chunk.Switch as Sw +import qualified Penny.Steel.Chunk as C +import qualified Penny.Steel.Chunk.Switch as Sw -- | The light color scheme. You can change various values below to -- affect the color scheme. diff --git a/Penny/Copper.hs b/Penny/Copper.hs --- a/Penny/Copper.hs +++ b/Penny/Copper.hs @@ -9,7 +9,6 @@ -- * Convenience functions to read and parse files parse , open - , openStdin -- * Types for things found in ledger files , Y.Item(BlankLine, IComment, PricePoint, Transaction) @@ -44,7 +43,8 @@ import qualified Penny.Lincoln as L import qualified Penny.Copper.Render as R import qualified Penny.Copper.Types as Y -import qualified System.IO.Error as E +import System.Console.MultiArg.GetArgs (getProgName) +import qualified System.Exit as Exit import qualified System.IO as IO newtype FileContents = FileContents { unFileContents :: X.Text } @@ -170,46 +170,40 @@ -> Ex.Exceptional ErrorMsg Y.Ledger parse ps = fmap addGlobalMetadata $ mapM parseFile ps --- | Reads and parses the given filename. Does not do anything to --- handle @-@ arguments; for that, see openStdin. Errors are indicated --- by throwing an exception. -open :: [String] -> IO Y.Ledger -open = fmap addGlobalMetadata - . mapM (\s -> getFileContents s >>= parseAndResolve) - -getFileContents :: String -> IO (L.Filename, FileContents) -getFileContents s = fmap f (TIO.readFile s) - where f c = (L.Filename . X.pack $ s, FileContents c) - parseAndResolve :: (L.Filename, FileContents) -> IO Y.Ledger parseAndResolve p@(L.Filename fn, _) = Ex.switch err return $ parseFile p where - err (ErrorMsg x) = - E.ioError $ E.mkIOError E.userErrorType - ("could not parse file: " ++ X.unpack x) - Nothing (Just . X.unpack $ fn) + err (ErrorMsg x) = do + pn <- getProgName + let msg = pn ++ ": error: could not parse file " + ++ X.unpack fn ++ "\n" + ++ X.unpack x + IO.hPutStr IO.stderr msg + Exit.exitFailure -- | Reads and parses the given files. If any of the files is @-@, -- reads standard input. If the list of files is empty, reads standard --- input. Errors are indicated by throwing an exception. -openStdin :: [String] -> IO Y.Ledger -openStdin ss = +-- input. IO errors are not caught. Parse errors are printed to +-- standard error and the program will exit with a failure. +open :: [String] -> IO Y.Ledger +open ss = let ls = if null ss - then fmap (\x -> [x]) (getFileContentsStdin "-") + then fmap (:[]) (getFileContentsStdin "-") else mapM getFileContentsStdin ss in fmap addGlobalMetadata (ls >>= mapM parseAndResolve) getFileContentsStdin :: String -> IO (L.Filename, FileContents) getFileContentsStdin s = do + pn <- getProgName txt <- if s == "-" then do isTerm <- IO.hIsTerminalDevice IO.stdin when isTerm (IO.hPutStrLn IO.stderr $ - "warning: reading from standard input, which" + pn ++ ": warning: reading from standard input, which" ++ "is a terminal.") TIO.hGetContents IO.stdin else TIO.readFile s diff --git a/Penny/Liberty.hs b/Penny/Liberty.hs --- a/Penny/Liberty.hs +++ b/Penny/Liberty.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | Liberty - Penny command line parsing utilities -- -- Both Cabin and Zinc share various functions that aid in parsing @@ -9,8 +11,6 @@ module Penny.Liberty ( MatcherFactory, - X.evaluate, - X.Token(..), FilteredNum(FilteredNum, unFilteredNum), SortedNum(SortedNum, unSortedNum), LibertyMeta(filteredNum, sortedNum), @@ -20,9 +20,13 @@ PostFilterFn, parseComparer, processPostFilters, - parseTokenList, parsePredicate, parseInt, + parseInfix, + parseRPN, + exprDesc, + showExpression, + verboseFilter, -- * Parsers Operand, @@ -30,16 +34,21 @@ postFilterSpecs, matcherSelectSpecs, caseSelectSpecs, - operatorSpecs + operatorSpecs, + -- * Errors + Error + ) where -import Control.Applicative ((<*>), (<$>)) +import Control.Applicative ((<*>), (<$>), pure, Applicative) import qualified Control.Monad.Exception.Synchronous as Ex import Data.Char (toUpper) +import Data.Maybe (mapMaybe) +import Data.Monoid ((<>)) import Data.List (sortBy) -import Data.Text (Text, pack, unpack) -import qualified Data.Text as Text +import Data.Text (Text, pack) +import qualified Data.Time as Time import qualified System.Console.MultiArg.Combinator as C import System.Console.MultiArg.Combinator (OptSpec) import Text.Parsec (parse) @@ -48,13 +57,18 @@ import Penny.Lincoln.Family.Child (child, parent) import qualified Penny.Lincoln.Predicates as P +import qualified Penny.Steel.Pdct as E import qualified Penny.Lincoln as L -import qualified Penny.Liberty.Expressions as X +import qualified Penny.Steel.Chunk as C +import qualified Penny.Steel.Expressions as X -import Text.Matchers.CaseSensitive ( +import Text.Matchers ( CaseSensitive(Sensitive, Insensitive)) -import qualified Text.Matchers.Text as TM +import qualified Text.Matchers as TM +-- | A multiline Text that holds an error message. +type Error = Text + -- | A serial indicating how a post relates to all other postings that -- made it through the filtering phase. newtype FilteredNum = FilteredNum { unFilteredNum :: L.Serial } @@ -72,30 +86,24 @@ deriving Show --- | Parses a list of tokens. Returns Nothing if the token sequence is --- invalid (e.g. if two operators are next to each other) or if the --- resulting RPN expression is bad (there are tokens left on the stack --- after parsing). Otherwise, returns the expression. --- --- An empty list will fail to parse. The function calling this one --- must deal with empty lists if those are a possibility. -parseTokenList :: [X.Token a] -> Maybe a -parseTokenList = X.evaluate - -- | Parses a list of tokens to obtain a predicate. Deals with an -- empty list of tokens by returning a predicate that is always -- True. Fails if the list of tokens is not empty and the parse fails. -parsePredicate :: [X.Token (a -> Bool)] -> Maybe (a -> Bool) -parsePredicate ls = case ls of - [] -> return (const True) - ts -> parseTokenList ts +parsePredicate + :: X.ExprDesc + -> [X.Token a] + -> Ex.Exceptional Error (E.Pdct a) +parsePredicate d ls = case ls of + [] -> return E.always + _ -> X.parseExpression d ls -- | Takes a list of transactions, splits them into PostingChild -- instances, filters them, post-filters them, sorts them, and places --- them in Box instances with Filtered serials. +-- them in Box instances with Filtered serials. Also returns a Text +-- containing a description of the evalutation process. xactionsToFiltered :: - (L.PostFam -> Bool) + P.LPdct -- ^ The predicate to filter the transactions -> [PostFilterFn] @@ -107,19 +115,40 @@ -> [L.Transaction] -- ^ The transactions to work on (probably parsed in from Copper) - -> [L.Box LibertyMeta] + -> ([C.Chunk], [L.Box LibertyMeta]) -- ^ Sorted, filtered postings -xactionsToFiltered pdct pfs s = - addSortedNum - . processPostFilters pfs - . sortBy (sorter s) - . addFilteredNum - . map toBox - . filter pdct - . concatMap L.postFam +xactionsToFiltered pdct postFilts s txns = + let pdcts = map (makeLabeledPdct pdct) pfs + evaluator subj pd = E.evaluate indentAmt True subj 0 pd + pairMaybes = zipWith evaluator pfs pdcts + pairs = mapMaybe rmMaybe pairMaybes + rmMaybe (mayB, x) = case mayB of + Nothing -> Nothing + Just b -> Just (b, x) + pfs = concatMap L.postFam txns + txt = concatMap snd pairs + filtered = map snd . filter fst $ zipWith zipper pairs pfs + zipper (bool, _) pf = (bool, pf) + resultLs = addSortedNum + . processPostFilters postFilts + . sortBy (sorter s) + . addFilteredNum + . map toBox + $ filtered + in (txt, resultLs) +-- | Creates a Pdct and prepends a one-line description of the PostFam +-- to the Pdct's label so it can be easily identified in the output. +makeLabeledPdct :: E.Pdct L.PostFam -> L.PostFam -> E.Pdct L.PostFam +makeLabeledPdct pd pf = E.rename f pd + where + f old = old <> " - " <> L.display pf + +indentAmt :: E.IndentAmt +indentAmt = 4 + -- | Transforms a PostingChild into a Box. toBox :: L.PostFam -> L.Box () toBox = L.Box () @@ -149,8 +178,7 @@ type MatcherFactory = CaseSensitive -> Text - -> Ex.Exceptional Text (Text -> Bool) -type Operand = X.Operand (L.PostFam -> Bool) + -> Ex.Exceptional Text TM.Matcher newtype ListLength = ListLength { unListLength :: Int } deriving (Eq, Ord, Show) @@ -177,113 +205,71 @@ ------------------------------------------------------------ -- | Given a String from the command line which represents a pattern, --- and a MatcherFactor, return a Matcher. Fails if the pattern is bad --- (e.g. it is not a valid regular expression). +-- the current case sensitivity, and a MatcherFactory, return a +-- Matcher. Fails if the pattern is bad (e.g. it is not a valid +-- regular expression). getMatcher :: String -> CaseSensitive -> MatcherFactory - -> Ex.Exceptional String (Text -> Bool) + -> Ex.Exceptional Error TM.Matcher -getMatcher s cs f = Ex.mapException e (f cs (pack s)) +getMatcher s cs f + = Ex.mapException mkError + $ f cs (pack s) where - e err = "bad pattern: " ++ s ++ " error message: " - ++ unpack err + mkError eMsg = "bad pattern: \"" <> pack s <> " - " <> eMsg + <> "\n" --- | Parses comparers given on command line to a function. Aborts if + +-- | Parses comparers given on command line to a function. Fails if -- the string given is invalid. -parseComparer :: - (Eq a, Ord a) - => String - -> Ex.Exceptional String (a -> a -> Bool) +parseComparer :: String -> Ex.Exceptional Error P.Comp parseComparer t - | t == "<" = return (<) - | t == "<=" = return (<=) - | t == "==" = return (==) - | t == "=" = return (==) - | t == ">" = return (>) - | t == ">=" = return (>=) - | t == "/=" = return (/=) - | t == "!=" = return (/=) - | otherwise = Ex.throw $ "invalid comparer: " ++ t + | t == "<" = return P.DLT + | t == "<=" = return P.DLTEQ + | t == "==" = return P.DEQ + | t == "=" = return P.DEQ + | t == ">" = return P.DGT + | t == ">=" = return P.DGTEQ + | t == "/=" = return P.DNE + | t == "!=" = return P.DNE + | otherwise = Ex.throw msg + where + msg = "bad comparer: " <> pack t <> "\n" -parseDate :: String -> Ex.Exceptional String L.DateTime -parseDate = - Ex.mapException f . Ex.fromEither . parse Pc.dateTime "" . pack +-- | Parses a date from the command line. On failure, throws back the +-- error message from the failed parse. +parseDate :: String -> Ex.Exceptional Error Time.UTCTime +parseDate arg = + Ex.mapExceptional err L.toUTC + . Ex.fromEither + . parse Pc.dateTime "" + . pack + $ arg where - f msg = "invalid date: " ++ show msg + err msg = "bad date: \"" <> pack arg <> "\" - " <> (pack . show $ msg) -date :: OptSpec (Ex.Exceptional String Operand) +type Operand = E.Pdct L.PostFam + +-- | OptSpec for a date. +date :: OptSpec (Ex.Exceptional Error Operand) date = C.OptSpec ["date"] ['d'] (C.TwoArg f) where - f a1 a2 = g <$> parseComparer a1 <*> parseDate a2 - g cmp dt = X.Operand (P.date (`cmp` dt)) + f a1 a2 = P.date <$> parseComparer a1 <*> parseDate a2 current :: L.DateTime -> OptSpec Operand current dt = C.OptSpec ["current"] [] (C.NoArg f) where - f = X.Operand (P.date (<= dt)) - - --- | Creates options that match against fields that are --- colon-separated. The operand added will return True if the --- posting's colon-separated option matches the pattern given, or --- False if it does not. -sepOption :: - String - -- ^ Long option name - - -> Maybe Char - -- ^ Short option name, if there is one - - -> (Text -> (Text -> Bool) -> L.PostFam -> Bool) - -- ^ When applied to a text that separates the different segments of - -- the field, a matcher, and a posting, this function returns True - -- if the posting matches the matcher or False if it does not. - - -> OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional String Operand ) -sepOption str mc f = C.OptSpec [str] so (C.OneArg g) - where - so = maybe [] return mc - g a cs fty = h <$> getMatcher a cs fty - where - h mtr = X.Operand (f sep mtr) - - -sep :: Text -sep = Text.singleton ':' + f = P.date P.DLTEQ (L.toUTC dt) -- | Parses exactly one integer; fails if it cannot read exactly one. -parseInt :: String -> Ex.Exceptional String Int +parseInt :: String -> Ex.Exceptional Error Int parseInt t = case reads t of ((i, ""):[]) -> return i - _ -> Ex.throw ("invalid number: " ++ t) - --- | Creates options that take two arguments, with the first argument --- being the level to match, and the second being the pattern that --- should match against that level. Adds an operand that returns True --- if the pattern matches. -levelOption :: - String - -- ^ Long option name - - -> (Int -> (Text -> Bool) -> L.PostFam -> Bool) - -- ^ Applied to an integer, a matcher, and a PostingBox, this - -- function returns True if a particular field in the posting - -- matches the matcher given at the given level, or False otherwise. - - -> OptSpec ( CaseSensitive - -> MatcherFactory - -> Ex.Exceptional String Operand) - -levelOption str f = C.OptSpec [str] [] (C.TwoArg g) - where - g a1 a2 cs fty = h <$> parseInt a1 <*> getMatcher a2 cs fty - h i m = X.Operand (f i m) + _ -> Ex.throw $ "could not parse integer: \"" <> pack t <> "\"\n" -- | Creates options that add an operand that matches the posting if a @@ -295,96 +281,104 @@ -> Maybe Char -- ^ Short option, if included - -> ((Text -> Bool) -> L.PostFam -> Bool) - -- ^ When applied to a matcher and a PostingBox, this function - -- returns True if the posting matches, or False if it does not. + -> (TM.Matcher -> P.LPdct) + -- ^ When applied to a Matcher, this function returns a predicate. -> OptSpec ( CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand ) + -> Ex.Exceptional Error Operand ) patternOption str mc f = C.OptSpec [str] so (C.OneArg g) where - so = maybe [] (\c -> [c]) mc - g a1 cs fty = h <$> getMatcher a1 cs fty - h m = X.Operand (f m) - + so = maybe [] (:[]) mc + g a1 cs fty = f <$> getMatcher a1 cs fty -- | The account option; matches if the pattern given matches the -- colon-separated account name. account :: OptSpec ( CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand ) -account = sepOption "account" (Just 'a') P.account + -> Ex.Exceptional Error Operand ) +account = C.OptSpec ["account"] "a" (C.OneArg f) + where + f a1 cs fty + = fmap P.account + $ getMatcher a1 cs fty + -- | The account-level option; matches if the account at the given -- level matches. accountLevel :: OptSpec ( CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand) -accountLevel = levelOption "account-level" P.accountLevel + -> Ex.Exceptional Error Operand) +accountLevel = C.OptSpec ["account-level"] "" (C.TwoArg f) + where + f a1 a2 cs fty + = P.accountLevel <$> parseInt a1 <*> getMatcher a2 cs fty + -- | The accountAny option; returns True if the matcher given matches -- a single sub-account name at any level. accountAny :: OptSpec ( CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand ) + -> Ex.Exceptional Error Operand ) accountAny = patternOption "account-any" Nothing P.accountAny -- | The payee option; returns True if the matcher matches the payee -- name. payee :: OptSpec ( CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand ) + -> Ex.Exceptional Error Operand ) payee = patternOption "payee" (Just 'p') P.payee tag :: OptSpec ( CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand) + -> Ex.Exceptional Error Operand) tag = patternOption "tag" (Just 't') P.tag number :: OptSpec ( CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand ) + -> Ex.Exceptional Error Operand ) number = patternOption "number" Nothing P.number flag :: OptSpec ( CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand) + -> Ex.Exceptional Error Operand) flag = patternOption "flag" Nothing P.flag commodity :: OptSpec ( CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand) + -> Ex.Exceptional Error Operand) commodity = patternOption "commodity" Nothing P.commodity postingMemo :: OptSpec ( CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand) + -> Ex.Exceptional Error Operand) postingMemo = patternOption "posting-memo" Nothing P.postingMemo transactionMemo :: OptSpec ( CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand) + -> Ex.Exceptional Error Operand) transactionMemo = patternOption "transaction-memo" Nothing P.transactionMemo debit :: OptSpec Operand -debit = C.OptSpec ["debit"] [] (C.NoArg (X.Operand P.debit)) +debit = C.OptSpec ["debit"] [] (C.NoArg P.debit) credit :: OptSpec Operand -credit = C.OptSpec ["credit"] [] (C.NoArg (X.Operand P.credit)) +credit = C.OptSpec ["credit"] [] (C.NoArg P.credit) -qtyOption :: OptSpec (Ex.Exceptional String Operand) +qtyOption :: OptSpec (Ex.Exceptional Error Operand) qtyOption = C.OptSpec ["qty"] [] (C.TwoArg f) where - f a1 a2 = g <$> parseComparer a1 <*> parseQty a2 - parseQty = Ex.mapException err . Ex.fromEither - . parse Pc.quantity "" . pack - err msg = "invalid quantity: " ++ show msg - g cmp qty = X.Operand (P.qty (`cmp` qty)) + f a1 a2 = P.qty <$> parseComparer a1 <*> parseQty a2 + parseQty a = case parse Pc.quantity "" (pack a) of + Left e -> Ex.throw $ "could not parse quantity: " + <> pack a <> " - " + <> (pack . show $ e) + Right g -> pure g + -- | Creates two options suitable for comparison of serial numbers, -- one for ascending, one for descending. serialOption :: @@ -396,8 +390,8 @@ -> String -- ^ Name of the command line option, such as @global-transaction@ - -> ( OptSpec (Ex.Exceptional String Operand) - , OptSpec (Ex.Exceptional String Operand) ) + -> ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) -- ^ Parses both descending and ascending serial options. serialOption getSerial n = (osA, osD) @@ -406,13 +400,15 @@ (C.TwoArg (f L.forward)) osD = C.OptSpec [addPrefix "rev" n] [] (C.TwoArg (f L.backward)) - f getInt a1 a2 = g <$> parseComparer a1 <*> parseInt a2 - where - g cmp i = - let op pf = case getSerial pf of - Nothing -> False - Just ser -> getInt ser `cmp` i - in X.Operand op + f getInt a1 a2 = do + cmp <- parseComparer a1 + num <- parseInt a2 + let op pf = case getSerial pf of + Nothing -> False + Just ser -> getInt ser `cmpFn` num + (cmpDesc, cmpFn) = P.descComp cmp + desc = pack n <> " is " <> cmpDesc <> " " <> (pack . show $ num) + return (E.operand desc op) -- | Takes a string, adds a prefix and capitalizes the first letter of @@ -424,8 +420,8 @@ "" -> "" x:xs -> toUpper x : xs -globalTransaction :: ( OptSpec (Ex.Exceptional String Operand) - , OptSpec (Ex.Exceptional String Operand) ) +globalTransaction :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) globalTransaction = let f = fmap L.unGlobalTransaction . L.tGlobalTransaction @@ -433,8 +429,8 @@ . L.unPostFam in serialOption f "globalTransaction" -globalPosting :: ( OptSpec (Ex.Exceptional String Operand) - , OptSpec (Ex.Exceptional String Operand) ) +globalPosting :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) globalPosting = let f = fmap L.unGlobalPosting . L.pGlobalPosting @@ -442,8 +438,8 @@ . L.unPostFam in serialOption f "globalPosting" -filePosting :: ( OptSpec (Ex.Exceptional String Operand) - , OptSpec (Ex.Exceptional String Operand) ) +filePosting :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) filePosting = let f = fmap L.unFilePosting . L.pFilePosting @@ -451,8 +447,8 @@ . L.unPostFam in serialOption f "filePosting" -fileTransaction :: ( OptSpec (Ex.Exceptional String Operand) - , OptSpec (Ex.Exceptional String Operand) ) +fileTransaction :: ( OptSpec (Ex.Exceptional Error Operand) + , OptSpec (Ex.Exceptional Error Operand) ) fileTransaction = let f = fmap L.unFileTransaction . L.tFileTransaction @@ -460,68 +456,77 @@ . L.unPostFam in serialOption f "fileTransaction" -unDouble - :: ( OptSpec (Ex.Exceptional String Operand) - , OptSpec (Ex.Exceptional String Operand) ) - -> [ OptSpec (a -> b -> Ex.Exceptional String Operand) ] -unDouble (o1, o2) = [fmap f o1, fmap f o2] - where - f = (\g _ _ -> g) - - -- | All operand OptSpec. operandSpecs :: L.DateTime -> [OptSpec (CaseSensitive -> MatcherFactory - -> Ex.Exceptional String Operand)] + -> Ex.Exceptional Error Operand)] operandSpecs dt = - [ fmap (\f _ _ -> f) date - , fmap (\o _ _ -> return o) (current dt) - , wrapFactArg account - , wrapFactArg accountLevel - , wrapFactArg accountAny - , wrapFactArg payee - , wrapFactArg tag - , wrapFactArg number - , wrapFactArg flag - , wrapFactArg commodity - , wrapFactArg postingMemo - , wrapFactArg transactionMemo - , fmap (\f _ _ -> return f) debit - , fmap (\f _ _ -> return f) credit - , fmap (\f _ _ -> f) qtyOption + [ fmap (const . const) date + , fmap (const . const . pure) (current dt) + , account + , accountLevel + , accountAny + , payee + , tag + , number + , flag + , commodity + , postingMemo + , transactionMemo + , fmap (const . const . pure) debit + , fmap (const . const . pure) credit + , fmap (const . const) qtyOption ] - ++ unDouble globalTransaction - ++ unDouble globalPosting - ++ unDouble filePosting - ++ unDouble fileTransaction - where - wrapFactArg = fmap (\f cs fty -> f cs fty) + ++ serialSpecs +serialSpecs :: [OptSpec (CaseSensitive + -> MatcherFactory + -> Ex.Exceptional Error Operand)] +serialSpecs + = concat + $ [unDouble] + <*> [ globalTransaction, globalPosting, + filePosting, fileTransaction ] + +unDouble + :: Functor f + => (f (Ex.Exceptional Error a), + f (Ex.Exceptional Error a )) + -> [ f (x -> y -> Ex.Exceptional Error a) ] +unDouble (o1, o2) = [fmap (const . const) o1, fmap (const . const) o2] + + ------------------------------------------------------------ -- Post filters ------------------------------------------------------------ -optHead :: OptSpec (Ex.Exceptional String PostFilterFn) +-- | The user passed a bad number for the head or tail option. The +-- argument is the bad number passed. +data BadHeadTailError = BadHeadTailError Text + deriving Show + +optHead :: OptSpec (Ex.Exceptional Error PostFilterFn) optHead = C.OptSpec ["head"] [] (C.OneArg f) where - f a = g <$> parseInt a - where - g i _ ii = ii < (ItemIndex i) + f a = do + num <- parseInt a + let g _ ii = ii < (ItemIndex num) + return g -optTail :: OptSpec (Ex.Exceptional String PostFilterFn) +optTail :: OptSpec (Ex.Exceptional Error PostFilterFn) optTail = C.OptSpec ["tail"] [] (C.OneArg f) where - f a = g <$> parseInt a - where - g i (ListLength len) (ItemIndex ii) = ii >= len - i - + f a = do + num <- parseInt a + let g (ListLength len) (ItemIndex ii) = ii >= len - num + return g -postFilterSpecs :: ( OptSpec (Ex.Exceptional String PostFilterFn) - , OptSpec (Ex.Exceptional String PostFilterFn) ) +postFilterSpecs :: ( OptSpec (Ex.Exceptional Error PostFilterFn) + , OptSpec (Ex.Exceptional Error PostFilterFn) ) postFilterSpecs = (optHead, optTail) ------------------------------------------------------------ @@ -565,25 +570,43 @@ -- | Open parentheses open :: OptSpec (X.Token a) -open = noArg X.TokOpenParen "open" +open = noArg X.openParen "open" -- | Close parentheses close :: OptSpec (X.Token a) -close = noArg X.TokCloseParen "close" +close = noArg X.closeParen "close" -- | and operator -parseAnd :: OptSpec (X.Token (a -> Bool)) -parseAnd = noArg X.tokAnd "and" +parseAnd :: OptSpec (X.Token a) +parseAnd = noArg X.opAnd "and" -- | or operator -parseOr :: OptSpec (X.Token (a -> Bool)) -parseOr = noArg X.tokOr "or" +parseOr :: OptSpec (X.Token a) +parseOr = noArg X.opOr "or" -- | not operator -parseNot :: OptSpec (X.Token (a -> Bool)) -parseNot = noArg X.tokNot "not" where +parseNot :: OptSpec (X.Token a) +parseNot = noArg X.opNot "not" -operatorSpecs :: [OptSpec (X.Token (a -> Bool))] +operatorSpecs :: [OptSpec (X.Token a)] operatorSpecs = [open, close, parseAnd, parseOr, parseNot] + +-- Infix and RPN expression selectors + +parseInfix :: OptSpec X.ExprDesc +parseInfix = noArg X.Infix "infix" + +parseRPN :: OptSpec X.ExprDesc +parseRPN = noArg X.RPN "rpn" + +-- | Both Infix and RPN options. +exprDesc :: [OptSpec X.ExprDesc] +exprDesc = [ parseInfix, parseRPN ] + +showExpression :: OptSpec () +showExpression = noArg () "show-expression" + +verboseFilter :: OptSpec () +verboseFilter = noArg () "verbose-filter" diff --git a/Penny/Liberty/Expressions.hs b/Penny/Liberty/Expressions.hs deleted file mode 100644 --- a/Penny/Liberty/Expressions.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Penny.Liberty.Expressions ( - I.Precedence(Precedence), - - I.Associativity(ALeft, ARight), - - I.Token(TokOperand, - TokUnaryPostfix, - TokUnaryPrefix, - TokBinary, - TokOpenParen, - TokCloseParen), - - R.Operand(..), - tokAnd, - tokOr, - tokNot, - evaluate) where - -import qualified Data.Foldable as Fdbl -import Penny.Liberty.Expressions.Infix as I -import Penny.Liberty.Expressions.RPN as R - - --- | Tokens should be enqueued from left to right, so that tokens on --- the left side of the sequence are those at the beginning of the --- expression. -evaluate :: - Fdbl.Foldable l - => l (I.Token a) - -> Maybe a -evaluate i = I.infixToRPN i >>= R.process - --- | An And token which is left associative with precedence 3. -tokAnd :: I.Token (a -> Bool) -tokAnd = I.TokBinary (I.Precedence 3) I.ALeft f where - f x y = \a -> x a && y a - --- | An Or token which is left associative with precedence 2. -tokOr :: I.Token (a -> Bool) -tokOr = I.TokBinary (I.Precedence 2) I.ALeft f where - f x y = \a -> x a || y a - --- | A unary prefix Not token with precedence 4. -tokNot :: I.Token (a -> Bool) -tokNot = I.TokUnaryPrefix (I.Precedence 4) (not .) - --- --- Testing --- -_plus :: I.Token Double -_plus = I.TokBinary (I.Precedence 4) I.ALeft (+) - -_minus :: I.Token Double -_minus = I.TokBinary (I.Precedence 4) I.ALeft (-) - -_times :: I.Token Double -_times = I.TokBinary (I.Precedence 5) I.ALeft (*) - -_divide :: I.Token Double -_divide = I.TokBinary (I.Precedence 5) I.ALeft (/) - -_neg :: I.Token Double -_neg = I.TokUnaryPrefix (I.Precedence 5) negate diff --git a/Penny/Liberty/Expressions/Infix.hs b/Penny/Liberty/Expressions/Infix.hs deleted file mode 100644 --- a/Penny/Liberty/Expressions/Infix.hs +++ /dev/null @@ -1,218 +0,0 @@ --- | Creates RPN expressions from infix inputs. --- --- Penny accepts only infix expressions, but RPN expressions are --- easier to process. This module converts infix expressions to RPN --- expressions for further processing. --- --- Uses the shunting-yard algorithm, best described at --- http://www.chris-j.co.uk/parsing.php (be sure to use the \"click to --- display\" links). -module Penny.Liberty.Expressions.Infix ( - - Precedence(Precedence), - - Associativity(ALeft, - ARight), - - Token(TokOperand, - TokUnaryPostfix, - TokUnaryPrefix, - TokBinary, - TokOpenParen, - TokCloseParen), - - infixToRPN - ) where - -import qualified Data.Foldable as Fdbl -import qualified Penny.Liberty.Expressions.RPN as R -import qualified Data.Sequence as Seq -import Data.Sequence((|>), Seq) - --- | Precedence can be any integer; the greater the number, the higher --- the precedence. -newtype Precedence = Precedence Int deriving (Show, Eq, Ord) - -data Associativity = ALeft | ARight deriving Show - -data Token a = - TokOperand a - | TokUnaryPostfix (a -> a) - | TokUnaryPrefix Precedence (a -> a) - | TokBinary Precedence Associativity (a -> a -> a) - | TokOpenParen - | TokCloseParen - -instance (Show a) => Show (Token a) where - show (TokOperand a) = "" - show (TokUnaryPostfix _) = "" - show (TokUnaryPrefix (Precedence i) _) = - "" - show (TokBinary (Precedence i) a _) = - "" - show TokOpenParen = "" - show TokCloseParen = "" - -data StackVal a = - StkUnaryPrefix Precedence (a -> a) - | StkBinary Precedence (a -> a -> a) - | StkOpenParen - -instance Show (StackVal a) where - show (StkUnaryPrefix p _) = - "" - show (StkBinary p _) = - "" - show StkOpenParen = "" - --- | Converts an infix expression to an RPN expression. -infixToRPN :: - Fdbl.Foldable l - => l (Token a) - -- ^ Input tokens. These should be in the sequence from left to - -- right in ordinary infix order. The easiest choice is a list, - -- though you might want to use Data.Sequence if many appends will - -- be needed to build the sequence. - - -> Maybe (Seq (R.Token a)) - -- ^ The resulting RPN expression. The token type here is a token - -- from Penny.Liberty.Expressions.RPN, which is a different type - -- than the Token in this module. Fails only if there is a close - -- parenthesis without a matching open parenthesis, or if there is - -- an open parenthesis without a matching close parenthesis. Other - -- nonsensical expressions will still parse to an RPN expression - -- successfully, so the RPN parser has to catch these errors. - -infixToRPN ls = - Fdbl.foldlM processToken ([], Seq.empty) ls - >>= popRemainingOperators - - --- | Process a single input token. Fails if the token is a close --- parenthesis and a matching open parenthesis is not --- found. Otherwise, succeeds and adjusts the stack and the output --- queue accordingly. -processToken :: - ([StackVal a], Seq (R.Token a)) - -> Token a - -> Maybe ([StackVal a], Seq (R.Token a)) -processToken (ss, ts) tok = - case tok of - TokOperand a -> Just (ss, processOperand a ts) - TokUnaryPostfix f -> - Just (ss, processUnaryPostfix f ts) - TokUnaryPrefix p f -> - Just (processUnaryPrefix p f ss, ts) - TokBinary p a f -> - Just (processBinary p a f (ss, ts)) - TokOpenParen -> Just (processOpenParen ss, ts) - TokCloseParen -> processCloseParen (ss, ts) - --- | If a token is an operand, append it to the postfix output. -processOperand :: a -> Seq (R.Token a) -> Seq (R.Token a) -processOperand a sq = sq |> (R.TokOperand (R.Operand a)) - --- | If a token is a unary postfix operator, append it to the postfix --- output. -processUnaryPostfix :: - (a -> a) - -> Seq (R.Token a) - -> Seq (R.Token a) -processUnaryPostfix f sq = - sq |> (R.TokOperator (R.Unary f)) - --- | If a token is a unary prefix operator, push it onto the stack. -processUnaryPrefix :: - Precedence - -> (a -> a) - -> [StackVal a] - -> [StackVal a] -processUnaryPrefix p f s = (StkUnaryPrefix p f):s - --- | Pops tokens from the stack and appends them to the ouptut, as --- long as the token at the top of the stack is and operator and its --- precedence meets the given predicate. -popTokens :: - (Precedence -> Bool) - -> ([StackVal a], Seq (R.Token a)) - -> ([StackVal a], Seq (R.Token a)) -popTokens f (ss, os) = - case ss of - [] -> (ss, os) - x:xs -> case x of - StkOpenParen -> (ss, os) - StkUnaryPrefix p g -> popper (R.Unary g) p - StkBinary p g -> popper (R.Binary g) p - where - popper tok pr = - if f pr - then - let output' = os |> (R.TokOperator tok) - in popTokens f (xs, output') - else (ss, os) - - --- | If the token is a binary operator A, then: --- --- If A is left associative, while there is an operator B of higher or --- equal precedence than A at the top of the stack, pop B off the --- stack and append it to the output. --- --- If A is right associative, while there is an operator B of higher --- precedence than A at the top of the stack, pop B off the stack and --- append it to the output. --- --- Push A onto the stack. -processBinary :: - Precedence - -> Associativity - -> (a -> a -> a) - -> ([StackVal a], Seq (R.Token a)) - -> ([StackVal a], Seq (R.Token a)) -processBinary p a f pair = - let pdct = case a of - ALeft -> (>= p) - ARight -> (> p) - (ss, os) = popTokens pdct pair - in ((StkBinary p f):ss, os) - --- | If the token is an opening parenthesis, push it onto the stack. -processOpenParen :: [StackVal a] -> [StackVal a] -processOpenParen = (StkOpenParen :) - --- | If the token is a closing parenthesis, pop operators off the top --- of the stack and append them to the output until the operator at --- the top of the stack is an opening bracket. Pop the opening bracket --- off the stack. --- --- Fails if no open paren is found. -processCloseParen :: - ([StackVal a], Seq (R.Token a)) - -> Maybe ([StackVal a], Seq (R.Token a)) -processCloseParen (ss, os) = case ss of - [] -> Nothing - (x:xs) -> - let popper op = processCloseParen (xs, output') - where - output' = os |> (R.TokOperator op) - in case x of - StkUnaryPrefix _ f -> popper (R.Unary f) - StkBinary _ f -> popper (R.Binary f) - StkOpenParen -> Just (xs, os) - --- | Removes all remaining operators from the stack and puts them on --- the output queue. Fails if the stack has an open parenthesis; as --- this is unmatched. -popRemainingOperators :: - ([StackVal a], Seq (R.Token a)) - -> Maybe (Seq (R.Token a)) -popRemainingOperators (s, os) = case s of - [] -> Just os - x:xs -> case x of - StkOpenParen -> Nothing - StkUnaryPrefix _ f -> pusher (R.Unary f) - StkBinary _ f -> pusher (R.Binary f) - where - pusher op = popRemainingOperators (xs, output') where - output' = os |> (R.TokOperator op) diff --git a/Penny/Liberty/Expressions/RPN.hs b/Penny/Liberty/Expressions/RPN.hs deleted file mode 100644 --- a/Penny/Liberty/Expressions/RPN.hs +++ /dev/null @@ -1,112 +0,0 @@ --- | Parses reverse polish notation expressions. This module needs --- much better error messages (right now it has none). --- --- An RPN expression consists of operands and operators; a token is --- either an operand or an operator. For example, in the expression @5 --- 4 +@, the @5@ and the @4@ are operands; the @+@ is an operator; --- each of these three is a token. -module Penny.Liberty.Expressions.RPN ( - Operand(..), - Operator(Unary, Binary), - Token(TokOperand, TokOperator), - process) where - -import qualified Data.Foldable as Fdbl - --- | An operand; for example, in the expression @5 4 +@, @5@ and @4@ --- are operands. -newtype Operand a = Operand { unOperand :: a } deriving Show - --- | Operators; for example, in the expression @5 4 +@, @+@ is an --- operator. Because this is RPN, there is no operator precedence. -data Operator a = - Unary (a -> a) - -- ^ Unary operators take only one operand (for example, a factorial - -- operator). - - | Binary (a -> a -> a) - -- ^ Binary operators take two operands (for example, an addition - -- operator). - -instance Show (Operator a) where - show (Unary _) = "" - show (Binary _) = "" - --- | A token is either an operator or an operand. -data Token a = - TokOperand (Operand a) - | TokOperator (Operator a) - deriving Show - - --- | Given an operator, and the stack of operands, process the --- operator. When parsing an RPN expression, encountering an operator --- at the front of the queue of tokens to be processed means that the --- correct number of tokens (one, for a unary operator, or two, for a --- binary operator) must be popped off the stack of operands. The --- operator is then applied to the operands. For a binary operator, --- the binary function is applied first to the operand that was lowest --- on the stack, and then to the operand that was higher up on the --- stack. The result of the operator is then pushed onto the top of --- the stack. --- --- This function fails if there were insufficient operands on the --- stack to process the operator. If successful, returns the new --- stack, with the processed operands removed and the result of the --- operator pushed onto the top of the stack. -processOperator :: - Operator a - -> [Operand a] - -> Maybe ([Operand a]) -processOperator t ds = case t of - (Unary f) -> case ds of - [] -> Nothing - (Operand x):xs -> return $ (Operand (f x)) : xs - (Binary f) -> case ds of - [] -> Nothing - (Operand x):dss -> case dss of - (Operand y):dsss -> - return $ (Operand (f y x)) : dsss - [] -> Nothing - --- | Adds an operand to the top of the stack. -processOperand :: - Operand a - -> [Operand a] - -> [Operand a] -processOperand = (:) - --- | Processes the next token. Fails if the next token is an operator --- and fails; otherwise, returns the new stack of operands. -processToken :: - [Operand a] - -> Token a - -> Maybe ([Operand a]) -processToken s tok = case tok of - TokOperand d -> return (processOperand d s) - TokOperator t -> processOperator t s - --- | Processes an entire input sequence of RPN tokens. -process :: - Fdbl.Foldable l - => l (Token a) - -- ^ The tokens must be in the sequence from left to right in - -- postfix order; for example, @5 4 -@ will yield @1@. Typically - -- many appends will be required in order to build this sequence. If - -- performance is a concern, you can use a Data.Sequence; if the - -- list is small (as these lists will typically be) a regular list - -- will do just fine. - - -> Maybe a - -- ^ Fails if there is not exactly one operand remaining on the - -- stack at the end of the parse, or if at any time there are - -- insufficient operands on the stack to parse an - -- operator. Otherwise, succeeds and returns the result. -process ls = do - os <- Fdbl.foldlM processToken [] ls - (top, rest) <- case os of - (Operand x) : oss -> return (x, oss) - _ -> Nothing - case rest of - [] -> return top - _ -> Nothing diff --git a/Penny/Lincoln.hs b/Penny/Lincoln.hs --- a/Penny/Lincoln.hs +++ b/Penny/Lincoln.hs @@ -47,6 +47,7 @@ , I.toZonedTime , I.fromZonedTime , I.sameInstant + , I.showDateTime -- ** Debits and credits , I.DrCr(Debit, Credit) @@ -212,9 +213,11 @@ , S.nSerials -- * Matchers - , Matchers.Matcher , Matchers.Factory + -- * Showing postFam in one line + , display + ) where import qualified Penny.Lincoln.Balance as B @@ -226,3 +229,44 @@ import qualified Penny.Lincoln.PriceDb as DB import qualified Penny.Lincoln.Serial as S import qualified Penny.Lincoln.Transaction as T + +import Data.List (intersperse) +import Data.Text (Text) +import qualified Data.Text as X +import qualified Penny.Lincoln.Queries as Q +import qualified Data.Time as Time +import System.Locale (defaultTimeLocale) + +-- +-- Display +-- + +-- | Displays a PostFam in a one line format. +-- +-- Format: +-- +-- File LineNo Date Payee Acct DrCr Cmdty Qty +display :: T.PostFam -> Text +display p = X.pack $ concat (intersperse " " ls) + where + ls = [file, lineNo, dt, pye, acct, dc, cmdty, qt] + file = maybe (labelNo "filename") (X.unpack . I.unFilename) + (Q.filename p) + lineNo = maybe (labelNo "line number") + (show . I.unPostingLine) (Q.postingLine p) + dateFormat = "%Y-%m-%d %T %z" + dt = Time.formatTime defaultTimeLocale dateFormat + . Time.utctDay + . I.toUTC + . Q.dateTime + $ p + pye = maybe (labelNo "payee") + (X.unpack . HT.text) (Q.payee p) + acct = X.unpack . X.intercalate (X.singleton ':') + . map I.unSubAccount . I.unAccount . Q.account $ p + dc = case Q.drCr p of + I.Debit -> "Dr" + I.Credit -> "Cr" + cmdty = X.unpack . I.unCommodity . Q.commodity $ p + qt = show . Q.qty $ p + labelNo s = "(no " ++ s ++ ")" diff --git a/Penny/Lincoln/Bits.hs b/Penny/Lincoln/Bits.hs --- a/Penny/Lincoln/Bits.hs +++ b/Penny/Lincoln/Bits.hs @@ -30,6 +30,7 @@ DT.toZonedTime, DT.fromZonedTime, DT.sameInstant, + DT.showDateTime, -- * Debits and Credits O.DrCr(Debit, Credit), diff --git a/Penny/Lincoln/Bits/DateTime.hs b/Penny/Lincoln/Bits/DateTime.hs --- a/Penny/Lincoln/Bits/DateTime.hs +++ b/Penny/Lincoln/Bits/DateTime.hs @@ -18,6 +18,7 @@ , toZonedTime , fromZonedTime , sameInstant + , showDateTime ) where import qualified Data.Time as T @@ -132,4 +133,20 @@ sameInstant :: DateTime -> DateTime -> Bool sameInstant t1 t2 = toUTC t1 == toUTC t2 + +-- | Shows a DateTime in a pretty way. +showDateTime :: DateTime -> String +showDateTime (DateTime d h m s tz) = + ds ++ " " ++ hmss ++ " " ++ showOffset + where + ds = show d + hmss = hs ++ ":" ++ ms ++ ":" ++ ss + hs = pad0 . show . unHours $ h + ms = pad0 . show . unMinutes $ m + ss = pad0 . show . unSeconds $ s + pad0 str = if length str < 2 then '0':str else str + showOffset = + let (zoneHr, zoneMin) = abs (offsetToMins tz) `divMod` 60 + sign = if offsetToMins tz < 0 then "-" else "+" + in sign ++ pad0 (show zoneHr) ++ pad0 (show zoneMin) diff --git a/Penny/Lincoln/Builders.hs b/Penny/Lincoln/Builders.hs --- a/Penny/Lincoln/Builders.hs +++ b/Penny/Lincoln/Builders.hs @@ -15,15 +15,14 @@ ( account ) where -import qualified Data.List.Split as S import qualified Penny.Lincoln.Bits as B -import Data.Text (pack) +import qualified Data.Text as X --- | Create an Account. You supply a single String, with colons to +-- | Create an Account. You supply a single Text, with colons to -- separate the different sub-accounts. -account :: String -> B.Account +account :: X.Text -> B.Account account s = - if null s + if X.null s then B.Account [] - else B.Account . map B.SubAccount . map pack . S.splitOn ":" $ s + else B.Account . map B.SubAccount . X.splitOn (X.singleton ':') $ s diff --git a/Penny/Lincoln/Matchers.hs b/Penny/Lincoln/Matchers.hs --- a/Penny/Lincoln/Matchers.hs +++ b/Penny/Lincoln/Matchers.hs @@ -4,9 +4,7 @@ import qualified Data.Text as X import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Text.Matchers.Text as MT - -type Matcher = X.Text -> Bool +import qualified Text.Matchers as MT -- | A function that makes Matchers. type Factory @@ -17,7 +15,7 @@ -- ^ The pattern to use when testing for a match. For example, this -- might be a regular expression, or simply the text to be matched. - -> Ex.Exceptional X.Text Matcher + -> Ex.Exceptional X.Text MT.Matcher -- ^ Sometimes producing a matcher might fail; for example, the user -- might have supplied a bad pattern. If so, an exception is -- returned. On success, a Matcher is returned. diff --git a/Penny/Lincoln/NestedMap.hs b/Penny/Lincoln/NestedMap.hs deleted file mode 100644 --- a/Penny/Lincoln/NestedMap.hs +++ /dev/null @@ -1,275 +0,0 @@ --- | A nested map. The values in each NestedMap are tuples, with the --- first element of the tuple being a label that you select and the --- second value being another NestedMap. Functions are provided so you --- may query the map at any level or insert new labels (and, --- therefore, new keys) at any level. -module Penny.Lincoln.NestedMap ( - NestedMap ( NestedMap, unNestedMap ), - empty, - relabel, - descend, - insert, - cumulativeTotal, - traverse, - traverseWithTrail, - toForest ) where - -import Control.Applicative ((<*>), (<$>)) -import Data.Map ( Map ) -import qualified Data.Foldable as F -import qualified Data.Traversable as T -import qualified Data.Tree as E -import qualified Data.Map as M -import Data.Monoid ( Monoid, mconcat, mappend, mempty ) - -newtype NestedMap k l = - NestedMap { unNestedMap :: Map k (l, NestedMap k l) } - deriving (Eq, Show, Ord) - -instance Functor (NestedMap k) where - fmap f (NestedMap m) = let - g (l, s) = (f l, fmap f s) - in NestedMap $ M.map g m - -instance (Ord k) => F.Foldable (NestedMap k) where - foldMap = T.foldMapDefault - -instance (Ord k) => T.Traversable (NestedMap k) where - -- traverse :: Applicative f - -- => (a -> f b) - -- -> NestedMap k a - -- -> f (NestedMap k b) - traverse f (NestedMap m) = let - f' (l, m') = (,) <$> f l <*> T.traverse f m' - in NestedMap <$> T.traverse f' m - --- | An empty NestedMap. -empty :: NestedMap k l -empty = NestedMap (M.empty) - --- | Helper function for relabel. For a given key and function --- that modifies the label, return the new submap to insert into the --- given map. Does not actually insert the submap though. That way, --- relabel can then modify the returned submap before --- inserting it into the mother map with the given label. -newSubmap :: - (Ord k) - => NestedMap k l - -> k - -> (Maybe l -> l) - -> (l, NestedMap k l) -newSubmap (NestedMap m) k g = (newL, NestedMap newM) where - (newL, newM) = case M.lookup k m of - Nothing -> (g Nothing, M.empty) - (Just (oldL, (NestedMap oldM))) -> (g (Just oldL), oldM) - --- | Descends through a NestedMap with successive keys in the list, --- proceeding from left to right. At any given level, if the key --- given does not already exist, then inserts an empty submap and --- applies the given label modification function to Nothing to --- determine the new label. If the given key already does exist, then --- preserves the existing submap and applies the given label --- modification function to (Just oldlabel) to determine the new --- label. -relabel :: - (Ord k) - => NestedMap k l - -> [(k, (Maybe l -> l))] - -> NestedMap k l -relabel m [] = m -relabel (NestedMap m) ((k, f):vs) = let - (newL, newM) = newSubmap (NestedMap m) k f - newM' = relabel newM vs - in NestedMap $ M.insert k (newL, newM') m - --- | Given a list of keys, find the key that is furthest down in the --- map that matches the requested list of keys. Returns [(k, l)], --- where the first item in the list is the topmost key found and its --- matching label, and the last item in the list is the deepest key --- found and its matching label. (Often you will be most interested --- in the deepest key.) -descend :: - Ord k - => [k] - -> NestedMap k l - -> [(k, l)] -descend keys (NestedMap mi) = descend' keys mi where - descend' [] _ = [] - descend' (k:ks) m = case M.lookup k m of - Nothing -> [] - Just (l, (NestedMap im)) -> (k, l) : descend' ks im - - --- | Descends through the NestedMap one level at a time, proceeding --- key by key from left to right through the list of keys given. At --- the last key, appends the given label to the labels already --- present; if no label is present, uses mempty and mappend to create --- a new label. If the list of keys is empty, does nothing. -insert :: - (Ord k, Monoid l) - => NestedMap k l - -> [k] - -> l - -> NestedMap k l -insert m [] _ = m -insert m ks l = relabel m ts where - ts = firsts ++ [end] - firsts = map (\k -> (k, keepOld)) (init ks) where - keepOld mk = case mk of - (Just old) -> old - Nothing -> mempty - end = (key, newL) where - key = last ks - newL mk = case mk of - (Just old) -> old `mappend` l - Nothing -> mempty `mappend` l - -totalMap :: - (Monoid l) - => NestedMap k l - -> l -totalMap (NestedMap m) = - if M.null m - then mempty - else mconcat . map totalTuple . M.elems $ m - -totalTuple :: - (Monoid l) - => (l, NestedMap k l) - -> l -totalTuple (l, (NestedMap top)) = - if M.null top - then l - else mappend l (totalMap (NestedMap top)) - -remapWithTotals :: - (Monoid l) - => NestedMap k l - -> NestedMap k l -remapWithTotals (NestedMap top) = - if M.null top - then NestedMap M.empty - else NestedMap $ M.map f top where - f a@(_, m) = (totalTuple a, remapWithTotals m) - --- | Leaves all keys of the map and submaps the same. Changes each --- label to reflect the total of that label and of all the labels of --- the maps within the NestedMap accompanying the label. Returns the --- total of the entire NestedMap. -cumulativeTotal :: - (Monoid l) - => NestedMap k l - -> (l, NestedMap k l) -cumulativeTotal m = (totalMap m, remapWithTotals m) - --- | Supply a function that takes a key, a label, and a --- NestedMap. traverse will traverse the NestedMap. For each (label, --- NestedMap) pair, traverse will first apply the given function to --- the label before descending through the NestedMap. The function is --- applied to the present key and label and the accompanying --- NestedMap. The function you supply must return a Maybe. If the --- result is Nothing, then the pair is deleted as a value from its --- parent NestedMap. If the result is (Just s), then the label of this --- level of the NestedMap is changed to s before descending to the --- next level of the NestedMap. --- --- All this is done in a monad, so you can carry out arbitrary side --- effects such as inspecting or changing a state or doing IO. If you --- don't need a monad, just use Identity. --- --- Thus this function can be used to inspect, modify, and prune a --- NestedMap. --- --- For a simpler traverse that does not provide you with so much --- information, NestedMap is also an instance of Data.Traversable. -traverse :: - (Monad m, Ord k) - => (k -> l -> NestedMap k l -> m (Maybe a)) - -> NestedMap k l - -> m (NestedMap k a) -traverse f m = traverseWithTrail (\_ -> f) m - --- | Like traverse, but the supplied function is also applied to a --- list that tells it about the levels of NestedMap that are parents --- to this NestedMap. -traverseWithTrail :: - (Monad m, Ord k) - => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) ) - -> NestedMap k l - -> m (NestedMap k a) -traverseWithTrail f = traverseWithTrail' f [] - -traverseWithTrail' :: - (Monad m, Ord k) - => ([(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a)) - -> [(k, l)] - -> NestedMap k l - -> m (NestedMap k a) -traverseWithTrail' f ts (NestedMap m) = - if M.null m - then return $ NestedMap M.empty - else do - let ps = M.assocs m - mlsMaybes <- mapM (traversePairWithTrail f ts) ps - let ps' = zip (M.keys m) mlsMaybes - folder (k, ma) rs = case ma of - (Just r) -> (k, r):rs - Nothing -> rs - ps'' = foldr folder [] ps' - return (NestedMap (M.fromList ps'')) - -traversePairWithTrail :: - (Monad m, Ord k) - => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) ) - -> [(k, l)] - -> (k, (l, NestedMap k l)) - -> m (Maybe (a, NestedMap k a)) -traversePairWithTrail f ls (k, (l, m)) = do - ma <- f ls k l m - case ma of - Nothing -> return Nothing - (Just a) -> do - m' <- traverseWithTrail' f ((k, l):ls) m - return (Just (a, m')) - --- | Convert a NestedMap to a Forest. -toForest :: Ord k => NestedMap k l -> E.Forest (k, l) -toForest = map toNode . M.assocs . unNestedMap - where - toNode (k, (l, m)) = E.Node (k, l) (toForest m) - --- For testing -_new :: (k, l) -> (k, (Maybe l -> l)) -_new (k, l) = (k, const l) - -_map1, _map2, _map3, _map4 :: NestedMap Int String -_map1 = NestedMap M.empty -_map2 = relabel _map1 [_new (5, "hello"), _new (66, "goodbye"), _new (777, "yeah")] -_map3 = relabel _map2 [_new (6, "what"), _new (77, "zeke"), _new (888, "foo")] -_map4 = relabel _map3 - [ (6, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "_new")) - , (77, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "more _new")) ] - -_printer :: Int -> String -> a -> IO (Maybe ()) -_printer i s _ = do - putStrLn (show i) - putStrLn s - return $ Just () - -_printerWithTrail :: [(Int, String)] -> Int -> String -> a -> IO (Maybe ()) -_printerWithTrail ps n str _ = do - let ptr (i, s) = putStr ("(" ++ show i ++ ", " ++ s ++ ") ") - mapM_ ptr . reverse $ ps - ptr (n, str) - putStrLn "" - return $ Just () - -_showMap4 :: IO () -_showMap4 = do - _ <- traverse _printer _map4 - return () - -_showMapWithTrail :: IO () -_showMapWithTrail = do - _ <- traverseWithTrail _printerWithTrail _map4 - return () diff --git a/Penny/Lincoln/Predicates.hs b/Penny/Lincoln/Predicates.hs --- a/Penny/Lincoln/Predicates.hs +++ b/Penny/Lincoln/Predicates.hs @@ -1,155 +1,247 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | Functions that return a boolean based upon some criterion that -- matches something, often a PostFam. Useful when filtering -- Postings. -module Penny.Lincoln.Predicates where +module Penny.Lincoln.Predicates + ( LPdct + , MakePdct + , payee + , number + , flag + , postingMemo + , transactionMemo + , Comp(..) + , descComp + , date + , qty + , drCr + , debit + , credit + , commodity + , account + , accountLevel + , accountAny + , tag + , reconciled + , clonedTransactions + , clonedTopLines + , clonedPostings + ) where import Data.List (intersperse) +import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as X -import Data.Time (Day) +import qualified Data.Time as Time import qualified Penny.Lincoln.Bits as B import Penny.Lincoln.HasText (HasText, text, HasTextList, textList) import qualified Penny.Lincoln.Family.Family as F import qualified Penny.Lincoln.Queries as Q import Penny.Lincoln.Transaction (PostFam) import qualified Penny.Lincoln.Transaction as T +import qualified Text.Matchers as M +import qualified Penny.Steel.Pdct as P --- * Matching helpers +type LPdct = P.Pdct PostFam -match :: HasText a => (Text -> Bool) -> a -> Bool -match f = f . text +type MakePdct = M.Matcher -> LPdct -matchMaybe :: HasText a => (Text -> Bool) -> Maybe a -> Bool -matchMaybe f = maybe False (match f) +-- * Matching helpers +match + :: HasText a + => Text + -- ^ Description of this field + -> (PostFam -> a) + -- ^ Function that returns the field being matched + -> M.Matcher + -> LPdct +match t f m = P.operand desc pd + where + desc = makeDesc t m + pd = M.match m . text . f +matchMaybe + :: HasText a + => Text + -- ^ Description of this field + -> (PostFam -> Maybe a) + -> M.Matcher + -> LPdct +matchMaybe t f m = P.operand desc pd + where + desc = makeDesc t m + pd = maybe False (M.match m . text) . f +makeDesc :: Text -> M.Matcher -> Text +makeDesc t m + = "subject: " <> t + <> " matcher: " <> M.matchDesc m + -- | Does the given matcher match any of the elements of the Texts in -- a HasTextList? -matchAny :: HasTextList a => (Text -> Bool) -> a -> Bool -matchAny f = any f . textList - -matchAnyMaybe :: HasTextList a => (Text -> Bool) -> Maybe a -> Bool -matchAnyMaybe f = maybe False (matchAny f) - +matchAny + :: HasTextList a + => Text + -> (PostFam -> a) + -> M.Matcher + -> LPdct +matchAny t f m = P.operand desc pd + where + desc = makeDesc t m + pd = any (M.match m) . textList . f -- | Does the given matcher match the text that is at the given -- element of a HasTextList? If the HasTextList does not have a -- sufficent number of elements to perform this test, returns False. -matchLevel :: HasTextList a => Int -> (Text -> Bool) -> a -> Bool -matchLevel i f a = let ts = textList a in - if i < 0 || i >= length ts - then False - else f (ts !! i) +matchLevel + :: HasTextList a + => Int + -> Text + -> (PostFam -> a) + -> M.Matcher + -> LPdct +matchLevel l d f m = P.operand desc pd + where + desc = makeDesc ("level " <> X.pack (show l) <> " of " <> d) m + pd pf = let ts = textList (f pf) + in if l < 0 || l >= length ts + then False + else M.match m (ts !! l) -- | Does the matcher match the text of the memo? Joins each line of -- the memo with a space. -matchMemo :: (Text -> Bool) -> Maybe B.Memo -> Bool -matchMemo f = maybe False (f . X.intercalate (X.singleton ' ') . B.unMemo) - - -matchMaybeLevel :: - HasTextList a - => Int - -> (Text -> Bool) - -> Maybe a - -> Bool -matchMaybeLevel i f = maybe False (matchLevel i f) +matchMemo + :: Text + -> (PostFam -> Maybe B.Memo) + -> M.Matcher + -> LPdct +matchMemo t f m = P.operand desc pd + where + desc = makeDesc t m + pd = maybe False doMatch . f + doMatch = M.match m + . X.intercalate (X.singleton ' ') + . B.unMemo +matchDelimited + :: HasTextList a + => Text + -- ^ Separator + -> Text + -- ^ Label + -> (PostFam -> a) + -> M.Matcher + -> LPdct +matchDelimited sep lbl f m = match lbl f' m + where + f' = X.concat . intersperse sep . textList . f -- * Pattern matching fields -payee :: (Text -> Bool) -> PostFam -> Bool -payee f = matchMaybe f . Q.payee +payee :: MakePdct +payee = matchMaybe "payee" Q.payee -number :: (Text -> Bool) -> PostFam -> Bool -number f = matchMaybe f . Q.number +number :: MakePdct +number = matchMaybe "number" Q.number -flag :: (Text -> Bool) -> PostFam -> Bool -flag f = matchMaybe f . Q.flag +flag :: MakePdct +flag = matchMaybe "flag" Q.flag -postingMemo :: (Text -> Bool) -> PostFam -> Bool -postingMemo f = matchMemo f . Q.postingMemo +postingMemo :: MakePdct +postingMemo = matchMemo "posting memo" Q.postingMemo -transactionMemo :: (Text -> Bool) -> PostFam -> Bool -transactionMemo f = matchMemo f . Q.transactionMemo +transactionMemo :: MakePdct +transactionMemo = matchMemo "transaction memo" Q.transactionMemo -- * Date -date :: - (B.DateTime -> Bool) - -> PostFam - -> Bool -date f c = f (Q.dateTime c) - - -localDay :: - (Day -> Bool) - -> PostFam - -> Bool -localDay f = f . Q.localDay - --- * Qty - -qty :: - (B.Qty -> Bool) - -> PostFam - -> Bool -qty f c = f (Q.qty c) - +-- | Comparisons. +data Comp + = DLT + -- ^ Less than --- * DrCr -drCr :: B.DrCr -> PostFam -> Bool -drCr dc p = dc == Q.drCr p + | DLTEQ + -- ^ Less than or equal to -debit :: PostFam -> Bool -debit p = Q.drCr p == B.Debit + | DEQ + -- ^ Equal to -credit :: PostFam -> Bool -credit p = Q.drCr p == B.Credit + | DGTEQ + -- ^ Greater than or equal to --- * Matching delimited fields + | DGT + -- ^ Greater than -matchDelimited :: - HasTextList a - => Text - -> (Text -> Bool) - -> a -> Bool -matchDelimited d f = f . X.concat . intersperse d . textList + | DNE + -- ^ Not equal to + deriving Eq --- * Commodity +-- | Describes a Comp, and returns a function to actually perform +-- comparisons. +descComp :: Ord a => Comp -> (Text, a -> a -> Bool) +descComp c = case c of + DLT -> ("less than", (<)) + DLTEQ -> ("less than or equal to", (<=)) + DEQ -> ("equal to", (==)) + DGTEQ -> ("greater than or equal to", (>=)) + DGT -> ("greater than", (>)) + DNE -> ("not equal to", (/=)) -commodity :: (Text -> Bool) -> PostFam -> Bool -commodity f = f . text . Q.commodity +date + :: Comp + -> Time.UTCTime + -> LPdct +date c d = P.operand desc pd + where + desc = "UTC date is " <> dd <> " " <> X.pack (show d) + (dd, cmp) = descComp c + pd pf = (B.toUTC . Q.dateTime $ pf) `cmp` d --- * Account -account :: Text -> (Text -> Bool) -> PostFam -> Bool -account t f = matchDelimited t f . Q.account +qty :: Comp -> B.Qty -> LPdct +qty c q = P.operand desc pd + where + desc = "quantity is " <> dd <> " " <> X.pack (show q) + (dd, cmp) = descComp c + pd pf = (Q.qty pf) `cmp` q -accountLevel :: Int -> (Text -> Bool) -> PostFam -> Bool -accountLevel i f = matchLevel i f . Q.account +drCr :: B.DrCr -> LPdct +drCr dc = P.operand desc pd + where + desc = "entry is a " <> s + s = case dc of { B.Debit -> "debit"; B.Credit -> "credit" } + pd pf = Q.drCr pf == dc -accountAny :: (Text -> Bool) -> PostFam -> Bool -accountAny f = matchAny f . Q.account +debit :: LPdct +debit = drCr B.Debit --- * Tags -tag :: (Text -> Bool) -> PostFam -> Bool -tag f = matchAny f . Q.tags +credit :: LPdct +credit = drCr B.Credit --- * Combining predicates -(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) -(&&&) l r = \a -> l a && r a +commodity :: M.Matcher -> LPdct +commodity = match "commodity" Q.commodity -infixr 3 &&& +account :: M.Matcher -> LPdct +account = matchDelimited ":" "account" Q.account -(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) -(|||) l r = \a -> l a || r a +accountLevel :: Int -> M.Matcher -> LPdct +accountLevel i = matchLevel i "account" Q.account -infixr 2 ||| +accountAny :: M.Matcher -> LPdct +accountAny = matchAny "any sub-account" Q.account +tag :: M.Matcher -> LPdct +tag = matchAny "any tag" Q.tags --- * Clones +-- | True if a posting is reconciled; that is, its flag is exactly +-- @R@. +reconciled :: LPdct +reconciled = P.operand d p + where + d = "posting flag is exactly \"R\" (is reconciled)" + p = maybe False ((== X.singleton 'R') . B.unFlag) . Q.flag -- | Returns True if these two transactions are clones; that is, if -- they are identical in all respects except some aspects of their @@ -193,3 +285,4 @@ && (T.pEntry p1 == T.pEntry p2) && (T.pMemo p1 == T.pMemo p2) && (T.pInferred p1 == T.pInferred p2) + diff --git a/Penny/Lincoln/Transaction.hs b/Penny/Lincoln/Transaction.hs --- a/Penny/Lincoln/Transaction.hs +++ b/Penny/Lincoln/Transaction.hs @@ -496,3 +496,4 @@ ps' = zipWith applyPostingChange (cps ++ repeat emptyPostingChangeData) ps in Transaction (F.Family tl' p1' p2' ps') + diff --git a/Penny/Shield.hs b/Penny/Shield.hs --- a/Penny/Shield.hs +++ b/Penny/Shield.hs @@ -14,8 +14,6 @@ ScreenWidth, unScreenWidth, Output(IsTTY, NotTTY), - Term, - unTerm, Runtime, environment, currentTime, @@ -23,13 +21,16 @@ screenLines, screenWidth, term, - runtime) + runtime, + termFromEnv, + autoTerm) where import Control.Applicative ((<$>), (<*>)) import qualified Data.Time as T import System.Environment (getEnvironment) import System.IO (hIsTerminalDevice, stdout) +import qualified Penny.Steel.Chunk as C import qualified Penny.Lincoln.Bits as B @@ -39,7 +40,7 @@ newtype ScreenWidth = ScreenWidth { unScreenWidth :: Int } deriving Show -data Output = IsTTY | NotTTY +data Output = IsTTY | NotTTY deriving (Eq, Ord, Show) newtype Term = Term { unTerm :: String } deriving Show @@ -85,3 +86,20 @@ safeRead s = case reads s of (a, []):[] -> Just a _ -> Nothing + +-- | Determines which Chunk Term to use based on the TERM environment +-- variable, regardless of whether standard output is a terminal. Uses +-- Dumb if TERM is not set. +termFromEnv :: Runtime -> C.Term +termFromEnv rt = case term rt of + Just t -> C.TermName . unTerm $ t + Nothing -> C.Dumb + +-- | Determines which Chunk Term to use based on whether standard +-- output is a terminal. Uses Dumb if standard output is not a +-- terminal; otherwise, uses the TERM environment variable. +autoTerm :: Runtime -> C.Term +autoTerm rt = case output rt of + IsTTY -> termFromEnv rt + NotTTY -> C.Dumb + diff --git a/Penny/Steel.hs b/Penny/Steel.hs new file mode 100644 --- /dev/null +++ b/Penny/Steel.hs @@ -0,0 +1,3 @@ +-- | Steel - independent Penny utilities + +module Penny.Steel where diff --git a/Penny/Steel/Chunk.hs b/Penny/Steel/Chunk.hs new file mode 100644 --- /dev/null +++ b/Penny/Steel/Chunk.hs @@ -0,0 +1,2452 @@ +-- | Handles colors and special effects for text. Internally this +-- module uses the Haskell terminfo library, which links against the +-- UNIX library of the same name, so it should work with a wide +-- variety of UNIX terminals. This module is a layer between terminfo +-- and the rest of Penny, allowing the Chunk internals to be swapped +-- out and replaced. (I know this because this module previously used +-- a home-grown implementation written based on the Xterm +-- configuration; that implementation was swapped out and replaced +-- with terminfo with minimal disruption.) +-- +-- However, terminfo is a UNIX thing, so at this time Penny probably +-- would not work on a Windows based system. +-- +-- There is an ansi-terminal library on Hackage, which does support +-- Windows. One problem with that though is that ansi-terminal does +-- not appear to support more than 8 colors; Chunk supports 256 +-- colors, which is very helpful for Penny. +module Penny.Steel.Chunk ( + -- * Colors + Term(..), + Background8, + Background256, + Foreground8, + Foreground256, + + -- * Chunks + Chunk (chunkTextSpec, chunkText), + chunk, + Width(Width, unWidth), + chunkWidth, + printChunks, + + -- * Effects + Bold(Bold, unBold), + Underline(Underline, unUnderline), + Flash(Flash, unFlash), + Inverse(Inverse, unInverse), + + -- * Style and TextSpec + + -- | A style is a bundle of attributes that describes text + -- attributes, such as its color and whether it is bold. + StyleCommon (StyleCommon, bold, underline, flash, inverse), + Style8 (Style8, foreground8, background8, common8), + Style256 (Style256, foreground256, background256, common256), + defaultStyleCommon, + defaultStyle8, + defaultStyle256, + + TextSpec (TextSpec, style8, style256), + defaultTextSpec, + + -- * Specific colors + -- * 8 color foreground colors + color8_f_default, + color8_f_black, + color8_f_red, + color8_f_green, + color8_f_yellow, + color8_f_blue, + color8_f_magenta, + color8_f_cyan, + color8_f_white, + + -- ** 8 color background colors + color8_b_default, + color8_b_black, + color8_b_red, + color8_b_green, + color8_b_yellow, + color8_b_blue, + color8_b_magenta, + color8_b_cyan, + color8_b_white, + + -- * 256 color foreground colors + color256_f_default, + color256_f_0, + color256_f_1, + color256_f_2, + color256_f_3, + color256_f_4, + color256_f_5, + color256_f_6, + color256_f_7, + color256_f_8, + color256_f_9, + color256_f_10, + color256_f_11, + color256_f_12, + color256_f_13, + color256_f_14, + color256_f_15, + color256_f_16, + color256_f_17, + color256_f_18, + color256_f_19, + color256_f_20, + color256_f_21, + color256_f_22, + color256_f_23, + color256_f_24, + color256_f_25, + color256_f_26, + color256_f_27, + color256_f_28, + color256_f_29, + color256_f_30, + color256_f_31, + color256_f_32, + color256_f_33, + color256_f_34, + color256_f_35, + color256_f_36, + color256_f_37, + color256_f_38, + color256_f_39, + color256_f_40, + color256_f_41, + color256_f_42, + color256_f_43, + color256_f_44, + color256_f_45, + color256_f_46, + color256_f_47, + color256_f_48, + color256_f_49, + color256_f_50, + color256_f_51, + color256_f_52, + color256_f_53, + color256_f_54, + color256_f_55, + color256_f_56, + color256_f_57, + color256_f_58, + color256_f_59, + color256_f_60, + color256_f_61, + color256_f_62, + color256_f_63, + color256_f_64, + color256_f_65, + color256_f_66, + color256_f_67, + color256_f_68, + color256_f_69, + color256_f_70, + color256_f_71, + color256_f_72, + color256_f_73, + color256_f_74, + color256_f_75, + color256_f_76, + color256_f_77, + color256_f_78, + color256_f_79, + color256_f_80, + color256_f_81, + color256_f_82, + color256_f_83, + color256_f_84, + color256_f_85, + color256_f_86, + color256_f_87, + color256_f_88, + color256_f_89, + color256_f_90, + color256_f_91, + color256_f_92, + color256_f_93, + color256_f_94, + color256_f_95, + color256_f_96, + color256_f_97, + color256_f_98, + color256_f_99, + color256_f_100, + color256_f_101, + color256_f_102, + color256_f_103, + color256_f_104, + color256_f_105, + color256_f_106, + color256_f_107, + color256_f_108, + color256_f_109, + color256_f_110, + color256_f_111, + color256_f_112, + color256_f_113, + color256_f_114, + color256_f_115, + color256_f_116, + color256_f_117, + color256_f_118, + color256_f_119, + color256_f_120, + color256_f_121, + color256_f_122, + color256_f_123, + color256_f_124, + color256_f_125, + color256_f_126, + color256_f_127, + color256_f_128, + color256_f_129, + color256_f_130, + color256_f_131, + color256_f_132, + color256_f_133, + color256_f_134, + color256_f_135, + color256_f_136, + color256_f_137, + color256_f_138, + color256_f_139, + color256_f_140, + color256_f_141, + color256_f_142, + color256_f_143, + color256_f_144, + color256_f_145, + color256_f_146, + color256_f_147, + color256_f_148, + color256_f_149, + color256_f_150, + color256_f_151, + color256_f_152, + color256_f_153, + color256_f_154, + color256_f_155, + color256_f_156, + color256_f_157, + color256_f_158, + color256_f_159, + color256_f_160, + color256_f_161, + color256_f_162, + color256_f_163, + color256_f_164, + color256_f_165, + color256_f_166, + color256_f_167, + color256_f_168, + color256_f_169, + color256_f_170, + color256_f_171, + color256_f_172, + color256_f_173, + color256_f_174, + color256_f_175, + color256_f_176, + color256_f_177, + color256_f_178, + color256_f_179, + color256_f_180, + color256_f_181, + color256_f_182, + color256_f_183, + color256_f_184, + color256_f_185, + color256_f_186, + color256_f_187, + color256_f_188, + color256_f_189, + color256_f_190, + color256_f_191, + color256_f_192, + color256_f_193, + color256_f_194, + color256_f_195, + color256_f_196, + color256_f_197, + color256_f_198, + color256_f_199, + color256_f_200, + color256_f_201, + color256_f_202, + color256_f_203, + color256_f_204, + color256_f_205, + color256_f_206, + color256_f_207, + color256_f_208, + color256_f_209, + color256_f_210, + color256_f_211, + color256_f_212, + color256_f_213, + color256_f_214, + color256_f_215, + color256_f_216, + color256_f_217, + color256_f_218, + color256_f_219, + color256_f_220, + color256_f_221, + color256_f_222, + color256_f_223, + color256_f_224, + color256_f_225, + color256_f_226, + color256_f_227, + color256_f_228, + color256_f_229, + color256_f_230, + color256_f_231, + color256_f_232, + color256_f_233, + color256_f_234, + color256_f_235, + color256_f_236, + color256_f_237, + color256_f_238, + color256_f_239, + color256_f_240, + color256_f_241, + color256_f_242, + color256_f_243, + color256_f_244, + color256_f_245, + color256_f_246, + color256_f_247, + color256_f_248, + color256_f_249, + color256_f_250, + color256_f_251, + color256_f_252, + color256_f_253, + color256_f_254, + color256_f_255, + + -- ** 256 color background colors + color256_b_default, + color256_b_0, + color256_b_1, + color256_b_2, + color256_b_3, + color256_b_4, + color256_b_5, + color256_b_6, + color256_b_7, + color256_b_8, + color256_b_9, + color256_b_10, + color256_b_11, + color256_b_12, + color256_b_13, + color256_b_14, + color256_b_15, + color256_b_16, + color256_b_17, + color256_b_18, + color256_b_19, + color256_b_20, + color256_b_21, + color256_b_22, + color256_b_23, + color256_b_24, + color256_b_25, + color256_b_26, + color256_b_27, + color256_b_28, + color256_b_29, + color256_b_30, + color256_b_31, + color256_b_32, + color256_b_33, + color256_b_34, + color256_b_35, + color256_b_36, + color256_b_37, + color256_b_38, + color256_b_39, + color256_b_40, + color256_b_41, + color256_b_42, + color256_b_43, + color256_b_44, + color256_b_45, + color256_b_46, + color256_b_47, + color256_b_48, + color256_b_49, + color256_b_50, + color256_b_51, + color256_b_52, + color256_b_53, + color256_b_54, + color256_b_55, + color256_b_56, + color256_b_57, + color256_b_58, + color256_b_59, + color256_b_60, + color256_b_61, + color256_b_62, + color256_b_63, + color256_b_64, + color256_b_65, + color256_b_66, + color256_b_67, + color256_b_68, + color256_b_69, + color256_b_70, + color256_b_71, + color256_b_72, + color256_b_73, + color256_b_74, + color256_b_75, + color256_b_76, + color256_b_77, + color256_b_78, + color256_b_79, + color256_b_80, + color256_b_81, + color256_b_82, + color256_b_83, + color256_b_84, + color256_b_85, + color256_b_86, + color256_b_87, + color256_b_88, + color256_b_89, + color256_b_90, + color256_b_91, + color256_b_92, + color256_b_93, + color256_b_94, + color256_b_95, + color256_b_96, + color256_b_97, + color256_b_98, + color256_b_99, + color256_b_100, + color256_b_101, + color256_b_102, + color256_b_103, + color256_b_104, + color256_b_105, + color256_b_106, + color256_b_107, + color256_b_108, + color256_b_109, + color256_b_110, + color256_b_111, + color256_b_112, + color256_b_113, + color256_b_114, + color256_b_115, + color256_b_116, + color256_b_117, + color256_b_118, + color256_b_119, + color256_b_120, + color256_b_121, + color256_b_122, + color256_b_123, + color256_b_124, + color256_b_125, + color256_b_126, + color256_b_127, + color256_b_128, + color256_b_129, + color256_b_130, + color256_b_131, + color256_b_132, + color256_b_133, + color256_b_134, + color256_b_135, + color256_b_136, + color256_b_137, + color256_b_138, + color256_b_139, + color256_b_140, + color256_b_141, + color256_b_142, + color256_b_143, + color256_b_144, + color256_b_145, + color256_b_146, + color256_b_147, + color256_b_148, + color256_b_149, + color256_b_150, + color256_b_151, + color256_b_152, + color256_b_153, + color256_b_154, + color256_b_155, + color256_b_156, + color256_b_157, + color256_b_158, + color256_b_159, + color256_b_160, + color256_b_161, + color256_b_162, + color256_b_163, + color256_b_164, + color256_b_165, + color256_b_166, + color256_b_167, + color256_b_168, + color256_b_169, + color256_b_170, + color256_b_171, + color256_b_172, + color256_b_173, + color256_b_174, + color256_b_175, + color256_b_176, + color256_b_177, + color256_b_178, + color256_b_179, + color256_b_180, + color256_b_181, + color256_b_182, + color256_b_183, + color256_b_184, + color256_b_185, + color256_b_186, + color256_b_187, + color256_b_188, + color256_b_189, + color256_b_190, + color256_b_191, + color256_b_192, + color256_b_193, + color256_b_194, + color256_b_195, + color256_b_196, + color256_b_197, + color256_b_198, + color256_b_199, + color256_b_200, + color256_b_201, + color256_b_202, + color256_b_203, + color256_b_204, + color256_b_205, + color256_b_206, + color256_b_207, + color256_b_208, + color256_b_209, + color256_b_210, + color256_b_211, + color256_b_212, + color256_b_213, + color256_b_214, + color256_b_215, + color256_b_216, + color256_b_217, + color256_b_218, + color256_b_219, + color256_b_220, + color256_b_221, + color256_b_222, + color256_b_223, + color256_b_224, + color256_b_225, + color256_b_226, + color256_b_227, + color256_b_228, + color256_b_229, + color256_b_230, + color256_b_231, + color256_b_232, + color256_b_233, + color256_b_234, + color256_b_235, + color256_b_236, + color256_b_237, + color256_b_238, + color256_b_239, + color256_b_240, + color256_b_241, + color256_b_242, + color256_b_243, + color256_b_244, + color256_b_245, + color256_b_246, + color256_b_247, + color256_b_248, + color256_b_249, + color256_b_250, + color256_b_251, + color256_b_252, + color256_b_253, + color256_b_254, + color256_b_255 + + ) where + + +import Data.Monoid (Monoid, mempty, mappend, mconcat) +import Data.Text (Text) +import Data.Maybe (fromMaybe) +import qualified Data.Text as X +import qualified System.Console.Terminfo as T + +-- +-- Colors +-- + +-- | Which terminal definition to use. +data Term + = Dumb + -- ^ Using this terminal should always succeed. This suppresses all + -- colors. Uesful if output is not going to a TTY, or if you just do + -- not like colors. + + | TermName String + -- ^ Use the terminal with this given name. You might get this from + -- the TERM environment variable, or set it explicitly. A runtime + -- error will result if the terminfo database does not have a + -- definition for this terminal. If this terminal supports 256 + -- colors, then 256 colors are used. If this terminal supports less + -- than 256 colors, but at least 8 colors, then 8 colors are + -- used. Otherwise, no colors are used. + deriving (Eq, Show) + + +-- For Background8, Background256, Foreground8, Foreground256: the +-- newtype wraps a Terminfo Color. If Nothing, use the default color. + +-- | Background color in an 8 color setting. +newtype Background8 = Background8 { unBackground8 :: Maybe T.Color } + deriving (Eq, Show, Ord) + +-- | Background color in a 256 color setting. +newtype Background256 = Background256 { unBackground256 :: Maybe T.Color } + deriving (Eq, Show, Ord) + +-- | Foreground color in an 8 color setting. +newtype Foreground8 = Foreground8 { unForeground8 :: Maybe T.Color } + deriving (Eq, Show, Ord) + +-- | Foreground color in a 256 color setting. +newtype Foreground256 = Foreground256 { unForeground256 :: Maybe T.Color } + deriving (Eq, Show, Ord) + + +-- +-- Chunks +-- + +-- | A chunk is some textual data coupled with a description of what +-- color the text is, attributes like whether it is bold or +-- underlined, etc. The chunk knows what foreground and background +-- colors and what attributes to use for both an 8 color terminal and +-- a 256 color terminal. To change these attributes and colors, you +-- must make a new chunk. +-- +-- There is no way to combine chunks. To print large numbers of +-- chunks, lazily build a list of them and then print them using +-- 'printChunks'. + +data Chunk = Chunk + { chunkTextSpec :: TextSpec + , chunkText :: Text + } deriving (Eq, Show, Ord) + +-- | Makes new Chunks. +chunk :: TextSpec -> Text -> Chunk +chunk = Chunk + +-- | How wide the text of a chunk is. +newtype Width = Width { unWidth :: Int } + deriving (Show, Eq, Ord) + +instance Monoid Width where + mempty = Width 0 + mappend (Width w1) (Width w2) = Width $ w1 + w2 + +chunkWidth :: Chunk -> Width +chunkWidth (Chunk _ t) = Width . X.length $ t + +-- | Sends a list of chunks to standard output for printing. Sets up +-- the terminal (this only needs to be done once.) Lazily processes +-- the list of Chunk. +printChunks :: Term -> [Chunk] -> IO () +printChunks t cs = do + let setup = case t of + Dumb -> T.setupTerm "dumb" + TermName s -> T.setupTerm s + term <- setup + mapM_ (printChunk term) cs + T.runTermOutput term (defaultColors term) + T.runTermOutput term + $ case T.getCapability term T.allAttributesOff of + Nothing -> error $ "Penny.Steel.Chunk.printChunks: error: " + ++ "allAttributesOff failed" + Just s -> s + +printChunk :: T.Terminal -> Chunk -> IO () +printChunk t (Chunk ts x) = + T.runTermOutput t + . mconcat + $ [defaultColors t, codes, txt] + where + codes = getTermCodes t ts + txt = T.termText . X.unpack $ x + +defaultColors :: T.Terminal -> T.TermOutput +defaultColors term = + fromMaybe mempty (T.getCapability term T.restoreDefaultColors) + +-- +-- Effects +-- +newtype Bold = Bold { unBold :: Bool } + deriving (Show, Eq, Ord) + +newtype Underline = Underline { unUnderline :: Bool } + deriving (Show, Eq, Ord) + +newtype Flash = Flash { unFlash :: Bool } + deriving (Show, Eq, Ord) + +newtype Inverse = Inverse { unInverse :: Bool } + deriving (Show, Eq, Ord) + +-- +-- Styles +-- + +-- | Style elements that apply in both 8 and 256 color +-- terminals. However, the elements are described separately for 8 and +-- 256 color terminals, so that the text appearance can change +-- depending on how many colors a terminal has. +data StyleCommon = StyleCommon + { bold :: Bold + , underline :: Underline + , flash :: Flash + , inverse :: Inverse + } deriving (Show, Eq, Ord) + +-- | Describes text appearance (foreground and background colors, as +-- well as other attributes such as bold) for an 8 color terminal. +data Style8 = Style8 + { foreground8 :: Foreground8 + , background8 :: Background8 + , common8 :: StyleCommon + } deriving (Show, Eq, Ord) + +-- | Describes text appearance (foreground and background colors, as +-- well as other attributes such as bold) for a 256 color terminal. +data Style256 = Style256 + { foreground256 :: Foreground256 + , background256 :: Background256 + , common256 :: StyleCommon + } deriving (Show, Eq, Ord) + +-- | Has all bold, flash, underline, and inverse turned off. +defaultStyleCommon :: StyleCommon +defaultStyleCommon = StyleCommon + { bold = Bold False + , underline = Underline False + , flash = Flash False + , inverse = Inverse False + } + +-- | Uses the default terminal colors (which will vary depending on +-- the terminal). +defaultStyle8 :: Style8 +defaultStyle8 = Style8 + { foreground8 = color8_f_default + , background8 = color8_b_default + , common8 = defaultStyleCommon + } + +-- | Uses the default terminal colors (which will vary depending on +-- the terminal). +defaultStyle256 :: Style256 +defaultStyle256 = Style256 + { foreground256 = color256_f_default + , background256 = color256_b_default + , common256 = defaultStyleCommon + } + +-- +-- TextSpec +-- + +-- | The TextSpec bundles together the styles for the 8 and 256 color +-- terminals, so that the text can be portrayed on any terminal. +data TextSpec = TextSpec + { style8 :: Style8 + , style256 :: Style256 + } deriving (Show, Eq, Ord) + +-- | A TextSpec with the default colors on 8 and 256 color terminals, +-- with all attributes turned off. +defaultTextSpec :: TextSpec +defaultTextSpec = TextSpec + { style8 = defaultStyle8 + , style256 = defaultStyle256 + } + +-- +-- Internal +-- + +commonAttrs :: T.Terminal -> StyleCommon -> T.TermOutput +commonAttrs t s = + let a = T.Attributes + { T.standoutAttr = False + , T.underlineAttr = unUnderline . underline $ s + , T.reverseAttr = unInverse . inverse $ s + , T.blinkAttr = unFlash . flash $ s + , T.dimAttr = False + , T.boldAttr = unBold . bold $ s + , T.invisibleAttr = False + , T.protectedAttr = False + } + in case T.getCapability t (T.setAttributes) of + Nothing -> error $ "Penny.Steel.Chunk: commonAttrs: " + ++ "capability failed; should never happen" + Just f -> f a + + +-- | Gets the right set of terminal codes to apply the desired +-- highlighting, bold, underlining, etc. Be sure to apply the +-- attributes first (bold, underlining, etc) and then the +-- colors. Setting the colors first and then the attributes seems to +-- reset the colors, giving blank output. +getTermCodes + :: T.Terminal + -> TextSpec + -> T.TermOutput +getTermCodes t ts = fromMaybe mempty $ do + cols <- T.getCapability t T.termColors + let TextSpec s8 s256 = ts + Style8 f8 b8 c8 = s8 + Style256 f256 b256 c256 = s256 + setFg <- T.getCapability t T.setForegroundColor + setBg <- T.getCapability t T.setBackgroundColor + (fg, bg, cm) <- case () of + _ | cols >= 256 -> Just $ ( unForeground256 f256 + , unBackground256 b256 + , c256 ) + | cols >= 8 -> Just ( unForeground8 f8 + , unBackground8 b8 + , c8) + | otherwise -> Nothing + let oFg = maybe mempty setFg fg + oBg = maybe mempty setBg bg + oCm = commonAttrs t cm + return $ mconcat [oCm, oFg, oBg] + + +-- +-- Color basement +-- +color8_f_default :: Foreground8 +color8_f_default = Foreground8 Nothing + +color8_f_black :: Foreground8 +color8_f_black = Foreground8 $ Just T.Black + +color8_f_red :: Foreground8 +color8_f_red = Foreground8 $ Just T.Red + +color8_f_green :: Foreground8 +color8_f_green = Foreground8 $ Just T.Green + +color8_f_yellow :: Foreground8 +color8_f_yellow = Foreground8 $ Just T.Yellow + +color8_f_blue :: Foreground8 +color8_f_blue = Foreground8 $ Just T.Blue + +color8_f_magenta :: Foreground8 +color8_f_magenta = Foreground8 $ Just T.Magenta + +color8_f_cyan :: Foreground8 +color8_f_cyan = Foreground8 $ Just T.Cyan + +color8_f_white :: Foreground8 +color8_f_white = Foreground8 $ Just T.White + +color8_b_default :: Background8 +color8_b_default = Background8 Nothing + +color8_b_black :: Background8 +color8_b_black = Background8 $ Just T.Black + +color8_b_red :: Background8 +color8_b_red = Background8 $ Just T.Red + +color8_b_green :: Background8 +color8_b_green = Background8 $ Just T.Green + +color8_b_yellow :: Background8 +color8_b_yellow = Background8 $ Just T.Yellow + +color8_b_blue :: Background8 +color8_b_blue = Background8 $ Just T.Blue + +color8_b_magenta :: Background8 +color8_b_magenta = Background8 $ Just T.Magenta + +color8_b_cyan :: Background8 +color8_b_cyan = Background8 $ Just T.Cyan + +color8_b_white :: Background8 +color8_b_white = Background8 $ Just T.White + +color256_f_default :: Foreground256 +color256_f_default = Foreground256 Nothing + +color256_f_0 :: Foreground256 +color256_f_0 = Foreground256 (Just (T.ColorNumber 0)) + +color256_f_1 :: Foreground256 +color256_f_1 = Foreground256 (Just (T.ColorNumber 1)) + +color256_f_2 :: Foreground256 +color256_f_2 = Foreground256 (Just (T.ColorNumber 2)) + +color256_f_3 :: Foreground256 +color256_f_3 = Foreground256 (Just (T.ColorNumber 3)) + +color256_f_4 :: Foreground256 +color256_f_4 = Foreground256 (Just (T.ColorNumber 4)) + +color256_f_5 :: Foreground256 +color256_f_5 = Foreground256 (Just (T.ColorNumber 5)) + +color256_f_6 :: Foreground256 +color256_f_6 = Foreground256 (Just (T.ColorNumber 6)) + +color256_f_7 :: Foreground256 +color256_f_7 = Foreground256 (Just (T.ColorNumber 7)) + +color256_f_8 :: Foreground256 +color256_f_8 = Foreground256 (Just (T.ColorNumber 8)) + +color256_f_9 :: Foreground256 +color256_f_9 = Foreground256 (Just (T.ColorNumber 9)) + +color256_f_10 :: Foreground256 +color256_f_10 = Foreground256 (Just (T.ColorNumber 10)) + +color256_f_11 :: Foreground256 +color256_f_11 = Foreground256 (Just (T.ColorNumber 11)) + +color256_f_12 :: Foreground256 +color256_f_12 = Foreground256 (Just (T.ColorNumber 12)) + +color256_f_13 :: Foreground256 +color256_f_13 = Foreground256 (Just (T.ColorNumber 13)) + +color256_f_14 :: Foreground256 +color256_f_14 = Foreground256 (Just (T.ColorNumber 14)) + +color256_f_15 :: Foreground256 +color256_f_15 = Foreground256 (Just (T.ColorNumber 15)) + +color256_f_16 :: Foreground256 +color256_f_16 = Foreground256 (Just (T.ColorNumber 16)) + +color256_f_17 :: Foreground256 +color256_f_17 = Foreground256 (Just (T.ColorNumber 17)) + +color256_f_18 :: Foreground256 +color256_f_18 = Foreground256 (Just (T.ColorNumber 18)) + +color256_f_19 :: Foreground256 +color256_f_19 = Foreground256 (Just (T.ColorNumber 19)) + +color256_f_20 :: Foreground256 +color256_f_20 = Foreground256 (Just (T.ColorNumber 20)) + +color256_f_21 :: Foreground256 +color256_f_21 = Foreground256 (Just (T.ColorNumber 21)) + +color256_f_22 :: Foreground256 +color256_f_22 = Foreground256 (Just (T.ColorNumber 22)) + +color256_f_23 :: Foreground256 +color256_f_23 = Foreground256 (Just (T.ColorNumber 23)) + +color256_f_24 :: Foreground256 +color256_f_24 = Foreground256 (Just (T.ColorNumber 24)) + +color256_f_25 :: Foreground256 +color256_f_25 = Foreground256 (Just (T.ColorNumber 25)) + +color256_f_26 :: Foreground256 +color256_f_26 = Foreground256 (Just (T.ColorNumber 26)) + +color256_f_27 :: Foreground256 +color256_f_27 = Foreground256 (Just (T.ColorNumber 27)) + +color256_f_28 :: Foreground256 +color256_f_28 = Foreground256 (Just (T.ColorNumber 28)) + +color256_f_29 :: Foreground256 +color256_f_29 = Foreground256 (Just (T.ColorNumber 29)) + +color256_f_30 :: Foreground256 +color256_f_30 = Foreground256 (Just (T.ColorNumber 30)) + +color256_f_31 :: Foreground256 +color256_f_31 = Foreground256 (Just (T.ColorNumber 31)) + +color256_f_32 :: Foreground256 +color256_f_32 = Foreground256 (Just (T.ColorNumber 32)) + +color256_f_33 :: Foreground256 +color256_f_33 = Foreground256 (Just (T.ColorNumber 33)) + +color256_f_34 :: Foreground256 +color256_f_34 = Foreground256 (Just (T.ColorNumber 34)) + +color256_f_35 :: Foreground256 +color256_f_35 = Foreground256 (Just (T.ColorNumber 35)) + +color256_f_36 :: Foreground256 +color256_f_36 = Foreground256 (Just (T.ColorNumber 36)) + +color256_f_37 :: Foreground256 +color256_f_37 = Foreground256 (Just (T.ColorNumber 37)) + +color256_f_38 :: Foreground256 +color256_f_38 = Foreground256 (Just (T.ColorNumber 38)) + +color256_f_39 :: Foreground256 +color256_f_39 = Foreground256 (Just (T.ColorNumber 39)) + +color256_f_40 :: Foreground256 +color256_f_40 = Foreground256 (Just (T.ColorNumber 40)) + +color256_f_41 :: Foreground256 +color256_f_41 = Foreground256 (Just (T.ColorNumber 41)) + +color256_f_42 :: Foreground256 +color256_f_42 = Foreground256 (Just (T.ColorNumber 42)) + +color256_f_43 :: Foreground256 +color256_f_43 = Foreground256 (Just (T.ColorNumber 43)) + +color256_f_44 :: Foreground256 +color256_f_44 = Foreground256 (Just (T.ColorNumber 44)) + +color256_f_45 :: Foreground256 +color256_f_45 = Foreground256 (Just (T.ColorNumber 45)) + +color256_f_46 :: Foreground256 +color256_f_46 = Foreground256 (Just (T.ColorNumber 46)) + +color256_f_47 :: Foreground256 +color256_f_47 = Foreground256 (Just (T.ColorNumber 47)) + +color256_f_48 :: Foreground256 +color256_f_48 = Foreground256 (Just (T.ColorNumber 48)) + +color256_f_49 :: Foreground256 +color256_f_49 = Foreground256 (Just (T.ColorNumber 49)) + +color256_f_50 :: Foreground256 +color256_f_50 = Foreground256 (Just (T.ColorNumber 50)) + +color256_f_51 :: Foreground256 +color256_f_51 = Foreground256 (Just (T.ColorNumber 51)) + +color256_f_52 :: Foreground256 +color256_f_52 = Foreground256 (Just (T.ColorNumber 52)) + +color256_f_53 :: Foreground256 +color256_f_53 = Foreground256 (Just (T.ColorNumber 53)) + +color256_f_54 :: Foreground256 +color256_f_54 = Foreground256 (Just (T.ColorNumber 54)) + +color256_f_55 :: Foreground256 +color256_f_55 = Foreground256 (Just (T.ColorNumber 55)) + +color256_f_56 :: Foreground256 +color256_f_56 = Foreground256 (Just (T.ColorNumber 56)) + +color256_f_57 :: Foreground256 +color256_f_57 = Foreground256 (Just (T.ColorNumber 57)) + +color256_f_58 :: Foreground256 +color256_f_58 = Foreground256 (Just (T.ColorNumber 58)) + +color256_f_59 :: Foreground256 +color256_f_59 = Foreground256 (Just (T.ColorNumber 59)) + +color256_f_60 :: Foreground256 +color256_f_60 = Foreground256 (Just (T.ColorNumber 60)) + +color256_f_61 :: Foreground256 +color256_f_61 = Foreground256 (Just (T.ColorNumber 61)) + +color256_f_62 :: Foreground256 +color256_f_62 = Foreground256 (Just (T.ColorNumber 62)) + +color256_f_63 :: Foreground256 +color256_f_63 = Foreground256 (Just (T.ColorNumber 63)) + +color256_f_64 :: Foreground256 +color256_f_64 = Foreground256 (Just (T.ColorNumber 64)) + +color256_f_65 :: Foreground256 +color256_f_65 = Foreground256 (Just (T.ColorNumber 65)) + +color256_f_66 :: Foreground256 +color256_f_66 = Foreground256 (Just (T.ColorNumber 66)) + +color256_f_67 :: Foreground256 +color256_f_67 = Foreground256 (Just (T.ColorNumber 67)) + +color256_f_68 :: Foreground256 +color256_f_68 = Foreground256 (Just (T.ColorNumber 68)) + +color256_f_69 :: Foreground256 +color256_f_69 = Foreground256 (Just (T.ColorNumber 69)) + +color256_f_70 :: Foreground256 +color256_f_70 = Foreground256 (Just (T.ColorNumber 70)) + +color256_f_71 :: Foreground256 +color256_f_71 = Foreground256 (Just (T.ColorNumber 71)) + +color256_f_72 :: Foreground256 +color256_f_72 = Foreground256 (Just (T.ColorNumber 72)) + +color256_f_73 :: Foreground256 +color256_f_73 = Foreground256 (Just (T.ColorNumber 73)) + +color256_f_74 :: Foreground256 +color256_f_74 = Foreground256 (Just (T.ColorNumber 74)) + +color256_f_75 :: Foreground256 +color256_f_75 = Foreground256 (Just (T.ColorNumber 75)) + +color256_f_76 :: Foreground256 +color256_f_76 = Foreground256 (Just (T.ColorNumber 76)) + +color256_f_77 :: Foreground256 +color256_f_77 = Foreground256 (Just (T.ColorNumber 77)) + +color256_f_78 :: Foreground256 +color256_f_78 = Foreground256 (Just (T.ColorNumber 78)) + +color256_f_79 :: Foreground256 +color256_f_79 = Foreground256 (Just (T.ColorNumber 79)) + +color256_f_80 :: Foreground256 +color256_f_80 = Foreground256 (Just (T.ColorNumber 80)) + +color256_f_81 :: Foreground256 +color256_f_81 = Foreground256 (Just (T.ColorNumber 81)) + +color256_f_82 :: Foreground256 +color256_f_82 = Foreground256 (Just (T.ColorNumber 82)) + +color256_f_83 :: Foreground256 +color256_f_83 = Foreground256 (Just (T.ColorNumber 83)) + +color256_f_84 :: Foreground256 +color256_f_84 = Foreground256 (Just (T.ColorNumber 84)) + +color256_f_85 :: Foreground256 +color256_f_85 = Foreground256 (Just (T.ColorNumber 85)) + +color256_f_86 :: Foreground256 +color256_f_86 = Foreground256 (Just (T.ColorNumber 86)) + +color256_f_87 :: Foreground256 +color256_f_87 = Foreground256 (Just (T.ColorNumber 87)) + +color256_f_88 :: Foreground256 +color256_f_88 = Foreground256 (Just (T.ColorNumber 88)) + +color256_f_89 :: Foreground256 +color256_f_89 = Foreground256 (Just (T.ColorNumber 89)) + +color256_f_90 :: Foreground256 +color256_f_90 = Foreground256 (Just (T.ColorNumber 90)) + +color256_f_91 :: Foreground256 +color256_f_91 = Foreground256 (Just (T.ColorNumber 91)) + +color256_f_92 :: Foreground256 +color256_f_92 = Foreground256 (Just (T.ColorNumber 92)) + +color256_f_93 :: Foreground256 +color256_f_93 = Foreground256 (Just (T.ColorNumber 93)) + +color256_f_94 :: Foreground256 +color256_f_94 = Foreground256 (Just (T.ColorNumber 94)) + +color256_f_95 :: Foreground256 +color256_f_95 = Foreground256 (Just (T.ColorNumber 95)) + +color256_f_96 :: Foreground256 +color256_f_96 = Foreground256 (Just (T.ColorNumber 96)) + +color256_f_97 :: Foreground256 +color256_f_97 = Foreground256 (Just (T.ColorNumber 97)) + +color256_f_98 :: Foreground256 +color256_f_98 = Foreground256 (Just (T.ColorNumber 98)) + +color256_f_99 :: Foreground256 +color256_f_99 = Foreground256 (Just (T.ColorNumber 99)) + +color256_f_100 :: Foreground256 +color256_f_100 = Foreground256 (Just (T.ColorNumber 100)) + +color256_f_101 :: Foreground256 +color256_f_101 = Foreground256 (Just (T.ColorNumber 101)) + +color256_f_102 :: Foreground256 +color256_f_102 = Foreground256 (Just (T.ColorNumber 102)) + +color256_f_103 :: Foreground256 +color256_f_103 = Foreground256 (Just (T.ColorNumber 103)) + +color256_f_104 :: Foreground256 +color256_f_104 = Foreground256 (Just (T.ColorNumber 104)) + +color256_f_105 :: Foreground256 +color256_f_105 = Foreground256 (Just (T.ColorNumber 105)) + +color256_f_106 :: Foreground256 +color256_f_106 = Foreground256 (Just (T.ColorNumber 106)) + +color256_f_107 :: Foreground256 +color256_f_107 = Foreground256 (Just (T.ColorNumber 107)) + +color256_f_108 :: Foreground256 +color256_f_108 = Foreground256 (Just (T.ColorNumber 108)) + +color256_f_109 :: Foreground256 +color256_f_109 = Foreground256 (Just (T.ColorNumber 109)) + +color256_f_110 :: Foreground256 +color256_f_110 = Foreground256 (Just (T.ColorNumber 110)) + +color256_f_111 :: Foreground256 +color256_f_111 = Foreground256 (Just (T.ColorNumber 111)) + +color256_f_112 :: Foreground256 +color256_f_112 = Foreground256 (Just (T.ColorNumber 112)) + +color256_f_113 :: Foreground256 +color256_f_113 = Foreground256 (Just (T.ColorNumber 113)) + +color256_f_114 :: Foreground256 +color256_f_114 = Foreground256 (Just (T.ColorNumber 114)) + +color256_f_115 :: Foreground256 +color256_f_115 = Foreground256 (Just (T.ColorNumber 115)) + +color256_f_116 :: Foreground256 +color256_f_116 = Foreground256 (Just (T.ColorNumber 116)) + +color256_f_117 :: Foreground256 +color256_f_117 = Foreground256 (Just (T.ColorNumber 117)) + +color256_f_118 :: Foreground256 +color256_f_118 = Foreground256 (Just (T.ColorNumber 118)) + +color256_f_119 :: Foreground256 +color256_f_119 = Foreground256 (Just (T.ColorNumber 119)) + +color256_f_120 :: Foreground256 +color256_f_120 = Foreground256 (Just (T.ColorNumber 120)) + +color256_f_121 :: Foreground256 +color256_f_121 = Foreground256 (Just (T.ColorNumber 121)) + +color256_f_122 :: Foreground256 +color256_f_122 = Foreground256 (Just (T.ColorNumber 122)) + +color256_f_123 :: Foreground256 +color256_f_123 = Foreground256 (Just (T.ColorNumber 123)) + +color256_f_124 :: Foreground256 +color256_f_124 = Foreground256 (Just (T.ColorNumber 124)) + +color256_f_125 :: Foreground256 +color256_f_125 = Foreground256 (Just (T.ColorNumber 125)) + +color256_f_126 :: Foreground256 +color256_f_126 = Foreground256 (Just (T.ColorNumber 126)) + +color256_f_127 :: Foreground256 +color256_f_127 = Foreground256 (Just (T.ColorNumber 127)) + +color256_f_128 :: Foreground256 +color256_f_128 = Foreground256 (Just (T.ColorNumber 128)) + +color256_f_129 :: Foreground256 +color256_f_129 = Foreground256 (Just (T.ColorNumber 129)) + +color256_f_130 :: Foreground256 +color256_f_130 = Foreground256 (Just (T.ColorNumber 130)) + +color256_f_131 :: Foreground256 +color256_f_131 = Foreground256 (Just (T.ColorNumber 131)) + +color256_f_132 :: Foreground256 +color256_f_132 = Foreground256 (Just (T.ColorNumber 132)) + +color256_f_133 :: Foreground256 +color256_f_133 = Foreground256 (Just (T.ColorNumber 133)) + +color256_f_134 :: Foreground256 +color256_f_134 = Foreground256 (Just (T.ColorNumber 134)) + +color256_f_135 :: Foreground256 +color256_f_135 = Foreground256 (Just (T.ColorNumber 135)) + +color256_f_136 :: Foreground256 +color256_f_136 = Foreground256 (Just (T.ColorNumber 136)) + +color256_f_137 :: Foreground256 +color256_f_137 = Foreground256 (Just (T.ColorNumber 137)) + +color256_f_138 :: Foreground256 +color256_f_138 = Foreground256 (Just (T.ColorNumber 138)) + +color256_f_139 :: Foreground256 +color256_f_139 = Foreground256 (Just (T.ColorNumber 139)) + +color256_f_140 :: Foreground256 +color256_f_140 = Foreground256 (Just (T.ColorNumber 140)) + +color256_f_141 :: Foreground256 +color256_f_141 = Foreground256 (Just (T.ColorNumber 141)) + +color256_f_142 :: Foreground256 +color256_f_142 = Foreground256 (Just (T.ColorNumber 142)) + +color256_f_143 :: Foreground256 +color256_f_143 = Foreground256 (Just (T.ColorNumber 143)) + +color256_f_144 :: Foreground256 +color256_f_144 = Foreground256 (Just (T.ColorNumber 144)) + +color256_f_145 :: Foreground256 +color256_f_145 = Foreground256 (Just (T.ColorNumber 145)) + +color256_f_146 :: Foreground256 +color256_f_146 = Foreground256 (Just (T.ColorNumber 146)) + +color256_f_147 :: Foreground256 +color256_f_147 = Foreground256 (Just (T.ColorNumber 147)) + +color256_f_148 :: Foreground256 +color256_f_148 = Foreground256 (Just (T.ColorNumber 148)) + +color256_f_149 :: Foreground256 +color256_f_149 = Foreground256 (Just (T.ColorNumber 149)) + +color256_f_150 :: Foreground256 +color256_f_150 = Foreground256 (Just (T.ColorNumber 150)) + +color256_f_151 :: Foreground256 +color256_f_151 = Foreground256 (Just (T.ColorNumber 151)) + +color256_f_152 :: Foreground256 +color256_f_152 = Foreground256 (Just (T.ColorNumber 152)) + +color256_f_153 :: Foreground256 +color256_f_153 = Foreground256 (Just (T.ColorNumber 153)) + +color256_f_154 :: Foreground256 +color256_f_154 = Foreground256 (Just (T.ColorNumber 154)) + +color256_f_155 :: Foreground256 +color256_f_155 = Foreground256 (Just (T.ColorNumber 155)) + +color256_f_156 :: Foreground256 +color256_f_156 = Foreground256 (Just (T.ColorNumber 156)) + +color256_f_157 :: Foreground256 +color256_f_157 = Foreground256 (Just (T.ColorNumber 157)) + +color256_f_158 :: Foreground256 +color256_f_158 = Foreground256 (Just (T.ColorNumber 158)) + +color256_f_159 :: Foreground256 +color256_f_159 = Foreground256 (Just (T.ColorNumber 159)) + +color256_f_160 :: Foreground256 +color256_f_160 = Foreground256 (Just (T.ColorNumber 160)) + +color256_f_161 :: Foreground256 +color256_f_161 = Foreground256 (Just (T.ColorNumber 161)) + +color256_f_162 :: Foreground256 +color256_f_162 = Foreground256 (Just (T.ColorNumber 162)) + +color256_f_163 :: Foreground256 +color256_f_163 = Foreground256 (Just (T.ColorNumber 163)) + +color256_f_164 :: Foreground256 +color256_f_164 = Foreground256 (Just (T.ColorNumber 164)) + +color256_f_165 :: Foreground256 +color256_f_165 = Foreground256 (Just (T.ColorNumber 165)) + +color256_f_166 :: Foreground256 +color256_f_166 = Foreground256 (Just (T.ColorNumber 166)) + +color256_f_167 :: Foreground256 +color256_f_167 = Foreground256 (Just (T.ColorNumber 167)) + +color256_f_168 :: Foreground256 +color256_f_168 = Foreground256 (Just (T.ColorNumber 168)) + +color256_f_169 :: Foreground256 +color256_f_169 = Foreground256 (Just (T.ColorNumber 169)) + +color256_f_170 :: Foreground256 +color256_f_170 = Foreground256 (Just (T.ColorNumber 170)) + +color256_f_171 :: Foreground256 +color256_f_171 = Foreground256 (Just (T.ColorNumber 171)) + +color256_f_172 :: Foreground256 +color256_f_172 = Foreground256 (Just (T.ColorNumber 172)) + +color256_f_173 :: Foreground256 +color256_f_173 = Foreground256 (Just (T.ColorNumber 173)) + +color256_f_174 :: Foreground256 +color256_f_174 = Foreground256 (Just (T.ColorNumber 174)) + +color256_f_175 :: Foreground256 +color256_f_175 = Foreground256 (Just (T.ColorNumber 175)) + +color256_f_176 :: Foreground256 +color256_f_176 = Foreground256 (Just (T.ColorNumber 176)) + +color256_f_177 :: Foreground256 +color256_f_177 = Foreground256 (Just (T.ColorNumber 177)) + +color256_f_178 :: Foreground256 +color256_f_178 = Foreground256 (Just (T.ColorNumber 178)) + +color256_f_179 :: Foreground256 +color256_f_179 = Foreground256 (Just (T.ColorNumber 179)) + +color256_f_180 :: Foreground256 +color256_f_180 = Foreground256 (Just (T.ColorNumber 180)) + +color256_f_181 :: Foreground256 +color256_f_181 = Foreground256 (Just (T.ColorNumber 181)) + +color256_f_182 :: Foreground256 +color256_f_182 = Foreground256 (Just (T.ColorNumber 182)) + +color256_f_183 :: Foreground256 +color256_f_183 = Foreground256 (Just (T.ColorNumber 183)) + +color256_f_184 :: Foreground256 +color256_f_184 = Foreground256 (Just (T.ColorNumber 184)) + +color256_f_185 :: Foreground256 +color256_f_185 = Foreground256 (Just (T.ColorNumber 185)) + +color256_f_186 :: Foreground256 +color256_f_186 = Foreground256 (Just (T.ColorNumber 186)) + +color256_f_187 :: Foreground256 +color256_f_187 = Foreground256 (Just (T.ColorNumber 187)) + +color256_f_188 :: Foreground256 +color256_f_188 = Foreground256 (Just (T.ColorNumber 188)) + +color256_f_189 :: Foreground256 +color256_f_189 = Foreground256 (Just (T.ColorNumber 189)) + +color256_f_190 :: Foreground256 +color256_f_190 = Foreground256 (Just (T.ColorNumber 190)) + +color256_f_191 :: Foreground256 +color256_f_191 = Foreground256 (Just (T.ColorNumber 191)) + +color256_f_192 :: Foreground256 +color256_f_192 = Foreground256 (Just (T.ColorNumber 192)) + +color256_f_193 :: Foreground256 +color256_f_193 = Foreground256 (Just (T.ColorNumber 193)) + +color256_f_194 :: Foreground256 +color256_f_194 = Foreground256 (Just (T.ColorNumber 194)) + +color256_f_195 :: Foreground256 +color256_f_195 = Foreground256 (Just (T.ColorNumber 195)) + +color256_f_196 :: Foreground256 +color256_f_196 = Foreground256 (Just (T.ColorNumber 196)) + +color256_f_197 :: Foreground256 +color256_f_197 = Foreground256 (Just (T.ColorNumber 197)) + +color256_f_198 :: Foreground256 +color256_f_198 = Foreground256 (Just (T.ColorNumber 198)) + +color256_f_199 :: Foreground256 +color256_f_199 = Foreground256 (Just (T.ColorNumber 199)) + +color256_f_200 :: Foreground256 +color256_f_200 = Foreground256 (Just (T.ColorNumber 200)) + +color256_f_201 :: Foreground256 +color256_f_201 = Foreground256 (Just (T.ColorNumber 201)) + +color256_f_202 :: Foreground256 +color256_f_202 = Foreground256 (Just (T.ColorNumber 202)) + +color256_f_203 :: Foreground256 +color256_f_203 = Foreground256 (Just (T.ColorNumber 203)) + +color256_f_204 :: Foreground256 +color256_f_204 = Foreground256 (Just (T.ColorNumber 204)) + +color256_f_205 :: Foreground256 +color256_f_205 = Foreground256 (Just (T.ColorNumber 205)) + +color256_f_206 :: Foreground256 +color256_f_206 = Foreground256 (Just (T.ColorNumber 206)) + +color256_f_207 :: Foreground256 +color256_f_207 = Foreground256 (Just (T.ColorNumber 207)) + +color256_f_208 :: Foreground256 +color256_f_208 = Foreground256 (Just (T.ColorNumber 208)) + +color256_f_209 :: Foreground256 +color256_f_209 = Foreground256 (Just (T.ColorNumber 209)) + +color256_f_210 :: Foreground256 +color256_f_210 = Foreground256 (Just (T.ColorNumber 210)) + +color256_f_211 :: Foreground256 +color256_f_211 = Foreground256 (Just (T.ColorNumber 211)) + +color256_f_212 :: Foreground256 +color256_f_212 = Foreground256 (Just (T.ColorNumber 212)) + +color256_f_213 :: Foreground256 +color256_f_213 = Foreground256 (Just (T.ColorNumber 213)) + +color256_f_214 :: Foreground256 +color256_f_214 = Foreground256 (Just (T.ColorNumber 214)) + +color256_f_215 :: Foreground256 +color256_f_215 = Foreground256 (Just (T.ColorNumber 215)) + +color256_f_216 :: Foreground256 +color256_f_216 = Foreground256 (Just (T.ColorNumber 216)) + +color256_f_217 :: Foreground256 +color256_f_217 = Foreground256 (Just (T.ColorNumber 217)) + +color256_f_218 :: Foreground256 +color256_f_218 = Foreground256 (Just (T.ColorNumber 218)) + +color256_f_219 :: Foreground256 +color256_f_219 = Foreground256 (Just (T.ColorNumber 219)) + +color256_f_220 :: Foreground256 +color256_f_220 = Foreground256 (Just (T.ColorNumber 220)) + +color256_f_221 :: Foreground256 +color256_f_221 = Foreground256 (Just (T.ColorNumber 221)) + +color256_f_222 :: Foreground256 +color256_f_222 = Foreground256 (Just (T.ColorNumber 222)) + +color256_f_223 :: Foreground256 +color256_f_223 = Foreground256 (Just (T.ColorNumber 223)) + +color256_f_224 :: Foreground256 +color256_f_224 = Foreground256 (Just (T.ColorNumber 224)) + +color256_f_225 :: Foreground256 +color256_f_225 = Foreground256 (Just (T.ColorNumber 225)) + +color256_f_226 :: Foreground256 +color256_f_226 = Foreground256 (Just (T.ColorNumber 226)) + +color256_f_227 :: Foreground256 +color256_f_227 = Foreground256 (Just (T.ColorNumber 227)) + +color256_f_228 :: Foreground256 +color256_f_228 = Foreground256 (Just (T.ColorNumber 228)) + +color256_f_229 :: Foreground256 +color256_f_229 = Foreground256 (Just (T.ColorNumber 229)) + +color256_f_230 :: Foreground256 +color256_f_230 = Foreground256 (Just (T.ColorNumber 230)) + +color256_f_231 :: Foreground256 +color256_f_231 = Foreground256 (Just (T.ColorNumber 231)) + +color256_f_232 :: Foreground256 +color256_f_232 = Foreground256 (Just (T.ColorNumber 232)) + +color256_f_233 :: Foreground256 +color256_f_233 = Foreground256 (Just (T.ColorNumber 233)) + +color256_f_234 :: Foreground256 +color256_f_234 = Foreground256 (Just (T.ColorNumber 234)) + +color256_f_235 :: Foreground256 +color256_f_235 = Foreground256 (Just (T.ColorNumber 235)) + +color256_f_236 :: Foreground256 +color256_f_236 = Foreground256 (Just (T.ColorNumber 236)) + +color256_f_237 :: Foreground256 +color256_f_237 = Foreground256 (Just (T.ColorNumber 237)) + +color256_f_238 :: Foreground256 +color256_f_238 = Foreground256 (Just (T.ColorNumber 238)) + +color256_f_239 :: Foreground256 +color256_f_239 = Foreground256 (Just (T.ColorNumber 239)) + +color256_f_240 :: Foreground256 +color256_f_240 = Foreground256 (Just (T.ColorNumber 240)) + +color256_f_241 :: Foreground256 +color256_f_241 = Foreground256 (Just (T.ColorNumber 241)) + +color256_f_242 :: Foreground256 +color256_f_242 = Foreground256 (Just (T.ColorNumber 242)) + +color256_f_243 :: Foreground256 +color256_f_243 = Foreground256 (Just (T.ColorNumber 243)) + +color256_f_244 :: Foreground256 +color256_f_244 = Foreground256 (Just (T.ColorNumber 244)) + +color256_f_245 :: Foreground256 +color256_f_245 = Foreground256 (Just (T.ColorNumber 245)) + +color256_f_246 :: Foreground256 +color256_f_246 = Foreground256 (Just (T.ColorNumber 246)) + +color256_f_247 :: Foreground256 +color256_f_247 = Foreground256 (Just (T.ColorNumber 247)) + +color256_f_248 :: Foreground256 +color256_f_248 = Foreground256 (Just (T.ColorNumber 248)) + +color256_f_249 :: Foreground256 +color256_f_249 = Foreground256 (Just (T.ColorNumber 249)) + +color256_f_250 :: Foreground256 +color256_f_250 = Foreground256 (Just (T.ColorNumber 250)) + +color256_f_251 :: Foreground256 +color256_f_251 = Foreground256 (Just (T.ColorNumber 251)) + +color256_f_252 :: Foreground256 +color256_f_252 = Foreground256 (Just (T.ColorNumber 252)) + +color256_f_253 :: Foreground256 +color256_f_253 = Foreground256 (Just (T.ColorNumber 253)) + +color256_f_254 :: Foreground256 +color256_f_254 = Foreground256 (Just (T.ColorNumber 254)) + +color256_f_255 :: Foreground256 +color256_f_255 = Foreground256 (Just (T.ColorNumber 255)) + +color256_b_default :: Background256 +color256_b_default = Background256 Nothing + +color256_b_0 :: Background256 +color256_b_0 = Background256 (Just (T.ColorNumber 0)) + +color256_b_1 :: Background256 +color256_b_1 = Background256 (Just (T.ColorNumber 1)) + +color256_b_2 :: Background256 +color256_b_2 = Background256 (Just (T.ColorNumber 2)) + +color256_b_3 :: Background256 +color256_b_3 = Background256 (Just (T.ColorNumber 3)) + +color256_b_4 :: Background256 +color256_b_4 = Background256 (Just (T.ColorNumber 4)) + +color256_b_5 :: Background256 +color256_b_5 = Background256 (Just (T.ColorNumber 5)) + +color256_b_6 :: Background256 +color256_b_6 = Background256 (Just (T.ColorNumber 6)) + +color256_b_7 :: Background256 +color256_b_7 = Background256 (Just (T.ColorNumber 7)) + +color256_b_8 :: Background256 +color256_b_8 = Background256 (Just (T.ColorNumber 8)) + +color256_b_9 :: Background256 +color256_b_9 = Background256 (Just (T.ColorNumber 9)) + +color256_b_10 :: Background256 +color256_b_10 = Background256 (Just (T.ColorNumber 10)) + +color256_b_11 :: Background256 +color256_b_11 = Background256 (Just (T.ColorNumber 11)) + +color256_b_12 :: Background256 +color256_b_12 = Background256 (Just (T.ColorNumber 12)) + +color256_b_13 :: Background256 +color256_b_13 = Background256 (Just (T.ColorNumber 13)) + +color256_b_14 :: Background256 +color256_b_14 = Background256 (Just (T.ColorNumber 14)) + +color256_b_15 :: Background256 +color256_b_15 = Background256 (Just (T.ColorNumber 15)) + +color256_b_16 :: Background256 +color256_b_16 = Background256 (Just (T.ColorNumber 16)) + +color256_b_17 :: Background256 +color256_b_17 = Background256 (Just (T.ColorNumber 17)) + +color256_b_18 :: Background256 +color256_b_18 = Background256 (Just (T.ColorNumber 18)) + +color256_b_19 :: Background256 +color256_b_19 = Background256 (Just (T.ColorNumber 19)) + +color256_b_20 :: Background256 +color256_b_20 = Background256 (Just (T.ColorNumber 20)) + +color256_b_21 :: Background256 +color256_b_21 = Background256 (Just (T.ColorNumber 21)) + +color256_b_22 :: Background256 +color256_b_22 = Background256 (Just (T.ColorNumber 22)) + +color256_b_23 :: Background256 +color256_b_23 = Background256 (Just (T.ColorNumber 23)) + +color256_b_24 :: Background256 +color256_b_24 = Background256 (Just (T.ColorNumber 24)) + +color256_b_25 :: Background256 +color256_b_25 = Background256 (Just (T.ColorNumber 25)) + +color256_b_26 :: Background256 +color256_b_26 = Background256 (Just (T.ColorNumber 26)) + +color256_b_27 :: Background256 +color256_b_27 = Background256 (Just (T.ColorNumber 27)) + +color256_b_28 :: Background256 +color256_b_28 = Background256 (Just (T.ColorNumber 28)) + +color256_b_29 :: Background256 +color256_b_29 = Background256 (Just (T.ColorNumber 29)) + +color256_b_30 :: Background256 +color256_b_30 = Background256 (Just (T.ColorNumber 30)) + +color256_b_31 :: Background256 +color256_b_31 = Background256 (Just (T.ColorNumber 31)) + +color256_b_32 :: Background256 +color256_b_32 = Background256 (Just (T.ColorNumber 32)) + +color256_b_33 :: Background256 +color256_b_33 = Background256 (Just (T.ColorNumber 33)) + +color256_b_34 :: Background256 +color256_b_34 = Background256 (Just (T.ColorNumber 34)) + +color256_b_35 :: Background256 +color256_b_35 = Background256 (Just (T.ColorNumber 35)) + +color256_b_36 :: Background256 +color256_b_36 = Background256 (Just (T.ColorNumber 36)) + +color256_b_37 :: Background256 +color256_b_37 = Background256 (Just (T.ColorNumber 37)) + +color256_b_38 :: Background256 +color256_b_38 = Background256 (Just (T.ColorNumber 38)) + +color256_b_39 :: Background256 +color256_b_39 = Background256 (Just (T.ColorNumber 39)) + +color256_b_40 :: Background256 +color256_b_40 = Background256 (Just (T.ColorNumber 40)) + +color256_b_41 :: Background256 +color256_b_41 = Background256 (Just (T.ColorNumber 41)) + +color256_b_42 :: Background256 +color256_b_42 = Background256 (Just (T.ColorNumber 42)) + +color256_b_43 :: Background256 +color256_b_43 = Background256 (Just (T.ColorNumber 43)) + +color256_b_44 :: Background256 +color256_b_44 = Background256 (Just (T.ColorNumber 44)) + +color256_b_45 :: Background256 +color256_b_45 = Background256 (Just (T.ColorNumber 45)) + +color256_b_46 :: Background256 +color256_b_46 = Background256 (Just (T.ColorNumber 46)) + +color256_b_47 :: Background256 +color256_b_47 = Background256 (Just (T.ColorNumber 47)) + +color256_b_48 :: Background256 +color256_b_48 = Background256 (Just (T.ColorNumber 48)) + +color256_b_49 :: Background256 +color256_b_49 = Background256 (Just (T.ColorNumber 49)) + +color256_b_50 :: Background256 +color256_b_50 = Background256 (Just (T.ColorNumber 50)) + +color256_b_51 :: Background256 +color256_b_51 = Background256 (Just (T.ColorNumber 51)) + +color256_b_52 :: Background256 +color256_b_52 = Background256 (Just (T.ColorNumber 52)) + +color256_b_53 :: Background256 +color256_b_53 = Background256 (Just (T.ColorNumber 53)) + +color256_b_54 :: Background256 +color256_b_54 = Background256 (Just (T.ColorNumber 54)) + +color256_b_55 :: Background256 +color256_b_55 = Background256 (Just (T.ColorNumber 55)) + +color256_b_56 :: Background256 +color256_b_56 = Background256 (Just (T.ColorNumber 56)) + +color256_b_57 :: Background256 +color256_b_57 = Background256 (Just (T.ColorNumber 57)) + +color256_b_58 :: Background256 +color256_b_58 = Background256 (Just (T.ColorNumber 58)) + +color256_b_59 :: Background256 +color256_b_59 = Background256 (Just (T.ColorNumber 59)) + +color256_b_60 :: Background256 +color256_b_60 = Background256 (Just (T.ColorNumber 60)) + +color256_b_61 :: Background256 +color256_b_61 = Background256 (Just (T.ColorNumber 61)) + +color256_b_62 :: Background256 +color256_b_62 = Background256 (Just (T.ColorNumber 62)) + +color256_b_63 :: Background256 +color256_b_63 = Background256 (Just (T.ColorNumber 63)) + +color256_b_64 :: Background256 +color256_b_64 = Background256 (Just (T.ColorNumber 64)) + +color256_b_65 :: Background256 +color256_b_65 = Background256 (Just (T.ColorNumber 65)) + +color256_b_66 :: Background256 +color256_b_66 = Background256 (Just (T.ColorNumber 66)) + +color256_b_67 :: Background256 +color256_b_67 = Background256 (Just (T.ColorNumber 67)) + +color256_b_68 :: Background256 +color256_b_68 = Background256 (Just (T.ColorNumber 68)) + +color256_b_69 :: Background256 +color256_b_69 = Background256 (Just (T.ColorNumber 69)) + +color256_b_70 :: Background256 +color256_b_70 = Background256 (Just (T.ColorNumber 70)) + +color256_b_71 :: Background256 +color256_b_71 = Background256 (Just (T.ColorNumber 71)) + +color256_b_72 :: Background256 +color256_b_72 = Background256 (Just (T.ColorNumber 72)) + +color256_b_73 :: Background256 +color256_b_73 = Background256 (Just (T.ColorNumber 73)) + +color256_b_74 :: Background256 +color256_b_74 = Background256 (Just (T.ColorNumber 74)) + +color256_b_75 :: Background256 +color256_b_75 = Background256 (Just (T.ColorNumber 75)) + +color256_b_76 :: Background256 +color256_b_76 = Background256 (Just (T.ColorNumber 76)) + +color256_b_77 :: Background256 +color256_b_77 = Background256 (Just (T.ColorNumber 77)) + +color256_b_78 :: Background256 +color256_b_78 = Background256 (Just (T.ColorNumber 78)) + +color256_b_79 :: Background256 +color256_b_79 = Background256 (Just (T.ColorNumber 79)) + +color256_b_80 :: Background256 +color256_b_80 = Background256 (Just (T.ColorNumber 80)) + +color256_b_81 :: Background256 +color256_b_81 = Background256 (Just (T.ColorNumber 81)) + +color256_b_82 :: Background256 +color256_b_82 = Background256 (Just (T.ColorNumber 82)) + +color256_b_83 :: Background256 +color256_b_83 = Background256 (Just (T.ColorNumber 83)) + +color256_b_84 :: Background256 +color256_b_84 = Background256 (Just (T.ColorNumber 84)) + +color256_b_85 :: Background256 +color256_b_85 = Background256 (Just (T.ColorNumber 85)) + +color256_b_86 :: Background256 +color256_b_86 = Background256 (Just (T.ColorNumber 86)) + +color256_b_87 :: Background256 +color256_b_87 = Background256 (Just (T.ColorNumber 87)) + +color256_b_88 :: Background256 +color256_b_88 = Background256 (Just (T.ColorNumber 88)) + +color256_b_89 :: Background256 +color256_b_89 = Background256 (Just (T.ColorNumber 89)) + +color256_b_90 :: Background256 +color256_b_90 = Background256 (Just (T.ColorNumber 90)) + +color256_b_91 :: Background256 +color256_b_91 = Background256 (Just (T.ColorNumber 91)) + +color256_b_92 :: Background256 +color256_b_92 = Background256 (Just (T.ColorNumber 92)) + +color256_b_93 :: Background256 +color256_b_93 = Background256 (Just (T.ColorNumber 93)) + +color256_b_94 :: Background256 +color256_b_94 = Background256 (Just (T.ColorNumber 94)) + +color256_b_95 :: Background256 +color256_b_95 = Background256 (Just (T.ColorNumber 95)) + +color256_b_96 :: Background256 +color256_b_96 = Background256 (Just (T.ColorNumber 96)) + +color256_b_97 :: Background256 +color256_b_97 = Background256 (Just (T.ColorNumber 97)) + +color256_b_98 :: Background256 +color256_b_98 = Background256 (Just (T.ColorNumber 98)) + +color256_b_99 :: Background256 +color256_b_99 = Background256 (Just (T.ColorNumber 99)) + +color256_b_100 :: Background256 +color256_b_100 = Background256 (Just (T.ColorNumber 100)) + +color256_b_101 :: Background256 +color256_b_101 = Background256 (Just (T.ColorNumber 101)) + +color256_b_102 :: Background256 +color256_b_102 = Background256 (Just (T.ColorNumber 102)) + +color256_b_103 :: Background256 +color256_b_103 = Background256 (Just (T.ColorNumber 103)) + +color256_b_104 :: Background256 +color256_b_104 = Background256 (Just (T.ColorNumber 104)) + +color256_b_105 :: Background256 +color256_b_105 = Background256 (Just (T.ColorNumber 105)) + +color256_b_106 :: Background256 +color256_b_106 = Background256 (Just (T.ColorNumber 106)) + +color256_b_107 :: Background256 +color256_b_107 = Background256 (Just (T.ColorNumber 107)) + +color256_b_108 :: Background256 +color256_b_108 = Background256 (Just (T.ColorNumber 108)) + +color256_b_109 :: Background256 +color256_b_109 = Background256 (Just (T.ColorNumber 109)) + +color256_b_110 :: Background256 +color256_b_110 = Background256 (Just (T.ColorNumber 110)) + +color256_b_111 :: Background256 +color256_b_111 = Background256 (Just (T.ColorNumber 111)) + +color256_b_112 :: Background256 +color256_b_112 = Background256 (Just (T.ColorNumber 112)) + +color256_b_113 :: Background256 +color256_b_113 = Background256 (Just (T.ColorNumber 113)) + +color256_b_114 :: Background256 +color256_b_114 = Background256 (Just (T.ColorNumber 114)) + +color256_b_115 :: Background256 +color256_b_115 = Background256 (Just (T.ColorNumber 115)) + +color256_b_116 :: Background256 +color256_b_116 = Background256 (Just (T.ColorNumber 116)) + +color256_b_117 :: Background256 +color256_b_117 = Background256 (Just (T.ColorNumber 117)) + +color256_b_118 :: Background256 +color256_b_118 = Background256 (Just (T.ColorNumber 118)) + +color256_b_119 :: Background256 +color256_b_119 = Background256 (Just (T.ColorNumber 119)) + +color256_b_120 :: Background256 +color256_b_120 = Background256 (Just (T.ColorNumber 120)) + +color256_b_121 :: Background256 +color256_b_121 = Background256 (Just (T.ColorNumber 121)) + +color256_b_122 :: Background256 +color256_b_122 = Background256 (Just (T.ColorNumber 122)) + +color256_b_123 :: Background256 +color256_b_123 = Background256 (Just (T.ColorNumber 123)) + +color256_b_124 :: Background256 +color256_b_124 = Background256 (Just (T.ColorNumber 124)) + +color256_b_125 :: Background256 +color256_b_125 = Background256 (Just (T.ColorNumber 125)) + +color256_b_126 :: Background256 +color256_b_126 = Background256 (Just (T.ColorNumber 126)) + +color256_b_127 :: Background256 +color256_b_127 = Background256 (Just (T.ColorNumber 127)) + +color256_b_128 :: Background256 +color256_b_128 = Background256 (Just (T.ColorNumber 128)) + +color256_b_129 :: Background256 +color256_b_129 = Background256 (Just (T.ColorNumber 129)) + +color256_b_130 :: Background256 +color256_b_130 = Background256 (Just (T.ColorNumber 130)) + +color256_b_131 :: Background256 +color256_b_131 = Background256 (Just (T.ColorNumber 131)) + +color256_b_132 :: Background256 +color256_b_132 = Background256 (Just (T.ColorNumber 132)) + +color256_b_133 :: Background256 +color256_b_133 = Background256 (Just (T.ColorNumber 133)) + +color256_b_134 :: Background256 +color256_b_134 = Background256 (Just (T.ColorNumber 134)) + +color256_b_135 :: Background256 +color256_b_135 = Background256 (Just (T.ColorNumber 135)) + +color256_b_136 :: Background256 +color256_b_136 = Background256 (Just (T.ColorNumber 136)) + +color256_b_137 :: Background256 +color256_b_137 = Background256 (Just (T.ColorNumber 137)) + +color256_b_138 :: Background256 +color256_b_138 = Background256 (Just (T.ColorNumber 138)) + +color256_b_139 :: Background256 +color256_b_139 = Background256 (Just (T.ColorNumber 139)) + +color256_b_140 :: Background256 +color256_b_140 = Background256 (Just (T.ColorNumber 140)) + +color256_b_141 :: Background256 +color256_b_141 = Background256 (Just (T.ColorNumber 141)) + +color256_b_142 :: Background256 +color256_b_142 = Background256 (Just (T.ColorNumber 142)) + +color256_b_143 :: Background256 +color256_b_143 = Background256 (Just (T.ColorNumber 143)) + +color256_b_144 :: Background256 +color256_b_144 = Background256 (Just (T.ColorNumber 144)) + +color256_b_145 :: Background256 +color256_b_145 = Background256 (Just (T.ColorNumber 145)) + +color256_b_146 :: Background256 +color256_b_146 = Background256 (Just (T.ColorNumber 146)) + +color256_b_147 :: Background256 +color256_b_147 = Background256 (Just (T.ColorNumber 147)) + +color256_b_148 :: Background256 +color256_b_148 = Background256 (Just (T.ColorNumber 148)) + +color256_b_149 :: Background256 +color256_b_149 = Background256 (Just (T.ColorNumber 149)) + +color256_b_150 :: Background256 +color256_b_150 = Background256 (Just (T.ColorNumber 150)) + +color256_b_151 :: Background256 +color256_b_151 = Background256 (Just (T.ColorNumber 151)) + +color256_b_152 :: Background256 +color256_b_152 = Background256 (Just (T.ColorNumber 152)) + +color256_b_153 :: Background256 +color256_b_153 = Background256 (Just (T.ColorNumber 153)) + +color256_b_154 :: Background256 +color256_b_154 = Background256 (Just (T.ColorNumber 154)) + +color256_b_155 :: Background256 +color256_b_155 = Background256 (Just (T.ColorNumber 155)) + +color256_b_156 :: Background256 +color256_b_156 = Background256 (Just (T.ColorNumber 156)) + +color256_b_157 :: Background256 +color256_b_157 = Background256 (Just (T.ColorNumber 157)) + +color256_b_158 :: Background256 +color256_b_158 = Background256 (Just (T.ColorNumber 158)) + +color256_b_159 :: Background256 +color256_b_159 = Background256 (Just (T.ColorNumber 159)) + +color256_b_160 :: Background256 +color256_b_160 = Background256 (Just (T.ColorNumber 160)) + +color256_b_161 :: Background256 +color256_b_161 = Background256 (Just (T.ColorNumber 161)) + +color256_b_162 :: Background256 +color256_b_162 = Background256 (Just (T.ColorNumber 162)) + +color256_b_163 :: Background256 +color256_b_163 = Background256 (Just (T.ColorNumber 163)) + +color256_b_164 :: Background256 +color256_b_164 = Background256 (Just (T.ColorNumber 164)) + +color256_b_165 :: Background256 +color256_b_165 = Background256 (Just (T.ColorNumber 165)) + +color256_b_166 :: Background256 +color256_b_166 = Background256 (Just (T.ColorNumber 166)) + +color256_b_167 :: Background256 +color256_b_167 = Background256 (Just (T.ColorNumber 167)) + +color256_b_168 :: Background256 +color256_b_168 = Background256 (Just (T.ColorNumber 168)) + +color256_b_169 :: Background256 +color256_b_169 = Background256 (Just (T.ColorNumber 169)) + +color256_b_170 :: Background256 +color256_b_170 = Background256 (Just (T.ColorNumber 170)) + +color256_b_171 :: Background256 +color256_b_171 = Background256 (Just (T.ColorNumber 171)) + +color256_b_172 :: Background256 +color256_b_172 = Background256 (Just (T.ColorNumber 172)) + +color256_b_173 :: Background256 +color256_b_173 = Background256 (Just (T.ColorNumber 173)) + +color256_b_174 :: Background256 +color256_b_174 = Background256 (Just (T.ColorNumber 174)) + +color256_b_175 :: Background256 +color256_b_175 = Background256 (Just (T.ColorNumber 175)) + +color256_b_176 :: Background256 +color256_b_176 = Background256 (Just (T.ColorNumber 176)) + +color256_b_177 :: Background256 +color256_b_177 = Background256 (Just (T.ColorNumber 177)) + +color256_b_178 :: Background256 +color256_b_178 = Background256 (Just (T.ColorNumber 178)) + +color256_b_179 :: Background256 +color256_b_179 = Background256 (Just (T.ColorNumber 179)) + +color256_b_180 :: Background256 +color256_b_180 = Background256 (Just (T.ColorNumber 180)) + +color256_b_181 :: Background256 +color256_b_181 = Background256 (Just (T.ColorNumber 181)) + +color256_b_182 :: Background256 +color256_b_182 = Background256 (Just (T.ColorNumber 182)) + +color256_b_183 :: Background256 +color256_b_183 = Background256 (Just (T.ColorNumber 183)) + +color256_b_184 :: Background256 +color256_b_184 = Background256 (Just (T.ColorNumber 184)) + +color256_b_185 :: Background256 +color256_b_185 = Background256 (Just (T.ColorNumber 185)) + +color256_b_186 :: Background256 +color256_b_186 = Background256 (Just (T.ColorNumber 186)) + +color256_b_187 :: Background256 +color256_b_187 = Background256 (Just (T.ColorNumber 187)) + +color256_b_188 :: Background256 +color256_b_188 = Background256 (Just (T.ColorNumber 188)) + +color256_b_189 :: Background256 +color256_b_189 = Background256 (Just (T.ColorNumber 189)) + +color256_b_190 :: Background256 +color256_b_190 = Background256 (Just (T.ColorNumber 190)) + +color256_b_191 :: Background256 +color256_b_191 = Background256 (Just (T.ColorNumber 191)) + +color256_b_192 :: Background256 +color256_b_192 = Background256 (Just (T.ColorNumber 192)) + +color256_b_193 :: Background256 +color256_b_193 = Background256 (Just (T.ColorNumber 193)) + +color256_b_194 :: Background256 +color256_b_194 = Background256 (Just (T.ColorNumber 194)) + +color256_b_195 :: Background256 +color256_b_195 = Background256 (Just (T.ColorNumber 195)) + +color256_b_196 :: Background256 +color256_b_196 = Background256 (Just (T.ColorNumber 196)) + +color256_b_197 :: Background256 +color256_b_197 = Background256 (Just (T.ColorNumber 197)) + +color256_b_198 :: Background256 +color256_b_198 = Background256 (Just (T.ColorNumber 198)) + +color256_b_199 :: Background256 +color256_b_199 = Background256 (Just (T.ColorNumber 199)) + +color256_b_200 :: Background256 +color256_b_200 = Background256 (Just (T.ColorNumber 200)) + +color256_b_201 :: Background256 +color256_b_201 = Background256 (Just (T.ColorNumber 201)) + +color256_b_202 :: Background256 +color256_b_202 = Background256 (Just (T.ColorNumber 202)) + +color256_b_203 :: Background256 +color256_b_203 = Background256 (Just (T.ColorNumber 203)) + +color256_b_204 :: Background256 +color256_b_204 = Background256 (Just (T.ColorNumber 204)) + +color256_b_205 :: Background256 +color256_b_205 = Background256 (Just (T.ColorNumber 205)) + +color256_b_206 :: Background256 +color256_b_206 = Background256 (Just (T.ColorNumber 206)) + +color256_b_207 :: Background256 +color256_b_207 = Background256 (Just (T.ColorNumber 207)) + +color256_b_208 :: Background256 +color256_b_208 = Background256 (Just (T.ColorNumber 208)) + +color256_b_209 :: Background256 +color256_b_209 = Background256 (Just (T.ColorNumber 209)) + +color256_b_210 :: Background256 +color256_b_210 = Background256 (Just (T.ColorNumber 210)) + +color256_b_211 :: Background256 +color256_b_211 = Background256 (Just (T.ColorNumber 211)) + +color256_b_212 :: Background256 +color256_b_212 = Background256 (Just (T.ColorNumber 212)) + +color256_b_213 :: Background256 +color256_b_213 = Background256 (Just (T.ColorNumber 213)) + +color256_b_214 :: Background256 +color256_b_214 = Background256 (Just (T.ColorNumber 214)) + +color256_b_215 :: Background256 +color256_b_215 = Background256 (Just (T.ColorNumber 215)) + +color256_b_216 :: Background256 +color256_b_216 = Background256 (Just (T.ColorNumber 216)) + +color256_b_217 :: Background256 +color256_b_217 = Background256 (Just (T.ColorNumber 217)) + +color256_b_218 :: Background256 +color256_b_218 = Background256 (Just (T.ColorNumber 218)) + +color256_b_219 :: Background256 +color256_b_219 = Background256 (Just (T.ColorNumber 219)) + +color256_b_220 :: Background256 +color256_b_220 = Background256 (Just (T.ColorNumber 220)) + +color256_b_221 :: Background256 +color256_b_221 = Background256 (Just (T.ColorNumber 221)) + +color256_b_222 :: Background256 +color256_b_222 = Background256 (Just (T.ColorNumber 222)) + +color256_b_223 :: Background256 +color256_b_223 = Background256 (Just (T.ColorNumber 223)) + +color256_b_224 :: Background256 +color256_b_224 = Background256 (Just (T.ColorNumber 224)) + +color256_b_225 :: Background256 +color256_b_225 = Background256 (Just (T.ColorNumber 225)) + +color256_b_226 :: Background256 +color256_b_226 = Background256 (Just (T.ColorNumber 226)) + +color256_b_227 :: Background256 +color256_b_227 = Background256 (Just (T.ColorNumber 227)) + +color256_b_228 :: Background256 +color256_b_228 = Background256 (Just (T.ColorNumber 228)) + +color256_b_229 :: Background256 +color256_b_229 = Background256 (Just (T.ColorNumber 229)) + +color256_b_230 :: Background256 +color256_b_230 = Background256 (Just (T.ColorNumber 230)) + +color256_b_231 :: Background256 +color256_b_231 = Background256 (Just (T.ColorNumber 231)) + +color256_b_232 :: Background256 +color256_b_232 = Background256 (Just (T.ColorNumber 232)) + +color256_b_233 :: Background256 +color256_b_233 = Background256 (Just (T.ColorNumber 233)) + +color256_b_234 :: Background256 +color256_b_234 = Background256 (Just (T.ColorNumber 234)) + +color256_b_235 :: Background256 +color256_b_235 = Background256 (Just (T.ColorNumber 235)) + +color256_b_236 :: Background256 +color256_b_236 = Background256 (Just (T.ColorNumber 236)) + +color256_b_237 :: Background256 +color256_b_237 = Background256 (Just (T.ColorNumber 237)) + +color256_b_238 :: Background256 +color256_b_238 = Background256 (Just (T.ColorNumber 238)) + +color256_b_239 :: Background256 +color256_b_239 = Background256 (Just (T.ColorNumber 239)) + +color256_b_240 :: Background256 +color256_b_240 = Background256 (Just (T.ColorNumber 240)) + +color256_b_241 :: Background256 +color256_b_241 = Background256 (Just (T.ColorNumber 241)) + +color256_b_242 :: Background256 +color256_b_242 = Background256 (Just (T.ColorNumber 242)) + +color256_b_243 :: Background256 +color256_b_243 = Background256 (Just (T.ColorNumber 243)) + +color256_b_244 :: Background256 +color256_b_244 = Background256 (Just (T.ColorNumber 244)) + +color256_b_245 :: Background256 +color256_b_245 = Background256 (Just (T.ColorNumber 245)) + +color256_b_246 :: Background256 +color256_b_246 = Background256 (Just (T.ColorNumber 246)) + +color256_b_247 :: Background256 +color256_b_247 = Background256 (Just (T.ColorNumber 247)) + +color256_b_248 :: Background256 +color256_b_248 = Background256 (Just (T.ColorNumber 248)) + +color256_b_249 :: Background256 +color256_b_249 = Background256 (Just (T.ColorNumber 249)) + +color256_b_250 :: Background256 +color256_b_250 = Background256 (Just (T.ColorNumber 250)) + +color256_b_251 :: Background256 +color256_b_251 = Background256 (Just (T.ColorNumber 251)) + +color256_b_252 :: Background256 +color256_b_252 = Background256 (Just (T.ColorNumber 252)) + +color256_b_253 :: Background256 +color256_b_253 = Background256 (Just (T.ColorNumber 253)) + +color256_b_254 :: Background256 +color256_b_254 = Background256 (Just (T.ColorNumber 254)) + +color256_b_255 :: Background256 +color256_b_255 = Background256 (Just (T.ColorNumber 255)) + diff --git a/Penny/Steel/Chunk/Switch.hs b/Penny/Steel/Chunk/Switch.hs new file mode 100644 --- /dev/null +++ b/Penny/Steel/Chunk/Switch.hs @@ -0,0 +1,26 @@ +module Penny.Steel.Chunk.Switch where + +import qualified Penny.Steel.Chunk as C + +-- | Switch the foreground colors for new ones. +switchForeground :: + C.Foreground8 + -> C.Foreground256 + -> C.TextSpec + -> C.TextSpec +switchForeground c8 c256 ts = ts' where + ts' = C.TextSpec s8' s256' + s8' = (C.style8 ts) { C.foreground8 = c8 } + s256' = (C.style256 ts) { C.foreground256 = c256 } + +-- | Switch the background colors for new ones. +switchBackground :: + C.Background8 + -> C.Background256 + -> C.TextSpec + -> C.TextSpec +switchBackground c8 c256 ts = ts' where + ts' = C.TextSpec s8' s256' + s8' = (C.style8 ts) { C.background8 = c8 } + s256' = (C.style256 ts) { C.background256 = c256 } + diff --git a/Penny/Steel/Expressions.hs b/Penny/Steel/Expressions.hs new file mode 100644 --- /dev/null +++ b/Penny/Steel/Expressions.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +module Penny.Steel.Expressions + ( ExprDesc(..) + , Error + , Token + , operand + , opAnd + , opOr + , opNot + , openParen + , closeParen + , parseExpression + ) where + +import Data.Either (partitionEithers) +import qualified Data.Text as X +import qualified Penny.Steel.Expressions.Infix as I +import qualified Penny.Steel.Expressions.RPN as R +import qualified Penny.Steel.Pdct as P +import qualified Control.Monad.Exception.Synchronous as Ex + +-- | A single type for both RPN tokens and infix tokens. +newtype Token a = Token { unToken :: I.InfixToken a } +type Error = X.Text + +operand :: P.Pdct a -> Token a +operand p = Token (I.TokRPN (R.TokOperand p)) + +opAnd :: Token a +opAnd = Token (I.TokRPN (R.TokOperator R.OpAnd)) + +opOr :: Token a +opOr = Token (I.TokRPN (R.TokOperator R.OpOr)) + +opNot :: Token a +opNot = Token (I.TokRPN (R.TokOperator R.OpNot)) + +openParen :: Token a +openParen = Token (I.TokParen I.Open) + +closeParen :: Token a +closeParen = Token (I.TokParen I.Close) + +data ExprDesc + = Infix + | RPN + deriving (Eq, Show) + +toksToRPN :: [Token a] -> Maybe [R.RPNToken a] +toksToRPN toks + = let toEither t = case unToken t of + I.TokRPN tok -> Right tok + _ -> Left () + in case partitionEithers . map toEither $ toks of + ([], xs) -> return xs + _ -> Nothing + +parseExpression + :: ExprDesc + -> [Token a] + -> Ex.Exceptional Error (P.Pdct a) +parseExpression e toks = do + rpnToks <- case e of + Infix -> Ex.fromMaybe "unbalanced parentheses\n" + . I.createRPN + . map unToken + $ toks + RPN -> Ex.fromMaybe "parentheses in an RPN expression\n" + $ toksToRPN toks + R.pushTokens rpnToks diff --git a/Penny/Steel/Expressions/Infix.hs b/Penny/Steel/Expressions/Infix.hs new file mode 100644 --- /dev/null +++ b/Penny/Steel/Expressions/Infix.hs @@ -0,0 +1,126 @@ +module Penny.Steel.Expressions.Infix + ( InfixToken (..) + , Paren(..) + , createRPN + ) where + +import qualified Penny.Steel.Expressions.RPN as R +import qualified Data.Foldable as Fdbl + +data InfixToken a + = TokRPN (R.RPNToken a) + | TokParen Paren + +data Paren = Open | Close + +-- | Values on the operator stack. +data OpStackVal + = StkOp R.Operator + | StkOpenParen + +-- In the shunting yard algorithm, the output sequence is a queue. The +-- first values to go into the output sequence are the first to be +-- processed by the RPN parser. In this module, the output sequence is +-- implemented as a list stack, which means it must be reversed upon +-- output (this is done in the createRPN function.) + +processInfixToken + :: ([OpStackVal], [R.RPNToken a]) + -> InfixToken a + -> Maybe ([OpStackVal], [R.RPNToken a]) +processInfixToken (os, ts) t = case t of + TokRPN tok -> return $ processRPNToken (os, ts) tok + TokParen p -> processParen (os, ts) p + + +-- | If the token is a binary operator A, then: +-- +-- If A is left associative, while there is an operator B of higher or +-- equal precedence than A at the top of the stack, pop B off the +-- stack and append it to the output. +-- +-- If A is right associative, while there is an operator B of higher +-- precedence than A at the top of the stack, pop B off the stack and +-- append it to the output. +-- +-- Push A onto the stack. +-- +-- If a token is an operand, append it to the postfix output. +-- +-- And has higher precedence than Or. +processRPNToken + :: ([OpStackVal], [R.RPNToken a]) + -> R.RPNToken a + -> ([OpStackVal], [R.RPNToken a]) +processRPNToken (os, ts) t = case t of + p@(R.TokOperand _) -> (os, p:ts) + R.TokOperator d -> case d of + R.OpNot -> (StkOp R.OpNot : os, ts) + R.OpAnd -> (StkOp R.OpAnd : os, ts) + R.OpOr -> + let (os', ts') = popper os ts + in (StkOp R.OpOr : os', ts') + +-- | Pops operators from the operator stack and places then in the +-- output queue, as long as there is an And operator on the top of the +-- operator stack. +popper :: [OpStackVal] -> [R.RPNToken a] -> ([OpStackVal], [R.RPNToken a]) +popper os ts = case os of + [] -> (os, ts) + x:xs -> case x of + StkOp R.OpAnd -> + let os' = xs + ts' = R.TokOperator R.OpAnd : ts + in popper os' ts' + _ -> (os, ts) + +-- | Pops operators off the operator stack and onto the output stack +-- as long as the top of the operator stack is not an open +-- parenthesis. When an open parenthesis is encountered, pop that too, +-- but not onto the output stack. Fails if the stack has no open +-- parentheses. +popThroughOpen + :: ([OpStackVal], [R.RPNToken a]) + -> Maybe ([OpStackVal], [R.RPNToken a]) +popThroughOpen (os, ts) = case os of + [] -> Nothing + v:vs -> case v of + StkOp op -> popThroughOpen (vs, R.TokOperator op : ts) + StkOpenParen -> return (vs, ts) + +-- | Places an open parenthesis on the top of the operator stack. For +-- Close parenthesis, pops operators off the operator stack through +-- the next open parenthesis on the operator stack. +processParen + :: ([OpStackVal], [R.RPNToken a]) + -> Paren + -> Maybe ([OpStackVal], [R.RPNToken a]) +processParen (os, ts) p = case p of + Open -> Just (StkOpenParen : os, ts) + Close -> popThroughOpen (os, ts) + +-- | Creates an RPN expression from an infix one. Fails only if there +-- are mismatched parentheses. It is possible to create a nonsensical +-- RPN expression; the RPN parser must catch this. +createRPN + :: Fdbl.Foldable f + => f (InfixToken a) + -- ^ The input tokens, with the beginning of the expression on the + -- left side of the sequence. + + -> Maybe [R.RPNToken a] + -- ^ The output sequence of tokens, with the beginning of the + -- expression on the left side of the list. +createRPN ts = do + (stack, toks) <- Fdbl.foldlM processInfixToken ([], []) ts + fmap reverse $ popRemainingOperators stack toks + +-- | Pops remaining items off operator stack. Fails if there is an +-- open paren left on the stack, as this indicates mismatched +-- parenthesis. +popRemainingOperators :: [OpStackVal] -> [R.RPNToken a] -> Maybe [R.RPNToken a] +popRemainingOperators os ts = case os of + [] -> return ts + x:xs -> case x of + StkOp op -> popRemainingOperators xs (R.TokOperator op : ts) + StkOpenParen -> Nothing diff --git a/Penny/Steel/Expressions/RPN.hs b/Penny/Steel/Expressions/RPN.hs new file mode 100644 --- /dev/null +++ b/Penny/Steel/Expressions/RPN.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Postfix, or RPN, expression parsing. +-- +-- This module parses RPN expressions where the operands are +-- predicates and the operators are one of @and@, @or@, or @not@, +-- where @and@ and @or@ are binary and @not@ is unary. +module Penny.Steel.Expressions.RPN where + +import qualified Control.Monad.Exception.Synchronous as Ex +import qualified Data.Foldable as Fdbl +import qualified Penny.Steel.Pdct as P +import Penny.Steel.Pdct ((&&&), (|||)) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as X +import qualified Penny.Steel.Chunk as C + +type Error = Text + +data RPNToken a + = TokOperand (P.Pdct a) + | TokOperator Operator + +data Operator + = OpAnd + | OpOr + | OpNot + deriving Show + +pushOperand :: P.Pdct a -> [P.Pdct a] -> [P.Pdct a] +pushOperand p ts = p : ts + +pushOperator + :: Operator + -> [P.Pdct a] + -> Ex.Exceptional Error [P.Pdct a] +pushOperator o ts = case o of + OpAnd -> case ts of + x:y:zs -> return $ (y &&& x) : zs + _ -> Ex.throw $ err "and" + OpOr -> case ts of + x:y:zs -> return $ (y ||| x) : zs + _ -> Ex.throw $ err "or" + OpNot -> case ts of + x:zs -> return $ P.not x : zs + _ -> Ex.throw $ err "not" + where + err x = "insufficient operands to apply \"" <> x + <> "\" operator\n" + +pushToken + :: [P.Pdct a] + -> RPNToken a + -> Ex.Exceptional Error [P.Pdct a] +pushToken ts t = case t of + TokOperand p -> return $ pushOperand p ts + TokOperator o -> pushOperator o ts + +pushTokens + :: Fdbl.Foldable f + => f (RPNToken a) + -> Ex.Exceptional Error (P.Pdct a) +pushTokens ts = do + trees <- Fdbl.foldlM pushToken [] ts + case trees of + [] -> Ex.throw $ "bad expression: no operands left on the stack\n" + x:[] -> return x + xs -> Ex.throw + $ "bad expression: multiple operands left on the stack:\n" + <> ( X.concat + . map C.chunkText + . concatMap (P.showPdct 4 0) + $ xs ) + diff --git a/Penny/Steel/NestedMap.hs b/Penny/Steel/NestedMap.hs new file mode 100644 --- /dev/null +++ b/Penny/Steel/NestedMap.hs @@ -0,0 +1,275 @@ +-- | A nested map. The values in each NestedMap are tuples, with the +-- first element of the tuple being a label that you select and the +-- second value being another NestedMap. Functions are provided so you +-- may query the map at any level or insert new labels (and, +-- therefore, new keys) at any level. +module Penny.Steel.NestedMap ( + NestedMap ( NestedMap, unNestedMap ), + empty, + relabel, + descend, + insert, + cumulativeTotal, + traverse, + traverseWithTrail, + toForest ) where + +import Control.Applicative ((<*>), (<$>)) +import Data.Map ( Map ) +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import qualified Data.Tree as E +import qualified Data.Map as M +import Data.Monoid ( Monoid, mconcat, mappend, mempty ) + +newtype NestedMap k l = + NestedMap { unNestedMap :: Map k (l, NestedMap k l) } + deriving (Eq, Show, Ord) + +instance Functor (NestedMap k) where + fmap f (NestedMap m) = let + g (l, s) = (f l, fmap f s) + in NestedMap $ M.map g m + +instance (Ord k) => F.Foldable (NestedMap k) where + foldMap = T.foldMapDefault + +instance (Ord k) => T.Traversable (NestedMap k) where + -- traverse :: Applicative f + -- => (a -> f b) + -- -> NestedMap k a + -- -> f (NestedMap k b) + traverse f (NestedMap m) = let + f' (l, m') = (,) <$> f l <*> T.traverse f m' + in NestedMap <$> T.traverse f' m + +-- | An empty NestedMap. +empty :: NestedMap k l +empty = NestedMap (M.empty) + +-- | Helper function for relabel. For a given key and function +-- that modifies the label, return the new submap to insert into the +-- given map. Does not actually insert the submap though. That way, +-- relabel can then modify the returned submap before +-- inserting it into the mother map with the given label. +newSubmap :: + (Ord k) + => NestedMap k l + -> k + -> (Maybe l -> l) + -> (l, NestedMap k l) +newSubmap (NestedMap m) k g = (newL, NestedMap newM) where + (newL, newM) = case M.lookup k m of + Nothing -> (g Nothing, M.empty) + (Just (oldL, (NestedMap oldM))) -> (g (Just oldL), oldM) + +-- | Descends through a NestedMap with successive keys in the list, +-- proceeding from left to right. At any given level, if the key +-- given does not already exist, then inserts an empty submap and +-- applies the given label modification function to Nothing to +-- determine the new label. If the given key already does exist, then +-- preserves the existing submap and applies the given label +-- modification function to (Just oldlabel) to determine the new +-- label. +relabel :: + (Ord k) + => NestedMap k l + -> [(k, (Maybe l -> l))] + -> NestedMap k l +relabel m [] = m +relabel (NestedMap m) ((k, f):vs) = let + (newL, newM) = newSubmap (NestedMap m) k f + newM' = relabel newM vs + in NestedMap $ M.insert k (newL, newM') m + +-- | Given a list of keys, find the key that is furthest down in the +-- map that matches the requested list of keys. Returns [(k, l)], +-- where the first item in the list is the topmost key found and its +-- matching label, and the last item in the list is the deepest key +-- found and its matching label. (Often you will be most interested +-- in the deepest key.) +descend :: + Ord k + => [k] + -> NestedMap k l + -> [(k, l)] +descend keys (NestedMap mi) = descend' keys mi where + descend' [] _ = [] + descend' (k:ks) m = case M.lookup k m of + Nothing -> [] + Just (l, (NestedMap im)) -> (k, l) : descend' ks im + + +-- | Descends through the NestedMap one level at a time, proceeding +-- key by key from left to right through the list of keys given. At +-- the last key, appends the given label to the labels already +-- present; if no label is present, uses mempty and mappend to create +-- a new label. If the list of keys is empty, does nothing. +insert :: + (Ord k, Monoid l) + => NestedMap k l + -> [k] + -> l + -> NestedMap k l +insert m [] _ = m +insert m ks l = relabel m ts where + ts = firsts ++ [end] + firsts = map (\k -> (k, keepOld)) (init ks) where + keepOld mk = case mk of + (Just old) -> old + Nothing -> mempty + end = (key, newL) where + key = last ks + newL mk = case mk of + (Just old) -> old `mappend` l + Nothing -> mempty `mappend` l + +totalMap :: + (Monoid l) + => NestedMap k l + -> l +totalMap (NestedMap m) = + if M.null m + then mempty + else mconcat . map totalTuple . M.elems $ m + +totalTuple :: + (Monoid l) + => (l, NestedMap k l) + -> l +totalTuple (l, (NestedMap top)) = + if M.null top + then l + else mappend l (totalMap (NestedMap top)) + +remapWithTotals :: + (Monoid l) + => NestedMap k l + -> NestedMap k l +remapWithTotals (NestedMap top) = + if M.null top + then NestedMap M.empty + else NestedMap $ M.map f top where + f a@(_, m) = (totalTuple a, remapWithTotals m) + +-- | Leaves all keys of the map and submaps the same. Changes each +-- label to reflect the total of that label and of all the labels of +-- the maps within the NestedMap accompanying the label. Returns the +-- total of the entire NestedMap. +cumulativeTotal :: + (Monoid l) + => NestedMap k l + -> (l, NestedMap k l) +cumulativeTotal m = (totalMap m, remapWithTotals m) + +-- | Supply a function that takes a key, a label, and a +-- NestedMap. traverse will traverse the NestedMap. For each (label, +-- NestedMap) pair, traverse will first apply the given function to +-- the label before descending through the NestedMap. The function is +-- applied to the present key and label and the accompanying +-- NestedMap. The function you supply must return a Maybe. If the +-- result is Nothing, then the pair is deleted as a value from its +-- parent NestedMap. If the result is (Just s), then the label of this +-- level of the NestedMap is changed to s before descending to the +-- next level of the NestedMap. +-- +-- All this is done in a monad, so you can carry out arbitrary side +-- effects such as inspecting or changing a state or doing IO. If you +-- don't need a monad, just use Identity. +-- +-- Thus this function can be used to inspect, modify, and prune a +-- NestedMap. +-- +-- For a simpler traverse that does not provide you with so much +-- information, NestedMap is also an instance of Data.Traversable. +traverse :: + (Monad m, Ord k) + => (k -> l -> NestedMap k l -> m (Maybe a)) + -> NestedMap k l + -> m (NestedMap k a) +traverse f m = traverseWithTrail (\_ -> f) m + +-- | Like traverse, but the supplied function is also applied to a +-- list that tells it about the levels of NestedMap that are parents +-- to this NestedMap. +traverseWithTrail :: + (Monad m, Ord k) + => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) ) + -> NestedMap k l + -> m (NestedMap k a) +traverseWithTrail f = traverseWithTrail' f [] + +traverseWithTrail' :: + (Monad m, Ord k) + => ([(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a)) + -> [(k, l)] + -> NestedMap k l + -> m (NestedMap k a) +traverseWithTrail' f ts (NestedMap m) = + if M.null m + then return $ NestedMap M.empty + else do + let ps = M.assocs m + mlsMaybes <- mapM (traversePairWithTrail f ts) ps + let ps' = zip (M.keys m) mlsMaybes + folder (k, ma) rs = case ma of + (Just r) -> (k, r):rs + Nothing -> rs + ps'' = foldr folder [] ps' + return (NestedMap (M.fromList ps'')) + +traversePairWithTrail :: + (Monad m, Ord k) + => ( [(k, l)] -> k -> l -> NestedMap k l -> m (Maybe a) ) + -> [(k, l)] + -> (k, (l, NestedMap k l)) + -> m (Maybe (a, NestedMap k a)) +traversePairWithTrail f ls (k, (l, m)) = do + ma <- f ls k l m + case ma of + Nothing -> return Nothing + (Just a) -> do + m' <- traverseWithTrail' f ((k, l):ls) m + return (Just (a, m')) + +-- | Convert a NestedMap to a Forest. +toForest :: Ord k => NestedMap k l -> E.Forest (k, l) +toForest = map toNode . M.assocs . unNestedMap + where + toNode (k, (l, m)) = E.Node (k, l) (toForest m) + +-- For testing +_new :: (k, l) -> (k, (Maybe l -> l)) +_new (k, l) = (k, const l) + +_map1, _map2, _map3, _map4 :: NestedMap Int String +_map1 = NestedMap M.empty +_map2 = relabel _map1 [_new (5, "hello"), _new (66, "goodbye"), _new (777, "yeah")] +_map3 = relabel _map2 [_new (6, "what"), _new (77, "zeke"), _new (888, "foo")] +_map4 = relabel _map3 + [ (6, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "_new")) + , (77, (\m -> case m of Nothing -> "_new"; (Just s) -> s ++ "more _new")) ] + +_printer :: Int -> String -> a -> IO (Maybe ()) +_printer i s _ = do + putStrLn (show i) + putStrLn s + return $ Just () + +_printerWithTrail :: [(Int, String)] -> Int -> String -> a -> IO (Maybe ()) +_printerWithTrail ps n str _ = do + let ptr (i, s) = putStr ("(" ++ show i ++ ", " ++ s ++ ") ") + mapM_ ptr . reverse $ ps + ptr (n, str) + putStrLn "" + return $ Just () + +_showMap4 :: IO () +_showMap4 = do + _ <- traverse _printer _map4 + return () + +_showMapWithTrail :: IO () +_showMapWithTrail = do + _ <- traverseWithTrail _printerWithTrail _map4 + return () diff --git a/Penny/Steel/Pdct.hs b/Penny/Steel/Pdct.hs new file mode 100644 --- /dev/null +++ b/Penny/Steel/Pdct.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Trees of predicates. +-- +-- Exports names which conflict with Prelude names, so you probably +-- want to import this module qualified. + +module Penny.Steel.Pdct + ( Pdct(..) + , always + , never + , and + , or + , not + , operand + , neverFalse + , neverTrue + , (&&&) + , (|||) + , Level + , IndentAmt + , ShowDiscards + , showPdct + , rename + , eval + , evaluate + , boxPdct + , boxNode + ) where + +import Control.Applicative ((<*>)) +import Data.Maybe (fromMaybe, isJust, catMaybes) +import Data.Text (Text) +import qualified Data.Text as X +import Data.Monoid ((<>), mconcat, mempty) +import qualified Penny.Steel.Chunk as C +import qualified Penny.Steel.Chunk.Switch as Sw +import Prelude hiding (not, and, or) +import qualified Prelude + +type Label = Text + +-- | A tree of predicates. +data Pdct a = Pdct Label (Node a) + +instance Show (Pdct a) where + show _ = "predicate" + +-- | Renames the top level of the Pdct. The function you pass will be +-- applied to the old name. +rename :: (Text -> Text) -> Pdct a -> Pdct a +rename f (Pdct l n) = Pdct (f l) n + +data Node a + = And [Pdct a] + -- ^ None of the Pdct in list may be Just False. An empty list or + -- list with only Nothing is Just True. + + | Or [Pdct a] + -- ^ At least one of the Pdct in the list must be Just True. An + -- empty list or list with only Nothing is Just False. + + | Not (Pdct a) + -- ^ Just True is Just False and vice versa; Nothing remains Nothing. + + | NeverFalse (Pdct a) + -- ^ Just True if the child is Just True; Nothing otherwise. + + | NeverTrue (Pdct a) + -- ^ Just False if the child is Just False; Nothing otherwise. + + | Operand (a -> Maybe Bool) + +-- | Given a function that un-boxes values of type b, changes a Node +-- from type a to type b. +boxNode + :: (b -> a) + -> Node a + -> Node b +boxNode f n = case n of + And ls -> And $ map (boxPdct f) ls + Or ls -> Or $ map (boxPdct f) ls + Not o -> Not $ boxPdct f o + NeverFalse o -> NeverFalse $ boxPdct f o + NeverTrue o -> NeverTrue $ boxPdct f o + Operand g -> Operand $ \b -> g (f b) + + +-- | Given a function that un-boxes values of type b, changes a Pdct +-- from type a to type b. +boxPdct + :: (b -> a) + -> Pdct a + -> Pdct b +boxPdct f (Pdct l n) = Pdct l $ boxNode f n + +and :: [Pdct a] -> Pdct a +and = Pdct "and" . And + +or :: [Pdct a] -> Pdct a +or = Pdct "or" . Or + +not :: Pdct a -> Pdct a +not = Pdct "not" . Not + +-- | Creates a new operand. The Pdct is Just True or Just False, never +-- Nothing. +operand :: Text -> (a -> Bool) -> Pdct a +operand t = Pdct t . Operand . fmap Just + +-- | Turns an existing Pdct to one that never says False. If the +-- underlying predicate returns Just True, the new Pdct also returns +-- Just True. Otherwise, the Pdct returns Nothing. Has no effect on +-- non-Operand Pdct. +neverFalse :: Pdct a -> Pdct a +neverFalse = Pdct "never False" . NeverFalse + +-- | Turns an existing Pdct to one that never says True. If the +-- underlying predicate returns Just False, the new Pdct also returns +-- Just False. Otherwise, the Pdct returns Nothing. Has no effect on +-- non-Operand Pdct. +neverTrue :: Pdct a -> Pdct a +neverTrue = Pdct "never True" . NeverTrue + + +-- | Returns a tree that is always True. +always :: Pdct a +always = Pdct "always True" (Operand (const (Just True))) + +-- | Returns a tree that is always False. +never :: Pdct a +never = Pdct "always False" (Operand (const (Just False))) + +(&&&) :: Pdct a -> Pdct a -> Pdct a +(&&&) x y = Pdct "and" (And [x, y]) +infixr 3 &&& + +(|||) :: Pdct a -> Pdct a -> Pdct a +(|||) x y = Pdct "or" (Or [x, y]) +infixr 2 ||| + +type Level = Int +type IndentAmt = Int + +-- | Indents text, and adds a newline to the end. +indent :: IndentAmt -> Level -> [C.Chunk] -> [C.Chunk] +indent amt lvl cs = idt : (cs ++ [nl]) + where + idt = C.chunk C.defaultTextSpec + (X.replicate (lvl * amt) " ") + nl = C.chunk C.defaultTextSpec (X.singleton '\n') + +defaultChunk :: Text -> C.Chunk +defaultChunk = C.chunk C.defaultTextSpec + +showPdct :: IndentAmt -> Level -> Pdct a -> [C.Chunk] +showPdct amt lvl (Pdct l pd) = case pd of + And ls -> indent amt lvl [defaultChunk l] + <> mconcat (map (showPdct amt (lvl + 1)) ls) + Or ls -> indent amt lvl [defaultChunk l] + <> mconcat (map (showPdct amt (lvl + 1)) ls) + Not t -> indent amt lvl [defaultChunk l] + <> showPdct amt (lvl + 1) t + NeverFalse t -> indent amt lvl [defaultChunk l] + <> showPdct amt (lvl + 1) t + NeverTrue t -> indent amt lvl [defaultChunk l] + <> showPdct amt (lvl + 1) t + Operand _ -> indent amt lvl [defaultChunk l] + + +labelBool :: Text -> Maybe Bool -> [C.Chunk] +labelBool t b = [open, trueFalse, close, blank, txt] + where + trueFalse = C.chunk ts tf + (tf, ts) = case b of + Nothing -> ("discard", Sw.switchForeground C.color8_f_yellow + C.color256_f_3 C.defaultTextSpec) + Just bl -> if bl + then ("TRUE", Sw.switchForeground C.color8_f_green + C.color256_f_2 C.defaultTextSpec) + else ("FALSE", Sw.switchForeground C.color8_f_red + C.color256_f_1 C.defaultTextSpec) + open = C.chunk C.defaultTextSpec "[" + close = C.chunk C.defaultTextSpec "]" + blank = C.chunk C.defaultTextSpec (X.replicate blankLen " ") + blankLen = X.length "discard" - X.length tf + 1 + txt = C.chunk C.defaultTextSpec t + +type ShowDiscards = Bool + +-- | Evaluates a Pdct. +eval :: Pdct a -> a -> Maybe Bool +eval (Pdct _ n) a = case n of + And ps -> Just . Prelude.and . catMaybes $ [flip eval a] <*> ps + Or ps -> Just . Prelude.or . catMaybes $ [flip eval a] <*> ps + Not p -> fmap Prelude.not $ eval p a + NeverFalse p -> case eval p a of + Nothing -> Nothing + Just b -> if Prelude.not b then Nothing else Just b + NeverTrue p -> case eval p a of + Nothing -> Nothing + Just b -> if b then Nothing else Just b + Operand f -> f a + +-- | Verbosely evaluates a Pdct. +evaluate + :: IndentAmt + -- ^ Indent each level by this many spaces. + + -> ShowDiscards + -- ^ If True, show discarded test results; otherwise, hide + -- them. + + -> a + -- ^ The subject to evaluate + + -> Level + -- ^ How many levels deep in the tree we are. Start at level 0. This + -- determines the level of indentation. + -> Pdct a + -> (Maybe Bool, [C.Chunk]) +evaluate i sd a lvl (Pdct l pd) = case pd of + + And ps -> let (resBool, resTxt) = evalAnd i sd a (lvl + 1) ps + txt = indent i lvl (labelBool l (Just resBool)) + <> resTxt + in (Just resBool, txt) + + Or ps -> let (resBool, resTxt) = evalOr i sd a (lvl + 1) ps + txt = indent i lvl (labelBool l (Just resBool)) + <> resTxt + in (Just resBool, txt) + + Not p -> let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p + thisMayBool = fmap Prelude.not childMayBool + thisTxt = indent i lvl (labelBool l thisMayBool) + txt = if sd || isJust thisMayBool + then thisTxt <> childTxt else mempty + in (thisMayBool, txt) + + NeverFalse p -> + let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p + thisMayBool = case childMayBool of + Nothing -> Nothing + Just b -> if Prelude.not b then Nothing else Just b + thisTxt = indent i lvl (labelBool l thisMayBool) + txt = if sd || isJust thisMayBool + then thisTxt <> childTxt else mempty + in (thisMayBool, txt) + + NeverTrue p -> + let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p + thisMayBool = case childMayBool of + Nothing -> Nothing + Just b -> if b then Nothing else Just b + thisTxt = indent i lvl (labelBool l thisMayBool) + txt = if sd || isJust thisMayBool + then thisTxt <> childTxt else mempty + in (thisMayBool, txt) + + Operand p -> let res = p a + txt = indent i lvl (labelBool l res) + in (res, if sd || isJust res then txt else mempty) + +evalAnd :: IndentAmt -> ShowDiscards -> a + -> Level -> [Pdct a] -> (Bool, [C.Chunk]) +evalAnd i sd a l ts = (Prelude.not foundFalse, txt) + where + (foundFalse, txt) = go ts (False, mempty) + go [] p = p + go (x:xs) (fndFalse, acc) = + if fndFalse + then (fndFalse, acc <> indent i l + [defaultChunk "(short circuit)"]) + else let (res, cTxt) = evaluate i sd a l x + fndFalse' = maybe False Prelude.not res + in go xs (fndFalse', acc <> cTxt) + +evalOr :: IndentAmt -> ShowDiscards -> a + -> Level -> [Pdct a] -> (Bool, [C.Chunk]) +evalOr i sd a l ts = (foundTrue, txt) + where + (foundTrue, txt) = go ts (False, mempty) + go [] p = p + go (x:xs) (fnd, acc) = + if fnd + then (fnd, acc <> indent i l + [defaultChunk "(short circuit)"]) + else let (res, cTxt) = evaluate i sd a l x + fnd' = fromMaybe False res + in go xs (fnd', acc <> cTxt) + diff --git a/Penny/Steel/TestTree.hs b/Penny/Steel/TestTree.hs new file mode 100644 --- /dev/null +++ b/Penny/Steel/TestTree.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Penny.Steel.TestTree where + +import Data.Maybe (isJust) +import qualified Data.Text as X +import Data.Text (Text) +import qualified Data.List.Split as Sp + +import qualified Penny.Steel.Chunk as C +import qualified Penny.Steel.Chunk.Switch as Sw +import qualified Penny.Steel.Pdct as Pt + +-- +-- Types +-- + +type Pass = Bool +type Name = Text + +-- | A tree of tests. On evaluation of the tree, the name is not shown +-- for tests (it is only shown for groups.) However, the name is used +-- when the tree is displayed statically, without evaluation. +data TestTree a = TestTree Name (Payload a) + +data Payload a + = Group [TestTree a] + | Test (TestFunc a) + +type TestFunc a + = Pt.IndentAmt + -> PassVerbosity + -> FailVerbosity + -> [a] + -> Pt.Level + -> (Pass, [C.Chunk]) + + +group :: Name -> [TestTree a] -> TestTree a +group n ts = TestTree n (Group ts) + +test :: Name -> TestFunc a -> TestTree a +test n t = TestTree n (Test t) + +type PassVerbosity = Verbosity +type FailVerbosity = Verbosity + +data Verbosity + = Silent + -- ^ Show nothing at all + + | PassFail + -- ^ Show only whether the test passed or failed + + | FalseSubjects + -- ^ Show subjects that are False + + | TrueSubjects + -- ^ Show subjects that are True. (This is cumulative, so False + -- subjects are shown too.) + + | DiscardedSubjects + + | DiscardedPredicates + -- ^ Show discarded results + deriving (Eq, Ord, Show) + +-- +-- Helper functions +-- + + +-- | Determines whether to show a subject, and shows it. +showSubject + :: (a -> X.Text) + -> Verbosity + -> Pt.IndentAmt + -> Pt.Level + -> Pt.Pdct a + -> (a, Maybe Bool) + -> [C.Chunk] +showSubject swr v i l p (s, b) = + let (showSubj, showDisc) = isSubjectAndDiscardsShown v b + renamer txt = X.concat [swr s, " - ", txt] + renamed = Pt.rename renamer p + in if showSubj + then snd $ Pt.evaluate i showDisc s l renamed + else [] + +-- | Given a Verbosity and a Maybe Boolean indicating whether a +-- subject is True, False, or a discard, returns whether to show the +-- subject and whether to show the discards contained within the +-- subject. +isSubjectAndDiscardsShown :: Verbosity -> Maybe Bool -> (Bool, Bool) +isSubjectAndDiscardsShown v b = case v of + Silent -> (False, False) + PassFail -> (False, False) + FalseSubjects -> (not . isTrue $ b, False) + TrueSubjects -> (isJust b, False) + DiscardedSubjects -> (True, False) + DiscardedPredicates -> (True, True) + + +showTestTitle :: Pt.IndentAmt -> Pt.Level -> Name -> Pass -> [C.Chunk] +showTestTitle i l n p = [idt, open, passFail, close, blank, txt, nl] + where + passFail = C.chunk ts tf + idt = C.chunk C.defaultTextSpec (X.replicate (i * l) " ") + nl = C.chunk C.defaultTextSpec "\n" + (tf, ts) = + if p + then ("PASS", Sw.switchForeground C.color8_f_green + C.color256_f_2 C.defaultTextSpec) + else ("FAIL", Sw.switchForeground C.color8_f_red + C.color256_f_1 C.defaultTextSpec) + open = C.chunk C.defaultTextSpec "[" + close = C.chunk C.defaultTextSpec "]" + blank = C.chunk C.defaultTextSpec (X.singleton ' ') + txt = C.chunk C.defaultTextSpec n + +isTrue :: Maybe Bool -> Bool +isTrue = maybe False id + +-- +-- Tests +-- + +-- | Passes if every subject is True. +eachSubjectMustBeTrue + :: Name + -> (a -> Text) + -> Pt.Pdct a + -> TestTree a +eachSubjectMustBeTrue n swr p = TestTree n (Test tf) + where + tf i pv fv as lvl = (pass, cks) + where + rslts = zip as (map (Pt.eval p) as) + pass = all (isTrue . snd) rslts + v = if pass then pv else fv + cks = tit ++ subjectChunks + tit = if v == Silent then [] else showTestTitle i lvl n pass + subjectChunks = + concatMap (showSubject swr v i (lvl + 1) p) rslts + +-- | Passes if at least n subjects are True. +seriesAtLeastN + :: Name + -> (a -> X.Text) + -> Int + -> Pt.Pdct a + -> TestTree a +seriesAtLeastN n swr count p = TestTree n (Test tf) + where + tf idnt pv fv as l = (pass, cks) + where + pd (_, res) = isTrue res + resultList = take count + . Sp.split (Sp.keepDelimsR (Sp.whenElt pd)) + $ zip as (map (Pt.eval p) as) + pass = length resultList >= count + v = if pass then pv else fv + cks = tit ++ subjectChunks + tit = if v == Silent then [] else showTestTitle idnt l n pass + subjectChunks = + concatMap (showSubject swr v idnt (l + 1) p) . concat $ resultList + +indent :: Pt.IndentAmt -> Pt.Level -> Text -> C.Chunk +indent amt lvl t = C.chunk ts txt + where + ts = C.defaultTextSpec + txt = X.concat [spaces, t, "\n"] + spaces = X.replicate (amt * lvl) " " + +-- | Shows a tree, without evaluating it. +showTestTree + :: Pt.IndentAmt + -> Pt.Level + -> TestTree a + -> [C.Chunk] +showTestTree amt l (TestTree n p) = indent amt l n : children + where + children = case p of + Group ts -> concatMap (showTestTree amt l) ts + Test _ -> [] + +evalTestTree + :: Pt.IndentAmt + -> Pt.Level + -> PassVerbosity + -> FailVerbosity + -> [a] + -> TestTree a + -> [Either C.Chunk (Pass, [C.Chunk])] +evalTestTree i l pv fv as (TestTree n p) = case p of + Test f -> [Right $ f i pv fv as l] + Group ts -> Left (indent i l n) + : concatMap (evalTestTree i (l + 1) pv fv as) ts diff --git a/Penny/Wheat.hs b/Penny/Wheat.hs new file mode 100644 --- /dev/null +++ b/Penny/Wheat.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} +module Penny.Wheat where + +import Control.Applicative +import Control.Monad (when) +import Data.List (find, isPrefixOf) +import Data.Maybe (mapMaybe, catMaybes) +import Data.Monoid ((<>), mempty) +import qualified Penny.Copper as Cop +import qualified Penny.Copper.Parsec as CP +import qualified Penny.Lincoln as L +import qualified Data.Text as X +import qualified Data.Time as Time +import qualified Text.Parsec as Parsec +import qualified System.Exit as Exit +import qualified Penny.Shield as S + +import qualified Penny.Steel.TestTree as TT +import qualified Penny.Steel.Pdct as Pe +import qualified Penny.Steel.Chunk as C +import qualified Options.Applicative as OA + +------------------------------------------------------------ +-- Other conveniences +------------------------------------------------------------ + + +-- | A non-terminating list of starting with the first day of the +-- first month following the given day, followed by successive first +-- days of the month. +futureFirstsOfTheMonth :: Time.Day -> [Time.Day] +futureFirstsOfTheMonth d = iterate (Time.addGregorianMonthsClip 1) d1 + where + d1 = Time.fromGregorian yr mo 1 + (yr, mo, _) = Time.toGregorian $ Time.addGregorianMonthsClip 1 d + +------------------------------------------------------------ +-- CLI +------------------------------------------------------------ + +type ColorToFile = Bool +type BaseTime = Time.UTCTime +type ProgName = String + +data WheatConf = WheatConf + { briefDescription :: String + , moreHelp :: [String] + , passVerbosity :: TT.PassVerbosity + , failVerbosity :: TT.FailVerbosity + , indentAmt :: Pe.IndentAmt + , colorToFile :: ColorToFile + , tests :: [BaseTime -> TT.TestTree L.PostFam] + , baseTime :: BaseTime + } + +parseAbbrev :: [(String, a)] -> String -> Either OA.ParseError a +parseAbbrev ls str = case find (\(s, _) -> s == str) ls of + Nothing -> lookupAbbrev + Just (_, a) -> Right a + where + lookupAbbrev = case filter ((str `isPrefixOf`) . fst) ls of + (_, a):[] -> Right a + _ -> Left (OA.ErrorMsg ("invalid argument: " ++ str)) + +parseVerbosity :: String -> Either OA.ParseError TT.Verbosity +parseVerbosity = parseAbbrev + [ ("silent", TT.Silent) + , ("minimal", TT.PassFail) + , ("false", TT.FalseSubjects) + , ("true", TT.TrueSubjects) + , ("discarded", TT.DiscardedSubjects) + , ("all", TT.DiscardedPredicates) + ] + +parseColorToFile :: String -> Either OA.ParseError ColorToFile +parseColorToFile = parseAbbrev [ ("no", False), ("yes", True) ] + +parseBaseTime :: String -> Either OA.ParseError BaseTime +parseBaseTime s = case Parsec.parse CP.dateTime "" (X.pack s) of + Left e -> Left (OA.ErrorMsg $ "could not parse date: " ++ show e) + Right g -> Right . L.toUTC $ g + +data Parsed = Parsed + { p_passVerbosity :: TT.PassVerbosity + , p_failVerbosity :: TT.FailVerbosity + , p_indentAmt :: Pe.IndentAmt + , p_colorToFile :: ColorToFile + , p_baseTime :: BaseTime + , p_ledgers :: [String] + } + +parseOpts :: WheatConf -> OA.Parser Parsed +parseOpts wc + = Parsed + <$> ( OA.nullOption + ( OA.long "pass-verbosity" + <> OA.short 'p' + <> OA.reader parseVerbosity ) + <|> pure (passVerbosity wc) ) + + <*> ( OA.nullOption + ( OA.long "fail-verbosity" + <> OA.short 'f' + <> OA.reader parseVerbosity ) + <|> pure (failVerbosity wc) ) + + <*> ( OA.option + ( OA.long "indentation" + <> OA.short 'i' ) + <|> pure (indentAmt wc) ) + + <*> ( OA.nullOption + ( OA.long "color-to-file" + <> OA.reader parseColorToFile ) + <|> pure (colorToFile wc)) + + <*> ( OA.nullOption + ( OA.long "base-date" + <> OA.reader parseBaseTime ) + <|> pure (baseTime wc) ) + + <*> ( many (OA.argument OA.str mempty)) + +main :: (S.Runtime -> WheatConf) -> IO () +main getWc = do + rt <- S.runtime + let inf = OA.fullDesc + wc = getWc rt + psd <- OA.execParser (OA.info (parseOpts wc) inf) + let term = if p_colorToFile psd || (S.output rt == S.IsTTY) + then S.termFromEnv rt + else S.autoTerm rt + pfs <- getItems (p_ledgers psd) + let tts = zipWith ($) (tests wc) (repeat (p_baseTime psd)) + doEval = TT.evalTestTree (p_indentAmt psd) 0 (p_passVerbosity psd) + (p_failVerbosity psd) pfs + eithers = concatMap doEval tts + passes <- mapM (showEitherChunk (C.printChunks term)) eithers + when (not . and . catMaybes $ passes) Exit.exitFailure + +showEitherChunk + :: ([C.Chunk] -> IO ()) + -> Either C.Chunk (TT.Pass, [C.Chunk]) + -> IO (Maybe TT.Pass) +showEitherChunk f ei = case ei of + Left ck -> f [ck] >> return Nothing + Right (p, cs) -> f cs >> return (Just p) + +getItems :: [String] -> IO [L.PostFam] +getItems ss = fmap f $ Cop.open ss + where + f = concatMap L.postFam . mapMaybe toTxn . Cop.unLedger + toTxn i = case i of { Cop.Transaction x -> Just x; _ -> Nothing } + +-- +-- Tests +-- +eachPostingMustBeTrue + :: TT.Name + -> Pe.Pdct L.PostFam + -> TT.TestTree L.PostFam +eachPostingMustBeTrue n = TT.eachSubjectMustBeTrue n L.display + +atLeastNPostings + :: Int + -> TT.Name + -> Pe.Pdct L.PostFam + -> TT.TestTree L.PostFam +atLeastNPostings i n = TT.seriesAtLeastN n L.display i diff --git a/Penny/Zinc.hs b/Penny/Zinc.hs --- a/Penny/Zinc.hs +++ b/Penny/Zinc.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} + -- | Zinc - the Penny command-line interface module Penny.Zinc ( Defaults(..) @@ -7,34 +9,34 @@ , runZinc ) where -import qualified Penny.Cabin.Chunk as Chk +import qualified Penny.Steel.Chunk as Chk import qualified Penny.Cabin.Interface as I import qualified Penny.Cabin.Parsers as P import qualified Penny.Cabin.Scheme as E import qualified Penny.Copper as C import qualified Penny.Liberty as Ly -import qualified Penny.Liberty.Expressions as X +import qualified Penny.Steel.Expressions as X +import qualified Penny.Steel.Pdct as Pe import qualified Penny.Lincoln as L import qualified Penny.Lincoln.Queries as Q import qualified Penny.Shield as S -import Control.Applicative ((<$>), (<*>), pure) -import Control.Monad (when) +import Control.Applicative ((<*>), pure, (<$)) +import Control.Monad (join) import qualified Control.Monad.Trans.State as St import qualified Control.Monad.Exception.Synchronous as Ex import Data.Char (toUpper, toLower) +import Data.Either (partitionEithers) import Data.List (isPrefixOf) import Data.Maybe (mapMaybe, catMaybes) -import Data.Monoid (mappend, mconcat) +import Data.Monoid (mappend, mconcat, (<>)) import Data.Ord (comparing) -import Data.Text (Text, pack, unpack) +import Data.Text (Text, pack) import qualified Data.Text.IO as TIO import qualified System.Console.MultiArg as MA -import System.Console.MultiArg.GetArgs (getArgs) -import System.Exit (exitSuccess, exitFailure) +import qualified System.Exit as Exit import qualified System.IO as IO -import System.IO (hIsTerminalDevice, stdin, stderr, hPutStrLn) -import qualified Text.Matchers.Text as M +import qualified Text.Matchers as M runZinc :: Defaults @@ -42,9 +44,12 @@ -> [I.Report] -> IO () runZinc df rt rs = do - as <- getArgs - parseAndPrint df rt rs as + let ord = sortPairsToFn . sorter $ df + hlp = helpText df rt rs + join $ MA.modesWithHelp hlp (allOpts (S.currentTime rt) df) + (processGlobal rt ord df rs) + -- | Whether to use color when standard output is not a terminal. newtype ColorToFile = ColorToFile { unColorToFile :: Bool } deriving (Eq, Show) @@ -82,6 +87,8 @@ -- are equal, use -- -- > [(Date, Ascending), (Payee, Ascending)] + + , exprDesc :: X.ExprDesc } sortPairToFn :: (SortField, P.SortOrder) -> Orderer @@ -123,28 +130,6 @@ sortPairsToFn :: [(SortField, P.SortOrder)] -> Orderer sortPairsToFn = mconcat . map sortPairToFn -data State = State - { stSensitive :: M.CaseSensitive - , stFactory :: M.CaseSensitive -> Text - -> Ex.Exceptional Text (Text -> Bool) - , stColorToFile :: ColorToFile - , stScheme :: Maybe E.TextSpecs - } - -stateFromDefaults - :: Defaults - -> State -stateFromDefaults df = State - { stSensitive = sensitive df - , stFactory = case matcher df of - Within -> \c t -> return (M.within c t) - Exact -> \c t -> return (M.exact c t) - TDFA -> M.tdfa - PCRE -> M.pcre - , stColorToFile = colorToFile df - , stScheme = fmap E.textSpecs . defaultScheme $ df - } - -- -- ## Option parsing -- @@ -152,25 +137,32 @@ -- -- ## OptResult, and functions dealing with it -- +newtype ShowExpression = ShowExpression Bool + deriving (Show, Eq) + +newtype VerboseFilter = VerboseFilter Bool + deriving (Show, Eq) + +type Error = Text + data OptResult = ROperand (M.CaseSensitive -> Ly.MatcherFactory - -> Ex.Exceptional String Ly.Operand) - | RPostFilter (Ex.Exceptional String Ly.PostFilterFn) + -> Ex.Exceptional Ly.Error Ly.Operand) + | RPostFilter (Ex.Exceptional Ly.Error Ly.PostFilterFn) | RMatcherSelect Ly.MatcherFactory | RCaseSelect M.CaseSensitive - | ROperator (Ly.Token (L.PostFam -> Bool)) - | RSortSpec (Ex.Exceptional String Orderer) - | RHelp + | ROperator (X.Token L.PostFam) + | RSortSpec (Ex.Exceptional Error Orderer) | RColorToFile ColorToFile | RScheme E.TextSpecs - -isHelp :: OptResult -> Bool -isHelp o = case o of { RHelp -> True; _ -> False } + | RExprDesc X.ExprDesc + | RShowExpression + | RVerboseFilter getPostFilters :: [OptResult] - -> Ex.Exceptional String [Ly.PostFilterFn] + -> Ex.Exceptional Ly.Error [Ly.PostFilterFn] getPostFilters = sequence . mapMaybe f @@ -179,10 +171,21 @@ RPostFilter pf -> Just pf _ -> Nothing +getExprDesc + :: Defaults + -> [OptResult] + -> X.ExprDesc +getExprDesc df os = case mapMaybe f os of + [] -> exprDesc df + xs -> last xs + where + f (RExprDesc d) = Just d + f _ = Nothing + getSortSpec :: Orderer -> [OptResult] - -> Ex.Exceptional String Orderer + -> Ex.Exceptional Error Orderer getSortSpec i ls = let getSpec o = case o of RSortSpec x -> Just x @@ -193,17 +196,16 @@ else fmap mconcat . sequence $ exSpecs type Factory = M.CaseSensitive - -> Text -> Ex.Exceptional Text (Text -> Bool) + -> Text -> Ex.Exceptional Text M.Matcher makeToken :: OptResult -> St.State (M.CaseSensitive, Factory) - (Maybe (Ex.Exceptional String (Ly.Token (L.PostFam -> Bool)))) + (Maybe (Ex.Exceptional Ly.Error (X.Token L.PostFam))) makeToken o = case o of ROperand f -> do (s, fty) <- St.get - let g = fmap h (f s fty) - h (X.Operand fn) = Ly.TokOperand fn + let g = fmap X.operand (f s fty) return (Just g) RMatcherSelect f -> do (c, _) <- St.get @@ -218,12 +220,17 @@ makeTokens - :: State + :: Defaults -> [OptResult] - -> Ex.Exceptional String ( [Ly.Token (L.PostFam -> Bool)] - , (M.CaseSensitive, Factory) ) + -> Ex.Exceptional Ly.Error ( [X.Token L.PostFam] + , (M.CaseSensitive, Factory) ) makeTokens df os = - let initSt = (stSensitive df, stFactory df) + let initSt = (sensitive df, fty) + fty = case matcher df of + Within -> \c t -> return (M.within c t) + Exact -> \c t -> return (M.exact c t) + TDFA -> M.tdfa + PCRE -> M.pcre lsSt = mapM makeToken os (ls, st') = St.runState lsSt initSt in fmap (\xs -> (xs, st')) . sequence . catMaybes $ ls @@ -238,10 +245,13 @@ ++ map (fmap RCaseSelect) Ly.caseSelectSpecs ++ map (fmap ROperator) Ly.operatorSpecs ++ [fmap RSortSpec sortSpecs] - ++ [ MA.OptSpec ["help"] "h" (MA.NoArg RHelp) - , optColorToFile ] + ++ [ optColorToFile ] ++ let ss = moreSchemes df - in if not . null $ ss then [optScheme ss] else [] + in (if not . null $ ss then [optScheme ss] else []) + ++ map (fmap RExprDesc) Ly.exprDesc + ++ [ RShowExpression <$ Ly.showExpression + , RVerboseFilter <$ Ly.verboseFilter + ] optColorToFile :: MA.OptSpec OptResult optColorToFile = MA.OptSpec ["color-to-file"] "" (MA.ChoiceArg ls) @@ -249,10 +259,10 @@ ls = [ ("yes", RColorToFile $ ColorToFile True) , ("no", RColorToFile $ ColorToFile False) ] -getColorToFile :: State -> [OptResult] -> ColorToFile +getColorToFile :: Defaults -> [OptResult] -> ColorToFile getColorToFile d ls = case mapMaybe getOpt ls of - [] -> stColorToFile d + [] -> colorToFile d xs -> last xs where getOpt o = case o of @@ -265,219 +275,184 @@ ls = map f ss f (E.Scheme n _ s) = (n, RScheme s) -getScheme :: State -> [OptResult] -> Maybe E.TextSpecs +getScheme :: Defaults -> [OptResult] -> Maybe E.TextSpecs getScheme d ls = case mapMaybe getOpt ls of - [] -> stScheme d + [] -> fmap E.textSpecs $ defaultScheme d xs -> Just $ last xs where getOpt o = case o of RScheme s -> Just s _ -> Nothing -data GlobalResult - = NeedsHelp - | RunPenny FilterOpts +getShowExpression :: [OptResult] -> ShowExpression +getShowExpression ls = case mapMaybe f ls of + [] -> ShowExpression False + _ -> ShowExpression True + where + f o = case o of { RShowExpression -> Just (); _ -> Nothing } +getVerboseFilter :: [OptResult] -> VerboseFilter +getVerboseFilter ls = case mapMaybe f ls of + [] -> VerboseFilter False + _ -> VerboseFilter True + where + f o = case o of { RVerboseFilter -> Just (); _ -> Nothing } + -- | Indicates the result of a successful parse of filtering options. data FilterOpts = FilterOpts - { _resultFactory :: M.CaseSensitive - -> Text -> Ex.Exceptional Text (Text -> Bool) + { foResultFactory :: Factory -- ^ The factory indicated, so that it can be used in -- subsequent parses of the same command line. - , _resultSensitive :: M.CaseSensitive + , foResultSensitive :: M.CaseSensitive -- ^ Indicated case sensitivity, so that it can be used in -- subsequent parses of the command line. - , _sorterFilterer :: [L.Transaction] -> [L.Box Ly.LibertyMeta] + , foSorterFilterer :: [L.Transaction] + -> ([Chk.Chunk], [L.Box Ly.LibertyMeta]) -- ^ Applied to a list of Transaction, will sort and filter -- the transactions and assign them LibertyMeta. , foTextSpecs :: Maybe E.TextSpecs , foColorToFile :: ColorToFile + , foExprDesc :: X.ExprDesc + , foPredicate :: Pe.Pdct L.PostFam + , foShowExpression :: ShowExpression + , foVerboseFilter :: VerboseFilter } processGlobal - :: Orderer - -> State + :: S.Runtime + -> Orderer + -> Defaults + -> [I.Report] -> [OptResult] - -> Ex.Exceptional String GlobalResult -processGlobal srt st os = - if any isHelp os - then return NeedsHelp - else do - postFilts <- getPostFilters os - sortSpec <- getSortSpec srt os - (toks, (rs, rf)) <- makeTokens st os - let ctf = getColorToFile st os - sch = getScheme st os - err = "could not parse filter expression." - pdct <- Ex.fromMaybe err $ Ly.parsePredicate toks - let sf = Ly.xactionsToFiltered pdct postFilts sortSpec - fo = FilterOpts rf rs sf sch ctf - return $ RunPenny fo - --- --- Ledger parsing --- -warnTerminal :: IO () -warnTerminal = - hPutStrLn stderr $ "penny: warning: reading from standard input, " - ++ "which is a terminal" - -data Filename = - Filename Text - | Stdin - --- | Converts a Ledgers filename to a Lincoln filename. -convertFilename :: Filename -> L.Filename -convertFilename (Filename x) = L.Filename x -convertFilename Stdin = L.Filename . pack $ "" - --- | Actually reads the file off disk. For now just let this crash if --- any of the IO errors occur. -ledgerText :: Filename -> IO Text -ledgerText f = case f of - Stdin -> do - isTerm <- hIsTerminalDevice stdin - when isTerm warnTerminal - TIO.hGetContents stdin - Filename fn -> TIO.readFile (unpack fn) - --- | Converts a string from the command line to a Filename. -toFilename :: String -> Filename -toFilename s = - if s == "-" - then Stdin - else Filename . pack $ s - -readLedgers :: [String] -> IO [(Filename, Text)] -readLedgers ss = - let fns = if null ss then [Stdin] else map toFilename ss - f fn = (\txt -> (fn, txt)) <$> ledgerText fn - in mapM f fns + -> Either (a -> IO ()) [MA.Mode (IO ())] +processGlobal rt srt df rpts os + = case processFiltOpts srt df os of + Ex.Exception s -> Left $ (const $ handleTextError s) + Ex.Success fo -> Right $ map (makeMode rt fo) rpts +processFiltOpts + :: Orderer + -> Defaults + -> [OptResult] + -> Ex.Exceptional Error FilterOpts +processFiltOpts ord df os = do + postFilts <- getPostFilters os + sortSpec <- getSortSpec ord os + (toks, (rs, rf)) <- makeTokens df os + let ctf = getColorToFile df os + sch = getScheme df os + expDsc = getExprDesc df os + showExpr = getShowExpression os + verbFilt = getVerboseFilter os + pdct <- Ly.parsePredicate expDsc toks + let sf = Ly.xactionsToFiltered pdct postFilts sortSpec + return $ FilterOpts rf rs sf sch ctf expDsc pdct showExpr verbFilt -parseLedgers - :: [(Filename, Text)] - -> Ex.Exceptional String ([L.Transaction], [L.PricePoint]) -parseLedgers ls = - let toPair (f, t) = (convertFilename f, C.FileContents t) - parsed = C.parse (map toPair ls) - folder i (ts, ps) = case i of - C.Transaction t -> (t:ts, ps) - C.PricePoint p -> (ts, p:ps) - _ -> (ts, ps) - toResult (C.Ledger is) = foldr folder ([], []) is - toErr x = "could not parse ledger: " - ++ (unpack . C.unErrorMsg $ x) - in Ex.mapExceptional toErr toResult parsed +makeMode + :: S.Runtime + -> FilterOpts + -> I.Report + -> MA.Mode (IO ()) +makeMode rt fo r = fmap makeIO mode + where + mode = snd (r rt) (foResultSensitive fo) (foResultFactory fo) + (foExprDesc fo) (fmap snd (foSorterFilterer fo)) + makeIO parseResult = do + (posArgs, printRpt) <- + Ex.switch handleTextError return parseResult + (txns, pps) <- fmap splitLedger $ C.open posArgs + let term = if unColorToFile (foColorToFile fo) + then S.termFromEnv rt + else S.autoTerm rt + printer = Chk.printChunks term + verbFiltChunks = fst . foSorterFilterer fo $ txns + showFilterExpression printer (foShowExpression fo) (foPredicate fo) + showVerboseFilter printer (foVerboseFilter fo) verbFiltChunks + Ex.switch handleTextError (printChunks printer (foTextSpecs fo)) + $ printRpt txns pps -data DisplayOpts = DisplayOpts ColorToFile (Maybe E.TextSpecs) +handleTextError :: Text -> IO a +handleTextError x = do + pn <- MA.getProgName + TIO.hPutStr IO.stderr $ (pack pn) <> ": error: " <> x + Exit.exitFailure -toDisplayOpts :: FilterOpts -> DisplayOpts -toDisplayOpts o = DisplayOpts (foColorToFile o) (foTextSpecs o) +indentAmt :: Pe.IndentAmt +indentAmt = 4 -parseCommandLine - :: Defaults - -> [I.Report] - -> S.Runtime - -> [String] - -> Ex.Exceptional MA.Error - (GlobalResult, Either [()] (DisplayOpts, I.ParseResult)) -parseCommandLine df rs rt ss = - let initSt = stateFromDefaults df - in MA.modes (allOpts (S.currentTime rt) df) - (processGlobal (sortPairsToFn . sorter $ df) initSt) - (whatMode rt rs) ss +blankLine :: Chk.Chunk +blankLine = Chk.chunk Chk.defaultTextSpec "\n" -whatMode - :: S.Runtime - -> [I.Report] - -> GlobalResult - -> Either (a -> ()) [MA.Mode (DisplayOpts, I.ParseResult)] -whatMode rt pairFns gr = - case gr of - NeedsHelp -> Left $ const () - RunPenny fo@(FilterOpts fty cs sf _ _) -> - let prs = map snd (pairFns <*> pure rt) - <*> pure cs - <*> pure fty - <*> pure sf - in Right $ map (fmap (\r -> ((toDisplayOpts fo), r))) prs +showFilterExpression + :: ([Chk.Chunk] -> IO ()) + -> ShowExpression + -> Pe.Pdct L.PostFam + -> IO () +showFilterExpression ptr (ShowExpression se) pdct = + if not se + then return () + else ptr $ info : blankLine : + (Pe.showPdct indentAmt 0 pdct ++ [blankLine]) + where + info = Chk.chunk Chk.defaultTextSpec "Posting filter expression:\n" -handleParseResult - :: S.Runtime - -> Defaults - -> [I.Report] - -> Ex.Exceptional MA.Error - (a, Either b (DisplayOpts, I.ParseResult)) +showVerboseFilter + :: ([Chk.Chunk] -> IO ()) + -> VerboseFilter + -> [Chk.Chunk] -> IO () -handleParseResult rt df rs r = - let showErr e = do - IO.hPutStrLn IO.stderr $ "penny: error: " ++ e - exitFailure - in case r of - Ex.Exception e -> do - IO.hPutStr IO.stderr $ MA.formatError "penny" e - exitFailure - Ex.Success (_, ei) -> - case ei of - Left _ -> putStr (helpText df rt rs) >> exitSuccess - Right ((DisplayOpts ctf sch), ex) -> case ex of - Ex.Exception s -> showErr s - Ex.Success good -> either showHelp runCmd good - where - showHelp h = putStr h >> exitSuccess - runCmd (fns, pr) = do - ledgers <- readLedgers fns - (txns, pps) <- Ex.switch showErr return - $ parseLedgers ledgers - let term = if unColorToFile ctf - then Chk.termFromEnv rt - else Chk.autoTerm rt - Ex.switch (showErr . unpack) - (printChunks term sch) $ pr txns pps +showVerboseFilter ptr (VerboseFilter vb) cks = + if not vb + then return () + else ptr $ info : blankLine : (cks ++ [blankLine]) + where + info = Chk.chunk Chk.defaultTextSpec "Filtering information:\n" +-- | Splits a Ledger into its Transactions and PricePoints. +splitLedger :: C.Ledger -> ([L.Transaction], [L.PricePoint]) +splitLedger = partitionEithers . mapMaybe toEither . C.unLedger + where + toEither i = case i of + C.Transaction t -> Just $ Left t + C.PricePoint p -> Just $ Right p + _ -> Nothing + printChunks - :: Chk.Term + :: ([Chk.Chunk] -> IO ()) -> Maybe E.TextSpecs - -> [E.PreChunk] + -> [Either Chk.Chunk E.PreChunk] -> IO () -printChunks t mayS = - Chk.printChunks t +printChunks printer mayS = + printer . map makeChunk where - makeChunk pc = case mayS of - Nothing -> Chk.chunk Chk.defaultTextSpec (E.text pc) - Just s -> E.makeChunk s pc + makeChunk eiChkOrPc = + case eiChkOrPc of + Left c -> c + Right pc -> case mayS of + Nothing -> Chk.chunk Chk.defaultTextSpec (E.text pc) + Just s -> E.makeChunk s pc helpText :: Defaults -> S.Runtime -> [I.Report] -> String -helpText df rt pairMakers = - mappend (help df) . mconcat . map addHdr . fmap fst $ pairs + -> String +helpText df rt pairMakers pn = + mappend (help df pn) . mconcat . map addHdr . fmap fst $ pairs where pairs = pairMakers <*> pure rt addHdr s = hdr ++ s hdr = unlines [ "", replicate 50 '=' ] -parseAndPrint - :: Defaults - -> S.Runtime - -> [I.Report] - -> [String] - -> IO () -parseAndPrint df rt rs ss = - handleParseResult rt df rs - $ parseCommandLine df rs rt ss - ------------------------------------------------------------ -- ## Sorting ------------------------------------------------------------ @@ -538,14 +513,14 @@ (x == y) && ((map toUpper xs) `isPrefixOf` (map toUpper ys)) _ -> True -sortSpecs :: MA.OptSpec (Ex.Exceptional String Orderer) +sortSpecs :: MA.OptSpec (Ex.Exceptional Error Orderer) sortSpecs = MA.OptSpec ["sort"] ['s'] (MA.OneArg f) where f a = let matches = filter (\p -> a `argMatch` (fst p)) ords in case matches of x:[] -> return $ snd x - _ -> Ex.throw $ "invalid sort key: " ++ a + _ -> Ex.throw $ "bad sort specification: " <> pack a <> "\n" @@ -553,9 +528,9 @@ -- ## Help ------------------------------------------------------------ -help :: Defaults -> String -help d = unlines $ - [ "usage: penny [posting filters] report [report options] file . . ." +help :: Defaults -> String -> String +help d pn = unlines $ + [ "usage: " ++ pn ++ " [posting filters] report [report options] file . . ." , "" , "Posting filters" , "------------------------------------------" @@ -620,18 +595,6 @@ , "--qty cmp number" , " Entry quantity must fall within given range" , "" - , "Operators - from highest to lowest precedence" - , "(all are left associative)" - , "--------------------------" - , "--open expr --close" - , " Force precedence (as in \"open\" and \"close\" parentheses)" - , "--not expr" - , " True if expr is false" - , "expr1 --and expr2 " - , " True if expr and expr2 are both true" - , "expr1 --or expr2" - , " True if either expr1 or expr2 is true" - , "" , "Options affecting patterns" , "--------------------------" , "" @@ -661,8 +624,41 @@ , "--exact" , " Use \"exact\" matcher" ++ ifDefault (matcher d == Exact) - , "" + , "Infix or RPN selection" + , "----------------------" + , "--infix - use infix notation" + ++ ifDefault (exprDesc d == X.Infix) + , "--rpn - use reverse polish notation" + ++ ifDefault (exprDesc d == X.RPN) + , "" + , "Infix Operators - from highest to lowest precedence" + , "(all are left associative)" + , "--------------------------" + , "--open expr --close" + , " Force precedence (as in \"open\" and \"close\" parentheses)" + , "--not expr" + , " True if expr is false" + , "expr1 --and expr2 " + , " True if expr and expr2 are both true" + , "expr1 --or expr2" + , " True if either expr1 or expr2 is true" + , "" + , "RPN Operators" + , "-------------" + , "--not" + , "--and" + , "--or" + , " RPN counterparts to the infix operators" + , " are postfix and manipulate the RPN stack accordingly" + , "" + , "Showing expressions" + , "-------------------" + , "--show-expression" + , " Show the parsed filter expression" + , "--verbose-filter" + , " Verbosely show filtering results" + , "" , "Removing postings after sorting and filtering" , "---------------------------------------------" , "--head n" @@ -706,6 +702,7 @@ , " terminal (default: " ++ if unColorToFile . colorToFile $ d then "yes)" else "no)" ] + descScheme :: E.Scheme -> String descScheme (E.Scheme n d _) = " " ++ n ++ " - " ++ d diff --git a/penny-lib.cabal b/penny-lib.cabal --- a/penny-lib.cabal +++ b/penny-lib.cabal @@ -1,5 +1,5 @@ Name: penny-lib -Version: 0.6.0.0 +Version: 0.8.0.0 Cabal-version: >=1.8 Build-Type: Simple License: BSD3 @@ -21,8 +21,11 @@ . This package is a library. To start using Penny you will want to - install the penny-bin package, which has the executable programs. It - is available on Hackage and by running "cabal install penny-bin". + install the penny-bin package, which has the executable programs. + More about the penny-bin package, along with a full sales pitch + for Penny and how to get started, is at + . It may be installed + with "cabal install penny-bin". . @@ -36,17 +39,19 @@ Library Build-depends: base ==4.* - , bytestring ==0.9.* + , bytestring ==0.10.* , cereal ==0.3.* - , containers ==0.4.* + , containers ==0.5.* , explicit-exception ==0.1.* - , matchers ==0.4.* + , matchers ==0.6.* , monad-loops ==0.3.* - , multiarg ==0.8.* + , multiarg ==0.10.* , old-locale ==1.0.* + , optparse-applicative ==0.5.* , parsec >= 3.1.2 && < 3.2 - , pretty-show ==1.2.* - , semigroups ==0.8.* + , pcre-light ==0.4.* + , pretty-show ==1.5.* + , semigroups ==0.9.* , split ==0.2.* , strict ==0.3.* , terminfo == 0.3.* @@ -76,8 +81,6 @@ , Penny.Cabin.Balance.MultiCommodity.Chunker , Penny.Cabin.Balance.MultiCommodity.Parser , Penny.Cabin.Balance.Util - , Penny.Cabin.Chunk - , Penny.Cabin.Chunk.Switch , Penny.Cabin.Interface , Penny.Cabin.Meta , Penny.Cabin.Options @@ -102,9 +105,6 @@ , Penny.Copper.Terminals , Penny.Copper.Types , Penny.Liberty - , Penny.Liberty.Expressions - , Penny.Liberty.Expressions.Infix - , Penny.Liberty.Expressions.RPN , Penny.Lincoln , Penny.Lincoln.Balance , Penny.Lincoln.Bits @@ -119,7 +119,6 @@ , Penny.Lincoln.Family.Siblings , Penny.Lincoln.HasText , Penny.Lincoln.Matchers - , Penny.Lincoln.NestedMap , Penny.Lincoln.Predicates , Penny.Lincoln.PriceDb , Penny.Lincoln.Queries @@ -127,6 +126,16 @@ , Penny.Lincoln.Transaction , Penny.Lincoln.Transaction.Unverified , Penny.Shield + , Penny.Steel + , Penny.Steel.Chunk + , Penny.Steel.Chunk.Switch + , Penny.Steel.Expressions + , Penny.Steel.Expressions.Infix + , Penny.Steel.Expressions.RPN + , Penny.Steel.NestedMap + , Penny.Steel.Pdct + , Penny.Steel.TestTree + , Penny.Wheat , Penny.Zinc