shentong-0.3.1: Shentong/Backend/Track.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE ViewPatterns #-}
module Backend.Track where
import Control.Monad.Except
import Control.Parallel
import Environment
import Primitives as Primitives
import Backend.Utils
import Types as Types
import Utils
import Wrap
import Backend.Toplevel
import Backend.Core
import Backend.Sys
import Backend.Sequent
import Backend.Yacc
import Backend.Reader
import Backend.Prolog
{-
Copyright (c) 2015, Mark Tarver
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. The name of Mark Tarver may not be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY
EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-}
kl_shen_f_error :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_shen_f_error (!kl_V3779) = do let !aw_0 = Types.Atom (Types.UnboundSym "shen.app")
!appl_1 <- kl_V3779 `pseq` applyWrapper aw_0 [kl_V3779,
Types.Atom (Types.Str ";\n"),
Types.Atom (Types.UnboundSym "shen.a")]
!appl_2 <- appl_1 `pseq` cn (Types.Atom (Types.Str "partial function ")) appl_1
!appl_3 <- kl_stoutput
let !aw_4 = Types.Atom (Types.UnboundSym "shen.prhush")
!appl_5 <- appl_2 `pseq` (appl_3 `pseq` applyWrapper aw_4 [appl_2,
appl_3])
!appl_6 <- kl_V3779 `pseq` kl_shen_trackedP kl_V3779
!kl_if_7 <- appl_6 `pseq` kl_not appl_6
!kl_if_8 <- case kl_if_7 of
Atom (B (True)) -> do let !aw_9 = Types.Atom (Types.UnboundSym "shen.app")
!appl_10 <- kl_V3779 `pseq` applyWrapper aw_9 [kl_V3779,
Types.Atom (Types.Str "? "),
Types.Atom (Types.UnboundSym "shen.a")]
!appl_11 <- appl_10 `pseq` cn (Types.Atom (Types.Str "track ")) appl_10
!kl_if_12 <- appl_11 `pseq` kl_y_or_nP appl_11
case kl_if_12 of
Atom (B (True)) -> do return (Atom (B True))
Atom (B (False)) -> do do return (Atom (B False))
_ -> throwError "if: expected boolean"
Atom (B (False)) -> do do return (Atom (B False))
_ -> throwError "if: expected boolean"
!appl_13 <- case kl_if_8 of
Atom (B (True)) -> do !appl_14 <- kl_V3779 `pseq` kl_ps kl_V3779
appl_14 `pseq` kl_shen_track_function appl_14
Atom (B (False)) -> do do return (Types.Atom (Types.UnboundSym "shen.ok"))
_ -> throwError "if: expected boolean"
!appl_15 <- simpleError (Types.Atom (Types.Str "aborted"))
!appl_16 <- appl_13 `pseq` (appl_15 `pseq` kl_do appl_13 appl_15)
appl_5 `pseq` (appl_16 `pseq` kl_do appl_5 appl_16)
kl_shen_trackedP :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_shen_trackedP (!kl_V3781) = do !appl_0 <- value (Types.Atom (Types.UnboundSym "shen.*tracking*"))
kl_V3781 `pseq` (appl_0 `pseq` kl_elementP kl_V3781 appl_0)
kl_track :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_track (!kl_V3783) = do let !appl_0 = ApplC (Func "lambda" (Context (\(!kl_Source) -> do kl_Source `pseq` kl_shen_track_function kl_Source)))
!appl_1 <- kl_V3783 `pseq` kl_ps kl_V3783
appl_1 `pseq` applyWrapper appl_0 [appl_1]
kl_shen_track_function :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_shen_track_function (!kl_V3785) = do let pat_cond_0 kl_V3785 kl_V3785t kl_V3785th kl_V3785tt kl_V3785tth kl_V3785ttt kl_V3785ttth = do let !appl_1 = ApplC (Func "lambda" (Context (\(!kl_KL) -> do let !appl_2 = ApplC (Func "lambda" (Context (\(!kl_Ob) -> do let !appl_3 = ApplC (Func "lambda" (Context (\(!kl_Tr) -> do return kl_Ob)))
!appl_4 <- value (Types.Atom (Types.UnboundSym "shen.*tracking*"))
!appl_5 <- kl_Ob `pseq` (appl_4 `pseq` klCons kl_Ob appl_4)
!appl_6 <- appl_5 `pseq` klSet (Types.Atom (Types.UnboundSym "shen.*tracking*")) appl_5
appl_6 `pseq` applyWrapper appl_3 [appl_6])))
!appl_7 <- kl_KL `pseq` evalKL kl_KL
appl_7 `pseq` applyWrapper appl_2 [appl_7])))
!appl_8 <- kl_V3785th `pseq` (kl_V3785tth `pseq` (kl_V3785ttth `pseq` kl_shen_insert_tracking_code kl_V3785th kl_V3785tth kl_V3785ttth))
!appl_9 <- appl_8 `pseq` klCons appl_8 (Types.Atom Types.Nil)
!appl_10 <- kl_V3785tth `pseq` (appl_9 `pseq` klCons kl_V3785tth appl_9)
!appl_11 <- kl_V3785th `pseq` (appl_10 `pseq` klCons kl_V3785th appl_10)
!appl_12 <- appl_11 `pseq` klCons (Types.Atom (Types.UnboundSym "defun")) appl_11
appl_12 `pseq` applyWrapper appl_1 [appl_12]
pat_cond_13 = do do kl_shen_f_error (ApplC (wrapNamed "shen.track-function" kl_shen_track_function))
in case kl_V3785 of
!(kl_V3785@(Cons (Atom (UnboundSym "defun"))
(!(kl_V3785t@(Cons (!kl_V3785th)
(!(kl_V3785tt@(Cons (!kl_V3785tth)
(!(kl_V3785ttt@(Cons (!kl_V3785ttth)
(Atom (Nil))))))))))))) -> pat_cond_0 kl_V3785 kl_V3785t kl_V3785th kl_V3785tt kl_V3785tth kl_V3785ttt kl_V3785ttth
!(kl_V3785@(Cons (ApplC (PL "defun" _))
(!(kl_V3785t@(Cons (!kl_V3785th)
(!(kl_V3785tt@(Cons (!kl_V3785tth)
(!(kl_V3785ttt@(Cons (!kl_V3785ttth)
(Atom (Nil))))))))))))) -> pat_cond_0 kl_V3785 kl_V3785t kl_V3785th kl_V3785tt kl_V3785tth kl_V3785ttt kl_V3785ttth
!(kl_V3785@(Cons (ApplC (Func "defun" _))
(!(kl_V3785t@(Cons (!kl_V3785th)
(!(kl_V3785tt@(Cons (!kl_V3785tth)
(!(kl_V3785ttt@(Cons (!kl_V3785ttth)
(Atom (Nil))))))))))))) -> pat_cond_0 kl_V3785 kl_V3785t kl_V3785th kl_V3785tt kl_V3785tth kl_V3785ttt kl_V3785ttth
_ -> pat_cond_13
kl_shen_insert_tracking_code :: Types.KLValue ->
Types.KLValue ->
Types.KLValue -> Types.KLContext Types.Env Types.KLValue
kl_shen_insert_tracking_code (!kl_V3789) (!kl_V3790) (!kl_V3791) = do !appl_0 <- klCons (Types.Atom (Types.UnboundSym "shen.*call*")) (Types.Atom Types.Nil)
!appl_1 <- appl_0 `pseq` klCons (ApplC (wrapNamed "value" value)) appl_0
!appl_2 <- klCons (Types.Atom (Types.N (Types.KI 1))) (Types.Atom Types.Nil)
!appl_3 <- appl_1 `pseq` (appl_2 `pseq` klCons appl_1 appl_2)
!appl_4 <- appl_3 `pseq` klCons (ApplC (wrapNamed "+" add)) appl_3
!appl_5 <- appl_4 `pseq` klCons appl_4 (Types.Atom Types.Nil)
!appl_6 <- appl_5 `pseq` klCons (Types.Atom (Types.UnboundSym "shen.*call*")) appl_5
!appl_7 <- appl_6 `pseq` klCons (ApplC (wrapNamed "set" klSet)) appl_6
!appl_8 <- klCons (Types.Atom (Types.UnboundSym "shen.*call*")) (Types.Atom Types.Nil)
!appl_9 <- appl_8 `pseq` klCons (ApplC (wrapNamed "value" value)) appl_8
!appl_10 <- kl_V3790 `pseq` kl_shen_cons_form kl_V3790
!appl_11 <- appl_10 `pseq` klCons appl_10 (Types.Atom Types.Nil)
!appl_12 <- kl_V3789 `pseq` (appl_11 `pseq` klCons kl_V3789 appl_11)
!appl_13 <- appl_9 `pseq` (appl_12 `pseq` klCons appl_9 appl_12)
!appl_14 <- appl_13 `pseq` klCons (ApplC (wrapNamed "shen.input-track" kl_shen_input_track)) appl_13
!appl_15 <- klCons (ApplC (PL "shen.terpri-or-read-char" kl_shen_terpri_or_read_char)) (Types.Atom Types.Nil)
!appl_16 <- klCons (Types.Atom (Types.UnboundSym "shen.*call*")) (Types.Atom Types.Nil)
!appl_17 <- appl_16 `pseq` klCons (ApplC (wrapNamed "value" value)) appl_16
!appl_18 <- klCons (Types.Atom (Types.UnboundSym "Result")) (Types.Atom Types.Nil)
!appl_19 <- kl_V3789 `pseq` (appl_18 `pseq` klCons kl_V3789 appl_18)
!appl_20 <- appl_17 `pseq` (appl_19 `pseq` klCons appl_17 appl_19)
!appl_21 <- appl_20 `pseq` klCons (ApplC (wrapNamed "shen.output-track" kl_shen_output_track)) appl_20
!appl_22 <- klCons (Types.Atom (Types.UnboundSym "shen.*call*")) (Types.Atom Types.Nil)
!appl_23 <- appl_22 `pseq` klCons (ApplC (wrapNamed "value" value)) appl_22
!appl_24 <- klCons (Types.Atom (Types.N (Types.KI 1))) (Types.Atom Types.Nil)
!appl_25 <- appl_23 `pseq` (appl_24 `pseq` klCons appl_23 appl_24)
!appl_26 <- appl_25 `pseq` klCons (ApplC (wrapNamed "-" Primitives.subtract)) appl_25
!appl_27 <- appl_26 `pseq` klCons appl_26 (Types.Atom Types.Nil)
!appl_28 <- appl_27 `pseq` klCons (Types.Atom (Types.UnboundSym "shen.*call*")) appl_27
!appl_29 <- appl_28 `pseq` klCons (ApplC (wrapNamed "set" klSet)) appl_28
!appl_30 <- klCons (ApplC (PL "shen.terpri-or-read-char" kl_shen_terpri_or_read_char)) (Types.Atom Types.Nil)
!appl_31 <- klCons (Types.Atom (Types.UnboundSym "Result")) (Types.Atom Types.Nil)
!appl_32 <- appl_30 `pseq` (appl_31 `pseq` klCons appl_30 appl_31)
!appl_33 <- appl_32 `pseq` klCons (ApplC (wrapNamed "do" kl_do)) appl_32
!appl_34 <- appl_33 `pseq` klCons appl_33 (Types.Atom Types.Nil)
!appl_35 <- appl_29 `pseq` (appl_34 `pseq` klCons appl_29 appl_34)
!appl_36 <- appl_35 `pseq` klCons (ApplC (wrapNamed "do" kl_do)) appl_35
!appl_37 <- appl_36 `pseq` klCons appl_36 (Types.Atom Types.Nil)
!appl_38 <- appl_21 `pseq` (appl_37 `pseq` klCons appl_21 appl_37)
!appl_39 <- appl_38 `pseq` klCons (ApplC (wrapNamed "do" kl_do)) appl_38
!appl_40 <- appl_39 `pseq` klCons appl_39 (Types.Atom Types.Nil)
!appl_41 <- kl_V3791 `pseq` (appl_40 `pseq` klCons kl_V3791 appl_40)
!appl_42 <- appl_41 `pseq` klCons (Types.Atom (Types.UnboundSym "Result")) appl_41
!appl_43 <- appl_42 `pseq` klCons (Types.Atom (Types.UnboundSym "let")) appl_42
!appl_44 <- appl_43 `pseq` klCons appl_43 (Types.Atom Types.Nil)
!appl_45 <- appl_15 `pseq` (appl_44 `pseq` klCons appl_15 appl_44)
!appl_46 <- appl_45 `pseq` klCons (ApplC (wrapNamed "do" kl_do)) appl_45
!appl_47 <- appl_46 `pseq` klCons appl_46 (Types.Atom Types.Nil)
!appl_48 <- appl_14 `pseq` (appl_47 `pseq` klCons appl_14 appl_47)
!appl_49 <- appl_48 `pseq` klCons (ApplC (wrapNamed "do" kl_do)) appl_48
!appl_50 <- appl_49 `pseq` klCons appl_49 (Types.Atom Types.Nil)
!appl_51 <- appl_7 `pseq` (appl_50 `pseq` klCons appl_7 appl_50)
appl_51 `pseq` klCons (ApplC (wrapNamed "do" kl_do)) appl_51
kl_step :: Types.KLValue -> Types.KLContext Types.Env Types.KLValue
kl_step (!kl_V3797) = do let pat_cond_0 = do klSet (Types.Atom (Types.UnboundSym "shen.*step*")) (Atom (B True))
pat_cond_1 = do klSet (Types.Atom (Types.UnboundSym "shen.*step*")) (Atom (B False))
pat_cond_2 = do do simpleError (Types.Atom (Types.Str "step expects a + or a -.\n"))
in case kl_V3797 of
kl_V3797@(Atom (UnboundSym "+")) -> pat_cond_0
kl_V3797@(ApplC (PL "+" _)) -> pat_cond_0
kl_V3797@(ApplC (Func "+" _)) -> pat_cond_0
kl_V3797@(Atom (UnboundSym "-")) -> pat_cond_1
kl_V3797@(ApplC (PL "-" _)) -> pat_cond_1
kl_V3797@(ApplC (Func "-" _)) -> pat_cond_1
_ -> pat_cond_2
kl_spy :: Types.KLValue -> Types.KLContext Types.Env Types.KLValue
kl_spy (!kl_V3803) = do let pat_cond_0 = do klSet (Types.Atom (Types.UnboundSym "shen.*spy*")) (Atom (B True))
pat_cond_1 = do klSet (Types.Atom (Types.UnboundSym "shen.*spy*")) (Atom (B False))
pat_cond_2 = do do simpleError (Types.Atom (Types.Str "spy expects a + or a -.\n"))
in case kl_V3803 of
kl_V3803@(Atom (UnboundSym "+")) -> pat_cond_0
kl_V3803@(ApplC (PL "+" _)) -> pat_cond_0
kl_V3803@(ApplC (Func "+" _)) -> pat_cond_0
kl_V3803@(Atom (UnboundSym "-")) -> pat_cond_1
kl_V3803@(ApplC (PL "-" _)) -> pat_cond_1
kl_V3803@(ApplC (Func "-" _)) -> pat_cond_1
_ -> pat_cond_2
kl_shen_terpri_or_read_char :: Types.KLContext Types.Env
Types.KLValue
kl_shen_terpri_or_read_char = do !kl_if_0 <- value (Types.Atom (Types.UnboundSym "shen.*step*"))
case kl_if_0 of
Atom (B (True)) -> do !appl_1 <- value (Types.Atom (Types.UnboundSym "*stinput*"))
!appl_2 <- appl_1 `pseq` readByte appl_1
appl_2 `pseq` kl_shen_check_byte appl_2
Atom (B (False)) -> do do kl_nl (Types.Atom (Types.N (Types.KI 1)))
_ -> throwError "if: expected boolean"
kl_shen_check_byte :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_shen_check_byte (!kl_V3809) = do !appl_0 <- kl_shen_hat
!kl_if_1 <- kl_V3809 `pseq` (appl_0 `pseq` eq kl_V3809 appl_0)
case kl_if_1 of
Atom (B (True)) -> do simpleError (Types.Atom (Types.Str "aborted"))
Atom (B (False)) -> do do return (Atom (B True))
_ -> throwError "if: expected boolean"
kl_shen_input_track :: Types.KLValue ->
Types.KLValue ->
Types.KLValue -> Types.KLContext Types.Env Types.KLValue
kl_shen_input_track (!kl_V3813) (!kl_V3814) (!kl_V3815) = do !appl_0 <- kl_V3813 `pseq` kl_shen_spaces kl_V3813
!appl_1 <- kl_V3813 `pseq` kl_shen_spaces kl_V3813
let !aw_2 = Types.Atom (Types.UnboundSym "shen.app")
!appl_3 <- appl_1 `pseq` applyWrapper aw_2 [appl_1,
Types.Atom (Types.Str ""),
Types.Atom (Types.UnboundSym "shen.a")]
!appl_4 <- appl_3 `pseq` cn (Types.Atom (Types.Str " \n")) appl_3
let !aw_5 = Types.Atom (Types.UnboundSym "shen.app")
!appl_6 <- kl_V3814 `pseq` (appl_4 `pseq` applyWrapper aw_5 [kl_V3814,
appl_4,
Types.Atom (Types.UnboundSym "shen.a")])
!appl_7 <- appl_6 `pseq` cn (Types.Atom (Types.Str "> Inputs to ")) appl_6
let !aw_8 = Types.Atom (Types.UnboundSym "shen.app")
!appl_9 <- kl_V3813 `pseq` (appl_7 `pseq` applyWrapper aw_8 [kl_V3813,
appl_7,
Types.Atom (Types.UnboundSym "shen.a")])
!appl_10 <- appl_9 `pseq` cn (Types.Atom (Types.Str "<")) appl_9
let !aw_11 = Types.Atom (Types.UnboundSym "shen.app")
!appl_12 <- appl_0 `pseq` (appl_10 `pseq` applyWrapper aw_11 [appl_0,
appl_10,
Types.Atom (Types.UnboundSym "shen.a")])
!appl_13 <- appl_12 `pseq` cn (Types.Atom (Types.Str "\n")) appl_12
!appl_14 <- kl_stoutput
let !aw_15 = Types.Atom (Types.UnboundSym "shen.prhush")
!appl_16 <- appl_13 `pseq` (appl_14 `pseq` applyWrapper aw_15 [appl_13,
appl_14])
!appl_17 <- kl_V3815 `pseq` kl_shen_recursively_print kl_V3815
appl_16 `pseq` (appl_17 `pseq` kl_do appl_16 appl_17)
kl_shen_recursively_print :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_shen_recursively_print (!kl_V3817) = do let pat_cond_0 = do !appl_1 <- kl_stoutput
let !aw_2 = Types.Atom (Types.UnboundSym "shen.prhush")
appl_1 `pseq` applyWrapper aw_2 [Types.Atom (Types.Str " ==>"),
appl_1]
pat_cond_3 kl_V3817 kl_V3817h kl_V3817t = do let !aw_4 = Types.Atom (Types.UnboundSym "print")
!appl_5 <- kl_V3817h `pseq` applyWrapper aw_4 [kl_V3817h]
!appl_6 <- kl_stoutput
let !aw_7 = Types.Atom (Types.UnboundSym "shen.prhush")
!appl_8 <- appl_6 `pseq` applyWrapper aw_7 [Types.Atom (Types.Str ", "),
appl_6]
!appl_9 <- kl_V3817t `pseq` kl_shen_recursively_print kl_V3817t
!appl_10 <- appl_8 `pseq` (appl_9 `pseq` kl_do appl_8 appl_9)
appl_5 `pseq` (appl_10 `pseq` kl_do appl_5 appl_10)
pat_cond_11 = do do kl_shen_f_error (ApplC (wrapNamed "shen.recursively-print" kl_shen_recursively_print))
in case kl_V3817 of
kl_V3817@(Atom (Nil)) -> pat_cond_0
!(kl_V3817@(Cons (!kl_V3817h)
(!kl_V3817t))) -> pat_cond_3 kl_V3817 kl_V3817h kl_V3817t
_ -> pat_cond_11
kl_shen_spaces :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_shen_spaces (!kl_V3819) = do let pat_cond_0 = do return (Types.Atom (Types.Str ""))
pat_cond_1 = do do !appl_2 <- kl_V3819 `pseq` Primitives.subtract kl_V3819 (Types.Atom (Types.N (Types.KI 1)))
!appl_3 <- appl_2 `pseq` kl_shen_spaces appl_2
appl_3 `pseq` cn (Types.Atom (Types.Str " ")) appl_3
in case kl_V3819 of
kl_V3819@(Atom (N (KI 0))) -> pat_cond_0
_ -> pat_cond_1
kl_shen_output_track :: Types.KLValue ->
Types.KLValue ->
Types.KLValue -> Types.KLContext Types.Env Types.KLValue
kl_shen_output_track (!kl_V3823) (!kl_V3824) (!kl_V3825) = do !appl_0 <- kl_V3823 `pseq` kl_shen_spaces kl_V3823
!appl_1 <- kl_V3823 `pseq` kl_shen_spaces kl_V3823
let !aw_2 = Types.Atom (Types.UnboundSym "shen.app")
!appl_3 <- kl_V3825 `pseq` applyWrapper aw_2 [kl_V3825,
Types.Atom (Types.Str ""),
Types.Atom (Types.UnboundSym "shen.s")]
!appl_4 <- appl_3 `pseq` cn (Types.Atom (Types.Str "==> ")) appl_3
let !aw_5 = Types.Atom (Types.UnboundSym "shen.app")
!appl_6 <- appl_1 `pseq` (appl_4 `pseq` applyWrapper aw_5 [appl_1,
appl_4,
Types.Atom (Types.UnboundSym "shen.a")])
!appl_7 <- appl_6 `pseq` cn (Types.Atom (Types.Str " \n")) appl_6
let !aw_8 = Types.Atom (Types.UnboundSym "shen.app")
!appl_9 <- kl_V3824 `pseq` (appl_7 `pseq` applyWrapper aw_8 [kl_V3824,
appl_7,
Types.Atom (Types.UnboundSym "shen.a")])
!appl_10 <- appl_9 `pseq` cn (Types.Atom (Types.Str "> Output from ")) appl_9
let !aw_11 = Types.Atom (Types.UnboundSym "shen.app")
!appl_12 <- kl_V3823 `pseq` (appl_10 `pseq` applyWrapper aw_11 [kl_V3823,
appl_10,
Types.Atom (Types.UnboundSym "shen.a")])
!appl_13 <- appl_12 `pseq` cn (Types.Atom (Types.Str "<")) appl_12
let !aw_14 = Types.Atom (Types.UnboundSym "shen.app")
!appl_15 <- appl_0 `pseq` (appl_13 `pseq` applyWrapper aw_14 [appl_0,
appl_13,
Types.Atom (Types.UnboundSym "shen.a")])
!appl_16 <- appl_15 `pseq` cn (Types.Atom (Types.Str "\n")) appl_15
!appl_17 <- kl_stoutput
let !aw_18 = Types.Atom (Types.UnboundSym "shen.prhush")
appl_16 `pseq` (appl_17 `pseq` applyWrapper aw_18 [appl_16,
appl_17])
kl_untrack :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_untrack (!kl_V3827) = do !appl_0 <- kl_V3827 `pseq` kl_ps kl_V3827
appl_0 `pseq` kl_eval appl_0
kl_profile :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_profile (!kl_V3829) = do !appl_0 <- kl_V3829 `pseq` kl_ps kl_V3829
appl_0 `pseq` kl_shen_profile_help appl_0
kl_shen_profile_help :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_shen_profile_help (!kl_V3835) = do let pat_cond_0 kl_V3835 kl_V3835t kl_V3835th kl_V3835tt kl_V3835tth kl_V3835ttt kl_V3835ttth = do let !appl_1 = ApplC (Func "lambda" (Context (\(!kl_G) -> do let !appl_2 = ApplC (Func "lambda" (Context (\(!kl_Profile) -> do let !appl_3 = ApplC (Func "lambda" (Context (\(!kl_Def) -> do let !appl_4 = ApplC (Func "lambda" (Context (\(!kl_CompileProfile) -> do let !appl_5 = ApplC (Func "lambda" (Context (\(!kl_CompileG) -> do return kl_V3835th)))
!appl_6 <- kl_Def `pseq` kl_shen_eval_without_macros kl_Def
appl_6 `pseq` applyWrapper appl_5 [appl_6])))
!appl_7 <- kl_Profile `pseq` kl_shen_eval_without_macros kl_Profile
appl_7 `pseq` applyWrapper appl_4 [appl_7])))
!appl_8 <- kl_G `pseq` (kl_V3835th `pseq` (kl_V3835ttth `pseq` kl_subst kl_G kl_V3835th kl_V3835ttth))
!appl_9 <- appl_8 `pseq` klCons appl_8 (Types.Atom Types.Nil)
!appl_10 <- kl_V3835tth `pseq` (appl_9 `pseq` klCons kl_V3835tth appl_9)
!appl_11 <- kl_G `pseq` (appl_10 `pseq` klCons kl_G appl_10)
!appl_12 <- appl_11 `pseq` klCons (Types.Atom (Types.UnboundSym "defun")) appl_11
appl_12 `pseq` applyWrapper appl_3 [appl_12])))
!appl_13 <- kl_G `pseq` (kl_V3835tth `pseq` klCons kl_G kl_V3835tth)
!appl_14 <- kl_V3835th `pseq` (kl_V3835tth `pseq` (appl_13 `pseq` kl_shen_profile_func kl_V3835th kl_V3835tth appl_13))
!appl_15 <- appl_14 `pseq` klCons appl_14 (Types.Atom Types.Nil)
!appl_16 <- kl_V3835tth `pseq` (appl_15 `pseq` klCons kl_V3835tth appl_15)
!appl_17 <- kl_V3835th `pseq` (appl_16 `pseq` klCons kl_V3835th appl_16)
!appl_18 <- appl_17 `pseq` klCons (Types.Atom (Types.UnboundSym "defun")) appl_17
appl_18 `pseq` applyWrapper appl_2 [appl_18])))
!appl_19 <- kl_gensym (Types.Atom (Types.UnboundSym "shen.f"))
appl_19 `pseq` applyWrapper appl_1 [appl_19]
pat_cond_20 = do do simpleError (Types.Atom (Types.Str "Cannot profile.\n"))
in case kl_V3835 of
!(kl_V3835@(Cons (Atom (UnboundSym "defun"))
(!(kl_V3835t@(Cons (!kl_V3835th)
(!(kl_V3835tt@(Cons (!kl_V3835tth)
(!(kl_V3835ttt@(Cons (!kl_V3835ttth)
(Atom (Nil))))))))))))) -> pat_cond_0 kl_V3835 kl_V3835t kl_V3835th kl_V3835tt kl_V3835tth kl_V3835ttt kl_V3835ttth
!(kl_V3835@(Cons (ApplC (PL "defun" _))
(!(kl_V3835t@(Cons (!kl_V3835th)
(!(kl_V3835tt@(Cons (!kl_V3835tth)
(!(kl_V3835ttt@(Cons (!kl_V3835ttth)
(Atom (Nil))))))))))))) -> pat_cond_0 kl_V3835 kl_V3835t kl_V3835th kl_V3835tt kl_V3835tth kl_V3835ttt kl_V3835ttth
!(kl_V3835@(Cons (ApplC (Func "defun" _))
(!(kl_V3835t@(Cons (!kl_V3835th)
(!(kl_V3835tt@(Cons (!kl_V3835tth)
(!(kl_V3835ttt@(Cons (!kl_V3835ttth)
(Atom (Nil))))))))))))) -> pat_cond_0 kl_V3835 kl_V3835t kl_V3835th kl_V3835tt kl_V3835tth kl_V3835ttt kl_V3835ttth
_ -> pat_cond_20
kl_unprofile :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_unprofile (!kl_V3837) = do kl_V3837 `pseq` kl_untrack kl_V3837
kl_shen_profile_func :: Types.KLValue ->
Types.KLValue ->
Types.KLValue -> Types.KLContext Types.Env Types.KLValue
kl_shen_profile_func (!kl_V3841) (!kl_V3842) (!kl_V3843) = do !appl_0 <- klCons (Types.Atom (Types.UnboundSym "run")) (Types.Atom Types.Nil)
!appl_1 <- appl_0 `pseq` klCons (ApplC (wrapNamed "get-time" getTime)) appl_0
!appl_2 <- klCons (Types.Atom (Types.UnboundSym "run")) (Types.Atom Types.Nil)
!appl_3 <- appl_2 `pseq` klCons (ApplC (wrapNamed "get-time" getTime)) appl_2
!appl_4 <- klCons (Types.Atom (Types.UnboundSym "Start")) (Types.Atom Types.Nil)
!appl_5 <- appl_3 `pseq` (appl_4 `pseq` klCons appl_3 appl_4)
!appl_6 <- appl_5 `pseq` klCons (ApplC (wrapNamed "-" Primitives.subtract)) appl_5
!appl_7 <- kl_V3841 `pseq` klCons kl_V3841 (Types.Atom Types.Nil)
!appl_8 <- appl_7 `pseq` klCons (ApplC (wrapNamed "shen.get-profile" kl_shen_get_profile)) appl_7
!appl_9 <- klCons (Types.Atom (Types.UnboundSym "Finish")) (Types.Atom Types.Nil)
!appl_10 <- appl_8 `pseq` (appl_9 `pseq` klCons appl_8 appl_9)
!appl_11 <- appl_10 `pseq` klCons (ApplC (wrapNamed "+" add)) appl_10
!appl_12 <- appl_11 `pseq` klCons appl_11 (Types.Atom Types.Nil)
!appl_13 <- kl_V3841 `pseq` (appl_12 `pseq` klCons kl_V3841 appl_12)
!appl_14 <- appl_13 `pseq` klCons (ApplC (wrapNamed "shen.put-profile" kl_shen_put_profile)) appl_13
!appl_15 <- klCons (Types.Atom (Types.UnboundSym "Result")) (Types.Atom Types.Nil)
!appl_16 <- appl_14 `pseq` (appl_15 `pseq` klCons appl_14 appl_15)
!appl_17 <- appl_16 `pseq` klCons (Types.Atom (Types.UnboundSym "Record")) appl_16
!appl_18 <- appl_17 `pseq` klCons (Types.Atom (Types.UnboundSym "let")) appl_17
!appl_19 <- appl_18 `pseq` klCons appl_18 (Types.Atom Types.Nil)
!appl_20 <- appl_6 `pseq` (appl_19 `pseq` klCons appl_6 appl_19)
!appl_21 <- appl_20 `pseq` klCons (Types.Atom (Types.UnboundSym "Finish")) appl_20
!appl_22 <- appl_21 `pseq` klCons (Types.Atom (Types.UnboundSym "let")) appl_21
!appl_23 <- appl_22 `pseq` klCons appl_22 (Types.Atom Types.Nil)
!appl_24 <- kl_V3843 `pseq` (appl_23 `pseq` klCons kl_V3843 appl_23)
!appl_25 <- appl_24 `pseq` klCons (Types.Atom (Types.UnboundSym "Result")) appl_24
!appl_26 <- appl_25 `pseq` klCons (Types.Atom (Types.UnboundSym "let")) appl_25
!appl_27 <- appl_26 `pseq` klCons appl_26 (Types.Atom Types.Nil)
!appl_28 <- appl_1 `pseq` (appl_27 `pseq` klCons appl_1 appl_27)
!appl_29 <- appl_28 `pseq` klCons (Types.Atom (Types.UnboundSym "Start")) appl_28
appl_29 `pseq` klCons (Types.Atom (Types.UnboundSym "let")) appl_29
kl_profile_results :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_profile_results (!kl_V3845) = do let !appl_0 = ApplC (Func "lambda" (Context (\(!kl_Results) -> do let !appl_1 = ApplC (Func "lambda" (Context (\(!kl_Initialise) -> do kl_V3845 `pseq` (kl_Results `pseq` kl_Atp kl_V3845 kl_Results))))
!appl_2 <- kl_V3845 `pseq` kl_shen_put_profile kl_V3845 (Types.Atom (Types.N (Types.KI 0)))
appl_2 `pseq` applyWrapper appl_1 [appl_2])))
!appl_3 <- kl_V3845 `pseq` kl_shen_get_profile kl_V3845
appl_3 `pseq` applyWrapper appl_0 [appl_3]
kl_shen_get_profile :: Types.KLValue ->
Types.KLContext Types.Env Types.KLValue
kl_shen_get_profile (!kl_V3847) = do (do !appl_0 <- value (Types.Atom (Types.UnboundSym "*property-vector*"))
kl_V3847 `pseq` (appl_0 `pseq` kl_get kl_V3847 (ApplC (wrapNamed "profile" kl_profile)) appl_0)) `catchError` (\(!kl_E) -> do return (Types.Atom (Types.N (Types.KI 0))))
kl_shen_put_profile :: Types.KLValue ->
Types.KLValue -> Types.KLContext Types.Env Types.KLValue
kl_shen_put_profile (!kl_V3850) (!kl_V3851) = do !appl_0 <- value (Types.Atom (Types.UnboundSym "*property-vector*"))
kl_V3850 `pseq` (kl_V3851 `pseq` (appl_0 `pseq` kl_put kl_V3850 (ApplC (wrapNamed "profile" kl_profile)) kl_V3851 appl_0))
expr7 :: Types.KLContext Types.Env Types.KLValue
expr7 = do (do return (Types.Atom (Types.Str "Copyright (c) 2015, Mark Tarver\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n1. Redistributions of source code must retain the above copyright\n notice, this list of conditions and the following disclaimer.\n2. Redistributions in binary form must reproduce the above copyright\n notice, this list of conditions and the following disclaimer in the\n documentation and/or other materials provided with the distribution.\n3. The name of Mark Tarver may not be used to endorse or promote products\n derived from this software without specific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY\nEXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\nWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY\nDIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\n(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\nLOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\nON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\nSOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."))) `catchError` (\(!kl_E) -> do return (Types.Atom (Types.Str "E")))
(do klSet (Types.Atom (Types.UnboundSym "shen.*step*")) (Atom (B False))) `catchError` (\(!kl_E) -> do return (Types.Atom (Types.Str "E")))