diff --git a/app/Main.hs b/app/Main.hs index 38ed88c..416fbba 100644 --- a/app/Main.hs +++ b/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 diff --git a/app/Rendering.hs b/app/Rendering.hs index 1b8313b..ca3d256 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -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 diff --git a/app/Translate.hs b/app/Translate.hs new file mode 100644 index 0000000..dd2ff2a --- /dev/null +++ b/app/Translate.hs @@ -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 [] diff --git a/glance.cabal b/glance.cabal index 733737f..5ad81e4 100644 --- a/glance.cabal +++ b/glance.cabal @@ -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 diff --git a/stack.yaml b/stack.yaml index 3914a70..387c6f9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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