liboleg 2010.1.9.0 → 2010.1.10.0

raw patch · 10 files changed

+546/−8 lines, 10 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Control/CCCxe.hs +1/−1
• Control/CCExc.hs +1/−1
• Control/CaughtMonadIO.hs +3/−3
• Data/Symbolic/Diff.hs +295/−0
• Data/Symbolic/DiffTest.hs +33/−0
• Data/Symbolic/TypedCode.hs +154/−0
• Data/Symbolic/TypedCodeAux.hs +50/−0
• Language/TEval/TInfTM.hs +1/−0
• System/SafeHandles.hs +1/−1
• liboleg.cabal +7/−2

@@ -183,7 +183,7 @@   P2 (Either (CCT (P2 w1 w2) m x w1) (CCT (P2 w1 w2) m x w2))  --- | There are two generalized prompts of the flavor P2"+-- | There are two generalized prompts of the flavor P2 p2L :: Prompt (P2 w1 w2) m w1 p2L = (inj, prj)  where

@@ -190,7 +190,7 @@   P2 (Either (CCT (P2 w1 w2) m x w1) (CCT (P2 w1 w2) m x w2))  --- | There are two generalized prompts of the flavor P2:+-- | There are two generalized prompts of the flavor P2 p2L :: Prompt (P2 w1 w2) m w1 p2L = (inj, prj)  where

@@ -31,8 +31,8 @@ import Data.Typeable import Data.Dynamic import Control.Monad.Trans-import Control.Exception hiding (catch, catchDyn)-import qualified Control.Exception (catch)+import Control.OldException hiding (catch, catchDyn)+import qualified Control.OldException (catch) import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.State@@ -81,7 +81,7 @@      gcatch :: m a -> (Exception -> m a) -> m a  instance CaughtMonadIO IO where-     gcatch = Control.Exception.catch+     gcatch = Control.OldException.catch  instance (CaughtMonadIO m, Error e) => CaughtMonadIO (ErrorT e m) where      gcatch m f = mapErrorT (\m -> gcatch m (\e -> runErrorT $ f e)) m

