{-# LANGUAGE DefaultSignatures #-}

-- | Equality and rendering of 'AST's

module Language.Syntactic.Interpretation
    ( -- * Equality
      Equality (..)
      -- * Rendering
    , Render (..)
    , renderArgsSmart
    , render
    , StringTree (..)
    , stringTree
    , showAST
    , drawAST
    , writeHtmlAST
      -- * Default interpretation
    , equalDefault
    , hashDefault
    ) where



import Data.Tree (Tree (..))

import Data.Hash (Hash, combine, hashInt)
import qualified Data.Hash as Hash
import Data.Tree.View

import Language.Syntactic.Syntax



----------------------------------------------------------------------------------------------------
-- * Equality
----------------------------------------------------------------------------------------------------

-- | Higher-kinded equality
class Equality e
  where
    -- | Higher-kinded equality
    --
    -- Comparing elements of different types is often needed when dealing with expressions with
    -- existentially quantified sub-terms.
    equal :: e a -> e b -> Bool
    default equal :: Render e => e a -> e b -> Bool
    equal = e a -> e b -> Bool
forall (sym :: * -> *) a b. Render sym => sym a -> sym b -> Bool
equalDefault

    -- | Higher-kinded hashing. Elements that are equal according to 'equal' must result in the same
    -- hash:
    --
    -- @equal a b  ==>  hash a == hash b@
    hash :: e a -> Hash
    default hash :: Render e => e a -> Hash
    hash = e a -> Hash
forall (sym :: * -> *) a. Render sym => sym a -> Hash
hashDefault

instance Equality sym => Equality (AST sym)
  where
    equal :: AST sym a -> AST sym b -> Bool
equal (Sym sym a
s1)   (Sym sym b
s2)   = sym a -> sym b -> Bool
forall (e :: * -> *) a b. Equality e => e a -> e b -> Bool
equal sym a
s1 sym b
s2
    equal (AST sym (a :-> a)
s1 :$ AST sym (Full a)
a1) (AST sym (a :-> b)
s2 :$ AST sym (Full a)
a2) = AST sym (a :-> a) -> AST sym (a :-> b) -> Bool
forall (e :: * -> *) a b. Equality e => e a -> e b -> Bool
equal AST sym (a :-> a)
s1 AST sym (a :-> b)
s2 Bool -> Bool -> Bool
&& AST sym (Full a) -> AST sym (Full a) -> Bool
forall (e :: * -> *) a b. Equality e => e a -> e b -> Bool
equal AST sym (Full a)
a1 AST sym (Full a)
a2
    equal AST sym a
_ AST sym b
_                   = Bool
False

    hash :: AST sym a -> Hash
hash (Sym sym a
s)  = Int -> Hash
hashInt Int
0 Hash -> Hash -> Hash
`combine` sym a -> Hash
forall (e :: * -> *) a. Equality e => e a -> Hash
hash sym a
s
    hash (AST sym (a :-> a)
s :$ AST sym (Full a)
a) = Int -> Hash
hashInt Int
1 Hash -> Hash -> Hash
`combine` AST sym (a :-> a) -> Hash
forall (e :: * -> *) a. Equality e => e a -> Hash
hash AST sym (a :-> a)
s Hash -> Hash -> Hash
`combine` AST sym (Full a) -> Hash
forall (e :: * -> *) a. Equality e => e a -> Hash
hash AST sym (Full a)
a

instance Equality sym => Eq (AST sym a)
  where
    == :: AST sym a -> AST sym a -> Bool
(==) = AST sym a -> AST sym a -> Bool
forall (e :: * -> *) a b. Equality e => e a -> e b -> Bool
equal

instance (Equality sym1, Equality sym2) => Equality (sym1 :+: sym2)
  where
    equal :: (:+:) sym1 sym2 a -> (:+:) sym1 sym2 b -> Bool
equal (InjL sym1 a
a) (InjL sym1 b
b) = sym1 a -> sym1 b -> Bool
forall (e :: * -> *) a b. Equality e => e a -> e b -> Bool
equal sym1 a
a sym1 b
b
    equal (InjR sym2 a
a) (InjR sym2 b
b) = sym2 a -> sym2 b -> Bool
forall (e :: * -> *) a b. Equality e => e a -> e b -> Bool
equal sym2 a
a sym2 b
b
    equal (:+:) sym1 sym2 a
_ (:+:) sym1 sym2 b
_               = Bool
False

    hash :: (:+:) sym1 sym2 a -> Hash
hash (InjL sym1 a
a) = Int -> Hash
hashInt Int
0 Hash -> Hash -> Hash
`combine` sym1 a -> Hash
forall (e :: * -> *) a. Equality e => e a -> Hash
hash sym1 a
a
    hash (InjR sym2 a
a) = Int -> Hash
hashInt Int
1 Hash -> Hash -> Hash
`combine` sym2 a -> Hash
forall (e :: * -> *) a. Equality e => e a -> Hash
hash sym2 a
a

instance (Equality sym1, Equality sym2) => Eq ((sym1 :+: sym2) a)
  where
    == :: (:+:) sym1 sym2 a -> (:+:) sym1 sym2 a -> Bool
(==) = (:+:) sym1 sym2 a -> (:+:) sym1 sym2 a -> Bool
forall (e :: * -> *) a b. Equality e => e a -> e b -> Bool
equal

instance Equality Empty
  where
    equal :: Empty a -> Empty b -> Bool
equal = [Char] -> Empty a -> Empty b -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"equal: Empty"
    hash :: Empty a -> Hash
hash  = [Char] -> Empty a -> Hash
forall a. HasCallStack => [Char] -> a
error [Char]
"hash: Empty"

instance Equality sym => Equality (Typed sym)
  where
    equal :: Typed sym a -> Typed sym b -> Bool
equal (Typed sym a
s1) (Typed sym b
s2) = sym a -> sym b -> Bool
forall (e :: * -> *) a b. Equality e => e a -> e b -> Bool
equal sym a
s1 sym b
s2
    hash :: Typed sym a -> Hash
hash (Typed sym a
s) = sym a -> Hash
forall (e :: * -> *) a. Equality e => e a -> Hash
hash sym a
s



----------------------------------------------------------------------------------------------------
-- * Rendering
----------------------------------------------------------------------------------------------------

-- | Render a symbol as concrete syntax. A complete instance must define at least the 'renderSym'
-- method.
class Render sym
  where
    -- | Show a symbol as a 'String'
    renderSym :: sym sig -> String

    -- | Render a symbol given a list of rendered arguments
    renderArgs :: [String] -> sym sig -> String
    renderArgs []   sym sig
s = sym sig -> [Char]
forall (sym :: * -> *) sig. Render sym => sym sig -> [Char]
renderSym sym sig
s
    renderArgs [[Char]]
args sym sig
s = [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords (sym sig -> [Char]
forall (sym :: * -> *) sig. Render sym => sym sig -> [Char]
renderSym sym sig
s [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"

instance (Render sym1, Render sym2) => Render (sym1 :+: sym2)
  where
    renderSym :: (:+:) sym1 sym2 sig -> [Char]
renderSym (InjL sym1 sig
s) = sym1 sig -> [Char]
forall (sym :: * -> *) sig. Render sym => sym sig -> [Char]
renderSym sym1 sig
s
    renderSym (InjR sym2 sig
s) = sym2 sig -> [Char]
forall (sym :: * -> *) sig. Render sym => sym sig -> [Char]
renderSym sym2 sig
s
    renderArgs :: [[Char]] -> (:+:) sym1 sym2 sig -> [Char]
renderArgs [[Char]]
args (InjL sym1 sig
s) = [[Char]] -> sym1 sig -> [Char]
forall (sym :: * -> *) sig.
Render sym =>
[[Char]] -> sym sig -> [Char]
renderArgs [[Char]]
args sym1 sig
s
    renderArgs [[Char]]
args (InjR sym2 sig
s) = [[Char]] -> sym2 sig -> [Char]
forall (sym :: * -> *) sig.
Render sym =>
[[Char]] -> sym sig -> [Char]
renderArgs [[Char]]
args sym2 sig
s

-- | Implementation of 'renderArgs' that handles infix operators
renderArgsSmart :: Render sym => [String] -> sym a -> String
renderArgsSmart :: [[Char]] -> sym a -> [Char]
renderArgsSmart []   sym a
sym = sym a -> [Char]
forall (sym :: * -> *) sig. Render sym => sym sig -> [Char]
renderSym sym a
sym
renderArgsSmart [[Char]]
args sym a
sym
    | Bool
isInfix   = [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords [[Char]
a,[Char]
op,[Char]
b] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
    | Bool
otherwise = [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ([Char]
name [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
  where
    name :: [Char]
name  = sym a -> [Char]
forall (sym :: * -> *) sig. Render sym => sym sig -> [Char]
renderSym sym a
sym
    [[Char]
a,[Char]
b] = [[Char]]
args
    op :: [Char]
op    = [Char] -> [Char]
forall a. [a] -> [a]
init ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
tail [Char]
name
    isInfix :: Bool
isInfix
      =  Bool -> Bool
not ([Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
name)
      Bool -> Bool -> Bool
&& [Char] -> Char
forall a. [a] -> a
head [Char]
name Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'('
      Bool -> Bool -> Bool
&& [Char] -> Char
forall a. [a] -> a
last [Char]
name Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')'
      Bool -> Bool -> Bool
&& [[Char]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2

-- | Render an 'AST' as concrete syntax
render :: forall sym a. Render sym => ASTF sym a -> String
render :: ASTF sym a -> [Char]
render = [[Char]] -> ASTF sym a -> [Char]
forall sig. [[Char]] -> AST sym sig -> [Char]
go []
  where
    go :: [String] -> AST sym sig -> String
    go :: [[Char]] -> AST sym sig -> [Char]
go [[Char]]
args (Sym sym sig
s)  = [[Char]] -> sym sig -> [Char]
forall (sym :: * -> *) sig.
Render sym =>
[[Char]] -> sym sig -> [Char]
renderArgs [[Char]]
args sym sig
s
    go [[Char]]
args (AST sym (a :-> sig)
s :$ AST sym (Full a)
a) = [[Char]] -> AST sym (a :-> sig) -> [Char]
forall sig. [[Char]] -> AST sym sig -> [Char]
go (AST sym (Full a) -> [Char]
forall (sym :: * -> *) a. Render sym => ASTF sym a -> [Char]
render AST sym (Full a)
a [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
args) AST sym (a :-> sig)
s

instance Render Empty
  where
    renderSym :: Empty sig -> [Char]
renderSym  = [Char] -> Empty sig -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"renderSym: Empty"
    renderArgs :: [[Char]] -> Empty sig -> [Char]
renderArgs = [Char] -> [[Char]] -> Empty sig -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"renderArgs: Empty"

instance Render sym => Render (Typed sym)
  where
    renderSym :: Typed sym sig -> [Char]
renderSym (Typed sym sig
s)  = sym sig -> [Char]
forall (sym :: * -> *) sig. Render sym => sym sig -> [Char]
renderSym sym sig
s
    renderArgs :: [[Char]] -> Typed sym sig -> [Char]
renderArgs [[Char]]
args (Typed sym sig
s) = [[Char]] -> sym sig -> [Char]
forall (sym :: * -> *) sig.
Render sym =>
[[Char]] -> sym sig -> [Char]
renderArgs [[Char]]
args sym sig
s

instance Render sym => Show (ASTF sym a)
  where
    show :: ASTF sym a -> [Char]
show = ASTF sym a -> [Char]
forall (sym :: * -> *) a. Render sym => ASTF sym a -> [Char]
render



-- | Convert a symbol to a 'Tree' of strings
class Render sym => StringTree sym
  where
    -- | Convert a symbol to a 'Tree' given a list of argument trees
    stringTreeSym :: [Tree String] -> sym a -> Tree String
    stringTreeSym [Tree [Char]]
args sym a
s = [Char] -> [Tree [Char]] -> Tree [Char]
forall a. a -> Forest a -> Tree a
Node (sym a -> [Char]
forall (sym :: * -> *) sig. Render sym => sym sig -> [Char]
renderSym sym a
s) [Tree [Char]]
args

instance (StringTree sym1, StringTree sym2) => StringTree (sym1 :+: sym2)
  where
    stringTreeSym :: [Tree [Char]] -> (:+:) sym1 sym2 a -> Tree [Char]
stringTreeSym [Tree [Char]]
args (InjL sym1 a
s) = [Tree [Char]] -> sym1 a -> Tree [Char]
forall (sym :: * -> *) a.
StringTree sym =>
[Tree [Char]] -> sym a -> Tree [Char]
stringTreeSym [Tree [Char]]
args sym1 a
s
    stringTreeSym [Tree [Char]]
args (InjR sym2 a
s) = [Tree [Char]] -> sym2 a -> Tree [Char]
forall (sym :: * -> *) a.
StringTree sym =>
[Tree [Char]] -> sym a -> Tree [Char]
stringTreeSym [Tree [Char]]
args sym2 a
s

instance StringTree Empty

instance StringTree sym => StringTree (Typed sym)
  where
    stringTreeSym :: [Tree [Char]] -> Typed sym a -> Tree [Char]
stringTreeSym [Tree [Char]]
args (Typed sym a
s) = [Tree [Char]] -> sym a -> Tree [Char]
forall (sym :: * -> *) a.
StringTree sym =>
[Tree [Char]] -> sym a -> Tree [Char]
stringTreeSym [Tree [Char]]
args sym a
s

-- | Convert an 'AST' to a 'Tree' of strings
stringTree :: forall sym a . StringTree sym => ASTF sym a -> Tree String
stringTree :: ASTF sym a -> Tree [Char]
stringTree = [Tree [Char]] -> ASTF sym a -> Tree [Char]
forall sig. [Tree [Char]] -> AST sym sig -> Tree [Char]
go []
  where
    go :: [Tree String] -> AST sym sig -> Tree String
    go :: [Tree [Char]] -> AST sym sig -> Tree [Char]
go [Tree [Char]]
args (Sym sym sig
s)  = [Tree [Char]] -> sym sig -> Tree [Char]
forall (sym :: * -> *) a.
StringTree sym =>
[Tree [Char]] -> sym a -> Tree [Char]
stringTreeSym [Tree [Char]]
args sym sig
s
    go [Tree [Char]]
args (AST sym (a :-> sig)
s :$ AST sym (Full a)
a) = [Tree [Char]] -> AST sym (a :-> sig) -> Tree [Char]
forall sig. [Tree [Char]] -> AST sym sig -> Tree [Char]
go (AST sym (Full a) -> Tree [Char]
forall (sym :: * -> *) a.
StringTree sym =>
ASTF sym a -> Tree [Char]
stringTree AST sym (Full a)
a Tree [Char] -> [Tree [Char]] -> [Tree [Char]]
forall a. a -> [a] -> [a]
: [Tree [Char]]
args) AST sym (a :-> sig)
s

-- | Show a syntax tree using ASCII art
showAST :: StringTree sym => ASTF sym a -> String
showAST :: ASTF sym a -> [Char]
showAST = Tree [Char] -> [Char]
showTree (Tree [Char] -> [Char])
-> (ASTF sym a -> Tree [Char]) -> ASTF sym a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTF sym a -> Tree [Char]
forall (sym :: * -> *) a.
StringTree sym =>
ASTF sym a -> Tree [Char]
stringTree

-- | Print a syntax tree using ASCII art
drawAST :: StringTree sym => ASTF sym a -> IO ()
drawAST :: ASTF sym a -> IO ()
drawAST = [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> (ASTF sym a -> [Char]) -> ASTF sym a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTF sym a -> [Char]
forall (sym :: * -> *) a. StringTree sym => ASTF sym a -> [Char]
showAST

-- | Write a syntax tree to an HTML file with foldable nodes
writeHtmlAST :: StringTree sym => FilePath -> ASTF sym a -> IO ()
writeHtmlAST :: [Char] -> ASTF sym a -> IO ()
writeHtmlAST [Char]
file
    = Maybe [Char] -> [Char] -> Tree NodeInfo -> IO ()
writeHtmlTree Maybe [Char]
forall a. Maybe a
Nothing [Char]
file
    (Tree NodeInfo -> IO ())
-> (ASTF sym a -> Tree NodeInfo) -> ASTF sym a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> NodeInfo) -> Tree [Char] -> Tree NodeInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Char]
n -> Behavior -> [Char] -> [Char] -> NodeInfo
NodeInfo Behavior
InitiallyExpanded [Char]
n [Char]
"") (Tree [Char] -> Tree NodeInfo)
-> (ASTF sym a -> Tree [Char]) -> ASTF sym a -> Tree NodeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTF sym a -> Tree [Char]
forall (sym :: * -> *) a.
StringTree sym =>
ASTF sym a -> Tree [Char]
stringTree



----------------------------------------------------------------------------------------------------
-- * Default interpretation
----------------------------------------------------------------------------------------------------

-- | Default implementation of 'equal'
equalDefault :: Render sym => sym a -> sym b -> Bool
equalDefault :: sym a -> sym b -> Bool
equalDefault sym a
a sym b
b = sym a -> [Char]
forall (sym :: * -> *) sig. Render sym => sym sig -> [Char]
renderSym sym a
a [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== sym b -> [Char]
forall (sym :: * -> *) sig. Render sym => sym sig -> [Char]
renderSym sym b
b

-- | Default implementation of 'hash'
hashDefault :: Render sym => sym a -> Hash
hashDefault :: sym a -> Hash
hashDefault = [Char] -> Hash
forall a. Hashable a => a -> Hash
Hash.hash ([Char] -> Hash) -> (sym a -> [Char]) -> sym a -> Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sym a -> [Char]
forall (sym :: * -> *) sig. Render sym => sym sig -> [Char]
renderSym