ap-reflect

debug

simple-reflect と組み合わせて使う

モチベーション

simple-reflect パッケージでは、演算子を以下のように定義している。

iOp  :: (Expr -> Expr) -> (Integer -> Integer) -> Expr -> Expr
dOp  :: (Expr -> Expr) -> (Double -> Double)   -> Expr -> Expr
bOp  :: (Expr -> Expr) -> (Bool -> Bool) -> Expr -> Expr
iOp r f a = (r a) { intExpr    = f <$> intExpr    a }
dOp r f a = (r a) { doubleExpr = f <$> doubleExpr a }
bOp r f a = (r a) { boolExpr   = f <$> boolExpr   a }

iOp2 :: (Expr -> Expr -> Expr) -> (Integer -> Integer -> Integer) -> Expr -> Expr -> Expr
dOp2 :: (Expr -> Expr -> Expr) -> (Double  -> Double  -> Double)  -> Expr -> Expr -> Expr
bOp2 :: (Expr -> Expr -> Expr) -> (Bool    -> Bool    -> Bool)    -> Expr -> Expr -> Expr
iOp2 r f a b = (r a b) { intExpr    = f <$> intExpr    a <*> intExpr    b }
dOp2 r f a b = (r a b) { doubleExpr = f <$> doubleExpr a <*> doubleExpr b }
bOp2 r f a b = (r a b) { boolExpr   = f <$> boolExpr   a <*> boolExpr   b }

また、Expr型の定義は以下のようになっている。

data Expr = Expr
   { showExpr   :: Int -> ShowS  -- ^ Show with the given precedence level
   , intExpr    :: Maybe Integer -- ^ Integer value?
   , doubleExpr :: Maybe Double  -- ^ Floating value?
   , boolExpr   :: Maybe Bool
   , reduced    :: Maybe Expr    -- ^ Next reduction step
   }

これらを一般化して、任意の型に対して動作する関数が makeBinOp 。

使い方

λ stack repl --package simple-reflect --package ap-reflect

*Main> mapM_ print . reductions $ makeBinOp "+" (+) -$- Just a -*- Just b
(+) <$> Just a <*> Just b
Just (a +) <*> Just b
Just (a + b)

サンプル

