{-# LANGUAGE CPP #-}

#ifndef MIN_VERSION_GLASGOW_HASKELL
#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) 0
#endif
  -- MIN_VERSION_GLASGOW_HASKELL was introduced in GHC 7.10

#if MIN_VERSION_GLASGOW_HASKELL(7,10,0,0)
#else
{-# LANGUAGE OverlappingInstances #-}
#endif

-- | Construct for decorating symbols or expressions with additional information

module Language.Syntactic.Decoration where



import Data.Tree (Tree (..))

import Data.Tree.View

import Language.Syntactic.Syntax
import Language.Syntactic.Traversal
import Language.Syntactic.Interpretation
import Language.Syntactic.Sugar



-- | Decorating symbols or expressions with additional information
--
-- One usage of ':&:' is to decorate every node of a syntax tree. This is done
-- simply by changing
--
-- > AST sym sig
--
-- to
--
-- > AST (sym :&: info) sig
data (expr :&: info) sig
  where
    (:&:)
        :: { (:&:) expr info sig -> expr sig
decorExpr :: expr sig
           , (:&:) expr info sig -> info (DenResult sig)
decorInfo :: info (DenResult sig)
           }
        -> (expr :&: info) sig

instance Symbol sym => Symbol (sym :&: info)
  where
    symSig :: (:&:) sym info sig -> SigRep sig
symSig = sym sig -> SigRep sig
forall (sym :: * -> *) sig. Symbol sym => sym sig -> SigRep sig
symSig (sym sig -> SigRep sig)
-> ((:&:) sym info sig -> sym sig)
-> (:&:) sym info sig
-> SigRep sig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:&:) sym info sig -> sym sig
forall (expr :: * -> *) (info :: * -> *) sig.
(:&:) expr info sig -> expr sig
decorExpr

instance (NFData1 sym, NFData1 info) => NFData1 (sym :&: info)
  where
    rnf1 :: (:&:) sym info a -> ()
rnf1 (sym a
s :&: info (DenResult a)
i) = sym a -> ()
forall (c :: * -> *) a. NFData1 c => c a -> ()
rnf1 sym a
s () -> () -> ()
`seq` info (DenResult a) -> ()
forall (c :: * -> *) a. NFData1 c => c a -> ()
rnf1 info (DenResult a)
i () -> () -> ()
`seq` ()

instance Project sub sup => Project sub (sup :&: info)
  where
    prj :: (:&:) sup info a -> Maybe (sub a)
prj = sup a -> Maybe (sub a)
forall (sub :: * -> *) (sup :: * -> *) a.
Project sub sup =>
sup a -> Maybe (sub a)
prj (sup a -> Maybe (sub a))
-> ((:&:) sup info a -> sup a) -> (:&:) sup info a -> Maybe (sub a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:&:) sup info a -> sup a
forall (expr :: * -> *) (info :: * -> *) sig.
(:&:) expr info sig -> expr sig
decorExpr

instance Equality expr => Equality (expr :&: info)
  where
    equal :: (:&:) expr info a -> (:&:) expr info b -> Bool
equal (:&:) expr info a
a (:&:) expr info b
b = (:&:) expr info a -> expr a
forall (expr :: * -> *) (info :: * -> *) sig.
(:&:) expr info sig -> expr sig
decorExpr (:&:) expr info a
a expr a -> expr b -> Bool
forall (e :: * -> *) a b. Equality e => e a -> e b -> Bool
`equal` (:&:) expr info b -> expr b
forall (expr :: * -> *) (info :: * -> *) sig.
(:&:) expr info sig -> expr sig
decorExpr (:&:) expr info b
b
    hash :: (:&:) expr info a -> Hash
hash      = expr a -> Hash
forall (e :: * -> *) a. Equality e => e a -> Hash
hash (expr a -> Hash)
-> ((:&:) expr info a -> expr a) -> (:&:) expr info a -> Hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:&:) expr info a -> expr a
forall (expr :: * -> *) (info :: * -> *) sig.
(:&:) expr info sig -> expr sig
decorExpr

instance Render expr => Render (expr :&: info)
  where
    renderSym :: (:&:) expr info sig -> String
