summaryrefslogtreecommitdiff
path: root/src/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF')
-rw-r--r--src/GF/Shell.hs3
-rw-r--r--src/GF/Shell/PShell.hs1
-rw-r--r--src/GF/Shell/ShellCommands.hs2
-rw-r--r--src/GF/UseGrammar/Custom.hs4
-rw-r--r--src/GF/Visualization/VisualizeGrammar.hs69
5 files changed, 53 insertions, 26 deletions
diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index 2b7a66701..4d0d9b879 100644
--- a/src/GF/Shell.hs
+++ b/src/GF/Shell.hs
@@ -41,6 +41,7 @@ import Operations
import UseIO
import UTF8 (encodeUTF8)
+import VisualizeGrammar (visualizeSourceGrammar)
---- import qualified GrammarToGramlet as Gr
---- import qualified GrammarToCanonXML2 as Canon
@@ -228,6 +229,8 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = checkOptions st co >> case comm of
CPrintMultiGrammar -> do
sa' <- changeState purgeShellState sa
returnArg (AString (optPrintMultiGrammar opts cgr)) sa'
+ CPrintSourceGrammar ->
+ returnArg (AString (visualizeSourceGrammar src)) sa
---- CPrintGramlet -> returnArg (AString (Gr.prGramlet st)) sa
---- CPrintCanonXML -> returnArg (AString (Canon.prCanonXML st False)) sa
diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs
index 230a6e62a..ff447fc6d 100644
--- a/src/GF/Shell/PShell.hs
+++ b/src/GF/Shell/PShell.hs
@@ -113,6 +113,7 @@ pCommand ws = case ws of
"pxs" : [] -> aUnit CPrintCanonXMLStruct
"px" : [] -> aUnit CPrintCanonXML
"pm" : [] -> aUnit CPrintMultiGrammar
+ "sg" : [] -> aUnit CPrintSourceGrammar
"po" : [] -> aUnit CPrintGlobalOptions
"pl" : [] -> aUnit CPrintLanguages
"h" : c : [] -> aUnit $ CHelp (Just (abbrevCommand c))
diff --git a/src/GF/Shell/ShellCommands.hs b/src/GF/Shell/ShellCommands.hs
index 846c753bc..e30b8010b 100644
--- a/src/GF/Shell/ShellCommands.hs
+++ b/src/GF/Shell/ShellCommands.hs
@@ -57,6 +57,7 @@ data Command =
| CPrintLanguages
| CPrintInformation I.Ident
| CPrintMultiGrammar
+ | CPrintSourceGrammar
| CPrintGramlet
| CPrintCanonXML
| CPrintCanonXMLStruct
@@ -166,6 +167,7 @@ optionsOfCommand co = case co of
CPrintGrammar -> both "utf8" "printer lang"
CPrintMultiGrammar -> both "utf8" "printer"
+ CPrintSourceGrammar -> both "utf8" "printer"
CHelp _ -> opts "all filter length lexer unlexer printer transform depth number"
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index a2180491a..2cf9fdc67 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -52,7 +52,7 @@ import qualified PrintParser as Prt
import GFC
import qualified MkGFC as MC
import PrintCFGrammar (prCanonAsCFGM)
-import VisualizeGrammar (visualizeGrammar)
+import VisualizeGrammar (visualizeCanonGrammar, visualizeSourceGrammar)
import MyParser
@@ -230,7 +230,7 @@ customMultiGrammarPrinter =
(strCI "gfcm", MC.prCanon)
,(strCI "header", MC.prCanonMGr)
,(strCI "cfgm", prCanonAsCFGM)
- ,(strCI "graph", visualizeGrammar)
+ ,(strCI "graph", visualizeCanonGrammar)
]
++ moreCustomMultiGrammarPrinter
diff --git a/src/GF/Visualization/VisualizeGrammar.hs b/src/GF/Visualization/VisualizeGrammar.hs
index 5a2939098..f8ca567b6 100644
--- a/src/GF/Visualization/VisualizeGrammar.hs
+++ b/src/GF/Visualization/VisualizeGrammar.hs
@@ -4,15 +4,21 @@ module VisualizeGrammar where
import qualified Modules as M
import GFC
import Ident
+import Grammar (SourceGrammar)
-import Data.List (intersperse)
+import Data.List (intersperse, nub)
import Data.Maybe (maybeToList)
-data GrType = GrAbstract | GrConcrete | GrResource
+data GrType = GrAbstract
+ | GrConcrete
+ | GrResource
+ | GrInterface
+ | GrInstance
deriving Show
data Node = Node {
label :: String,
+ url :: String,
grtype :: GrType,
extends :: [String],
opens :: [String],
@@ -21,28 +27,40 @@ data Node = Node {
deriving Show
-visualizeGrammar :: CanonGrammar -> String
-visualizeGrammar gr = prGraph ns
- where
- ns = [ toNode i m | (i,M.ModMod m) <- M.modules gr ]
+visualizeCanonGrammar :: CanonGrammar -> String
+visualizeCanonGrammar = prGraph . canon2graph
-toNode :: Ident -> M.Module Ident f Info -> Node
+visualizeSourceGrammar :: SourceGrammar -> String
+visualizeSourceGrammar = prGraph . source2graph
+
+canon2graph :: CanonGrammar -> [Node]
+canon2graph gr = [ toNode i m | (i,M.ModMod m) <- M.modules gr ]
+
+source2graph :: SourceGrammar -> [Node]
+source2graph gr = [ toNode i m | (i,M.ModMod m) <- M.modules gr ] -- FIXME: handle ModWith
+
+toNode :: Ident -> M.Module Ident f i -> Node
toNode i m = Node {
- label = prIdent i,
+ label = l,
+ url = l ++ ".gf", -- FIXME: might be in a different directory
grtype = t,
extends = map prIdent (M.extends m),
- opens = map openName (M.opens m),
+ opens = nub $ map openName (M.opens m), -- FIXME: nub is needed because of triple open with
+ -- instance modules
implements = is
}
where
+ l = prIdent i
(t,is) = case M.mtype m of
M.MTAbstract -> (GrAbstract, Nothing)
+ M.MTTransfer _ _ -> error "Can't visualize transfer modules yet" -- FIXME
M.MTConcrete i -> (GrConcrete, Just (prIdent i))
M.MTResource -> (GrResource, Nothing)
- M.MTTransfer _ _ ->
- -- FIXME
- error "Can't visualize transfer modules yet"
-
+ M.MTInterface -> (GrInterface, Nothing)
+ M.MTInstance i -> (GrInstance, Just (prIdent i))
+ M.MTReuse rt -> error "Can't visualize reuse modules yet" -- FIXME
+ M.MTUnion _ _ -> error "Can't visualize union modules yet" -- FIXME
+
openName :: M.OpenSpec Ident -> String
openName (M.OSimple q i) = prIdent i
openName (M.OQualif q i _) = prIdent i
@@ -54,25 +72,28 @@ prNode :: Node -> String
prNode n = concat (map (++";\n") stmts)
where
l = label n
+ t = grtype n
stmts = [l ++ " [" ++ prAttributes attrs ++ "]"]
- ++ map (prExtend l) (extends n)
+ ++ map (prExtend t l) (extends n)
++ map (prOpen l) (opens n)
- ++ map (prImplement l) (maybeToList (implements n))
- style = case grtype n of
- GrAbstract -> "solid"
- GrConcrete -> "dashed"
- GrResource -> "dotted"
- attrs = [("style",style),("URL", l++".gf")] -- FIXME: might be in a different directory
+ ++ map (prImplement t l) (maybeToList (implements n))
+ (shape,style) = case t of
+ GrAbstract -> ("ellipse","solid")
+ GrConcrete -> ("box","dashed")
+ GrResource -> ("ellipse","dashed")
+ GrInterface -> ("ellipse","dotted")
+ GrInstance -> ("diamond","dotted")
+ attrs = [("style", style),("shape", shape),("URL", url n)]
-prExtend :: String -> String -> String
-prExtend f t = prEdge f t []
+prExtend :: GrType -> String -> String -> String
+prExtend g f t = prEdge f t [("style","solid")]
prOpen :: String -> String -> String
prOpen f t = prEdge f t [("style","dotted")]
-prImplement :: String -> String -> String
-prImplement f t = prEdge f t [("arrowhead","empty"),("style","dashed")]
+prImplement :: GrType -> String -> String -> String
+prImplement g f t = prEdge f t [("arrowhead","empty"),("style","dashed")]
prEdge :: String -> String -> [(String,String)] -> String
prEdge f t as = f ++ " -> " ++ t ++ " [" ++ prAttributes as ++ "]"
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 07:29:18 +0000