Add typediff util

typediff/.ghci

@@ -0,0 +1 @@
+:set -isrc -itest

typediff/.gitignore

@@ -0,0 +1 @@
+/dist/

typediff/src/Main.hs

@@ -0,0 +1,23 @@
+module Main where
+
+import           Control.Monad
+import           System.Environment
+import           System.Exit
+import           System.IO
+
+import           TypeDiff
+
+main :: IO ()
+main = do
+  [file1, file2] <- getArgs
+  input1 <- readFile_ file1
+  input2 <- readFile_ file2
+  let diff = typeDiff input1 input2
+  unless (null diff) $ do
+    hPutStr stderr diff
+    exitFailure
+
+readFile_ :: FilePath -> IO String
+readFile_ name = case name of
+  "-" -> getContents
+  _ -> readFile name

typediff/src/TypeDiff.hs

@@ -0,0 +1,101 @@
+module TypeDiff (
+  typeDiff
+
+-- exported for testing
+, sigMap
+, typeEq
+, alphaNormalize
+) where
+
+import           Data.Char
+import           Data.Maybe
+import           Data.List
+import           Data.Map as Map (Map)
+import qualified Data.Map as Map
+import           Language.Haskell.Exts.Syntax
+import           Language.Haskell.Exts.Parser
+
+import           Data.Generics.Uniplate.Data
+
+typeDiff :: String -> String -> String
+typeDiff input1 input2 = unlines (missing ++ extra ++ wrongSigs)
+  where
+    sigs1 = sigMap input1
+    sigs2 = sigMap input2
+
+    names1 = Map.keys sigs1
+    names2 = Map.keys sigs2
+
+    missing = map format (names1 \\ names2)
+      where
+        format :: String -> String
+        format = ("missing " ++)
+
+    extra = map format (names2 \\ names1)
+      where
+        format :: String -> String
+        format = ("extra " ++)
+
+    wrongSigs :: [String]
+    wrongSigs
+      | null mismatches = []
+      | otherwise = "wrong types:" : mismatches
+      where
+        mismatches :: [String]
+        mismatches = (catMaybes . map checkType . Map.toList) sigs1
+
+        checkType :: (String, String) -> Maybe String
+        checkType (name, t1) = case Map.lookup name sigs2 of
+          Just t2 | not (parseType_ t1 `typeEq` parseType_ t2) -> Just (format name t1 ++ "\n" ++ format name t2)
+          _ -> Nothing
+
+        format :: String -> String -> String
+        format name type_ = "  " ++ name ++ " :: " ++ type_
+
+parseType_ :: String -> Type
+parseType_ type_ = case parseType type_ of
+  ParseOk t -> t
+  _ -> error ("can not parse type " ++ show type_)
+
+sigMap :: String -> Map String String
+sigMap = Map.fromList . map splitType . lines
+  where
+    splitType :: String -> (String, String)
+    splitType = fmap stripSigMark . span (not . isSpace)
+
+    stripSigMark :: String -> String
+    stripSigMark = dropWhile isSpace . dropWhile (== ':') . dropWhile isSpace
+
+typeEq :: Type -> Type -> Bool
+typeEq t1 t2 = normalize t1 == normalize t2
+  where normalize = alphaNormalize . normalizeConstrains . sortConstrains
+
+sortConstrains :: Type -> Type
+sortConstrains x = case x of
+  TyForall a1 constrains a2 -> TyForall a1 (sort constrains) a2
+  _ -> x
+
+normalizeConstrains :: Type -> Type
+normalizeConstrains t = case t of
+  TyForall a1 [ParenA a2] a3 -> TyForall a1 [a2] a3
+  _ -> t
+
+alphaNormalize :: Type -> Type
+alphaNormalize t = transformBi f t
+  where
+    f :: Name -> Name
+    f name = fromMaybe name $ lookup name mapping
+
+    names :: [Name]
+    names = (nub . filter isTyVar . universeBi) t
+
+    isTyVar :: Name -> Bool
+    isTyVar x = case x of
+      Ident n -> null (takeWhile isUpper n)
+      _ -> False
+
+    mapping :: [(Name, Name)]
+    mapping = zip names vars
+
+    vars :: [Name]
+    vars = map (Ident . ('t' :) . show) [0 :: Integer ..]

