Merge pull request #1 from Siriusly/quash-warnings

Quash compiler warnings.

src/AST.hs

@@ -24,41 +24,45 @@ data DecT = DecT String [RHS] deriving Show
 --             Constructor name, [
 data RHS = RHS String [String] deriving Show
 
+list0 :: Name
 list0 = mkName "List0"
+list1 :: Name
 list1 = mkName "List1"
 
 isDataD :: Dec -> Bool
-isDataD (DataD _ _ _ _ _) = True
+isDataD (DataD {}) = True
 isDataD _ = False
 
 -- Converts a Haskell Declaration to our DecT type
 -- (mostly just strips unessecary data and converts Names to Strings)
 dataDToDecT :: Dec -> (DecT, String)
-dataDToDecT (DataD cxt name tvb constructors derives) =
+dataDToDecT (DataD _ {- cxt -} name _ {- tvb -} constructors _ {- derives -}) =
     let rhss = (map conToRHS constructors)
-    in (DecT (showName name) (map (\(x,y) -> x) rhss), (foldr (\(x,y) acc -> "\n" ++ y ++ acc) "" rhss))
+    in (DecT (showName name) (map (\(x,_) -> x) rhss),
+            (foldr (\(_,y) acc -> "\n" ++ y ++ acc) "" rhss))
                 
 dataDToDecT _ = error "dataDtoDecT applied to non-data dec"
 
 -- Converts Haskell Con type (right hand sides in a data declaration)
 conToRHS :: Con -> (RHS, String)
-conToRHS (NormalC n stypes) = let sts = (map stypeToString stypes)
-                              in (RHS (showName n) (map (\(x,y) -> x) sts),
-                                   (foldr (\(x,y) acc -> "\n" ++ y ++ acc) "\n" sts))
+conToRHS (NormalC n stypes) =
+     let sts = (map stypeToString stypes)
+      in (RHS (showName n) (map (\(x,_) -> x) sts),
+           (foldr (\(_,y) acc -> "\n" ++ y ++ acc) "\n" sts))
 conToRHS _ = error "conToRHS on not-NormalC not supported"
 
--- flattenType :: Type -> String
-
 flattenTuple :: Type -> Type -> [Type]
-flattenTuple (TupleT n) t = [t]
+flattenTuple (TupleT _) t = [t]
 flattenTuple (AppT t1 t2) t3 = (flattenTuple t1 t2) ++ [t3]
+flattenTuple _ _ = error "flattenTuple must be called on TupleT or AppT"
 
 -- Converts a type to string, returns pair of the type in string form
 -- and any new rules it needed to produce (for tuples and lists)
 stypeToString :: StrictType -> (String, String)
 stypeToString (_, (ConT n)) = (showName n, "")
-stypeToString (_, (AppT ListT t)) = let (s, rs) = (stypeToString (IsStrict, t))
-                                        in (s ++ "*", (rs ++ "\n\n" ++ makeMultiRules (AppT (ConT list0) t) s))
+stypeToString (_, (AppT ListT t)) = 
+    let (s, rs) = (stypeToString (IsStrict, t))
+     in (s ++ "*", (rs ++ "\n\n" ++ makeMultiRules (AppT (ConT list0) t) s))
 stypeToString (_, (AppT (ConT n) t)) = 
     if n == list0 || n == list1 then 
         let (s, rs) = (stypeToString (IsStrict, t))
@@ -71,19 +75,27 @@ stypeToString (_, (AppT (ConT n) t)) =
                                    (makeTab ("maybe" ++ s)) ++ "| \t{Nothing}"))
     else ("", "")
                                         
