mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-17 10:50:24 +03:00
Add pattern names to PApp.
This commit is contained in:
parent
9702cabc29
commit
4b0d32d034
1
.gitignore
vendored
1
.gitignore
vendored
@ -16,6 +16,7 @@ cabal.sandbox.config
|
|||||||
.stack-work/
|
.stack-work/
|
||||||
*.*~
|
*.*~
|
||||||
*~
|
*~
|
||||||
|
*#
|
||||||
|
|
||||||
# You can put SVG images created by Glance in /images
|
# You can put SVG images created by Glance in /images
|
||||||
/images
|
/images
|
||||||
|
@ -44,7 +44,7 @@ colorOnBlackScheme = ColorStyle {
|
|||||||
patternC = lightMagenta,
|
patternC = lightMagenta,
|
||||||
patternTextC = cyan,
|
patternTextC = cyan,
|
||||||
bindTextBoxC = reddishOrange,
|
bindTextBoxC = reddishOrange,
|
||||||
bindTextBoxTextC = lime,
|
bindTextBoxTextC = lightGreen,
|
||||||
edgeListC = [white, lime, reddishOrange, lightPurple, yellow, lightBlue],
|
edgeListC = [white, lime, reddishOrange, lightPurple, yellow, lightBlue],
|
||||||
nestingC = cycle [red, reddishOrange, yellow]
|
nestingC = cycle [red, reddishOrange, yellow]
|
||||||
}
|
}
|
||||||
@ -56,6 +56,7 @@ colorOnBlackScheme = ColorStyle {
|
|||||||
--lightBlue = sRGB24 126 127 255
|
--lightBlue = sRGB24 126 127 255
|
||||||
lightBlue = sRGB24 35 156 255
|
lightBlue = sRGB24 35 156 255
|
||||||
lightPurple = sRGB24 208 137 255
|
lightPurple = sRGB24 208 137 255
|
||||||
|
lightGreen = sRGB24 180 255 145
|
||||||
|
|
||||||
|
|
||||||
whiteOnBlackScheme :: (Floating a, Ord a) => ColorStyle a
|
whiteOnBlackScheme :: (Floating a, Ord a) => ColorStyle a
|
||||||
|
60
app/Icons.hs
60
app/Icons.hs
@ -23,10 +23,10 @@ module Icons
|
|||||||
|
|
||||||
import Diagrams.Prelude hiding ((&), (#), Name)
|
import Diagrams.Prelude hiding ((&), (#), Name)
|
||||||
|
|
||||||
|
import qualified Control.Arrow as Arrow
|
||||||
|
import Data.Either(partitionEithers)
|
||||||
import Data.List(find)
|
import Data.List(find)
|
||||||
import Data.Maybe(catMaybes, listToMaybe, isJust, fromJust)
|
import Data.Maybe(catMaybes, listToMaybe, isJust, fromJust)
|
||||||
import Data.Either(partitionEithers)
|
|
||||||
import qualified Control.Arrow as Arrow
|
|
||||||
|
|
||||||
import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum, NodeName, Port(..), LikeApplyFlavor(..),
|
import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum, NodeName, Port(..), LikeApplyFlavor(..),
|
||||||
SyntaxNode(..))
|
SyntaxNode(..))
|
||||||
@ -94,7 +94,7 @@ guardPortAngles (Port port) = case port of
|
|||||||
findNestedIcon :: NodeName -> Icon -> Maybe Icon
|
findNestedIcon :: NodeName -> Icon -> Maybe Icon
|
||||||
findNestedIcon name icon = case icon of
|
findNestedIcon name icon = case icon of
|
||||||
NestedApply _ args -> snd <$> findIcon name args
|
NestedApply _ args -> snd <$> findIcon name args
|
||||||
NestedPApp args -> snd <$> findIcon name args
|
NestedPApp args -> snd <$> findIcon name (fmap fst args)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
findIcon :: NodeName -> [Maybe (NodeName, Icon)] -> Maybe (Int, Icon)
|
findIcon :: NodeName -> [Maybe (NodeName, Icon)] -> Maybe (Int, Icon)
|
||||||
@ -150,7 +150,7 @@ getPortAngles icon port maybeNodeName = case icon of
|
|||||||
CaseResultIcon -> []
|
CaseResultIcon -> []
|
||||||
FlatLambdaIcon _ -> applyPortAngles port
|
FlatLambdaIcon _ -> applyPortAngles port
|
||||||
NestedApply _ args -> generalNestedPortAngles applyPortAngles args port maybeNodeName
|
NestedApply _ args -> generalNestedPortAngles applyPortAngles args port maybeNodeName
|
||||||
NestedPApp args -> generalNestedPortAngles pAppPortAngles args port maybeNodeName
|
NestedPApp args -> generalNestedPortAngles pAppPortAngles (fmap fst args) port maybeNodeName
|
||||||
NestedCaseIcon args -> nestedGuardPortAngles args port maybeNodeName
|
NestedCaseIcon args -> nestedGuardPortAngles args port maybeNodeName
|
||||||
NestedGuardIcon args -> nestedGuardPortAngles args port maybeNodeName
|
NestedGuardIcon args -> nestedGuardPortAngles args port maybeNodeName
|
||||||
|
|
||||||
@ -228,6 +228,17 @@ makePort x = named x mempty
|
|||||||
makeQualifiedPort :: SpecialNum n => NodeName -> Port -> SpecialQDiagram b n
|
makeQualifiedPort :: SpecialNum n => NodeName -> Port -> SpecialQDiagram b n
|
||||||
makeQualifiedPort n x = n .>> makePort x
|
makeQualifiedPort n x = n .>> makePort x
|
||||||
|
|
||||||
|
makeLabelledPort :: SpecialBackend b n =>
|
||||||
|
NodeName -> Bool -> Angle n -> String -> Port -> SpecialQDiagram b n
|
||||||
|
makeLabelledPort name reflect angle str portNum = case str of
|
||||||
|
-- Don't display " tempvar" from Translate.hs/matchesToCase
|
||||||
|
(' ':_) -> portAndCircle
|
||||||
|
(_:_:_) -> portAndCircle ||| label
|
||||||
|
_ -> portAndCircle
|
||||||
|
where
|
||||||
|
portAndCircle = makeQualifiedPort name portNum <> portCircle
|
||||||
|
label = transformableBindTextBox str reflect angle
|
||||||
|
|
||||||
-- END Diagram helper functions
|
-- END Diagram helper functions
|
||||||
|
|
||||||
|
|
||||||
@ -279,7 +290,7 @@ generalTextAppDia textCol borderCol numArgs str name _ reflect angle = nameDiagr
|
|||||||
|
|
||||||
-- TODO Refactor with generalNestedDia
|
-- TODO Refactor with generalNestedDia
|
||||||
nestedPAppDia :: SpecialBackend b n =>
|
nestedPAppDia :: SpecialBackend b n =>
|
||||||
[Colour Double] -> [Maybe (NodeName, Icon)] -> TransformableDia b n
|
[Colour Double] -> [(Maybe (NodeName, Icon), String)] -> TransformableDia b n
|
||||||
nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
|
||||||
[] -> mempty
|
[] -> mempty
|
||||||
(maybeFunText:args) -> centerXY $ centerY finalDia ||| transformedText ||| resultCircleAndPort
|
(maybeFunText:args) -> centerXY $ centerY finalDia ||| transformedText ||| resultCircleAndPort
|
||||||
@ -287,8 +298,8 @@ nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = n
|
|||||||
borderCol = borderCols !! nestingLevel
|
borderCol = borderCols !! nestingLevel
|
||||||
|
|
||||||
transformedText = case maybeFunText of
|
transformedText = case maybeFunText of
|
||||||
Just _ -> makeInnerIcon True inputPortConst maybeFunText
|
(Just _, _) -> makeInnerIcon True inputPortConst maybeFunText
|
||||||
Nothing -> mempty
|
(Nothing, _) -> mempty
|
||||||
separation = circleRadius * 1.5
|
separation = circleRadius * 1.5
|
||||||
verticalSeparation = circleRadius
|
verticalSeparation = circleRadius
|
||||||
resultCircleAndPort = makeQualifiedPort name resultPortConst <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)
|
resultCircleAndPort = makeQualifiedPort name resultPortConst <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)
|
||||||
@ -303,9 +314,9 @@ nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = n
|
|||||||
argBox = alignT $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeparation) (circleRadius * 0.5)
|
argBox = alignT $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeparation) (circleRadius * 0.5)
|
||||||
finalDia = argBox <> allPorts
|
finalDia = argBox <> allPorts
|
||||||
|
|
||||||
makeInnerIcon _ portNum Nothing = makeQualifiedPort name portNum <> portCircle
|
makeInnerIcon _ portNum (Nothing, str) = centerX $ makeLabelledPort name reflect angle str portNum
|
||||||
makeInnerIcon True _ (Just (_, TextBoxIcon t)) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
|
makeInnerIcon True _ ((Just (_, TextBoxIcon t)), _) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
|
||||||
makeInnerIcon func _ (Just (iconNodeName, icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
makeInnerIcon func _ ((Just (iconNodeName, icon)), _) = iconToDiagram icon iconNodeName innerLevel reflect angle where
|
||||||
innerLevel = if func then nestingLevel else nestingLevel + 1
|
innerLevel = if func then nestingLevel else nestingLevel + 1
|
||||||
|
|
||||||
|
|
||||||
@ -395,10 +406,6 @@ coloredTextBox textColor boxColor t =
|
|||||||
fontSize (local textBoxFontSize) (bold $ font "freemono" $ fc textColor $ text t)
|
fontSize (local textBoxFontSize) (bold $ font "freemono" $ fc textColor $ text t)
|
||||||
<> lwG (0.6 * defaultLineWidth) (lcA boxColor $ fcA (withOpacity (backgroundC colorScheme) 0.5) $ rectForText (length t))
|
<> lwG (0.6 * defaultLineWidth) (lcA boxColor $ fcA (withOpacity (backgroundC colorScheme) 0.5) $ rectForText (length t))
|
||||||
|
|
||||||
bindTextBox :: SpecialBackend b n =>
|
|
||||||
String -> SpecialQDiagram b n
|
|
||||||
bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC colorScheme)
|
|
||||||
|
|
||||||
transformCorrectedTextBox :: SpecialBackend b n =>
|
transformCorrectedTextBox :: SpecialBackend b n =>
|
||||||
String -> Colour Double -> Colour Double -> Bool -> Angle n -> SpecialQDiagram b n
|
String -> Colour Double -> Colour Double -> Bool -> Angle n -> SpecialQDiagram b n
|
||||||
transformCorrectedTextBox str textCol borderCol reflect angle =
|
transformCorrectedTextBox str textCol borderCol reflect angle =
|
||||||
@ -409,13 +416,17 @@ transformCorrectedTextBox str textCol borderCol reflect angle =
|
|||||||
textBoxRotation = if (reducedAngle > (1/4)) && (reducedAngle < (3/4)) then 1 / 2 else 0
|
textBoxRotation = if (reducedAngle > (1/4)) && (reducedAngle < (3/4)) then 1 / 2 else 0
|
||||||
reflectIfTrue shouldReflect dia = if shouldReflect then reflectX dia else dia
|
reflectIfTrue shouldReflect dia = if shouldReflect then reflectX dia else dia
|
||||||
|
|
||||||
defaultColoredTextBox :: SpecialBackend b n =>
|
transformableBindTextBox :: SpecialBackend b n =>
|
||||||
String -> Bool -> Angle n -> SpecialQDiagram b n
|
String -> Bool -> Angle n -> SpecialQDiagram b n
|
||||||
defaultColoredTextBox str = transformCorrectedTextBox str (textBoxTextC colorScheme) (textBoxC colorScheme)
|
transformableBindTextBox str = transformCorrectedTextBox str (bindTextBoxTextC colorScheme) (bindTextBoxC colorScheme)
|
||||||
|
|
||||||
|
bindTextBox :: SpecialBackend b n =>
|
||||||
|
String -> SpecialQDiagram b n
|
||||||
|
bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC colorScheme)
|
||||||
|
|
||||||
textBox :: SpecialBackend b n =>
|
textBox :: SpecialBackend b n =>
|
||||||
String -> TransformableDia b n
|
String -> TransformableDia b n
|
||||||
textBox t name _ reflect angle = nameDiagram name $ defaultColoredTextBox t reflect angle
|
textBox t name _ reflect angle = nameDiagram name $ transformCorrectedTextBox t (textBoxTextC colorScheme) (textBoxC colorScheme) reflect angle
|
||||||
|
|
||||||
-- END Text boxes and icons
|
-- END Text boxes and icons
|
||||||
|
|
||||||
@ -507,25 +518,13 @@ nestedCaseDia = generalNestedGuard (patternC colorScheme) caseC caseResult
|
|||||||
|
|
||||||
-- END Guard and case icons
|
-- END Guard and case icons
|
||||||
|
|
||||||
-- BEGIN Lambda icon --
|
|
||||||
makeLabelledPort :: SpecialBackend b n =>
|
|
||||||
NodeName -> Bool -> Angle n -> String -> Port -> SpecialQDiagram b n
|
|
||||||
makeLabelledPort name reflect angle str portNum = case str of
|
|
||||||
-- Don't display " tempvar" from Translate.hs/matchesToCase
|
|
||||||
(' ':_) -> portAndCircle
|
|
||||||
(_:_:_) -> portAndCircle ||| label
|
|
||||||
_ -> portAndCircle
|
|
||||||
where
|
|
||||||
portAndCircle = makeQualifiedPort name portNum <> portCircle
|
|
||||||
label = defaultColoredTextBox str reflect angle
|
|
||||||
|
|
||||||
-- | The ports of flatLambdaIcon are:
|
-- | The ports of flatLambdaIcon are:
|
||||||
-- 0: Result icon
|
-- 0: Result icon
|
||||||
-- 1: The lambda function value
|
-- 1: The lambda function value
|
||||||
-- 2,3.. : The parameters
|
-- 2,3.. : The parameters
|
||||||
flatLambda :: SpecialBackend b n => [String] -> TransformableDia b n
|
flatLambda :: SpecialBackend b n => [String] -> TransformableDia b n
|
||||||
flatLambda paramNames name _ reflect angle = named name finalDia where
|
flatLambda paramNames name _ reflect angle = named name finalDia where
|
||||||
lambdaCircle = lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ fc (regionPerimC colorScheme) $ circle circleRadius
|
lambdaCircle = lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ fc (regionPerimC colorScheme) $ circle (1.5 * circleRadius)
|
||||||
lambdaParts = (makeQualifiedPort name inputPortConst <> resultIcon) : (portIcons ++ [makeQualifiedPort name resultPortConst <> alignR lambdaCircle])
|
lambdaParts = (makeQualifiedPort name inputPortConst <> resultIcon) : (portIcons ++ [makeQualifiedPort name resultPortConst <> alignR lambdaCircle])
|
||||||
|
|
||||||
portIcons = zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
|
portIcons = zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
|
||||||
@ -534,6 +533,5 @@ flatLambda paramNames name _ reflect angle = named name finalDia where
|
|||||||
topAndBottomLine = alignL $ lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ hrule topAndBottomLineWidth
|
topAndBottomLine = alignL $ lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ hrule topAndBottomLineWidth
|
||||||
finalDia = topAndBottomLine <> alignB (topAndBottomLine <> alignT middle)
|
finalDia = topAndBottomLine <> alignB (topAndBottomLine <> alignT middle)
|
||||||
|
|
||||||
-- END Lambda icon --
|
|
||||||
-- END Main icons
|
-- END Main icons
|
||||||
-- END Icons
|
-- END Icons
|
||||||
|
@ -13,6 +13,7 @@ import Data.Either(partitionEithers)
|
|||||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||||
import Data.List(unzip5, partition, intercalate)
|
import Data.List(unzip5, partition, intercalate)
|
||||||
import Data.Maybe(catMaybes, isJust, fromMaybe)
|
import Data.Maybe(catMaybes, isJust, fromMaybe)
|
||||||
|
|
||||||
import qualified Language.Haskell.Exts as Exts
|
import qualified Language.Haskell.Exts as Exts
|
||||||
|
|
||||||
import Language.Haskell.Exts(Decl(..), parseDeclWithMode, Name(..), Pat(..), Rhs(..),
|
import Language.Haskell.Exts(Decl(..), parseDeclWithMode, Name(..), Pat(..), Rhs(..),
|
||||||
@ -70,6 +71,14 @@ bindOrAltHelper c pat rhs maybeWhereBinds = do
|
|||||||
rhsGraphAndRef <- rhsWithBinds maybeWhereBinds rhs rhsContext
|
rhsGraphAndRef <- rhsWithBinds maybeWhereBinds rhs rhsContext
|
||||||
pure (patGraphAndRef, rhsGraphAndRef)
|
pure (patGraphAndRef, rhsGraphAndRef)
|
||||||
|
|
||||||
|
patternName :: (GraphAndRef, Maybe String) -> String
|
||||||
|
patternName (GraphAndRef _ ref, mStr) = fromMaybe
|
||||||
|
(case ref of
|
||||||
|
Left str -> str
|
||||||
|
Right _ -> ""
|
||||||
|
)
|
||||||
|
mStr
|
||||||
|
|
||||||
-- END Helper Functions --
|
-- END Helper Functions --
|
||||||
|
|
||||||
-- BEGIN Names helper functions --
|
-- BEGIN Names helper functions --
|
||||||
@ -121,11 +130,16 @@ asNameBind (GraphAndRef _ ref, mAsName) = case mAsName of
|
|||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
Just asName -> Just $ SgBind asName ref
|
Just asName -> Just $ SgBind asName ref
|
||||||
|
|
||||||
patternArgumentMapper :: (GraphAndRef, t) -> Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph)
|
patternArgumentMapper :: ((GraphAndRef, Maybe String), t) -> (String, Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph))
|
||||||
patternArgumentMapper argAndPort = case graph of
|
patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) = (patName, eitherVal)
|
||||||
|
where
|
||||||
|
graph = graphAndRefToGraph graphAndRef
|
||||||
|
patName = patternName asGraphAndRef
|
||||||
|
|
||||||
|
eitherVal = case graph of
|
||||||
(SyntaxGraph [namedNode] [] _ _ _) -> Right (namedNode, graph)
|
(SyntaxGraph [namedNode] [] _ _ _) -> Right (namedNode, graph)
|
||||||
_ -> Left argAndPort
|
_ -> Left (graphAndRef, port)
|
||||||
where graph = graphAndRefToGraph $ fst argAndPort
|
|
||||||
|
|
||||||
graphToTuple :: SyntaxGraph -> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)])
|
graphToTuple :: SyntaxGraph -> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)])
|
||||||
graphToTuple (SyntaxGraph a b c d e) = (a, b, c, d, e)
|
graphToTuple (SyntaxGraph a b c d e) = (a, b, c, d, e)
|
||||||
@ -137,22 +151,24 @@ graphsToComponents graphs = (concat a, concat b, concat c, concat d, concat e) w
|
|||||||
makeNestedPatternGraph :: NodeName -> String -> [(GraphAndRef, Maybe String)] -> (SyntaxGraph, NameAndPort)
|
makeNestedPatternGraph :: NodeName -> String -> [(GraphAndRef, Maybe String)] -> (SyntaxGraph, NameAndPort)
|
||||||
makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult
|
makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult
|
||||||
where
|
where
|
||||||
pAppNode = NestedPatternApplyNode funStr argList
|
dummyNode = NestedPatternApplyNode "" []
|
||||||
argsAndPorts = zip (fmap fst argVals) $ map (nameAndPort applyIconName) $ argumentPorts pAppNode
|
|
||||||
|
argsAndPorts = zip argVals $ map (nameAndPort applyIconName) $ argumentPorts dummyNode
|
||||||
mappedArgs = fmap patternArgumentMapper argsAndPorts
|
mappedArgs = fmap patternArgumentMapper argsAndPorts
|
||||||
|
|
||||||
(unnestedArgsAndPort, nestedNamedNodesAndGraphs) = partitionEithers mappedArgs
|
(unnestedArgsAndPort, nestedNamedNodesAndGraphs) = partitionEithers (fmap snd mappedArgs)
|
||||||
|
|
||||||
(nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) = graphsToComponents $ fmap snd nestedNamedNodesAndGraphs
|
(nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) = graphsToComponents $ fmap snd nestedNamedNodesAndGraphs
|
||||||
|
|
||||||
argListMapper arg = case arg of
|
argListMapper (str, arg) = case arg of
|
||||||
Left _ -> Nothing
|
Left _ -> (Nothing, str)
|
||||||
Right (namedNode, _) -> Just namedNode
|
Right (namedNode, _) -> (Just namedNode, str)
|
||||||
|
|
||||||
argList = fmap argListMapper mappedArgs
|
argList = fmap argListMapper mappedArgs
|
||||||
|
|
||||||
combinedGraph = combineExpressions True unnestedArgsAndPort
|
combinedGraph = combineExpressions True unnestedArgsAndPort
|
||||||
|
|
||||||
|
pAppNode = NestedPatternApplyNode funStr argList
|
||||||
icons = [SgNamedNode applyIconName pAppNode]
|
icons = [SgNamedNode applyIconName pAppNode]
|
||||||
|
|
||||||
asNameBinds = catMaybes $ fmap asNameBind argVals
|
asNameBinds = catMaybes $ fmap asNameBind argVals
|
||||||
@ -615,14 +631,6 @@ evalRecConstr c qName _ = evalQName qName c
|
|||||||
asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph
|
asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph
|
||||||
asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName]
|
asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName]
|
||||||
|
|
||||||
paramName :: (GraphAndRef, Maybe String) -> String
|
|
||||||
paramName (GraphAndRef _ ref, mStr) = fromMaybe
|
|
||||||
(case ref of
|
|
||||||
Left str -> str
|
|
||||||
Right _ -> ""
|
|
||||||
)
|
|
||||||
mStr
|
|
||||||
|
|
||||||
generalEvalLambda :: EvalContext -> [Pat] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (SyntaxGraph, NameAndPort)
|
generalEvalLambda :: EvalContext -> [Pat] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (SyntaxGraph, NameAndPort)
|
||||||
generalEvalLambda context patterns rhsEvalFun = do
|
generalEvalLambda context patterns rhsEvalFun = do
|
||||||
lambdaName <- getUniqueName
|
lambdaName <- getUniqueName
|
||||||
@ -631,7 +639,7 @@ generalEvalLambda context patterns rhsEvalFun = do
|
|||||||
patternVals = fmap fst patternValsWithAsNames
|
patternVals = fmap fst patternValsWithAsNames
|
||||||
patternStrings = concatMap namesInPattern patternValsWithAsNames
|
patternStrings = concatMap namesInPattern patternValsWithAsNames
|
||||||
rhsContext = patternStrings <> context
|
rhsContext = patternStrings <> context
|
||||||
paramNames = fmap paramName patternValsWithAsNames
|
paramNames = fmap patternName patternValsWithAsNames
|
||||||
lambdaNode = FunctionDefNode paramNames
|
lambdaNode = FunctionDefNode paramNames
|
||||||
lambdaPorts = map (nameAndPort lambdaName) $ argumentPorts lambdaNode
|
lambdaPorts = map (nameAndPort lambdaName) $ argumentPorts lambdaNode
|
||||||
patternGraph = mconcat $ fmap graphAndRefToGraph patternVals
|
patternGraph = mconcat $ fmap graphAndRefToGraph patternVals
|
||||||
|
@ -31,6 +31,7 @@ module TranslateCore(
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.State(State, state)
|
import Control.Monad.State(State, state)
|
||||||
|
import qualified Control.Arrow as Arrow
|
||||||
import Data.Either(partitionEithers)
|
import Data.Either(partitionEithers)
|
||||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||||
import qualified Data.Graph.Inductive.Graph as ING
|
import qualified Data.Graph.Inductive.Graph as ING
|
||||||
@ -278,11 +279,11 @@ nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of
|
|||||||
argPorts = take (2 * numArgs) $ argumentPorts dummyNode
|
argPorts = take (2 * numArgs) $ argumentPorts dummyNode
|
||||||
argList = fmap (makeArg args) (inputPort dummyNode : argPorts)
|
argList = fmap (makeArg args) (inputPort dummyNode : argPorts)
|
||||||
|
|
||||||
nestedPatternNodeToIcon :: String -> [Maybe SgNamedNode] -> Icon
|
nestedPatternNodeToIcon :: String -> [(Maybe SgNamedNode, String)] -> Icon
|
||||||
nestedPatternNodeToIcon str children = NestedPApp $
|
nestedPatternNodeToIcon str children = NestedPApp $
|
||||||
Just (NodeName (-1), TextBoxIcon str)
|
(Just (NodeName (-1), TextBoxIcon str), "")
|
||||||
:
|
:
|
||||||
(fmap (mapNodeInNamedNode nodeToIcon) <$> children)
|
fmap (Arrow.first $ fmap (mapNodeInNamedNode nodeToIcon)) children
|
||||||
|
|
||||||
findArg :: Port -> (SgNamedNode, Edge) -> Bool
|
findArg :: Port -> (SgNamedNode, Edge) -> Bool
|
||||||
findArg currentPort (SgNamedNode argName _, Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
|
findArg currentPort (SgNamedNode argName _, Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
|
||||||
|
@ -37,7 +37,7 @@ data Icon = TextBoxIcon String | GuardIcon Int
|
|||||||
| BindTextBoxIcon String
|
| BindTextBoxIcon String
|
||||||
-- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
|
-- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
|
||||||
| NestedApply LikeApplyFlavor [Maybe (NodeName, Icon)]
|
| NestedApply LikeApplyFlavor [Maybe (NodeName, Icon)]
|
||||||
| NestedPApp [Maybe (NodeName, Icon)]
|
| NestedPApp [(Maybe (NodeName, Icon), String)]
|
||||||
| NestedCaseIcon [Maybe (NodeName, Icon)]
|
| NestedCaseIcon [Maybe (NodeName, Icon)]
|
||||||
| NestedGuardIcon [Maybe (NodeName, Icon)]
|
| NestedGuardIcon [Maybe (NodeName, Icon)]
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
@ -52,7 +52,7 @@ data SyntaxNode =
|
|||||||
| NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)]
|
| NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)]
|
||||||
| PatternApplyNode String Int -- Destructors as used in patterns
|
| PatternApplyNode String Int -- Destructors as used in patterns
|
||||||
-- | NestedPatternApplyNode String Int [(SgNamedNode, Edge)]
|
-- | NestedPatternApplyNode String Int [(SgNamedNode, Edge)]
|
||||||
| NestedPatternApplyNode String [Maybe SgNamedNode]
|
| NestedPatternApplyNode String [(Maybe SgNamedNode, String)]
|
||||||
| NameNode String -- Identifiers or symbols
|
| NameNode String -- Identifiers or symbols
|
||||||
| BindNameNode String
|
| BindNameNode String
|
||||||
| LiteralNode String -- Literal values like the string "Hello World"
|
| LiteralNode String -- Literal values like the string "Hello World"
|
||||||
|
@ -38,10 +38,10 @@ renameNode nameMap counter (SgNamedNode nodeName syntaxNode) = (newNamedNode, na
|
|||||||
newNamedNode = SgNamedNode newNodeName newSyntaxNode
|
newNamedNode = SgNamedNode newNodeName newSyntaxNode
|
||||||
|
|
||||||
maybeRenameNodeFolder ::
|
maybeRenameNodeFolder ::
|
||||||
([Maybe SgNamedNode], NameMap, Int) -> Maybe SgNamedNode -> ([Maybe SgNamedNode], NameMap, Int)
|
([(Maybe SgNamedNode, String)], NameMap, Int) -> Maybe SgNamedNode -> ([(Maybe SgNamedNode, String)], NameMap, Int)
|
||||||
maybeRenameNodeFolder (renamedNodes, nameMap, counter) mNode = case mNode of
|
maybeRenameNodeFolder (renamedNodes, nameMap, counter) mNode = case mNode of
|
||||||
Nothing -> (Nothing:renamedNodes, nameMap, counter)
|
Nothing -> ((Nothing, ""):renamedNodes, nameMap, counter)
|
||||||
Just node -> (Just newNamedNode:renamedNodes, newNameMap, newCounter) where
|
Just node -> ((Just newNamedNode, ""):renamedNodes, newNameMap, newCounter) where
|
||||||
(newNamedNode, newNameMap, newCounter) = renameNode nameMap counter node
|
(newNamedNode, newNameMap, newCounter) = renameNode nameMap counter node
|
||||||
|
|
||||||
renameSyntaxNode :: NameMap -> SyntaxNode -> Int -> (SyntaxNode, NameMap, Int)
|
renameSyntaxNode :: NameMap -> SyntaxNode -> Int -> (SyntaxNode, NameMap, Int)
|
||||||
@ -49,7 +49,7 @@ renameSyntaxNode nameMap node counter = case node of
|
|||||||
-- TODO Keep the Nothing subNodes
|
-- TODO Keep the Nothing subNodes
|
||||||
NestedPatternApplyNode s subNodes -> (NestedPatternApplyNode s (reverse renamedSubNodes), newNameMap, counter2)
|
NestedPatternApplyNode s subNodes -> (NestedPatternApplyNode s (reverse renamedSubNodes), newNameMap, counter2)
|
||||||
where
|
where
|
||||||
(renamedSubNodes, newNameMap, counter2) = foldl' maybeRenameNodeFolder ([], nameMap, counter) subNodes
|
(renamedSubNodes, newNameMap, counter2) = foldl' maybeRenameNodeFolder ([], nameMap, counter) (fmap fst subNodes)
|
||||||
_ -> (node, nameMap, counter)
|
_ -> (node, nameMap, counter)
|
||||||
|
|
||||||
renameNodeFolder :: ([SgNamedNode], NameMap, Int) -> SgNamedNode -> ([SgNamedNode], NameMap, Int)
|
renameNodeFolder :: ([SgNamedNode], NameMap, Int) -> SgNamedNode -> ([SgNamedNode], NameMap, Int)
|
||||||
|
@ -166,7 +166,10 @@ patternTests = [
|
|||||||
|
|
||||||
"y = let {(x, y) = (1,2)} in x + y",
|
"y = let {(x, y) = (1,2)} in x + y",
|
||||||
"y = let {(x, y) = (1,2); (z, w) = x; (m, g) = y} in foo x y z w m g",
|
"y = let {(x, y) = (1,2); (z, w) = x; (m, g) = y} in foo x y z w m g",
|
||||||
"(x:y) = 2"
|
"(x:y) = 2",
|
||||||
|
|
||||||
|
-- test labelled ports
|
||||||
|
"Foo x1 x2 = 4"
|
||||||
]
|
]
|
||||||
|
|
||||||
lambdaTests :: [String]
|
lambdaTests :: [String]
|
||||||
|
Loading…
Reference in New Issue
Block a user