glance/app/TranslateCore.hs

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)