mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +03:00
Use customRenderSVG in Main.hs. Change font to monospace. Use optparse-applicative for Main.
This commit is contained in:
parent
69589f7d24
commit
71f6d55df3
11
README.md
11
README.md
@ -9,9 +9,14 @@ First install Graphviz. For instance, in Ubuntu run:
|
||||
Then build and execute glance:
|
||||
```
|
||||
stack build
|
||||
stack exec glance-exe -- -o images/fact.svg -w 500 examples/fact.hs -
|
||||
stack exec glance-exe -- examples/fact.hs images/fact.svg 500
|
||||
```
|
||||
and display the SVG
|
||||
To see the command line options run
|
||||
```
|
||||
stack exec glance-exe -- --help
|
||||
```
|
||||
|
||||
Now display the SVG image
|
||||
```
|
||||
firefox --new-window images/fact.svg
|
||||
```
|
||||
@ -26,7 +31,7 @@ Glance is still in development, so for the time being, layout, routing, and icon
|
||||
## Getting started
|
||||
Below is a getting started guide for Glance rendered by Glance itself ([source here](examples/tutorial.hs)). To generate this image run
|
||||
|
||||
`stack exec glance-exe -- -o examples/tutorial.svg -w 873 examples/tutorial.hs c`
|
||||
`stack exec glance-exe -- examples/tutorial.hs examples/tutorial.svg 873 -c`
|
||||
|
||||
Also, the [Glance wiki](../../wiki) has a brief introduction to the code architecture.
|
||||
|
||||
|
15
app/Icons.hs
15
app/Icons.hs
@ -361,10 +361,15 @@ nestedApplyDia flavor = case flavor of
|
||||
-- Text constants --
|
||||
textBoxFontSize :: (Num a) => a
|
||||
textBoxFontSize = 1
|
||||
|
||||
monoLetterWidthToHeightFraction :: (Fractional a) => a
|
||||
monoLetterWidthToHeightFraction = 0.61
|
||||
|
||||
textBoxHeightFactor :: (Fractional a) => a
|
||||
textBoxHeightFactor = 1.1
|
||||
textBoxHeightFactor = 1.4
|
||||
|
||||
textFont :: String
|
||||
textFont = "monospace"
|
||||
|
||||
-- BEGIN Text helper functions --
|
||||
|
||||
@ -379,15 +384,15 @@ textBoxHeightFactor = 1.1
|
||||
rectForText :: (InSpace V2 n t, TrailLike t) => Int -> t
|
||||
rectForText n = rect rectangleWidth (textBoxFontSize * textBoxHeightFactor)
|
||||
where
|
||||
rectangleWidth = fromIntegral n * textBoxFontSize * monoLetterWidthToHeightFraction
|
||||
+ (textBoxFontSize * 0.2)
|
||||
rectangleWidth = (fromIntegral n * textBoxFontSize * monoLetterWidthToHeightFraction)
|
||||
+ (textBoxFontSize * 0.3)
|
||||
|
||||
-- END Text helper functions
|
||||
|
||||
commentTextArea :: SpecialBackend b n =>
|
||||
Colour Double -> String -> SpecialQDiagram b n
|
||||
commentTextArea textColor t =
|
||||
alignL $ fontSize (local textBoxFontSize) (font "freemono" $ fc textColor $ topLeftText t)
|
||||
alignL $ fontSize (local textBoxFontSize) (font textFont $ fc textColor $ topLeftText t)
|
||||
<> alignTL (lw none $ rectForText (length t))
|
||||
|
||||
multilineComment :: SpecialBackend b n =>
|
||||
@ -403,7 +408,7 @@ coloredTextBox :: SpecialBackend b n =>
|
||||
Colour Double
|
||||
-> AlphaColour Double -> String -> SpecialQDiagram b n
|
||||
coloredTextBox textColor boxColor t =
|
||||
fontSize (local textBoxFontSize) (bold $ font "freemono" $ fc textColor $ text t)
|
||||
fontSize (local textBoxFontSize) (bold $ font textFont $ fc textColor $ text t)
|
||||
<> lwG (0.6 * defaultLineWidth) (lcA boxColor $ fcA (withOpacity (backgroundC colorScheme) 0.5) $ rectForText (length t))
|
||||
|
||||
transformCorrectedTextBox :: SpecialBackend b n =>
|
||||
|
56
app/Main.hs
56
app/Main.hs
@ -4,18 +4,34 @@ import Prelude hiding (return)
|
||||
|
||||
-- Note: (#) and (&) are hidden in all Glance source files, since they would require
|
||||
-- - an special case when translating when Glance is run on its own source code.
|
||||
import Diagrams.Prelude hiding ((#), (&))
|
||||
import Diagrams.Backend.SVG.CmdLine
|
||||
--import Diagrams.Backend.Rasterific.CmdLine
|
||||
import qualified Diagrams.Prelude as Dia hiding ((#), (&))
|
||||
|
||||
import qualified Language.Haskell.Exts as Exts
|
||||
|
||||
-- Options.Applicative does not seem to work qualified
|
||||
import Options.Applicative
|
||||
|
||||
import Icons(ColorStyle(..), colorScheme, multilineComment)
|
||||
import Rendering(renderIngSyntaxGraph)
|
||||
import Translate(translateModuleToCollapsedGraphs)
|
||||
import Util(customRenderSVG)
|
||||
|
||||
data CmdLineOptions = CmdLineOptions {
|
||||
cmdInputFilename :: String,
|
||||
cmdOutputFilename :: String,
|
||||
cmdImageWidth :: Double,
|
||||
cmdIncludeComments :: Bool
|
||||
}
|
||||
|
||||
renderFile :: String -> String -> IO (Diagram B)
|
||||
renderFile inputFilename includeComments = do
|
||||
optionParser :: Parser CmdLineOptions
|
||||
optionParser = CmdLineOptions
|
||||
<$> argument str (metavar "INPUT_FILE" <> help "Input .hs filename")
|
||||
<*> argument str (metavar "OUTPUT_FILE" <> help "Output .svg filename")
|
||||
<*> argument auto (metavar "IMAGE_WIDTH" <> help "Output image width")
|
||||
<*> switch (short 'c' <> help "Include comments between top level declarations.")
|
||||
|
||||
renderFile :: CmdLineOptions -> IO ()
|
||||
renderFile (CmdLineOptions inputFilename outputFilename imageWidth includeComments) = do
|
||||
putStrLn $ "Translating file " ++ inputFilename ++ " into a Glance image."
|
||||
parseResult <- Exts.parseFileWithComments
|
||||
(Exts.defaultParseMode
|
||||
@ -32,16 +48,30 @@ renderFile inputFilename includeComments = do
|
||||
|
||||
diagrams <- traverse renderIngSyntaxGraph drawings
|
||||
let
|
||||
commentsInBoxes = fmap (\(Exts.Comment _ _ c) -> alignL $ multilineComment white (opaque white) c) comments
|
||||
diagramsAndComments = vsep 2 $ zipWith (\x y -> x === strutY 0.4 === y) commentsInBoxes (fmap alignL diagrams)
|
||||
justDiagrams = vsep 1 $ fmap alignL diagrams
|
||||
diagramsAndMaybeComments = if includeComments == "c" then diagramsAndComments else justDiagrams
|
||||
commentsInBoxes = fmap (\(Exts.Comment _ _ c) -> Dia.alignL $ multilineComment Dia.white (Dia.opaque Dia.white) c) comments
|
||||
diagramsAndComments = Dia.vsep 2 $ zipWith (\x y -> x Dia.=== Dia.strutY 0.4 Dia.=== y) commentsInBoxes (fmap Dia.alignL diagrams)
|
||||
justDiagrams = Dia.vsep 1 $ fmap Dia.alignL diagrams
|
||||
diagramsAndMaybeComments = if includeComments then diagramsAndComments else justDiagrams
|
||||
--print comments
|
||||
|
||||
pure (bgFrame 1 (backgroundC colorScheme) diagramsAndMaybeComments :: Diagram B)
|
||||
finalDia = Dia.bgFrame 1 (backgroundC colorScheme) diagramsAndMaybeComments
|
||||
customRenderSVG outputFilename (Dia.mkWidth imageWidth) finalDia
|
||||
putStrLn $ "Successfully wrote " ++ outputFilename
|
||||
|
||||
translateFileMain :: IO ()
|
||||
translateFileMain = customExecParser parserPrefs opts >>= renderFile where
|
||||
|
||||
parserPrefs = defaultPrefs{
|
||||
prefShowHelpOnError = True
|
||||
|
||||
-- TODO enable this option when optparse-applicative has been upgraded
|
||||
--prefShowHelpOnEmpty = True
|
||||
}
|
||||
|
||||
opts = info (helper <*> optionParser)
|
||||
(fullDesc
|
||||
<> progDesc "Translate a Haskell source file (.hs) into an SVG image."
|
||||
<> header "Glance - a visual representation of Haskell")
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
mainWith renderFile
|
||||
putStrLn "Successfully translated file."
|
||||
main = translateFileMain
|
||||
|
@ -769,9 +769,13 @@ evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do
|
||||
-- TODO May want to trim whitespace from (prettyPrint typeForNames)
|
||||
evalTypeSig :: Decl -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalTypeSig (TypeSig _ names typeForNames) = makeBox
|
||||
(intercalate "," (fmap prettyPrint names)
|
||||
(intercalate "," (fmap prettyPrintWithoutNewlines names)
|
||||
++ " :: "
|
||||
++ prettyPrint typeForNames)
|
||||
++ prettyPrintWithoutNewlines typeForNames)
|
||||
where
|
||||
-- TODO Make custom version of prettyPrint for type signitures.
|
||||
-- Use (unwords . words) to convert consecutive whitspace characters to one space
|
||||
prettyPrintWithoutNewlines = unwords . words . prettyPrint
|
||||
|
||||
evalDecl :: EvalContext -> Decl -> State IDState SyntaxGraph
|
||||
evalDecl c d = case d of
|
||||
|
10
app/Util.hs
10
app/Util.hs
@ -22,14 +22,16 @@ module Util (
|
||||
customRenderSVG
|
||||
)where
|
||||
|
||||
import Diagrams.Backend.SVG(renderSVG', Options(..))
|
||||
import Diagrams.Backend.SVG(renderSVG', Options(..), SVG)
|
||||
import Graphics.Svg.Attributes(bindAttr, AttrTag(..))
|
||||
import qualified Diagrams.Prelude as Dia
|
||||
|
||||
import Control.Arrow(first)
|
||||
-- import Diagrams.Prelude(IsName, toName, Name)
|
||||
import Data.Maybe(fromMaybe)
|
||||
import qualified Debug.Trace
|
||||
import Data.Text(pack)
|
||||
import Data.Typeable(Typeable)
|
||||
|
||||
import Types(EdgeEnd(..), Edge(..), NameAndPort(..), Connection, NodeName(..), Port,
|
||||
SyntaxNode, SgNamedNode(..))
|
||||
@ -96,6 +98,12 @@ sgNamedNodeToSyntaxNode (SgNamedNode _ n) = n
|
||||
nodeNameToInt :: NodeName -> Int
|
||||
nodeNameToInt (NodeName x) = x
|
||||
|
||||
|
||||
customRenderSVG :: (Typeable n, Show n, RealFloat n) =>
|
||||
FilePath
|
||||
-> Dia.SizeSpec Dia.V2 n
|
||||
-> Dia.QDiagram SVG Dia.V2 n Dia.Any
|
||||
-> IO ()
|
||||
customRenderSVG outputFilename size = renderSVG' outputFilename svgOptions where
|
||||
-- This xml:space attribute preserves the whitespace in the svg text.
|
||||
attributes = [bindAttr XmlSpace_ (pack "preserve")]
|
||||
|
@ -39,6 +39,7 @@ executable glance-exe
|
||||
, diagrams-rasterific
|
||||
, text
|
||||
, svg-builder
|
||||
, optparse-applicative
|
||||
default-language: Haskell2010
|
||||
Other-modules: Icons, Rendering, Types, Util, Translate, TranslateCore, DrawingColors, GraphAlgorithms
|
||||
|
||||
|
@ -1,6 +1,5 @@
|
||||
import Prelude hiding (return)
|
||||
|
||||
import Diagrams.Backend.SVG (renderSVG)
|
||||
import Diagrams.Backend.SVG.CmdLine(B)
|
||||
import Diagrams.Prelude hiding ((#), (&))
|
||||
|
||||
|
7
todo.md
7
todo.md
@ -1,7 +1,9 @@
|
||||
# Todo
|
||||
|
||||
## Todo Now
|
||||
* Use customRenderSVG in app/Main.hs.
|
||||
* Update tutorial code formatting.
|
||||
|
||||
* Update Stackage lts (see todo in Main.hs)
|
||||
|
||||
* Add wiki pages discussing: Why a visual language?, Glance design goals, History of Glance, FAQ's, How to contribute, Code guide [code style, ...], Related projects, examples demonstrating the utility of Glance etc..
|
||||
|
||||
@ -31,3 +33,6 @@
|
||||
* Add proper RecConstr, and RecUpdate support.
|
||||
|
||||
* Special case for otherwise.
|
||||
|
||||
### Command line todos
|
||||
* Tab completion
|
||||
|
Loading…
Reference in New Issue
Block a user