renderSym       = expr sig -> String
forall (sym :: * -> *) sig. Render sym => sym sig -> String
renderSym (expr sig -> String)
-> ((:&:) expr info sig -> expr sig)
-> (:&:) expr info sig
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:&:) expr info sig -> expr sig
forall (expr :: * -> *) (info :: * -> *) sig.
(:&:) expr info sig -> expr sig
decorExpr
    renderArgs :: [String] -> (:&:) expr info sig -> String
renderArgs [String]
args = [String] -> expr sig -> String
forall (sym :: * -> *) sig.
Render sym =>
[String] -> sym sig -> String
renderArgs [String]
args (expr sig -> String)
-> ((:&:) expr info sig -> expr sig)
-> (:&:) expr info sig
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:&:) expr info sig -> expr sig
forall (expr :: * -> *) (info :: * -> *) sig.
(:&:) expr info sig -> expr sig
decorExpr

instance StringTree expr => StringTree (expr :&: info)
  where
    stringTreeSym :: [Tree String] -> (:&:) expr info a -> Tree String
stringTreeSym [Tree String]
args = [Tree String] -> expr a -> Tree String
forall (sym :: * -> *) a.
StringTree sym =>
[Tree String] -> sym a -> Tree String
stringTreeSym [Tree String]
args (expr a -> Tree String)
-> ((:&:) expr info a -> expr a)
-> (:&:) expr info a
-> Tree String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:&:) expr info a -> expr a
forall (expr :: * -> *) (info :: * -> *) sig.
(:&:) expr info sig -> expr sig
decorExpr



-- | Map over a decoration
mapDecor
    :: (sym1 sig -> sym2 sig)
    -> (info1 (DenResult sig) -> info2 (DenResult sig))
    -> ((sym1 :&: info1) sig -> (sym2 :&: info2) sig)
mapDecor :: (sym1 sig -> sym2 sig)
-> (info1 (DenResult sig) -> info2 (DenResult sig))
-> (:&:) sym1 info1 sig
-> (:&:) sym2 info2 sig
mapDecor sym1 sig -> sym2 sig
fs info1 (DenResult sig) -> info2 (DenResult sig)
fi (sym1 sig
s :&: info1 (DenResult sig)
i) = sym1 sig -> sym2 sig
fs sym1 sig
s sym2 sig -> info2 (DenResult sig) -> (:&:) sym2 info2 sig
forall (expr :: * -> *) sig (info :: * -> *).
expr sig -> info (DenResult sig) -> (:&:) expr info sig
:&: info1 (DenResult sig) -> info2 (DenResult sig)
fi info1 (DenResult sig)
i

-- | Get the decoration of the top-level node
getDecor :: AST (sym :&: info) sig -> info (DenResult sig)
getDecor :: AST (sym :&: info) sig -> info (DenResult sig)
getDecor (Sym (sym sig
_ :&: info (DenResult sig)
info)) = info (DenResult sig)
info
getDecor (AST (sym :&: info) (a :-> sig)
f :$ AST (sym :&: info) (Full a)
_)           = AST (sym :&: info) (a :-> sig) -> info (DenResult (a :-> sig))
forall (sym :: * -> *) (info :: * -> *) sig.
AST (sym :&: info) sig -> info (DenResult sig)
getDecor AST (sym :&: info) (a :-> sig)
f

-- | Update the decoration of the top-level node
updateDecor :: forall info sym a .
    (info a -> info a) -> ASTF (sym :&: info) a -> ASTF (sym :&: info) a
updateDecor :: (info a -> info a)
-> ASTF (sym :&: info) a -> ASTF (sym :&: info) a
updateDecor info a -> info a
f = (forall sig.
 (a ~ DenResult sig) =>
 (:&:) sym info sig
 -> Args (AST (sym :&: info)) sig -> ASTF (sym :&: info) a)
