glance/app/TranslateCore.hs

-- 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
      )