@@ -0,0 +1,295 @@+{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Reify the (compiled) code to its typed TH representation +-- (or, the dictionary *view*, to be precise) and reflect\/compile that code.+-- We must spread the code through several modules, due to the+-- particular requirement of the Template Haskell.+-- See DiffTest.hs for reflection of the differentiated TH code back+-- into (machine) code.++module Data.Symbolic.Diff where++import Data.Symbolic.TypedCode+++-- | Lift Nums, Fractionals, and Floating to code expressions+--+instance Num a => Num (Code a) where+    x + y = op'add `appC` x `appC` y+    x - y = op'sub `appC` x `appC` y+    x * y = op'mul `appC` x `appC` y+    negate x = op'negate `appC` x+    fromInteger = integerC++instance Fractional a => Fractional (Code a) where+    x / y = op'div `appC` x `appC` y+    recip x = op'recip `appC` x+    fromRational = rationalC++instance Floating a => Floating (Code a) where+    pi = op'pi+    sin x = op'sin `appC` x+    cos x = op'cos `appC` x++testf1 :: Num a => a+testf1 = 1 + 2+testf1' = return (testf1 :: Code Int)+testf1'' = showQC testf1' -- (GHC.Num.+) 1 2+++-- | We can define a function+--+test1f x = let y = x * x in y + 1+test1 = test1f (2.0::Float)++-- | we can even compile it. At any point, we can reify it, into+-- a `dictionary view'+-- The result is the TH code, which we can print, and compile back+-- to the code. We can also differentiate the TH code, simplify it,+-- partially evaluate it, etc.+--+test1c = new'diffVar >>= \ (v::Var Float) -> return $ (test1f (var'exp v),v)+test1r = test1c >>= \ (c,v) -> reflectDF v c+test1cp = showQC test1r++-- and reflect it back, see DiffTest.hs+{-+We must stress that there is no `reify' function. One may say it is+built into Haskell already.+++    *Diff> test1+    5.0+    *DiffTest> test1'+    5.0+    *Diff> test1cp+    \dx_0 -> GHC.Num.+ (GHC.Num.* dx_0 dx_0) 1+-}+++-- | Symbolic Differentiation of the reified, typed TH code expressions+-- The derivative over the code is a type preserving operation+--+diffC :: (Floating a, Floating b) => Var b -> Code a -> Code a++diffC v c | Just _  <- on'litC c = 0+diffC v c | Just ev <- on'varC v c = either (const 1) (const 0) ev++diffC v c | Just (x,y) <- on'2opC op'add c =+			  (diffC v x) + (diffC v y)++diffC v c | Just (x,y) <- on'2opC op'sub c =+			  (diffC v x) - (diffC v y)++diffC v c | Just (x,y) <- on'2opC op'mul c =+			    ((diffC v x) * y) + (x * (diffC v y))++diffC v c | Just (x,y) <- on'2opC op'div c =+			  ((diffC v x) * y - x * (diffC v y)) / (y*y)++diffC v c | Just x <- on'1opC op'negate c =+			  negate (diffC v x)++diffC v c | Just x <- on'1opC op'recip c =+			  negate (diffC v x) / (x*x)++diffC v c | Just x <- on'1opC op'sin c =+			  (diffC v x) * cos x++diffC v c | Just x <- on'1opC op'cos c =+			  negate ((diffC v x) * sin x)++diffC v c = error $ "Cannot handle code: " ++ show c+++test1d = test1c >>= \ (c,v) -> reflectDF v $ diffC v c+test1dp = showQC test1d++{-+ *Diff> test1dp+ \dx_0 -> (GHC.Num.+) ((GHC.Num.+) ((GHC.Num.*) 1 dx_0) ((GHC.Num.*) dx_0 1)) 0+-}+++-- | Simplification rules+-- simplification is type-preserving+-- obviously, simplification is an `open-ended' problem:+-- we could even recognize common sub-expressions and simplify them+-- by introducing let binding.+-- In the following however, we do trivial simplification only.+-- One can always add more simplification rules later.+--+simpleC :: Floating a => Var b -> Code a -> Code a++-- | repeat until no simplifications are made+simpleC v c | Just c' <- simpleCL v c = simpleC v c'+simpleC v c = c++simpleCL :: Floating a => Var b -> Code a -> Maybe (Code a)++simpleCL v c | Just _ <- on'litC c = Nothing+simpleCL v c | Just _ <- on'varC v c = Nothing++simpleCL v c | Just (x,y) <- on'2opC op'add c =+			     simple'recur op'add sadd v x y+  where+  sadd x y | Just 0 <- on'litRationalC x = Just y+  sadd x y | Just 0 <- on'litRationalC y = Just x+		       -- constant folding+  sadd x y | (Just x, Just y) <- (on'litRationalC x, on'litRationalC y)+			      = Just (fromRational $ x + y)+  sadd x y = Nothing++simpleCL v c | Just (x,y) <- on'2opC op'sub c =+			     simple'recur op'sub ssub v x y+  where+  ssub x y | Just 0 <- on'litRationalC y = Just x+		       -- constant folding+  ssub x y | (Just x, Just y) <- (on'litRationalC x, on'litRationalC y)+			      = Just (fromRational $ x - y)+  ssub x y = Nothing+++simpleCL v c | Just (x,y) <- on'2opC op'mul c =+			     simple'recur op'mul smul v x y+  where+  smul x y | Just 0 <- on'litRationalC x = Just (fromRational 0)+  smul x y | Just 0 <- on'litRationalC y = Just (fromRational 0)+  smul x y | Just 1 <- on'litRationalC x = Just y+  smul x y | Just 1 <- on'litRationalC y = Just x+  smul x y | (Just x, Just y) <- (on'litRationalC x, on'litRationalC y)+			      = Just (fromRational $ x * y)+  smul x y = Nothing -- error $ unwords ["here",show x,show y] -- Nothing+++simpleCL v c | Just (x,y) <- on'2opC op'div c =+			     simple'recur op'div sdiv v x y+  where+  sdiv x y | Just 0 <- on'litRationalC x = Just (fromRational 0)+  sdiv x y = Nothing -- error $ unwords ["here",show x,show y] -- Nothing++simpleCL v c | Just x <- on'1opC op'negate c =+			     simple'recur1 op'negate sneg v x+  where+  sneg x | Just 0 <- on'litRationalC x = Just (fromRational 0)+  sneg x = Nothing +++simpleCL v c = Nothing++simple'recur op fn v x y = +    case (simpleCL v x, simpleCL v y) of+	     (Nothing,Nothing) -> fn x y+	     (Just x,Nothing)  -> Just (op `appC` x `appC` y)+	     (Nothing,Just y)  -> Just (op `appC` x `appC` y)+	     (Just x,Just y)   -> Just (op `appC` x `appC` y)++simple'recur1 op fn v x = +    case simpleCL v x of+	     Nothing -> fn x+	     Just x  -> Just (op `appC` x)++test1ds = test1c >>= \ (c,v) -> reflectDF v $ simpleC v $ diffC v c+test1dsp = showQC test1ds++{-+   *Diff> test1dsp+   \dx_0 -> GHC.Num.+ dx_0 dx_0+-}++-- | And that's about it. Putting it all together gives us:+--+diff_fn :: Floating b => (forall a. Floating a => a -> a) -> QCode (b -> b)+diff_fn f = +    do+    v <- new'diffVar+    let body = f (var'exp v)   -- reified body of the function+    reflectDF v . simpleC v . diffC v $ body -- differentiate and simplify++-- | This is a useful helper to show us the code of the function in question+show_fn :: (forall a. Floating a => a -> a) -> IO ()+show_fn f = showQC (+		    do+		    v <- new'diffVar+		    reflectDF v (f (var'exp v)))++-- We can either print the result of diff_fn, or compile it+-- (that is, splice it: see DiffTest.hs)+++-- | More examples+--+test2f x = foldl (\z c -> x*z + c) 0 [1,2,3]+test2n = test2f (4::Float)  -- 27.0+test2s = show_fn test2f++{-+  *Diff> test2s+  \dx_0 -> GHC.Num.+ (GHC.Num.* dx_0 (GHC.Num.+ +     (GHC.Num.* dx_0 (GHC.Num.+ (GHC.Num.* dx_0 0) 1)) 2)) 3+-}++test2ds = showQC (diff_fn test2f)++{- Not too bad: 2*x + 2+ *Diff> test2ds+ \dx_0 -> GHC.Num.+ (GHC.Num.+ dx_0 2) dx_0+-}++{- The differentiated code can be `compiled back', see DiffTest.hs+  test2dn = $(reflectQC (diff_fn test2f)) (4::Float)+  -- 10.0+-}++-- Check the constant folding+test11f x = 2*x + 3*x+test11ds = showQC (diff_fn test11f) -- \dx_0 -> 5%1+++-- | Here's a slightly more complex example:+--+test5f x = sin (5*x + pi/2) + cos(1 / x)+test5n = test5f (pi::Float) -- cos(1/pi)-1 == -5.023426e-2+test5ds = showQC (diff_fn test5f)+++{- which isn't too bad: quite optimal, actually+*Diff> test5ds+\dx_0 -> GHC.Num.+ (GHC.Num.* 5 (GHC.Float.cos +    (GHC.Num.+ (GHC.Num.* 5 dx_0) (GHC.Real./ GHC.Float.pi 2))))+   (GHC.Num.negate (GHC.Num.* (GHC.Real./ ((-1)%1) (GHC.Num.* dx_0 dx_0)) +        (GHC.Float.sin (GHC.Real./ 1 dx_0))))+-}++-- One may evaluate the function test5f numerically, differentiate it+-- symbolically, check the result of differentiation -- and evaluate it+-- numerically right away. See test5dn in DiffTest.hs for the latter.+++-- | We can even do partial derivatives:+--+test3f x y = (x*y + (5*x*x)) / y++test4x y = diff_fn (\x -> test3f x (fromIntegral y))+test4y x = diff_fn (test3f (fromInteger x))++test4xds = showQC (test4x 1) -- 1 + 10*x+test4yds = showQC (test4y 5) ++{-+ *DiffTest> test4yds+ \dx_0 -> GHC.Real./ (GHC.Num.- (GHC.Num.* 5 dx_0) +             (GHC.Num.+ (GHC.Num.* 5 dx_0) (125%1))) (GHC.Num.* dx_0 dx_0)++-}++{- In DiffTest.hs+-- partial derivative with respect to x+test4xdn = $(reflectQC (test4x 1)) (2::Float)+-- 21.0++-- | partial derivative with respect to y+test4ydn = $(reflectQC (test4y 5)) (5::Float)+-- -5.0+-}

@@ -0,0 +1,33 @@+{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TemplateHaskell #-} ++-- | Running the splicing tests from Diff.hs.+-- Due to the TH requirement, this code must be in a separate module.+--+module Data.Symbolic.DiffTest where++import Data.Symbolic.Diff+import Data.Symbolic.TypedCode++testrf1 = $(reflectQC testf1')++test1' = $(reflectQC test1r) 2.0+test1ds' = $(reflectQC test1ds) 2.0++test2dn = $(reflectQC (diff_fn test2f)) (4::Float)+-- 10.0++test11dn = $(reflectQC (diff_fn test11f)) (4::Float)+-- 5.0++test5dn = $(reflectQC (diff_fn test5f)) (pi::Float)+-- 3.171623e-2, approx sin(1/pi)/pi/pi+-- approx, because: cos(5*(pi::Float) + pi/2) isn't exactly 0++-- | partial derivative with respect to x+test4xdn = $(reflectQC (test4x 1)) (2::Float)+-- 21.0++-- | partial derivative with respect to y+test4ydn = $(reflectQC (test4y 5)) (5::Float)+-- -5.0

@@ -0,0 +1,154 @@+{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Template Haskell code is untyped, which is a bummer and leads to late+-- error reporting. We make code expressions typed, at least for our particular+-- domain.+--+module Data.Symbolic.TypedCode (+                  Code, -- only the type is exported,+                        -- data constructor is private+                  Var,  -- ditto+                  QCode,+                  reflectQC, showQC,++                  -- typed primitive operations+                  op'add, op'sub, op'mul, op'div, op'negate, op'recip,+                  op'sin, op'cos, op'pi,++                  -- Code combinators+                  appC,++                  -- Lifting from primitive datatypes to Code+                  integerC, rationalC,++                  -- create a variable to differentiate over+                  new'diffVar, var'exp, reflectDF,++                  -- combinators for the intensional code analysis+                  on'varC, on'litC, on'litRationalC, on'1opC, on'2opC+                 ) where++import Data.Symbolic.TypedCodeAux+import Language.Haskell.TH+import Language.Haskell.TH.Ppr++-- | The data type of a typed TH code experssion. The phantom parameter 'a'+-- is the type.+--+newtype Code a = Code {unC :: Exp} deriving (Eq, Show)+type QCode a = Q (Code a)+newtype Var a = Var Name++show_code cde = runQ cde >>= putStrLn . pprint++showQC :: Q (Code a) -> IO ()+showQC qc = runQ qc >>= putStrLn . pprint . unC++-- | This function is useful when splicing code expressions+-- See DiffTest.hs for the examples of its use.+reflectQC :: Q (Code a) -> Q Exp+reflectQC qc = qc >>= return . unC+++-- | Typed primitive operations+--+op'add :: Num a => Code (a->a->a)+op'add = Code . VarE $ $(reifyName [e| (+) |])+op'sub :: Num a => Code (a->a->a)+op'sub = Code . VarE $ $(reifyName [e| (-) |])+op'mul :: Num a => Code (a->a->a)+op'mul = Code . VarE $ $(reifyName [e| (*) |])+op'div :: Fractional a => Code (a->a->a)+op'div = Code . VarE $ $(reifyName [e| (/) |])+op'negate :: Num a => Code (a->a)+op'negate = Code . VarE $ $(reifyName [e| negate |])+op'recip :: Fractional a => Code (a->a)+op'recip = Code . VarE $ $(reifyName [e| recip |])++op'sin :: Floating a => Code (a->a)+op'sin = Code . VarE $ $(reifyName [e| sin |])+op'cos :: Floating a => Code (a->a)+op'cos = Code . VarE $ $(reifyName [e| cos |])+op'pi :: Floating a => Code a+op'pi = Code . VarE $ $(reifyName [e| pi |])++-- | Code expression combinators +--+appC :: Code (a->b) -> Code a -> Code b+appC (Code f) (Code x) = Code $ AppE f x++-- | Lifting from primitive datatypes to Code+--+integerC :: Num a => Integer -> Code a +integerC x = Code . LitE . integerL $ x+rationalC :: Fractional a => Rational -> Code a +rationalC x = Code . LitE . rationalL $ x++-- | A distinguished variable (over which we differentiate)+new'diffVar :: Q (Var a)+new'diffVar = newName "dx" >>= return . Var++-- | Lift this variable to Code+var'exp :: Var a -> Code a+var'exp (Var name) = Code . VarE $ name++-- abstract over the differentiation variable+-- That is, convert from+--+-- > diffVar |- body +--+-- to+--+-- > |- diffVar -> body+--+-- In this formulation, this looks exactly like the Deduction theorem!+-- We take advantage of the fact that TH is non-hygienic.+-- That is, instead of binding a fresh variable and traversing+-- the body replacing diffVar with that variable (as we should do+-- in MetaOCaml), we simply non-hygienically bind the diffVar.+-- We save ourselves the term traversal: normalization by evaluation.+--+reflectDF:: Var a -> Code a -> QCode (a->a)+reflectDF (Var name) (Code body) = +    lam1E (varP name) (return body) >>= return . Code++e1 = [e| 1 + 2 |]+t1 = show_code e1+t2 (InfixE me1 (VarE name) me3) = reify name+t2' = show_code (e1 >>= t2)+++-- | Intensional code analysis+-- Alas, TH.Exp is not a GADT. So, we have to do their emulation...+--+on'litC :: Code a -> Maybe (Code a)+on'litC c@(Code (LitE _)) = Just c+on'litC _ = Nothing++on'litRationalC :: Code a -> Maybe Rational+on'litRationalC (Code (LitE lit)) = +    case lit of+         IntegerL x    -> Just $ toRational x+         IntPrimL x    -> Just $ toRational x+         RationalL x   -> Just x+         FloatPrimL x  -> Just x+         DoublePrimL x -> Just x+         _ -> Nothing+on'litRationalC _ = Nothing+++on'varC :: Var a -> Code b -> Maybe (Either (Var a) (Var b))+on'varC v@(Var name) (Code c) | c == VarE name = Just (Left v)+on'varC _ (Code (VarE n)) = Just . Right . Var $ n+on'varC _ _ = Nothing++on'2opC :: Code (a->b->c) -> Code d -> Maybe (Code a, Code b)+on'2opC (Code op) (Code (AppE (AppE f x) y)) | op == f+    = Just (Code x,Code y)+on'2opC _ _ = Nothing++on'1opC :: Code (a->b) -> Code d -> Maybe (Code a)+on'1opC (Code op) (Code (AppE f x)) | op == f+    = Just (Code x)+on'1opC _ _ = Nothing

@@ -0,0 +1,50 @@+{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Obtain the Name that corresponds to a top-level (Prelude-level)+-- Haskell identifier.+-- Given an expression such as [e| (+) |] we return the expression+-- that is the application of mkNameG_v to the correct strings.+-- That expression, when spliced in, will compute exactly the same+-- name that corresponds to the one we started with, that is, (+).+-- Note that (+) was the identifier, not the name.+-- The result of splicing reifyName can be used in splices+-- (see the Diff.hs for examples).+-- We essentially apply the TH to itself and emulate more than one stage+-- of computation.+--+module Data.Symbolic.TypedCodeAux where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Ppr++reifyName :: Q Exp -> Q Exp++{- For GHC prior to 6.6, use the following code. TH has changed in+   GHC 6.6+reifyName nameE = nameE >>= +		    \ (VarE (Name occname (NameG VarName mn))) -> +			[e| mkNameG_v $(litE . stringL . modString $ mn)+			 $(litE . stringL . occString $ occname)|]++-}++reifyName nameE = nameE >>= +		    \ (VarE (Name occname (NameG VarName pn mn))) -> +			[e| mkNameG_v+			 $(litE . stringL . pkgString $ pn)+			 $(litE . stringL . modString $ mn)+			 $(litE . stringL . occString $ occname)|]++++{-+  Remnants of early experiments++foo = $([e| (+) |] >>= \ (VarE name) -> global name)+-- foo1 = $([e| (+) |] >>= \ (VarE name) -> global $ mkName "GHC.Num.+")+foo1 = $([e| (+) |] >>= \ (VarE (Name occname (NameG VarName mn))) -> +	 [e| mkNameG_v $(litE . stringL . modString $ mn)+	               $(litE . stringL . occString $ occname)|])+-}

@@ -1,3 +1,4 @@+{-# LANGUAGE PatternGuards #-} -- | Simply-typed Curry-style (nominal) lambda-calculus -- with integers and zero-comparison -- Type inference. Hiding the single-threaded state via simple

@@ -67,7 +67,7 @@      ) where  import System.IO-import Control.Exception+import Control.OldException import Control.Monad.Reader import Control.Monad.Trans import Data.IORef

@@ -1,5 +1,5 @@ name:           liboleg-version:        2010.1.9.0+version:        2010.1.10.0 license:        BSD3 license-file:   LICENSE author:         Oleg Kiselyov@@ -18,7 +18,7 @@  library     build-depends:-            base >= 2 && < 4,+            base >=4 && <5,             containers,             mtl,             unix,@@ -30,6 +30,11 @@             Data.Class1             Data.Class2             Data.Numerals++            Data.Symbolic.Diff+            Data.Symbolic.DiffTest+            Data.Symbolic.TypedCodeAux+            Data.Symbolic.TypedCode              Control.CaughtMonadIO             Control.ShiftResetGenuine