Accessors.hs

-- | Utilities for working with term accessors.

module Hydra.Show.Accessors where

import qualified Hydra.Accessors as Accessors
import qualified Hydra.Core as Core
import qualified Hydra.Lib.Lists as Lists
import qualified Hydra.Lib.Maps as Maps
import qualified Hydra.Lib.Optionals as Optionals
import qualified Hydra.Lib.Sets as Sets
import qualified Hydra.Lib.Strings as Strings
import qualified Hydra.Module as Module
import qualified Hydra.Names as Names
import qualified Hydra.Rewriting as Rewriting
import Prelude hiding  (Enum, Ordering, fail, map, pure, sum)
import qualified Data.Int as I
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S

-- | Convert a term accessor to a string representation
termAccessor :: (Accessors.TermAccessor -> Maybe String)
termAccessor accessor =  
  let idx = (\i -> Nothing) 
      idxSuff = (\suffix -> \i -> Optionals.map (\s -> Strings.cat2 s suffix) (idx i))
  in ((\x -> case x of
    Accessors.TermAccessorAnnotatedSubject -> Nothing
    Accessors.TermAccessorApplicationFunction -> (Just "fun")
    Accessors.TermAccessorApplicationArgument -> (Just "arg")
    Accessors.TermAccessorLambdaBody -> (Just "body")
    Accessors.TermAccessorUnionCasesDefault -> (Just "default")
    Accessors.TermAccessorUnionCasesBranch v1 -> (Just (Strings.cat2 "." (Core.unName v1)))
    Accessors.TermAccessorLetEnvironment -> (Just "in")
    Accessors.TermAccessorLetBinding v1 -> (Just (Strings.cat2 (Core.unName v1) "="))
    Accessors.TermAccessorListElement v1 -> (idx v1)
    Accessors.TermAccessorMapKey v1 -> (idxSuff ".key" v1)
    Accessors.TermAccessorMapValue v1 -> (idxSuff ".value" v1)
    Accessors.TermAccessorOptionalTerm -> (Just "just")
    Accessors.TermAccessorProductTerm v1 -> (idx v1)
    Accessors.TermAccessorRecordField v1 -> (Just (Strings.cat2 "." (Core.unName v1)))
    Accessors.TermAccessorSetElement v1 -> (idx v1)
    Accessors.TermAccessorSumTerm -> Nothing
    Accessors.TermAccessorTypeLambdaBody -> Nothing
    Accessors.TermAccessorTypeApplicationTerm -> Nothing
    Accessors.TermAccessorInjectionTerm -> Nothing
    Accessors.TermAccessorWrappedTerm -> Nothing) accessor)

-- | Build an accessor graph from a term
termToAccessorGraph :: (M.Map Module.Namespace String -> Core.Term -> Accessors.AccessorGraph)
termToAccessorGraph namespaces term =  
  let dontCareAccessor = Accessors.TermAccessorAnnotatedSubject 
      helper = (\ids -> \mroot -> \path -> \state -> \accessorTerm ->  
              let accessor = (fst accessorTerm) 
                  currentTerm = (snd accessorTerm)
                  nodesEdges = (fst state)
                  visited = (snd state)
                  nodes = (fst nodesEdges)
                  edges = (snd nodesEdges)
                  nextPath = (Lists.cons accessor path)
              in ((\x -> case x of
                Core.TermLet v1 ->  
                  let bindings = (Core.letBindings v1) 
                      env = (Core.letEnvironment v1)
                      bindingNames = (Lists.map Core.bindingName bindings)
                      addBindingName = (\nodesVisitedIds -> \name ->  
                              let currentNodesVisited = (fst nodesVisitedIds) 
                                  currentIds = (snd nodesVisitedIds)
                                  currentNodes = (fst currentNodesVisited)
                                  currentVisited = (snd currentNodesVisited)
                                  rawLabel = (Names.compactName namespaces name)
                                  uniqueLabel = (Names.uniqueLabel currentVisited rawLabel)
                                  node = Accessors.AccessorNode {
                                          Accessors.accessorNodeName = name,
                                          Accessors.accessorNodeLabel = rawLabel,
                                          Accessors.accessorNodeId = uniqueLabel}
                                  newVisited = (Sets.insert uniqueLabel currentVisited)
                                  newNodes = (Lists.cons node currentNodes)
                                  newIds = (Maps.insert name node currentIds)
                              in ((newNodes, newVisited), newIds))
                      nodesVisitedIds1 = (Lists.foldl addBindingName (([], visited), ids) bindingNames)
                      nodes1 = (fst (fst nodesVisitedIds1))
                      visited1 = (snd (fst nodesVisitedIds1))
                      ids1 = (snd nodesVisitedIds1)
                      addBindingTerm = (\currentState -> \nodeBinding ->  
                              let root = (fst nodeBinding) 
                                  binding = (snd nodeBinding)
                                  term1 = (Core.bindingTerm binding)
                              in (helper ids1 (Just root) [] currentState (dontCareAccessor, term1)))
                      nodeBindingPairs = (Lists.zip nodes1 bindings)
                      stateAfterBindings = (Lists.foldl addBindingTerm ((Lists.concat2 nodes1 nodes, edges), visited1) nodeBindingPairs)
                  in (helper ids1 mroot nextPath stateAfterBindings (Accessors.TermAccessorLetEnvironment, env))
                Core.TermVariable v1 -> (Optionals.maybe state (\root -> Optionals.maybe state (\node ->  
                  let edge = Accessors.AccessorEdge {
                          Accessors.accessorEdgeSource = root,
                          Accessors.accessorEdgePath = (Accessors.AccessorPath (Lists.reverse nextPath)),
                          Accessors.accessorEdgeTarget = node} 
                      newEdges = (Lists.cons edge edges)
                  in ((nodes, newEdges), visited)) (Maps.lookup v1 ids)) mroot)
                _ -> (Lists.foldl (helper ids mroot nextPath) state (Rewriting.subtermsWithAccessors currentTerm))) currentTerm))
      initialState = (([], []), Sets.empty)
      result = (helper Maps.empty Nothing [] initialState (dontCareAccessor, term))
      finalNodesEdges = (fst result)
      finalNodes = (fst finalNodesEdges)
      finalEdges = (snd finalNodesEdges)
  in Accessors.AccessorGraph {
    Accessors.accessorGraphNodes = finalNodes,
    Accessors.accessorGraphEdges = finalEdges}