mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Make constants for input and result port numbers.
This commit is contained in:
parent
04ddca3c1b
commit
2ddb5c8a09
@ -1,4 +1,5 @@
|
|||||||
{-# LANGUAGE MultiWayIf #-}
|
{-# LANGUAGE MultiWayIf #-}
|
||||||
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
module GraphAlgorithms(
|
module GraphAlgorithms(
|
||||||
ParentType(..),
|
ParentType(..),
|
||||||
annotateGraph,
|
annotateGraph,
|
||||||
@ -10,10 +11,12 @@ import qualified Data.Graph.Inductive as ING
|
|||||||
import Data.List(foldl', find)
|
import Data.List(foldl', find)
|
||||||
import Data.Tuple(swap)
|
import Data.Tuple(swap)
|
||||||
|
|
||||||
|
import Constants(pattern ResultPortConst, pattern InputPortConst)
|
||||||
import Types(SyntaxNode(..), IngSyntaxGraph, Edge(..),
|
import Types(SyntaxNode(..), IngSyntaxGraph, Edge(..),
|
||||||
CaseOrMultiIfTag(..), Port(..), NameAndPort(..), SgNamedNode(..)
|
CaseOrMultiIfTag(..), Port(..), NameAndPort(..), SgNamedNode(..)
|
||||||
, AnnotatedGraph, EmbedInfo(..), EmbedDirection(..))
|
, AnnotatedGraph, EmbedInfo(..), EmbedDirection(..))
|
||||||
import Util(sgNamedNodeToSyntaxNode)
|
import Util(sgNamedNodeToSyntaxNode)
|
||||||
|
|
||||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||||
|
|
||||||
data ParentType = ApplyParent
|
data ParentType = ApplyParent
|
||||||
@ -61,13 +64,13 @@ syntaxNodeIsEmbeddable parentType syntaxNode mParentPort mChildPort
|
|||||||
_ -> False
|
_ -> False
|
||||||
where
|
where
|
||||||
isInput mPort = case mPort of
|
isInput mPort = case mPort of
|
||||||
Just (Port 0) -> True
|
Just InputPortConst -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
isResult mPort = case mPort of
|
isResult mPort = case mPort of
|
||||||
Just (Port 1) -> True
|
Nothing -> True
|
||||||
|
Just ResultPortConst -> True
|
||||||
Just _ -> False
|
Just _ -> False
|
||||||
_ -> True
|
|
||||||
|
|
||||||
parentPortNotInput = not $ isInput mParentPort
|
parentPortNotInput = not $ isInput mParentPort
|
||||||
parentPortNotResult = not $ isResult mParentPort
|
parentPortNotResult = not $ isResult mParentPort
|
||||||
|
49
app/Icons.hs
49
app/Icons.hs
@ -1,5 +1,9 @@
|
|||||||
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies, ScopedTypeVariables #-}
|
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
module Icons
|
module Icons
|
||||||
(
|
(
|
||||||
TransformParams(..),
|
TransformParams(..),
|
||||||
@ -30,10 +34,11 @@ import Data.List(find)
|
|||||||
import Data.Maybe(catMaybes, listToMaybe, isJust, fromJust)
|
import Data.Maybe(catMaybes, listToMaybe, isJust, fromJust)
|
||||||
import Data.Typeable(Typeable)
|
import Data.Typeable(Typeable)
|
||||||
|
|
||||||
|
import Constants(pattern InputPortConst, pattern ResultPortConst)
|
||||||
|
import DrawingColors(colorScheme, ColorStyle(..))
|
||||||
import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum
|
import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum
|
||||||
, NodeName, Port(..), LikeApplyFlavor(..),
|
, NodeName, Port(..), LikeApplyFlavor(..),
|
||||||
SyntaxNode(..), NamedIcon(..), Labeled(..))
|
SyntaxNode(..), NamedIcon(..), Labeled(..))
|
||||||
import DrawingColors(colorScheme, ColorStyle(..))
|
|
||||||
|
|
||||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||||
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||||
@ -181,21 +186,15 @@ getPortAngles icon port maybeNodeName = case icon of
|
|||||||
|
|
||||||
-- BEGIN Port numbers
|
-- BEGIN Port numbers
|
||||||
|
|
||||||
inputPortConst :: Port
|
|
||||||
inputPortConst = Port 0
|
|
||||||
|
|
||||||
resultPortConst :: Port
|
|
||||||
resultPortConst = Port 1
|
|
||||||
|
|
||||||
argPortsConst :: [Port]
|
argPortsConst :: [Port]
|
||||||
argPortsConst = fmap Port [2,3..]
|
argPortsConst = fmap Port [2,3..]
|
||||||
|
|
||||||
-- TODO It's a bit strange that the parameter is a SyntaxNode, not an Icon.
|
-- TODO It's a bit strange that the parameter is a SyntaxNode, not an Icon.
|
||||||
inputPort :: SyntaxNode -> Port
|
inputPort :: SyntaxNode -> Port
|
||||||
inputPort = const inputPortConst
|
inputPort = const InputPortConst
|
||||||
|
|
||||||
resultPort :: SyntaxNode -> Port
|
resultPort :: SyntaxNode -> Port
|
||||||
resultPort = const resultPortConst
|
resultPort = const ResultPortConst
|
||||||
|
|
||||||
caseRhsPorts :: [Port]
|
caseRhsPorts :: [Port]
|
||||||
caseRhsPorts = fmap Port [3,5..]
|
caseRhsPorts = fmap Port [3,5..]
|
||||||
@ -312,7 +311,7 @@ makeTransformedText :: SpecialBackend b n =>
|
|||||||
-> SpecialQDiagram b n
|
-> SpecialQDiagram b n
|
||||||
makeTransformedText tp maybeFunText = case laValue maybeFunText of
|
makeTransformedText tp maybeFunText = case laValue maybeFunText of
|
||||||
Just _ ->
|
Just _ ->
|
||||||
makeAppInnerIcon tp True inputPortConst maybeFunText
|
makeAppInnerIcon tp True InputPortConst maybeFunText
|
||||||
Nothing -> mempty
|
Nothing -> mempty
|
||||||
|
|
||||||
appArgBox :: (HasStyle a, Typeable (N a)
|
appArgBox :: (HasStyle a, Typeable (N a)
|
||||||
@ -344,7 +343,7 @@ nestedPAppDia
|
|||||||
transformedText = makeTransformedText tp maybeFunText
|
transformedText = makeTransformedText tp maybeFunText
|
||||||
separation = circleRadius * 1.5
|
separation = circleRadius * 1.5
|
||||||
resultCircleAndPort
|
resultCircleAndPort
|
||||||
= makeQualifiedPort name resultPortConst
|
= makeQualifiedPort name ResultPortConst
|
||||||
<> alignR
|
<> alignR
|
||||||
(lc borderCol
|
(lc borderCol
|
||||||
$ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)
|
$ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)
|
||||||
@ -353,7 +352,7 @@ nestedPAppDia
|
|||||||
rotate quarterTurn (apply0Triangle borderCol) :
|
rotate quarterTurn (apply0Triangle borderCol) :
|
||||||
zipWith (makeAppInnerIcon tp False) argPortsConst args
|
zipWith (makeAppInnerIcon tp False) argPortsConst args
|
||||||
allPorts
|
allPorts
|
||||||
= makeQualifiedPort name inputPortConst <> alignT triangleAndPorts
|
= makeQualifiedPort name InputPortConst <> alignT triangleAndPorts
|
||||||
argBox = alignT $ appArgBox
|
argBox = alignT $ appArgBox
|
||||||
borderCol
|
borderCol
|
||||||
(width allPorts)
|
(width allPorts)
|
||||||
@ -366,8 +365,8 @@ beside' :: (Semigroup a, Juxtaposable a) => V a (N a) -> a -> a -> a
|
|||||||
beside' dir dia1 dia2 = juxtapose dir dia1 dia2 <> dia1
|
beside' dir dia1 dia2 = juxtapose dir dia1 dia2 <> dia1
|
||||||
|
|
||||||
-- | apply port locations:
|
-- | apply port locations:
|
||||||
-- inputPortConst: Function
|
-- InputPortConst: Function
|
||||||
-- resultPortConst: Result
|
-- ResultPortConst: Result
|
||||||
-- Ports 2,3..: Arguments
|
-- Ports 2,3..: Arguments
|
||||||
generalNestedDia :: SpecialBackend b n
|
generalNestedDia :: SpecialBackend b n
|
||||||
=> (Colour Double -> SpecialQDiagram b n)
|
=> (Colour Double -> SpecialQDiagram b n)
|
||||||
@ -389,13 +388,13 @@ generalNestedDia
|
|||||||
trianglePortsCircle = hsep separation $
|
trianglePortsCircle = hsep separation $
|
||||||
reflectX (dia borderCol) :
|
reflectX (dia borderCol) :
|
||||||
zipWith (makeAppInnerIcon tp False) argPortsConst (fmap pure args) ++
|
zipWith (makeAppInnerIcon tp False) argPortsConst (fmap pure args) ++
|
||||||
[makeQualifiedPort name resultPortConst
|
[makeQualifiedPort name ResultPortConst
|
||||||
<> alignR
|
<> alignR
|
||||||
(lc borderCol $ lwG defaultLineWidth $ fc borderCol
|
(lc borderCol $ lwG defaultLineWidth $ fc borderCol
|
||||||
$ circle circleRadius)
|
$ circle circleRadius)
|
||||||
]
|
]
|
||||||
allPorts
|
allPorts
|
||||||
= makeQualifiedPort name inputPortConst <> alignL trianglePortsCircle
|
= makeQualifiedPort name InputPortConst <> alignL trianglePortsCircle
|
||||||
argBox = alignL $ appArgBox
|
argBox = alignL $ appArgBox
|
||||||
borderCol
|
borderCol
|
||||||
(width allPorts - circleRadius)
|
(width allPorts - circleRadius)
|
||||||
@ -553,11 +552,11 @@ generalNestedMultiIf triangleColor lBracket bottomDia inputAndArgs
|
|||||||
= named name $ case inputAndArgs of
|
= named name $ case inputAndArgs of
|
||||||
[] -> mempty
|
[] -> mempty
|
||||||
input : args -> centerXY finalDia where
|
input : args -> centerXY finalDia where
|
||||||
finalDia = alignT (bottomDia <> makeQualifiedPort name resultPortConst)
|
finalDia = alignT (bottomDia <> makeQualifiedPort name ResultPortConst)
|
||||||
<> alignB
|
<> alignB
|
||||||
(inputIcon === (bigVerticalLine
|
(inputIcon === (bigVerticalLine
|
||||||
<> multiIfDia
|
<> multiIfDia
|
||||||
<> makeQualifiedPort name inputPortConst))
|
<> makeQualifiedPort name InputPortConst))
|
||||||
|
|
||||||
iconMapper (Port portNum) arg
|
iconMapper (Port portNum) arg
|
||||||
| even portNum = Right $ multiIfTriangle port ||| makeInnerIcon True arg
|
| even portNum = Right $ multiIfTriangle port ||| makeInnerIcon True arg
|
||||||
@ -608,8 +607,8 @@ multiIfLBracket portDia = alignL (alignT ell) <> portDia
|
|||||||
$ lwG defaultLineWidth $ lc (boolC colorScheme) (strokeLine ellShape)
|
$ lwG defaultLineWidth $ lc (boolC colorScheme) (strokeLine ellShape)
|
||||||
|
|
||||||
-- | The ports of the multiIf icon are as follows:
|
-- | The ports of the multiIf icon are as follows:
|
||||||
-- inputPortConst: Top result port (not used)
|
-- InputPortConst: Top result port (not used)
|
||||||
-- resultPortConst: Bottom result port
|
-- ResultPortConst: Bottom result port
|
||||||
-- Ports 3,5...: The left ports for the booleans
|
-- Ports 3,5...: The left ports for the booleans
|
||||||
-- Ports 2,4...: The right ports for the values
|
-- Ports 2,4...: The right ports for the values
|
||||||
nestedMultiIfDia :: SpecialBackend b n =>
|
nestedMultiIfDia :: SpecialBackend b n =>
|
||||||
@ -629,8 +628,8 @@ caseC :: SpecialBackend b n =>
|
|||||||
caseC portDia = caseResult <> portDia
|
caseC portDia = caseResult <> portDia
|
||||||
|
|
||||||
-- | The ports of the case icon are as follows:
|
-- | The ports of the case icon are as follows:
|
||||||
-- inputPortConst: Top input port
|
-- InputPortConst: Top input port
|
||||||
-- resultPortConst: Bottom result port
|
-- ResultPortConst: Bottom result port
|
||||||
-- Ports 3,5...: The left ports for the results
|
-- Ports 3,5...: The left ports for the results
|
||||||
-- Ports 2,4...: The right ports for the patterns
|
-- Ports 2,4...: The right ports for the patterns
|
||||||
nestedCaseDia :: SpecialBackend b n => [Maybe NamedIcon] -> TransformableDia b n
|
nestedCaseDia :: SpecialBackend b n => [Maybe NamedIcon] -> TransformableDia b n
|
||||||
@ -651,10 +650,10 @@ flatLambda paramNames (TransformParams name _ reflect angle)
|
|||||||
$ lc (regionPerimC colorScheme)
|
$ lc (regionPerimC colorScheme)
|
||||||
$ fc (regionPerimC colorScheme) $ circle (1.5 * circleRadius)
|
$ fc (regionPerimC colorScheme) $ circle (1.5 * circleRadius)
|
||||||
lambdaParts
|
lambdaParts
|
||||||
= (makeQualifiedPort name inputPortConst <> resultIcon)
|
= (makeQualifiedPort name InputPortConst <> resultIcon)
|
||||||
:
|
:
|
||||||
(portIcons
|
(portIcons
|
||||||
++ [makeQualifiedPort name resultPortConst <> alignR lambdaCircle])
|
++ [makeQualifiedPort name ResultPortConst <> alignR lambdaCircle])
|
||||||
|
|
||||||
portIcons
|
portIcons
|
||||||
= zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
|
= zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
|
||||||
|
@ -55,6 +55,7 @@ executable glance-exe
|
|||||||
, DrawingColors
|
, DrawingColors
|
||||||
, GraphAlgorithms
|
, GraphAlgorithms
|
||||||
, SimplifySyntax
|
, SimplifySyntax
|
||||||
|
, Constants
|
||||||
|
|
||||||
test-suite glance-test
|
test-suite glance-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
@ -96,7 +97,7 @@ test-suite glance-test
|
|||||||
, DrawingColors
|
, DrawingColors
|
||||||
, GraphAlgorithms
|
, GraphAlgorithms
|
||||||
, SimplifySyntax
|
, SimplifySyntax
|
||||||
|
, Constants
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
|
1
todo.md
1
todo.md
@ -1,7 +1,6 @@
|
|||||||
# Todo
|
# Todo
|
||||||
|
|
||||||
## Todo Now
|
## Todo Now
|
||||||
* Remove port number magic numbers in GraphAlgorithms.hs.
|
|
||||||
* Let lambda icons embed results.
|
* Let lambda icons embed results.
|
||||||
* Redesign case to avoid non-locality.
|
* Redesign case to avoid non-locality.
|
||||||
* Add command line flags for color style, embedding, and whether to draw arrowheads.
|
* Add command line flags for color style, embedding, and whether to draw arrowheads.
|
||||||
|
Loading…
Reference in New Issue
Block a user