From 0b3efb0262510c8ed7bfb87908dfd8e106839efe Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Fri, 25 Dec 2020 22:35:24 -0800 Subject: [PATCH] Update stackage, fix warnings and format some app files with Ormolu. --- app/Translate.hs | 753 ++++++++++++++++++++++++------------------- app/TranslateCore.hs | 399 +++++++++++++---------- app/Types.hs | 144 +++++---- stack.yaml | 2 +- 4 files changed, 723 insertions(+), 575 deletions(-) diff --git a/app/Translate.hs b/app/Translate.hs index cd9272c..4b0c184 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -1,44 +1,85 @@ -{-# LANGUAGE NoMonomorphismRestriction, TupleSections #-} -module Translate( - translateStringToSyntaxGraph, - translateStringToCollapsedGraphAndDecl, - translateModuleToCollapsedGraphs, - customParseDecl -) where +-- This file is formatted with Ormolu +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoMonomorphismRestriction #-} -import Diagrams.Prelude((<>)) +module Translate + ( translateStringToSyntaxGraph, + translateStringToCollapsedGraphAndDecl, + translateModuleToCollapsedGraphs, + customParseDecl, + ) +where -import Control.Monad(replicateM) -import Control.Monad.State(State, evalState) -import Data.Either(partitionEithers) +import Control.Monad (replicateM) +import Control.Monad.State (State, evalState) +import Data.Either (partitionEithers) import qualified Data.Graph.Inductive.PatriciaTree as FGR -import Data.List(unzip5, partition, intercalate) +import Data.List (intercalate, partition, unzip5) import qualified Data.Map as Map -import Data.Maybe(fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set - +import GraphAlgorithms (annotateGraph, collapseAnnotatedGraph) +import Icons + ( argumentPorts, + casePatternPorts, + caseRhsPorts, + inputPort, + resultPort, + ) import qualified Language.Haskell.Exts as Exts import qualified Language.Haskell.Exts.Pretty as PExts - -import GraphAlgorithms(annotateGraph, collapseAnnotatedGraph) -import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts, - casePatternPorts) -import SimplifySyntax(SimpAlt(..), stringToSimpDecl, SimpExp(..), SimpPat(..) - , qNameToString, nameToString, customParseDecl - , SimpDecl(..), hsDeclToSimpDecl, SelectorAndVal(..)) -import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..) - , SgSink(..), syntaxGraphFromNodes - , syntaxGraphFromNodesEdges, getUniqueName - , edgesForRefPortList, makeApplyGraph, makeMultiIfGraph - , combineExpressions, namesInPattern, lookupReference - , deleteBindings, makeEdges, makeBox, syntaxGraphToFglGraph - , getUniqueString, bindsToSyntaxGraph, SgBind(..) - , graphAndRefToGraph, initialIdState) -import Types(AnnotatedGraph, Labeled(..), NameAndPort(..), IDState, - Edge, SyntaxNode(..), NodeName, SgNamedNode, - LikeApplyFlavor(..), CaseOrMultiIfTag(..), Named(..) - , mkEmbedder) -import Util(makeSimpleEdge, nameAndPort, justName) +import SimplifySyntax + ( SelectorAndVal (..), + SimpAlt (..), + SimpDecl (..), + SimpExp (..), + SimpPat (..), + customParseDecl, + hsDeclToSimpDecl, + nameToString, + qNameToString, + stringToSimpDecl, + ) +import TranslateCore + ( EvalContext, + GraphAndRef (..), + Reference, + SgBind (..), + SgSink (..), + SyntaxGraph (..), + bindsToSyntaxGraph, + combineExpressions, + deleteBindings, + edgesForRefPortList, + getUniqueName, + getUniqueString, + graphAndRefToGraph, + initialIdState, + lookupReference, + makeApplyGraph, + makeBox, + makeEdges, + makeMultiIfGraph, + namesInPattern, + syntaxGraphFromNodes, + syntaxGraphFromNodesEdges, + syntaxGraphToFglGraph, + ) +import Types + ( AnnotatedGraph, + CaseOrMultiIfTag (..), + Edge, + IDState, + Labeled (..), + LikeApplyFlavor (..), + NameAndPort (..), + Named (..), + NodeName, + SgNamedNode, + SyntaxNode (..), + mkEmbedder, + ) +import Util (justName, makeSimpleEdge, nameAndPort) {-# ANN module "HLint: ignore Use record patterns" #-} @@ -52,8 +93,8 @@ import Util(makeSimpleEdge, nameAndPort, justName) -- | Make a syntax graph that has the bindings for a list of "as pattern" (@) -- names. makeAsBindGraph :: Reference -> [Maybe String] -> SyntaxGraph -makeAsBindGraph ref asNames - = bindsToSyntaxGraph $ mapMaybe makeBind asNames +makeAsBindGraph ref asNames = + bindsToSyntaxGraph $ mapMaybe makeBind asNames where makeBind mName = case mName of Nothing -> Nothing @@ -63,26 +104,26 @@ grNamePortToGrRef :: (SyntaxGraph, NameAndPort) -> GraphAndRef grNamePortToGrRef (graph, np) = GraphAndRef graph (Right np) -- TODO Find a better name for bindOrAltHelper -bindOrAltHelper :: Show l => - EvalContext - -> SimpPat l - -> SimpExp l - -> State IDState ((GraphAndRef, Maybe String), GraphAndRef) +bindOrAltHelper :: + Show l => + EvalContext -> + SimpPat l -> + SimpExp l -> + State IDState ((GraphAndRef, Maybe String), GraphAndRef) bindOrAltHelper c pat e = do patGraphAndRef <- evalPattern pat - let - rhsContext = namesInPattern patGraphAndRef <> c + let rhsContext = namesInPattern patGraphAndRef <> c rhsGraphAndRef <- evalExp rhsContext e pure (patGraphAndRef, rhsGraphAndRef) - patternName :: (GraphAndRef, Maybe String) -> String -patternName (GraphAndRef _ ref, mStr) = fromMaybe - (case ref of - Left str -> str - Right _ -> "" - ) - mStr +patternName (GraphAndRef _ ref, mStr) = + fromMaybe + ( case ref of + Left str -> str + Right _ -> "" + ) + mStr -- END Helper Functions -- @@ -118,10 +159,10 @@ asNameBind (GraphAndRef _ ref, mAsName) = case mAsName of Just asName -> Just $ SgBind asName ref patternArgumentMapper :: - ((GraphAndRef, Maybe String), t) - -> (String, Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph)) -patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) - = (patName, eitherVal) + ((GraphAndRef, Maybe String), t) -> + (String, Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph)) +patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) = + (patName, eitherVal) where graph = graphAndRefToGraph graphAndRef patName = patternName asGraphAndRef @@ -130,38 +171,37 @@ patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) (SyntaxGraph [namedNode] [] _ _ _) -> Right (namedNode, graph) _ -> Left (graphAndRef, port) - graphToTuple :: - SyntaxGraph - -> ([SgNamedNode], [Edge], [SgSink], [SgBind], Map.Map NodeName NodeName) + SyntaxGraph -> + ([SgNamedNode], [Edge], [SgSink], [SgBind], Map.Map NodeName NodeName) graphToTuple (SyntaxGraph a b c d e) = (a, b, c, d, e) graphsToComponents :: - [SyntaxGraph] - -> ([SgNamedNode], [Edge], [SgSink], [SgBind], Map.Map NodeName NodeName) -graphsToComponents graphs - = (mconcat a, mconcat b, mconcat c, mconcat d, mconcat e) + [SyntaxGraph] -> + ([SgNamedNode], [Edge], [SgSink], [SgBind], Map.Map NodeName NodeName) +graphsToComponents graphs = + (mconcat a, mconcat b, mconcat c, mconcat d, mconcat e) where (a, b, c, d, e) = unzip5 $ fmap graphToTuple graphs makeNestedPatternGraph :: - NodeName - -> String - -> [(GraphAndRef, Maybe String)] - -> (SyntaxGraph, NameAndPort) + NodeName -> + String -> + [(GraphAndRef, Maybe String)] -> + (SyntaxGraph, NameAndPort) makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult where dummyNode = PatternApplyNode "" [] - argsAndPorts - = zip argVals $ map (nameAndPort applyIconName) $ argumentPorts dummyNode + argsAndPorts = + zip argVals $ map (nameAndPort applyIconName) $ argumentPorts dummyNode mappedArgs = fmap patternArgumentMapper argsAndPorts - (unnestedArgsAndPort, nestedNamedNodesAndGraphs) - = partitionEithers (fmap snd mappedArgs) + (unnestedArgsAndPort, nestedNamedNodesAndGraphs) = + partitionEithers (fmap snd mappedArgs) - (nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) - = graphsToComponents $ fmap snd nestedNamedNodesAndGraphs + (nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) = + graphsToComponents $ fmap snd nestedNamedNodesAndGraphs argListMapper (str, arg) = case arg of Left _ -> Labeled Nothing str @@ -177,27 +217,31 @@ makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult asNameBinds = mapMaybe asNameBind argVals allBinds = nestedBinds <> asNameBinds - newEMap = Map.fromList - ((\(Named n _) -> (n, applyIconName)) <$> nestedArgs) - <> nestedEMaps + newEMap = + Map.fromList + ((\(Named n _) -> (n, applyIconName)) <$> nestedArgs) + <> nestedEMaps - newGraph = SyntaxGraph - icons - [] - nestedSinks - allBinds - newEMap - nestedApplyResult = (newGraph <> combinedGraph - , nameAndPort applyIconName (resultPort pAppNode)) + newGraph = + SyntaxGraph + icons + [] + nestedSinks + allBinds + newEMap + nestedApplyResult = + ( newGraph <> combinedGraph, + nameAndPort applyIconName (resultPort pAppNode) + ) - -evalPApp :: Show l => - Exts.QName l - -> [SimpPat l] - -> State IDState (SyntaxGraph, NameAndPort) +evalPApp :: + Show l => + Exts.QName l -> + [SimpPat l] -> + State IDState (SyntaxGraph, NameAndPort) evalPApp name patterns = case patterns of [] -> makeBox constructorName - _ -> do + _ -> do patName <- getUniqueName evaledPatterns <- mapM evalPattern patterns pure $ makeNestedPatternGraph patName constructorName evaledPatterns @@ -226,22 +270,29 @@ evalPLit :: evalPLit sign l = case sign of Exts.Signless _ -> evalLit l Exts.Negative _ -> makeBox ('-' : showLiteral l) + -- END evalPLit -evalPAsPat :: Show l => - Exts.Name l -> SimpPat l -> State IDState (GraphAndRef, Maybe String) +evalPAsPat :: + Show l => + Exts.Name l -> + SimpPat l -> + State IDState (GraphAndRef, Maybe String) evalPAsPat n p = do (GraphAndRef evaledPatGraph evaledPatRef, mInnerName) <- evalPattern p - let - outerName = nameToString n - asBindGraph = makeAsBindGraph (Left outerName) [mInnerName] - pure (GraphAndRef (asBindGraph <> evaledPatGraph) evaledPatRef - , Just outerName) + let outerName = nameToString n + asBindGraph = makeAsBindGraph (Left outerName) [mInnerName] + pure + ( GraphAndRef (asBindGraph <> evaledPatGraph) evaledPatRef, + Just outerName + ) -makePatternResult :: Functor f => - f (SyntaxGraph, NameAndPort) -> f (GraphAndRef, Maybe String) -makePatternResult - = fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing)) +makePatternResult :: + Functor f => + f (SyntaxGraph, NameAndPort) -> + f (GraphAndRef, Maybe String) +makePatternResult = + fmap (\(graph, namePort) -> (GraphAndRef graph (Right namePort), Nothing)) evalPattern :: Show l => SimpPat l -> State IDState (GraphAndRef, Maybe String) evalPattern p = case p of @@ -250,7 +301,8 @@ evalPattern p = case p of SpApp _ name patterns -> makePatternResult $ evalPApp name patterns SpAsPat _ name pat -> evalPAsPat name pat SpWildCard _ -> makePatternResult $ makeBox "_" - -- _ -> error ("evalPattern todo: " <> show p) + +-- _ -> error ("evalPattern todo: " <> show p) -- END evalPattern @@ -258,49 +310,56 @@ evalPattern p = case p of -- strToGraphRef is not in TranslateCore, since it is only used by evalQName. strToGraphRef :: EvalContext -> String -> State IDState GraphAndRef -strToGraphRef c str = fmap mapper (makeBox str) where - mapper gr = if str `elem` c - then GraphAndRef mempty (Left str) - else grNamePortToGrRef gr +strToGraphRef c str = fmap mapper (makeBox str) + where + mapper gr = + if str `elem` c + then GraphAndRef mempty (Left str) + else grNamePortToGrRef gr -- END evalQName -- BEGIN apply and compose helper functions -evalFunExpAndArgs :: Show l => - EvalContext - -> LikeApplyFlavor - -> (SimpExp l, [SimpExp l]) - -> State IDState (SyntaxGraph, NameAndPort) +evalFunExpAndArgs :: + Show l => + EvalContext -> + LikeApplyFlavor -> + (SimpExp l, [SimpExp l]) -> + State IDState (SyntaxGraph, NameAndPort) evalFunExpAndArgs c flavor (funExp, argExps) = do funVal <- evalExp c funExp argVals <- mapM (evalExp c) argExps applyIconName <- getUniqueName - pure - $ makeApplyGraph (length argExps) flavor False applyIconName funVal argVals + pure $ + makeApplyGraph (length argExps) flavor False applyIconName funVal argVals -- END apply and compose helper functions -evalFunctionComposition :: Show l => - EvalContext -> [SimpExp l] -> State IDState (SyntaxGraph, NameAndPort) +evalFunctionComposition :: + Show l => + EvalContext -> + [SimpExp l] -> + State IDState (SyntaxGraph, NameAndPort) evalFunctionComposition c functions = do let reversedFunctios = reverse functions evaluatedFunctions <- mapM (evalExp c) reversedFunctios neverUsedPort <- Left <$> getUniqueString "unusedArgument" applyIconName <- getUniqueName - pure $ makeApplyGraph - (length evaluatedFunctions) - ComposeNodeFlavor - False - applyIconName - (GraphAndRef mempty neverUsedPort) - evaluatedFunctions + pure $ + makeApplyGraph + (length evaluatedFunctions) + ComposeNodeFlavor + False + applyIconName + (GraphAndRef mempty neverUsedPort) + evaluatedFunctions -- | Turn (a . b . c) into [a, b, c] compositionToList :: SimpExp l -> [SimpExp l] compositionToList e = case e of - (SeApp _ (SeApp _ (SeName _ ".") f1) f2) - -> f1 : compositionToList f2 + (SeApp _ (SeApp _ (SeName _ ".") f1) f2) -> + f1 : compositionToList f2 x -> [x] -- BEGIN evaluateAppExpression @@ -309,22 +368,23 @@ compositionToList e = case e of -- return the nesting depth if (f x) is rendered with -- the (normal apply icon, compose apply icon) applyComposeScoreHelper :: SimpExp l -> SimpExp l -> (Int, Int) -applyComposeScoreHelper exp1 exp2 = (appScore, compScore) where - (e1App, e1Comp) = applyComposeScore exp1 - (e2App, e2Comp) = applyComposeScore exp2 +applyComposeScoreHelper exp1 exp2 = (appScore, compScore) + where + (e1App, e1Comp) = applyComposeScore exp1 + (e2App, e2Comp) = applyComposeScore exp2 - leftApp = min e1App (1 + e1Comp) - rightApp = 1 + min e2App e2Comp + leftApp = min e1App (1 + e1Comp) + rightApp = 1 + min e2App e2Comp - appScore = max leftApp rightApp + appScore = max leftApp rightApp - leftComp = 1 + min e1App e1Comp - rightComp = min (1 + e2App) e2Comp - - compScore = max leftComp rightComp + leftComp = 1 + min e1App e1Comp + rightComp = min (1 + e2App) e2Comp + compScore = max leftComp rightComp -- TODO Consider putting this logic in a separate "simplifyExpression" function. + -- | Returns the amount of nesting if the App is converted to -- (applyNode, composeNode) applyComposeScore :: SimpExp l -> (Int, Int) @@ -333,6 +393,7 @@ applyComposeScore e = case e of _ -> (0, 0) -- Todo add test for this function + -- | Given an App expression, return -- (function, list of arguments) appExpToFuncArgs :: SimpExp l -> (SimpExp l, [SimpExp l]) @@ -351,18 +412,20 @@ appExpToArgFuncs e = case e of (argExp, funcs) = appExpToArgFuncs exp2 simpleExp -> (simpleExp, []) - -- TODO Refactor this and all sub-expressions -evalApp :: Show l => - EvalContext -> SimpExp l - -> State IDState (SyntaxGraph, NameAndPort) +evalApp :: + Show l => + EvalContext -> + SimpExp l -> + State IDState (SyntaxGraph, NameAndPort) evalApp c expr = case expr of -- TODO This pattern for "." appears at least twice in this file. Refactor? - (SeApp _ (SeApp _ (SeName _ ".") _) _) - -> evalFunctionComposition c (compositionToList expr) - _ -> if appScore <= compScore - then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs expr) - else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs expr) + (SeApp _ (SeApp _ (SeName _ ".") _) _) -> + evalFunctionComposition c (compositionToList expr) + _ -> + if appScore <= compScore + then evalFunExpAndArgs c ApplyNodeFlavor (appExpToFuncArgs expr) + else evalFunExpAndArgs c ComposeNodeFlavor (appExpToArgFuncs expr) where (appScore, compScore) = applyComposeScore expr @@ -372,148 +435,162 @@ evalApp c expr = case expr of getBoundVarName :: Show l => SimpDecl l -> [String] getBoundVarName d = case d of - SdPatBind _ pat _ -> namesInPattern - -- TODO Should evalState be used here? - $ evalState (evalPattern pat) initialIdState + SdPatBind _ pat _ -> + namesInPattern + -- TODO Should evalState be used here? + $ + evalState (evalPattern pat) initialIdState SdTypeSig _ _ _ -> [] SdCatchAll _ -> [] -evalDecls :: Show l => - EvalContext -> [SimpDecl l] -> State IDState (SyntaxGraph, EvalContext) +evalDecls :: + Show l => + EvalContext -> + [SimpDecl l] -> + State IDState (SyntaxGraph, EvalContext) evalDecls c decls = - let - boundNames = concatMap getBoundVarName decls - augmentedContext = boundNames <> c - in - (,augmentedContext) . mconcat <$> mapM (evalDecl augmentedContext) decls + let boundNames = concatMap getBoundVarName decls + augmentedContext = boundNames <> c + in (,augmentedContext) . mconcat <$> mapM (evalDecl augmentedContext) decls -evalLet :: Show l => - EvalContext - -> [SimpDecl l] - -> SimpExp l - -> State IDState GraphAndRef +evalLet :: + Show l => + EvalContext -> + [SimpDecl l] -> + SimpExp l -> + State IDState GraphAndRef evalLet c decls expr = do (bindGraph, bindContext) <- evalDecls c decls expVal <- evalExp bindContext expr - let - GraphAndRef expGraph expResult = expVal - newGraph = deleteBindings . makeEdges $ expGraph <> bindGraph - bindings = sgBinds bindGraph + let GraphAndRef expGraph expResult = expVal + newGraph = deleteBindings . makeEdges $ expGraph <> bindGraph + bindings = sgBinds bindGraph pure $ GraphAndRef newGraph (lookupReference bindings expResult) -- END evalGeneralLet -evalSelectorAndVal :: Show l => - EvalContext -> SelectorAndVal l -> State IDState (GraphAndRef, GraphAndRef) -evalSelectorAndVal c SelectorAndVal{svSelector=sel, svVal=val} - = (,) <$> evalExp c sel <*> evalExp c val +evalSelectorAndVal :: + Show l => + EvalContext -> + SelectorAndVal l -> + State IDState (GraphAndRef, GraphAndRef) +evalSelectorAndVal c SelectorAndVal {svSelector = sel, svVal = val} = + (,) <$> evalExp c sel <*> evalExp c val -evalMultiIf :: Show l => - EvalContext -> [SelectorAndVal l] -> State IDState (SyntaxGraph, NameAndPort) -evalMultiIf c selectorsAndVals = let - evaledRhss = unzip <$> mapM (evalSelectorAndVal c) selectorsAndVals - in - makeMultiIfGraph (length selectorsAndVals) - <$> - getUniqueName - <*> - fmap fst evaledRhss - <*> - fmap snd evaledRhss +evalMultiIf :: + Show l => + EvalContext -> + [SelectorAndVal l] -> + State IDState (SyntaxGraph, NameAndPort) +evalMultiIf c selectorsAndVals = + let evaledRhss = unzip <$> mapM (evalSelectorAndVal c) selectorsAndVals + in makeMultiIfGraph (length selectorsAndVals) + <$> getUniqueName + <*> fmap fst evaledRhss + <*> fmap snd evaledRhss -- BEGIN evalCase -- TODO patRhsAreConnected is sometimes incorrectly true if the pat is just a -- name -- returns (combined graph, pattern reference, rhs reference) -evalAlt :: Show l => - EvalContext - -> SimpAlt l - -> State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String) +evalAlt :: + Show l => + EvalContext -> + SimpAlt l -> + State IDState (Bool, SyntaxGraph, Reference, Reference, Maybe String) evalAlt c (SimpAlt pat rhs) = do ((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <- bindOrAltHelper c pat rhs - let - grWithEdges = makeEdges (rhsGraph <> patGraph) - lookedUpRhsRef = lookupReference (sgBinds grWithEdges) rhsRef - -- The pattern and rhs are conneted if makeEdges added extra edges, or if - -- the rhsRef refers to a source in the pattern. - patRhsAreConnected - = (rhsRef /= lookedUpRhsRef) - || ( length (sgEdges grWithEdges) - > - (length (sgEdges rhsGraph) + length (sgEdges patGraph))) - pure (patRhsAreConnected - , deleteBindings grWithEdges - , patRef - , lookedUpRhsRef - , mPatAsName) + let grWithEdges = makeEdges (rhsGraph <> patGraph) + lookedUpRhsRef = lookupReference (sgBinds grWithEdges) rhsRef + -- The pattern and rhs are conneted if makeEdges added extra edges, or if + -- the rhsRef refers to a source in the pattern. + patRhsAreConnected = + (rhsRef /= lookedUpRhsRef) + || ( length (sgEdges grWithEdges) + > (length (sgEdges rhsGraph) + length (sgEdges patGraph)) + ) + pure + ( patRhsAreConnected, + deleteBindings grWithEdges, + patRef, + lookedUpRhsRef, + mPatAsName + ) evalCaseHelper :: - Int - -> NodeName - -> [NodeName] - -> GraphAndRef - -> [(Bool, SyntaxGraph, Reference, Reference, Maybe String)] - -> (SyntaxGraph, NameAndPort) -evalCaseHelper numAlts caseIconName resultIconNames - (GraphAndRef expGraph expRef) evaledAlts - = result - where - (patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts - combindedAltGraph = mconcat altGraphs - caseNode = CaseOrMultiIfNode CaseTag numAlts - icons = [Named caseIconName (mkEmbedder caseNode)] - caseGraph = syntaxGraphFromNodes icons - expEdge = (expRef, nameAndPort caseIconName (inputPort caseNode)) - patEdges = zip patRefs $ map (nameAndPort caseIconName) casePatternPorts - rhsEdges = zip patRhsConnected $ zip rhsRefs - $ map (nameAndPort caseIconName) caseRhsPorts - (connectedRhss, unConnectedRhss) = partition fst rhsEdges + Int -> + NodeName -> + [NodeName] -> + GraphAndRef -> + [(Bool, SyntaxGraph, Reference, Reference, Maybe String)] -> + (SyntaxGraph, NameAndPort) +evalCaseHelper + numAlts + caseIconName + resultIconNames + (GraphAndRef expGraph expRef) + evaledAlts = + result + where + (patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts + combindedAltGraph = mconcat altGraphs + caseNode = CaseOrMultiIfNode CaseTag numAlts + icons = [Named caseIconName (mkEmbedder caseNode)] + caseGraph = syntaxGraphFromNodes icons + expEdge = (expRef, nameAndPort caseIconName (inputPort caseNode)) + patEdges = zip patRefs $ map (nameAndPort caseIconName) casePatternPorts + rhsEdges = + zip patRhsConnected $ + zip rhsRefs $ + map (nameAndPort caseIconName) caseRhsPorts + (connectedRhss, unConnectedRhss) = partition fst rhsEdges - makeCaseResult :: NodeName -> Reference -> SyntaxGraph - makeCaseResult resultIconName rhsRef = case rhsRef of - Left _ -> mempty - Right rhsPort -> syntaxGraphFromNodesEdges rhsNewIcons rhsNewEdges - where - rhsNewIcons = [Named resultIconName (mkEmbedder CaseResultNode)] - rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)] + makeCaseResult :: NodeName -> Reference -> SyntaxGraph + makeCaseResult resultIconName rhsRef = case rhsRef of + Left _ -> mempty + Right rhsPort -> syntaxGraphFromNodesEdges rhsNewIcons rhsNewEdges + where + rhsNewIcons = [Named resultIconName (mkEmbedder CaseResultNode)] + rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)] - caseResultGraphs = - mconcat - $ zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss) - filteredRhsEdges = fmap snd unConnectedRhss - patternEdgesGraph = edgesForRefPortList True patEdges - caseEdgeGraph = edgesForRefPortList False (expEdge : filteredRhsEdges) + caseResultGraphs = + mconcat $ + zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss) + filteredRhsEdges = fmap snd unConnectedRhss + patternEdgesGraph = edgesForRefPortList True patEdges + caseEdgeGraph = edgesForRefPortList False (expEdge : filteredRhsEdges) - bindGraph = makeAsBindGraph expRef asNames + bindGraph = makeAsBindGraph expRef asNames - finalGraph = deleteBindings $ makeEdges $ mconcat [bindGraph - , patternEdgesGraph - , caseResultGraphs - , expGraph - , caseEdgeGraph - , caseGraph - , combindedAltGraph] - result = (finalGraph, nameAndPort caseIconName (resultPort caseNode)) + finalGraph = + deleteBindings $ + makeEdges $ + mconcat + [ bindGraph, + patternEdgesGraph, + caseResultGraphs, + expGraph, + caseEdgeGraph, + caseGraph, + combindedAltGraph + ] + result = (finalGraph, nameAndPort caseIconName (resultPort caseNode)) - -evalCase :: Show l => - EvalContext -> SimpExp l -> [SimpAlt l] - -> State IDState (SyntaxGraph, NameAndPort) +evalCase :: + Show l => + EvalContext -> + SimpExp l -> + [SimpAlt l] -> + State IDState (SyntaxGraph, NameAndPort) evalCase c e alts = - let - numAlts = length alts - in - evalCaseHelper (length alts) - <$> - getUniqueName - <*> - replicateM numAlts getUniqueName - <*> - evalExp c e - <*> - mapM (evalAlt c) alts + let numAlts = length alts + in evalCaseHelper (length alts) + <$> getUniqueName + <*> replicateM numAlts getUniqueName + <*> evalExp c e + <*> mapM (evalAlt c) alts -- END evalCase @@ -524,44 +601,46 @@ asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName] -- TODO Refactor evalLambda -evalLambda :: Show l - => l - -> EvalContext - -> [SimpPat l] - -> SimpExp l - -> State IDState (SyntaxGraph, NameAndPort) +evalLambda :: + Show l => + l -> + EvalContext -> + [SimpPat l] -> + SimpExp l -> + State IDState (SyntaxGraph, NameAndPort) evalLambda _ context patterns expr = do lambdaName <- getUniqueName patternValsWithAsNames <- mapM evalPattern patterns - let - patternVals = fmap fst patternValsWithAsNames - patternStrings = concatMap namesInPattern patternValsWithAsNames - rhsContext = patternStrings <> context + let patternVals = fmap fst patternValsWithAsNames + patternStrings = concatMap namesInPattern patternValsWithAsNames + rhsContext = patternStrings <> context GraphAndRef rhsRawGraph rhsRef <- evalExp rhsContext expr - let - paramNames = fmap patternName patternValsWithAsNames - enclosedNodeNames = Set.fromList $ naName <$> sgNodes combinedGraph - lambdaNode = FunctionDefNode paramNames enclosedNodeNames - lambdaPorts = map (nameAndPort lambdaName) $ argumentPorts lambdaNode - patternGraph = mconcat $ fmap graphAndRefToGraph patternVals + let paramNames = fmap patternName patternValsWithAsNames + enclosedNodeNames = Set.fromList $ naName <$> sgNodes combinedGraph + lambdaNode = FunctionDefNode paramNames enclosedNodeNames + lambdaPorts = map (nameAndPort lambdaName) $ argumentPorts lambdaNode + patternGraph = mconcat $ fmap graphAndRefToGraph patternVals - (patternEdges, newBinds) = - partitionEithers $ zipWith makePatternEdges patternVals lambdaPorts + (patternEdges, newBinds) = + partitionEithers $ zipWith makePatternEdges patternVals lambdaPorts - icons = [Named lambdaName (mkEmbedder lambdaNode)] - returnPort = nameAndPort lambdaName (inputPort lambdaNode) - (newEdges, newSinks) = case rhsRef of - Left s -> (patternEdges, [SgSink s returnPort]) - Right rhsPort -> - (makeSimpleEdge (rhsPort, returnPort) : patternEdges, mempty) - finalGraph = SyntaxGraph icons newEdges newSinks newBinds mempty + icons = [Named lambdaName (mkEmbedder lambdaNode)] + returnPort = nameAndPort lambdaName (inputPort lambdaNode) + (newEdges, newSinks) = case rhsRef of + Left s -> (patternEdges, [SgSink s returnPort]) + Right rhsPort -> + (makeSimpleEdge (rhsPort, returnPort) : patternEdges, mempty) + finalGraph = SyntaxGraph icons newEdges newSinks newBinds mempty - asBindGraph = mconcat $ zipWith - asBindGraphZipper - (fmap snd patternValsWithAsNames) - lambdaPorts - combinedGraph = deleteBindings . makeEdges - $ (asBindGraph <> rhsRawGraph <> patternGraph <> finalGraph) + asBindGraph = + mconcat $ + zipWith + asBindGraphZipper + (fmap snd patternValsWithAsNames) + lambdaPorts + combinedGraph = + deleteBindings . makeEdges $ + (asBindGraph <> rhsRawGraph <> patternGraph <> finalGraph) pure (combinedGraph, nameAndPort lambdaName (resultPort lambdaNode)) where @@ -584,35 +663,43 @@ evalExp c x = case x of SeLambda l patterns e -> grNamePortToGrRef <$> evalLambda l c patterns e SeLet _ decls expr -> evalLet c decls expr SeCase _ expr alts -> grNamePortToGrRef <$> evalCase c expr alts - SeMultiIf _ selectorsAndVals - -> grNamePortToGrRef <$> evalMultiIf c selectorsAndVals + SeMultiIf _ selectorsAndVals -> + grNamePortToGrRef <$> evalMultiIf c selectorsAndVals -- BEGIN evalDecl -evalPatBind :: Show l => - l -> EvalContext -> SimpPat l -> SimpExp l -> State IDState SyntaxGraph +evalPatBind :: + Show l => + l -> + EvalContext -> + SimpPat l -> + SimpExp l -> + State IDState SyntaxGraph evalPatBind _ c pat e = do ((GraphAndRef patGraph patRef, mPatAsName), GraphAndRef rhsGraph rhsRef) <- bindOrAltHelper c pat e - let - (newEdges, newSinks, bindings) = case patRef of - (Left s) -> (mempty, mempty, [SgBind s rhsRef]) - (Right patPort) -> case rhsRef of - (Left rhsStr) -> (mempty, [SgSink rhsStr patPort], mempty) - (Right rhsPort) -> ([makeSimpleEdge (rhsPort, patPort)], mempty, mempty) - asBindGraph = makeAsBindGraph rhsRef [mPatAsName] - gr = asBindGraph <> SyntaxGraph mempty newEdges newSinks bindings mempty + let (newEdges, newSinks, bindings) = case patRef of + (Left s) -> (mempty, mempty, [SgBind s rhsRef]) + (Right patPort) -> case rhsRef of + (Left rhsStr) -> (mempty, [SgSink rhsStr patPort], mempty) + (Right rhsPort) -> ([makeSimpleEdge (rhsPort, patPort)], mempty, mempty) + asBindGraph = makeAsBindGraph rhsRef [mPatAsName] + gr = asBindGraph <> SyntaxGraph mempty newEdges newSinks bindings mempty pure . makeEdges $ (gr <> rhsGraph <> patGraph) -- Pretty printing the entire type sig results in extra whitespace in the middle -- TODO May want to trim whitespace from (prettyPrint typeForNames) -evalTypeSig :: Show l => - [Exts.Name l] -> Exts.Type l - -> State IDState (SyntaxGraph, NameAndPort) -evalTypeSig names typeForNames = makeBox - (intercalate "," (fmap prettyPrintWithoutNewlines names) - ++ " :: " - ++ prettyPrintWithoutNewlines typeForNames) +evalTypeSig :: + Show l => + [Exts.Name l] -> + Exts.Type l -> + State IDState (SyntaxGraph, NameAndPort) +evalTypeSig names typeForNames = + makeBox + ( intercalate "," (fmap prettyPrintWithoutNewlines names) + ++ " :: " + ++ prettyPrintWithoutNewlines typeForNames + ) where -- TODO Make custom version of prettyPrint for type signitures. -- Use (unwords . words) to convert consecutive whitspace characters to one @@ -631,50 +718,54 @@ evalDecl c d = case d of showTopLevelBinds :: SyntaxGraph -> State IDState SyntaxGraph showTopLevelBinds gr = do - let - binds = sgBinds gr - addBind (SgBind _ (Left _)) = pure mempty - addBind (SgBind patName (Right port)) = do - uniquePatName <- getUniqueName - let - icons = [Named uniquePatName $ mkEmbedder (BindNameNode patName)] - edges = [makeSimpleEdge (port, justName uniquePatName)] - edgeGraph = syntaxGraphFromNodesEdges icons edges - pure edgeGraph + let binds = sgBinds gr + addBind (SgBind _ (Left _)) = pure mempty + addBind (SgBind patName (Right port)) = do + uniquePatName <- getUniqueName + let icons = [Named uniquePatName $ mkEmbedder (BindNameNode patName)] + edges = [makeSimpleEdge (port, justName uniquePatName)] + edgeGraph = syntaxGraphFromNodesEdges icons edges + pure edgeGraph newGraph <- mconcat <$> mapM addBind binds pure $ newGraph <> gr translateDeclToSyntaxGraph :: Show l => SimpDecl l -> SyntaxGraph -translateDeclToSyntaxGraph d = graph where - evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds - graph = evalState evaluatedDecl initialIdState +translateDeclToSyntaxGraph d = graph + where + evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds + graph = evalState evaluatedDecl initialIdState -- | Convert a single function declaration into a SyntaxGraph translateStringToSyntaxGraph :: String -> SyntaxGraph translateStringToSyntaxGraph = translateDeclToSyntaxGraph . stringToSimpDecl syntaxGraphToCollapsedGraph :: SyntaxGraph -> AnnotatedGraph FGR.Gr -syntaxGraphToCollapsedGraph - = collapseAnnotatedGraph . annotateGraph . syntaxGraphToFglGraph - -- = annotateGraph . syntaxGraphToFglGraph +syntaxGraphToCollapsedGraph = + collapseAnnotatedGraph . annotateGraph . syntaxGraphToFglGraph + +-- = annotateGraph . syntaxGraphToFglGraph translateDeclToCollapsedGraph :: Show l => Exts.Decl l -> AnnotatedGraph FGR.Gr -translateDeclToCollapsedGraph - = syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph . hsDeclToSimpDecl +translateDeclToCollapsedGraph = + syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph . hsDeclToSimpDecl -- Profiling: At one point, this was about 1.5% of total time. translateStringToCollapsedGraphAndDecl :: String -> (AnnotatedGraph FGR.Gr, Exts.Decl Exts.SrcSpanInfo) -translateStringToCollapsedGraphAndDecl s = (drawing, decl) where - decl = customParseDecl s -- :: ParseResult Module - drawing = translateDeclToCollapsedGraph decl +translateStringToCollapsedGraphAndDecl s = (drawing, decl) + where + decl = customParseDecl s -- :: ParseResult Module + drawing = translateDeclToCollapsedGraph decl -translateModuleToCollapsedGraphs :: Show l => - Exts.Module l -> [AnnotatedGraph FGR.Gr] -translateModuleToCollapsedGraphs (Exts.Module _ _ _ _ decls) - = fmap translateDeclToCollapsedGraph decls -translateModuleToCollapsedGraphs moduleSyntax - = error $ "Unsupported syntax in translateModuleToCollapsedGraphs: " - <> show moduleSyntax +translateModuleToCollapsedGraphs :: + Show l => + Exts.Module l -> + [AnnotatedGraph FGR.Gr] +translateModuleToCollapsedGraphs (Exts.Module _ _ _ _ decls) = + fmap translateDeclToCollapsedGraph decls +translateModuleToCollapsedGraphs moduleSyntax = + error $ + "Unsupported syntax in translateModuleToCollapsedGraphs: " + <> show moduleSyntax -- END Exported functions diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs index 1e96bbe..378ef1b 100644 --- a/app/TranslateCore.hs +++ b/app/TranslateCore.hs @@ -1,51 +1,74 @@ -module TranslateCore( - Reference, - SyntaxGraph(..), - EvalContext, - GraphAndRef(..), - SgSink(..), - SgBind(..), - syntaxGraphFromNodes, - syntaxGraphFromNodesEdges, - bindsToSyntaxGraph, - graphAndRefToGraph, - getUniqueName, - getUniqueString, - edgesForRefPortList, - combineExpressions, - makeApplyGraph, - makeMultiIfGraph, - namesInPattern, - lookupReference, - deleteBindings, - makeEdges, - makeBox, - nTupleString, - nTupleSectionString, - nListString, - syntaxGraphToFglGraph, - nodeToIcon, - initialIdState -) where +-- This file is formatted with Ormolu +module TranslateCore + ( Reference, + SyntaxGraph (..), + EvalContext, + GraphAndRef (..), + SgSink (..), + SgBind (..), + syntaxGraphFromNodes, + syntaxGraphFromNodesEdges, + bindsToSyntaxGraph, + graphAndRefToGraph, + getUniqueName, + getUniqueString, + edgesForRefPortList, + combineExpressions, + makeApplyGraph, + makeMultiIfGraph, + namesInPattern, + lookupReference, + deleteBindings, + makeEdges, + makeBox, + nTupleString, + nTupleSectionString, + nListString, + syntaxGraphToFglGraph, + nodeToIcon, + initialIdState, + ) +where -import Control.Monad.State(State, state) -import Data.Either(partitionEithers) +import Control.Monad.State (State, state) +import Data.Either (partitionEithers) import qualified Data.Graph.Inductive.Graph as ING import qualified Data.Graph.Inductive.PatriciaTree as FGR -import Data.List(find) +import Data.List (find) import qualified Data.Map as Map -import Data.Semigroup(Semigroup, (<>)) import qualified Data.Set as Set - -import Icons(inputPort, resultPort, argumentPorts, multiIfRhsPorts - , multiIfBoolPorts) -import Types(Labeled(..), Icon(..), SyntaxNode(..), Edge(..), EdgeOption(..) - , NameAndPort(..), IDState, SgNamedNode, NodeName(..), Port - , LikeApplyFlavor(..), CaseOrMultiIfTag(..), IDState(..) - , Embedder(..), mkEmbedder, Named(..) - , EmbedderSyntaxNode) -import Util(nameAndPort, makeSimpleEdge, justName, maybeBoolToBool - , nodeNameToInt) +import Icons + ( argumentPorts, + inputPort, + multiIfBoolPorts, + multiIfRhsPorts, + resultPort, + ) +import Types + ( CaseOrMultiIfTag (..), + Edge (..), + EdgeOption (..), + Embedder (..), + EmbedderSyntaxNode, + IDState (..), + Icon (..), + Labeled (..), + LikeApplyFlavor (..), + NameAndPort (..), + Named (..), + NodeName (..), + Port, + SgNamedNode, + SyntaxNode (..), + mkEmbedder, + ) +import Util + ( justName, + makeSimpleEdge, + maybeBoolToBool, + nameAndPort, + nodeNameToInt, + ) {-# ANN module "HLint: ignore Use list comprehension" #-} @@ -63,28 +86,30 @@ data SgBind = SgBind String Reference deriving (Eq, Show, Ord) data SgSink = SgSink String NameAndPort deriving (Eq, Ord, Show) -- TODO Replace lists with sets + -- | A SyntaxGraph is an abstract representation of Haskell syntax. SyntaxGraphs -- are generated from the Haskell syntax tree and are used to generate Drawings. -data SyntaxGraph = SyntaxGraph { - sgNodes :: [SgNamedNode], - sgEdges :: [Edge], - sgSinks :: [SgSink], - sgBinds :: [SgBind], - -- sgEmbedMap keeps track of nodes embedded in other nodes. If (child, parent) - -- is in the Map, then child is embedded inside parent. - sgEmbedMap :: Map.Map NodeName NodeName - } deriving (Show, Eq) +data SyntaxGraph = SyntaxGraph + { sgNodes :: [SgNamedNode], + sgEdges :: [Edge], + sgSinks :: [SgSink], + sgBinds :: [SgBind], + -- sgEmbedMap keeps track of nodes embedded in other nodes. If (child, parent) + -- is in the Map, then child is embedded inside parent. + sgEmbedMap :: Map.Map NodeName NodeName + } + deriving (Show, Eq) instance Semigroup SyntaxGraph where (<>) (SyntaxGraph icons1 edges1 sinks1 sources1 map1) - (SyntaxGraph icons2 edges2 sinks2 sources2 map2) - = SyntaxGraph - (icons1 <> icons2) - (edges1 <> edges2) - (sinks1 <> sinks2) - (sources1 <> sources2) - (map1 <> map2) + (SyntaxGraph icons2 edges2 sinks2 sources2 map2) = + SyntaxGraph + (icons1 <> icons2) + (edges1 <> edges2) + (sinks1 <> sinks2) + (sources1 <> sources2) + (map1 <> map2) instance Monoid SyntaxGraph where mempty = SyntaxGraph mempty mempty mempty mempty mempty @@ -104,8 +129,8 @@ syntaxGraphFromNodes :: [SgNamedNode] -> SyntaxGraph syntaxGraphFromNodes icons = SyntaxGraph icons mempty mempty mempty mempty syntaxGraphFromNodesEdges :: [SgNamedNode] -> [Edge] -> SyntaxGraph -syntaxGraphFromNodesEdges icons edges - = SyntaxGraph icons edges mempty mempty mempty +syntaxGraphFromNodesEdges icons edges = + SyntaxGraph icons edges mempty mempty mempty bindsToSyntaxGraph :: [SgBind] -> SyntaxGraph bindsToSyntaxGraph binds = SyntaxGraph mempty mempty mempty binds mempty @@ -127,81 +152,89 @@ initialIdState :: IDState initialIdState = IDState 0 getId :: State IDState Int -getId = state incrementer where - incrementer (IDState x) = (x, IDState checkedIncrement) where - xPlusOne = x + 1 - checkedIncrement = if xPlusOne > x - then xPlusOne - else error "getId: the ID state has overflowed." +getId = state incrementer + where + incrementer (IDState x) = (x, IDState checkedIncrement) + where + xPlusOne = x + 1 + checkedIncrement = + if xPlusOne > x + then xPlusOne + else error "getId: the ID state has overflowed." getUniqueName :: State IDState NodeName getUniqueName = fmap NodeName getId -- TODO Should getUniqueString prepend an illegal character? getUniqueString :: String -> State IDState String -getUniqueString base = fmap ((base ++). show) getId +getUniqueString base = fmap ((base ++) . show) getId -- END IDState -- TODO: Refactor with combineExpressions edgesForRefPortList :: Bool -> [(Reference, NameAndPort)] -> SyntaxGraph -edgesForRefPortList inPattern portExpPairs - = mconcat $ fmap makeGraph portExpPairs +edgesForRefPortList inPattern portExpPairs = + mconcat $ fmap makeGraph portExpPairs where edgeOpts = if inPattern then [EdgeInPattern] else [] makeGraph (ref, port) = case ref of - Left str -> if inPattern - then bindsToSyntaxGraph [SgBind str (Right port)] - else sinksToSyntaxGraph [SgSink str port] + Left str -> + if inPattern + then bindsToSyntaxGraph [SgBind str (Right port)] + else sinksToSyntaxGraph [SgSink str port] Right resPort -> edgesToSyntaxGraph [Edge edgeOpts connection] where - connection = if inPattern - -- If in a pattern, then the port on the case icon is - -- the data source. - then (port, resPort) - else (resPort, port) + connection = + if inPattern + then -- If in a pattern, then the port on the case icon is + -- the data source. + (port, resPort) + else (resPort, port) combineExpressions :: Bool -> [(GraphAndRef, NameAndPort)] -> SyntaxGraph -combineExpressions inPattern portExpPairs - = mconcat $ fmap makeGraph portExpPairs +combineExpressions inPattern portExpPairs = + mconcat $ fmap makeGraph portExpPairs where edgeOpts = if inPattern then [EdgeInPattern] else [] - makeGraph (GraphAndRef graph ref, port) = graph <> case ref of - Left str -> if inPattern - then bindsToSyntaxGraph [SgBind str (Right port)] - else sinksToSyntaxGraph [SgSink str port] - Right resPort -> edgesToSyntaxGraph [Edge edgeOpts (resPort, port)] + makeGraph (GraphAndRef graph ref, port) = + graph <> case ref of + Left str -> + if inPattern + then bindsToSyntaxGraph [SgBind str (Right port)] + else sinksToSyntaxGraph [SgSink str port] + Right resPort -> edgesToSyntaxGraph [Edge edgeOpts (resPort, port)] makeApplyGraph :: - Int - -> LikeApplyFlavor - -> Bool - -> NodeName - -> GraphAndRef - -> [GraphAndRef] - -> (SyntaxGraph, NameAndPort) -makeApplyGraph numArgs applyFlavor inPattern applyIconName funVal argVals - = (newGraph <> combinedGraph - , nameAndPort applyIconName (resultPort applyNode) - ) + Int -> + LikeApplyFlavor -> + Bool -> + NodeName -> + GraphAndRef -> + [GraphAndRef] -> + (SyntaxGraph, NameAndPort) +makeApplyGraph numArgs applyFlavor inPattern applyIconName funVal argVals = + ( newGraph <> combinedGraph, + nameAndPort applyIconName (resultPort applyNode) + ) where applyNode = ApplyNode applyFlavor numArgs - argumentNamePorts - = map (nameAndPort applyIconName) (argumentPorts applyNode) + argumentNamePorts = + map (nameAndPort applyIconName) (argumentPorts applyNode) functionPort = nameAndPort applyIconName (inputPort applyNode) - combinedGraph = combineExpressions inPattern - $ zip (funVal:argVals) (functionPort:argumentNamePorts) + combinedGraph = + combineExpressions inPattern $ + zip (funVal : argVals) (functionPort : argumentNamePorts) icons = [Named applyIconName (mkEmbedder applyNode)] newGraph = syntaxGraphFromNodes icons makeMultiIfGraph :: - Int - -> NodeName - -> [GraphAndRef] - -> [GraphAndRef] - -> (SyntaxGraph, NameAndPort) -makeMultiIfGraph numPairs multiIfName bools exps - = (newGraph, nameAndPort multiIfName (resultPort multiIfNode)) + Int -> + NodeName -> + [GraphAndRef] -> + [GraphAndRef] -> + (SyntaxGraph, NameAndPort) +makeMultiIfGraph numPairs multiIfName bools exps = + (newGraph, nameAndPort multiIfName (resultPort multiIfNode)) where multiIfNode = CaseOrMultiIfNode MultiIfTag numPairs expsWithPorts = zip exps $ map (nameAndPort multiIfName) multiIfRhsPorts @@ -226,14 +259,15 @@ namesInPattern (graphAndRef, mName) = case mName of -- TODO: Might want to present some indication if there is a reference cycle. lookupReference :: [SgBind] -> 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 (fmap sgBindToTuple 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 +lookupReference bindings ref@(Left originalS) = lookupHelper ref + where + lookupHelper newRef@(Right _) = newRef + lookupHelper newRef@(Left s) = case lookup s (fmap sgBindToTuple 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 :: SyntaxGraph -> SyntaxGraph deleteBindings (SyntaxGraph a b c _ e) = SyntaxGraph a b c mempty e @@ -242,23 +276,24 @@ makeEdgesCore :: [SgSink] -> [SgBind] -> ([SgSink], [Edge]) makeEdgesCore sinks bindings = partitionEithers $ fmap renameOrMakeEdge sinks where renameOrMakeEdge :: SgSink -> Either SgSink Edge - renameOrMakeEdge orig@(SgSink s destPort) - = case lookup s (fmap sgBindToTuple bindings) of - Just ref -> case lookupReference bindings ref of - Right sourcePort -> Right $ makeSimpleEdge (sourcePort, destPort) - Left newStr -> Left $ SgSink newStr destPort - Nothing -> Left orig + renameOrMakeEdge orig@(SgSink s destPort) = + case lookup s (fmap sgBindToTuple bindings) of + Just ref -> case lookupReference bindings ref of + Right sourcePort -> Right $ makeSimpleEdge (sourcePort, destPort) + Left newStr -> Left $ SgSink newStr destPort + Nothing -> Left orig makeEdges :: SyntaxGraph -> SyntaxGraph -makeEdges (SyntaxGraph icons edges sinks bindings eMap) = newGraph where - (newSinks, newEdges) = makeEdgesCore sinks bindings - newGraph = SyntaxGraph icons (newEdges <> edges) newSinks bindings eMap +makeEdges (SyntaxGraph icons edges sinks bindings eMap) = newGraph + where + (newSinks, newEdges) = makeEdgesCore sinks bindings + newGraph = SyntaxGraph icons (newEdges <> edges) newSinks bindings eMap makeBox :: String -> State IDState (SyntaxGraph, NameAndPort) makeBox str = do name <- getUniqueName - let graph - = syntaxGraphFromNodes [Named name (mkEmbedder (LiteralNode str))] + let graph = + syntaxGraphFromNodes [Named name (mkEmbedder (LiteralNode str))] pure (graph, justName name) nTupleString :: Int -> String @@ -266,15 +301,16 @@ nTupleString n = '(' : replicate (n -1) ',' ++ ")" -- TODO Unit tests for this nTupleSectionString :: [Bool] -> String -nTupleSectionString bools = '(' : (commas ++ ")") where - commas = case concatMap trueToUnderscore bools of - [] -> [] - (_:xs) -> xs - - trueToUnderscore x = if x - then ",_" - else "," +nTupleSectionString bools = '(' : (commas ++ ")") + where + commas = case concatMap trueToUnderscore bools of + [] -> [] + (_ : xs) -> xs + trueToUnderscore x = + if x + then ",_" + else "," nListString :: Int -> String -- TODO: Use something better than [_] @@ -283,35 +319,38 @@ nListString n = '[' : replicate (n -1) ',' ++ "]" nodeToIcon :: EmbedderSyntaxNode -> Icon nodeToIcon (Embedder embeddedNodes node) = case node of - (ApplyNode flavor x) - -> nestedApplySyntaxNodeToIcon flavor x embeddedNodes - (PatternApplyNode s children) - -> nestedPatternNodeToIcon s children + (ApplyNode flavor x) -> + nestedApplySyntaxNodeToIcon flavor x embeddedNodes + (PatternApplyNode s children) -> + nestedPatternNodeToIcon s children (NameNode s) -> TextBoxIcon s (BindNameNode s) -> BindTextBoxIcon s (LiteralNode s) -> TextBoxIcon s - (FunctionDefNode labels bodyNodes) - -> nestedLambdaToIcon labels embeddedNodes bodyNodes + (FunctionDefNode labels bodyNodes) -> + nestedLambdaToIcon labels embeddedNodes bodyNodes CaseResultNode -> CaseResultIcon - (CaseOrMultiIfNode tag x) - -> nestedCaseOrMultiIfNodeToIcon tag x embeddedNodes + (CaseOrMultiIfNode tag x) -> + nestedCaseOrMultiIfNodeToIcon tag x embeddedNodes -- | Helper for makeArg findArg :: Port -> (NodeName, Edge) -> Bool -findArg currentPort - (argName - , Edge _ (NameAndPort fromName fromPort, NameAndPort toName toPort)) - | argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort - | argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort - | otherwise = False -- This case should never happen +findArg + currentPort + ( argName, + Edge _ (NameAndPort fromName fromPort, NameAndPort toName toPort) + ) + | argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort + | argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort + | otherwise = False -- This case should never happen makeArg :: Set.Set (NodeName, Edge) -> Port -> Maybe NodeName makeArg args port = fst <$> find (findArg port) args -nestedApplySyntaxNodeToIcon :: LikeApplyFlavor - -> Int - -> Set.Set (NodeName, Edge) - -> Icon +nestedApplySyntaxNodeToIcon :: + LikeApplyFlavor -> + Int -> + Set.Set (NodeName, Edge) -> + Icon nestedApplySyntaxNodeToIcon flavor numArgs args = NestedApply flavor headIcon argList where @@ -320,10 +359,11 @@ nestedApplySyntaxNodeToIcon flavor numArgs args = headIcon = makeArg args (inputPort dummyNode) argList = fmap (makeArg args) argPorts -nestedLambdaToIcon :: [String] -- labels - -> Set.Set (NodeName, Edge) -- embedded icons - -> Set.Set NodeName -- body nodes - -> Icon +nestedLambdaToIcon :: + [String] -> -- labels + Set.Set (NodeName, Edge) -> -- embedded icons + Set.Set NodeName -> -- body nodes + Icon nestedLambdaToIcon labels embeddedNodes = LambdaIcon labels embeddedBodyNode where @@ -331,10 +371,10 @@ nestedLambdaToIcon labels embeddedNodes = embeddedBodyNode = makeArg embeddedNodes (inputPort dummyNode) nestedCaseOrMultiIfNodeToIcon :: - CaseOrMultiIfTag - -> Int - -> Set.Set (NodeName, Edge) - -> Icon + CaseOrMultiIfTag -> + Int -> + Set.Set (NodeName, Edge) -> + Icon nestedCaseOrMultiIfNodeToIcon tag numArgs args = case tag of CaseTag -> NestedCaseIcon argList MultiIfTag -> NestedMultiIfIcon argList @@ -344,29 +384,38 @@ nestedCaseOrMultiIfNodeToIcon tag numArgs args = case tag of argList = fmap (makeArg args) (inputPort dummyNode : argPorts) nestedPatternNodeToIcon :: String -> [Labeled (Maybe SgNamedNode)] -> Icon -nestedPatternNodeToIcon str children = NestedPApp - (pure (Just (Named (NodeName (-1)) (TextBoxIcon str)))) - -- Why so many fmaps? - ( (fmap . fmap . fmap . fmap) nodeToIcon children) +nestedPatternNodeToIcon str children = + NestedPApp + (pure (Just (Named (NodeName (-1)) (TextBoxIcon str)))) + -- Why so many fmaps? + ((fmap . fmap . fmap . fmap) nodeToIcon children) makeLNode :: SgNamedNode -> ING.LNode SgNamedNode makeLNode namedNode@(Named (NodeName name) _) = (name, namedNode) lookupInEmbeddingMap :: NodeName -> Map.Map NodeName NodeName -> NodeName -lookupInEmbeddingMap origName eMap = lookupHelper origName where - lookupHelper name = case Map.lookup name eMap of - Nothing -> name - Just parent -> if parent == origName - then error $ "lookupInEmbeddingMap: Found cycle. Node = " - ++ show origName ++ "\nEmbedding Map = " ++ show eMap - else lookupHelper parent +lookupInEmbeddingMap origName eMap = lookupHelper origName + where + lookupHelper name = case Map.lookup name eMap of + Nothing -> name + Just parent -> + if parent == origName + then + error $ + "lookupInEmbeddingMap: Found cycle. Node = " + ++ show origName + ++ "\nEmbedding Map = " + ++ show eMap + else lookupHelper parent syntaxGraphToFglGraph :: SyntaxGraph -> FGR.Gr SgNamedNode Edge syntaxGraphToFglGraph (SyntaxGraph nodes edges _ _ eMap) = - ING.mkGraph (fmap makeLNode nodes) labeledEdges where + ING.mkGraph (fmap makeLNode nodes) labeledEdges + where labeledEdges = fmap makeLabeledEdge edges makeLabeledEdge e@(Edge _ (NameAndPort name1 _, NameAndPort name2 _)) = - (nodeNameToInt $ lookupInEmbeddingMap name1 eMap - , nodeNameToInt $ lookupInEmbeddingMap name2 eMap - , e) + ( nodeNameToInt $ lookupInEmbeddingMap name1 eMap, + nodeNameToInt $ lookupInEmbeddingMap name2 eMap, + e + ) diff --git a/app/Types.hs b/app/Types.hs index 3987155..d5f0846 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -1,47 +1,50 @@ -{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, ConstraintKinds #-} +-- This file is formatted with Ormolu +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} -module Types ( - Named(..), - NamedIcon, - IconInfo, - Icon(..), - SyntaxNode(..), - NodeName(..), - Port(..), - NameAndPort(..), - Connection, - Edge(..), - EdgeOption(..), - Drawing(..), - IDState(..), - SpecialQDiagram, - SpecialBackend, - SpecialNum, - SgNamedNode, - IngSyntaxGraph, - LikeApplyFlavor(..), - CaseOrMultiIfTag(..), - Labeled(..), - EmbedDirection(..), - EmbedInfo(..), - AnnotatedGraph, - NodeInfo(..), - Embedder(..), - mkEmbedder, - EmbedderSyntaxNode, -) where +module Types + ( Named (..), + NamedIcon, + IconInfo, + Icon (..), + SyntaxNode (..), + NodeName (..), + Port (..), + NameAndPort (..), + Connection, + Edge (..), + EdgeOption (..), + Drawing (..), + IDState (..), + SpecialQDiagram, + SpecialBackend, + SpecialNum, + SgNamedNode, + IngSyntaxGraph, + LikeApplyFlavor (..), + CaseOrMultiIfTag (..), + Labeled (..), + EmbedDirection (..), + EmbedInfo (..), + AnnotatedGraph, + NodeInfo (..), + Embedder (..), + mkEmbedder, + EmbedderSyntaxNode, + ) +where -import Diagrams.Prelude(QDiagram, V2, Any, Renderable, Path, IsName) -import Diagrams.TwoD.Text(Text) - -import Control.Applicative(Applicative(..)) import qualified Data.Graph.Inductive as ING import qualified Data.IntMap as IM -import Data.Set(Set, empty) -import Data.Typeable(Typeable) +import Data.Set (Set, empty) +import Data.Typeable (Typeable) +import Diagrams.Prelude (Any, IsName, Path, QDiagram, Renderable, V2) +import Diagrams.TwoD.Text (Text) newtype NodeName = NodeName Int deriving (Typeable, Eq, Ord, Show) + instance IsName NodeName data Named a = Named {naName :: NodeName, naVal :: a} @@ -63,23 +66,24 @@ type IconInfo = IM.IntMap Icon -- | A datatype that represents an icon. -- The TextBoxIcon's data is the text that appears in the text box. -data Icon = TextBoxIcon String +data Icon + = TextBoxIcon String | MultiIfIcon - Int -- Number of alternatives + Int -- Number of alternatives | LambdaIcon - [String] -- Parameter labels - (Maybe NodeName) -- Function body expression - (Set NodeName) -- Nodes inside the lambda + [String] -- Parameter labels + (Maybe NodeName) -- Function body expression + (Set NodeName) -- Nodes inside the lambda | CaseIcon Int | CaseResultIcon | BindTextBoxIcon String | NestedApply - LikeApplyFlavor -- apply or compose - (Maybe NodeName) -- The function for apply, or the argument for compose - [Maybe NodeName] -- list of arguments or functions + LikeApplyFlavor -- apply or compose + (Maybe NodeName) -- The function for apply, or the argument for compose + [Maybe NodeName] -- list of arguments or functions | NestedPApp - (Labeled (Maybe NamedIcon)) -- Data constructor - [Labeled (Maybe NamedIcon)] -- Arguments + (Labeled (Maybe NamedIcon)) -- Data constructor + [Labeled (Maybe NamedIcon)] -- Arguments | NestedCaseIcon [Maybe NodeName] | NestedMultiIfIcon [Maybe NodeName] deriving (Show, Eq, Ord) @@ -90,9 +94,10 @@ data LikeApplyFlavor = ApplyNodeFlavor | ComposeNodeFlavor data CaseOrMultiIfTag = CaseTag | MultiIfTag deriving (Show, Eq, Ord) -- TODO The full edge does not need to be included, just the port. -data Embedder a = Embedder { - emEmbedded :: Set (NodeName, Edge) -- ^ Set of embedded nodes - , emNode :: a +data Embedder a = Embedder + { -- | Set of embedded nodes + emEmbedded :: Set (NodeName, Edge), + emNode :: a } deriving (Show, Eq, Ord, Functor) @@ -104,22 +109,23 @@ type EmbedderSyntaxNode = Embedder SyntaxNode type SgNamedNode = Named EmbedderSyntaxNode -- TODO remove Ints from SyntaxNode data constructors. -data SyntaxNode = - -- Function application, composition, and applying to a composition - -- The list of nodes is unordered (replace with a map?) - ApplyNode LikeApplyFlavor Int +data SyntaxNode + = -- Function application, composition, and applying to a composition + -- The list of nodes is unordered (replace with a map?) + ApplyNode LikeApplyFlavor Int | PatternApplyNode String [Labeled (Maybe SgNamedNode)] | NameNode String -- Identifiers or symbols | BindNameNode String | LiteralNode String -- Literal values like the string "Hello World" - | FunctionDefNode -- Function definition (ie. lambda expression) - [String] -- Parameter labels - (Set NodeName) -- Nodes inside the lambda + | FunctionDefNode -- Function definition (ie. lambda expression) + [String] -- Parameter labels + (Set NodeName) -- Nodes inside the lambda | CaseResultNode -- TODO remove caseResultNode | CaseOrMultiIfNode CaseOrMultiIfTag Int deriving (Show, Eq, Ord) newtype Port = Port Int deriving (Typeable, Eq, Ord, Show) + instance IsName Port data NameAndPort = NameAndPort NodeName (Maybe Port) deriving (Show, Eq, Ord) @@ -131,8 +137,10 @@ data EdgeOption = EdgeInPattern deriving (Show, Eq, Ord) -- | An Edge has an name of the source icon, and its optional port number, -- and the name of the destination icon, and its optional port number. -data Edge = Edge { edgeOptions :: [EdgeOption] - , edgeConnection :: Connection} +data Edge = Edge + { edgeOptions :: [EdgeOption], + edgeConnection :: Connection + } deriving (Show, Eq, Ord) -- | A drawing is a map from names to Icons, a list of edges, @@ -143,19 +151,19 @@ data Drawing = Drawing [NamedIcon] [Edge] deriving (Show, Eq) -- unique id. newtype IDState = IDState Int deriving (Eq, Show) -type SpecialNum n - = (Floating n, RealFrac n, RealFloat n, Typeable n, Show n, Enum n) +type SpecialNum n = + (Floating n, RealFrac n, RealFloat n, Typeable n, Show n, Enum n) -- Note that SpecialBackend is a constraint synonym, not a type synonym. -type SpecialBackend b n - = (SpecialNum n, Renderable (Path V2 n) b, Renderable (Text n) b) +type SpecialBackend b n = + (SpecialNum n, Renderable (Path V2 n) b, Renderable (Text n) b) type SpecialQDiagram b n = QDiagram b V2 n Any type IngSyntaxGraph gr = gr SgNamedNode Edge -data EmbedDirection = - EdEmbedFrom -- The tail +data EmbedDirection + = EdEmbedFrom -- The tail | EdEmbedTo -- The head deriving (Show, Eq) @@ -165,8 +173,8 @@ data EmbedInfo a = EmbedInfo {eiEmbedDir :: Maybe EmbedDirection, eiVal :: a} type AnnotatedGraph gr = gr (NodeInfo SgNamedNode) (EmbedInfo Edge) -data NodeInfo a = NodeInfo { - niParent :: Maybe ING.Node - , niVal :: a +data NodeInfo a = NodeInfo + { niParent :: Maybe ING.Node, + niVal :: a } deriving (Show, Eq, Functor, Ord) diff --git a/stack.yaml b/stack.yaml index dcd5c42..d21260f 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-16.18 +resolver: lts-16.27 # Local packages, usually specified by relative directory name packages: