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