-> ASTF (sym :&: info) a -> ASTF (sym :&: info) a
forall (sym :: * -> *) a (c :: * -> *).
(forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> c (Full a))
-> ASTF sym a -> c (Full a)
match forall sig.
(a ~ DenResult sig) =>
(:&:) sym info sig
-> Args (AST (sym :&: info)) sig -> ASTF (sym :&: info) a
update
  where
    update
        :: (a ~ DenResult sig)
        => (sym :&: info) sig
        -> Args (AST (sym :&: info)) sig
        -> ASTF (sym :&: info) a
    update :: (:&:) sym info sig
-> Args (AST (sym :&: info)) sig -> ASTF (sym :&: info) a
update (sym sig
a :&: info (DenResult sig)
info) Args (AST (sym :&: info)) sig
args = AST (sym :&: info) sig
-> Args (AST (sym :&: info)) sig
-> ASTF (sym :&: info) (DenResult sig)
forall (sym :: * -> *) sig.
AST sym sig -> Args (AST sym) sig -> ASTF sym (DenResult sig)
appArgs ((:&:) sym info sig -> AST (sym :&: info) sig
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (:&:) sym info sig
sym) Args (AST (sym :&: info)) sig
args
      where
        sym :: (:&:) sym info sig
sym = sym sig
a sym sig -> info (DenResult sig) -> (:&:) sym info sig
forall (expr :: * -> *) sig (info :: * -> *).
expr sig -> info (DenResult sig) -> (:&:) expr info sig
:&: (info a -> info a
f info a
info (DenResult sig)
info)

-- | Lift a function that operates on expressions with associated information to
-- operate on a ':&:' expression. This function is convenient to use together
-- with e.g. 'queryNodeSimple' when the domain has the form @(sym `:&:` info)@.
liftDecor :: (expr s -> info (DenResult s) -> b) -> ((expr :&: info) s -> b)
liftDecor :: (expr s -> info (DenResult s) -> b) -> (:&:) expr info s -> b
liftDecor expr s -> info (DenResult s) -> b
f (expr s
a :&: info (DenResult s)
info) = expr s -> info (DenResult s) -> b
f expr s
a info (DenResult s)
info

-- | Strip decorations from an 'AST'
stripDecor :: AST (sym :&: info) sig -> AST sym sig
stripDecor :: AST (sym :&: info) sig -> AST sym sig
stripDecor (Sym (sym sig
a :&: info (DenResult sig)
_)) = sym sig -> AST sym sig
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym sym sig
a
stripDecor (AST (sym :&: info) (a :-> sig)
f :$ AST (sym :&: info) (Full a)
a)        = AST (sym :&: info) (a :-> sig) -> AST sym (a :-> sig)
forall (sym :: * -> *) (info :: * -> *) sig.
AST (sym :&: info) sig -> AST sym sig
stripDecor AST (sym :&: info) (a :-> sig)
f AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ AST (sym :&: info) (Full a) -> AST sym (Full a)
forall (sym :: * -> *) (info :: * -> *) sig.
AST (sym :&: info) sig -> AST sym sig
stripDecor AST (sym :&: info) (Full a)
a

-- | Rendering of decorated syntax trees
stringTreeDecor :: forall info sym a . StringTree sym =>
    (forall a . info a -> String) -> ASTF (sym :&: info) a -> Tree String
stringTreeDecor :: (forall a. info a -> String)
-> ASTF (sym :&: info) a -> Tree String
stringTreeDecor forall a. info a -> String
showInfo ASTF (sym :&: info) a
a = [Tree String] -> ASTF (sym :&: info) a -> Tree String
forall sig. [Tree String] -> AST (sym :&: info) sig -> Tree String
mkTree [] ASTF (sym :&: info) a
a
  where
    mkTree :: [Tree String] -> AST (sym :&: info) sig -> Tree String
    mkTree :: [Tree String] -> AST (sym :&: info) sig -> Tree String
mkTree [Tree String]
args (Sym (sym sig
expr :&: info (DenResult sig)
info)) = String -> [Tree String] -> Tree String
forall a. a -> Forest a -> Tree a
Node String
infoStr [[Tree String] -> sym sig -> Tree String
forall (sym :: * -> *) a.
StringTree sym =>
[Tree String] -> sym a -> Tree String
stringTreeSym [Tree String]
args sym sig
expr]
      where
        infoStr :: String
