diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,9 @@ +Copyright (c) 2008, Thomas Davie +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. +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. +Neither the name of the Thomas Davie nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 THE COPYRIGHT OWNER OR CONTRIBUTORS 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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/cap.cabal b/cap.cabal new file mode 100644 --- /dev/null +++ b/cap.cabal @@ -0,0 +1,32 @@ +Name: cap +Cabal-Version: >= 1.2 +Version: 1.0 +Synopsis: Interprets and debug the cap language. +Description: An interpreter and debugger for the cap language. +License: BSD3 +License-file: LICENSE +Author: Thomas Davie +Maintainer: Thomas Davie (tom.davie@gmail.com) +Data-Files: README +Category: Distribution +build-type: Simple +Extra-source-files: examples/add.cap + examples/allOdd.cap + examples/fx.cap + examples/higherOrder.cap + examples/problem.cap + examples/test.cap +Executable cap + Build-Depends: base >= 3.0,haskell98 >= 1.0,containers,array + hs-source-dirs: src + Main-is: Language/Cap/Main.hs + Other-Modules: Language.Cap.Debug.Algorithmic, + Language.Cap.Debug.Dotty, + Language.Cap.Debug.EDT, + Language.Cap.Debug.FDT, + Language.Cap.Debug.Trace, + Language.Cap.Debug.TraceMode, + Language.Cap.Interpret.Parse, + Language.Cap.Interpret.Pretty, + Language.Cap.Interpret.Program + diff --git a/dist/build/cap/cap-tmp/Language/Cap/Interpret/Parse.hs b/dist/build/cap/cap-tmp/Language/Cap/Interpret/Parse.hs new file mode 100644 --- /dev/null +++ b/dist/build/cap/cap-tmp/Language/Cap/Interpret/Parse.hs @@ -0,0 +1,795 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +module Language.Cap.Interpret.Parse + (Program,RewriteRule(..),Term(..) + ,parseProgram,parseTerm + ,functionName,showRule) where + +import Language.Cap.Interpret.Pretty + +import Data.Char +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif + +-- parser produced by Happy Version 1.17 + +newtype HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15 = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = GHC.Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn5 :: t5 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyIn5 x = unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> t5 +happyOut5 x = unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: t6 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyIn6 x = unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> t6 +happyOut6 x = unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: t7 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyIn7 x = unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> t7 +happyOut7 x = unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: t8 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyIn8 x = unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> t8 +happyOut8 x = unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: t9 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyIn9 x = unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> t9 +happyOut9 x = unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: t10 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyIn10 x = unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> t10 +happyOut10 x = unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: t11 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyIn11 x = unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> t11 +happyOut11 x = unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: t12 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyIn12 x = unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> t12 +happyOut12 x = unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: t13 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyIn13 x = unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> t13 +happyOut13 x = unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: t14 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyIn14 x = unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> t14 +happyOut14 x = unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: t15 -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyIn15 x = unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> t15 +happyOut15 x = unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyInTok :: Token -> (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) +happyInTok x = unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15) -> Token +happyOutTok x = unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x56\x00\x4e\x00\x1c\x00\x00\x00\x47\x00\x29\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x44\x00\x1d\x00\x56\x00\x22\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x3d\x00\x00\x00\x1a\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x0f\x00\x0c\x00\x00\x00\x00\x00\x0d\x00\x04\x00\x02\x00\x33\x00\x30\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xff\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x68\x00\x4c\x00\x00\x00\x00\x00\x7e\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x65\x00\x7b\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x5c\x00\x00\x00\x73\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x6e\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x59\x00\x64\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\xfd\xff\xe7\xff\x00\x00\x00\x00\xe6\xff\xec\xff\xe5\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xff\x00\x00\xfc\xff\xf9\xff\xf6\xff\xf5\xff\xef\xff\xf4\xff\x00\x00\x00\x00\xfb\xff\x00\x00\x00\x00\xe3\xff\xe8\xff\xe2\xff\xea\xff\xe1\xff\xe0\xff\x00\x00\xed\xff\x00\x00\x00\x00\xe9\xff\xee\xff\x00\x00\x00\x00\xf1\xff\x00\x00\xfa\xff\x00\x00\xf2\xff\xf0\xff\xf7\xff\xe4\xff\xeb\xff\xf3\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x08\x00\x01\x00\x02\x00\x03\x00\x01\x00\x02\x00\x03\x00\x07\x00\x08\x00\x08\x00\x07\x00\x08\x00\x01\x00\x02\x00\x03\x00\x01\x00\x02\x00\x03\x00\x07\x00\x08\x00\x08\x00\x07\x00\x08\x00\x01\x00\x02\x00\x03\x00\x01\x00\x02\x00\x03\x00\x07\x00\x08\x00\x04\x00\x07\x00\x08\x00\x01\x00\x02\x00\x03\x00\x09\x00\xff\xff\x06\x00\x07\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\x07\x00\x01\x00\x02\x00\x03\x00\x01\x00\x02\x00\x03\x00\x07\x00\xff\xff\xff\xff\x07\x00\x01\x00\x02\x00\x03\x00\x01\x00\x02\x00\x03\x00\x07\x00\xff\xff\xff\xff\x07\x00\x01\x00\x02\x00\x03\x00\x01\x00\x02\x00\x03\x00\x07\x00\xff\xff\xff\xff\x07\x00\x01\x00\x02\x00\x03\x00\x06\x00\xff\xff\x08\x00\x07\x00\x0a\x00\x01\x00\xff\xff\xff\xff\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x00\x00\x01\x00\x02\x00\x00\x00\x01\x00\x02\x00\x07\x00\x03\x00\x09\x00\x05\x00\x03\x00\xff\xff\x05\x00\x07\x00\xff\xff\x09\x00\x07\x00\x06\x00\x09\x00\x08\x00\x07\x00\x07\x00\x09\x00\x09\x00\x06\x00\x03\x00\x08\x00\x05\x00\x07\x00\x06\x00\x09\x00\x08\x00\x07\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\xf0\xff\x14\x00\x15\x00\x16\x00\x14\x00\x15\x00\x16\x00\x18\x00\x33\x00\xef\xff\x18\x00\x2f\x00\x1e\x00\x1f\x00\x20\x00\x1e\x00\x1f\x00\x20\x00\x22\x00\x31\x00\x30\x00\x22\x00\x32\x00\x1e\x00\x1f\x00\x20\x00\x1e\x00\x1f\x00\x20\x00\x22\x00\x26\x00\x04\x00\x22\x00\x27\x00\x14\x00\x15\x00\x16\x00\xff\xff\x00\x00\x17\x00\x18\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x00\x00\x00\x00\x22\x00\x1e\x00\x1f\x00\x20\x00\x14\x00\x2a\x00\x16\x00\x22\x00\x00\x00\x00\x00\x2b\x00\x08\x00\x09\x00\x0a\x00\x14\x00\x2a\x00\x16\x00\x0b\x00\x00\x00\x00\x00\x2b\x00\x08\x00\x09\x00\x0a\x00\x1e\x00\x1f\x00\x20\x00\x0b\x00\x00\x00\x00\x00\x22\x00\x08\x00\x09\x00\x0a\x00\x04\x00\x00\x00\x05\x00\x0b\x00\x06\x00\x0f\x00\x00\x00\x00\x00\x04\x00\x10\x00\x27\x00\x2c\x00\x12\x00\x27\x00\x28\x00\x12\x00\x10\x00\x0c\x00\x0d\x00\x18\x00\x0c\x00\x0d\x00\x0b\x00\x0c\x00\x0d\x00\x1b\x00\x2d\x00\x1c\x00\x12\x00\x2d\x00\x00\x00\x12\x00\x1b\x00\x00\x00\x1c\x00\x1b\x00\x23\x00\x22\x00\x24\x00\x1b\x00\x1b\x00\x1c\x00\x22\x00\x04\x00\x11\x00\x2b\x00\x12\x00\x1b\x00\x19\x00\x1c\x00\x1a\x00\x1b\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = array (2, 31) [ + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31) + ] + +happy_n_terms = 10 :: Int +happy_n_nonterms = 11 :: Int + +happyReduce_2 = happySpecReduce_1 0# happyReduction_2 +happyReduction_2 happy_x_1 + = happyIn5 + ([] + ) + +happyReduce_3 = happySpecReduce_2 0# happyReduction_3 +happyReduction_3 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn5 + (happy_var_2 + )} + +happyReduce_4 = happySpecReduce_2 0# happyReduction_4 +happyReduction_4 happy_x_2 + happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn5 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_5 = happySpecReduce_3 1# happyReduction_5 +happyReduction_5 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_3 of { happy_var_3 -> + happyIn6 + (Rule happy_var_1 happy_var_3 + )}} + +happyReduce_6 = happySpecReduce_2 2# happyReduction_6 +happyReduction_6 happy_x_2 + happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn7 + (TApplication happy_var_1 happy_var_2 + )}} + +happyReduce_7 = happySpecReduce_1 2# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenVariable happy_var_1) -> + happyIn7 + (TAtom happy_var_1 + )} + +happyReduce_8 = happySpecReduce_3 3# happyReduction_8 +happyReduction_8 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn8 + (happy_var_2 + )} + +happyReduce_9 = happySpecReduce_1 3# happyReduction_9 +happyReduction_9 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn8 + (happy_var_1 + )} + +happyReduce_10 = happySpecReduce_1 3# happyReduction_10 +happyReduction_10 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenVariable happy_var_1) -> + happyIn8 + (TVariable happy_var_1 + )} + +happyReduce_11 = happySpecReduce_1 3# happyReduction_11 +happyReduction_11 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenNumber happy_var_1) -> + happyIn8 + (TAtom happy_var_1 + )} + +happyReduce_12 = happySpecReduce_3 4# happyReduction_12 +happyReduction_12 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut9 happy_x_2 of { happy_var_2 -> + happyIn9 + (happy_var_2 + )} + +happyReduce_13 = happySpecReduce_2 4# happyReduction_13 +happyReduction_13 happy_x_2 + happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn9 + (TApplication happy_var_1 happy_var_2 + )}} + +happyReduce_14 = happySpecReduce_1 4# happyReduction_14 +happyReduction_14 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenConstructor happy_var_1) -> + happyIn9 + (TAtom happy_var_1 + )} + +happyReduce_15 = happySpecReduce_3 5# happyReduction_15 +happyReduction_15 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut9 happy_x_2 of { happy_var_2 -> + happyIn10 + (happy_var_2 + )} + +happyReduce_16 = happySpecReduce_1 5# happyReduction_16 +happyReduction_16 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenConstructor happy_var_1) -> + happyIn10 + (TAtom happy_var_1 + )} + +happyReduce_17 = happySpecReduce_3 6# happyReduction_17 +happyReduction_17 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn11 + (happy_var_2 + )} + +happyReduce_18 = happySpecReduce_2 6# happyReduction_18 +happyReduction_18 happy_x_2 + happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + case happyOut14 happy_x_2 of { happy_var_2 -> + happyIn11 + (TApplication happy_var_1 happy_var_2 + )}} + +happyReduce_19 = happySpecReduce_1 6# happyReduction_19 +happyReduction_19 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenConstructor happy_var_1) -> + happyIn11 + (TAtom happy_var_1 + )} + +happyReduce_20 = happySpecReduce_3 7# happyReduction_20 +happyReduction_20 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn12 + (happy_var_2 + )} + +happyReduce_21 = happySpecReduce_1 7# happyReduction_21 +happyReduction_21 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenConstructor happy_var_1) -> + happyIn12 + (TAtom happy_var_1 + )} + +happyReduce_22 = happySpecReduce_3 8# happyReduction_22 +happyReduction_22 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn13 + (happy_var_2 + )} + +happyReduce_23 = happySpecReduce_2 8# happyReduction_23 +happyReduction_23 happy_x_2 + happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + case happyOut14 happy_x_2 of { happy_var_2 -> + happyIn13 + (TApplication happy_var_1 happy_var_2 + )}} + +happyReduce_24 = happySpecReduce_1 8# happyReduction_24 +happyReduction_24 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn13 + (happy_var_1 + )} + +happyReduce_25 = happySpecReduce_1 8# happyReduction_25 +happyReduction_25 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenVariable happy_var_1) -> + happyIn13 + (TAtom happy_var_1 + )} + +happyReduce_26 = happySpecReduce_1 8# happyReduction_26 +happyReduction_26 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenNumber happy_var_1) -> + happyIn13 + (TAtom happy_var_1 + )} + +happyReduce_27 = happySpecReduce_3 9# happyReduction_27 +happyReduction_27 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn14 + (happy_var_2 + )} + +happyReduce_28 = happySpecReduce_1 9# happyReduction_28 +happyReduction_28 happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + happyIn14 + (happy_var_1 + )} + +happyReduce_29 = happySpecReduce_1 9# happyReduction_29 +happyReduction_29 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenVariable happy_var_1) -> + happyIn14 + (TAtom happy_var_1 + )} + +happyReduce_30 = happySpecReduce_1 9# happyReduction_30 +happyReduction_30 happy_x_1 + = case happyOutTok happy_x_1 of { (TokenNumber happy_var_1) -> + happyIn14 + (TAtom happy_var_1 + )} + +happyReduce_31 = happySpecReduce_2 10# happyReduction_31 +happyReduction_31 happy_x_2 + happy_x_1 + = case happyOut13 happy_x_1 of { happy_var_1 -> + happyIn15 + (happy_var_1 + )} + +happyNewToken action sts stk [] = + happyDoAction 9# notHappyAtAll action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + TokenVariable happy_dollar_dollar -> cont 1#; + TokenConstructor happy_dollar_dollar -> cont 2#; + TokenNumber happy_dollar_dollar -> cont 3#; + TokenEOF -> cont 4#; + TokenEOR -> cont 5#; + TokenEq -> cont 6#; + TokenOB -> cont 7#; + TokenCB -> cont 8#; + _ -> happyError' (tk:tks) + } + +happyError_ tk tks = happyError' (tk:tks) + +newtype HappyIdentity a = HappyIdentity a +happyIdentity = HappyIdentity +happyRunIdentity (HappyIdentity a) = a + +instance Monad HappyIdentity where + return = HappyIdentity + (HappyIdentity p) >>= q = q p + +happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b +happyThen = (>>=) +happyReturn :: () => a -> HappyIdentity a +happyReturn = (return) +happyThen1 m k tks = (>>=) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> HappyIdentity a +happyReturn1 = \a tks -> (return) a +happyError' :: () => [Token] -> HappyIdentity a +happyError' = HappyIdentity . parseError + +parse tks = happyRunIdentity happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x)) + +parseT tks = happyRunIdentity happySomeParser where + happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut15 x)) + +happySeq = happyDontSeq + + +-- | Terms are atoms, applications or variables. When used on the LHS of a +-- rule, the function symbol must be an atom, and all arguments must be atoms +-- variables or applications of constructors. +data Term = TAtom String + | TVariable String + | TApplication Term Term + deriving (Show,Read) + +-- | A rewrite rule is made up of a pattern to match against, and a right hand +-- side to rewrite to. +data RewriteRule = Rule Term Term + deriving (Show,Read) + +-- | Programs are simply lots of rewrite rules. +type Program = [RewriteRule] + +parseError :: [Token] -> a +parseError x = error ("Out of cheese error, redo from start. " ++ show x) + +data Token = TokenVariable String + | TokenConstructor String + | TokenNumber String + | TokenEOR + | TokenEOF + | TokenEq + | TokenOB + | TokenCB + deriving Show + +lexer :: String -> [Token] +lexer [] = [TokenEOF] +lexer ('\r':cs) = TokenEOR : lexer cs +lexer ('\n':cs) = TokenEOR : lexer cs +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c && isUpper c = lexText TokenConstructor (c:cs) + | isAlpha c && isLower c = lexText TokenVariable (c:cs) + | isDigit c = lexNum (c:cs) +lexer ('=':cs) = TokenEq : lexer cs +lexer ('(':cs) = TokenOB : lexer cs +lexer (')':cs) = TokenCB : lexer cs + +lexNum cs = TokenNumber num : lexer rest + where (num,rest) = span isDigit cs + +lexText cons cs = cons text : lexer rest + where + (text,rest) = span isAlpha cs + +-- | Takes a string representation of a pragram and parses into a list of rules +parseProgram :: String -> Program +parseProgram = sortVariables . parse . lexer + +-- | Takes a string representation of a term and parses it +parseTerm :: String -> Term +parseTerm = parseT . lexer + +sortVariables :: Program -> Program +sortVariables = + map sortRuleVariables + where + sortRuleVariables :: RewriteRule -> RewriteRule + sortRuleVariables (Rule p t) = Rule p (makeVariables t $ collectBindings p) + + collectBindings (TAtom _) = [] + collectBindings (TApplication i j) = collectBindings i ++ collectBindings j + collectBindings (TVariable n) = [n] + + makeVariables t@(TAtom x) bs + | x `elem` bs = TVariable x + | otherwise = TAtom x + makeVariables (TApplication i j) bs = + TApplication (makeVariables i bs) (makeVariables j bs) + makeVariables x bs = x + +-- | Returns the name of the function defined in a given rewrite rule +functionName :: RewriteRule -> String +functionName (Rule t _) = + tHead t + where + tHead :: Term -> String + tHead (TAtom x) = x + tHead (TVariable x) = x + tHead (TApplication f _) = tHead f + +-- | Pretty prints a given rewrite rule +showRule :: RewriteRule -> String +showRule (Rule p e) = + pretty (toPrettyTerm p) ++ " = " ++ pretty (toPrettyTerm e) ++ "\n" + where + toPrettyTerm (TAtom x) = PAtom x + toPrettyTerm (TVariable x) = PAtom x + toPrettyTerm (TApplication f a) = + PApplication (toPrettyTerm f) (toPrettyTerm a) +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 28 "templates/GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Int# Happy_IntList + + + + + +{-# LINE 49 "templates/GenericTemplate.hs" #-} + +{-# LINE 59 "templates/GenericTemplate.hs" #-} + +{-# LINE 68 "templates/GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | (n <# (0# :: Int#)) -> {- nothing -} + + (happyReduceArr ! rule) i tk st + where rule = (I# ((negateInt# ((n +# (1# :: Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n -# (1# :: Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off +# i) + check = if (off_i >=# (0# :: Int#)) + then (indexShortOffAddr happyCheck off_i ==# i) + else False + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + +{-# LINE 127 "templates/GenericTemplate.hs" #-} + + +indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 + narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + intToInt16# i +#else + (i `iShiftL#` 16#) `iShiftRA#` 16# +#endif + where +#if __GLASGOW_HASKELL__ >= 503 + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) +#else + i = word2Int# ((high `shiftL#` 8#) `or#` low) +#endif + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# + + + + + +data HappyAddr = HappyA# Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 170 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k -# (1# :: Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + drop_stk = happyDropStk k stk + + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off +# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk = +-- trace "failing" $ + happyError_ tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/examples/add.cap b/examples/add.cap new file mode 100644 --- /dev/null +++ b/examples/add.cap @@ -0,0 +1,24 @@ +main = add (Succ Zero) Zero + +add x Zero = x +add x (Succ y) = Succ (add x y) + +pred (Succ x) = x + +sub x Zero = x +sub x (Succ y) = pred (sub x y) + +mul x Zero = Zero +mul x (Succ y) = add x (mul x y) + +eq Zero Zero = True +eq (Succ x) (Succ y) = eq x y +eq Zero (Succ x) = False +eq (Succ x) Zero = False + +gt Zero x = False +gt (Succ x) Zero = True +gt (Succ x) (Succ y) = gt x y + +if True x y = x +if False x y = y diff --git a/examples/allOdd.cap b/examples/allOdd.cap new file mode 100644 --- /dev/null +++ b/examples/allOdd.cap @@ -0,0 +1,37 @@ +main = allOdd id (Leaf Zero) + +allOdd f (Leaf n) = f (odd n) +allOdd f (Branch l r) = allOdd ((flip (and)) (allOdd f r)) l + +id x = x + +flip f x y = f y x + +and True True = True +and True False = False +and False x = False + +odd x = eq (mod x (Succ (Succ Zero))) Zero + +if True x y = x +if False x y = y + +mod x y = if (lt x y) x (mod (sub x y) y) + +sub (Succ x) (Succ y) = sub x y +sub x Zero = x + +lt Zero Zero = False +lt Zero (Succ x) = True +lt (Succ x) (Succ y) = lt x y +lt (Succ x) Zero = False + +lteq Zero Zero = True +lteq Zero (Succ x) = True +lteq (Succ x) (Succ y) = lteq x y +lteq (Succ x) Zero = False + +eq Zero Zero = True +eq (Succ x) (Succ y) = eq x y +eq Zero (Succ y) = False +eq (Succ x) Zero = False diff --git a/examples/fx.cap b/examples/fx.cap new file mode 100644 --- /dev/null +++ b/examples/fx.cap @@ -0,0 +1,1 @@ +f x = x diff --git a/examples/higherOrder.cap b/examples/higherOrder.cap new file mode 100644 --- /dev/null +++ b/examples/higherOrder.cap @@ -0,0 +1,5 @@ +main = f g Zero + +f x = x + +g x = (Succ x) diff --git a/examples/problem.cap b/examples/problem.cap new file mode 100644 --- /dev/null +++ b/examples/problem.cap @@ -0,0 +1,5 @@ +main = g id + +id x = x + +g h = h h 4 diff --git a/examples/test.cap b/examples/test.cap new file mode 100644 --- /dev/null +++ b/examples/test.cap @@ -0,0 +1,3 @@ +f 1 = g f +f 2 = 99999999 +g h = h 2 diff --git a/src/Language/Cap/Debug/Algorithmic.hs b/src/Language/Cap/Debug/Algorithmic.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cap/Debug/Algorithmic.hs @@ -0,0 +1,44 @@ +module Language.Cap.Debug.Algorithmic (ADT(..),debug) where + +import qualified Language.Cap.Interpret.Pretty as Pretty +import Language.Cap.Debug.Trace + +import Data.Char +import Data.List + +{- | An algorithmic debugging tree, currently may only be the EDT, but can be + extended to support any tree based on different functions for building. +-} +data ADT = Node NodeName [ADT] + +{- | Runs an algorithmic debugging session. Splits answers into boolean values + and asks appropriate questions. +-} +debug :: Graph -> (Graph -> ADT) -> (Graph -> NodeName -> String) -> IO () +debug g buildTree question = questions g [buildTree g] question Nothing + +-- | Convert a yes or no answer into a boolean value. +toBool :: String -> Bool +toBool n + | n `isPrefixOf` "yes" = True + | n `isPrefixOf` "no" = False + +-- | The list of questions asked about a tree based on an input list of answers. +questions :: Graph + -> [ADT] + -> (Graph -> NodeName -> String) + -> Maybe NodeName + -> IO () +questions g ((Node name children):r) question b = + do putStrLn $ question g name + x <- getLine + if ":q" `isPrefixOf` (map toLower x) + then putStrLn "Debugging aborted" + else + if toBool (map toLower x) + then questions g r question b + else questions g children question (Just name) +questions g [] question b = + case b of + Nothing -> putStrLn "No bugs" + Just b' -> putStrLn ("Bug identified in node: " ++ reverse b' ++ "\nReduction: " ++ Pretty.pretty (nodeContents g b') ++ " ~> " ++ Pretty.pretty (nodeContents g ('r':b'))) diff --git a/src/Language/Cap/Debug/Dotty.hs b/src/Language/Cap/Debug/Dotty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cap/Debug/Dotty.hs @@ -0,0 +1,64 @@ +module Language.Cap.Debug.Dotty (pretty) where + +import Language.Cap.Debug.Trace + +import Data.List (isSuffixOf,sortBy) + + +-- | Takes a trace graph and outputs a ``dot'' representation of it +pretty :: Graph -> String +pretty g = + "digraph Trace {\nordering=out;\n" ++ + concatMap (makeRankGroup . (concatMap (prettyNode g))) (groupNodes (allNodes g)) ++ concatMap (prettyEdges g) (allNodes g) ++ " } " + +groupNodes :: [NodeName] -> [[NodeName]] +groupNodes xs = + groupNodes' $ reverse $ sortBy compareNumberOfRs xs + where + groupNodes' :: [NodeName] -> [[NodeName]] + groupNodes' [] = [] + groupNodes' (x:xs) = (allRedexes x):(groupNodes' (filter (notResOf x) xs)) + + notResOf :: NodeName -> NodeName -> Bool + notResOf ('r':x) y = x /= y && notResOf x y + notResOf _ _ = True + + allRedexes ('r':xs) = ('r':xs) : allRedexes xs + allRedexes x = [x] + +compareNumberOfRs x y = compare (numRs x) (numRs y) + +numRs :: String -> Int +numRs ('r':xs) = 1 + numRs xs +numRs _ = 0 + +makeRankGroup n = " { rank = same;\n" ++ n ++ " }\n" + +prettyNode :: Graph -> NodeName -> String +prettyNode g x = + case nodeValue g x of + Just (Atom a) + -> (nodeName x) ++ " [label=\"" ++ a ++ "\"];\n" + Just (Application i j) + -> (nodeName x) ++ " [label=\"\"];\n" + Just (Indirection i) + -> (nodeName x) ++ " [label=\"\"];\n" + +prettyEdges :: Graph -> NodeName -> String +prettyEdges g x = + (case nodeValue g x of + Just (Atom a) + -> "" + Just (Application i j) + -> (nodeName x) ++ " -> " ++ (nodeName i) ++ ";\n" ++ + (nodeName x) ++ " -> " ++ (nodeName j) ++ ";\n" + Just (Indirection i) + -> (nodeName x) ++ " -> " ++ (nodeName i) ++ ";\n") + ++ (case x of + ('r':y) -> (nodeName y) ++ " -> " ++ x ++ " [style = bold];\n" + _ -> "") + + +nodeName :: String -> String +nodeName "" = "m" +nodeName x = x diff --git a/src/Language/Cap/Debug/EDT.hs b/src/Language/Cap/Debug/EDT.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cap/Debug/EDT.hs @@ -0,0 +1,54 @@ +module Language.Cap.Debug.EDT (buildEDT,edtParent,edtQuestion) where + +import Language.Cap.Interpret.Pretty +import Language.Cap.Debug.Algorithmic +import Language.Cap.Debug.Trace + +{- | Generates a question for a node in the ART. Questions are made up by + comparing the redex to a most evaluated form. +-} +edtQuestion :: Graph -> NodeName -> String +edtQuestion g n = + (pretty $ edtRedex g n) ++ " =?= " ++ (pretty $ edtMef g n) + +-- | Constructs an EDT for a given trace. +buildEDT :: Graph -> ADT +buildEDT g = + buildEDT' g "" + where + -- | Constructs an EDT starting at a specific node in the ART. + buildEDT' :: Graph -> NodeName -> ADT + buildEDT' g n = Node n (map (buildEDT' g) (children g n)) + + -- | Gathers the children of a node in the ART. + children :: Graph -> NodeName -> [NodeName] + children g n = [name | name <- allNodes g, ('r':name) `elem` allNodes g + && name /= "" + && edtParent name == Just n] + +-- | Find the parent (as defined for the EDT) of a node in the ART. +-- This is a partial function and is undefined for the epsilon node. +edtParent :: NodeName -> Maybe NodeName +edtParent ('f':n) = edtParent n +edtParent ('a':n) = edtParent n +edtParent ('r':n) = Just n +edtParent [] = Nothing + +-- | Create a redex for any application or atom node in the trace. +edtRedex :: Graph -> NodeName -> PrettyTerm +edtRedex g n = + case nodeValue g n of + Just (Application i j) -> PApplication (edtMef g i) (edtMef g j) + Just (Atom a) -> PAtom a + +-- | Find the most evaluated form for any node in the trace +edtMef :: Graph -> NodeName -> PrettyTerm +edtMef g n = + case nodeValue g l of + Just x -> edtMeft g x + where + l = nodeLast g n + +edtMeft :: Graph -> NodeInfo -> PrettyTerm +edtMeft g (Atom a) = PAtom a +edtMeft g (Application i j) = PApplication (edtMef g i) (edtMef g j) diff --git a/src/Language/Cap/Debug/FDT.hs b/src/Language/Cap/Debug/FDT.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cap/Debug/FDT.hs @@ -0,0 +1,135 @@ +module Language.Cap.Debug.FDT + (buildFDT,fdtParent,fdtQuestion) + where + +import Language.Cap.Interpret.Pretty +import Language.Cap.Debug.Algorithmic +import Language.Cap.Debug.EDT +import Language.Cap.Debug.Trace +import Language.Cap.Debug.TraceMode + +import Data.Char +import System.IO.Unsafe + +infixl 3 >+< + +{- | Generates a question for a node in the ART. Questions are made up by + comparing the redex to a most evaluated form. +-} +fdtQuestion :: MapMode -> Graph -> NodeName -> String +fdtQuestion m g n = + (pretty $ fdtRedex m g n) ++ " =?= " ++ (pretty $ fdtMef m g n) ++ "\n" + +-- | Constructs an FDT for a given trace. +buildFDT :: Graph -> ADT +buildFDT g = + buildFDT' g "" + where + -- | Constructs an FDT starting at a specific node in the ART. + buildFDT' :: Graph -> NodeName -> ADT + buildFDT' g n = Node n (map (buildFDT' g) (children g n)) + + -- | Gathers the children of a node in the ART. + children :: Graph -> NodeName -> [NodeName] + children g n = [name | name <- allNodes g, ('r':name) `elem` allNodes g + && fdtParent g name == Just n] + +-- | Find the parent (as defined for the FDT) of a node in the ART. +fdtParent :: Graph -> NodeName -> Maybe NodeName +fdtParent g n = + case nodeValue g n of + Just (Atom a) -> edtParent n + Just (Application f _) -> edtParent (nodeLast g f) + +-- | Create a redex for any application or atom node in the trace. +fdtRedex :: MapMode -> Graph -> NodeName -> PrettyTerm +fdtRedex _ g "" = PAtom "main" +fdtRedex m g n = case nodeValue g n of + Just x -> fdtMeaT m g x + +fdtMeaT :: MapMode -> Graph -> NodeInfo -> PrettyTerm +fdtMeaT m g (Atom a) = PAtom a +fdtMeaT m g (Application i j) = PApplication (fdtMea m g i) (fdtMef m g j) + +fdtMea :: MapMode -> Graph -> NodeName -> PrettyTerm +fdtMea m g n = + case nodeValue g l of + Just x -> fdtMeaT m g x + where + l = nodeLast g n + +-- | Either this is a function symbol (i.e. all lower case letters) +-- or it is an application of a function symbol. +-- Neither may have a result pointer. +-- Longer version is to check the arity of the graph. this is better +-- because it allows for the possibility of a computation not having been +-- demanded. The short-cut would result in a mapping {} in this situation. +-- Thus if the shortcut is used, empty mappings should be replaced with the _ +-- symbol to indicate that the expression was never needed. +isFunction :: Graph -> NodeName -> Bool +isFunction g n = + case nodeValue g at of + Just (Atom a) -> isFunctionName g at + Just (Application i j) -> isFunctionName g i + where + at = (nodeLast g n) + +isFunctionName :: Graph -> NodeName -> Bool +isFunctionName g n = + case nodeValue g n of + Just (Atom a) -> isAllLowerCase a + Just (Application i j) -> isFunctionName g i + where + isAllLowerCase :: String -> Bool + isAllLowerCase = all (`elem` "abcdefghijklmnopqrstuvwxyz") + +-- | Find the most evaluated form for any node in the trace +fdtMef :: MapMode -> Graph -> NodeName -> PrettyTerm +fdtMef m g n = + if isFunction g n + then fdtMap m g (nodeLast g n) + else fdtMea m g n + +(>+<) :: NodeName -> Graph -> NodeName -> Bool +(n >+< g) m = n /= m && ('r':m) `elem` allNodes g && n `elem` nodeHeads g m + +(>-<) :: NodeName -> Graph -> NodeName -> Bool +(n >-< g) m = n /= m && ('r':m) `elem` allNodes g && nodeHead g m == n + +fdtMap :: MapMode -> Graph -> NodeName -> PrettyTerm +fdtMap Index g n = + PMap [M (args Index g m n) (fdtMef Index g m) | m <- allNodes g, (n >+< g) m] +fdtMap IndexFunctions g n = + fdtMap' g n (nodeHead g n) +fdtMap OnTheFly g n = + PMap (map (makeMap g) (filter (isAppOf g n) (allApplications g))) + -- Needs to be an underscore if it's an empty mapping, because we don't know + -- if it's a function symbol or a value + +fdtMap' :: Graph -> NodeName -> NodeName -> PrettyTerm +fdtMap' g n m = + PMap [M (args IndexFunctions g m' n) (fdtMef IndexFunctions g m') + | m' <- allNodes g, (m >-< g) m' && n `elem` nodeHeads g m'] + +args :: MapMode -> Graph -> NodeName -> NodeName -> [PrettyTerm] +args mm g m n = + if m /= n then + case nodeValue g m of + Just (Application i j) -> args mm g (nodeLast g i) n ++ [fdtMef mm g j] + Just (Atom x) -> [] + else [] + +isAppOf :: Graph -> NodeName -> NodeName -> Bool +isAppOf g n m = + case nodeValue g m of + Just (Application n' o) -> n == nodeLast g n' + _ -> False + +makeMap :: Graph -> NodeName -> Mapping +makeMap g m = + case nodeValue g m of + Just (Application _ o) -> M [fdtMef OnTheFly g o] (fdtRes OnTheFly g m) + +fdtRes :: MapMode -> Graph -> NodeName -> PrettyTerm +fdtRes m g n = if ('r':n) `elem` allNodes g then fdtMef m g n + else fdtMap m g n diff --git a/src/Language/Cap/Debug/Trace.hs b/src/Language/Cap/Debug/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cap/Debug/Trace.hs @@ -0,0 +1,134 @@ +module Language.Cap.Debug.Trace + (Graph,NodeInfo(..),NodeName + ,numNodes,numApps,numReductions + ,nodeLast,nodeHead,nodeHeads,nodeArgs,nodeValue,isApplication + ,isIndirection,nodeContents,nodeResult,allNodes,allApplications + ,dispReduction) + where + +import Language.Cap.Interpret.Pretty +import qualified Language.Cap.Interpret.Pretty as P (pretty) + +import Data.Map (Map(..)) +import qualified Data.Map as M + +import Data.Maybe +import Data.List + +{- | A type synonym for the graph - it simply maps node names onto info about + the node. +-} +type Graph = Map NodeName NodeInfo + +-- | Stores information about any given node in the trace. +data NodeInfo = Application NodeName NodeName + | Atom String + | Indirection NodeName + deriving (Show,Read) + +-- | Checks whether a given node is an application node. +isApplication :: NodeInfo -> Bool +isApplication (Application _ _) = True +isApplication _ = False + +-- | Checks whether a given node is an indirection node. +isIndirection :: NodeInfo -> Bool +isIndirection (Indirection _) = True +isIndirection _ = False + +{- | Node names are just strings (of rs, as and fs at the moment). Node names + are stored in reverse order thus if the theory paper describes a node as + \"rarf\" it will be stored as \"frar\". +-} +type NodeName = String + +-- | Counts the number of nodes in any given trace. +numNodes :: Graph -> Int +numNodes n = M.size n + +-- | Counts the number of application nodes in any given trace. +numApps :: Graph -> Int +numApps n = M.size (M.filter isApplication n) + +-- | Counts the number of reduction arrows in any given trace. +numReductions :: Graph -> Int +numReductions n = + M.size (M.filterWithKey keyEndsWithR n) + where + -- | Checks whether the node is the direct result of a reduction. + keyEndsWithR ('r':xs) _ = True + keyEndsWithR _ _ = False + +{- | The final node in a sequence of reductions starting at a node m. + The purpose of this function is to find the most evaluated point for m. +-} +nodeLast :: Graph -> NodeName -> NodeName +nodeLast g m = + case nodeValue g ('r':m) of + Just n -> nodeLast g ('r':m) + _ -> case nodeValue g m of + Just (Indirection n) -> nodeLast g n + _ -> m + +{- | The head of the term at node m, head(G,m) where G is a graph and m is + a node in g. +-} +nodeHead :: Graph -> NodeName -> NodeName +nodeHead g m = + case nodeValue g m of + Just (Application i j) -> nodeHead g (nodeLast g i) + Just a@(Atom x) -> m + +nodeHeads :: Graph -> NodeName -> [NodeName] +nodeHeads g m = + case nodeValue g m of + Just (Application i j) -> m:nodeHeads g (nodeLast g i) + Just (Atom x) -> [m] + +{- | The arguments of the application at node m. Note that the arguments of the + application are a sequence of nodes. +-} +nodeArgs :: Graph -> NodeName -> [NodeName] +nodeArgs g m = + case nodeValue g m of + Just (Application i j) -> nodeArgs g (nodeLast g i) ++ [j] + _ -> [] + +{- | Returns the value held at a specific node +-} +nodeValue :: Graph -> NodeName -> Maybe NodeInfo +nodeValue g m = M.lookup m g + +{- | Gives a printable version of the node m in graph G. +-} +nodeContents :: Graph -> NodeName -> PrettyTerm +nodeContents g m = + case nodeValue g m of + Just (Application i j) -> PApplication (nodeContents g i) (nodeContents g j) + Just (Atom a) -> PAtom a + Just (Indirection x) -> nodeContents g x + Nothing -> PAtom "" + +nodeResult :: Graph -> NodeName -> PrettyTerm +nodeResult g m = + case nodeValue g (nodeLast g m) of + Just (Application i j) -> PApplication (nodeResult g i) (nodeResult g j) + Just (Atom a) -> PAtom a + Just (Indirection x) -> nodeResult g x + Nothing -> PAtom "" + +{- | Gives a list of all nodes in the trace. +-} +allNodes :: Graph -> [NodeName] +allNodes g = M.keys g + +{- | Gives a list of all nodes that are applications +-} +allApplications :: Graph -> [NodeName] +allApplications g = filter (isApplication . fromJust . nodeValue g) (allNodes g) + +-- | Display a full reduction. +dispReduction :: Graph -> NodeName -> String +dispReduction g n = P.pretty (nodeContents g n) + ++ " = " + ++ P.pretty (nodeResult g n) diff --git a/src/Language/Cap/Debug/TraceMode.hs b/src/Language/Cap/Debug/TraceMode.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cap/Debug/TraceMode.hs @@ -0,0 +1,58 @@ +module Language.Cap.Debug.TraceMode + (TraceMode(..),DebugMode(..) + ,MapMode(..),FileType(..) + ,Options(..),options) where + +import List (isSuffixOf) + +-- | Dictates what mode tracing should occur in +data TraceMode = Stat + | AlgorithmicDebug DebugMode + deriving Show + +data DebugMode = FDT MapMode + | EDT + deriving Show + +data MapMode = OnTheFly + | Index + | IndexFunctions + deriving Show + +data FileType = Program + | Trace + deriving (Show,Eq) + +-- | The different options the program can be started with +data Options = Options + { mode :: TraceMode + , fileType :: FileType + , fileName :: String} + deriving Show + +{- | Works out what options the user called the program with. +-} +options :: [String] -> Options +options [] = Options {mode=Stat, fileType=Program, fileName="trace.cap"} +options [x] = Options {mode=Stat, fileType=inferType x, fileName=x} +options ("-s":xs) = (options xs) {mode=Stat} +options ("-ad":xs) = + case xs of + ("fdt":xs') -> + case xs' of + "-o":xs'' -> (options xs'') {mode=AlgorithmicDebug (FDT OnTheFly)} + _ -> (options xs') {mode=AlgorithmicDebug (FDT Index)} + ("edt":xs') -> (options xs') {mode=AlgorithmicDebug EDT} + _ -> (options xs) {mode=AlgorithmicDebug (FDT Index)} +options ("-p":x:xs) = (options xs) {fileType=Program, fileName=x} +options ("-t":x:xs) = (options xs) {fileType=Trace, fileName=x} +options (x:xs) = options xs + +{- | Attempts to infer whether the program has been given a trace file or + program file based on the extension. +-} +inferType :: String -> FileType +inferType x + | ".cat" `isSuffixOf` x = Trace + | ".cap" `isSuffixOf` x = Program + | otherwise = Program diff --git a/src/Language/Cap/Interpret/Parse.y b/src/Language/Cap/Interpret/Parse.y new file mode 100644 --- /dev/null +++ b/src/Language/Cap/Interpret/Parse.y @@ -0,0 +1,166 @@ +{ +module Language.Cap.Interpret.Parse + (Program,RewriteRule(..),Term(..) + ,parseProgram,parseTerm + ,functionName,showRule) where + +import Language.Cap.Interpret.Pretty + +import Data.Char +} + +%name parse Program +%name parseT Exp +%tokentype { Token } +%error { parseError } + +%token + variable { TokenVariable $$ } + constructor { TokenConstructor $$ } + number { TokenNumber $$ } + 'eof' { TokenEOF } + '\n' { TokenEOR } + '=' { TokenEq } + '(' { TokenOB } + ')' { TokenCB } + +%% + +Program : 'eof' { [] } + | '\n' Program { $2 } + | Rule Program { $1 : $2 } + +Rule : Function '=' Term { Rule $1 $3 } + +Function : Function Pattern { TApplication $1 $2 } + | variable { TAtom $1 } + +Pattern : '(' Pattern ')' { $2 } + | SConstruction { $1 } + | variable { TVariable $1 } + | number { TAtom $1 } + +Construction : '(' Construction ')' { $2 } + | Construction Pattern { TApplication $1 $2 } + | constructor { TAtom $1 } + +SConstruction : '(' Construction ')' { $2 } + | constructor { TAtom $1 } + +TConstruction : '(' TConstruction ')' { $2 } + | TConstruction STerm { TApplication $1 $2 } + | constructor { TAtom $1 } + +STConstruction : '(' TConstruction ')' { $2 } + | constructor { TAtom $1 } + +Term : '(' Term ')' { $2 } + | Term STerm { TApplication $1 $2 } + | TConstruction { $1 } + | variable { TAtom $1 } + | number { TAtom $1 } + +STerm : '(' Term ')' { $2 } + | STConstruction { $1 } + | variable { TAtom $1 } + | number { TAtom $1 } + +Exp : Term 'eof' { $1 } + +{ + +-- | Terms are atoms, applications or variables. When used on the LHS of a +-- rule, the function symbol must be an atom, and all arguments must be atoms +-- variables or applications of constructors. +data Term = TAtom String + | TVariable String + | TApplication Term Term + deriving (Show,Read) + +-- | A rewrite rule is made up of a pattern to match against, and a right hand +-- side to rewrite to. +data RewriteRule = Rule Term Term + deriving (Show,Read) + +-- | Programs are simply lots of rewrite rules. +type Program = [RewriteRule] + +parseError :: [Token] -> a +parseError x = error ("Out of cheese error, redo from start. " ++ show x) + +data Token = TokenVariable String + | TokenConstructor String + | TokenNumber String + | TokenEOR + | TokenEOF + | TokenEq + | TokenOB + | TokenCB + deriving Show + +lexer :: String -> [Token] +lexer [] = [TokenEOF] +lexer ('\r':cs) = TokenEOR : lexer cs +lexer ('\n':cs) = TokenEOR : lexer cs +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c && isUpper c = lexText TokenConstructor (c:cs) + | isAlpha c && isLower c = lexText TokenVariable (c:cs) + | isDigit c = lexNum (c:cs) +lexer ('=':cs) = TokenEq : lexer cs +lexer ('(':cs) = TokenOB : lexer cs +lexer (')':cs) = TokenCB : lexer cs + +lexNum cs = TokenNumber num : lexer rest + where (num,rest) = span isDigit cs + +lexText cons cs = cons text : lexer rest + where + (text,rest) = span isAlpha cs + +-- | Takes a string representation of a pragram and parses into a list of rules +parseProgram :: String -> Program +parseProgram = sortVariables . parse . lexer + +-- | Takes a string representation of a term and parses it +parseTerm :: String -> Term +parseTerm = parseT . lexer + +sortVariables :: Program -> Program +sortVariables = + map sortRuleVariables + where + sortRuleVariables :: RewriteRule -> RewriteRule + sortRuleVariables (Rule p t) = Rule p (makeVariables t $ collectBindings p) + + collectBindings (TAtom _) = [] + collectBindings (TApplication i j) = collectBindings i ++ collectBindings j + collectBindings (TVariable n) = [n] + + makeVariables t@(TAtom x) bs + | x `elem` bs = TVariable x + | otherwise = TAtom x + makeVariables (TApplication i j) bs = + TApplication (makeVariables i bs) (makeVariables j bs) + makeVariables x bs = x + +-- | Returns the name of the function defined in a given rewrite rule +functionName :: RewriteRule -> String +functionName (Rule t _) = + tHead t + where + tHead :: Term -> String + tHead (TAtom x) = x + tHead (TVariable x) = x + tHead (TApplication f _) = tHead f + +-- | Pretty prints a given rewrite rule +showRule :: RewriteRule -> String +showRule (Rule p e) = + pretty (toPrettyTerm p) ++ " = " ++ pretty (toPrettyTerm e) ++ "\n" + where + toPrettyTerm (TAtom x) = PAtom x + toPrettyTerm (TVariable x) = PAtom x + toPrettyTerm (TApplication f a) = + PApplication (toPrettyTerm f) (toPrettyTerm a) +} diff --git a/src/Language/Cap/Interpret/Pretty.hs b/src/Language/Cap/Interpret/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cap/Interpret/Pretty.hs @@ -0,0 +1,32 @@ +module Language.Cap.Interpret.Pretty + (PrettyTerm(..),Mapping(..),pretty) + where + +-- | Defines terms that can be displayed by the debugger (ready for pretty +-- printing. +data PrettyTerm = PAtom String + | PApplication PrettyTerm PrettyTerm + | PMap [Mapping] + +-- | Defines a mapping ready for display by the pretty printer. +data Mapping = M [PrettyTerm] PrettyTerm + +-- | Pretty prints a given pretty term +pretty :: PrettyTerm -> String +pretty = pretty' False + +pretty' :: Bool -> PrettyTerm -> String +pretty' _ (PAtom a) = a +pretty' True (PApplication f a) = + "(" ++ (pretty' False f) ++ " " ++ (pretty' True a) ++ ")" +pretty' False (PApplication f a) = + (pretty' False f) ++ " " ++ (pretty' True a) +pretty' _ (PMap ms) = + "{" ++ commas (map prettyMap ms) ++ "}" + +prettyMap :: Mapping -> String +prettyMap (M as r) = unwords (map pretty as) ++ " -> " ++ pretty r + +commas [] = [] +commas [x] = x +commas (x:xs) = x ++ ", " ++ commas xs diff --git a/src/Language/Cap/Interpret/Program.hs b/src/Language/Cap/Interpret/Program.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cap/Interpret/Program.hs @@ -0,0 +1,147 @@ +module Language.Cap.Interpret.Program (interpret) where + +import Language.Cap.Interpret.Parse +import Language.Cap.Debug.Trace + +import Data.Map (Map(..)) +import qualified Data.Map as M +import Data.Maybe +import Data.List +import System.IO.Unsafe + + +-- | Substitutions are mappings from variable names to a graph to substitute in. +type Substitution = Map String NodeName + +-- | Checks whether a term is simply a variable. +isVariable :: Term -> Bool +isVariable (TVariable _) = True +isVariable _ = False + +-- | Fetches the variable name from a variable term. +variableName :: Term -> String +variableName (TVariable x) = x + +-- | Constructs a graph for a term using a particular substitution. No +-- evaluation is performed. +graph :: NodeName -> Term -> Substitution -> Graph +graph n (TAtom x) _ = M.singleton n (Atom x) +graph n (TVariable x) subs = + M.singleton n (Indirection (fromJust (M.lookup x subs))) +graph n (TApplication (TVariable i) (TVariable j)) subs = + M.singleton n (Application (fromJust (M.lookup i subs)) + (fromJust (M.lookup j subs))) +graph n (TApplication (TVariable i) j) subs = + M.insert n + (Application (fromJust (M.lookup i subs)) ('a':n)) + (graph ('a':n) j subs) +graph n (TApplication i (TVariable j)) subs = + M.insert n + (Application ('f':n) (fromJust (M.lookup j subs))) + (graph ('f':n) i subs) +graph n (TApplication i j) subs = + M.insert n + (Application ('f':n) ('a':n)) + (M.union ig jg) + where + ig = graph ('f':n) i subs + jg = graph ('a':n) j subs + +-- | Attempts to match a node in the graph against a pattern. +match :: Graph -> NodeName -> Term -> Maybe Substitution +match t n (TAtom a) = + case nodeValue t n of + Just (Atom a') -> if a == a' then Just M.empty + else Nothing + _ -> Nothing +match t n (TApplication i j) = + case nodeValue t n of + Just (Application i' j') -> + do is <- if isVariable i then Just (M.singleton (variableName i) i') + else match t (nodeLast t i') i + js <- if isVariable j then Just (M.singleton (variableName j) j') + else match t (nodeLast t j') j + return $ M.union is js + _ -> Nothing + +-- | Evaluates the a term based on a given program. Returns a trace of the +-- completed evaluation +interpret :: Program -> Term -> Graph +interpret p t = compute p (graph "" t (M.fromList [])) + +-- | Evaluates the program by continuously attempting to match un-reduced +-- computations against rewrite rules. +compute :: Program -> Graph -> Graph +compute p g = if isJust computableNode + then compute p (M.union g (graph ('r':redex) term subs)) + else g + where + computableNode = findRedex p g + + (redex,term,subs) = fromJust computableNode + +-- | Attempts to find a reducable expression, and the rewrite rule that it may +-- be reduced with. +findRedex :: Program -> Graph -> Maybe (NodeName,Term,Substitution) +findRedex p g = + first (tryRules p g) + [n | n <- nodes, (not $ isIndirection $ fromJust $ nodeValue g n) + && not (('r':n) `elem` nodes)] + where + nodes = sortBy outerMostLeftMostFirst $ necessaryNodes g + +-- | Finds all nodes that may need to be reduced to complete construction of +-- the trace +necessaryNodes :: Graph -> [NodeName] +necessaryNodes g = + nub $ necessaryNodes' g "" + where + necessaryNodes' :: Graph -> NodeName -> [NodeName] + necessaryNodes' g n = + if ('r':n) `elem` allNodes g + then necessaryNodes' g ('r':n) + else + case nodeValue g n of + Just (Application i j) + -> n:(necessaryNodes' g i ++ necessaryNodes' g j) + Just (Atom a) + -> [n] + Just (Indirection x) + -> necessaryNodes' g x + +-- | Establishes an outermost leftmost first order on nodes +outerMostLeftMostFirst :: NodeName -> NodeName -> Ordering +outerMostLeftMostFirst x y = + outerMostLeftMostFirst' (reverse x) (reverse y) + where + outerMostLeftMostFirst' [] [] = EQ + outerMostLeftMostFirst' [] ('r':ys) = GT + outerMostLeftMostFirst' [] (_:ys) = LT + outerMostLeftMostFirst' ('r':xs) [] = LT + outerMostLeftMostFirst' (_:xs) [] = GT + outerMostLeftMostFirst' ('r':xs) ('r':ys) = outerMostLeftMostFirst' xs ys + outerMostLeftMostFirst' ('f':xs) ('f':ys) = outerMostLeftMostFirst' xs ys + outerMostLeftMostFirst' ('a':xs) ('a':ys) = outerMostLeftMostFirst' xs ys + outerMostLeftMostFirst' ('r':xs) (_:ys) = LT + outerMostLeftMostFirst' (_:xs) ('r':ys) = GT + outerMostLeftMostFirst' ('f':xs) ('a':ys) = LT + outerMostLeftMostFirst' ('a':xs) ('f':ys) = GT + +-- | Tries each rewrite rule on a given unreduced application to find out if +-- it's a redex. +tryRules :: Program -> Graph -> NodeName -> Maybe (NodeName,Term,Substitution) +tryRules [] g n = Nothing +tryRules ((Rule pattern term):rs) g n = + if isJust subs then Just (n,term,fromJust subs) + else tryRules rs g n + where + subs = match g n pattern + +-- | Finds the first item in a list for which f does not return Nothing.-} +first :: (a -> Maybe b) -> [a] -> Maybe b +first f [] = Nothing +first f (x:xs) + = if isJust r then r + else first f xs + where + r = f x diff --git a/src/Language/Cap/Main.hs b/src/Language/Cap/Main.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cap/Main.hs @@ -0,0 +1,134 @@ +module Main where + +import Language.Cap.Interpret.Program +import Language.Cap.Interpret.Parse +import qualified Language.Cap.Interpret.Pretty as Pretty +import Language.Cap.Debug.TraceMode +import Language.Cap.Debug.Trace +import qualified Language.Cap.Debug.Algorithmic as Algorithmic +import Language.Cap.Debug.EDT +import Language.Cap.Debug.FDT +import qualified Language.Cap.Debug.Dotty as Dotty + +import System +import System.IO +import qualified Data.Map as M +import Data.List + +-- | Interpreter and debugger for the TART language and trace. +main = do args <- System.getArgs + let opts = options args + hSetBuffering stdout NoBuffering + hSetBuffering stdin LineBuffering + if fileType opts == Trace + then do catFile <- readFile $ fileName opts + trace (mode opts) (read catFile) + else do capFile <- readFile $ fileName opts + interpretLoop (moduleName (fileName opts)) + (parseProgram capFile) + [] + +-- | Event loop for the interactive interpretter +interpretLoop :: String -> Program -> [Graph] -> IO () +interpretLoop name p xs = + do putStr (name ++ " > ") + x <- getLine + runCommand name p xs x + +-- | Understands a command from the user and does the appropriate thing. +runCommand :: String -> Program -> [Graph] -> String -> IO () +runCommand name p xs ":q" = return () +runCommand name p xs ":w" = do writeFile (name ++ ".pmt") (show xs) + interpretLoop name p xs +runCommand name p xs ":p" = do writeDots 1 name xs + interpretLoop name p xs +runCommand name p xs ":prog" = do putStrLn $ showProg p + interpretLoop name p xs +runCommand name p xs ":s" = do trace Stat xs + interpretLoop name p xs +runCommand name p xs (':':c) = + case c of + "ad" -> do trace (AlgorithmicDebug (FDT Index)) xs + interpretLoop name p xs + ('a':'d':' ':x) -> + case x of + "edt" -> do trace (AlgorithmicDebug EDT) xs + interpretLoop name p xs + ('f':'d':'t':y) -> + case y of + " -o" -> do trace (AlgorithmicDebug (FDT OnTheFly)) xs + interpretLoop name p xs + " -i" -> do trace (AlgorithmicDebug (FDT Index)) xs + interpretLoop name p xs + " -if" -> do trace (AlgorithmicDebug (FDT IndexFunctions)) xs + interpretLoop name p xs + _ -> do trace (AlgorithmicDebug (FDT Index)) xs + interpretLoop name p xs + _ -> do putStrLn "Unknown command" + interpretLoop name p xs +runCommand name p xs l = do let g = interpret p (parseTerm l) + putStrLn $ Pretty.pretty $ nodeResult g "" + interpretLoop name p (g:xs) + +writeDots :: Int -> String -> [Graph] -> IO () +writeDots _ _ [] = return () +writeDots n name (x:xs) = + do writeFile (name ++ (show n) ++ ".dot") (Dotty.pretty x) + writeDots (n + 1) name xs + +{- | Trace a given graph in a specific node. This generates a String -> String + function that can be used by interact to create an interactive session. +-} +trace :: TraceMode -> [Graph] -> IO () +trace Stat g = putStrLn $ concatMap stats g +trace (AlgorithmicDebug m) g = + do putStrLn (concat (zipWith (\x y -> x ++ ".\t" ++ y ++ "\n") + (map show [1..]) + (map ((flip dispReduction) "") g))) + x <- getLine + let reductionNum = (read x) :: Int + let numReductions = length g + if reductionNum > 0 && reductionNum <= numReductions + then case m of + EDT -> + Algorithmic.debug (g !! (reductionNum - 1)) buildEDT edtQuestion + (FDT m) -> + Algorithmic.debug (g !! (reductionNum - 1)) + buildFDT + (fdtQuestion m) + else putStrLn "Error: Reduction does not exist" + +-- | Formats the program given to it. Rules are grouped together according to +-- function symbol, and output with blank lines seperating functions +showProg :: Program -> String +showProg = concat . intersperse "\n" . map (concatMap showRule) . groupRules + +-- | Takes a program and groups the rules by function symbol. +groupRules :: Program -> [Program] +groupRules [] = [] +groupRules (r:rs) = + groupRules' (r:rs) (functionName r) [] + where + groupRules' :: Program -> String -> Program -> [Program] + groupRules' [] _ _ = [] + groupRules' (r:rs) n g = + if functionName r == n then groupRules' rs n (g ++ [r]) + else (g:(groupRules' (r:rs) (functionName r) [])) + + +-- | Generate statistics for a specific program run +stats :: Graph -> String +stats g = + "Computation: " ++ dispReduction g "" + ++ " | Number of nodes: " ++ show (numNodes g) ++ "\n" + ++ " | Number of applications: " ++ show (numApps g) ++ "\n" + ++ " | Number of reductions: " ++ show (numReductions g) ++ "\n" + ++ "------------\n" + +{- | Strips the extension from the file name. +-} +moduleName :: String -> String +moduleName n + | ".cap" `isSuffixOf` n = take (length n - 4) n + | ".cat" `isSuffixOf` n = take (length n - 4) n + | otherwise = n