-- | Utilities for working with term accessors

module Hydra.Tools.Accessors where

import Hydra.Kernel

import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Maybe as Y


type AccessorPath = [TermAccessor]
data AccessorNode = AccessorNode Name String String deriving Int -> AccessorNode -> ShowS
[AccessorNode] -> ShowS
AccessorNode -> String
(Int -> AccessorNode -> ShowS)
-> (AccessorNode -> String)
-> ([AccessorNode] -> ShowS)
-> Show AccessorNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AccessorNode -> ShowS
showsPrec :: Int -> AccessorNode -> ShowS
$cshow :: AccessorNode -> String
show :: AccessorNode -> String
$cshowList :: [AccessorNode] -> ShowS
showList :: [AccessorNode] -> ShowS
Show
data AccessorEdge = AccessorEdge AccessorNode AccessorPath AccessorNode deriving Int -> AccessorEdge -> ShowS
[AccessorEdge] -> ShowS
AccessorEdge -> String
(Int -> AccessorEdge -> ShowS)
-> (AccessorEdge -> String)
-> ([AccessorEdge] -> ShowS)
-> Show AccessorEdge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AccessorEdge -> ShowS
showsPrec :: Int -> AccessorEdge -> ShowS
$cshow :: AccessorEdge -> String
show :: AccessorEdge -> String
$cshowList :: [AccessorEdge] -> ShowS
showList :: [AccessorEdge] -> ShowS
Show
data AccessorGraph = AccessorGraph [AccessorNode] [AccessorEdge] deriving Int -> AccessorGraph -> ShowS
[AccessorGraph] -> ShowS
AccessorGraph -> String
(Int -> AccessorGraph -> ShowS)
-> (AccessorGraph -> String)
-> ([AccessorGraph] -> ShowS)
-> Show AccessorGraph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AccessorGraph -> ShowS
showsPrec :: Int -> AccessorGraph -> ShowS
$cshow :: AccessorGraph -> String
show :: AccessorGraph -> String
$cshowList :: [AccessorGraph] -> ShowS
showList :: [AccessorGraph] -> ShowS
Show

showTermAccessor :: TermAccessor -> Maybe String
showTermAccessor :: TermAccessor -> Maybe String
showTermAccessor TermAccessor
accessor = case TermAccessor
accessor of
   TermAccessor
TermAccessorAnnotatedSubject -> Maybe String
forall a. Maybe a
Nothing
   TermAccessor
TermAccessorApplicationFunction -> String -> Maybe String
forall a. a -> Maybe a
Just String
"fun"
   TermAccessor
TermAccessorApplicationArgument -> String -> Maybe String
forall a. a -> Maybe a
Just String
"arg"
   TermAccessor
TermAccessorLambdaBody -> String -> Maybe String
forall a. a -> Maybe a
Just String
"body"
   TermAccessor
TermAccessorListFold -> Maybe String
forall a. Maybe a
Nothing
   TermAccessor
TermAccessorOptionalCasesNothing -> String -> Maybe String
forall a. a -> Maybe a
Just String
"nothing"
   TermAccessor
TermAccessorOptionalCasesJust -> String -> Maybe String
forall a. a -> Maybe a
Just String
"just"
   TermAccessor
TermAccessorUnionCasesDefault -> String -> Maybe String
forall a. a -> Maybe a
Just String
"default"
   TermAccessorUnionCasesBranch Name
name -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
name
   TermAccessor
TermAccessorLetEnvironment -> String -> Maybe String
forall a. a -> Maybe a
Just String
"in"
   TermAccessorLetBinding Name
name -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Name -> String
unName Name
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"="
   TermAccessorListElement Int
i -> Int -> Maybe String
forall {p} {a}. p -> Maybe a
idx Int
i
   TermAccessorMapKey Int
i -> String -> Int -> Maybe String
forall {a} {p}. [a] -> p -> Maybe [a]
idxSuff String
".key" Int
i
   TermAccessorMapValue Int
i -> String -> Int -> Maybe String
forall {a} {p}. [a] -> p -> Maybe [a]
idxSuff String
".value" Int
i
   TermAccessor
TermAccessorOptionalTerm -> String -> Maybe String
forall a. a -> Maybe a
Just String
"just"
   TermAccessorProductTerm Int
i -> Int -> Maybe String
forall {p} {a}. p -> Maybe a
idx Int
i
   TermAccessorRecordField Name
name -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
unName Name
name
   TermAccessorSetElement Int
i -> Int -> Maybe String
forall {p} {a}. p -> Maybe a
idx Int
i
   TermAccessor
TermAccessorSumTerm -> Maybe String
forall a. Maybe a
Nothing
   TermAccessor
TermAccessorTypeAbstractionBody -> Maybe String
forall a. Maybe a
Nothing
   TermAccessor
TermAccessorTypeApplicationTerm -> Maybe String
forall a. Maybe a
Nothing
   TermAccessor