infoStr = String
"<<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ info (DenResult sig) -> String
forall a. info a -> String
showInfo info (DenResult sig)
info String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">>"
    mkTree [Tree String]
args (AST (sym :&: info) (a :-> sig)
f :$ AST (sym :&: info) (Full a)
a) = [Tree String] -> AST (sym :&: info) (a :-> sig) -> Tree String
forall sig. [Tree String] -> AST (sym :&: info) sig -> Tree String
mkTree ([Tree String] -> AST (sym :&: info) (Full a) -> Tree String
forall sig. [Tree String] -> AST (sym :&: info) sig -> Tree String
mkTree [] AST (sym :&: info) (Full a)
a Tree String -> [Tree String] -> [Tree String]
forall a. a -> [a] -> [a]
: [Tree String]
args) AST (sym :&: info) (a :-> sig)
f

-- | Show an decorated syntax tree using ASCII art
showDecorWith :: StringTree sym => (forall a . info a -> String) -> ASTF (sym :&: info) a -> String
showDecorWith :: (forall a. info a -> String) -> ASTF (sym :&: info) a -> String
showDecorWith forall a. info a -> String
showInfo = Tree String -> String
showTree (Tree String -> String)
-> (ASTF (sym :&: info) a -> Tree String)
-> ASTF (sym :&: info) a
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. info a -> String)
-> ASTF (sym :&: info) a -> Tree String
forall (info :: * -> *) (sym :: * -> *) a.
StringTree sym =>
(forall a. info a -> String)
-> ASTF (sym :&: info) a -> Tree String
stringTreeDecor forall a. info a -> String
showInfo

-- | Print an decorated syntax tree using ASCII art
drawDecorWith :: StringTree sym => (forall a . info a -> String) -> ASTF (sym :&: info) a -> IO ()
drawDecorWith :: (forall a. info a -> String) -> ASTF (sym :&: info) a -> IO ()
drawDecorWith forall a. info a -> String
showInfo = String -> IO ()
putStrLn (String -> IO ())
-> (ASTF (sym :&: info) a -> String)
-> ASTF (sym :&: info) a
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. info a -> String) -> ASTF (sym :&: info) a -> String
forall (sym :: * -> *) (info :: * -> *) a.
StringTree sym =>
(forall a. info a -> String) -> ASTF (sym :&: info) a -> String
showDecorWith forall a. info a -> String
showInfo

writeHtmlDecorWith :: forall info sym a. (StringTree sym)
                   => (forall b. info b -> String) -> FilePath -> ASTF (sym :&: info) a -> IO ()
writeHtmlDecorWith :: (forall b. info b -> String)
-> String -> ASTF (sym :&: info) a -> IO ()
writeHtmlDecorWith forall b. info b -> String
showInfo String
file ASTF (sym :&: info) a
a = Maybe String -> String -> Tree NodeInfo -> IO ()
writeHtmlTree Maybe String
forall a. Maybe a
Nothing String
file (Tree NodeInfo -> IO ()) -> Tree NodeInfo -> IO ()
forall a b. (a -> b) -> a -> b
$ [Tree NodeInfo] -> ASTF (sym :&: info) a -> Tree NodeInfo
forall sig.
[Tree NodeInfo] -> AST (sym :&: info) sig -> Tree NodeInfo
mkTree [] ASTF (sym :&: info) a
a
  where
    mkTree :: [Tree NodeInfo] -> AST (sym :&: info) sig -> Tree NodeInfo
    mkTree :: [Tree NodeInfo] -> AST (sym :&: info) sig -> Tree NodeInfo
mkTree [Tree NodeInfo]
args (AST (sym :&: info) (a :-> sig)
f :$ AST (sym :&: info) (Full a)
a) = [Tree NodeInfo] -> AST (sym :&: info) (a :-> sig) -> Tree NodeInfo
forall sig.
[Tree NodeInfo] -> AST (sym :&: info) sig -> Tree NodeInfo
mkTree ([Tree NodeInfo] -> AST (sym :&: info) (Full a) -> Tree NodeInfo
forall sig.
[Tree NodeInfo] -> AST (sym :&: info) sig -> Tree NodeInfo
mkTree [] AST (sym :&: info) (Full a)
a Tree NodeInfo -> [Tree NodeInfo] -> [Tree NodeInfo]
forall a. a -> [a] -> [a]
: [Tree NodeInfo]
args) AST (sym :&: info) (a :-> sig)
f
    mkTree [Tree NodeInfo]
