mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +03:00
Upgrade to LTS-5.0, start on using haskell-src-exts to generate drawings from text.
This commit is contained in:
parent
3a34c26cdc
commit
d3b38bb491
10
app/Main.hs
10
app/Main.hs
@ -9,8 +9,10 @@ import Rendering(renderDrawing)
|
||||
import Util(toNames, portToPort, iconToPort, iconToIcon,
|
||||
iconToIconEnds, iconTailToPort)
|
||||
import Types(Icon(..), Drawing(..), EdgeEnd(..))
|
||||
import Translate(translateString)
|
||||
|
||||
-- TODO Now --
|
||||
-- Work on Translate.
|
||||
|
||||
-- TODO Later --
|
||||
-- Add a small black border to lines to help distinguish line crossings.
|
||||
@ -235,5 +237,13 @@ main1 = do
|
||||
|
||||
main2 = mainWith ((apply0NDia 3 # bgFrame 0.1 black) :: Diagram B)
|
||||
|
||||
main3 :: IO ()
|
||||
main3 = do
|
||||
let
|
||||
(drawing, decl) = translateString "y2 = x1"
|
||||
print decl
|
||||
placedNodes <- renderDrawing drawing
|
||||
mainWith ((placedNodes # bgFrame 1 (backgroundC colorScheme)) :: Diagram B)
|
||||
|
||||
main :: IO ()
|
||||
main = main1
|
||||
|
@ -23,6 +23,9 @@ import Data.Typeable(Typeable)
|
||||
import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
|
||||
import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..))
|
||||
|
||||
-- If the inferred types for these functions becomes unweildy,
|
||||
-- try using PartialTypeSignitures.
|
||||
|
||||
-- CONSTANT
|
||||
scaleFactor :: (Fractional a) => a
|
||||
scaleFactor = 0.02
|
||||
|
58
app/Translate.hs
Normal file
58
app/Translate.hs
Normal file
@ -0,0 +1,58 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies #-}
|
||||
module Translate(
|
||||
translateString
|
||||
) where
|
||||
|
||||
import qualified Diagrams.Prelude as DIA
|
||||
|
||||
import Language.Haskell.Exts(Match(..), Decl(..), parseDecl, ParseResult(..),
|
||||
Name(..), Pat(..), Rhs(..), Exp(..), QName(..), fromParseResult) --(parseFile, parse, ParseResult, Module)
|
||||
|
||||
import Types(Icon, Edge, Drawing(..))
|
||||
import Util(toNames, iconToIcon)
|
||||
import Icons(Icon(..))
|
||||
|
||||
nameToString (Ident s) = s
|
||||
nameToString (Symbol s) = s
|
||||
|
||||
evalPattern p = case p of
|
||||
PVar n -> nameToString n
|
||||
-- TODO other cases
|
||||
|
||||
evalMatch (Match _ name patterns _ _ _) = res where
|
||||
patternStrings = map evalPattern patterns
|
||||
matchName = nameToString name
|
||||
res = (matchName, patternStrings)
|
||||
|
||||
evalQName (UnQual n) = nameToString n
|
||||
-- TODO other cases
|
||||
|
||||
evalVar x = case x of
|
||||
Var n -> evalQName n
|
||||
-- TODO other cases
|
||||
|
||||
evalRhs (UnGuardedRhs e) = evalVar e
|
||||
evalRhs (GuardedRhss _) = error "GuardedRhss not implemented"
|
||||
|
||||
evalPatBind :: Decl -> ([(DIA.Name, Icon)], [Edge])
|
||||
evalPatBind (PatBind _ pat rhs binds) = (icons, edges) where
|
||||
patName = evalPattern pat
|
||||
rhsName = evalRhs rhs
|
||||
icons = toNames [
|
||||
(patName, TextBoxIcon patName),
|
||||
(rhsName, TextBoxIcon rhsName)
|
||||
]
|
||||
edges = [
|
||||
iconToIcon patName rhsName
|
||||
]
|
||||
|
||||
evalDecl d = case d of
|
||||
pat@PatBind{} -> evalPatBind pat
|
||||
-- TODO other cases
|
||||
|
||||
translateString :: String -> (Drawing, Decl)
|
||||
translateString s = (drawing, decl) where
|
||||
parseResult = parseDecl s -- :: ParseResult Module
|
||||
decl = fromParseResult parseResult
|
||||
(icons, edges) = evalDecl decl
|
||||
drawing = Drawing icons edges []
|
@ -32,8 +32,9 @@ executable glance-exe
|
||||
, graphviz
|
||||
, containers
|
||||
, fgl
|
||||
, haskell-src-exts
|
||||
default-language: Haskell2010
|
||||
Other-modules: Icons, Rendering, Types, Util
|
||||
Other-modules: Icons, Rendering, Types, Util, Translate
|
||||
|
||||
test-suite glance-test
|
||||
type: exitcode-stdio-1.0
|
||||
|
@ -1,7 +1,7 @@
|
||||
# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
|
||||
|
||||
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
|
||||
resolver: lts-4.0
|
||||
resolver: lts-5.0
|
||||
|
||||
# Local packages, usually specified by relative directory name
|
||||
packages:
|
||||
@ -9,8 +9,7 @@ packages:
|
||||
|
||||
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
|
||||
extra-deps: [
|
||||
"diagrams-graphviz-1.3.0.0",
|
||||
"graphviz-2999.18.0.2"
|
||||
"diagrams-graphviz-1.3.0.0"
|
||||
]
|
||||
|
||||
# Override default flag values for local packages and extra-deps
|
||||
|
Loading…
Reference in New Issue
Block a user