Commit 03a007d4 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏢
Browse files

Removed debug modules (they moved to separate directory)

parent 6ea28356
definition module Debug
:: DebugShowFunction a :== !a -> [{#Char}]
debugBefore :: !.a !(DebugShowFunction .a) .b -> .b
debugAfter :: !.a !(DebugShowFunction .a) !.b -> .b
debugValue :: !(DebugShowFunction .a) !.a -> .a
debugShow :: DebugShowFunction .a
debugShowWithOptions :: [DebugShowOption] -> DebugShowFunction .a
:: DebugShowOption
= DebugMaxDepth !Int // default MaxInt
| DebugMaxBreadth !Int // default MaxInt
| DebugMaxChars !Int // default MaxInt
| DebugTerminator !{#Char} // default "\n"
implementation module Debug
import StdArray, StdEnum
from StdFile import <<<, ferror, stderr
from StdMisc import abort
from StdTuple import fst
from StdList import ++
from StdBool import &&
from StdString import %
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
= print (show copy1) copy2
where
(copy1, copy2)
= copyUniqueValue value
copyUniqueValue :: !.a -> (!.a, !.a)
copyUniqueValue value
= code {
.o 1 0
push_a 0
.d 2 0
}
:: DebugShowFunction a :== !a -> [{#Char}]
debugShow :: DebugShowFunction .a
debugShow
= \debugValue -> showWrapped (wrapNode debugValue) ++ ["\n"]
:: 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"
debugShowWithOptions :: [DebugShowOption] -> DebugShowFunction .a
debugShowWithOptions debugOptions
= \debug -> chop maxChars (showWrapped (pruneWrappedNode maxDepth maxBreadth (wrapNode debug))) ++ [terminator]
where
{maxDepth, maxBreadth, maxChars, terminator}
= set debugOptions DebugDefaultOptions
where
set [] options
= options
set [DebugMaxDepth maxDepth:t] options
= set t {options & maxDepth=maxDepth}
set [DebugMaxBreadth maxBreadth:t] options
= set t {options & maxBreadth=maxBreadth}
set [DebugMaxChars maxChars:t] options
= set t {options & maxChars=maxChars}
set [DebugTerminator terminator:t] options
= set t {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}
chop :: !Int ![{#Char}] -> [{#Char}]
chop _ []
= []
chop maxSize list=:[string:strings]
| maxSize < stringSize + sizeMaxCharsString
| fits maxSize list
= list
| stringSize > sizeMaxCharsString
= [string % (0, maxSize-sizeMaxCharsString-1), MaxCharsString]
// otherwise
= [MaxCharsString]
// otherwise
= [string : chop (maxSize - stringSize) strings]
where
fits _ []
= True
fits maxSize [h : t]
= maxSize >= size h && fits (maxSize - size h) t
stringSize
= size string
sizeMaxCharsString
= size MaxCharsString
instance <<< [a] | <<< a where
(<<<) :: *File [a] -> *File | <<< a
(<<<) file []
= file
(<<<) file [h:t]
= file <<< h <<< t
definition module RWSDebug
(->>) :: !.a !.b -> .a
(<<-) :: .a !.b -> .a
<<->> :: !.a -> .a
\ No newline at end of file
implementation module RWSDebug
import Debug
show x
= debugShowWithOptions [DebugMaxChars 80, DebugMaxDepth 5] x
(->>) :: !.a !.b -> .a
(->>) value debugValue
= debugAfter debugValue show value
(<<-) :: .a !.b -> .a
(<<-) value debugValue
= debugBefore debugValue show value
<<->> :: !.a -> .a
<<->> value
= debugValue show value
definition module ShowWrapped
from Wrap import WrappedNode
showWrapped :: WrappedNode -> [{#Char}]
\ No newline at end of file
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"
/*
Wrap Clean nodes (for debugging purposes).
Version 1.0.1
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
/*
Wrap Clean nodes (for debugging purposes).
Version 1.0.1
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
}
wrapNode :: !.a -> WrappedNode
wrapNode node
= code
{
| A: <node> <result>
| B:
eq_desc BOOL 0 0
jmp_false not_a_bool
pushB_a 0
pop_a 1
fill_r e_Wrap_kWrappedBool 0 1 0 0 0
pop_b 1
.d 1 0
rtn
:not_a_bool
eq_desc INT 0 0
jmp_false not_an_int
pushI_a 0
pop_a 1
fill_r e_Wrap_kWrappedInt 0 1 0 0 0
pop_b 1
.d 1 0
rtn
:not_an_int
eq_desc CHAR 0 0
jmp_false not_a_char
pushC_a 0
pop_a 1
fill_r e_Wrap_kWrappedChar 0 1 0 0 0
pop_b 1
.d 1 0
rtn
:not_a_char
eq_desc REAL 0 0
jmp_false not_a_real
pushR_a 0
pop_a 1
fill_r e_Wrap_kWrappedReal 0 2 0 0 0
pop_b 2
.d 1 0
rtn
:not_a_real
eq_desc FILE 0 0
jmp_false not_a_file
pushF_a 0
pop_a 1
fill_r e_Wrap_kWrappedFile 0 2 0 0 0
pop_b 2
.d 1 0
rtn
:not_a_file
eq_desc ARRAY 1 0
jmp_true wrap_array
eq_desc _ARRAY_ 0 0
jmp_true wrap__array
eq_desc _STRING_ 0 0
jmp_true wrap__string
is_record 0
.d 2 0
jmp_true wrap_record
get_node_arity 0
| B: <n>
eqI_b 0 0
jmp_true wrap_no_args
:wrap_args
push_a 0
push_b 0
push_b 0
repl_args_b
| A: <arg_1 .. arg_n> <node> <result>
push_b 0
create_array_ _ 1 0
| A: <_{args}> <arg_1 .. arg_n> <node> <result>
pushI 0
:wrap_args_loop
| A: <_{args}> <arg_(i+1) .. arg_n> <node> <result>
| B: <i> <n>
| wrap arg
push_a 1
build e_Wrap_swrapNode 1 e_Wrap_nwrapNode
update_a 0 2
pop_a 1
| update i-th element of _args array with wrapped arg
push_b 0
update _ 1 0
| increment index
incI
push_b 0
push_b 2
eqI
jmp_false wrap_args_loop
pop_b 2
| A: <_{args}> <node> <result>
| B:
.d 3 0
jmp wrap_descriptor
:wrap_no_args
| A: <node> <result>
| B: <0>
create_array_ _ 1 0
.o 3 0
:wrap_descriptor
| A: <_{args}> <node> <result>
push_a 1
update_a 1 2
update_a 0 1
pop_a 1
| A: <node> <_{args}> <result>
eq_nulldesc _Tuple 0
jmp_false not_a_tuple
build e_Wrap_dWrappedDescriptorTuple 0 _hnf
.d 4 0
jmp wrap_other
:not_a_tuple
eq_nulldesc _Cons 0
jmp_false not_a_cons
build e_Wrap_dWrappedDescriptorCons 0 _hnf
jmp wrap_other
:not_a_cons
eq_desc _Nil 0 0
jmp_false not_a_nil
build e_Wrap_dWrappedDescriptorNil 0 _hnf
jmp wrap_other
:not_a_nil
| A: <node> <_{args}> <result>
pushD_a 0
build_r e_Wrap_rWrappedDescriptorId 0 1 0 0
pop_b 1
build_r e_Wrap_kWrappedDescriptorOther 1 0 0 0
update_a 0 1
pop_a 1
.o 4 0
:wrap_other
| A: <descriptor> <node> <_{args}> <result>
update_a 0 1
pop_a 1
| A: <descriptor> <_{args}> <result>
fill_r e_Wrap_kWrappedOther 2 0 2 0 0
pop_a 2
| A: <result>
.d 1 0
rtn
.o 2 0
| constructors with strict arguments are also represented by records
:wrap_record
pushI 0
pushD_a 0
| A: <node> <result>
| B: <desc> <return>
push_t_r_args
:wrap_record_fields
| A: <afield_1 .. afield_m> <result>
| B: <l> <bfield_1 .. bfield_n> <desc> <return>
| (l: points to record layout,
| desc: record descriptor
| return: return selector)
| determine if it's a record or a constructor with strict arguments
push_b 0
push_r_arg_t
eqC_b 'd' 0
jmp_false is_record