typediff/test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

typediff/test/TypeDiffSpec.hs

@@ -0,0 +1,79 @@
+module TypeDiffSpec (main, spec) where
+
+import           Test.Hspec
+
+import           Data.Map (fromList)
+import           Language.Haskell.Exts.Parser
+import           TypeDiff
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+  describe "sigMap" $ do
+    it "creates mapping from function names to type signatures" $ do
+      sigMap "foo :: Int\nbar :: Float" `shouldBe` fromList [("foo", "Int"), ("bar", "Float")]
+
+  describe "typeDiff" $ do
+    it "returns the empty string on success" $ do
+      let sigs1 = "foo :: Int"
+          sigs2 = "foo :: Int"
+      typeDiff sigs1 sigs2 `shouldBe` ""
+
+    it "detects type missmatches" $ do
+      let sigs1 = "foo :: Float"
+          sigs2 = "foo :: Int"
+      typeDiff sigs1 sigs2 `shouldBe` "wrong types:\n  foo :: Float\n  foo :: Int\n"
+
+    it "detects missing identifiers" $ do
+      let sigs1 = "foo :: a\nbar :: a"
+          sigs2 = "foo :: a"
+      typeDiff sigs1 sigs2 `shouldBe` "missing bar\n"
+
+    it "detects extra identifiers" $ do
+      let sigs1 = "foo :: a"
+          sigs2 = "foo :: a\nbar :: a"
+      typeDiff sigs1 sigs2 `shouldBe` "extra bar\n"
+
+    it "ignores order of constrains" $ do
+      let sigs1 = "truncate :: (Integral b, RealFrac a) => a -> b"
+          sigs2 = "truncate :: (RealFrac a, Integral b) => a -> b"
+      typeDiff sigs1 sigs2 `shouldBe` ""
+
+  describe "typeEq" $ do
+    it "returns False for different types" $ do
+      let ParseOk x = parseType "Int -> Int"
+          ParseOk y = parseType "Float -> Float"
+      typeEq x y `shouldBe` False
+
+    it "returns True for same types" $ do
+      let ParseOk x = parseType "a -> a"
+          ParseOk y = parseType "a -> a"
+      typeEq x y `shouldBe` True
+
+    it "ignores order of constrains" $ do
+      let ParseOk x = parseType "(Integral b, RealFrac a) => a -> b"
+          ParseOk y = parseType "(RealFrac a, Integral b) => a -> b"
+      typeEq x y `shouldBe` True
+
+    it "performs alpha conversion" $ do
+      let ParseOk x = parseType "a -> b"
+          ParseOk y = parseType "b -> a"
+      typeEq x y `shouldBe` True
+
+    it "ignores redundant parentheses for constrains" $ do
+      let ParseOk x = parseType "Floating a => a -> a"
+          ParseOk y = parseType "(Floating a) => a -> a"
+      typeEq x y `shouldBe` True
+
+  describe "alphaNormalize" $ do
+    it "performs alpha conversion" $ do
+      let ParseOk x = parseType "a -> a -> b"
+          ParseOk y = parseType "t0 -> t0 -> t1"
+      alphaNormalize x `shouldBe` y
+
+    it "leaves concrete types intact" $ do
+      let ParseOk x = parseType "Int -> Float"
+          ParseOk y = parseType "Int -> Float"
+      alphaNormalize x `shouldBe` y

typediff/typediff.cabal

@@ -0,0 +1,36 @@
+name:             typediff
+version:          0.0.0
+build-type:       Simple
+cabal-version:    >= 1.10
+
+executable typediff
+  ghc-options:
+      -Wall
+  hs-source-dirs:
+      src
+  main-is:
+      Main.hs
+  build-depends:
+      base == 4.*
+    , containers
+    , uniplate
+    , haskell-src-exts
+  default-language: Haskell2010
+
+test-suite spec
+  type:
+      exitcode-stdio-1.0
+  ghc-options:
+      -Wall
+  hs-source-dirs:
+      test, src
+  main-is:
+      Spec.hs
+  build-depends:
+      base == 4.*
+    , containers
+    , uniplate
+    , haskell-src-exts
+
+    , hspec == 2.*
+  default-language: Haskell2010