diff --git a/Data/Graph/EasyGrapher/EasyGrapher.hs b/Data/Graph/EasyGrapher/EasyGrapher.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/EasyGrapher/EasyGrapher.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE NamedFieldPuns, StandaloneDeriving, DeriveDataTypeable, TypeSynonymInstances #-} +module Data.Graph.EasyGrapher.EasyGrapher (EGGraph(..), EGTerm(..), buildGraph, fromGr) where +import Data.Graph.Inductive hiding(empty) +import qualified Data.Graph.Inductive as G +import Control.Monad +import Data.Map hiding (map, empty) +import qualified Data.Map as M +import Control.Monad.State +import Data.Maybe +import Prelude hiding (lookup) +import Data.Generics +import qualified Data.Graph as DG +import Data.List (sort) + +-- |'EGTerm' is a vertex & an edge. +data (Eq a, Ord a) => EGTerm a = a :=> a | EGVertex a deriving (Show, Eq, Typeable, Ord) +deriving instance (Data a, Ord a)=>Data (EGTerm a) + +-- |'EGGraph a' is a list of 'EGTerm a'. +type EGGraph a = [EGTerm a] + +data Env gr a = Env{graph :: gr a (), dic :: Map a Node} +empty :: (Eq a, DynGraph gr) => Env gr a +empty = Env{graph = G.empty, dic = M.empty} + +type GrMachine gr lab a = State (Env gr lab) a + +-- |'buildGraph' converts EGGraph 'gr' into the '(gr a ())' +buildGraph :: (DynGraph gr, Ord a) => EGGraph a -> gr a () +buildGraph gr = evalState (build gr) empty + +build :: (Ord lab, DynGraph gr) => EGGraph lab -> GrMachine gr lab (gr lab ()) +build [] = gets graph +build ((lab1 :=> lab2):xs) = do + [n1, n2] <- mapM toNode [lab1, lab2] + env@Env{graph} <- get + put $ env{graph=insEdge (n1, n2, ()) graph} + build xs +build ((EGVertex lab):xs) = toNode lab >> build xs + +toNode :: (Ord lab, DynGraph gr) => lab -> GrMachine gr lab Node +toNode lab = do + cond <- gets $ notMember lab . dic + when cond $ mkNode lab + gets $ fromJust . lookup lab . dic + where + mkNode :: (Ord lab, DynGraph gr) => lab -> GrMachine gr lab () + mkNode lab = do + (nd:_) <- gets (newNodes 1 . graph) + env@Env{graph, dic} <- get + put $ env{graph=insNode (nd, lab) graph, dic=insert lab nd dic} + +-- |'fromGr' converts 'gr :: (gr a ())' into 'EGGraph a' +fromGr :: (Graph gr, Ord a) => gr a () -> EGGraph a +fromGr gr = sort $ map (uncurry (:=>).(\(a,b)->(toL a, toL b))) $ edges gr + where toL = fromJust . lab gr diff --git a/Data/Graph/EasyGrapher/Quote.hs b/Data/Graph/EasyGrapher/Quote.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/EasyGrapher/Quote.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TemplateHaskell, NamedFieldPuns, TupleSections, DeriveDataTypeable, + NoMonomorphismRestriction #-} +module Data.Graph.EasyGrapher.Quote (gr) where +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Text.Parsec hiding ((<|>), many, State, label) +import Control.Applicative +import Data.Graph.EasyGrapher.EasyGrapher +import Data.Generics +import Data.List + +-- * Graph Parser +parseGraph :: (Monad m) => (String, Int, Int) -> String -> m (EGGraph Value) +parseGraph (file, line, col) src = + case (parse p "" src) of + Left err -> fail $ show err + Right gr -> return gr + where + p = do + pos <- getPosition + setPosition $ + (flip setSourceName) file $ + (flip setSourceLine) line $ + (flip setSourceColumn) col $ + pos + spaces *> lexeme(graphs) + +data Value = Val String | Var String deriving (Typeable, Data, Ord, Eq, Show) + +-- * Parser Combinators +symbol s = lexeme $ string s +lexeme p = p <* spaces +graphs = sepEndBy1 term (symbol ",") +term = try edge <|> EGVertex <$> label +edge = (:=>) <$> (label<* symbol "->") <*> label +label = var <|> (Val <$> deserialize <$> ident) +var = Var <$> (symbol "'" *> ident) +ident = lexeme $ many1 alphaNum + +deserialize :: (Data a, Typeable a, Read a) => String -> a +deserialize = read `extR` (id :: String -> String) + + +-- | Quasi quoter for EGGraph +gr :: QuasiQuoter +gr = QuasiQuoter quoteGraphExp quoteGraphPat + +quoteGraphExp :: String -> ExpQ +quoteGraphExp src = do + loc <- location + let pos=(loc_filename loc, fst $ loc_start loc, snd $ loc_start loc) + gr <- parseGraph pos src + appE (varE 'buildGraph) $ dataToExpQ (const Nothing `extQ` antiStrExp) gr + +antiStrExp :: Value -> Maybe ExpQ +antiStrExp (Var sym) = Just $ varE (mkName sym) +antiStrExp (Val a) = Just $ litE $ stringL a +antiStrExp _ = Nothing + +quoteGraphPat :: String -> PatQ +quoteGraphPat src = do + loc <- location + let pos=(loc_filename loc, fst $ loc_start loc, snd $ loc_start loc) + gr <- parseGraph pos src + dataToPatQ (const Nothing `extQ` antiStrPat) (sort gr) + +antiStrPat :: Value -> Maybe PatQ +antiStrPat (Var sym) = Just $ varP (mkName sym) +antiStrPat (Val a) = Just $ litP $ stringL a +antiStrPat _ = Nothing diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c)2010, Hiromi ISHII +Copyright (c)2010, Hiromi Ishii All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Hiromi ISHII nor the names of other + * Neither the name of Hiromi Ishii nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/graph-utils.cabal b/graph-utils.cabal --- a/graph-utils.cabal +++ b/graph-utils.cabal @@ -1,43 +1,22 @@ Name: graph-utils - -Version: 0.3.5.2 +Version: 0.3.6 --- A short (one-line) description of the package. Synopsis: A simple wrapper & quasi quoter for fgl. - --- A longer description of the package. Description: Simple Wrapper for generating Graph provided by Data.Graph.Inductive. It also contains PageRank calculator. + -- URL for the project homepage or repository. Homepage: http://github.com/konn/graph-utils/ --- The license under which the package is released. License: BSD3 - --- The file containing the license text. License-file: LICENSE - --- The package author(s). -Author: Hiromi ISHII - --- An email address to which users can send suggestions, bug reports, --- and patches. -Maintainer: Hiromi Ishii - --- A copyright notice. -Copyright: (C) 2010 Hiromi Ishii - +Author: Hiromi Ishii +Maintainer: Hiromi Ishii +Copyright: (c) Hiromi Ishii 2010 Category: Data, Graphs, Data Structures - Build-type: Simple - --- Extra files to be distributed with the package, such as examples or --- a README. --- Extra-source-files: - --- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.6 source-repository head @@ -47,18 +26,10 @@ source-repository this type: git location: http://github.com/konn/graph-utils/tree/release - tag: rel-0.3.5.2 + tag: rel-0.3.6 Library - -- Modules exported by the library. - Exposed-modules: Data.Graph.EasyGrapher, Data.Graph.PageRank - - -- Packages needed in order to build this package. - Build-depends: base == 4.*, fgl, mtl, containers, template-haskell, parsec==3.*, syb - - -- Modules not exported by this package. - -- Other-modules: - - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. - -- Build-tools: + Exposed-modules: Data.Graph.EasyGrapher, Data.Graph.PageRank + Build-depends: base == 4.*, fgl, mtl, containers, template-haskell, parsec==3.*, syb + Other-modules: Data.Graph.EasyGrapher.EasyGrapher, Data.Graph.EasyGrapher.Quote