Move helper functions from Translate to SimplifySyntax.

app/SimplifySyntax.hs

@@ -1,10 +1,14 @@
 module SimplifySyntax (
   stringToSimpDecl
+  , qOpToExp
+  , qNameToString
+  , nameToString
+  , customParseDecl
   ) where
 
 import qualified Language.Haskell.Exts as Exts
 
-import Translate(qOpToExp, qNameToString, matchesToCase, customParseDecl)
+import TranslateCore(nTupleString)
 -- A simplified Haskell syntax tree
 
 -- rhs is now SimpExp
@@ -47,6 +51,35 @@ data SimpPat l =
   | SpAsPat l (Exts.Name l) (SimpPat l)
   deriving (Show, Eq)
 
+-- Helper functions
+
+makeVarExp :: l -> String -> Exts.Exp l
+makeVarExp l  = Exts.Var l . Exts.UnQual l . Exts.Ident l
+
+qOpToExp :: Exts.QOp l -> Exts.Exp l
+qOpToExp (Exts.QVarOp l n) = Exts.Var l n
+qOpToExp (Exts.QConOp l n) = Exts.Con l n
+
+nameToString :: Exts.Name l -> String
+nameToString (Exts.Ident _ s) = s
+nameToString (Exts.Symbol _ s) = s
+
+-- TODO refactor qNameToString
+qNameToString :: Show l => Exts.QName l -> String
+qNameToString (Exts.Qual _ (Exts.ModuleName _ modName) name)
+  = modName ++ "." ++ nameToString name
+qNameToString (Exts.UnQual _ name) = nameToString name
+qNameToString (Exts.Special _ (Exts.UnitCon _)) = "()"
+qNameToString (Exts.Special _ (Exts.ListCon _)) = "[]"
+qNameToString (Exts.Special _ (Exts.FunCon _)) = "(->)"
+qNameToString (Exts.Special _ (Exts.TupleCon _ _ n)) = nTupleString n
+qNameToString (Exts.Special _ (Exts.Cons _)) = "(:)"
+-- unboxed singleton tuple constructor
+qNameToString (Exts.Special _ (Exts.UnboxedSingleCon _)) = "(# #)"
+qNameToString q = error $ "Unsupported syntax in qNameToSrting: " <> show q
+
+--
+
 infixAppToSeApp :: Show a =>
   a -> Exts.Exp a -> Exts.QOp a -> Exts.Exp a -> SimpExp a
 infixAppToSeApp l e1 op e2 = case op of
@@ -88,6 +121,36 @@ matchToFunBind (Exts.Match l name patterns rhs maybeWhereBinds)
     (whereToLet l rhs maybeWhereBinds)
 matchToFunBind m = error $ "Unsupported syntax in matchToFunBind: " <> show m
 
+-- Only used by matchesToCase
+matchToAlt :: Show l => Exts.Match l -> Exts.Alt l
+matchToAlt (Exts.Match l _ mtaPats rhs binds) = Exts.Alt l altPattern rhs binds where
+  altPattern = case mtaPats of
+    [onePat] -> onePat
+    _ -> Exts.PTuple l Exts.Boxed mtaPats
+matchToAlt match = error $ "Unsupported syntax in matchToAlt: " <> show match
+
+-- TODO Refactor matchesToCase
+matchesToCase :: Show l => Exts.Match l -> [Exts.Match l] -> Exts.Match l
+matchesToCase match [] = match
+matchesToCase firstMatch@(Exts.Match srcLoc funName pats _ _) restOfMatches = match
+  where
+    -- There is a special case in Icons.hs/makeLabelledPort to exclude " tempvar"
+    -- TODO use a data constructor for the special case instead of using string
+    -- matching for tempvars.
+    tempStrings = fmap (\x -> " tempvar" ++ show x) [0..(length pats - 1)]
+    tempPats = fmap (Exts.PVar srcLoc . Exts.Ident srcLoc) tempStrings
+    tempVars = fmap (makeVarExp srcLoc) tempStrings
+    tuple = Exts.Tuple srcLoc Exts.Boxed tempVars
+    caseExp = case tempVars of
+      [oneTempVar] -> Exts.Case srcLoc oneTempVar alts
+      _ -> Exts.Case srcLoc tuple alts
+    rhs = Exts.UnGuardedRhs srcLoc caseExp
+    match = Exts.Match srcLoc funName tempPats rhs Nothing
+    allMatches = firstMatch:restOfMatches
+    alts = fmap matchToAlt allMatches
+matchesToCase firstMatch _
+  = error $ "Unsupported syntax in matchesToCase: " <> show firstMatch
+
 matchesToFunBind :: Show a => a -> [Exts.Match a] -> SimpDecl a
 matchesToFunBind l matches = case matches of
   [] -> error $ "Empty matches in matchesToFunBind. Label is :" <> show l
@@ -153,5 +216,17 @@ hsExpToSimpExp x = case x of
 
 -- Parsing
 
