Initial import

WrapDebug/Examples.icl

+module Examples
+
+import StdEnv
+
+/*
+	these examples use Ronny's syntax (->>, <<- and <<->>)
+	and options (see RWSDebug.icl)
+*/
+import RWSDebug
+
+// choose your example here
+Start
+	=	example1
+
+/*
+	a <<- b (debugBefore)
+		print b, then evaluate a
+*/
+example1
+	=	abort "example1 value\n" <<- "example1 debug"
+
+/*
+	a ->> b (debugAfter)
+		evaluate a, then print b
+*/
+example2
+	=	abort "example2 value\n" ->> "example2 debug"
+
+/*
+	<<->> a (debugValue)
+		print and evaluate a, value can be unique
+*/
+example3
+	=	<<->> "example3"
+
+/*
+	debugging also works with infinity values (provided you
+	limit the debug output with the DebugMax... options)
+*/
+example4
+	=	"example4" <<- [1..]
+
+/*
+	debugging with algebraic values
+*/
+:: List a
+	=	Nil
+	|	Cons a (List a)
+
+example5
+	=	"example5" <<- Cons 1 (Cons 2 Nil)
+
+/*
+	debugging with a record value, note that the field names
+	don't appear in the debug output (this information isn't
+	available at run-time)
+*/
+:: R	= {f1 :: Int, f2 :: Int}
+
+example6
+	=	"example6" <<- {f1 = 1, f2 = 2}
+
+/*
+	debugging with arrays 
+*/
+example7
+	=	"example7" <<- {1, 2, 3, 4, 5}
+
+/*
+	debugging with closures 
+*/
+example8
+	=	"example8" <<- (take, take 5, take 5 ['Brubek'])
+
+/*
+	debugging may evaluate values that wouldn't otherwise
+	be evaluated
+*/
+example9
+	=	hd (<<->> ["example9" : undef])
+
+/*
+	debugging may effect strictness, in this example f is not
+	strict in its first argument because of the debug function
+*/
+example10
+	=	f "example" "10"
+	where
+		f a b
+			=	(a <<- "f") +++ b
+
+/*
+	debugging depends on the evalution order, you'll have to
+	understand the evalution order to understand in which order
+	the debug values will be printed
+*/
+example11
+	=	fst (concatFirstTwo ["exam","ple11"])
+	where
+		concatFirstTwo
+			=	(get ->> "get first") `bind` \first
+			->	(get ->> "get second") `bind` \second
+			->	return (first+++second) ->> "return"
+	get [h:t]
+		=	(h, t)
+

WrapDebug/README.txt

+WrapDebug
+
+Version  1.0
+Ronny Wichers Schreur
+ronny@cs.kun.nl
+
+The WrapDebug package lets you print arbitrary expressions for debugging
+purposes. The main functions are in ShowDebug.
+
+
+FILES
+
+    README
+        This file
+    ShowDebug.dcl, ShowDebug.icl
+        Debug functions (uses Wrap and ShowWrapped)
+    Wrap.dcl, Wrap.icl
+        Wrap Clean nodes
+    ShowWrapped.dcl, ShowWrapped.icl
+        Convert a wrapped node to a list of strings
+    RWSDebug.dcl, RWSDebug.icl
+        Syntax and options I use for debugging (uses ShowDebug)
+    Examples.icl
+		Some examples with explanations

WrapDebug/RWSDebug.dcl

+definition module RWSDebug
+
+(->>) :: !.a !.b -> .a
+(<<-) :: .a !.b -> .a
+<<->> :: !.a -> .a
\ No newline at end of file

WrapDebug/RWSDebug.icl

+implementation module RWSDebug
+
+import Debug
+
+show x
+	=	debugShowWithOptions [DebugMaxChars 80, DebugMaxDepth 5]
+
+(->>) :: !.a !.b -> .a
+(->>) value debugValue
+	=	debugAfter debugValue show value
+
+(<<-) :: .a !.b -> .a
+(<<-) value debugValue
+	=	debugBefore debugValue show value
+
+<<->> :: !.a -> .a
+<<->> value
+	=	debugValue show value

