data-reify (empty) → 0.1
raw patch · 8 files changed
+395/−0 lines, 8 filesdep +basedep +ghc-primsetup-changed
Dependencies added: base, ghc-prim
Files
- Data/Unsafe/Reify.hs +64/−0
- LICENSE +25/−0
- Setup.hs +2/−0
- data-reify.cabal +58/−0
- test/Test1.hs +49/−0
- test/Test2.hs +37/−0
- test/Test3.hs +126/−0
- test/Test4.hs +34/−0
+ Data/Unsafe/Reify.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE MagicHash, UndecidableInstances, TypeFamilies #-}+module Data.Unsafe.Reify (+ MuRef(..),+ Graph(..),+ reifyGraph+ ) where++import GHC.Exts (Int(I#))+import GHC.Prim (reallyUnsafePtrEquality#, (/=#))+import Control.Concurrent.MVar+import Control.Monad+import Data.Unique++++-- | 'MuRef' is a class that provided a way to reference into a specific type,+-- and a way to map over the deferenced internals.++class MuRef a where+ type DeRef a :: * -> *+ deRef :: a -> (DeRef a) a++ mapDeRef :: (Monad m) => (a -> m Unique) -> (DeRef a) a -> m (DeRef a Unique)+++-- 'Graph' is a basic graph structure over nodes of the higher kind 'e', with a single root.+data Graph e = Graph [(Unique,e Unique)] Unique+++instance (Functor e,Show (e Int)) => Show (Graph e) where+ show (Graph netlist start) = "let " ++ show [ (hashUnique u,fmap hashUnique e)+ | (u,e) <- netlist + ] ++ " in " ++ show (hashUnique start)++-- | 'reifyGraph' takes a data structure that admits 'MuRef', and returns a 'Graph' that contains+-- the dereferenced nodes, with their children as 'Unique' rather than recursive values.++reifyGraph :: (MuRef s) => s -> IO (Graph (DeRef s))+reifyGraph m = do rt1 <- newMVar []+ rt2 <- newMVar []+ root <- findNodes rt1 rt2 m+ pairs <- readMVar rt2+ return (Graph pairs root)++findNodes :: (MuRef s) => MVar [(Unique,s)] -> MVar [(Unique,DeRef s Unique)] -> s -> IO Unique+findNodes rt1 rt2 j = do+ tab <- takeMVar rt1+ case [ m | (m,i) <- tab, j `seq` i `seq` (j `eq` i) ] of+ (var:_) -> do putMVar rt1 tab+ return $ var+ [] -> do var <- newUnique+ let e = deRef j + putMVar rt1 $ (var,j) : tab+ res <- mapDeRef (findNodes rt1 rt2) e+ tab' <- takeMVar rt2+ putMVar rt2 $ (var,res) : tab'+ return var+ +-- Dangerous, dangerous stuff.+eq :: a -> a -> Bool+eq a b = reallyUnsafePtrEquality# a b /=# 0#++ +
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2009 Andy Gill+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. The names of the authors may not be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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,2 @@+import Distribution.Simple+main = defaultMain
+ data-reify.cabal view
@@ -0,0 +1,58 @@+Name: data-reify+Version: 0.1+Synopsis: Reify a recursive data structure into an explicit graph.+Description: 'data-reify' provided the ability to turn recursive structures into explicit graphs. + Many (implicitly or explicitly) recursive data structure can be given this ability, via+ a type class instance. This gives an alternative to using 'Ref' for observable sharing.+ .+ Observable sharing in general is unsafe (hence the module path name Data.Unsafe.Reify), + but can be used safely if some simple conditions are met.+ Typically this package will be used to tie the knot with DSL's that depend of+ observable sharing, like Lava.+ .+ Providing an instance for 'MuRef' is the mechanism for allowing a structure to be + reified into a graph, and four examples of this are provided.+ .+ © 2009 Andy Gill; BSD3 license.++Category: Language, Data, Parsing, Reflection +License: BSD3+License-file: LICENSE+Author: Andy Gill+Maintainer: Andy Gill <andygill@ku.edu>+Copyright: (c) 2009 Andy Gill+Homepage: http://ittc.ku.edu/~andygill/data-reify.php+Stability: alpha+build-type: Simple+Cabal-Version: >= 1.6++Library+ Build-Depends: base, ghc-prim+ Exposed-modules:+ Data.Unsafe.Reify+ Ghc-Options: -Wall+++Executable data-reify-test1+ Build-Depends: base+ Main-Is: Test1.hs+ Hs-Source-Dirs: ., test+ buildable: False++Executable data-reify-test2+ Build-Depends: base+ Main-Is: Test2.hs+ Hs-Source-Dirs: ., test+ buildable: False++Executable data-reify-test3+ Build-Depends: base+ Main-Is: Test3.hs+ Hs-Source-Dirs: ., test+ buildable: False++Executable data-reify-test4+ Build-Depends: base+ Main-Is: Test4.hs+ Hs-Source-Dirs: ., test+ buildable: False
+ test/Test1.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TypeFamilies #-}+module Main where++import qualified Data.Traversable as T+import qualified Data.Foldable as F+import Data.Monoid+import Control.Applicative hiding (Const)+import Data.Unique+import Data.Unsafe.Reify++newtype Mu a = In (a (Mu a))++instance (T.Traversable a) => MuRef (Mu a) where+ type DeRef (Mu a) = a+ deRef (In a) = a+ + mapDeRef = T.mapM++data List a b = Cons a b | Nil+ deriving Show+ +type MyList a = Mu (List a)++instance Functor (List a) where+ fmap f Nil = Nil+ fmap f (Cons a b) = Cons a (f b)++instance F.Foldable (List a) where+ foldMap f Nil = mempty+ foldMap f (Cons a b) = f b++instance T.Traversable (List a) where+ traverse f (Cons a b) = Cons <$> pure a <*> f b+ traverse f Nil = pure Nil+++main = do+ let g1 :: MyList Int+ g1 = In (Cons 1 (In (Cons 2 (In Nil))))+ reifyGraph g1 >>= print+ let g2 = In (Cons 1 (In (Cons 2 g2)))+ reifyGraph g2 >>= print+ let count n m | n == m = In Nil+ | otherwise = In (Cons n (count (succ n) m)) + let g3 = count 1 1000 + reifyGraph g3 >>= print+ + +
+ test/Test2.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TypeFamilies #-}+module Main where++import qualified Data.Traversable as T+import qualified Data.Foldable as F+import Data.Monoid+import Control.Applicative hiding (Const)+import Data.Unique+import Data.Unsafe.Reify+import Control.Monad++-- Notice how there is nothing Mu-ish about this datatype.+data State a b = State a [(b,State a b)]+ deriving Show++s0 = State 0 [(True,s1),(False,s2)]+s1 = State 1 [(True,s0),(False,s1)]+s2 = State 2 [(True,s1),(False,s0)]++data StateDeRef a b r = StateDeRef a [(b,r)]+ deriving Show++instance MuRef (State a b) where+ type DeRef (State a b) = StateDeRef a b+ deRef (State a tr) = StateDeRef a tr+ mapDeRef f (StateDeRef a tr) = liftM (StateDeRef a) $ mapM (\ (b,s) -> liftM ((,) b) $ (f s)) tr++instance Functor (StateDeRef a b) where+ fmap f (StateDeRef a tr) = StateDeRef a [ (b,f s) | (b,s) <- tr ]+++main = do+ reifyGraph s0 >>= print++ + +
+ test/Test3.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE TypeFamilies #-}+module Main where++import qualified Data.Traversable as T+import qualified Data.Foldable as F+import Data.Monoid+import Control.Applicative hiding (Const)+import Data.Unique+import Control.Monad++import Data.Unsafe.Reify+ ++data Signal = Signal (Circuit Signal)++-- Call this 'Circuit'+data Circuit c+ = And2 (c,c)+ | Xor2 (c,c)+ | Mux2 c (c,c)+ | Delay c+ | Const BitValue+ | Var String+ deriving (Eq,Ord)++newtype Mu a = In (a (Mu a))++instance MuRef Signal where+ type DeRef Signal = Circuit+ deRef (Signal s) = s+ + mapDeRef = T.mapM+ +instance Show Signal where+ show (Signal b) = show b++instance Show c => Show (Circuit c) where+ show (Const bv) = show bv+ show (And2 (b1,b2)) = "and(" ++ show b1 ++ "," ++ show b2 ++ ")"+ show (Xor2 (b1,b2)) = "xor(" ++ show b1 ++ "," ++ show b2 ++ ")"+ show (Mux2 s (b1,b2)) = "mux(" ++ show s ++ "," ++ show b1 ++ "," ++ show b2 ++ ")"+ show (Delay b) = "delay(" ++ show b ++ ")"+ show (Var str) = show str+ +and2 (s1,s2) = Signal (And2 (s1,s2))+xor2 (s1,s2) = Signal (Xor2 (s1,s2))+mux2 s (s1,s2) = Signal (Mux2 s (s1,s2))+delay s = Signal (Delay s)++pad :: String -> Signal+pad nm = Signal (Var nm)++data BitValue = High | Low+ deriving (Eq,Ord)++high = Signal $ Const High+low = Signal $ Const Low++instance Show BitValue where+ show High = "high"+ show Low = "low"++halfAdder :: (Signal,Signal) -> (Signal,Signal)+halfAdder (a,b) = (carry,sum)+ where carry = and2 (a,b)+ sum = xor2 (a,b)++fullAdder :: (Signal,(Signal,Signal)) -> (Signal,Signal)+fullAdder (cin,(a,b)) = (cout,sum)+ where (car1,sum1) = halfAdder (a,b)+ (car2,sum) = halfAdder (cin,sum1)+ cout = xor2 (car1,car2)+ +instance F.Foldable Circuit where+ foldMap f (And2 (e1,e2)) = f e1 `mappend` f e2+ foldMap f (Xor2 (e1,e2)) = f e1 `mappend` f e2+ foldMap f (Mux2 s (e1,e2)) = f s `mappend` f e1 `mappend` f e2+ foldMap f (Delay s) = f s+ foldMap f (Const _) = mempty+ foldMap f (Var _) = mempty+++instance Functor Circuit where+ fmap f (And2 (e1,e2)) = And2 (f e1,f e2)+ fmap f (Xor2 (e1,e2)) = Xor2 (f e1,f e2)+ fmap f (Mux2 s (e1,e2)) = Mux2 (f s) (f e1,f e2)+ fmap f (Delay s) = Delay (f s)+ fmap f (Const a) = Const a+ fmap f (Var a) = Var a++instance T.Traversable Circuit where+ traverse f (And2 (e1,e2)) = (\ x y -> And2 (x,y)) <$> f e1 <*> f e2+ traverse f (Xor2 (e1,e2)) = (\ x y -> Xor2 (x,y)) <$> f e1 <*> f e2+ traverse f (Mux2 c (e1,e2)) = (\ c x y -> Mux2 c (x,y)) <$> f c <*> f e1 <*> f e2+ traverse f (Delay s) = Delay <$> f s+ traverse f (Const a) = pure (Const a)+ traverse f (Var a) = pure (Var a)++rowLA :: (Signal -> (b,b) -> b) -> ((Signal,a) -> (Signal,b)) -> (Signal,[a]) ->+ (Signal,[b])+rowLA mymux f (cin,[]) = (cin,[])+rowLA mymux f (cin,[a]) = (car,[sum])+ where+ (car,sum) = f (cin,a)+rowLA mymux f (cin,cs) = (mux2 cout1 (cout2_lo,cout2_hi),+ sums1 ++ + [ mymux cout1 (s_lo,s_hi)+ | (s_lo,s_hi) <- zip sums2_lo sums2_hi+ ])+ where+ len = length cs `div` 2+ (cout1,sums1) = rowLA mymux f (cin,take len cs)+ (cout2_hi,sums2_hi) = rowLA mymux f (high,drop len cs)+ (cout2_lo,sums2_lo) = rowLA mymux f (low,drop len cs)+++main = do+ let g1 = xor2 (xor2 (pad "a",pad "b"),g1)+ reifyGraph g1 >>= print+ let (g2,_) = rowLA mux2 fullAdder+ (pad "c",[ (pad $ "a" ++ show x,pad $ "b" ++ show x)+ | x <- [1..20]+ ])+ reifyGraph g2 >>= print++
+ test/Test4.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies #-}+module Main where++import qualified Data.Traversable as T+import qualified Data.Foldable as F+import Data.Monoid+--import Control.Monad+import Control.Applicative hiding (Const)+import Data.Unique++import Data.Unsafe.Reify -- Should this is Unsafe.Reify??+import Control.Monad++data List a b = Nil | Cons a b+ deriving Show+ ++instance MuRef [a] where+ type DeRef [a] = List a + deRef [] = Nil+ deRef (x:xs) = Cons x xs++ mapDeRef f (Cons x xs) = liftM (Cons x) $ f xs+ mapDeRef f Nil = return Nil+ +instance Functor (List a) where+ fmap f Nil = Nil+ fmap f (Cons a b) = Cons a (f b)++main = do+ let g1 = [1..10]+ reifyGraph g1 >>= print+ let g2 = [1..10] ++ g2+ reifyGraph g2 >>= print