Language/TCT/Debug.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DefaultSignatures #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE Rank2Types #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 module Language.TCT.Debug where
  10
  11 import Control.Monad (Monad(..), mapM)
  12 import Data.Bool
  13 import Data.Foldable (toList, null)
  14 import Data.Function (($), (.))
  15 import Data.Int (Int)
  16 import Data.List.NonEmpty (NonEmpty(..))
  17 import Data.Maybe (Maybe(..))
  18 import Data.Semigroup (Semigroup(..))
  19 import Data.Sequence (Seq)
  20 import Data.String (String)
  21 import Data.Text (Text)
  22 import Data.TreeSeq.Strict (Tree(..))
  23 import Prelude ((+))
  24 import Text.Show (Show(..))
  25 import qualified Control.Monad.Trans.Reader as R
  26 import qualified Data.List as List
  27 import qualified Data.Text.Lazy as TL
  28 import qualified Text.Megaparsec as P
  29
  30 -- * Debug
  31 #if DEBUG
  32 import qualified Debug.Trace as Trace
  33
  34 debug :: String -> a -> a
  35 debug = Trace.trace
  36
  37 debug0 :: Pretty a => String -> a -> a
  38 debug0 m a = Trace.trace (m <> ": " <> R.runReader (pretty a) 2) a
  39
  40 debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
  41 debug1 nf na f a =
  42         (\r -> Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) r) $
  43         (Trace.trace (nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) f)
  44         a
  45
  46 debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r
  47 debug1_ nf (na,a) r =
  48         Trace.trace (nf <> ":\n " <> na <> " = " <> R.runReader (pretty a) 2) $
  49         Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) $
  50         r
  51
  52 debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
  53 debug2 nf na nb f a b =
  54         (\r -> Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) r) $
  55         Trace.trace
  56          (nf <> ":"
  57                  <> "\n " <> na <> " = " <> R.runReader (pretty a) 2
  58                  <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2
  59          ) f a b
  60
  61 debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
  62 debug2_ nf (na,a) (nb,b) r =
  63         Trace.trace
  64          (nf <> ":"
  65                  <> "\n " <> na <> " = " <> R.runReader (pretty a) 2
  66                  <> "\n " <> nb <> " = " <> R.runReader (pretty b) 2
  67          ) $
  68         Trace.trace (nf <> ": " <> R.runReader (pretty r) 2) $
  69         r
  70
  71 debugParser :: Show a => String -> P.Parsec e s a -> P.Parsec e s a
  72 debugParser = P.dbg
  73 #else
  74 import Data.Function (id)
  75
  76 debug :: String -> a -> a
  77 debug _m = id
  78 {-# INLINE debug #-}
  79
  80 debug0 :: Pretty a => String -> a -> a
  81 debug0 _m = id
  82 {-# INLINE debug0 #-}
  83
  84 debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
  85 debug1 _nf _na = id
  86 {-# INLINE debug1 #-}
  87
  88 debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
  89 debug2 _nf _na _nb = id
  90 {-# INLINE debug2 #-}
  91
  92 debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
  93 debug2_ _nf _a _b = id
  94 {-# INLINE debug2_ #-}
  95
  96 debugParser :: Show a => String -> P.Parsec e s a -> P.Parsec e s a
  97 debugParser _m = id
  98 {-# INLINE debugParser #-}
  99 #endif
 100
 101 -- * Class 'Pretty'
 102 class Pretty a where
 103         pretty :: a -> R.Reader Int String
 104         default pretty :: Show a => a -> R.Reader Int String
 105         pretty = return . show
 106 instance Pretty Int
 107 instance Pretty Text
 108 instance Pretty TL.Text
 109 instance (Pretty a, Pretty b) => Pretty (a,b) where
 110         pretty (a,b) = do
 111                 i <- R.ask
 112                 a' <- R.local (+2) $ pretty a
 113                 b' <- R.local (+2) $ pretty b
 114                 return $
 115                         "\n" <> List.replicate i ' ' <> "( " <> a' <>
 116                         "\n" <> List.replicate i ' ' <> ", " <> b' <>
 117                         "\n" <> List.replicate i ' ' <> ") "
 118 instance Pretty a => Pretty [a] where
 119         pretty [] = return "[]"
 120         pretty as = do
 121                 i <- R.ask
 122                 s <- R.local (+2) $ mapM pretty as
 123                 return $
 124                         "\n" <> List.replicate i ' ' <> "[ " <>
 125                         List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
 126                         "\n" <> List.replicate i ' ' <> "] "
 127 instance Pretty a => Pretty (NonEmpty a) where
 128         pretty = pretty . toList
 129 instance Pretty a => Pretty (Seq a) where
 130         pretty ss
 131          | null ss = return "[]"
 132          | otherwise = do
 133                 let as = toList ss
 134                 i <- R.ask
 135                 s <- R.local (+2) $ mapM pretty as
 136                 return $
 137                         "\n" <> List.replicate i ' ' <> "[ " <>
 138                         List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
 139                         "\n" <> List.replicate i ' ' <> "] "
 140 instance Pretty a => Pretty (Maybe a) where
 141         pretty Nothing = return "Nothing"
 142         pretty (Just m) = do
 143                 s <- pretty m
 144                 return $ "Just "<>s
 145 instance Show a => Pretty (Tree a) where
 146         pretty (Tree n ts) = do
 147                 s <- R.local (+2) (pretty ts)
 148                 return $ "Tree "<>showsPrec 11 n ""<>" "<>s