TermAccessorTypedTerm -> Maybe String
forall a. Maybe a
Nothing
   TermAccessor
TermAccessorInjectionTerm -> Maybe String
forall a. Maybe a
Nothing
   TermAccessor
TermAccessorWrappedTerm -> Maybe String
forall a. Maybe a
Nothing
  where
--    idx i = Just $ "[" ++ show i ++ "]" -- TODO: restore this
    idx :: p -> Maybe a
idx p
i = Maybe a
forall a. Maybe a
Nothing
    idxSuff :: [a] -> p -> Maybe [a]
idxSuff [a]
suffix p
i = Maybe [a] -> ([a] -> Maybe [a]) -> Maybe [a] -> Maybe [a]
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe ([a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
suffix) [a] -> Maybe [a]
forall a. a -> Maybe a
Just (Maybe [a] -> Maybe [a]) -> Maybe [a] -> Maybe [a]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[a]
s -> [a]
s [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
suffix) (Maybe [a] -> Maybe [a]) -> Maybe [a] -> Maybe [a]
forall a b. (a -> b) -> a -> b
$ p -> Maybe [a]
forall {p} {a}. p -> Maybe a
idx p
i

termToAccessorGraph :: M.Map Namespace String -> Term -> AccessorGraph
termToAccessorGraph :: Map Namespace String -> Term -> AccessorGraph
termToAccessorGraph Map Namespace String
namespaces Term
term = [AccessorNode] -> [AccessorEdge] -> AccessorGraph
AccessorGraph [AccessorNode]
nodesX [AccessorEdge]
edgesX
  where
    ([AccessorNode]
nodesX, [AccessorEdge]
edgesX, Set String
_) = Map Name AccessorNode
-> Maybe AccessorNode
-> AccessorPath
-> ([AccessorNode], [AccessorEdge], Set String)
-> (TermAccessor, Term)
-> ([AccessorNode], [AccessorEdge], Set String)
helper Map Name AccessorNode
forall k a. Map k a
M.empty Maybe AccessorNode
forall a. Maybe a
Nothing [] ([], [], Set String
forall a. Set a
S.empty) (TermAccessor
dontCareAccessor, Term
term)
    dontCareAccessor :: TermAccessor
dontCareAccessor = TermAccessor
TermAccessorAnnotatedSubject
    helper :: Map Name AccessorNode
-> Maybe AccessorNode
-> AccessorPath
-> ([AccessorNode], [AccessorEdge], Set String)
-> (TermAccessor, Term)
-> ([AccessorNode], [AccessorEdge], Set String)
helper Map Name AccessorNode
ids Maybe AccessorNode
mroot AccessorPath
path ([AccessorNode]
nodes, [AccessorEdge]
edges, Set String
visited) (TermAccessor
accessor, Term
term) = case Term
term of
        TermLet (Let [LetBinding]
bindings Term
env) -> Map Name AccessorNode
-> Maybe AccessorNode
-> AccessorPath
-> ([AccessorNode], [AccessorEdge], Set String)
-> (TermAccessor, Term)
-> ([AccessorNode], [AccessorEdge], Set String)
helper Map Name AccessorNode
ids1 Maybe AccessorNode
mroot AccessorPath
nextPath ([AccessorNode]
nodes2, [AccessorEdge]
edges2, Set String
visited2) (TermAccessor
TermAccessorLetEnvironment, Term
env)
          where
            ([AccessorNode]
nodes2, [AccessorEdge]
edges2, Set String
visited2) = (([AccessorNode], [AccessorEdge], Set String)
 -> (AccessorNode, LetBinding)
 -> ([AccessorNode], [AccessorEdge], Set String))
-> ([AccessorNode], [AccessorEdge], Set String)
-> [(AccessorNode, LetBinding)]
-> ([AccessorNode], [AccessorEdge], Set String)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl ([AccessorNode], [AccessorEdge], Set String)
-> (AccessorNode, LetBinding)
-> ([AccessorNode], [AccessorEdge], Set String)
addBinding ([AccessorNode]
nodes1[AccessorNode] -> [AccessorNode] -> [AccessorNode]
forall a. [a] -> [a] -> [a]
++[AccessorNode]
nodes, [AccessorEdge]
edges, Set String
visited1) ([AccessorNode] -> [LetBinding] -> [(AccessorNode, LetBinding)]
forall a b. [a] -> [b] -> [(a, b)]
L.zip [AccessorNode]
nodes1 [LetBinding]
bindings)
              where
                addBinding :: ([AccessorNode], [AccessorEdge], Set String)
-> (AccessorNode, LetBinding)
-> ([AccessorNode], [AccessorEdge], Set String)
addBinding ([AccessorNode]
nodes, [AccessorEdge]
edges, Set String
visited) (AccessorNode
root, (LetBinding Name
name Term
term1 Maybe TypeScheme
_))
                    = Map Name AccessorNode
-> Maybe AccessorNode
-> AccessorPath
-> ([AccessorNode], [AccessorEdge], Set String)
-> (TermAccessor, Term)
-> ([AccessorNode], [AccessorEdge], Set String)
helper Map Name AccessorNode
ids1 (AccessorNode -> Maybe AccessorNode
forall a. a -> Maybe a
Just AccessorNode
root) [] ([AccessorNode]
nodes, [AccessorEdge]
edges, Set String
visited) (TermAccessor
dontCareAccessor, Term
term1)
            ([AccessorNode]
nodes1, Set String
visited1, Map Name AccessorNode
ids1) = (([AccessorNode], Set String, Map Name AccessorNode)
 -> Name -> ([AccessorNode], Set String, Map Name AccessorNode))
-> ([AccessorNode], Set String, Map Name AccessorNode)
-> [Name]
-> ([AccessorNode], Set String, Map Name AccessorNode)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl ([AccessorNode], Set String, Map Name AccessorNode)
-> Name -> ([AccessorNode], Set String, Map Name AccessorNode)
addBinding ([], Set String
visited, Map Name AccessorNode
ids) (LetBinding -> Name
letBindingName (LetBinding -> Name) -> [LetBinding] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LetBinding]
bindings)
              where
                addBinding :: ([AccessorNode], Set String, Map Name AccessorNode)
