mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
422 lines
13 KiB
Haskell
422 lines
13 KiB
Haskell
-- 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 qualified Data.Graph.Inductive.Graph as ING
|
|
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
|
import Data.List (find)
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
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" #-}
|
|
|
|
-- OVERVIEW --
|
|
-- This module has the core functions and data types used by Translate.
|
|
-- This module also contains most/all of the translation functions that
|
|
-- do not require Language.Haskell.Exts.
|
|
|
|
type Reference = Either String NameAndPort
|
|
|
|
type EvalContext = [String]
|
|
|
|
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)
|
|
|
|
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)
|
|
|
|
instance Monoid SyntaxGraph where
|
|
mempty = SyntaxGraph mempty mempty mempty mempty mempty
|
|
mappend = (<>)
|
|
|
|
data GraphAndRef = GraphAndRef SyntaxGraph Reference
|
|
|
|
-- BEGIN Constructors and Destructors
|
|
|
|
sgBindToString :: SgBind -> String
|
|
sgBindToString (SgBind s _) = s
|
|
|
|
sgBindToTuple :: SgBind -> (String, Reference)
|
|
sgBindToTuple (SgBind s r) = (s, r)
|
|
|
|
syntaxGraphFromNodes :: [SgNamedNode] -> SyntaxGraph
|
|
syntaxGraphFromNodes icons = SyntaxGraph icons mempty mempty mempty mempty
|
|
|
|
syntaxGraphFromNodesEdges :: [SgNamedNode] -> [Edge] -> SyntaxGraph
|
|
syntaxGraphFromNodesEdges icons edges =
|
|
SyntaxGraph icons edges mempty mempty mempty
|
|
|
|
bindsToSyntaxGraph :: [SgBind] -> SyntaxGraph
|
|
bindsToSyntaxGraph binds = SyntaxGraph mempty mempty mempty binds mempty
|
|
|
|
sinksToSyntaxGraph :: [SgSink] -> SyntaxGraph
|
|
sinksToSyntaxGraph sinks = SyntaxGraph mempty mempty sinks mempty mempty
|
|
|
|
edgesToSyntaxGraph :: [Edge] -> SyntaxGraph
|
|
edgesToSyntaxGraph edges = SyntaxGraph mempty edges mempty mempty mempty
|
|
|
|
graphAndRefToGraph :: GraphAndRef -> SyntaxGraph
|
|
graphAndRefToGraph (GraphAndRef g _) = g
|
|
|
|
-- END Constructors and Destructors
|
|
|
|
-- BEGIN IDState
|
|
|
|
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."
|
|
|
|
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
|
|
|
|
-- END IDState
|
|
|
|
-- TODO: Refactor with combineExpressions
|
|
edgesForRefPortList :: Bool -> [(Reference, NameAndPort)] -> SyntaxGraph
|
|
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]
|
|
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts connection]
|
|
where
|
|
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
|
|
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)]
|
|
|
|
makeApplyGraph ::
|
|
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)
|
|
functionPort = nameAndPort applyIconName (inputPort applyNode)
|
|
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))
|
|
where
|
|
multiIfNode = CaseOrMultiIfNode MultiIfTag numPairs
|
|
expsWithPorts = zip exps $ map (nameAndPort multiIfName) multiIfRhsPorts
|
|
boolsWithPorts = zip bools $ map (nameAndPort multiIfName) multiIfBoolPorts
|
|
combindedGraph = combineExpressions False $ expsWithPorts <> boolsWithPorts
|
|
icons = [Named multiIfName (mkEmbedder multiIfNode)]
|
|
newGraph = syntaxGraphFromNodes icons <> combindedGraph
|
|
|
|
namesInPatternHelper :: GraphAndRef -> [String]
|
|
namesInPatternHelper (GraphAndRef graph ref) = case ref of
|
|
Left str -> [str]
|
|
Right _ -> sgBindToString <$> sgBinds graph
|
|
|
|
namesInPattern :: (GraphAndRef, Maybe String) -> [String]
|
|
namesInPattern (graphAndRef, mName) = case mName of
|
|
Nothing -> otherNames
|
|
Just n -> n : otherNames
|
|
where
|
|
otherNames = namesInPatternHelper graphAndRef
|
|
|
|
-- | Recursivly find the matching reference in a list of bindings.
|
|
-- 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
|
|
|
|
deleteBindings :: SyntaxGraph -> SyntaxGraph
|
|
deleteBindings (SyntaxGraph a b c _ e) = SyntaxGraph a b c mempty e
|
|
|
|
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
|
|
|
|
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
|
|
|
|
makeBox :: String -> State IDState (SyntaxGraph, NameAndPort)
|
|
makeBox str = do
|
|
name <- getUniqueName
|
|
let graph =
|
|
syntaxGraphFromNodes [Named name (mkEmbedder (LiteralNode str))]
|
|
pure (graph, justName name)
|
|
|
|
nTupleString :: Int -> String
|
|
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 ","
|
|
|
|
nListString :: Int -> String
|
|
-- TODO: Use something better than [_]
|
|
nListString 1 = "[_]"
|
|
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
|
|
(NameNode s) -> TextBoxIcon s
|
|
(BindNameNode s) -> BindTextBoxIcon s
|
|
(LiteralNode s) -> TextBoxIcon s
|
|
(FunctionDefNode labels bodyNodes) ->
|
|
nestedLambdaToIcon labels embeddedNodes bodyNodes
|
|
CaseResultNode -> CaseResultIcon
|
|
(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
|
|
|
|
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 flavor numArgs args =
|
|
NestedApply flavor headIcon argList
|
|
where
|
|
dummyNode = ApplyNode flavor numArgs
|
|
argPorts = take numArgs (argumentPorts dummyNode)
|
|
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 labels embeddedNodes =
|
|
LambdaIcon labels embeddedBodyNode
|
|
where
|
|
dummyNode = FunctionDefNode [] Set.empty
|
|
embeddedBodyNode = makeArg embeddedNodes (inputPort dummyNode)
|
|
|
|
nestedCaseOrMultiIfNodeToIcon ::
|
|
CaseOrMultiIfTag ->
|
|
Int ->
|
|
Set.Set (NodeName, Edge) ->
|
|
Icon
|
|
nestedCaseOrMultiIfNodeToIcon tag numArgs args = case tag of
|
|
CaseTag -> NestedCaseIcon argList
|
|
MultiIfTag -> NestedMultiIfIcon argList
|
|
where
|
|
dummyNode = CaseOrMultiIfNode CaseTag numArgs
|
|
argPorts = take (2 * numArgs) $ argumentPorts dummyNode
|
|
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)
|
|
|
|
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
|
|
|
|
syntaxGraphToFglGraph :: SyntaxGraph -> FGR.Gr SgNamedNode Edge
|
|
syntaxGraphToFglGraph (SyntaxGraph nodes edges _ _ eMap) =
|
|
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
|
|
)
|