wtk 0.1 → 0.2
raw patch · 6 files changed
+284/−284 lines, 6 files
Files
- Calculator.hs +0/−155
- ReadEither.hs +0/−123
- Text/Calculator.hs +155/−0
- Text/PrettyShow.hs +1/−1
- Text/ReadEither.hs +123/−0
- wtk.cabal +5/−5
− Calculator.hs
@@ -1,155 +0,0 @@---------------------------------------------------------- --- --- 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
@@ -1,123 +0,0 @@---------------------------------------------------------- --- --- 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 -
+ Text/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 Text.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)
Text/PrettyShow.hs view
@@ -11,7 +11,7 @@ -- | Type class Show-like formating numbers for humans. --------------------------------------------------------- -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances,FlexibleInstances #-} module Text.PrettyShow (PrettyShow -- type class providing following functions
+ Text/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, FlexibleInstances #-} + +module Text.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 Text.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 +
wtk.cabal view
@@ -1,11 +1,11 @@ Name: wtk -Version: 0.1 -License: BSD3+Version: 0.2 +License: BSD3 License-file: license Author: Bartosz Wojcik Maintainer: Bartosz Wojcik <bartoszmwojcik@gmail.com> Copyright: Copyright (c) 2012 Bartosz Wojcik -Category: Tool Kit +Category: Utils Synopsis: Wojcik Tool Kit Stability: experimental Build-type: Simple @@ -15,8 +15,8 @@ library Build-Depends: base >= 3 && < 5, old-locale, time, transformers - Exposed-Modules: ReadEither - Calculator + Exposed-Modules: Text.ReadEither + Text.Calculator Text.PrettyShow Other-Modules: Text.WtkParser