summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--AST.hs21
-rw-r--r--Main.hs13
-rw-r--r--Parser.hs69
-rw-r--r--Simplify.hs25
-rw-r--r--Utility.hs2
5 files changed, 64 insertions, 66 deletions
diff --git a/AST.hs b/AST.hs
index d4c669b..7968f5e 100644
--- a/AST.hs
+++ b/AST.hs
@@ -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
diff --git a/Main.hs b/Main.hs
index b908807..f4c0472 100644
--- a/Main.hs
+++ b/Main.hs
@@ -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 ()
diff --git a/Parser.hs b/Parser.hs
index 636c04f..3bcf530 100644
--- a/Parser.hs
+++ b/Parser.hs
@@ -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
diff --git a/Utility.hs b/Utility.hs
index a160cb7..e2c245d 100644
--- a/Utility.hs
+++ b/Utility.hs
@@ -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