mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
373 lines
13 KiB
Haskell
373 lines
13 KiB
Haskell
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 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)
|
|
|
|
{-# 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
|
|
-- If in a pattern, then the port on the case icon is
|
|
-- the data source.
|
|
then (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)
|