{-# LANGUAGE DefaultSignatures #-}
module Language.Syntactic.Interpretation.Render
( Render (..)
, renderSymDefault
, renderArgsDefault
, render
, StringTree (..)
, stringTree
, showAST
, drawAST
, writeHtmlAST
) where
import Data.Tree (Tree (..))
import Data.Tree.View
import Language.Syntactic.Syntax
import Language.Syntactic.Interpretation.Semantics
class Render dom
where
renderSym :: dom sig -> String
renderArgs :: [String] -> dom sig -> String
renderArgs [] a = renderSym a
renderArgs args a = "(" ++ unwords (renderSym a : args) ++ ")"
{-# INLINABLE renderArgs #-}
default renderSym :: Semantic dom => dom sig -> String
renderSym = renderSymDefault
{-# INLINABLE renderSym #-}
renderSymDefault :: Semantic expr => expr a -> String
renderSymDefault = renderSym . semantics
{-# INLINABLE renderSymDefault #-}
renderArgsDefault :: Semantic expr => [String] -> expr a -> String
renderArgsDefault args = renderArgs args . semantics
{-# INLINABLE renderArgsDefault #-}
instance Render Semantics
where
{-# INLINABLE renderSym #-}
{-# INLINABLE renderArgs #-}
renderSym (Sem name _) = name
renderArgs [] (Sem name _) = name
renderArgs args (Sem name _)
| isInfix = "(" ++ unwords [a,op,b] ++ ")"
| otherwise = "(" ++ unwords (name : args) ++ ")"
where
[a,b] = args
op = init $ tail name
isInfix
= not (null name)
&& head name == '('
&& last name == ')'
&& length args == 2
instance (Render expr1, Render expr2) => Render (expr1 :+: expr2)
where
{-# SPECIALIZE instance (Render expr1, Render expr2) => Render (expr1 :+: expr2) #-}
{-# INLINABLE renderSym #-}
{-# INLINABLE renderArgs #-}
renderSym (InjL a) = renderSym a
renderSym (InjR a) = renderSym a
renderArgs args (InjL a) = renderArgs args a
renderArgs args (InjR a) = renderArgs args a
render :: forall dom a. Render dom => ASTF dom a -> String
render = go []
where
go :: [String] -> AST dom sig -> String
go args (Sym a) = renderArgs args a
go args (s :$ a) = go (render a : args) s
{-# INLINABLE render #-}
instance Render dom => Show (ASTF dom a)
where
{-# SPECIALIZE instance Render dom => Show (ASTF dom a) #-}
show = render
class Render dom => StringTree dom
where
stringTreeSym :: [Tree String] -> dom a -> Tree String
stringTreeSym args a = Node (renderSym a) args
{-# INLINABLE stringTreeSym #-}
instance (StringTree dom1, StringTree dom2) => StringTree (dom1 :+: dom2)
where
{-# SPECIALIZE instance (StringTree dom1, StringTree dom2) => StringTree (dom1 :+: dom2) #-}
{-# INLINABLE stringTreeSym #-}
stringTreeSym args (InjL a) = stringTreeSym args a
stringTreeSym args (InjR a) = stringTreeSym args a
stringTree :: forall dom a . StringTree dom => ASTF dom a -> Tree String
stringTree = go []
where
go :: [Tree String] -> AST dom sig -> Tree String
go args (Sym a) = stringTreeSym args a
go args (s :$ a) = go (go [] a : args) s
{-# INLINABLE stringTree #-}
showAST :: StringTree dom => ASTF dom a -> String
showAST = showTree . stringTree
{-# INLINABLE showAST #-}
drawAST :: StringTree dom => ASTF dom a -> IO ()
drawAST = putStrLn . showAST
{-# INLINABLE drawAST #-}
writeHtmlAST :: StringTree sym => FilePath -> ASTF sym a -> IO ()
writeHtmlAST file = writeHtmlTree Nothing file . fmap (\n -> NodeInfo InitiallyExpanded n "") . stringTree
{-# INLINABLE writeHtmlAST #-}