-
Notifications
You must be signed in to change notification settings - Fork 12
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
7 changed files
with
242 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1 @@ | ||
:set -isrc -itest |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1 @@ | ||
/dist/ |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 ..] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1 @@ | ||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 |