diff options
| -rw-r--r-- | AST.hs | 21 | ||||
| -rw-r--r-- | Main.hs | 13 | ||||
| -rw-r--r-- | Parser.hs | 69 | ||||
| -rw-r--r-- | Simplify.hs | 25 | ||||
| -rw-r--r-- | Utility.hs | 2 |
5 files changed, 64 insertions, 66 deletions
@@ -5,11 +5,10 @@ module AST where import qualified Data.Map.Strict as Map import Data.List import Data.Data -import Data.Typeable import Control.DeepSeq import PrettyPrint -import Debug +-- import Debug data AST = Number Double @@ -40,13 +39,13 @@ instance PrettyPrint AST where prettyPrint (Negative n) = '-' : case n of s@(Sum _) -> '(' : prettyPrint s ++ ")" - n -> prettyPrint n + _ -> prettyPrint n prettyPrint (Reciprocal n) = "1/" ++ case n of s@(Sum _) -> '(' : prettyPrint s ++ ")" s@(Product _) -> '(' : prettyPrint s ++ ")" s@(Reciprocal _) -> '(' : prettyPrint s ++ ")" - n -> prettyPrint n + _ -> prettyPrint n prettyPrint (Apply name args) = name ++ "(" ++ intercalate "," (map prettyPrint args) ++ ")" @@ -113,6 +112,7 @@ astIsCapture _ = False astFromNumber :: AST -> Double astFromNumber (Number n) = n +astFromNumber _ = undefined astMatchSimple :: AST -> AST -> Bool @@ -177,12 +177,13 @@ matchList :: ([AST] -> AST) -- AST constructor for this list (for inserti -> [AST] -- unordered patterns -> [AST] -- unordered subjects -> [Map.Map String AST] -- list of possible capture assignments -matchList constr pats subs = - let ordered = sort pats +matchList constr toppats topsubs = + let ordered = sort toppats (captures,nocaps) = span astIsCapture ordered in assertS "At most one capture in sum/product" (length captures <= 1) $ case captures of - [] -> matchListDBG Nothing nocaps subs - [c] -> matchListDBG (Just c) nocaps subs + [] -> matchListDBG Nothing nocaps topsubs + [c] -> matchListDBG (Just c) nocaps topsubs + _ -> undefined where matchList' :: Maybe AST -> [AST] -> [AST] -> [Map.Map String AST] matchList' Nothing [] [] = [Map.empty] matchList' Nothing [] _ = [] @@ -240,7 +241,7 @@ replaceCaptures mp n = case n of Apply name n2 -> Apply name $ map (replaceCaptures mp) n2 Capture name -> maybe n id $ Map.lookup name mp CaptureTerm name -> maybe n id $ Map.lookup name mp - CaptureConstr name c -> maybe n id $ Map.lookup name mp + CaptureConstr name _ -> maybe n id $ Map.lookup name mp hasCaptures :: AST -> Bool @@ -269,7 +270,7 @@ mapDel :: (a -> [a] -> b) -> [a] -> [b] mapDel _ [] = [] mapDel f l = let splits = zip l - $ map (\(a,b:bs) -> a++bs) + $ map (\(a,_:bs) -> a++bs) $ iterate (\(a,b:bs) -> (a++[b],bs)) ([],l) in map (uncurry f) splits @@ -3,18 +3,16 @@ module Main where import Control.Monad import Data.Char import Data.List -import Data.Either import Data.Maybe import System.Console.Readline import System.Exit import System.IO import qualified Data.Map.Strict as Map -import AST hiding (main) +import AST import Simplify import Parser import PrettyPrint -import Utility import Debug @@ -22,7 +20,7 @@ trimlr :: String -> String trimlr = reverse . dropWhile isSpace . reverse . dropWhile isSpace findstr :: String -> String -> Maybe Int -findstr pat sub = go sub 0 +findstr pat topsub = go topsub 0 where len = length pat go :: String -> Int -> Maybe Int go "" _ = Nothing @@ -103,14 +101,15 @@ readrules handle = liftM (uncurry fixincludes) $ go "general" Map.empty Map.empt fixincludes :: Map.Map String [(AST,AST)] -- rules db -> Map.Map String [String] -- to be included sections -> Map.Map String [(AST,AST)] -- resulting rules db - fixincludes db includes = Map.foldlWithKey insertincludes db includes + fixincludes topdb includes = Map.foldlWithKey insertincludes topdb includes where insertincludes :: Map.Map String [(AST,AST)] -- db -> String -- section -> [String] -- sections to be included -> Map.Map String [(AST,AST)] -- resulting db - insertincludes db sect incls = foldl (\db incl -> insertinclude db sect incl) db incls - where insertinclude db sect incl = Map.insertWith (++) sect (fromJust $ Map.lookup incl db) db + insertincludes db sect incls = + foldl (\db' incl -> insertinclude db' sect incl) db incls + where insertinclude db' sect' incl = Map.insertWith (++) sect' (fromJust $ Map.lookup incl db') db' printrules :: [(AST,AST)] -> IO () @@ -3,7 +3,6 @@ module Parser (parseExpression) where import Control.Applicative import Control.Monad import Data.Char -import Data.Maybe import AST import Utility @@ -13,7 +12,7 @@ parseExpression :: String -> Either String AST parseExpression s = case parse pexpression s of ((node,rest):_) -> case rest of "" -> Right node - s -> Left $ "Cannot parse from '" ++ take 10 rest ++ "'" + _ -> Left $ "Cannot parse from '" ++ take 10 rest ++ "'" _ -> Left "No valid parse" @@ -50,6 +49,7 @@ mplus1 p q = Parser $ \cs -> case parse (mplus p q) cs of (x:_) -> [x] --(++) = mplus +(+++) :: Parser a -> Parser a -> Parser a (+++) = mplus1 @@ -75,8 +75,8 @@ pchar c = psat (==c) pstring :: String -> Parser String pstring "" = return "" pstring (c:cs) = do - pchar c - pstring cs + void $ pchar c + void $ pstring cs return (c:cs) pmany :: Parser a -> Parser [a] @@ -88,24 +88,16 @@ pmany1 p = do as <- pmany p return (a:as) -pinteger :: Parser Int -pinteger = do - s <- pmany $ psat isDigit - return $ read s +-- pinteger :: Parser Int +-- pinteger = do +-- s <- pmany $ psat isDigit +-- return $ read s pdouble :: Parser Double pdouble = Parser reads -pquotstring :: Parser String -pquotstring = Parser reads - -poptws :: Parser String -poptws = Parser $ pure . span isSpace - -pws :: Parser String -pws = Parser $ \s -> case span isSpace s of - ("",_) -> [] - tup@(_,_) -> [tup] +poptws :: Parser () +poptws = void $ Parser $ pure . span isSpace pword :: Parser String pword = do @@ -137,14 +129,14 @@ pinfixoperator (plus,minus) pterm sumconstr negconstr plusopt noneg = do pmoretermsplus term = do poptws - pchar plus + void $ pchar plus poptws nextterm <- pterm let thissum = sumconstr [term,nextterm] pmoreterms thissum +++ return thissum pmoretermsminus term = do poptws - pchar minus + void $ pchar minus poptws nextterm <- pterm let thissum = sumconstr [term,negconstr nextterm] @@ -170,7 +162,12 @@ pfactor :: Parser AST pfactor = pnegative +++ pfactornoneg +++ pcapture +++ pcaptureterm pnegative :: Parser AST -pnegative = do {pchar '-'; poptws; f <- pfactor; return $ Negative f} +++ pfactornoneg +pnegative = (do + void $ pchar '-' + poptws + f <- pfactor + return $ Negative f) + +++ pfactornoneg pfactornoneg :: Parser AST pfactornoneg = do @@ -179,34 +176,34 @@ pfactornoneg = do where ppower fact = do poptws - pchar '^' + void $ pchar '^' poptws fact2 <- pfactornoneg return $ Apply "pow" [fact,fact2] pfactorial fact = do poptws - pchar '!' + void $ pchar '!' return $ Apply "fact" [fact] pparenthetical :: Parser AST pparenthetical = do - pchar '(' + void $ pchar '(' poptws - sum <- psum + s <- psum poptws - pchar ')' - return sum + void $ pchar ')' + return s pfunctioncall :: Parser AST pfunctioncall = do name <- pword poptws - pchar '(' + void $ pchar '(' poptws args <- parglist poptws - pchar ')' + void $ pchar ')' return $ Apply name args where parglist = do @@ -214,7 +211,7 @@ pfunctioncall = do poptws pmoreargs arg +++ return [arg] pmoreargs arg = do - pchar ',' + void $ pchar ',' poptws args <- parglist return (arg:args) @@ -222,18 +219,18 @@ pfunctioncall = do pcapture :: Parser AST pcapture = do - pchar '[' + void $ pchar '[' name <- pmany1 $ psat (/=']') - pchar ']' + void $ pchar ']' return $ Capture name pcaptureterm :: Parser AST pcaptureterm = do - pchar '[' - pchar '[' + void $ pchar '[' + void $ pchar '[' name <- pmany1 $ psat (/=']') - pchar ']' - pchar ']' + void $ pchar ']' + void $ pchar ']' return $ CaptureTerm name pexpression :: Parser AST diff --git a/Simplify.hs b/Simplify.hs index 9ae29f1..4cb8354 100644 --- a/Simplify.hs +++ b/Simplify.hs @@ -1,19 +1,18 @@ module Simplify (simplify) where import Data.List -import qualified Data.Map.Strict as Map import AST import Utility import Debug -import PrettyPrint +-- import PrettyPrint tracex :: (Show a) => String -> a -> a tracex s x = trace (s ++ ": " ++ show x) x -tracexp :: (PrettyPrint a) => String -> a -> a -tracexp s x = trace (s ++ ": " ++ prettyPrint x) x +-- tracexp :: (PrettyPrint a) => String -> a -> a +-- tracexp s x = trace (s ++ ": " ++ prettyPrint x) x simplify :: [(AST,AST)] -> AST -> AST @@ -33,17 +32,17 @@ flattenSums node = case node of (Sum args) -> case length args of 0 -> Number 0 1 -> flattenSums $ args !! 0 - otherwise -> Sum $ concat $ map (listify . flattenSums) args + _ -> Sum $ concat $ map (listify . flattenSums) args where - listify (Sum args) = args - listify node = [node] + listify (Sum a) = a + listify n = [n] (Product args) -> case length args of 0 -> Number 1 1 -> flattenSums $ args !! 0 - otherwise -> Product $ concat $ map (listify . flattenSums) args + _ -> Product $ concat $ map (listify . flattenSums) args where - listify (Product args) = args - listify node = [node] + listify (Product a) = a + listify n = [n] _ -> node foldNumbers :: AST -> AST @@ -55,7 +54,7 @@ foldNumbers node = case node of _ -> Negative $ fn (Reciprocal n) -> let fn = foldNumbers n in case fn of (Number x) -> Number (1/x) - (Negative n) -> Negative $ Reciprocal fn + (Negative _) -> Negative $ Reciprocal fn (Reciprocal n2) -> n2 _ -> Reciprocal $ fn (Apply name args) -> let fargs = map foldNumbers args @@ -74,7 +73,7 @@ foldNumbers node = case node of foldvalue = func $ map (\(Number n) -> n) nums in case length nums of x | x >= 1 -> if foldvalue == zerovalue then notnums else Number foldvalue : notnums - otherwise -> foldedArgs + _ -> foldedArgs dofoldnegsToProd args = let foldedArgs = map foldNumbers args (negs,notnegs) = partition isneg foldedArgs @@ -88,7 +87,7 @@ foldNumbers node = case node of in case length negs of x | x < 2 -> Product args | even x -> Product unnegged - | odd x -> Product $ Number (-1) : unnegged + | otherwise -> Product $ Number (-1) : unnegged canonicaliseOrder :: AST -> AST canonicaliseOrder node = case node of @@ -18,6 +18,8 @@ setcompareBy p a@(x:xs) b = length a == length b && setcompareBy p xs (deleteBy deleteIndex :: Int -> [a] -> [a] deleteIndex 0 (_:xs) = xs deleteIndex i (x:xs) | i > 0 = x : deleteIndex (i-1) xs + | otherwise = error "Negative index in deleteIndex" +deleteIndex _ [] = error "Too high index in deleteIndex" fromLeft :: Either a b -> a fromLeft (Left a) = a |