{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}

module ParseTable.Pretty where

import Data.Bifunctor (first, second)
import Data.List (intercalate)
import qualified Data.List as List
import qualified Data.List.NonEmpty as List1
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set

-- TODO: tabular printout
-- import Text.PrettyPrint.Boxes

import CFG
import DebugPrint
import ParseTable

instance {-# OVERLAPPABLE #-} (DebugPrint t) => DebugPrint (Input' t) where
  debugPrint :: Input' t -> String
debugPrint Input' t
ts = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (t -> String) -> Input' t -> [String]
forall a b. (a -> b) -> [a] -> [b]
map t -> String
forall a. DebugPrint a => a -> String
debugPrint Input' t
ts

instance DebugPrint x => DebugPrint (NT' x) where
  debugPrint :: NT' x -> String
debugPrint = x -> String
forall a. DebugPrint a => a -> String
debugPrint (x -> String) -> (NT' x -> x) -> NT' x -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NT' x -> x
forall x. NT' x -> x
ntNam

instance (DebugPrint x, DebugPrint t) => DebugPrint (Symbol' x t) where
  debugPrint :: Symbol' x t -> String
debugPrint (Term t
t)    = t -> String
forall a. DebugPrint a => a -> String
debugPrint t
t
  debugPrint (NonTerm NT' x
x) = NT' x -> String
forall a. DebugPrint a => a -> String
debugPrint NT' x
x

instance (DebugPrint x, DebugPrint t) => DebugPrint (Stack' x t) where
  debugPrint :: Stack' x t -> String
debugPrint (Stack [Symbol' x t]
s) = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Symbol' x t -> String) -> [Symbol' x t] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Symbol' x t -> String
forall a. DebugPrint a => a -> String
debugPrint ([Symbol' x t] -> [String]) -> [Symbol' x t] -> [String]
forall a b. (a -> b) -> a -> b
$ [Symbol' x t] -> [Symbol' x t]
forall a. [a] -> [a]
reverse [Symbol' x t]
s

instance (DebugPrint x, DebugPrint t) => DebugPrint (SRState' x t) where
  debugPrint :: SRState' x t -> String
debugPrint (SRState Stack' x t
s Input' t
inp) = [String] -> String
unwords [ Stack' x t -> String
forall a. DebugPrint a => a -> String
debugPrint Stack' x t
s, String
"\t.", Input' t -> String
forall a. DebugPrint a => a -> String
debugPrint Input' t
inp ]

instance (DebugPrint x, DebugPrint r) => DebugPrint (Rule' x r t) where
  debugPrint :: Rule' x r t -> String
debugPrint (Rule NT' x
x (Alt r
r Form' x t
alpha)) = r -> String
forall a. DebugPrint a => a -> String
debugPrint r
r

instance (DebugPrint x, DebugPrint r) => DebugPrint (SRAction' x r t) where
  debugPrint :: SRAction' x r t -> String
debugPrint SRAction' x r t
Shift      = String
"shift"
  debugPrint (Reduce Rule' x r t
r) = [String] -> String
unwords [ String
"reduce with rule", Rule' x r t -> String
forall a. DebugPrint a => a -> String
debugPrint Rule' x r t
r ]

instance (DebugPrint x, DebugPrint r) => DebugPrint (Action' x r t) where
  debugPrint :: Action' x r t -> String
debugPrint Action' x r t
Nothing  = String
"halt"
  debugPrint (Just SRAction' x r t
a) = SRAction' x r t -> String
forall a. DebugPrint a => a -> String
debugPrint SRAction' x r t
a

instance (DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (TraceItem' x r t) where
  debugPrint :: TraceItem' x r t -> String
debugPrint (TraceItem SRState' x t
s Action' x r t
a) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ SRState' x t -> String
forall a. DebugPrint a => a -> String
debugPrint SRState' x t
s, String
"\t-- ", Action' x r t -> String
forall a. DebugPrint a => a -> String
debugPrint Action' x r t
a ]

instance (DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (Trace' x r t) where
  debugPrint :: Trace' x r t -> String
debugPrint Trace' x r t
tr = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (TraceItem' x r t -> String) -> Trace' x r t -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TraceItem' x r t -> String
forall a. DebugPrint a => a -> String
debugPrint Trace' x r t
tr

instance DebugPrint IGotoActions where
  debugPrint :: IGotoActions -> String
debugPrint IGotoActions
gotos = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((Key, Key) -> String) -> [(Key, Key)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Key, Key) -> String
forall {a} {a}. (Show a, Show a) => (a, a) -> String
row ([(Key, Key)] -> [String]) -> [(Key, Key)] -> [String]
forall a b. (a -> b) -> a -> b
$ IGotoActions -> [(Key, Key)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IGotoActions
gotos
    where
    row :: (a, a) -> String
row (a
x, a
s) = [String] -> String
unwords [ String
"NT", a -> String
forall a. Show a => a -> String
show a
x, String
"\tgoto state", a -> String
forall a. Show a => a -> String
show a
s ]

instance (DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (ISRAction' x r t) where
  debugPrint :: ISRAction' x r t -> String
debugPrint (ISRAction Maybe Key
mshift Set (Rule' x r t)
rs) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
";" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
    [ String -> (Key -> String) -> Maybe Key -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\ Key
s -> [String] -> String
unwords [ String
"shift to state", Key -> String
forall a. Show a => a -> String
show Key
s ]) Maybe Key
mshift
    , if Set (Rule' x r t) -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set (Rule' x r t)
rs then String
""
      else [String] -> String
unwords [ String
"reduce with rule", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" or " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Rule' x r t -> String) -> [Rule' x r t] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Rule' x r t -> String
forall a. DebugPrint a => a -> String
debugPrint ([Rule' x r t] -> [String]) -> [Rule' x r t] -> [String]
forall a b. (a -> b) -> a -> b
$ Set (Rule' x r t) -> [Rule' x r t]
forall a. Set a -> [a]
Set.toList Set (Rule' x r t)
rs ]
    ]

instance (Ord r, Ord t, DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (ISRActions' x r t) where
  debugPrint :: ISRActions' x r t -> String
debugPrint (ISRActions ISRAction' x r t
aeof Map t (ISRAction' x r t)
tmap) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
    (if ISRAction' x r t
aeof ISRAction' x r t -> ISRAction' x r t -> Bool
forall a. Eq a => a -> a -> Bool
== ISRAction' x r t
forall a. Monoid a => a
mempty then [String] -> [String]
forall a. a -> a
id else ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"eof", String
"\t", ISRAction' x r t -> String
forall a. DebugPrint a => a -> String
debugPrint ISRAction' x r t
aeof ] String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
      ((t, ISRAction' x r t) -> String)
-> [(t, ISRAction' x r t)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(t
t,ISRAction' x r t
act) -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ t -> String
forall a. DebugPrint a => a -> String
debugPrint t
t, String
"\t", ISRAction' x r t -> String
forall a. DebugPrint a => a -> String
debugPrint ISRAction' x r t
act ]) (Map t (ISRAction' x r t) -> [(t, ISRAction' x r t)]
forall k a. Map k a -> [(k, a)]
Map.toList Map t (ISRAction' x r t)
tmap)

instance (Ord r, Ord t, DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (IPT' x r t) where
  debugPrint :: IPT' x r t -> String
debugPrint (IPT IntMap (ISRActions' x r t)
sr IntMap IGotoActions
goto) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (((Key, String) -> [String]) -> [(Key, String)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
`map` [(Key, String)]
srgoto) (((Key, String) -> [String]) -> [[String]])
-> ((Key, String) -> [String]) -> [[String]]
forall a b. (a -> b) -> a -> b
$ \ (Key
s, String
ls) ->
      [ [String] -> String
unwords [ String
"State", Key -> String
forall a. Show a => a -> String
show Key
s ]
      , String
""
      , String
ls
      ]
    where
    sr' :: [(Key, String)]
sr'    = ((Key, ISRActions' x r t) -> (Key, String))
-> [(Key, ISRActions' x r t)] -> [(Key, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((ISRActions' x r t -> String)
-> (Key, ISRActions' x r t) -> (Key, String)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ISRActions' x r t -> String
forall a. DebugPrint a => a -> String
debugPrint) ([(Key, ISRActions' x r t)] -> [(Key, String)])
-> [(Key, ISRActions' x r t)] -> [(Key, String)]
forall a b. (a -> b) -> a -> b
$ IntMap (ISRActions' x r t) -> [(Key, ISRActions' x r t)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap (ISRActions' x r t)
sr
    goto' :: [(Key, String)]
goto'  = ((Key, IGotoActions) -> (Key, String))
-> [(Key, IGotoActions)] -> [(Key, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((IGotoActions -> String) -> (Key, IGotoActions) -> (Key, String)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second IGotoActions -> String
forall a. DebugPrint a => a -> String
debugPrint) ([(Key, IGotoActions)] -> [(Key, String)])
-> [(Key, IGotoActions)] -> [(Key, String)]
forall a b. (a -> b) -> a -> b
$ IntMap IGotoActions -> [(Key, IGotoActions)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap IGotoActions
goto
    srgoto :: [(Key, String)]
srgoto = IntMap String -> [(Key, String)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList (IntMap String -> [(Key, String)])
-> IntMap String -> [(Key, String)]
forall a b. (a -> b) -> a -> b
$ (String -> String -> String) -> [(Key, String)] -> IntMap String
forall a. (a -> a -> a) -> [(Key, a)] -> IntMap a
IntMap.fromListWith (\ String
s String
g -> [String] -> String
unlines [String
s,String
g]) ([(Key, String)] -> IntMap String)
-> [(Key, String)] -> IntMap String
forall a b. (a -> b) -> a -> b
$ [(Key, String)]
goto' [(Key, String)] -> [(Key, String)] -> [(Key, String)]
forall a. [a] -> [a] -> [a]
++ [(Key, String)]
sr'

instance (DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (ParseItem' x r t) where
  debugPrint :: ParseItem' x r t -> String
debugPrint (ParseItem Rule' x r t
rule [Symbol' x t]
beta) = [String] -> String
unwords
    [ Rule' x r t -> String
forall a. DebugPrint a => a -> String
debugPrint Rule' x r t
rule
    , String
"/"
    , [Symbol' x t] -> String
forall a. DebugPrint a => a -> String
debugPrint [Symbol' x t]
beta
    ]
instance (DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (ParseState' x r t) where
  debugPrint :: ParseState' x r t -> String
debugPrint (ParseState Map (ParseItem' x r t) (Lookahead t)
m) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    ((ParseItem' x r t, Lookahead t) -> String)
-> [(ParseItem' x r t, Lookahead t)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ParseItem' x r t
item, Lookahead t
ls) -> [String] -> String
unwords [ ParseItem' x r t -> String
forall a. DebugPrint a => a -> String
debugPrint ParseItem' x r t
item, Lookahead t -> String
forall a. DebugPrint a => a -> String
debugPrint Lookahead t
ls ]) ([(ParseItem' x r t, Lookahead t)] -> [String])
-> [(ParseItem' x r t, Lookahead t)] -> [String]
forall a b. (a -> b) -> a -> b
$ Map (ParseItem' x r t) (Lookahead t)
-> [(ParseItem' x r t, Lookahead t)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (ParseItem' x r t) (Lookahead t)
m

---------------------------------------------------------------------------
-- Pretty printing of NTs using WithNTNames dictionary:

instance (DebugPrint x) => DebugPrint (WithNTNames x IGotoActions) where
  debugPrint :: WithNTNames x IGotoActions -> String
debugPrint (WithNTNames IntMap x
dict IGotoActions
gotos) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ((Key, Key) -> String) -> [(Key, Key)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Key, Key) -> String
forall {a}. Show a => (Key, a) -> String
row ([(Key, Key)] -> [String]) -> [(Key, Key)] -> [String]
forall a b. (a -> b) -> a -> b
$ IGotoActions -> [(Key, Key)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IGotoActions
gotos
    where
    row :: (Key, a) -> String
row (Key
i, a
s) = [String] -> String
unwords [ x -> String
forall a. DebugPrint a => a -> String
debugPrint (IntMap x
dict IntMap x -> Key -> x
forall a. IntMap a -> Key -> a
IntMap.! Key
i), String
"\tgoto state", a -> String
forall a. Show a => a -> String
show a
s ]

instance (Ord r, Ord t, DebugPrint x, DebugPrint r, DebugPrint t) => DebugPrint (WithNTNames x (IPT' x r t)) where
  debugPrint :: WithNTNames x (IPT' x r t) -> String
debugPrint (WithNTNames IntMap x
dict (IPT IntMap (ISRActions' x r t)
sr IntMap IGotoActions
goto)) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (((Key, String) -> [String]) -> [(Key, String)] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
`map` [(Key, String)]
srgoto) (((Key, String) -> [String]) -> [[String]])
-> ((Key, String) -> [String]) -> [[String]]
forall a b. (a -> b) -> a -> b
$ \ (Key
s, String
ls) ->
      [ [String] -> String
unwords [ String
"State", Key -> String
forall a. Show a => a -> String
show Key
s ]
      , String
""
      , String
ls
      ]
    where
    sr' :: [(Key, String)]
sr'    = ((Key, ISRActions' x r t) -> (Key, String))
-> [(Key, ISRActions' x r t)] -> [(Key, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((ISRActions' x r t -> String)
-> (Key, ISRActions' x r t) -> (Key, String)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ISRActions' x r t -> String
forall a. DebugPrint a => a -> String
debugPrint) ([(Key, ISRActions' x r t)] -> [(Key, String)])
-> [(Key, ISRActions' x r t)] -> [(Key, String)]
forall a b. (a -> b) -> a -> b
$ IntMap (ISRActions' x r t) -> [(Key, ISRActions' x r t)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap (ISRActions' x r t)
sr
    goto' :: [(Key, String)]
goto'  = ((Key, IGotoActions) -> (Key, String))
-> [(Key, IGotoActions)] -> [(Key, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((IGotoActions -> String) -> (Key, IGotoActions) -> (Key, String)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((IGotoActions -> String) -> (Key, IGotoActions) -> (Key, String))
-> (IGotoActions -> String) -> (Key, IGotoActions) -> (Key, String)
forall a b. (a -> b) -> a -> b
$ WithNTNames x IGotoActions -> String
forall a. DebugPrint a => a -> String
debugPrint (WithNTNames x IGotoActions -> String)
-> (IGotoActions -> WithNTNames x IGotoActions)
-> IGotoActions
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap x -> IGotoActions -> WithNTNames x IGotoActions
forall x a. IntMap x -> a -> WithNTNames x a
WithNTNames IntMap x
dict) ([(Key, IGotoActions)] -> [(Key, String)])
-> [(Key, IGotoActions)] -> [(Key, String)]
forall a b. (a -> b) -> a -> b
$ IntMap IGotoActions -> [(Key, IGotoActions)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList IntMap IGotoActions
goto
    srgoto :: [(Key, String)]
srgoto = IntMap String -> [(Key, String)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList (IntMap String -> [(Key, String)])
-> IntMap String -> [(Key, String)]
forall a b. (a -> b) -> a -> b
$ (String -> String -> String) -> [(Key, String)] -> IntMap String
forall a. (a -> a -> a) -> [(Key, a)] -> IntMap a
IntMap.fromListWith (\ String
s String
g -> [String] -> String
unlines [String
s,String
g]) ([(Key, String)] -> IntMap String)
-> [(Key, String)] -> IntMap String
forall a b. (a -> b) -> a -> b
$ [(Key, String)]
goto' [(Key, String)] -> [(Key, String)] -> [(Key, String)]
forall a. [a] -> [a] -> [a]
++ [(Key, String)]
sr'