]> Git — Sourcephile - doclang.git/blob - Language/TCT/Debug.hs
Fix href= in <toc>.
[doclang.git] / Language / TCT / Debug.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE DefaultSignatures #-}
4 {-# LANGUAGE FlexibleContexts #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE Rank2Types #-}
7 {-# LANGUAGE TypeFamilies #-}
8 module Language.TCT.Debug where
9
10 import Control.Monad (Monad(..), mapM)
11 import Data.Bool
12 import Data.Eq (Eq(..))
13 import Data.Foldable (toList, null)
14 import Data.Function (($), (.), id)
15 import Data.Int (Int)
16 import Data.List.NonEmpty (NonEmpty(..))
17 import Data.Maybe (Maybe(..))
18 import Data.Ord (Ord)
19 import Data.Semigroup (Semigroup(..))
20 import Data.Sequence (Seq)
21 import Data.String (String)
22 import Data.Text (Text)
23 import Data.TreeSeq.Strict (Tree(..))
24 import Prelude ((+))
25 import Text.Show (Show(..))
26 import qualified Control.Monad.Trans.Reader as R
27 import qualified Data.List as List
28 import qualified Data.Text.Lazy as TL
29 import qualified Debug.Trace as Trace
30 import qualified Text.Megaparsec as P
31
32 -- * Debug
33 #if DEBUG
34
35 debug :: String -> a -> a
36 debug = Trace.trace
37
38 debug0 :: Pretty a => String -> a -> a
39 debug0 m a = Trace.trace (m <> ": " <> runPretty 2 a) a
40
41 debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
42 debug1 nf na f a =
43 (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
44 Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) f
45 a
46
47 debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r
48 debug1_ nf (na,a) r =
49 Trace.trace ("[ " <> nf <> ":\n " <> na <> " = " <> runPretty 2 a) $
50 Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
51 r
52
53 debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
54 debug2 nf na nb f a b =
55 (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
56 Trace.trace
57 ("[ " <> nf <> ":"
58 <> "\n " <> na <> " = " <> runPretty 2 a
59 <> "\n " <> nb <> " = " <> runPretty 2 b
60 ) f a b
61
62 debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
63 debug2_ nf (na,a) (nb,b) r =
64 Trace.trace
65 ("[ " <> nf <> ":"
66 <> "\n " <> na <> " = " <> runPretty 2 a
67 <> "\n " <> nb <> " = " <> runPretty 2 b
68 ) $
69 Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
70 r
71
72 debug3 :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r)
73 debug3 nf na nb nc f a b c =
74 (\r -> Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) r) $
75 Trace.trace
76 ("[ " <> nf <> ":"
77 <> "\n " <> na <> " = " <> runPretty 2 a
78 <> "\n " <> nb <> " = " <> runPretty 2 b
79 <> "\n " <> nc <> " = " <> runPretty 2 c
80 ) f a b c
81
82 debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r
83 debug3_ nf (na,a) (nb,b) (nc,c) r =
84 Trace.trace
85 ("[ " <> nf <> ":"
86 <> "\n " <> na <> " = " <> runPretty 2 a
87 <> "\n " <> nb <> " = " <> runPretty 2 b
88 <> "\n " <> nc <> " = " <> runPretty 2 c
89 ) $
90 Trace.trace ("] " <> nf <> ": " <> runPretty 2 r) $
91 r
92
93 debugParser ::
94 ( P.Stream s
95 , P.ShowToken (P.Token s)
96 , P.ShowErrorComponent e
97 , Ord e
98 , Show a
99 ) =>
100 String -> P.ParsecT e s m a -> P.ParsecT e s m a
101 debugParser = P.dbg
102 #else
103
104 debug :: String -> a -> a
105 debug _m = id
106 {-# INLINE debug #-}
107
108 debug0 :: Pretty a => String -> a -> a
109 debug0 _m = id
110 {-# INLINE debug0 #-}
111
112 debug1 :: (Pretty r, Pretty a) => String -> String -> (a -> r) -> (a -> r)
113 debug1 _nf _na = id
114 {-# INLINE debug1 #-}
115
116 debug1_ :: (Pretty r, Pretty a) => String -> (String,a) -> r -> r
117 debug1_ _nf _na = id
118 {-# INLINE debug1_ #-}
119
120 debug2 :: (Pretty r, Pretty a, Pretty b) => String -> String -> String -> (a -> b -> r) -> (a -> b -> r)
121 debug2 _nf _na _nb = id
122 {-# INLINE debug2 #-}
123
124 debug2_ :: (Pretty r, Pretty a, Pretty b) => String -> (String,a) -> (String,b) -> r -> r
125 debug2_ _nf _a _b = id
126 {-# INLINE debug2_ #-}
127
128 debug3 :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> String -> String -> String -> (a -> b -> c -> r) -> (a -> b -> c -> r)
129 debug3 _nf _na _nb _nc = id
130 {-# INLINE debug3 #-}
131
132 debug3_ :: (Pretty r, Pretty a, Pretty b, Pretty c) => String -> (String,a) -> (String,b) -> (String,c) -> r -> r
133 debug3_ _nf _a _b _c = id
134 {-# INLINE debug3_ #-}
135
136 debugParser ::
137 ( P.Stream s
138 , P.ShowToken (P.Token s)
139 , P.ShowErrorComponent e
140 , Ord e
141 , Show a
142 ) =>
143 String -> P.ParsecT e s m a -> P.ParsecT e s m a
144 debugParser _m = id
145 {-# INLINE debugParser #-}
146 #endif
147
148 -- * Class 'Pretty'
149 class Pretty a where
150 pretty :: a -> R.Reader Int String
151 default pretty :: Show a => a -> R.Reader Int String
152 pretty = return . show
153
154 runPretty :: Pretty a => Int -> a -> String
155 runPretty i a = pretty a `R.runReader` i
156
157 instance Pretty Bool
158 instance Pretty Int
159 instance Pretty Text
160 instance Pretty TL.Text
161 instance Pretty P.Pos
162 instance (Pretty a, Pretty b) => Pretty (a,b) where
163 pretty (a,b) = do
164 i <- R.ask
165 a' <- R.local (+2) $ pretty a
166 b' <- R.local (+2) $ pretty b
167 return $
168 (if i == 0 then "" else "\n") <>
169 List.replicate i ' ' <> "( " <> a' <>
170 "\n" <> List.replicate i ' ' <> ", " <> b' <>
171 "\n" <> List.replicate i ' ' <> ") "
172 instance Pretty a => Pretty [a] where
173 pretty [] = return "[]"
174 pretty as = do
175 i <- R.ask
176 s <- R.local (+2) $ mapM pretty as
177 return $
178 (if i == 0 then "" else "\n") <>
179 List.replicate i ' ' <> "[ " <>
180 List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
181 "\n" <> List.replicate i ' ' <> "] "
182 instance Pretty a => Pretty (NonEmpty a) where
183 pretty = pretty . toList
184 instance Pretty a => Pretty (Seq a) where
185 pretty ss
186 | null ss = return "[]"
187 | otherwise = do
188 let as = toList ss
189 i <- R.ask
190 s <- R.local (+2) $ mapM pretty as
191 return $
192 (if i == 0 then "" else "\n") <>
193 List.replicate i ' ' <> "[ " <>
194 List.intercalate ("\n" <> List.replicate i ' ' <> ", ") s <>
195 "\n" <> List.replicate i ' ' <> "] "
196 instance Pretty a => Pretty (Maybe a) where
197 pretty Nothing = return "Nothing"
198 pretty (Just m) = do
199 s <- pretty m
200 return $ "Just "<>s
201 instance Show a => Pretty (Tree a) where
202 pretty (Tree n ts) = do
203 s <- R.local (+2) (pretty ts)
204 return $ "Tree "<>showsPrec 11 n ""<>" "<>s