glance/app/TranslateCore.hs
2019-07-31 12:01:37 -07:00

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)