WrapDebug/RWSDebug2.icl

+implementation module RWSDebug
+
+import ShowDebug
+
+show :: DebugShowFunction .a
+show
+	=	debugShow [DebugMaxChars 79, DebugMaxDepth 5, DebugMaxBreadth 20]
+
+class (<<-) infix 0 a  :: .a !b -> .a
+class (->>) infix 0 a  :: !.a !b -> .a
+class <<->> a :: !.a -> .a
+
+instance <<- a where
+	(<<-) value debugValue
+		=	debugBefore debugValue show value
+
+instance ->> a where
+	(->>) value debugValue
+		=	debugAfter debugValue show value
+
+instance <<->> a where
+	<<->> value
+		=	debugValue show value
+
+instance <<- (a -> b) | <<- b where
+	(<<-) f debugValue
+		=	\a -> (f a <<- debugValue)
+
+instance ->> (a -> b) | ->> b where
+	(->>) f debugValue
+		=	\a -> (f a ->> debugValue)
+
+instance <<->> (a -> b) | <<->> b where
+	<<->> f
+		=	\a -> <<->> (f a)

WrapDebug/ShowDebug.dcl

+/*
+	Debug functions.
+
+	Version 1.0
+	Ronny Wichers Schreur
+	ronny@cs.kun.nl
+*/
+definition module ShowDebug
+
+:: DebugShowFunction a :== a -> [{#Char}]
+
+// print (show a), then evaluate b
+debugBefore :: !.a !(DebugShowFunction .a) .b -> .b
+// evaluate b, then print (show a)
+debugAfter :: .a !(DebugShowFunction .a) !.b -> .b
+// evaluate and print (show a)
+debugValue :: !(DebugShowFunction .a) !.a -> .a
+
+// generic show function
+debugShow :: [DebugShowOption] .a -> [{#Char}]
+
+:: DebugShowOption 
+	=	DebugMaxDepth !Int			// default no limit
+	|	DebugMaxBreadth !Int		// default no limit
+	|	DebugMaxChars !Int			// default no limit
+	|	DebugTerminator !{#Char}	// default "\n"

WrapDebug/ShowDebug.icl

+/*
+	Debug functions.
+
+	Version 1.0
+	Ronny Wichers Schreur
+	ronny@cs.kun.nl
+*/
+implementation module ShowDebug
+
+import StdEnv
+import Wrap, ShowWrapped
+
+print :: ![{#Char}] .b -> .b
+print debugStrings value
+	| fst (ferror (stderr <<< debugStrings))
+		=	abort "Debug, print: couldn't write to stderr"
+	// otherwise
+		=	value
+
+debugBefore :: !.a !(DebugShowFunction .a) .b -> .b
+debugBefore debugValue show value
+	=	print (show debugValue) value
+
+debugAfter :: .a !(DebugShowFunction .a) !.b -> .b
+debugAfter debugValue show value
+	=	print (show debugValue) value
+
+debugValue :: !(DebugShowFunction .a) !.a -> .a
+debugValue show value
+	// copying a unique reference is OK here, because after the show
+	// reference1 is no longer in use and show shouldn't change anything
+	=	print (show reference1) reference2
+	where
+		(reference1, reference2)
+			=	copyUniqueReference value
+
+		copyUniqueReference :: !.a -> (!.a, !.a)
+		copyUniqueReference value
+			=	code {
+				.o 1 0
+					push_a	0				
+				.d 2 0
+				}
+
+:: DebugShowFunction a :== a -> [{#Char}]
+
+:: DebugOptionRecord
+	=	{maxDepth :: !Int, maxBreadth :: !Int, maxChars :: !Int, terminator :: !{#Char}}
+DebugDefaultOptions
+	:== {maxDepth = MaxInt, maxBreadth = MaxInt, maxChars = MaxInt, terminator = "\n"}
+
+MaxInt
+	:== (1<<31)-1
+
+:: DebugShowOption 
+	=	DebugMaxDepth !Int			// default MaxInt
+	|	DebugMaxBreadth !Int		// default MaxInt
+	|	DebugMaxChars !Int			// default MaxInt
+	|	DebugTerminator !{#Char}	// default "\n"
+
+(:-) infixl
+(:-) a f
+	:== f a
+
+debugShow :: [DebugShowOption] .a -> [{#Char}]
+debugShow debugOptions debugValue 
+	=	debugValue
+	:-	wrapNode
+	:-	pruneWrappedNode maxDepth maxBreadth
+	:-	showWrapped
+	:-	chop maxChars
+	:-	flip (++) [terminator]
+	where
+		{maxDepth, maxBreadth, maxChars, terminator}
+			=	foldl set DebugDefaultOptions debugOptions
+			where
+				set options (DebugMaxDepth maxDepth)
+					=	{options & maxDepth=maxDepth}
+				set options (DebugMaxBreadth maxBreadth)
+					=	{options & maxBreadth=maxBreadth}
+				set options (DebugMaxChars maxChars)
+					=	{options & maxChars=maxChars}
+				set options (DebugTerminator terminator)
+					=	{options & terminator=terminator}
+
+:: Indicators
+	=	...
+	|	.+.
+
+MaxCharsString
+	:== ".."
+MaxBreadthString
+	:== "..."
+MaxBreadthIndicator
+	:== wrapNode ...
+MaxDepthIndicator
+	:==	wrapNode .+.
+
+pruneWrappedNode :: !Int !Int !WrappedNode -> !WrappedNode
+pruneWrappedNode maxDepth maxBreadth value
+	=	prune 0 value
+	where
+		prune :: !Int WrappedNode -> WrappedNode
+		prune depth value
+			| depth == maxDepth
+				=	MaxDepthIndicator
+		prune depth (WrappedIntArray a)
+			=	pruneBasicArray depth a
+		prune depth (WrappedBoolArray a)
+			=	pruneBasicArray depth a
+		prune depth (WrappedRealArray a)
+			=	pruneBasicArray depth a
+		prune depth (WrappedFileArray a)
+			=	pruneBasicArray depth a
+		prune depth (WrappedString a)
+			| size a > maxBreadth
+				=	WrappedString ((a % (0, maxBreadth-1)) +++ MaxBreadthString)
+		prune depth (WrappedArray a)
+			=	WrappedArray (pruneArray depth a)
+		prune depth (WrappedRecord descriptor args)
+			=	WrappedRecord descriptor (pruneArray depth args)
+		prune depth (WrappedOther WrappedDescriptorCons args)
+			| size args == 2
+				=	WrappedOther WrappedDescriptorCons
+						{prune (depth+1) args.[0], prune depth args.[1]}
+		prune depth (WrappedOther WrappedDescriptorTuple args)
+			=	WrappedOther WrappedDescriptorTuple (pruneArray depth args)
+		prune depth (WrappedOther descriptor args)
+			=	WrappedOther descriptor (pruneArray depth args)
+		prune _ a
+			=	a
+
+		pruneArray :: !Int !{WrappedNode} -> {WrappedNode}
+		pruneArray depth a
+			| size a > maxBreadth
+				=	{{prune (depth+1) e \\ e <-: a & i <- [0 .. maxBreadth]}
+						& [maxBreadth] = MaxBreadthIndicator}
+			// otherwise
+				=	{prune (depth+1) e \\ e <-: a}
+
+		pruneBasicArray :: !Int !(a b) -> WrappedNode | Array .a & ArrayElem b
+		pruneBasicArray depth a
+			| size a > maxBreadth
+				=	WrappedArray (pruneArray depth {wrapNode e \\ e <-: a & i <- [0 .. maxBreadth]})
+			// otherwise
+				=	WrappedArray {wrapNode e \\ e <-: a}
+
+/* +++ handle newlines in strings correctly */
+chop :: !Int [{#Char}] -> [{#Char}]
+chop _ []
+	=	[]
+chop maxChars list=:[string:strings]
+	| maxChars < stringSize + sizeMaxCharsString
+		| fits maxChars list
+			=	list
+		| stringSize > sizeMaxCharsString
+			=	[string % (0, maxChars-sizeMaxCharsString-1), MaxCharsString]
+		// otherwise
+			=	[MaxCharsString]
+	// otherwise
+		=	[string : chop (maxChars - stringSize) strings]
+	where
+		stringSize
+			=	size string
+		sizeMaxCharsString
+			=	size MaxCharsString
+
+		fits :: !Int [{#Char}] -> Bool
+		fits _ []
+			=	True
+		fits maxChars [h : t]
+			=	maxChars >= size h && fits (maxChars - size h) t
+
+instance <<< [a] | <<< a where
+	(<<<) :: *File [a] -> *File | <<< a
+	(<<<) file []
+		=	file
+	(<<<) file [h:t]
+		=	file <<< h <<< t

WrapDebug/ShowWrapped.dcl

+definition module ShowWrapped
+
+from Wrap import WrappedNode
+
+showWrapped :: WrappedNode -> [{#Char}]
\ No newline at end of file

WrapDebug/ShowWrapped.icl

+implementation module ShowWrapped
+
+import StdEnv
+import Wrap
+
+ShowParentheses
+	:==	True
+Don`tShowParentheses
+	:==	False
+
+showWrapped :: WrappedNode -> [{#Char}]
+showWrapped node
+	=	show Don`tShowParentheses node
+
+show :: Bool WrappedNode -> [{#Char}]
+show _ (WrappedInt i)
+	=	[toString i]
+show _ (WrappedChar c)
+	=	["\'" +++ toString c +++ "\'"]
+show _ (WrappedBool b)
+	=	[toString b]
+show _ (WrappedReal r)
+	=	[toString r]
+show _ (WrappedFile _)
+	=	["File"]
+show _ (WrappedString s)
+	=	["\"" +++ s +++ "\""]
+show _ (WrappedIntArray a)
+	=	showBasicArray a
+show _ (WrappedBoolArray a)
+	=	showBasicArray a
+show _ (WrappedRealArray a)
+	=	showBasicArray a
+show _ (WrappedFileArray a)
+	=	showBasicArray a
+show _ (WrappedArray a)
+	=	["{" : flatten (separate [", "] [show Don`tShowParentheses el \\ el <-: a])] ++ ["}"]
+show _ (WrappedRecord descriptor args)
+	=	["{" : flatten (separate [" "] [[showDescriptor descriptor] : [show ShowParentheses arg \\ arg <-: args]])] ++ ["}"]
+show _ (WrappedOther WrappedDescriptorCons args)
+	| size args == 2
+		=	["[" : flatten [show Don`tShowParentheses args.[0] : showTail args.[1]]] ++ ["]"]
+	where
+		showTail :: WrappedNode -> [[{#Char}]]
+		showTail (WrappedOther WrappedDescriptorCons args)
+			| size args == 2
+				=	[[", "], show Don`tShowParentheses args.[0] : showTail args.[1]]
+		showTail (WrappedOther WrappedDescriptorNil args)
+			| size args == 0
+				=	[]
+		showTail node // abnormal list
+			=	[[" : " : show Don`tShowParentheses node]]
+show _ (WrappedOther WrappedDescriptorTuple args)
+	=	["(" : flatten (separate [", "] [show Don`tShowParentheses arg \\ arg <-: args])] ++ [")"]
+show parentheses (WrappedOther descriptor args)
+	| parentheses && size args > 0
+		=	["(" : application] ++ [")"]
+	// otherwise
+		=	application
+	where
+		application
+			=	flatten (separate [" "] [[showDescriptor descriptor] : [show ShowParentheses arg \\ arg <-: args]])
+
+showDescriptor :: WrappedDescriptor -> {#Char}
+showDescriptor (WrappedDescriptorOther id)
+	=	toString id
+showDescriptor WrappedDescriptorNil
+	=	"[]"
+showDescriptor WrappedDescriptorCons
+	=	"[:]"
+showDescriptor WrappedDescriptorTuple
+	=	"(..)"
+
+showBasicArray :: {#a} -> [{#Char}] | toString, ArrayElem a
+showBasicArray a
+	=	["{" : separate ", " [toString el \\ el <-: a]] ++ ["}"]
+
+showWrappedArray :: {WrappedNode} -> [{#Char}]
+showWrappedArray a
+	=	["{" : flatten (separate [", "] [show Don`tShowParentheses el \\ el <-: a])] ++ ["}"]
+
+separate :: a [a] -> [a]
+separate separator [a : t=:[b : _]]
+	=	[a, separator : separate separator t]
+separate _ l
+	=	l
+
+instance toString File
+where
+	toString :: File -> {#Char}
+	toString _
+		=	"File"

WrapDebug/Wrap.dcl

+/*
+	Wrap Clean nodes (for debugging purposes).
+
+	Version 1.0.2
+	Ronny Wichers Schreur
+	ronny@cs.kun.nl
+*/
+definition module Wrap
+
+from StdOverloaded import toString 
+
+::	WrappedDescriptorId
+
+instance toString WrappedDescriptorId
+
+::	WrappedDescriptor
+    =   WrappedDescriptorCons
+    |   WrappedDescriptorNil
+    |   WrappedDescriptorTuple
+    |   WrappedDescriptorOther !WrappedDescriptorId
+
+::  WrappedNode
+	//	basic types
+    =   WrappedInt !Int
+    |   WrappedChar !Char
+    |   WrappedBool !Bool
+    |   WrappedReal !Real
+    |   WrappedFile !File
+
+	// unboxed arrays of basic types
+    |   WrappedString !{#Char}
+    |   WrappedIntArray !{#Int}
+    |   WrappedBoolArray !{#Bool}
+    |   WrappedRealArray !{#Real}
+    |   WrappedFileArray !{#File}
+
+	// other arrays
+    |   WrappedArray !{WrappedNode}
+
+	// records
+    |   WrappedRecord !WrappedDescriptor !{WrappedNode}
+
+	// other nodes
+    |   WrappedOther !WrappedDescriptor !{WrappedNode}
+
+wrapNode :: !.a -> WrappedNode
\ No newline at end of file

WrapDebug/Wrap.icl

+/*
+	Wrap Clean nodes (for debugging purposes).
+
+	Version 1.0.2
+	Ronny Wichers Schreur
+	ronny@cs.kun.nl
+*/
+implementation module Wrap
+
+import	StdOverloaded
+
+::	WrappedDescriptorId = {descriptorId :: !Int}
+
+::  WrappedDescriptor
+    =   WrappedDescriptorCons
+    |   WrappedDescriptorNil
+    |   WrappedDescriptorTuple
+    |   WrappedDescriptorOther !WrappedDescriptorId
+
+::  WrappedNode
+    =   WrappedInt !Int
+    |   WrappedChar !Char
+    |   WrappedBool !Bool
+    |   WrappedReal !Real
+    |   WrappedFile !File
+    |   WrappedString !{#Char}
+    |   WrappedIntArray !{#Int}
+    |   WrappedBoolArray !{#Bool}
+    |   WrappedRealArray !{#Real}
+    |   WrappedFileArray !{#File}
+    |   WrappedArray !{WrappedNode}
+    |   WrappedRecord !WrappedDescriptor !{WrappedNode}
+    |   WrappedOther !WrappedDescriptor !{WrappedNode}
+
+instance toString WrappedDescriptorId where
+	toString :: WrappedDescriptorId -> {#Char}
+	toString {descriptorId}
+		=	descriptorIDtoString descriptorId
+	where
+		descriptorIDtoString :: !Int -> {#Char}
+		descriptorIDtoString id
+			=	code
+			{
+			.d 0 1 i
+				jsr DtoAC
+			.o 1 0
+			}
+