Ры (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 

  • 0 comments