ap-reflect (empty) → 0.1.0.0

raw patch · 4 files changed

+187/−0 lines, 4 filesdep +basesetup-changed

Dependencies added: base

Files

LICENSE +30/−0
Setup.hs +2/−0
ap-reflect.cabal +26/−0
src/Debug/Reflect.hs +129/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2014, Oleg Baev++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 Nickolay Kudasov nor the names of other+      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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ ap-reflect.cabal view

@@ -0,0 +1,26 @@+name:                ap-reflect
+version:             0.1.0.0
+synopsis:            Partial evaluation reflection a la simple-reflect.
+-- description:         
+license:             BSD3
+license-file:        LICENSE
+author:              Oleg Baev
+maintainer:          odbaev@yandex.ru
+homepage:            https://github.com/cmc-msu-ai/ap-reflect
+bug-reports:         https://github.com/cmc-msu-ai/ap-reflect/issues
+-- copyright:           
+-- category:            
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  default-language:    Haskell2010
+  hs-source-dirs:      src
+  ghc-options:         -Wall
+  exposed-modules:     Debug.Reflect
+  -- other-modules:       
+  build-depends:       base ==4.6.*
+
+Source-Repository head
+  Type:                 git
+  Location:             https://github.com/cmc-msu-ai/ap-reflect.git

+ src/Debug/Reflect.hs view

@@ -0,0 +1,129 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveFunctor #-}++module Debug.Reflect where++import Control.Applicative (Applicative(..), (<$>))+import Data.List (findIndex, isInfixOf, isPrefixOf)+import Data.Char (isAlpha)+++-- | analog of @(->)@+infixr 5 ~>+data (~>) a b = Fn String (a -> b) -- ^ name and function itself+  deriving (Functor)++-- | gets function+fromFn :: (a ~> b) -> (a -> b)+fromFn (Fn _ f) = f++instance Show (a ~> b) where+  show (Fn s _) = s++-- | adds brackets+parens :: String -> String+parens s = "(" ++ s ++ ")"++-- | checks whether function is infix+isInfixFn :: String -> Bool+isInfixFn = not . any isAlpha++-- | shows function with its argument+showFn :: String -> String -> String+showFn f x = if isInfixFn f then x ++ " " ++ f else f ++ " " ++ x++-- | translates function @(a -> b -> c)@ into @(a ~> b ~> c)@+makeFn2 :: Show a => String -> (a -> b -> c) -> (a ~> b ~> c)+makeFn2 s f = Fn s $ \x -> Fn (showFn s (show x)) (f x)++-- | makes binary operation+makeBinOp :: Show a => String -> (a -> b -> c) -> (a ~> b ~> c)+makeBinOp s f = Fn s' $ \x -> Fn (parens $ showFn s (show x)) (f x)+  where s' = if isInfixFn s then parens s else s++-- | reflected expression+data Ap b+  = Val b+  | forall a. Show a => Ap (a ~> b) :$ Ap a++-- | checks whether expression is @Val@+isVal :: Ap a -> Bool+isVal (Val _) = True+isVal _ = False++-- | balances brackets+balanceParens :: String -> String+balanceParens s = if "<*>" `isInfixOf` s then parens s else s++-- | balances brackets+parensFr :: String -> String+parensFr s = if ' ' `elem` s then parens s else s++-- | shows operation application+showOp :: String -> String -> String -> String+showOp op f x+    | isInfixFn op = f ++ " " ++ op ++ " " ++ balanceParens x+    | otherwise = op ++ " " ++ f ++ " " ++ parensFr x++-- | shows operation application+showF :: String -> String -> String+showF f x+    | "fmap" `isPrefixOf` f = f ++ " " ++ parensFr x+    | otherwise = f ++ " " ++ balanceParens x++instance Show a => Show (Ap a) where+  show (Val x) = show x+  show (op :$ f :$ x) = showOp (show op) (show f) (show x)+  show (f :$ x) = showF (show f) (show x)++-- | analog of @fmap@ using @(~>)@+fmap' :: Functor f => (a ~> b) ~> f a ~> f b+fmap' = makeFn2 "<$>" (fmap . fromFn)++-- | analog of @pure@ using @(~>)@+pure' :: Applicative f => a ~> f a+pure' = Fn "pure" pure++-- | analog of @\<*>@ using @(~>)@+ap' :: (Show (f (a ~> b)), Applicative f) => f (a ~> b) ~> f a ~> f b+ap' = Fn "<*>" $ \f -> Fn (show f ++ " <*>") $ \x -> fromFn <$> f <*> x++-- | analog of  @\<$>@+infix 6 -$-+(-$-) :: (Show (f a), Functor f) => (a ~> b) -> f a -> Ap (f b)+f -$- x = Val fmap' :$ Val f :$ Val x++-- | analog of @\<*>@+infixl 5 -*-+(-*-) :: (Show (f (a ~> b)), Show (f a), Applicative f) => Ap (f (a ~> b)) -> f a -> Ap (f b)+f -*- x = Val ap' :$ f :$ Val x++-- | analog of @pure@+pure'' :: (Show a, Applicative f) => a -> Ap (f a)+pure'' x = Val pure' :$ Val x++-- | analog of @fmap@+fmap'' :: (Show (f a), Functor f) => (a ~> b) -> f a -> Ap (f b)+fmap'' f x = Val (makeFn2 "fmap" (fmap . fromFn)) :$ Val f :$ Val x++-- | reduces an expression+reduce'' :: Ap a -> Ap a+reduce'' (Val (Fn _ f) :$ Val x) = Val (f x)+reduce'' (Val f :$ x) = Val f :$ reduce'' x+reduce'' (f :$ x) = reduce'' f :$ x+reduce'' v = v++-- | reduces (evaluates) an expression once+reduce' :: Show a => Ap a -> Ap a+reduce' x+    | isVal x = x+    | otherwise = head $ filter (\x' -> show x' /= show x) xs+    where xs = iterate reduce'' x++-- | gets all reduction steps when evaluating an expression+reductions :: Show a => Ap a -> [Ap a]+reductions x = take (n + 1) xs+  where+    Just n = findIndex isVal xs+    xs = iterate reduce' x