+customParseMode :: Exts.ParseMode
+customParseMode = Exts.defaultParseMode
+  {Exts.extensions =
+   [Exts.EnableExtension Exts.MultiParamTypeClasses,
+    Exts.EnableExtension Exts.FlexibleContexts,
+    Exts.EnableExtension Exts.TupleSections
+   ]
+  }
+
+customParseDecl :: String -> Exts.Decl Exts.SrcSpanInfo
+customParseDecl = Exts.fromParseResult . Exts.parseDeclWithMode customParseMode
+
 stringToSimpDecl :: String -> SimpDecl Exts.SrcSpanInfo
 stringToSimpDecl = hsDeclToSimpDecl . customParseDecl

app/Translate.hs

@@ -21,11 +21,14 @@ import Data.Maybe(catMaybes, isJust, fromMaybe)
 import qualified Language.Haskell.Exts as Exts
 
 import Language.Haskell.Exts(
-  Decl(..), parseDeclWithMode, Name(..), Pat(..), Rhs(..),
-  Exp(..), QName(..), fromParseResult, Match(..), QOp(..), GuardedRhs(..),
-  Stmt(..), Binds(..), Alt(..), Module(..), SpecialCon(..), prettyPrint)
+  Decl(..), Name(..), Pat(..), Rhs(..),
+  Exp(..), QName(..), Match(..), QOp(..), GuardedRhs(..),
+  Stmt(..), Binds(..), Alt(..), Module(..), prettyPrint)
 
 import GraphAlgorithms(collapseNodes)
+import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
+             casePatternPorts)
+import SimplifySyntax(qOpToExp, qNameToString, nameToString, customParseDecl)
 import TranslateCore(
   Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..), SgSink(..),
   syntaxGraphFromNodes, syntaxGraphFromNodesEdges, getUniqueName,
@@ -39,8 +42,6 @@ import Types(Labeled(..), NameAndPort(..), IDState,
   Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..),
   LikeApplyFlavor(..))
 import Util(makeSimpleEdge, nameAndPort, justName)
-import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
-             casePatternPorts)
 
 {-# ANN module "HLint: ignore Use record patterns" #-}
 
@@ -57,10 +58,6 @@ makeVarExp l  = Var l . UnQual l . Ident l
 makeQVarOp :: l -> String -> QOp l
 makeQVarOp l = QVarOp l . UnQual l . Ident l
 
-qOpToExp :: QOp l -> Exp l
-qOpToExp (QVarOp l n) = Var l n
-qOpToExp (QConOp l n) = Con l n
-
 -- | Make a syntax graph that has the bindings for a list of "as pattern" (@)
 -- names.
 makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph
@@ -97,27 +94,6 @@ patternName (GraphAndRef _ ref, mStr) = fromMaybe
 
 -- END Helper Functions --
 
--- BEGIN Names helper functions --
-
-nameToString :: Exts.Name l -> String
-nameToString (Ident _ s) = s
-nameToString (Symbol _ s) = s
-
-qNameToString :: Show l => QName l -> String
-qNameToString (Qual _ (Exts.ModuleName _ modName) name)
-  = modName ++ "." ++ nameToString name
-qNameToString (UnQual _ name) = nameToString name
-qNameToString (Special _ (UnitCon _)) = "()"
-qNameToString (Special _ (ListCon _)) = "[]"
-qNameToString (Special _ (FunCon _)) = "(->)"
-qNameToString (Special _ (TupleCon _ _ n)) = nTupleString n
-qNameToString (Special _ (Cons _)) = "(:)"
--- unboxed singleton tuple constructor
-qNameToString (Special _ (UnboxedSingleCon _)) = "(# #)"
-qNameToString q = error $ "Unsupported syntax in qNameToSrting: " <> show q
-
--- END Names helper functions
-
 -- BEGIN evalLit
 
 -- This is in Translate and not Translate core since currently it is only used
@@ -952,18 +928,6 @@ translateDeclToSyntaxGraph d = graph where
   evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds
   graph = evalState evaluatedDecl initialIdState
 
-customParseMode :: Exts.ParseMode
-customParseMode = Exts.defaultParseMode
-  {Exts.extensions =
-   [Exts.EnableExtension Exts.MultiParamTypeClasses,
-    Exts.EnableExtension Exts.FlexibleContexts,
-    Exts.EnableExtension Exts.TupleSections
-   ]
-  }
-
-customParseDecl :: String -> Decl Exts.SrcSpanInfo
-customParseDecl = fromParseResult . parseDeclWithMode customParseMode
-
 -- | Convert a single function declaration into a SyntaxGraph
 translateStringToSyntaxGraph :: String -> SyntaxGraph
 translateStringToSyntaxGraph = translateDeclToSyntaxGraph . customParseDecl

glance.cabal

@@ -46,7 +46,15 @@ executable glance-exe
                      , svg-builder
                      , optparse-applicative
   default-language:    Haskell2010
-  Other-modules: Icons, Rendering, Types, Util, Translate, TranslateCore, DrawingColors, GraphAlgorithms
+  Other-modules: Icons
+               , Rendering
+               , Types
+               , Util
+               , Translate
+               , TranslateCore
+               , DrawingColors
+               , GraphAlgorithms
+               , SimplifySyntax
 
 test-suite glance-test
   type:                exitcode-stdio-1.0
@@ -87,6 +95,7 @@ test-suite glance-test
                , TranslateCore
                , DrawingColors
                , GraphAlgorithms
+               , SimplifySyntax
 
 
 source-repository head