From 16f326696f70518922b026c2d9d50903f1c9e3f0 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Tue, 31 Mar 2015 16:27:00 +0800 Subject: [PATCH] Add typediff util --- typediff/.ghci | 1 + typediff/.gitignore | 1 + typediff/src/Main.hs | 23 ++++++++ typediff/src/TypeDiff.hs | 101 ++++++++++++++++++++++++++++++++++ typediff/test/Spec.hs | 1 + typediff/test/TypeDiffSpec.hs | 79 ++++++++++++++++++++++++++ typediff/typediff.cabal | 36 ++++++++++++ 7 files changed, 242 insertions(+) create mode 100644 typediff/.ghci create mode 100644 typediff/.gitignore create mode 100644 typediff/src/Main.hs create mode 100644 typediff/src/TypeDiff.hs create mode 100644 typediff/test/Spec.hs create mode 100644 typediff/test/TypeDiffSpec.hs create mode 100644 typediff/typediff.cabal diff --git a/typediff/.ghci b/typediff/.ghci new file mode 100644 index 0000000..11102c1 --- /dev/null +++ b/typediff/.ghci @@ -0,0 +1 @@ +:set -isrc -itest diff --git a/typediff/.gitignore b/typediff/.gitignore new file mode 100644 index 0000000..178135c --- /dev/null +++ b/typediff/.gitignore @@ -0,0 +1 @@ +/dist/ diff --git a/typediff/src/Main.hs b/typediff/src/Main.hs new file mode 100644 index 0000000..acb716a --- /dev/null +++ b/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 diff --git a/typediff/src/TypeDiff.hs b/typediff/src/TypeDiff.hs new file mode 100644 index 0000000..3828701 --- /dev/null +++ b/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 ..] diff --git a/typediff/test/Spec.hs b/typediff/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/typediff/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/typediff/test/TypeDiffSpec.hs b/typediff/test/TypeDiffSpec.hs new file mode 100644 index 0000000..f3af57b --- /dev/null +++ b/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 diff --git a/typediff/typediff.cabal b/typediff/typediff.cabal new file mode 100644 index 0000000..1602d10 --- /dev/null +++ b/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