-stypeToString (_, (AppT t1 t2)) = let ts = flattenTuple t1 t2 
-                                      ts' = map (stypeToString . (\x -> (IsStrict, x))) ts
-                                      (s, rs) = ((foldr (\(x, y) a -> (fixMultis x) ++ "\\" ++ a) "" ts'),
-                                                 (foldr (\(x, y) a -> y ++ a) "" ts'))
-                                      rs' = rs ++ "\n" ++ (makeTupleRules s)
-                                  in ((filter ((/=) '\\') s), rs')
+stypeToString (_, (AppT t1 t2)) = 
+    let ts = flattenTuple t1 t2 
+        ts' = map (stypeToString . (\x -> (IsStrict, x))) ts
+        (s, rs) = ((foldr (\(x, _) a -> (fixMultis x) ++ "\\" ++ a) "" ts'),
+                   (foldr (\(_, y) a -> y ++ a) "" ts'))
+        rs' = rs ++ "\n" ++ (makeTupleRules s)
+    in ((filter ((/=) '\\') s), rs')
 stypeToString (_, t) = error ("stypeToString of " ++ (show t) ++ " not yet supported")
 
 showDecT :: DecT -> String
-showDecT (DecT n rhs) = n ++ " [" ++ (foldr (\s a -> if a == "" then s else s ++ ", " ++ a) "" (map showRHS rhs)) ++ "] "
+showDecT (DecT n rhs) =
+  n ++ " [" ++ (foldr 
+                  (\s a -> if a == "" then s else s ++ ", " ++ a) 
+                  "" 
+                  (map showRHS rhs))
+            ++ "] "
 
 showRHS :: RHS -> String
-showRHS (RHS n types) = n ++ " [" ++ (foldr (\s a -> if a == "" then s else s ++ ", " ++ a) "" types) ++ "] "
+showRHS (RHS n types) =
+  n ++ " [" ++ 
+    (foldr (\s a -> if a == "" then s else s ++ ", " ++ a) "" types) ++ "] "
 
 -- Indicates if the given RHS construction is unique in the entire
 -- data declaration. data A = X E | Y E E: X,Y are unique, not so
@@ -98,7 +110,7 @@ myappend s1 s2 = s1 ++ " " ++ s2
 -- produces a string of form {$1 $2 ... $n}
 makeNums :: Int -> Int -> String -> String
 makeNums _ 0 _ = ""
-makeNums i 1 sep = "$" ++ (show i) 
+makeNums i 1 _ = "$" ++ (show i) 
 makeNums i n sep = "$" ++ (show (i-n+1)) ++ sep ++ (makeNums i (n-1) sep)
 
 -- produces the construction -> {EXP $1 $2} from the given RHS rule
@@ -109,17 +121,17 @@ isMulti :: String -> Bool
 isMulti "*" = True
 isMulti "+" = True
 isMulti [] = False
-isMulti (s:r) = isMulti r
+isMulti (_:r) = isMulti r
 
 isMulti0 :: String -> Bool
 isMulti0 "*" = True
 isMulti0 [] = False
-isMulti0 (s:r) = isMulti0 r
+isMulti0 (_:r) = isMulti0 r
 
 isMulti1 :: String -> Bool
 isMulti1 "+" = True
 isMulti1 [] = False
-isMulti1 (s:r) = isMulti1 r
+isMulti1 (_:r) = isMulti1 r
 
 fixMultis :: String -> String
 fixMultis s = (if isMulti1 s then "Multi1" 
@@ -141,12 +153,12 @@ strip (s:r) = s:(strip r)
 strip [] = []
 
 makeMultiRules :: Type -> String -> String
-makeMultiRules (AppT (ConT listt) t) s = 
+makeMultiRules (AppT (ConT listt) _) s = 
     let i = if listt == list0 then 0 else 1 
         name = "Multi" ++ (show i) ++ (strip s)
     in name ++ ": " ++ (strip s) ++ " " ++ name ++ 
            "\t{$1:$2}\n" ++ (makeTab name) ++ 
-           (if i == 0 then "|\t{[]}" else ("| " ++ (strip s) ++ "\t{[$1]}"))
+           (if i == (0::Integer) then "|\t{[]}" else ("| " ++ (strip s) ++ "\t{[$1]}"))
 makeMultiRules _ _ = undefined
 
 makeTupleRules :: String -> String
@@ -164,7 +176,7 @@ makeTab s = let helper 0 a = a
 -- will in turn produce the given declaration.
 decTToRule :: DecT -> String
 decTToRule (DecT n rhs) = 
-    let multiRules = "" --foldr getMultiRules "" rhs
+    let -- multiRules = "" --foldr getMultiRules "" rhs
         rhsStrings = map (rhsToRule rhs) rhs 
         tab = makeTab n
     in n ++ ": " ++ (head rhsStrings) ++ "\n" ++
@@ -183,27 +195,28 @@ cleanNLs :: String -> String
 cleanNLs s = cleanNLs' (dropWhile ((==) '\n') s)
 
 cleanMulti :: String -> String
-cleanMulti s = let regex = mkRegex "(^[^:]*:)"
-                   getNames = \s -> case matchRegexAll regex s of
-                                      Nothing -> []
-                                      Just (_, match, rest, _) -> match:(getNames rest)
-                   names = getNames s
-                   dups = repeated names
-                   dups' = map (\x -> (x, False)) dups
-                   removeDups dups s rembef = 
-                       case matchRegexAll regex s of
-                         Nothing -> s
-                         Just (bef, match, rest, _) -> 
-                             case find (\(x,y) -> x == match) dups of
-                               Nothing -> if rembef then match ++ (removeDups dups rest False)
-                                          else bef ++ match ++ (removeDups dups rest False)
-                               Just (x, False) ->
-                                   (if rembef then match else bef ++ match) ++
-                                   (removeDups (insert (x, True) (delete (x, False) dups)) rest False)
-                               Just (x, True) ->
-                                   (if rembef then "" else bef) ++
-                                   (removeDups dups rest True)
-               in (removeDups dups' s False)
+cleanMulti s =
+    let regex = mkRegex "(^[^:]*:)"
+        getNames = \str -> case matchRegexAll regex str of
+                            Nothing -> []
+                            Just (_, match, rest, _) -> match:(getNames rest)
+        names = getNames s
+        duplicates = repeated names
+        dups' = map (\x -> (x, False)) duplicates
+        removeDups dups str rembef = 
+             case matchRegexAll regex str of
+               Nothing -> str
+               Just (bef, match, rest, _) -> 
+                   case find (\(x,_) -> x == match) dups of
+                     Nothing -> if rembef then match ++ (removeDups dups rest False)
+                                else bef ++ match ++ (removeDups dups rest False)
+                     Just (x, False) ->
+                         (if rembef then match else bef ++ match) ++
+                         (removeDups (insert (x, True) (delete (x, False) dups)) rest False)
+                     Just (_, True) ->
+                         (if rembef then "" else bef) ++
+                         (removeDups dups rest True)
+     in (removeDups dups' s False)
 
 parseAstDecs :: String -> Grammar 
 parseAstDecs s = let decs = case parseDecs s of
@@ -211,8 +224,8 @@ parseAstDecs s = let decs = case parseDecs s of
                               (Left err) -> (trace err undefined)
                      dataDs = filter isDataD decs
                      decTs = (map dataDToDecT dataDs)
-                     rules = makeRules (map (\(x,y) -> x) decTs)
-                 in cleanNLs (cleanMulti (foldr (\(x, y) acc -> y ++ acc) "" decTs)) ++ rules
+                     rules = makeRules (map (\(x,_) -> x) decTs)
+                 in cleanNLs (cleanMulti (foldr (\(_, y) acc -> y ++ acc) "" decTs)) ++ rules
                      -- in (foldr (\(x, y) acc -> y ++ acc) "" decTs) ++ rules
 main :: IO ()
 main = do {