wtk (empty) → 0.1
raw patch · 7 files changed
+577/−0 lines, 7 filesdep +basedep +old-localedep +timesetup-changed
Dependencies added: base, old-locale, time, transformers
Files
- Calculator.hs +155/−0
- ReadEither.hs +123/−0
- Setup.hs +2/−0
- Text/PrettyShow.hs +94/−0
- Text/WtkParser.hs +148/−0
- license +31/−0
- wtk.cabal +24/−0
+ Calculator.hs view
@@ -0,0 +1,155 @@+--------------------------------------------------------- +-- +-- Module : Caclulator +-- Copyright : Bartosz Wójcik (2012) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- Module is part of Wojcik Tool Kit package. +-- | Simple calculator. Evaluates arithmetic formulas. +--------------------------------------------------------- +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, NoMonomorphismRestriction #-} +module Calculator ( + evaluate -- Evaluates arithmetic formula. + ,evaluateInt -- Evaluates arithmetic formula on @Integer@s. + ) +where + +import Control.Monad +import Control.Monad.Trans.Error +import Control.Monad.Trans.State +import Control.Monad.Trans.Class +import Data.Char +import Data.Either +import Text.WtkParser + + + +-- | State contains just operator +type State1 a = (a -> a -> a) + +-- | Only limited operators are available, +-- they are shown using some trick. +instance (Num a) => Show (State1 a) where + show f | 3 `f` 2 == 6 = "*" + | 3 `f` 2 == 5 = "+" + | 3 `f` 2 == 1 = "-" + | 3 `f` 2 == 8 = "^" + | otherwise = "/" + +-- | Calculator parser is just simple wtk parser with added state. +-- State keeps not yet consumed operator. +type Parser1 a = StateT (State1 a) Parser a + +runParser1 :: (Num a) => State1 a -> Parser1 a -> String -> Either String (String, (a, (State1 a))) +runParser1 st e = runParser $ runStateT e st + +-- | Evaluates arithmetic formula. In case formula cannot be parsed +-- returns error message. +evaluate :: (Floating a, RealFrac a, Ord a) => String -> Either String a +evaluate x = case runParser1 (+) arithmetic x of + Left err -> Left err + Right (_,(res,_)) -> Right res + +-- | Integer version of @evaluate@. +evaluateInt :: String -> Either String Integer +evaluateInt x = case runParser1 (+) arithmeticInt x of + Left err -> Left err + Right (_,(res,_)) -> Right res + +char1 = lift . lexeme . char + +finito n = (char1 '=' >> lift eof) `mplus` lift eof >> return n + +arithmetic = lift skipSpaces >> expression1 >>= finito +arithmeticInt = lift skipSpaces >> expressionInt >>= finito + +-- "runStateT p f" transforms "Parser1 a" to "Parser (a,s)" +-- "liftM fst" changes it to "Parser a" which gives us proper type +-- for manyF function. Then in turn we lift result of manyF from "Parser a" +-- to "Parser1 a". +manyF11 :: (Num a) => Parser1 a -> a -> Parser1 a +manyF11 p n = do + f <- get + lift $ manyF f (liftM fst (runStateT p f)) n + +manyF1 :: (Num a) => Parser1 a -> a -> Parser1 a +manyF1 p n = StateT many' + where many' f = Parser many'' + many'' x = + case runParser1 (-) p x of + Left err -> Right (x,(n,(-))) + Right (x',(a,f)) -> do + let Right (x'',(rest,_)) = many'' x' + Right (x'',(rest `f` a,f)) + +myPut :: (Monad m) => s -> a -> StateT s m a +myPut s a = StateT $ \_ -> return (a, s) + +expression1 :: (Floating a, RealFrac a, Ord a) => Parser1 a +expression1 = term1 >>= manyF1 (tMinus1 `mplus` tPlus1) + +tMinus1 :: (Floating a, RealFrac a, Ord a) => Parser1 a +tMinus1 = char1 '-' >> term1 >>= myPut (-) + +tPlus1 :: (Floating a, RealFrac a, Ord a) => Parser1 a +tPlus1 = char1 '+' >> term1 >>= myPut (+) + +term1 :: (Floating a, RealFrac a, Ord a) => Parser1 a +term1 = tPower1 >>= manyF1 (tMult1 `mplus` tDiv1) + +tMult1 :: (Floating a, RealFrac a, Ord a) => Parser1 a +tMult1 = char1 '*' >> tPower1 >>= myPut (*) + +tDiv1 :: (Floating a, RealFrac a, Ord a) => Parser1 a +tDiv1 = char1 '/' >> tPower1 >>= myPut (/) + +tPower1 :: (Floating a, RealFrac a, Ord a) => Parser1 a +tPower1 = tFactorial1 >>= manyF1 tPow1 + +tPow1 :: (Floating a, RealFrac a, Ord a) => Parser1 a +tPow1 = char1 '^' >> tFactorial1 >>= myPut (**) + +tFactorial1 :: (Floating a, RealFrac a, Ord a) => Parser1 a +tFactorial1 = phrase1 >>= manyF1 tFact1 + +tFact1 :: (RealFrac a, Ord a) => Parser1 a +tFact1 = char1 '!' >> return 1 >>= myPut (\a b -> fromIntegral (product [1 .. round a])) + +phrase1 :: (Floating a, RealFrac a, Ord a) => Parser1 a +phrase1 = (do + char1 '(' + v <- expression1 + char1 ')' + return v) + `mplus` lift (lexeme real) + +expressionInt = termInt >>= manyF1 (tMinusInt `mplus` tPlusInt) + +tMinusInt = char1 '-' >> termInt >>= myPut (-) + +tPlusInt = char1 '+' >> termInt >>= myPut (+) + +termInt = tPowerInt >>= manyF1 (tMultInt `mplus` tDivInt) + +tMultInt = char1 '*' >> tPowerInt >>= myPut (*) + +tDivInt = char1 '/' >> tPowerInt >>= myPut div + +tPowerInt = tFactorialInt >>= manyF1 tPowInt + +tPowInt = char1 '^' >> tFactorialInt >>= myPut (^) + +tFactorialInt = phraseInt >>= manyF1 tFactInt + +tFactInt = char1 '!' >> return 1 >>= myPut (\a b -> product [1 .. a]) + +phraseInt = (do + char1 '(' + v <- expressionInt + char1 ')' + return v) + `mplus` lift (lexeme intSigned)
+ ReadEither.hs view
@@ -0,0 +1,123 @@+--------------------------------------------------------- +-- +-- Module : ReadEither +-- Copyright : Bartosz Wójcik (2012) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- Module is part of Wojcik Tool Kit package.+-- | Safe version of Read with human friendly error messages. +--------------------------------------------------------- + + +{-# LANGUAGE TypeSynonymInstances #-} + +module ReadEither +where + +import Control.Monad (liftM) +import Control.Monad.Trans.Error +import Data.Char +import Data.Maybe +import Data.Time +import System.Locale +import Text.WtkParser +import Calculator + + +-- | Type class providing simple input parsing +class (Show a) => ReadEither a where + readEither :: String -> Either String a -- ^ Parses String to given readEither or returns error message. + +instance ReadEither () where + readEither _ = Right () + +instance ReadEither Char where + readEither [] = Left "Empty string" + readEither x = Right $ head x + +instance ReadEither String where + readEither = Right + +instance ReadEither Bool where + readEither " " = Right False + readEither "0" = Right False + readEither "False" = Right False + readEither _ = Right True + +instance ReadEither Integer where + readEither = eval intSigned + +instance ReadEither Int where + readEither x = eval intSigned x >>= return . fromIntegral + +instance ReadEither Double where + readEither = eval real + +instance ReadEither Float where + readEither x = eval real x >>= return . realToFrac + +-- | Parsing to Day can be done on many ways. For details see the source code. +instance ReadEither Day where + readEither x = readEither' localeList + where readEither' [] = Left "Date doesn't fit to the expected format" + readEither' (l:ls) = case parseTime defaultTimeLocale l x of + Just d -> Right d + Nothing -> readEither' ls + +-- List of all parsable formats. +-- Month name only in english due to usage of @defaultTimeLocale@. +localeList = ["%Y %m %d" -- 2000 11 10 + ,"%Y %b %d" -- 2000 Nov 10 + ,"%Y-%m-%d" -- 2000-11-10 + ,"%d %m %Y" -- 10 11 2000 + ,"%d %b %Y" -- 10 Nov 2000 + ,"%d.%m.%Y" -- 10.11.2000 + ,"%Y.%m.%d" -- 2000.11.10 + ,"%d-%m-%Y" -- 10-11-2000 + ,"%Y/%m/%d" -- 2000/11/10 + ,"%d/%m/%Y" -- 10/11/2000 + ,"%d/%m/%y" -- 10/11/00 + ,"%y %m %d" -- 00 11 10 + ,"%d%m%y" -- 101100 + ,"%d%m%Y" -- 10112000 + ,"%y%m%d" -- 0011210 + ,"%Y%m%d" -- 200011210 + ] + +instance ReadEither a => ReadEither (Maybe a) where + readEither "" = Right Nothing + readEither x = liftM Just $ readEither x + + +-- | Type class providing input parsing with additional features. +class (ReadEither a) => ReadEitherPlus a where + readEitherPlus :: String -> Either String a -- ^ Parses String to given readEither or returns error message. + +-- | Strips out all control charaters +instance ReadEitherPlus String where + readEitherPlus = Right . filter (\x -> ord x >= 32) + +-- | Parses arithmetic formula +instance ReadEitherPlus Double where + readEitherPlus = evaluate + +-- | Parses arithmetic formula +instance ReadEitherPlus Float where + readEitherPlus = liftM realToFrac . evaluate + +-- | Parses arithmetic formula +instance ReadEitherPlus Integer where + readEitherPlus = evaluateInt + +-- | Parses arithmetic formula +instance ReadEitherPlus Int where + readEitherPlus = liftM fromIntegral . evaluateInt + +instance ReadEitherPlus a => ReadEitherPlus (Maybe a) where + readEitherPlus "" = Right Nothing + readEitherPlus x = liftM Just $ readEitherPlus x +
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ Text/PrettyShow.hs view
@@ -0,0 +1,94 @@+--------------------------------------------------------- +-- +-- Module : Text.PrettyShow +-- Copyright : Bartosz Wójcik (2010) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- | Type class Show-like formating numbers for humans. +--------------------------------------------------------- + +{-# LANGUAGE TypeSynonymInstances #-} + +module Text.PrettyShow + (PrettyShow -- type class providing following functions + ,showWithLen -- returns output formated into String of given length + ,showWithLenDec -- like above with constrain to be for numbers with decimal point + ,showWithLenDecChar -- like above with char that spans output to get requested length + ,showAmtWithLen -- formats amount - always two digits after decimal point + ) + +where + +import Data.Time +import System.Locale (defaultTimeLocale) + +-- | Provides String of given length for given type 'a'. +class (Show a) => PrettyShow a where+ -- | Of given length. + showWithLen :: (Integral b) => b -> a -> String + -- | Of given length with given length after decimal point. + showWithLenDec :: (Integral b) => b -> b -> a -> String + -- | Of given length with given length after decimal point with defined char for decimal poit. + showWithLenDecChar :: (Integral b) => b -> b -> Char -> a -> String + -- | Formats amount which is @showAmtWithLen l x = showWithLenDec l 2 x@ + showAmtWithLen :: (Integral b) => b -> a -> String + + showWithLen l x = showWithLenDec l 0 x + showWithLenDec l d x = showWithLenDecChar l d ' ' x + showAmtWithLen l x = showWithLenDec l 2 x + +instance PrettyShow Int where + showWithLenDecChar l d c n + | length string <= l1 = (replicate (l1 - (length string)) c) ++ string + | otherwise = (replicate (l1 - 1) '.') ++ [last string] + where string = show n + l1 = fromIntegral l + showAmtWithLen l n | l < 5 = replicate l1 '.' + | n < 0 && + n > -100 = replicate (l1 - 5) ' ' ++ "-0." ++ showDec + | otherwise = showWithLen (l1 - 3) (n `quot` 100) ++ + "." ++ showDec + where l1 = fromIntegral l + dec = (n `rem` 100) + showDec = showWithLenDecChar 2 0 '0' (abs dec) +--- showWithLenDec l 2 ((fromIntegral x :: Double) / 100) + +instance PrettyShow Integer where + showWithLenDecChar l d c n + | d == -1 && + length string <= l1 = (replicate (l1 - (length string)) c) ++ "-" ++ [last string] -- hack to show '-' + | length string <= l1 = (replicate (l1 - (length string)) c) ++ string + | otherwise = (replicate (l1 - 1) '.') ++ [last string] + where string = show n + l1 = fromIntegral l + showAmtWithLen l n | l < 5 = replicate l1 '.' + | n < 0 && + n > -100 = replicate (l1 - 5) ' ' ++ "-0." ++ showDec + | otherwise = showWithLen (l1 - 3) (n `quot` 100) ++ + "." ++ showDec + where l1 = fromIntegral l + dec = (n `rem` 100) + showDec = showWithLenDecChar 2 0 '0' (abs dec) +-- showAmtWithLen l x = showWithLenDec l 2 ((fromIntegral x :: Double) / 100) + +instance PrettyShow String where + showWithLenDecChar l _ c xs = take (fromIntegral l) (xs ++ repeat c) + +instance PrettyShow Double where + showWithLenDecChar l d c n + | l <= d + 1 = replicate l1 '.' + | d < 0 = replicate l1 '.' + | d == 0 = showWithLen (l-d) (truncate n :: Integer) + | n < 0 && n > (-1) + = showWithLenDec (l-d-2) (-1) (truncate n :: Integer) ++ "." ++ ratioPart -- hack to show '-' in case of -0.01 + | otherwise = showWithLen (l-d-1) (truncate n :: Integer) ++ "." ++ ratioPart + where ratioPart = showWithLenDecChar d 0 '0' $ abs $ (truncate (n * 10^d) - (truncate n) * 10^d ::Integer)-- = replicate (d - lenRatioPartRaw) '0' ++ ratioPartRaw + l1 = fromIntegral l + +instance PrettyShow Day where + showWithLenDecChar 6 _ _ = formatTime defaultTimeLocale "%y%m%d" + showWithLenDecChar _ _ _ = formatTime defaultTimeLocale "%Y %m %d"
+ Text/WtkParser.hs view
@@ -0,0 +1,148 @@+--------------------------------------------------------- +-- +-- Module : Text.WtkParser +-- Copyright : Bartosz Wójcik (2012) +-- License : BSD3 +-- +-- Maintainer : bartek@sudety.it +-- Stability : Unstable +-- Portability : portable +-- +-- Module is part of Wojcik Tool Kit package. +-- | Simple parser for internal usage of Wtk. +-- Motivation for this parser vs. already existing ones +-- was its lightweightness. This decision can be changed +-- in the future, the parser is not available outside wtk. +--------------------------------------------------------- + +module Text.WtkParser +where + +import Control.Monad +import Control.Monad.Trans.Error +import Control.Monad.Trans.State +import Control.Monad.Trans.Class +import Data.Char +import Data.Either + +newtype Parser a = Parser { + runParser :: String -> Either String (String,a) } + +eval :: Parser a -> String -> Either String a +eval p s = case runParser p s of + Left err -> Left err + Right (_,res) -> Right res + +instance Monad Parser where + return a = Parser (\xl -> Right (xl,a)) + fail s = Parser (\xl -> Left s) + Parser m >>= k = Parser $ \xl -> + case m xl of + Left s -> Left s + Right (xl',a) -> + let Parser n = k a + in n xl' + +instance MonadPlus Parser where + mzero = Parser (\xl -> Left "mzero") + Parser p `mplus` Parser q = Parser $ \xl -> + case p xl of + Right a -> Right a + Left err -> case q xl of + Right b -> Right b + Left _ -> Left err + +char :: Char -> Parser Char +char c = Parser char' + where char' [] = Left ("expecting " ++ [c] ++ ",got EOF") + char' (x:xs) | x == c = Right (xs,c) + | otherwise = Left ("expecting " ++ [c] ++ ",got " ++ show x) + +matchChar :: (Char -> Bool) -> Parser Char +matchChar isTrue = Parser mC + where mC [] = Left ("expecting char, got EOF") + mC (x:xs) | isTrue x = Right (xs,x) + | otherwise = Left ("expecting char, got " ++ show x) + +many :: Parser a -> Parser [a] +many (Parser p) = Parser many' + where many' x = + case p x of + Left err -> Right (x,[]) + Right (x',a) -> + let Right (x'',rest) = many' x' + in Right (x'',a:rest) + +manyF :: (a -> a -> a) -> Parser a -> a -> Parser a +manyF f (Parser p) n = Parser many' + where many' x = + case p x of + Left err -> Right (x,n) + Right (x',a) -> + let Right (x'',rest) = many' x' + in Right (x'',rest `f` a) + +skipMany :: Parser p -> Parser () +skipMany (Parser p) = Parser skip' + where skip' x = + case p x of + Left err -> Right (x,()) + Right (x',_) -> skip' x' + +skipSpaces = (skipMany . matchChar) isSpace + +lexeme p = do + v <- p + skipSpaces + return v + +--int :: Parser Int +int = do + t1 <- matchChar isDigit + tr <- many $ matchChar isDigit + return (read (t1:tr)) + +--intSigned :: Parser Int +intSigned = (char '-' >> liftM (*(-1)) int) `mplus` int + +fromIntSign :: (Num a) => Parser a +fromIntSign = liftM fromIntegral intSigned + +fromIntUnsign :: (Num a) => Parser a +fromIntUnsign = liftM fromIntegral int + +decimalize :: (Ord a, Fractional a) => a -> a +decimalize n | abs n >= 1 = decimalize (n / 10) + | otherwise = n + +real :: (Fractional a, Ord a) => Parser a +real = sign >>= \s -> + fromIntUnsign >>= \i -> + (decimalPart >>= \d -> + (expPart >>= \e -> + return (withExp (s * (i + d)) e)) + `mplus` + return (s * (i + d)) + ) + `mplus` + ((expPart >>= \e -> + return (withExp (s*i) e) + ) + `mplus` + return (s*i) + ) + where sign = (char '-' >> return (-1)) `mplus` return 1 + withExp n e | e < 0 = n / 10 ^^ (-e) + | otherwise = n * 10 ^^ e + decimalPart = (char '.' `mplus` char ',') >> + many (char '0') >>= \zeroes -> + (fromIntUnsign >>= \b -> + return ((decimalize b) / 10 ^ length zeroes) + ) + `mplus` + return 0 + expPart = char 'e' >> fromIntSign + +eof = Parser many' + where many' [] = Right ([],()) + many' xs = Left $ "Epexted EOF, got " ++ take 10 xs
+ license view
@@ -0,0 +1,31 @@+Copyright (c) 2012, Bartosz Wójcik++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ wtk.cabal view
@@ -0,0 +1,24 @@+Name: wtk +Version: 0.1 +License: BSD3+License-file: license +Author: Bartosz Wojcik +Maintainer: Bartosz Wojcik <bartoszmwojcik@gmail.com> +Copyright: Copyright (c) 2012 Bartosz Wojcik +Category: Tool Kit +Synopsis: Wojcik Tool Kit +Stability: experimental +Build-type: Simple +Description: Set of simple tools. + +Cabal-Version: >=1.2.3 + +library + Build-Depends: base >= 3 && < 5, old-locale, time, transformers + Exposed-Modules: ReadEither + Calculator + Text.PrettyShow + Other-Modules: Text.WtkParser + + +