{-# LANGUAGE TypeOperators #-}

import Control.Applicative
import Data.Functor.Identity

import Debug.SimpleReflect
import Debug.Reflect

-- внутреннее представление операций

-- (+)
(.+) :: (Num a, Show a) => a ~> a ~> a
(.+) = makeBinOp "+" (+)

-- (-)
(.-) :: (Num a, Show a) => a ~> a ~> a
(.-) = makeBinOp "-" (-)

-- (*)
(.*) :: (Num a, Show a) => a ~> a ~> a
(.*) = makeBinOp "*" (*)

-- (/)
(./) :: (Fractional a, Show a) => a ~> a ~> a
(./) = makeBinOp "/" (/)

-- (++)
(.++) :: (Show a) => [a] ~> [a] ~> [a]
(.++) = makeBinOp "++" (++)

-- (:)
(.:) :: (Show a) => a ~> [a] ~> [a]
(.:) = makeBinOp ":" (:)

sequenceA' :: (Show a, Show (f a), Show (f [a]), Show (f ([a] ~> [a])), Applicative f) => [f a] -> Ap (f [a])
sequenceA' [] = pure'' []
sequenceA' (x:xs) = Val ap' :$ ((.:) -$- x) :$ sequenceA' xs

traverse' :: (Show a, Show b, Show (f b), Show (f [b]), Show (f ([b] ~> [b])), Applicative f) => (a -> f b) -> [a] -> Ap (f [b])
traverse' _ [] = pure'' []
traverse' f (x:xs) = Val ap' :$ (Val fmap' :$ Val (.:) :$ fx) :$ traverse' f xs
  where fx = Val (Fn "f" f) :$ Val x


main :: IO ()
main = do

  let line = putStrLn "------------------------------------------"

  let 
    g' = makeBinOp "g" (g :: Expr -> Expr -> Expr)
    h' = makeBinOp "h" (h :: Expr -> Expr -> Expr)
  mapM_ print . reductions $ Val [fromFn g' 1, fromFn h' 2] -*- [a, b, c]
  line

  mapM_ print . reductions $ makeBinOp "f" (f :: Expr -> Expr -> Expr) -$- Just a -*- Just b
  line
  mapM_ print . reductions $ Val (Just (fromFn (.+) a)) -*- Just b
  line
  mapM_ print . reductions $ Val (Just (Fn "(+ a)" (+ a))) -*- Just b
  line

  mapM_ print . reductions $ fmap'' (.+) (Just a)
  line
  mapM_ print . reductions $ fmap'' (.+) (Just a) -*- Just b
  line
  mapM_ print . reductions $ pure'' (.+) -*- Just a -*- Just b
  line

  mapM_ print . reductions $ (.+) -$- Identity a
  line
  mapM_ print . reductions $ (.+) -$- Identity a -*- Identity b
  line

  mapM_ print . reductions $ (.+) -$- Const (a + b)
  line
  mapM_ print . reductions $ (.+) -$- Const a -*- Const b
  line

  mapM_ print . reductions $ (.+) -$- ZipList [1,2,3] -*- ZipList [100,100,100]
  line
  mapM_ print . reductions $ makeBinOp "max" max -$- ZipList [1,2,3,4,5,3] -*- ZipList [5,3,1,2] 
  line
  mapM_ print . reductions $ Val (ZipList [fromFn (.+) 1, fromFn (.*) 100]) -*- ZipList [a,b]
  line

  let f x = if even (length x) then Just (head x) else Nothing
  mapM_ print . reductions $ traverse' f ["ab","cdef","gh"]
  line
  mapM_ print . reductions $ sequenceA' [Just a, Just b, Just c]
  line
  mapM_ print . reductions $ sequenceA' [Just a, Nothing, Just c]
  line
  mapM_ print . reductions $ makeBinOp "f" (+) -$- [x, y]
  line

  mapM_ print . reductions $ (.++) -$- Just "hello " -*- Just "world"
  line
  mapM_ print . reductions $ (.+) -$- ("1 + ", 1) -*- ("6 =", 6)
  line
  mapM_ print . reductions $ (.*) -$- Just 3 -*- Just 2
  line
  mapM_ print . reductions $ (./) -$- Just 3 -*- Just 2
  line
  mapM_ print . reductions $ (.+) -$- Just 1
  line
  mapM_ print . reductions $ (.+) -$- Just 1 -*- Just 3
  line
  mapM_ print . reductions $ (.+) -$- Just a -*- Just b
  line
  mapM_ print . reductions $ (.-) -$- Just a -*- Just b
  line
  mapM_ print . reductions $ (.+) -$- Nothing
  line
  mapM_ print . reductions $ (.+) -$- Just a -*- Nothing
  line
  mapM_ print . reductions $ (.+) -$- Nothing -*- Just b
  line
  mapM_ print . reductions $ (.+) -$- [1, 2, 3]
  line
  mapM_ print . reductions $ (.+) -$- [a, b] -*- [x, y]
  line
  mapM_ print . reductions $ (.+) -$- []
  line
  mapM_ print . reductions $ (.+) -$- [1,2] -*- []
  line
  mapM_ print . reductions $ (.+) -$- Right a -*- Left b
  line
  mapM_ print . reductions $ (.+) -$- Left a -*- Right b
  line

問題点

True && Fales && True のような式を書く場合に、どうしたら良いかわからない。

ghci
*Main> and = makeBinOp "&&" (&&)
*Main> :t and
and :: Bool ~> (Bool ~> Bool)

*Main> and -$- (Just True) -*- (Just True)
(&&) <$> Just True <*> Just True

*Main> and -$- e1 -*- Just False

<interactive>:10:9: error:
    • Couldn't match type ‘Maybe Bool’ with ‘Bool’
      Expected type: Ap Bool
        Actual type: Ap (Maybe Bool)
    • In the second argument of ‘(-$-)’, namely ‘e1’
      In the first argument of ‘(-*-)’, namely ‘and -$- e1’
      In the expression: and -$- e1 -*- Just False

<interactive>:10:16: error:
    • Couldn't match type ‘Maybe’ with ‘Ap’
      Expected type: Ap Bool
        Actual type: Maybe Bool
    • In the second argument of ‘(-*-)’, namely ‘Just False’
      In the expression: and -$- e1 -*- Just False
      In an equation for ‘it’: it = and -$- e1 -*- Just False

通常の Applicative であれば以下のように計算できる

ghci
*Main> (&&) <$> Just True <*> Just True
Just True

*Main> e1 = (&&) <$> Just True <*> Just True
*Main> (&&) <$> e1 <*> Just False
Just False

これは、計算の結果 Ap になってしまうために起きている問題。

ghci
*Main> :t (&&) <$> Just True <*> Just True
(&&) <$> Just True <*> Just True :: Maybe Bool

*Main> :t and -$- (Just True) -*- (Just True)
and -$- (Just True) -*- (Just True) :: Ap (Maybe Bool)
Previous理解支援Nextfree-theorems-static-webui

Last updated