Ры (pbl) wrote,
Ры
pbl

то есть в каком-то примитивном прототипическом виде это выглядит примерно вот так:

(просьба не пэять хид монструозному бойлерплэйту, это все детали)

(вторая редакция, незначительно дополненная)
{-# OPTIONS -fglasgow-exts #-}

-- boilerplate

import qualified Prelude as P
import qualified Control.Monad as M
import qualified Data.Maybe as Mb

class Desc a where
    dmp :: a -> P.String
    dmp _ = "<<<undumpable>>>"

type Desc0 = P.String
instance Desc Desc0 where
    dmp = P.id

data Desc a => Desc1 a = Desc1 P.String a
instance Desc a => Desc (Desc1 a) where
    dmp (Desc1 d v) = "{" P.++ d P.++ "} 1:(" P.++ dmp v P.++ ")"

data (Desc a, Desc b) => Desc2 a b = Desc2 P.String a b
instance (Desc a, Desc b) => Desc (Desc2 a b) where
    dmp (Desc2 d v1 v2) = "{" P.++ d P.++ "} 1:(" P.++ dmp v1 P.++
        ") 2:(" P.++ dmp v2 P.++ ")"

data (Desc a, Desc b, Desc c) => Desc3 a b c = Desc3 P.String a b c
instance (Desc a, Desc b, Desc c) => Desc (Desc3 a b c) where
    dmp (Desc3 d v1 v2 v3) = "{" P.++ d P.++ "} 1:(" P.++ dmp v1 P.++
        ") 2:(" P.++ dmp v2 P.++ ") 3:(" P.++ dmp v3 P.++ ")"

data P.Show a => Val a = forall b. Desc b => Val (Mb.Maybe a) b
instance P.Show a => Desc (Val a) where
    dmp (Val (P.Just v) d) = P.show v P.++ " [" P.++ dmp d P.++ "]"
    dmp (Val (P.Nothing) d) = "??? [" P.++ dmp d P.++ "]"

lift0 :: P.Show a => P.String -> a -> Val a
lift0 desc v = Val (M.return v) desc
lift1 :: (P.Show a, P.Show b) => P.String -> (a -> b) -> (Val a -> Val b)
lift1 desc f = \d@(Val v _) -> Val ((M.liftM f) v) (Desc1 desc d)
lift2 :: (P.Show a, P.Show b, P.Show c) => P.String -> (a -> b -> c) ->
    (Val a -> Val b -> Val c)
lift2 desc f = \d1@(Val v1 _) d2@(Val v2 _) -> Val ((M.liftM2 f) v1 v2)
    (Desc2 desc d1 d2)
lift3 :: (P.Show a, P.Show b, P.Show c, P.Show d) => P.String ->
    (a -> b -> c -> d) -> (Val a -> Val b -> Val c -> Val d)
lift3 desc f = \d1@(Val v1 _) d2@(Val v2 _) d3@(Val v3 _) -> Val
    ((M.liftM3 f) v1 v2 v3) (Desc3 desc d1 d2 d3)
(|--) :: P.Show a => P.String -> a -> Val a
(|--) = lift0
desc |- d@(Val v _) = Val v (Desc1 desc d)

neg = lift1 "-" P.negate
(+) = lift2 "+" (P.+)
(-) = lift2 "-" (P.-)
(*) = lift2 "*" (P.*)
(/) = lift2 "/" (P./)
(//) = lift2 "/" P.div
(\\) = lift2 "modulo" P.mod
(==) :: (P.Show a, P.Eq a) => Val a -> Val a -> Val P.Bool
(==) = lift2 "equals" (P.==)

{-
branch' :: P.Bool -> a -> a -> a
branch' p x y = if p then x else y
-}
branch :: P.Show a => Val P.Bool -> Val a -> Val a -> Val a
{-
branch = lift3 "if .. then .. else" branch'
-}
branch d1@(Val (P.Just P.True) _) d2@(Val v _) d3 = Val v
    (Desc3 "if .. then .. else" d1 d2 d3)
branch d1@(Val (P.Just P.False) _) d2 d3@(Val v _) = Val v
    (Desc3 "if .. then .. else" d1 d2 d3)
branch d1@(Val P.Nothing _) d2 d3 = Val P.Nothing
    (Desc3 "if .. then .. else" d1 d2 d3)

data Id a = Id a
w :: Id a -> a
w (Id x) = x
instance M.Monad Id where
    return = Id
    (>>=) = (P.flip (P.$)) P.. w

class Rdc a b where
    rdc :: a -> b
instance P.Show a => Rdc (Val a) (Val a) where
    rdc = P.id
instance (P.Show a, Rdc b c) => Rdc (Val a -> b) c where
    rdc x = rdc (x (Val P.Nothing ""))

-- eo boilerplate

k a b = w P.$ do
    let a' = "first parameter" |- a
    let b' = "second parameter" |- b
    let constValue = "some const value" |-- 1
    let c = "intermediate value" |- (a' + b')
    M.return (branch (a' == constValue) a' c)

k1 = k ("a" |-- 1) ("b" |-- 2)

k2 = k ("a" |-- 2) ("b" |-- 2)

k3 :: Val P.Integer
k3 = rdc P.$ k ("a" |-- 1)

k4 :: Val P.Integer
k4 = rdc P.$ (P.flip k) ("b" |-- 2)

k5 :: Val P.Integer
k5 = rdc k

main = M.mapM_ (P.print P.. dmp) [k1, k2, k3, k4, k5]
подопытная функция - k. ключевой мОмент - dmp k3. в общем, все это крайне няшно, но на практике пока неприменимо: хаскель такой хаскель етц.
Subscribe
  • Post a new comment

    Error

    default userpic

    Your reply will be screened

    Your IP address will be recorded 

    When you submit the form an invisible reCAPTCHA check will be performed.
    You must follow the Privacy Policy and Google Terms of use.
  • 0 comments