args (Sym (sym sig
expr :&: info (DenResult sig)
info)) =
      NodeInfo -> [Tree NodeInfo] -> Tree NodeInfo
forall a. a -> Forest a -> Tree a
Node (Behavior -> String -> String -> NodeInfo
NodeInfo Behavior
InitiallyExpanded (sym sig -> String
forall (sym :: * -> *) sig. Render sym => sym sig -> String
renderSym sym sig
expr) (info (DenResult sig) -> String
forall b. info b -> String
showInfo info (DenResult sig)
info)) [Tree NodeInfo]
args

-- | Make a smart constructor of a symbol. 'smartSymDecor' has any type of the
-- form:
--
-- > smartSymDecor :: (sub :<: AST (sup :&: info))
-- >     => info x
-- >     -> sub (a :-> b :-> ... :-> Full x)
-- >     -> (ASTF sup a -> ASTF sup b -> ... -> ASTF sup x)
smartSymDecor
    :: ( Signature sig
       , f              ~ SmartFun (sup :&: info) sig
       , sig            ~ SmartSig f
       , (sup :&: info) ~ SmartSym f
       , sub :<: sup
       )
    => info (DenResult sig) -> sub sig -> f
smartSymDecor :: info (DenResult sig) -> sub sig -> f
smartSymDecor info (DenResult sig)
d = (:&:) sup info sig -> f
forall sig f (sym :: * -> *).
(Signature sig, f ~ SmartFun sym sig, sig ~ SmartSig f,
 sym ~ SmartSym f) =>
sym sig -> f
smartSym' ((:&:) sup info sig -> f)
-> (sub sig -> (:&:) sup info sig) -> sub sig -> f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (sup sig -> info (DenResult sig) -> (:&:) sup info sig
forall (expr :: * -> *) sig (info :: * -> *).
expr sig -> info (DenResult sig) -> (:&:) expr info sig
:&: info (DenResult sig)
d) (sup sig -> (:&:) sup info sig)
-> (sub sig -> sup sig) -> sub sig -> (:&:) sup info sig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sub sig -> sup sig
forall (sub :: * -> *) (sup :: * -> *) a.
(sub :<: sup) =>
sub a -> sup a
inj

-- | \"Sugared\" symbol application
--
-- 'sugarSymDecor' has any type of the form:
--
-- > sugarSymDecor ::
-- >     ( sub :<: AST (sup :&: info)
-- >     , Syntactic a
-- >     , Syntactic b
-- >     , ...
-- >     , Syntactic x
-- >     , Domain a ~ Domain b ~ ... ~ Domain x
-- >     ) => info (Internal x)
-- >       -> sub (Internal a :-> Internal b :-> ... :-> Full (Internal x))
-- >       -> (a -> b -> ... -> x)
sugarSymDecor
    :: ( Signature sig
       , fi             ~ SmartFun (sup :&: info) sig
       , sig            ~ SmartSig fi
       , (sup :&: info) ~ SmartSym fi
       , SyntacticN f fi
       , sub :<: sup
       )
    => info (DenResult sig) -> sub sig -> f
sugarSymDecor :: info (DenResult sig) -> sub sig -> f
sugarSymDecor info (DenResult sig)
i = fi -> f
forall f internal. SyntacticN f internal => internal -> f
sugarN (fi -> f) -> (sub sig -> fi) -> sub sig -> f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. info (DenResult sig) -> sub sig -> fi
forall sig f (sup :: * -> *) (info :: * -> *) (sub :: * -> *).
(Signature sig, f ~ SmartFun (sup :&: info) sig, sig ~ SmartSig f,
 (sup :&: info) ~ SmartSym f, sub :<: sup) =>
info (DenResult sig) -> sub sig -> f
smartSymDecor info (DenResult sig)
i