diff --git a/Debug/SimpleReflect.hs b/Debug/SimpleReflect.hs new file mode 100644 --- /dev/null +++ b/Debug/SimpleReflect.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Debug.SimpleReflect +-- Copyright : (c) 2008 Twan van Laarhoven +-- License : BSD-style +-- +-- Maintainer : twanvl@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Simple reflection of haskell expressions containing variables. +-- +-- Some examples: +-- +-- > > sum [1..5] :: Expr +-- > 0 + 1 + 2 + 3 + 4 + 5 +-- +-- > > foldr1 f [a,b,c] +-- > f a (f b c) +-- +-- > > take 5 (iterate f x) +-- > [x,f x,f (f x),f (f (f x)),f (f (f (f x)))] +-- +-- > > mapM_ print $ reduction (1+2*(3+4)) +-- > 1 + 2 * (3 + 4) +-- > 1 + 2 * 7 +-- > 1 + 14 +-- > 15 +----------------------------------------------------------------------------- +module Debug.SimpleReflect + ( module Debug.SimpleReflect.Expr + , module Debug.SimpleReflect.Vars + ) where + +import Debug.SimpleReflect.Expr +import Debug.SimpleReflect.Vars diff --git a/Debug/SimpleReflect/Expr.hs b/Debug/SimpleReflect/Expr.hs new file mode 100644 --- /dev/null +++ b/Debug/SimpleReflect/Expr.hs @@ -0,0 +1,207 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Debug.SimpleReflect.Expr +-- Copyright : (c) 2008 Twan van Laarhoven +-- License : BSD-style +-- +-- Maintainer : twanvl@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Simple reflection of haskell expressions containing variables. +-- +----------------------------------------------------------------------------- +module Debug.SimpleReflect.Expr + ( -- * Construction + Expr + , FromExpr(..) + , var, fun + -- * Evaluating + , expr, reduce, reduction + ) where + +import Data.List +import Control.Applicative + +------------------------------------------------------------------------------ +-- Data type +------------------------------------------------------------------------------ + +-- | A reflected expression +data Expr = Expr + { showExpr :: Int -> ShowS -- ^ Show with the given precedence level + , intExpr :: Maybe Integer -- ^ Integer value? + , doubleExpr :: Maybe Double -- ^ Floating value? + , reduced :: Maybe Expr -- ^ Next reduction step + } + +instance Show Expr where + showsPrec p r = showExpr r p + +-- | Default expression +emptyExpr :: Expr +emptyExpr = Expr { showExpr = \_ -> showString "" + , intExpr = Nothing + , doubleExpr = Nothing + , reduced = Nothing + } + +------------------------------------------------------------------------------ +-- Lifting and combining expressions +------------------------------------------------------------------------------ + +-- | A variable with the given name +var :: String -> Expr +var s = emptyExpr { showExpr = \_ -> showString s } + +lift :: Show a => a -> Expr +lift x = emptyExpr { showExpr = \p -> showsPrec p x } + +data Fixity = L | R deriving Eq + +-- | A operator as expression +op :: Fixity -> Int -> String -> Expr -> Expr -> Expr +op fix prec op a b = emptyExpr { showExpr = showFun } + where showFun p = showParen (p > prec) + $ showExpr a (if fix == L then prec else prec + 1) + . showString op + . showExpr b (if fix == R then prec else prec + 1) + +------------------------------------------------------------------------------ +-- Adding numeric results +------------------------------------------------------------------------------ + +iOp r f a = (r a ) { intExpr = f <$> intExpr a } +iOp2 r f a b = (r a b) { intExpr = f <$> intExpr a <*> intExpr b } +dOp r f a = (r a ) { doubleExpr = f <$> doubleExpr a } +dOp2 r f a b = (r a b) { doubleExpr = f <$> doubleExpr a <*> doubleExpr b } + +withReduce r a = let rr = r a in + rr { reduced = withReduce r <$> reduced a + <|> fromInteger <$> intExpr rr + <|> fromDouble <$> doubleExpr rr + } +withReduce2 r a b = let rr = r a b in + rr { reduced = (\a' -> withReduce2 r a' b) <$> reduced a + <|> (\b' -> withReduce2 r a b') <$> reduced b + <|> fromInteger <$> intExpr rr + <|> fromDouble <$> doubleExpr rr + } + +------------------------------------------------------------------------------ +-- Function types +------------------------------------------------------------------------------ + +-- | Conversion from @Expr@ to other types +class FromExpr a where + fromExpr :: Expr -> a + +instance FromExpr Expr where + fromExpr = id + +instance (Show a, FromExpr b) => FromExpr (a -> b) where + fromExpr f a = fromExpr $ op L 10 " " f (lift a) + +-- | A generic function variable +fun :: FromExpr a => String -> a +fun = fromExpr . var + +------------------------------------------------------------------------------ +-- Forcing conversion & evaluation +------------------------------------------------------------------------------ + +-- | Force something to be an expression. +expr :: Expr -> Expr +expr = id + +-- | Reduce (evaluate) an expression once. +-- +-- For example @reduce (1 + 2 + 3 + 4) == 3 + 3 + 4@ +reduce :: Expr -> Expr +reduce e = maybe e id (reduced e) + +-- | Show all reduction steps when evaluating an expression. +reduction :: Expr -> [Expr] +reduction e = e : unfoldr (\e -> do e' <- reduced e; return (e',e')) e + +------------------------------------------------------------------------------ +-- Numeric classes +------------------------------------------------------------------------------ + +instance Eq Expr where + Expr{ intExpr = Just a } == Expr{ intExpr = Just b } = a == b + Expr{ doubleExpr = Just a } == Expr{ doubleExpr = Just b } = a == b + a == b = show a == show b + +instance Ord Expr where + compare Expr{ intExpr = Just a } Expr{ intExpr = Just b } = compare a b + compare Expr{ doubleExpr = Just a } Expr{ doubleExpr = Just b } = compare a b + compare a b = compare (show a) (show b) + min = fun "min" `iOp2` min `dOp2` min + max = fun "max" `iOp2` max `dOp2` max + +instance Num Expr where + (+) = withReduce2 $ op L 6 " + " `iOp2` (+) `dOp2` (+) + (-) = withReduce2 $ op L 6 " - " `iOp2` (-) `dOp2` (-) + (*) = withReduce2 $ op L 7 " * " `iOp2` (*) `dOp2` (*) + negate = withReduce $ fun "negate" `iOp` negate `dOp` negate + abs = withReduce $ fun "abs" `iOp` abs `dOp` abs + signum = withReduce $ fun "signum" `iOp` signum `dOp` signum + fromInteger i = (lift i) + { intExpr = Just i + , doubleExpr = Just $ fromInteger i } + +instance Real Expr where + toRational expr = case (doubleExpr expr, intExpr expr) of + (Just d,_) -> toRational d + (_,Just i) -> toRational i + _ -> error "not a number" + +instance Integral Expr where + quotRem a b = (quot a b, rem a b) + divMod a b = (div a b, mod a b) + quot = withReduce2 $ op L 7 " `quot` " `iOp2` quot + rem = withReduce2 $ op L 7 " `rem` " `iOp2` rem + div = withReduce2 $ op L 7 " `div` " `iOp2` div + mod = withReduce2 $ op L 7 " `mod` " `iOp2` mod + toInteger expr = case intExpr expr of + Just i -> i + _ -> error "not a number" + +instance Fractional Expr where + (/) = withReduce2 $ op L 7 " / " `dOp2` (/) + recip = withReduce $ fun "recip" `dOp` recip + fromRational r = fromDouble (fromRational r) + +fromDouble d = (lift d) { doubleExpr = Just d } + +instance Floating Expr where + pi = (var "pi") { doubleExpr = Just pi } + exp = withReduce $ fun "exp" `dOp` exp + sqrt = withReduce $ fun "sqrt" `dOp` sqrt + log = withReduce $ fun "log" `dOp` log + (**) = withReduce2 $ op R 8 "**" `dOp2` (**) + sin = withReduce $ fun "sin" `dOp` sin + cos = withReduce $ fun "cos" `dOp` cos + sinh = withReduce $ fun "sinh" `dOp` sinh + cosh = withReduce $ fun "cosh" `dOp` cosh + asin = withReduce $ fun "asin" `dOp` asin + acos = withReduce $ fun "acos" `dOp` acos + atan = withReduce $ fun "atan" `dOp` atan + asinh = withReduce $ fun "asinh" `dOp` asinh + acosh = withReduce $ fun "acosh" `dOp` acosh + atanh = withReduce $ fun "atanh" `dOp` atanh + +instance Enum Expr where + succ = withReduce $ fun "succ" `iOp` succ `dOp` succ + pred = withReduce $ fun "pred" `iOp` pred `dOp` pred + toEnum = fun "toEnum" + fromEnum = fromEnum . toInteger + enumFrom a = map fromInteger $ enumFrom (toInteger a) + enumFromThen a b = map fromInteger $ enumFromThen (toInteger a) (toInteger b) + enumFromTo a c = map fromInteger $ enumFromTo (toInteger a) (toInteger c) + enumFromThenTo a b c = map fromInteger $ enumFromThenTo (toInteger a) (toInteger b) (toInteger c) + +instance Bounded Expr where + minBound = var "minBound" + maxBound = var "maxBound" diff --git a/Debug/SimpleReflect/Vars.hs b/Debug/SimpleReflect/Vars.hs new file mode 100644 --- /dev/null +++ b/Debug/SimpleReflect/Vars.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Debug.SimpleReflect.Vars +-- Copyright : (c) 2008 Twan van Laarhoven +-- License : BSD-style +-- +-- Maintainer : twanvl@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Single letter variable names. +-- +-- All names have type @Expr@, except for @f@, @g@ and @h@, which are generic functions. +-- This means that @show (f x :: Expr) == \"f x\"@, but that @show (a x :: Expr)@ gives a type error. +-- On the other hand, the type of @g@ in @show (f g)@ is ambiguous. +-- +----------------------------------------------------------------------------- +module Debug.SimpleReflect.Vars + ( -- * Variables + a,b,c,d,e,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z + -- * Functions + , f,f',f'',g,h + ) where + +import Debug.SimpleReflect.Expr + +------------------------------------------------------------------------------ +-- Variables! +------------------------------------------------------------------------------ + +a,b,c,d,e,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z :: Expr +[a,b,c,d,e,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z] + = [var [x] | x <- ['a'..'e']++['i'..'z']] + +f,f',f'',g,h :: FromExpr a => a +f = fun "f" +f' = fun "f'" +f'' = fun "f''" +g = fun "g" +h = fun "h" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Twan van Laarhoven 2008. + +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. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/simple-reflect.cabal b/simple-reflect.cabal new file mode 100644 --- /dev/null +++ b/simple-reflect.cabal @@ -0,0 +1,22 @@ +name: simple-reflect +version: 0.1 +homepage: http://twan.home.fmf.nl/blog/haskell/simple-reflection-of-expressions.details +license: BSD3 +license-file: LICENSE +author: Twan van Laarhoven +maintainer: twanvl@gmail.com +category: Debug +cabal-version: >= 1.2 +build-type: Simple +synopsis: Simple reflection of expressions containing variables +description: + This package allows simple reflection of expressions containing variables. + Reflection here means that a Haskell expression is turned into a string. + + The primary aim of this package is teaching and understanding; + there are no options for manipulating the reflected expressions beyond showing them. +build-depends: base +exposed-modules: + Debug.SimpleReflect + Debug.SimpleReflect.Expr + Debug.SimpleReflect.Vars