From ea99c9bfe42583faaadb9612752618e234434801 Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Fri, 26 Feb 2016 22:58:49 -0800 Subject: [PATCH] Extract types and functions that do not use Language.Haskell.Exts into TranslateCore. --- app/Icons.hs | 6 +- app/Main.hs | 7 +- app/Translate.hs | 236 +++++++++++-------------------------------- app/TranslateCore.hs | 157 ++++++++++++++++++++++++++++ app/Types.hs | 2 +- app/Util.hs | 7 +- glance.cabal | 3 +- 7 files changed, 233 insertions(+), 185 deletions(-) create mode 100644 app/TranslateCore.hs diff --git a/app/Icons.hs b/app/Icons.hs index c2fe82a..bc46a1c 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -290,7 +290,7 @@ guardLBracket x = ell # alignT # alignL <> makePort x generalGuardIcon :: (RealFloat n, Typeable n, Renderable (Path V2 n) b) => Colour Double -> (Int -> QDiagram b V2 n Any) -> QDiagram b V2 n Any -> Int -> QDiagram b V2 n Any -generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ (alignT $ bottomDia <> makePort 1) <> alignB (bigVerticalLine <> guardDia <> makePort 0) +generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomDia <> makePort 1) <> alignB (bigVerticalLine <> guardDia <> makePort 0) where --guardTriangles = vsep 0.4 (take n (map guardTriangle [0,1..])) trianglesWithPorts = map guardTriangle [2,4..] @@ -317,13 +317,13 @@ guardIcon = generalGuardIcon lineCol guardLBracket mempty caseResult :: (RealFloat n, Typeable n, Renderable (Path V2 n) b) => QDiagram b V2 n Any -caseResult = (circle (circleRadius * 0.7) # fc caseCColor # lc caseCColor # lw none) where +caseResult = circle (circleRadius * 0.7) # fc caseCColor # lc caseCColor # lw none where caseCColor = caseRhsC colorScheme caseC :: (RealFloat n, Typeable n, Renderable (Path V2 n) b) => Int -> QDiagram b V2 n Any -caseC n = caseResult <> makePort n where +caseC n = caseResult <> makePort n -- | The ports of the case icon are as follows: diff --git a/app/Main.hs b/app/Main.hs index 8b8182f..89b2548 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,19 +10,22 @@ import Rendering(renderDrawing) import Util(toNames, portToPort, iconToPort, iconToIcon, iconToIconEnds, iconTailToPort) import Types(Icon(..), Drawing(..), EdgeEnd(..)) -import Translate(translateString, drawingFromDecl, drawingsFromModule) +import Translate(translateString, drawingsFromModule) -- TODO Now -- - -- Refactor Translate +-- Add documentation. +-- Update readme. -- Test reference lookup in case rhs. -- Have the file be a command line argument to main. -- In evalPatBind, give the edge from the rhs to the pattern a special arrowhead. -- TODO Later -- +-- Add function name and type to LambdaIcons. -- Let each bool, value pair in Guard icon be flipped to reduce line crossings. Do the same for case. -- Add text field to Apply. Also redraw text and icon when it is rotated so that the characters stay oriented. +-- Eliminate BranchIcon in Alts. -- Eliminate BranchIcon for the identity funciton "y x = x" -- otherwise Guard special case -- Let lines connect to ports in multiple locations (eg. argument for Apply0Dia) diff --git a/app/Translate.hs b/app/Translate.hs index c1b1bd3..8021dd4 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -13,54 +13,31 @@ import Language.Haskell.Exts(Decl(..), parseDecl, Name(..), Pat(..), Rhs(..), Stmt(..), Binds(..), Alt(..), Module(..)) import qualified Language.Haskell.Exts as Exts import Control.Monad.State(State, evalState) -import Debug.Trace -import Data.Either(partitionEithers, rights) +import Data.Either(partitionEithers) import Data.List(unzip4, partition) import Control.Monad(replicateM) -import Types(Icon, Edge(..), EdgeOption(..), Drawing(..), NameAndPort(..), IDState, - initialIdState, getId) -import Util(toNames, makeSimpleEdge, noEnds, nameAndPort, justName, mapFst) +import Types(Drawing(..), NameAndPort(..), IDState, + initialIdState) +import Util(toNames, makeSimpleEdge, nameAndPort, justName, mapFst) import Icons(Icon(..)) +import TranslateCore(Reference, IconGraph(..), EvalContext, GraphAndRef, + iconGraphFromIcons, iconGraphFromIconsEdges, getUniqueName, combineExpressions, + edgesForRefPortList, iconGraphToDrawing, qualifyNameAndPort, makeApplyGraph, + namesInPattern, lookupReference, deleteBindings, makeEdges, makeEdgesCore, + coerceExpressionResult, makeBox) -type Reference = Either String NameAndPort --- | An IconGraph is a normal Drawing (Icons, Edges, and sub Drawings) with two additional fields: --- unconected sink ports (varible usage), and unconnected source ports (varible definition). -data IconGraph = IconGraph { - igIcons :: [(DIA.Name, Icon)], - igEdges :: [Edge], - igSubDrawings :: [(DIA.Name, Drawing)], - igSinks :: [(String, NameAndPort)], - igBindings :: [(String, Reference)]} - deriving (Show) - -type EvalContext = [String] -type GraphAndRef = (IconGraph, Reference) -type Sink = (String, NameAndPort) - -instance DIA.Semigroup IconGraph where - (IconGraph icons1 edges1 subDrawings1 sinks1 sources1) <> (IconGraph icons2 edges2 subDrawings2 sinks2 sources2) = - IconGraph (icons1 <> icons2) (edges1 <> edges2) (subDrawings1 <> subDrawings2) (sinks1 <> sinks2) (sources1 <> sources2) - -instance Monoid IconGraph where - mempty = IconGraph mempty mempty mempty mempty mempty - mappend = (<>) - -iconGraphFromIcons :: [(DIA.Name, Icon)] -> IconGraph -iconGraphFromIcons icons = IconGraph icons mempty mempty mempty mempty - -iconGraphFromIconsEdges :: [(DIA.Name, Icon)] -> [Edge] -> IconGraph -iconGraphFromIconsEdges icons edges = IconGraph icons edges mempty mempty mempty - -getUniqueName :: String -> State IDState String -getUniqueName base = fmap ((base ++). show) getId +-- OVERVIEW -- +-- The core functions and data types used in this module are in TranslateCore. +-- The TranslateCore also contains most/all of the translation functions that +-- do not use Language.Haskell.Exts. nameToString :: Language.Haskell.Exts.Name -> String nameToString (Ident s) = s nameToString (Symbol s) = s qNameToString :: QName -> String -qNameToString (Qual mn name) = nameToString name +qNameToString (Qual (Exts.ModuleName modName) name) = modName ++ "." ++ nameToString name qNameToString (UnQual name) = nameToString name evalPApp :: QName -> [Pat] -> State IDState (IconGraph, NameAndPort) @@ -86,7 +63,7 @@ evalPattern p = case p of PLit s l -> fmap Right <$> evalPLit s l PApp name patterns -> fmap Right <$> evalPApp name patterns -- TODO special tuple handling. - PTuple box patterns -> fmap Right <$> evalPApp (Exts.UnQual $ Ident "(,)") patterns + PTuple _ patterns -> fmap Right <$> evalPApp (Exts.UnQual $ Ident "(,)") patterns PParen pat -> evalPattern pat PWildCard -> fmap Right <$> makeBox "_" @@ -106,34 +83,6 @@ evalQOp :: QOp -> EvalContext -> State IDState (IconGraph, Reference) evalQOp (QVarOp n) = evalQName n evalQOp (QConOp n) = evalQName n --- TODO: Refactor with combineExpressions -edgesForRefPortList :: Bool -> [(Reference, NameAndPort)] -> IconGraph -edgesForRefPortList inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs where - edgeOptions = [EdgeInPattern | inPattern] - mkGraph (ref, port) = case ref of - Left str -> if inPattern - then IconGraph mempty mempty mempty mempty [(str, Right port)] - else IconGraph mempty mempty mempty [(str, port)] mempty - Right resultPort -> IconGraph mempty [Edge edgeOptions noEnds (resultPort, port)] mempty mempty mempty - -combineExpressions :: Bool -> [(GraphAndRef, NameAndPort)] -> IconGraph -combineExpressions inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs where - edgeOptions = [EdgeInPattern | inPattern] - mkGraph ((graph, ref), port) = graph <> case ref of - Left str -> if inPattern - then IconGraph mempty mempty mempty mempty [(str, Right port)] - else IconGraph mempty mempty mempty [(str, port)] mempty - Right resultPort -> IconGraph mempty [Edge edgeOptions noEnds (resultPort, port)] mempty mempty mempty - -makeApplyGraph :: Bool -> DIA.Name -> (IconGraph, Reference) -> [(IconGraph, Reference)] -> Int -> (IconGraph, NameAndPort) -makeApplyGraph inPattern applyIconName funVal argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1) - where - argumentPorts = map (nameAndPort applyIconName) [2,3..] - functionPort = nameAndPort applyIconName 0 - combinedGraph = combineExpressions inPattern $ zip (funVal:argVals) (functionPort:argumentPorts) - icons = [(applyIconName, Apply0NIcon numArgs)] - newGraph = iconGraphFromIcons icons - evalApp :: (Exp, [Exp]) -> EvalContext -> State IDState (IconGraph, NameAndPort) evalApp (funExp, argExps) c = do funVal <- evalExp c funExp @@ -193,12 +142,7 @@ evalGuardedRhss c rhss = do newGraph = iconGraphFromIcons icons <> combindedGraph pure (newGraph, NameAndPort guardName (Just 1)) -makeBox :: String -> State IDState (IconGraph, NameAndPort) -makeBox str = do - name <- DIA.toName <$> getUniqueName str - let graph = iconGraphFromIcons [(DIA.toName name, TextBoxIcon str)] - pure (graph, justName name) - +-- This is in Translate and not Translate core since currently it is only used by evalLit. makeLiteral :: (Show x) => x -> State IDState (IconGraph, NameAndPort) makeLiteral = makeBox. show @@ -230,15 +174,9 @@ showLiteral (Exts.PrimDouble x) = show x showLiteral (Exts.PrimChar x) = show x showLiteral (Exts.PrimString x) = show x - -namesInPattern :: GraphAndRef -> [String] -namesInPattern (_, Left str) = [str] -namesInPattern (IconGraph _ _ _ _ bindings, Right _) = fmap fst bindings - getBoundVarName :: Decl -> [String] -- TODO Should evalState be used here? getBoundVarName (PatBind _ pat _ _) = namesInPattern $ evalState (evalPattern pat) initialIdState -getBoundVarName (FunBind [Match _ name _ _ _ _]) = [nameToString name] getBoundVarName (FunBind (Match _ name _ _ _ _:_)) = [nameToString name] --TODO: Should this call makeEdges? @@ -250,40 +188,6 @@ evalBinds c (BDecls decls) = do evaledDecl <- mconcat <$> mapM (evalDecl augmentedContext) decls pure (evaledDecl, augmentedContext) -printSelf :: (Show a) => a -> a -printSelf a = Debug.Trace.trace (show a ++ "\n\n") a - --- | Recursivly find the matching reference in a list of bindings. --- TODO: Might want to present some indication if there is a reference cycle. -lookupReference :: [(String, Reference)] -> Reference -> Reference -lookupReference _ ref@(Right _) = ref -lookupReference bindings ref@(Left originalS) = lookupHelper ref where - lookupHelper newRef@(Right _) = newRef - lookupHelper newRef@(Left s)= case lookup s bindings of - Just r -> failIfCycle r $ lookupHelper r - Nothing -> newRef - where - failIfCycle r@(Left newStr) res = if newStr == originalS then r else res - failIfCycle _ res = res - -deleteBindings :: IconGraph -> IconGraph -deleteBindings (IconGraph a b c d _) = IconGraph a b c d mempty - -makeEdgesCore :: [Sink] -> [(String, Reference)] -> ([Sink], [Edge]) -makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks - where - renameOrMakeEdge :: (String, NameAndPort) -> Either (String, NameAndPort) Edge - renameOrMakeEdge orig@(s, destPort) = case lookup s bindings of - Just ref -> case lookupReference bindings ref of - (Right sourcePort) -> Right $ makeSimpleEdge (sourcePort, destPort) - (Left newStr) -> Left (newStr, destPort) - Nothing -> Left orig - -makeEdges :: IconGraph -> IconGraph -makeEdges (IconGraph icons edges c sinks bindings) = newGraph where - (newSinks, newEdges) = makeEdgesCore sinks bindings - newGraph = IconGraph icons (newEdges <> edges) c newSinks bindings - evalGeneralLet :: (EvalContext -> State IDState (IconGraph, Reference)) -> EvalContext -> Binds -> State IDState (IconGraph, Reference) evalGeneralLet expOrRhsEvaler c bs = do (bindGraph, bindContext) <- evalBinds c bs @@ -305,7 +209,6 @@ evalPatAndRhs c pat rhs maybeWhereBinds = do -- TODO: remove coerceExpressionResult (rhsGraph, rhsRef) <- rhsWithBinds maybeWhereBinds rhs rhsContext >>= coerceExpressionResult (patGraph, patRef) <- evalPattern pat - caseIconName <- DIA.toName <$> getUniqueName "case" let grWithEdges = makeEdges (rhsGraph <> patGraph) -- The pattern and rhs are conneted if makeEdges added extra edges. @@ -315,7 +218,7 @@ evalPatAndRhs c pat rhs maybeWhereBinds = do -- returns (combined graph, pattern reference, rhs reference) evalAlt :: EvalContext -> Exts.Alt -> State IDState (Bool, IconGraph, Reference, NameAndPort) -evalAlt c (Exts.Alt s pat rhs maybeBinds) = evalPatAndRhs c pat rhs maybeBinds +evalAlt c (Exts.Alt _ pat rhs maybeBinds) = evalPatAndRhs c pat rhs maybeBinds evalCase :: EvalContext -> Exp -> [Alt] -> State IDState (IconGraph, NameAndPort) evalCase c e alts = do @@ -367,20 +270,6 @@ evalExp c x = case x of Tuple _ exps -> fmap Right <$> evalTuple c exps Paren e -> evalExp c e --- | This is used by the rhs for identity (eg. y x = x) -makeDummyRhs :: String -> State IDState (IconGraph, NameAndPort) -makeDummyRhs s = do - iconName <- getUniqueName s - let - graph = IconGraph icons mempty mempty [(s, port)] mempty - icons = [(DIA.toName iconName, BranchIcon)] - port = justName iconName - pure (graph, port) - -coerceExpressionResult :: (IconGraph, Reference) -> State IDState (IconGraph, NameAndPort) -coerceExpressionResult (_, Left str) = makeDummyRhs str -coerceExpressionResult (g, Right x) = pure (g, x) - -- | First argument is the right hand side. -- The second arugement is a list of strings that are bound in the environment. evalRhs :: EvalContext -> Rhs -> State IDState (IconGraph, Reference) @@ -408,26 +297,6 @@ evalPatBind c (PatBind _ pat rhs maybeWhereBinds) = do gr = IconGraph mempty newEdges mempty newSinks bindings pure . makeEdges $ (gr <> rhsGraph <> patGraph) -iconGraphToDrawing :: IconGraph -> Drawing -iconGraphToDrawing (IconGraph icons edges subDrawings _ _) = Drawing icons edges subDrawings - -makeRhsDrawing :: DIA.IsName a => a -> (IconGraph, NameAndPort) -> Drawing -makeRhsDrawing resultIconName (rhsGraph, rhsResult)= rhsDrawing where - rhsNewIcons = toNames [(resultIconName, ResultIcon)] - rhsNewEdges = [makeSimpleEdge (rhsResult, justName resultIconName)] - rhsGraphWithResult = rhsGraph <> iconGraphFromIconsEdges rhsNewIcons rhsNewEdges - rhsDrawing = iconGraphToDrawing rhsGraphWithResult - -qualifyNameAndPort :: String -> NameAndPort -> NameAndPort -qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p - --- TODO Like evalPatBind, this edge should have an indicator that it is the input to a pattern. -makePatternEdges :: String -> GraphAndRef -> NameAndPort -> Either IconGraph (String, Reference) -makePatternEdges lambdaName (_, Right patPort) lamPort = - Left $ iconGraphFromIconsEdges mempty - [makeSimpleEdge (lamPort, qualifyNameAndPort lambdaName patPort)] -makePatternEdges _ (_, Left str) lamPort = Right (str, Right lamPort) - generalEvalLambda :: EvalContext -> [Pat] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (IconGraph, NameAndPort) generalEvalLambda context patterns rhsEvalFun = do lambdaName <- getUniqueName "lam" @@ -457,6 +326,21 @@ generalEvalLambda context patterns rhsEvalFun = do finalGraph = IconGraph icons internalEdges [(rhsDrawingName, rhsDrawing)] newSinks mempty pure (patternEdgeGraph <> finalGraph, justName lambdaName) + where + makeRhsDrawing :: DIA.IsName a => a -> (IconGraph, NameAndPort) -> Drawing + makeRhsDrawing resultIconName (rhsGraph, rhsResult)= rhsDrawing where + rhsNewIcons = toNames [(resultIconName, ResultIcon)] + rhsNewEdges = [makeSimpleEdge (rhsResult, justName resultIconName)] + rhsGraphWithResult = rhsGraph <> iconGraphFromIconsEdges rhsNewIcons rhsNewEdges + rhsDrawing = iconGraphToDrawing rhsGraphWithResult + + -- TODO Like evalPatBind, this edge should have an indicator that it is the input to a pattern. + makePatternEdges :: String -> GraphAndRef -> NameAndPort -> Either IconGraph (String, Reference) + makePatternEdges lambdaName (_, Right patPort) lamPort = + Left $ iconGraphFromIconsEdges mempty + [makeSimpleEdge (lamPort, qualifyNameAndPort lambdaName patPort)] + makePatternEdges _ (_, Left str) lamPort = Right (str, Right lamPort) + evalLambda :: EvalContext -> [Pat] -> Exp -> State IDState (IconGraph, NameAndPort) evalLambda c patterns e = generalEvalLambda c patterns (`evalExp` e) @@ -472,32 +356,30 @@ evalMatch c (Match _ name patterns _ rhs maybeWhereBinds) = do newBinding = IconGraph mempty mempty mempty mempty [(matchFunNameString, Right lambdaPort)] pure $ makeEdges (newBinding <> lambdaGraph) --- TODO If only one pattern don't tuple and untuple. --- Warning: [] not matched. --- TODO refactor so this takes as seperate arguments the first matchs, and the rest of the matches as a list. --- this avoids the [] case. + matchesToCase :: Match -> [Match] -> State IDState Match matchesToCase match [] = pure match matchesToCase firstMatch@(Match srcLoc funName pats mType _ _) restOfMatches = do tempStrings <- replicateM (length pats) (getUniqueName "_tempvar") let - allMatches = firstMatch:restOfMatches tempPats = fmap (PVar . Ident) tempStrings tempVars = fmap (Var . UnQual . Ident) tempStrings tuple = Tuple Exts.Boxed tempVars - alts = fmap matchToAlt allMatches - -- TODO See if this can be made nicer. caseExp = case tempVars of - [oneTempVar] -> Case (head tempVars) alts + [oneTempVar] -> Case oneTempVar alts _ -> Case tuple alts rhs = UnGuardedRhs caseExp match = Match srcLoc funName tempPats mType rhs Nothing - - matchToAlt :: Match -> Alt - matchToAlt (Match srcLoc _ [pat] _ rhs binds) = Alt srcLoc pat rhs binds - matchToAlt (Match srcLoc _ pats _ rhs binds) = Alt srcLoc tuplePat rhs binds where - tuplePat = PTuple Exts.Boxed pats pure match + where + allMatches = firstMatch:restOfMatches + alts = fmap matchToAlt allMatches + matchToAlt :: Match -> Alt + matchToAlt (Match srcLocation _ mtaPats _ rhs binds) = Alt srcLocation altPattern rhs binds where + altPattern = case mtaPats of + [onePat] -> onePat + _ -> PTuple Exts.Boxed pats + evalMatches :: EvalContext -> [Match] -> State IDState IconGraph evalMatches _ [] = pure mempty @@ -511,25 +393,25 @@ evalDecl c d = evaluatedDecl where --TODO: Add other cases here _ -> pure mempty -showTopLevelBinds :: IconGraph -> State IDState IconGraph -showTopLevelBinds gr@(IconGraph _ _ _ _ binds) = do - let - addBind (_, Left _) = pure mempty - addBind (patName, Right port) = do - uniquePatName <- getUniqueName patName - let - icons = toNames [(uniquePatName, TextBoxIcon patName)] - edges = [makeSimpleEdge (justName uniquePatName, port)] - edgeGraph = iconGraphFromIconsEdges icons edges - pure edgeGraph - newGraph <- mconcat <$> mapM addBind binds - pure $ newGraph <> gr - drawingFromDecl :: Decl -> Drawing drawingFromDecl d = iconGraphToDrawing $ evalState evaluatedDecl initialIdState - where evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds + where + evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds + showTopLevelBinds :: IconGraph -> State IDState IconGraph + showTopLevelBinds gr@(IconGraph _ _ _ _ binds) = do + let + addBind (_, Left _) = pure mempty + addBind (patName, Right port) = do + uniquePatName <- getUniqueName patName + let + icons = toNames [(uniquePatName, TextBoxIcon patName)] + edges = [makeSimpleEdge (justName uniquePatName, port)] + edgeGraph = iconGraphFromIconsEdges icons edges + pure edgeGraph + newGraph <- mconcat <$> mapM addBind binds + pure $ newGraph <> gr --- Profiling: about 1.5% of time. +-- Profiling: about 1.5% of total time. translateString :: String -> (Drawing, Decl) translateString s = (drawing, decl) where parseResult = parseDecl s -- :: ParseResult Module diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs new file mode 100644 index 0000000..0f20a05 --- /dev/null +++ b/app/TranslateCore.hs @@ -0,0 +1,157 @@ +module TranslateCore( + Reference, + IconGraph(..), + EvalContext, + GraphAndRef, + Sink, + iconGraphFromIcons, + iconGraphFromIconsEdges, + getUniqueName, + edgesForRefPortList, + combineExpressions, + qualifyNameAndPort, + iconGraphToDrawing, + makeApplyGraph, + namesInPattern, + lookupReference, + deleteBindings, + makeEdges, + makeEdgesCore, + coerceExpressionResult, + makeBox +) where + +import Data.Semigroup(Semigroup, (<>)) +import qualified Diagrams.Prelude as DIA +import Control.Monad.State(State) +import Data.Either(partitionEithers) + +import Types(Icon, Edge(..), EdgeOption(..), Drawing(..), NameAndPort(..), IDState, + getId) +import Util(noEnds, nameAndPort, makeSimpleEdge, justName) +import Icons(Icon(..)) + +-- OVERVIEW -- +-- This module has the core functions and data types used by Translate. +-- This module also contains most/all of the translation functions that +-- do not require Language.Haskell.Exts. + +type Reference = Either String NameAndPort +-- | An IconGraph is a normal Drawing (Icons, Edges, and sub Drawings) with two additional fields: +-- unconected sink ports (varible usage), and unconnected source ports (varible definition). +data IconGraph = IconGraph { + igIcons :: [(DIA.Name, Icon)], + igEdges :: [Edge], + igSubDrawings :: [(DIA.Name, Drawing)], + igSinks :: [(String, NameAndPort)], + igBindings :: [(String, Reference)]} + deriving (Show) + +type EvalContext = [String] +type GraphAndRef = (IconGraph, Reference) +type Sink = (String, NameAndPort) + +instance Semigroup IconGraph where + (IconGraph icons1 edges1 subDrawings1 sinks1 sources1) <> (IconGraph icons2 edges2 subDrawings2 sinks2 sources2) = + IconGraph (icons1 <> icons2) (edges1 <> edges2) (subDrawings1 <> subDrawings2) (sinks1 <> sinks2) (sources1 <> sources2) + +instance Monoid IconGraph where + mempty = IconGraph mempty mempty mempty mempty mempty + mappend = (<>) + +iconGraphFromIcons :: [(DIA.Name, Icon)] -> IconGraph +iconGraphFromIcons icons = IconGraph icons mempty mempty mempty mempty + +iconGraphFromIconsEdges :: [(DIA.Name, Icon)] -> [Edge] -> IconGraph +iconGraphFromIconsEdges icons edges = IconGraph icons edges mempty mempty mempty + +getUniqueName :: String -> State IDState String +getUniqueName base = fmap ((base ++). show) getId + +-- TODO: Refactor with combineExpressions +edgesForRefPortList :: Bool -> [(Reference, NameAndPort)] -> IconGraph +edgesForRefPortList inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs where + edgeOpts = [EdgeInPattern | inPattern] + mkGraph (ref, port) = case ref of + Left str -> if inPattern + then IconGraph mempty mempty mempty mempty [(str, Right port)] + else IconGraph mempty mempty mempty [(str, port)] mempty + Right resultPort -> IconGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty mempty + +combineExpressions :: Bool -> [(GraphAndRef, NameAndPort)] -> IconGraph +combineExpressions inPattern portExpPairs = mconcat $ fmap mkGraph portExpPairs where + edgeOpts = [EdgeInPattern | inPattern] + mkGraph ((graph, ref), port) = graph <> case ref of + Left str -> if inPattern + then IconGraph mempty mempty mempty mempty [(str, Right port)] + else IconGraph mempty mempty mempty [(str, port)] mempty + Right resultPort -> IconGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty mempty + +qualifyNameAndPort :: String -> NameAndPort -> NameAndPort +qualifyNameAndPort s (NameAndPort n p) = NameAndPort (s DIA..> n) p + +iconGraphToDrawing :: IconGraph -> Drawing +iconGraphToDrawing (IconGraph icons edges subDrawings _ _) = Drawing icons edges subDrawings + +makeApplyGraph :: Bool -> DIA.Name -> (IconGraph, Reference) -> [(IconGraph, Reference)] -> Int -> (IconGraph, NameAndPort) +makeApplyGraph inPattern applyIconName funVal argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1) + where + argumentPorts = map (nameAndPort applyIconName) [2,3..] + functionPort = nameAndPort applyIconName 0 + combinedGraph = combineExpressions inPattern $ zip (funVal:argVals) (functionPort:argumentPorts) + icons = [(applyIconName, Apply0NIcon numArgs)] + newGraph = iconGraphFromIcons icons + +namesInPattern :: GraphAndRef -> [String] +namesInPattern (_, Left str) = [str] +namesInPattern (IconGraph _ _ _ _ bindings, Right _) = fmap fst bindings + +-- | Recursivly find the matching reference in a list of bindings. +-- TODO: Might want to present some indication if there is a reference cycle. +lookupReference :: [(String, Reference)] -> Reference -> Reference +lookupReference _ ref@(Right _) = ref +lookupReference bindings ref@(Left originalS) = lookupHelper ref where + lookupHelper newRef@(Right _) = newRef + lookupHelper newRef@(Left s)= case lookup s bindings of + Just r -> failIfCycle r $ lookupHelper r + Nothing -> newRef + where + failIfCycle r@(Left newStr) res = if newStr == originalS then r else res + failIfCycle _ res = res + +deleteBindings :: IconGraph -> IconGraph +deleteBindings (IconGraph a b c d _) = IconGraph a b c d mempty + +makeEdgesCore :: [Sink] -> [(String, Reference)] -> ([Sink], [Edge]) +makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks + where + renameOrMakeEdge :: (String, NameAndPort) -> Either (String, NameAndPort) Edge + renameOrMakeEdge orig@(s, destPort) = case lookup s bindings of + Just ref -> case lookupReference bindings ref of + (Right sourcePort) -> Right $ makeSimpleEdge (sourcePort, destPort) + (Left newStr) -> Left (newStr, destPort) + Nothing -> Left orig + +makeEdges :: IconGraph -> IconGraph +makeEdges (IconGraph icons edges c sinks bindings) = newGraph where + (newSinks, newEdges) = makeEdgesCore sinks bindings + newGraph = IconGraph icons (newEdges <> edges) c newSinks bindings + +-- | This is used by the rhs for identity (eg. y x = x) +coerceExpressionResult :: (IconGraph, Reference) -> State IDState (IconGraph, NameAndPort) +coerceExpressionResult (_, Left str) = makeDummyRhs str where + makeDummyRhs :: String -> State IDState (IconGraph, NameAndPort) + makeDummyRhs s = do + iconName <- getUniqueName s + let + graph = IconGraph icons mempty mempty [(s, port)] mempty + icons = [(DIA.toName iconName, BranchIcon)] + port = justName iconName + pure (graph, port) +coerceExpressionResult (g, Right x) = pure (g, x) + +makeBox :: String -> State IDState (IconGraph, NameAndPort) +makeBox str = do + name <- DIA.toName <$> getUniqueName str + let graph = iconGraphFromIcons [(DIA.toName name, TextBoxIcon str)] + pure (graph, justName name) diff --git a/app/Types.hs b/app/Types.hs index 70c84e2..f7db495 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -3,7 +3,7 @@ module Types ( Icon(..), NameAndPort(..), - Connection(..), + Connection, Edge(..), EdgeOption(..), EdgeEnd(..), diff --git a/app/Util.hs b/app/Util.hs index 46a6c98..c07023f 100644 --- a/app/Util.hs +++ b/app/Util.hs @@ -13,12 +13,14 @@ module Util ( nameAndPort, justName, fromMaybeError, - mapFst + mapFst, + printSelf )where import Control.Arrow(first) import Diagrams.Prelude(IsName, toName, Name) import Data.Maybe(fromMaybe) +import qualified Debug.Trace import Types(EdgeEnd(..), Edge(..), NameAndPort(..), Connection) @@ -64,3 +66,6 @@ iconTailToPort a endTail c d = Edge [] (endTail, EndNone) (justName a, nameAndPo fromMaybeError :: String -> Maybe a -> a fromMaybeError s = fromMaybe (error s) + +printSelf :: (Show a) => a -> a +printSelf a = Debug.Trace.trace (show a ++ "\n\n") a diff --git a/glance.cabal b/glance.cabal index 83b0602..85405c7 100644 --- a/glance.cabal +++ b/glance.cabal @@ -34,8 +34,9 @@ executable glance-exe , fgl , haskell-src-exts , mtl + , semigroups default-language: Haskell2010 - Other-modules: Icons, Rendering, Types, Util, Translate + Other-modules: Icons, Rendering, Types, Util, Translate, TranslateCore test-suite glance-test type: exitcode-stdio-1.0