{-# LANGUAGE CPP               #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-|
Module:      Text.Show.Text.Compiler.Hoopl
Copyright:   (C) 2014-2015 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Stability:   Experimental
Portability: GHC

Monomorphic 'Show' functions for data types in the @hoopl@ library.

/Since: 0.2/
-}
module Text.Show.Text.Compiler.Hoopl (
      showbLabel
    , showbLabelMapPrec
    , showbLabelSetPrec
    , showbPointed
    , showbUnique
    , showbUniqueMapPrec
    , showbUniqueSetPrec
    , showbDominatorNode
    , showbDominatorTree
    , showbDPath
    ) where

import Compiler.Hoopl (Label, LabelMap, LabelSet, Pointed(..),
                       Unique, UniqueMap, UniqueSet)
#if MIN_VERSION_hoopl(3,9,0)
import Compiler.Hoopl.Internals (lblToUnique)
#else
import Compiler.Hoopl.GHC (lblToUnique, uniqueToInt)
#endif
import Compiler.Hoopl.Passes.Dominator (DominatorNode(..), DominatorTree(..), DPath(..))

import Data.Monoid.Compat

import Prelude hiding (Show)

import Text.Show.Text (Show(showb, showbPrec), Show1(showbPrec1), Builder)
import Text.Show.Text.Data.Containers ()
import Text.Show.Text.Data.Integral (showbIntPrec)
import Text.Show.Text.TH (deriveShowPragmas, defaultInlineShowbPrec)
import Text.Show.Text.Utils (s)

#include "inline.h"

-- | Convert a 'Label' to a 'Builder'.
-- 
-- /Since: 0.2/
showbLabel :: Label -> Builder
showbLabel l = s 'L' <> showbUnique (lblToUnique l)
{-# INLINE showbLabel #-}

-- | Convert a 'LabelMap' to a 'Builder' with the given precedence.
-- 
-- /Since: 0.2/
showbLabelMapPrec :: Show v => Int -> LabelMap v -> Builder
showbLabelMapPrec = showbPrec
{-# INLINE showbLabelMapPrec #-}

-- | Convert a 'LabelSet' to a 'Builder' with the given precedence.
-- 
-- /Since: 0.2/
showbLabelSetPrec :: Int -> LabelSet -> Builder
showbLabelSetPrec = showbPrec
{-# INLINE showbLabelSetPrec #-}

-- | Convert a 'Pointed' value to a 'Builder'.
-- 
-- /Since: 0.2/
showbPointed :: Show a => Pointed t b a -> Builder
showbPointed Bot       = "_|_"
showbPointed Top       = s 'T'
showbPointed (PElem a) = showb a
{-# INLINE showbPointed #-}

-- | Convert a 'Unique' value to a 'Builder'.
-- 
-- /Since: 0.2/
showbUnique :: Unique -> Builder
#if MIN_VERSION_hoopl(3,9,0)
showbUnique = showbIntPrec 0
#else
showbUnique = showbIntPrec 0 . uniqueToInt
#endif
{-# INLINE showbUnique #-}

-- | Convert a 'UniqueMap' to a 'Builder' with the given precedence.
-- 
-- /Since: 0.2/
showbUniqueMapPrec :: Show v => Int -> UniqueMap v -> Builder
showbUniqueMapPrec = showbPrec
{-# INLINE showbUniqueMapPrec #-}

-- | Convert a 'UniqueSet' to a 'Builder' with the given precedence.
-- 
-- /Since: 0.2/
showbUniqueSetPrec :: Int -> UniqueSet -> Builder
showbUniqueSetPrec = showbPrec
{-# INLINE showbUniqueSetPrec #-}

-- | Convert a 'DominatorNode' to a 'Builder'.
-- 
-- /Since: 0.2/
showbDominatorNode :: DominatorNode -> Builder
showbDominatorNode Entry        = "entryNode"
showbDominatorNode (Labelled l) = showbLabel l
{-# INLINE showbDominatorNode #-}

-- | Convert a 'DominatorTree' to a 'Builder'.
-- 
-- /Since: 0.2/
showbDominatorTree :: DominatorTree -> Builder
showbDominatorTree t = mconcat $ "digraph {\n" : dot t ["}\n"]
  where
    dot :: DominatorTree -> [Builder] -> [Builder]
    dot (Dominates root trees) =
        (dotnode root :) . outedges trees . flip (foldl subtree) trees
      where
        outedges :: [DominatorTree] -> [Builder] -> [Builder]
        outedges [] = id
        outedges (Dominates n _ : ts) =
              \bs -> "  "
            : showbDominatorNode root
            : " -> "
            : showbDominatorNode n
            : s '\n'
            : outedges ts bs
        
        dotnode :: DominatorNode -> Builder
        dotnode Entry        = "  entryNode [shape=plaintext, label=\"entry\"]\n"
        dotnode (Labelled l) = "  " <> showbLabel l <> s '\n'
        
        subtree :: [Builder] -> DominatorTree -> [Builder]
        subtree = flip dot

-- | Convert a 'DPath' to a 'Builder'.
-- 
-- /Since: 0.2/
showbDPath :: DPath -> Builder
showbDPath (DPath ls) = mconcat $ foldr (\l path ->showbLabel l <> " -> " : path)
                                        ["entry"]
                                        ls
{-# INLINE showbDPath #-}

instance Show Label where
    showb = showbLabel
    INLINE_INST_FUN(showb)

$(deriveShowPragmas defaultInlineShowbPrec ''LabelMap)

instance Show1 LabelMap where
    showbPrec1 = showbPrec
    INLINE_INST_FUN(showbPrec1)

$(deriveShowPragmas defaultInlineShowbPrec ''LabelSet)

instance Show a => Show (Pointed t b a) where
    showb = showbPointed
    INLINE_INST_FUN(showb)

instance Show1 (Pointed t b) where
    showbPrec1 = showbPrec
    INLINE_INST_FUN(showbPrec1)

#if !(MIN_VERSION_hoopl(3,9,0))
instance Show Unique where
    showb = showbUnique
    INLINE_INST_FUN(showb)
#endif

$(deriveShowPragmas defaultInlineShowbPrec ''UniqueMap)

instance Show1 UniqueMap where
    showbPrec1 = showbPrec
    INLINE_INST_FUN(showbPrec1)

$(deriveShowPragmas defaultInlineShowbPrec ''UniqueSet)

instance Show DominatorNode where
    showb = showbDominatorNode
    INLINE_INST_FUN(showb)

instance Show DominatorTree where
    showb = showbDominatorTree
    INLINE_INST_FUN(showb)

instance Show DPath where
    showb = showbDPath
    INLINE_INST_FUN(showb)