gdiff-ig (empty) → 0.1

raw patch · 5 files changed

+374/−0 lines, 5 filesdep +arraydep +basedep +ghc-primsetup-changed

Dependencies added: array, base, ghc-prim, instant-generics, template-haskell

Files

LICENSE +28/−0
Setup.hs +3/−0
examples/Test.hs +56/−0
gdiff-ig.cabal +30/−0
src/Generics/Instant/GDiff.hs +257/−0

+ LICENSE view

@@ -0,0 +1,28 @@+Copyright (c) 2011 Universiteit Utrecht+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of Universiteit Utrecht nor the names of its contributors+   may be used to endorse or promote products derived from this software without+   specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+

+ Setup.hs view

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain

+ examples/Test.hs view

@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# OPTIONS_GHC -Wall                   #-}
+
+module Main where
+
+import Generics.Instant.TH
+import qualified Generics.Instant.Functions.Show as G
+import Generics.Instant.GDiff
+import Test.QuickCheck
+import Test.QuickCheck.Gen
+import System.Random
+import Data.Typeable
+
+-- Testing
+data Tree = Leaf | Node Char Tree Tree deriving (Show, Eq, Typeable)
+$(deriveAll ''Tree)
+
+level :: Tree -> Int
+level Leaf = 0
+level (Node _ l r) = 1 + (max (level l) (level r))
+
+instance G.Show   Tree where show'      = G.show
+instance SEq      Tree where shallowEq  = shallowEqDef
+instance Build    Tree where build      = buildDef
+instance Children Tree where children   = childrenDef
+instance GDiff Tree
+
+instance Arbitrary Tree where
+  arbitrary = sized genTree where
+    genTree n | n <= 1    = elements [Leaf]
+              | otherwise = do x <- elements "ABC"
+                               p <- elements [n `div` 3 .. n - n `div` 3]
+                               q <- elements [n `div` 3 .. n - n `div` 3]
+                               l <- genTree (n-p)
+                               r <- genTree (n-q)
+                               return (Node x l r)
+
+diffValid :: Tree -> Tree -> Property
+diffValid s t = collect (max (level s) (level t)) $ 
+                  patch (diff s t) s == Just t
+
+testQuickCheck, main, testBig :: IO ()
+testQuickCheck = quickCheck diffValid
+
+main = quickCheck diffValid
+
+--------------------------------------------------------------------------------
+-- Performance testing
+
+bigTree1, bigTree2 :: Tree
+bigTree1 = unGen arbitrary (mkStdGen 123) 200
+bigTree2 = unGen arbitrary (mkStdGen 124) 200
+
+testBig = print $ diffLen bigTree1 bigTree2

+ gdiff-ig.cabal view

@@ -0,0 +1,30 @@+category:               Generics+copyright:              (c) 2011 Universiteit Utrecht+name:                   gdiff-ig+version:                0.1+license:                BSD3+license-file:           LICENSE+author:                 José Pedro Magalhães+maintainer:             generics@haskell.org+synopsis:               Generic diff for the instant-generics library+description:               ++  The generic diff of <http://hackage.haskell.org/package/gdiff> adapted to the+  <http://hackage.haskell.org/package/instant-generics> library.+  .+  The Test.hs file (included in the package) shows an example of use of this+  library.++stability:              experimental+build-type:             Simple+homepage:               http://www.cs.uu.nl/wiki/GenericProgramming/InstantGenerics+cabal-version:          >= 1.2.3+tested-with:            GHC == 7.0.2+extra-source-files:     examples/Test.hs++library+  hs-source-dirs:         src+  build-depends:          base >= 4.3.1.0 && < 5, template-haskell >=2.5, +                          instant-generics >= 0.2.1, array, ghc-prim+  exposed-modules:        Generics.Instant.GDiff+  ghc-options:            -Wall

+ src/Generics/Instant/GDiff.hs view