-> Name -> ([AccessorNode], Set String, Map Name AccessorNode)
addBinding ([AccessorNode]
nodes, Set String
visited, Map Name AccessorNode
ids) Name
name =
                    ((AccessorNode
nodeAccessorNode -> [AccessorNode] -> [AccessorNode]
forall a. a -> [a] -> [a]
:[AccessorNode]
nodes), String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.insert String
uniqueLabel Set String
visited, Name
-> AccessorNode -> Map Name AccessorNode -> Map Name AccessorNode
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name AccessorNode
node Map Name AccessorNode
ids)
                  where
                    node :: AccessorNode
node = Name -> String -> String -> AccessorNode
AccessorNode Name
name String
rawLabel String
uniqueLabel
                    rawLabel :: String
rawLabel = Map Namespace String -> Name -> String
toCompactName Map Namespace String
namespaces Name
name
                    uniqueLabel :: String
uniqueLabel = Set String -> ShowS
toUniqueLabel Set String
visited String
rawLabel
        TermVariable Name
name -> case Maybe AccessorNode
mroot of
          Maybe AccessorNode
Nothing -> ([AccessorNode]
nodes, [AccessorEdge]
edges, Set String
visited)
          Just AccessorNode
root -> case Name -> Map Name AccessorNode -> Maybe AccessorNode
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name Map Name AccessorNode
ids of
            Maybe AccessorNode
Nothing -> ([AccessorNode]
nodes, [AccessorEdge]
edges, Set String
visited)
            Just AccessorNode
node -> ([AccessorNode]
nodes, AccessorEdge
edgeAccessorEdge -> [AccessorEdge] -> [AccessorEdge]
forall a. a -> [a] -> [a]
:[AccessorEdge]
edges, Set String
visited)
              where
                edge :: AccessorEdge
edge = AccessorNode -> AccessorPath -> AccessorNode -> AccessorEdge
AccessorEdge AccessorNode
root (AccessorPath -> AccessorPath
forall a. [a] -> [a]
L.reverse AccessorPath
nextPath) AccessorNode
node
        Term
_ -> (([AccessorNode], [AccessorEdge], Set String)
 -> (TermAccessor, Term)
 -> ([AccessorNode], [AccessorEdge], Set String))
-> ([AccessorNode], [AccessorEdge], Set String)
-> [(TermAccessor, Term)]
-> ([AccessorNode], [AccessorEdge], Set String)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl (Map Name AccessorNode
-> Maybe AccessorNode
-> AccessorPath
-> ([AccessorNode], [AccessorEdge], Set String)
-> (TermAccessor, Term)
-> ([AccessorNode], [AccessorEdge], Set String)
helper Map Name AccessorNode
ids Maybe AccessorNode
mroot AccessorPath
nextPath) ([AccessorNode]
nodes, [AccessorEdge]
edges, Set String
visited) ([(TermAccessor, Term)]
 -> ([AccessorNode], [AccessorEdge], Set String))
-> [(TermAccessor, Term)]
-> ([AccessorNode], [AccessorEdge], Set String)
forall a b. (a -> b) -> a -> b
$ Term -> [(TermAccessor, Term)]
subtermsWithAccessors Term
term
      where
        nextPath :: AccessorPath
nextPath = TermAccessor
accessorTermAccessor -> AccessorPath -> AccessorPath
forall a. a -> [a] -> [a]
:AccessorPath
path

toUniqueLabel :: S.Set String -> String -> String
toUniqueLabel :: Set String -> ShowS
toUniqueLabel Set String
visited String
l = if String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member String
l Set String
visited then Set String -> ShowS
toUniqueLabel Set String
visited (String
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'") else String
l