packages feed

hs2dot 0.1.3 → 0.1.4

raw patch · 2 files changed

+354/−2 lines, 2 files

Files

hs2dot.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.1.3+Version:             0.1.4  -- A short (one-line) description of the package. Synopsis:            Generate graphviz-code from Haskell-code.@@ -27,6 +27,8 @@    Changelog:    .    0.1.3: Updated dependencies to be less picky.+   .+   0.1.4: Included Hs2Dot.Internals in sdist  -- URL for the project homepage or repository. Homepage:            http://www.github.com/finnsson/hs2graphviz@@ -67,7 +69,7 @@   build-depends:       base >= 4 && < 5, directory >= 1.0 && < 1.1, split >= 0.1.2, haskell-src-exts >= 1.9 && < 2.0, haskell98, haskell-src >= 1.0 && < 1.1      -- Modules not exported by this package.-  -- Other-modules:       +  Other-modules:       Hs2Dot.Internals      -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.   -- Build-tools:
+ src/Hs2Dot/Internals.hs view
@@ -0,0 +1,350 @@+module Hs2Dot.Internals where++import System.Environment (getArgs)+import System.IO (FilePath)+import Control.Monad (filterM)+import System.Directory (doesFileExist)+import Control.Exception (throw, ErrorCall (..))++import Language.Haskell.Exts (parseFileContentsWithMode)+import Language.Haskell.Exts.Parser+import Language.Haskell.Exts.Pretty (prettyPrint)+import Language.Haskell.Exts.Syntax as E+import Language.Haskell.Syntax+-- import Text.Regex.Posix+import Language.Haskell.Exts.Extension+import Data.List+import Data.Maybe+import Data.List.Split+++files2dot :: [FilePath] -> IO String+files2dot files = do+  files <- mapM readFile files+  let modules = map file2module files+      namesInModules = modules >>= moduleNames -- map moduleNames modules+      names' = map (\n -> FullName (snd n) (getFullNameId n) (fst n) (fst n) False) namesInModules+  -- let code = foldr (++) "" files+  return $ header ++ (modules >>= module2dot names')  ++ "}" -- foldr (++) [] $ map file2dot files+  -- return $ error $ show modules -- +  -- return $ error $ show names'++file2module :: String -> E.Module+file2module file = res+  where+    parsedModule = parseFileContentsWithMode (defaultParseMode { extensions = knownExtensions } ) file -- fileCode+    res =+      case parsedModule of+        (ParseFailed _ msg) -> throw $ ErrorCall msg+        (ParseOk m) -> m+++-- file2dot :: String -> String+-- file2dot file = res+--   where+--     parsedModule = parseFileContents file -- fileCode+--     res =+--       case parsedModule of+--         (ParseFailed _ msg) -> throw $ ErrorCall msg+--         (ParseOk m) -> module2dot m++module2dot :: [FullName] -> E.Module -> String+module2dot names (E.Module srcLoc moduleName opts mwarnings mExps imps decls) = result+  where+    result =+      (subgraphHeader moduleName) +++      (decls >>= (\n -> decl2dot n (getModuleName moduleName) ) allNames) +++      (subgraphFooter)+    +    -- filter away names in modules not imported into this module+    allNames = importedNames ++ (mapMaybe (decl2fullname (getModuleName moduleName)) decls)+    importedNames = catMaybes $ mapCross (transformNameOnImport $ getModuleName moduleName ) imps names +++decl2fullname :: String -> E.Decl -> Maybe FullName+decl2fullname moduleName (E.DataDecl _ _ _ name tyVarBind qualConDecl derivings) =+  Just $ FullName name' (dot2Dash moduleName ++ "_" ++ name') moduleName moduleName False+  where name' = name2string name+decl2fullname moduleName (E.TypeDecl _ name _ _) = name2fullname moduleName name+decl2fullname moduleName (E.ClassDecl _ _ name _ _ _) = name2fullname moduleName name +decl2fullname _ _ = Nothing++name2fullname :: String -> E.Name -> Maybe FullName+name2fullname moduleName name = Just $ FullName name' (dot2Dash moduleName ++ "_" ++ name') moduleName moduleName False+  where name' = name2string name++mapCross :: (a -> b -> c) -> [a] -> [b] -> [c]+mapCross fn xs ys =+  concatMap (\x -> (map (fn x) ys)) xs++--  foldr (++) [] $ map (map fn as) bs++-- | Can remove and transform FullName depending on ImportDecl.+transformNameOnImport :: String -> ImportDecl -> FullName -> Maybe FullName       +transformNameOnImport nameOfThisModule (ImportDecl iLoc (ModuleName iName) iQual _ _ iAlias iSpecs) fullname = result+  where+    result = if fullNameModule fullname == nameOfThisModule+             then Just fullname+             else+               if iName /= fullNameModule fullname+               then Nothing+               else resultOfSpecs+    resultOfSpecs =+      case iSpecs of+        Nothing -> Just $ resultOfQualified+        Just specs -> filterImportedSpecs specs+    filterImportedSpecs :: (Bool, [ImportSpec]) -> Maybe FullName+    filterImportedSpecs (hide, specs) =+      if any (\i -> compare (importSpecName i) (fullNameDecl fullname)) specs  -- include?+      then Just $ resultOfQualified+      else Nothing+      where compare = if hide then (/=) else (==)+    -- filterImportedSpecs False specs = any (\i -> importSpecName i == fullNameDecl fullname) specs   -- filter away if not in list++    resultOfQualified :: FullName+    resultOfQualified =+      case iAlias of      +        Nothing -> fullname+        Just (ModuleName n) -> fullname { fullNamePrefix = n, fullNameQualified = True  }++importSpecName :: ImportSpec -> String+importSpecName (IVar n) = prettyPrint n+importSpecName (IAbs n) = prettyPrint n+importSpecName (IThingAll n) = prettyPrint n+importSpecName (IThingWith n _) = prettyPrint n++++getModuleName :: E.ModuleName -> String+getModuleName (E.ModuleName n) = n++getFullNameId :: (String, String) -> String+getFullNameId (modName, decName) =+  dot2Dash modName ++ "_" ++ decName++data FullName =+  FullName {+    fullNameDecl :: String, -- name used in analyzed module+    fullNameId :: String, -- unique id in dot-file, original-module-name + original decl name+    fullNameModule :: String, -- original name of module+    fullNamePrefix :: String, -- prefix of module in analyzed module+    fullNameQualified :: Bool -- if is qualified import+  }+  deriving (Show, Eq)++subgraphHeader :: ModuleName -> String+subgraphHeader (ModuleName n) = "subgraph cluster_" ++ n' ++ " {\ncolor=lightgrey;\nlabel = \"" ++ n ++ "\";\n"+  where n' = dot2Dash n++dot2Dash :: String -> String+dot2Dash value = map (\v -> if v == '.' then '_' else v) value++escapeName :: String -> String+escapeName value = value >>= (\v -> if v == '>' then ['\\',v] else [v])++subgraphFooter :: String+subgraphFooter = "}\n"++moduleNames :: E.Module -> [(String,String)]+moduleNames (E.Module _ (ModuleName moduleName) _ _ _ _ decls) = zip (repeat moduleName) $ mapMaybe declName decls++declName :: E.Decl -> Maybe String+declName (E.DataDecl _ _ _ name _ _ _ ) = Just $ name2string name+declName (E.TypeDecl _ name _ _ ) = Just $ name2string name+declName (E.ClassDecl _ _ name _ _ _) = Just $ name2string name+declName _ = Nothing++decl2dot :: [FullName] -> String -> E.Decl -> String++decl2dot names moduleName (E.TypeDecl _ name tyVarBind t ) = result+  where+    result = name'+    name' = showTypeDecl (name2string name) moduleName [] [("",t')]  -- []+    t' = escapeName $ prettyPrint t++decl2dot names moduleName (E.ClassDecl _ _ name _ _ _) = name'+  where+    name' = showClassDecl (name2string name) moduleName [] []++decl2dot names moduleName (E.InstDecl _ _ qname types _) = show'+  where+    show' = if 1 == length types && isNameInNames name' names && isNameInNames dataTypeName names+            then showRef'+            else ""+    showRef' = showArrow "odiamond" "datadecl" moduleName  (prettyPrint $ head types)   "datadecl" name' (fullNameModule fullClassName)+    name' = prettyPrint qname -- change this!!!+    dataTypeName = prettyPrint $ head types+    fullClassName = getFullNameForName name' names++decl2dot names moduleName (E.DataDecl _ _ context name tyVarBind qualConDecl derivings) = result+  where+    result = name' ++ qualConDecl' ++ asst' -- showNode name [] [] +    name' = showDataDecl dataTypeRefs (name2string name) moduleName [] []+    asst' = context >>= (asst2dot names (prettyPrint name) moduleName)+    qualConDecl' = qualConDecl >>= (\c -> qualConDecl2dot names c moduleName) +    dataTypeRefs :: [String]+    dataTypeRefs = map getDataTypeRefs qualConDecl+    getDataTypeRefs (E.QualConDecl _ _ _ c) = getConDeclName c+    getConDeclName (E.ConDecl name _) = name2string name+    getConDeclName (E.InfixConDecl _ name _ ) = name2string name+    getConDeclName (E.RecDecl name _ ) = name2string name+-- node for name+-- node per qualConDecl+-- -> (inheritance) per qualConDecl to name+decl2dot _ _  _ = "" ++qualConDecl2dot :: [FullName] -> E.QualConDecl -> String -> String+-- qualConDecl2dot = show --(E.QualConDecl +qualConDecl2dot names (E.QualConDecl _ _ _ c) moduleName = conDecl2dot names c moduleName++conDecl2dot :: [FullName] -> E.ConDecl -> String -> String+conDecl2dot names (E.ConDecl name bangTypes) moduleName =+  showConDecl names (name2string name) moduleName [] $ map (\b -> ("",bangType2String b)) bangTypes+conDecl2dot names (E.InfixConDecl bangTypeL name bangTypeR) moduleName =+  showConDecl names (name2string name) moduleName [] [("",bangType2String bangTypeL),("", bangType2String bangTypeR) ]+conDecl2dot names (E.RecDecl name nameBangTypes) moduleName =+  showConDecl names (name2string name) moduleName [] $ map nameBangType2String nameBangTypes++asst2dot :: [FullName] -> String -> String -> Asst -> String+asst2dot fullnames declname moduleName (ClassA qname types) =+  if isNameInNames classname fullnames+  then varnames >>= (asst2dot' (getFullNameForName classname fullnames))+  else error $classname ++ show ( length fullnames) -- ""+  where+    classname = prettyPrint qname+    varnames = map prettyPrint types+    asst2dot' :: FullName -> String -> String+    asst2dot' fullname varname =+      showArrow "diamond" "datadecl" moduleName declname "datadecl" (classname) (fullNameModule fullname)++-- showArrow :: String -> String -> String -> String -> String -> String -> String -> String+-- showArrow arrowHead fromPrefix fromModuleName fromDataRelation toPrefix toName toModuleName =++asst2dot _ _ _ _ = ""++bangType2String :: E.BangType -> String+bangType2String = prettyPrint+++nameBangType2String :: ([Name],E.BangType) -> (String, String)+nameBangType2String (names,bangType) = (maybe "" prettyPrint $ listToMaybe names, prettyPrint bangType)++name2string :: E.Name -> String+name2string (E.Symbol n) = n+name2string (E.Ident n) = n++arrow2dot :: E.Decl -> String+arrow2dot = error "Not implemented yet."++showConDecl = showNode "record" "condecl" []++showDataDecl refs = showNode "record" "datadecl" refs []+showClassDecl = showNode "record" "datadecl" [] [] +showTypeDecl = showNode "record" "datadecl" [] []++showNode :: String -> String -> [String] -> [FullName] -> String -> String -> [String] -> [(String,String)] -> String+showNode shape prefix refs names name moduleName instances records =+    "\"" ++ prefix ++ "_" ++ (dot2Dash moduleName) ++ "_" ++ name ++ "\" [\n" +++      "label = \"<f0> " ++ name ++ (foldl (++) "" $ map showLabel recs) ++ "\"" ++ "\n" +++      "shape = \"" ++ shape ++ "\"" ++ "\n" +++      "];\n" +++      (recsForLine >>= showRecord') +++      (refs >>= showRef')+    where+      recs = zip [1..] records+      recsForLine = zip [1..] $ filter (isRecordInNames names) records+      showRef' = showRef "condecl" moduleName name+      showRecord' r = showRecord prefix name moduleName (getModuleNameForRecord r names ) r++isRecordInNames :: [FullName] -> (String,String) -> Bool+isRecordInNames names record = result+  where+    result = any (isRecordInName record) names -- (\n -> fullNameDecl n == snd record) names++isNameInNames :: String -> [FullName] -> Bool+isNameInNames name  = any (isNameTheName name)++isNameTheName :: String -> FullName -> Bool+isNameTheName left fullname =+      if fullNameQualified fullname || modulePart /= ""+      then sameName && fullNamePrefix fullname == modulePart+      else sameName+      where+        sameName = fullNameDecl fullname == dataPart+        splitedName = splitOn "." left+        modulePart = if 1 < length splitedName+                     then head $ init splitedName+                     else ""+        dataPart = if 1 < length splitedName+                   then last splitedName+                   else head $ splitedName++isRecordInName record name =+  if fullNameQualified name || modulePart /= ""+  then sameName && fullNamePrefix name == modulePart -- fst record+  else sameName+  where+    sameName = fullNameDecl name == dataPart -- splitedName -- snd record+    splitedName = splitOn "." (snd record)+    modulePart :: String+    modulePart = if 1 < length splitedName+                 then head $ init splitedName+                 else ""+    dataPart :: String+    dataPart = if 1 < length splitedName+               then last splitedName+               else head $ splitedName++getFullNameForName :: String -> [FullName] -> FullName +getFullNameForName name fullnames = fullname+  where+    fullname = fromJust $ find (isNameTheName name) fullnames++getModuleNameForRecord :: (Integer, (String,String)) -> [FullName] -> String+getModuleNameForRecord (i, (key,value)) fullNames = result+  where+    result = fullNameId fullname+    fullname = fromJust $ find (isRecordInName (key,value)) fullNames+    ++showRef :: String -> String -> String -> String -> String+showRef prefix moduleName name dataRelation =+  "\""++ prefix ++"_"  ++ (dot2Dash moduleName) ++ "_" ++ dataRelation ++ "\":f"++ show 0 ++" -> \"datadecl_"++ (dot2Dash moduleName) ++ "_" ++ name  ++"\":f0 ["++ arrowhead ++ "];\n"+  where+    arrowhead = "arrowhead=onormal"+++showArrow :: String -> String -> String -> String -> String -> String -> String -> String+showArrow arrowHead fromPrefix fromModuleName fromDataRelation toPrefix toName toModuleName =+  "\""++ fromPrefix ++"_"  ++ (dot2Dash fromModuleName) ++ "_" ++ fromDataRelation ++ "\":f"++ show 0 ++" -> \""++ toPrefix ++"_"++ (dot2Dash toModuleName) ++ "_" ++ toName  ++"\":f0 ["++ arrowhead ++ "];\n"+  where+    arrowhead = "arrowhead=" ++ arrowHead+++showLabel :: (Integer, (String, String)) -> String+showLabel (i, (key,value)) =+  " | <f" ++ show i ++ "> " ++ key ++ " :: " ++ dataPart+  where+    splitedValue = splitOn "." value+    dataPart :: String+    dataPart = last $ splitedValue+ +showRecord :: String -> String -> String -> String -> (Integer, (String,String)) -> String+showRecord prefix dataRelation moduleName valueModuleName (i, (key, value)) =+  "\""++ prefix ++"_" ++ (dot2Dash moduleName) ++ "_" ++ dataRelation ++ "\":f"++ show i ++" -> \"datadecl_"++ valueModuleName  ++"\":f0 [];\n"++++header =+  "digraph g {\n" +++  "graph [\n" +++  "rankdir = \"LR\"\n" +++  "];\n" +++  "node [\n" +++  "fontsize = \"16\"\n" +++  "shape = \"ellipse\"\n" +++  "];\n" +++  "edge [\n" +++  "];\n"++