@@ -0,0 +1,257 @@+{-# LANGUAGE GADTs                #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE MagicHash            #-}
+
+module Generics.Instant.GDiff 
+  ( diff, patch, diffLen, GDiff
+  , SEq(..), shallowEqDef
+  , Build(..), buildDef
+  , Children(..), childrenDef
+  , Ex(..)
+  ) where
+
+import Control.Arrow
+import Data.Array
+
+import Data.Typeable
+import GHC.Prim
+
+
+-- GP lib
+import Generics.Instant
+
+--------------------------------------------------------------------------------
+
+ucast :: a -> b
+ucast = unsafeCoerce#
+
+--------------------------------------------------------------------------------
+
+class Children' a where
+  children' :: a -> [Ex]
+  children' _ = []
+
+instance Children' U
+
+instance (Children' a, Children' b) => Children' (a :+: b) where
+  children' (L a) = children' a
+  children' (R a) = children' a
+
+instance (Children' a, Children' b) => Children' (a :*: b) where
+  children' (a :*: b) = children' a ++ children' b 
+
+instance (Children' a) => Children' (C c a) where
+  children' (C a) = children' a
+
+instance (GDiff a) => Children' (Var a) where
+  children' (Var a) = [Ex a]
+
+instance (GDiff a) => Children' (Rec a) where
+  children' (Rec a) = [Ex a]
+
+-- | Gets all the immediate children of a term
+class Children a where
+  children :: a -> [Ex]
+  children _ = []
+
+instance Children Char
+instance Children Int
+
+instance (GDiff a) => Children [a] where
+  children []    = []
+  children (h:t) = [Ex h, Ex t]
+
+childrenDef :: (Representable a, Children' (Rep a)) => a -> [Ex]
+childrenDef x = children' (from x)
+
+--------------------------------------------------------------------------------
+
+class Build' a where
+  build' :: a -> [Ex] -> Maybe (a, [Ex])
+  build' c l = Just (c,l)
+
+instance Build' U
+
+instance (Build' a, Build' b) => Build' (a :+: b) where
+  build' (L a) l = fmap (first L) (build' a l)
+  build' (R a) l = fmap (first R) (build' a l)
+
+instance (Build' a, Build' b) => Build' (a :*: b) where
+  build' (a :*: b) l = do (r,l') <- build' a l
+                          fmap (first (r :*:)) (build' b l')
+
+instance (Build' a) => Build' (C c a) where
+  build' (C a) l = fmap (first C) (build' a l)
+
+instance (GDiff a) => Build' (Var a) where
+  build' (Var _) []         = Nothing
+  build' (Var _) ((Ex h):t) = cast h >>= return . flip (,) t . Var
+
+instance (GDiff a) => Build' (Rec a) where
+  build' (Rec _) []         = Nothing
+  build' (Rec _) ((Ex h):t) = cast h >>= return . flip (,) t . Rec
+
+
+-- | Rebuilds a term, replacing the children with elements from the list
+class Build a where
+  build :: a -> [Ex] -> Maybe (a, [Ex])
+  build c l = Just (c,l)
+
+instance Build Char
+instance Build Int
+
+instance (Typeable a) => Build [a]  where
+  build [] l = Just ([],l)
+  build _ ((Ex h'):(Ex t'):r) = do h <- cast h'
+                                   t <- cast t'
+                                   Just (h:t,r)
+  build _ _ = Nothing
+
+buildDef :: (Representable a, Build' (Rep a)) => a -> [Ex] -> Maybe (a, [Ex])
+buildDef x = fmap (first to) . build' (from x)
+
+--------------------------------------------------------------------------------
+
+-- Shallow equality
+class SEq' a where
+  shallowEq' :: a -> a -> Bool
+
+instance (SEq' a, SEq' b) => SEq' (a :+: b) where
+  shallowEq' (L x) (L x') = shallowEq' x x'
+  shallowEq' (R x) (R x') = shallowEq' x x'
+  shallowEq' _      _     = False
+  
+instance SEq' (C c a) where
+  shallowEq' _ _ = True
+
+
+-- | Shallow equality: compare the constructor name only
+class SEq a where
+  shallowEq :: a -> a -> Bool
+
+instance SEq Char where
+  shallowEq = (==)
+instance SEq Int  where 
+  shallowEq = (==)
+instance SEq [a]  where
+  shallowEq [] [] = True
+  shallowEq (_:_) (_:_) = True
+  shallowEq _ _ = False
+
+shallowEqDef :: (Representable a, SEq' (Rep a)) => a -> a -> Bool
+shallowEqDef x y = shallowEq' (from x) (from y)
+
+--------------------------------------------------------------------------------
+
+-- | Tying the recursive knot
+class (Typeable a, SEq a, Children a, Build a) => GDiff a
+
+instance GDiff Char
+instance GDiff Int
+instance (GDiff a) => GDiff [a]
+
+-- | Existentials
+data Ex where Ex :: (GDiff a) => !a -> Ex
+
+instance Show Ex where
+  -- should improve this
+  show (Ex a) = show (typeOf a)
+
+--------------------------------------------------------------------------------
+
+-- | Edit actions
+data Edit = Cpy !Ex | Del !Ex | Ins !Ex deriving Show
+
+-- | Editscript
+data EditScript = ES !Int# [Edit] deriving Show
+
+editScriptLen :: EditScript -> Int
+editScriptLen (ES _ l) = editScriptLen' l where
+  editScriptLen' []          = 0
+  editScriptLen' ((Cpy _):t) = editScriptLen' t
+  editScriptLen' (_      :t) = 1 + editScriptLen' t
+
+infixr 4 &
+(&) :: EditScript -> EditScript -> EditScript
+l@(ES m _) & r@(ES n _) = if m <=# n then l else r
+
+
+-- | Generic patch
+gpatch :: EditScript -> [Ex] -> Maybe [Ex]
+gpatch (ES 0# [])        [] = Just []
+gpatch (ES 0# [])        _  = Nothing
+gpatch (ES n  (Ins x:t)) ys =                 gpatch (ES (n -# 1#) t) ys >>= insert x
+gpatch (ES n  (Del x:t)) ys = delete x ys >>= gpatch (ES (n -# 1#) t)
+gpatch (ES n  (Cpy x:t)) ys = delete x ys >>= gpatch (ES (n -# 1#) t)    >>= insert x
+gpatch _ _ = error "impossible"
+
+insert :: Ex -> [Ex] -> Maybe [Ex]
+insert (Ex x) l = case splitAt (length (children x)) l of
+                    (xs, r) -> build x xs >>= Just . (:r) . Ex . fst
+
+delete :: Ex -> [Ex] -> Maybe [Ex]
+delete _ [] = Nothing
+delete (Ex x) ((Ex h):t)
+  | typeOf x == typeOf h && length (children x) == length (children h)
+  = Just (children h ++ t)
+  | otherwise = Nothing
+
+--------------------------------------------------------------------------------
+-- Memoization
+type Table = Array (Int,Int) EditScript
+
+gdiffm :: [Ex] -> [Ex] -> EditScript
+gdiffm x y = table ! (length x, length y) where
+  table :: Table
+  table = 
+    array ((0,0),(length x,length y))
+      [ ((m,n),ES 0# []) | m <- [0..length x], n <- [0..length y]] //
+
+    [ ((0,n), add (Ins (y !! (n-1))) (0,n-1))
+    | n <- [1..length y] ] //
+
+    [ ((n,0), add (Del (x !! (n-1))) (n-1,0))
+    | n <- [1..length x] ] //
+
+    [ ((m,n), gen m n) | m <- [1..length x], n <- [1.. length y] ]
+
+  gen m n = case (x !! (m-1), y !! (n-1)) of
+    (Ex x', Ex y') -> (if typeOf x' == typeOf y' && x' `shallowEq` (ucast y')
+                        -- && length xs == length ys -- do we need this?
+                       then (add (Cpy (Ex x')) (m-1,n-1)) & alt
+                       else alt) where
+      alt = add (Del (x !! (m-1))) (m-1,n) &
+            add (Ins (y !! (n-1))) (m,n-1)
+
+  add :: Edit -> (Int,Int) -> EditScript
+  add e (a,b) = case table ! (a,b) of ES n l -> ES (n +# 1#) (e:l)
+
+allChildren :: Ex -> [Ex]
+allChildren (Ex a) = Ex a : concatMap allChildren (children a)
+{-
+-- I thought this would use less memory, but apparently it doesn't
+allChildren (Ex x) = ux : concatMap allChildren xs
+  where xs  = children x
+        uxs = map (\(Ex y) -> Ex (undefined `asTypeOf` y)) xs
+        ux  = Ex . fst . fromJust $ build x uxs
+-}
+
+--------------------------------------------------------------------------------
+
+-- Top level functions
+-- | Generic diff
+diff :: (GDiff a) => a -> a -> EditScript
+diff x y = gdiffm (reverse (allChildren (Ex x))) (reverse (allChildren (Ex y)))
+
+-- | Generic diff
+patch :: (GDiff a) => EditScript -> a -> Maybe a
+patch es x = case gpatch es [Ex x] of
+               Just [Ex h] -> cast h
+               _           -> Nothing
+
+-- | Edit distance
+diffLen :: (GDiff a) => a -> a -> Float
+diffLen x y = fromIntegral (editScriptLen (diff x y)) / 
+                fromIntegral (length (allChildren (Ex x)))