]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/Expr/Fun.hs
Adapte hcompta-cli.
[comptalang.git] / cli / Hcompta / Expr / Fun.hs
1 {-# LANGUAGE DefaultSignatures #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE GADTs #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE NoImplicitPrelude #-}
7 -- {-# LANGUAGE PatternGuards #-}
8 {-# LANGUAGE Rank2Types #-}
9 {-# LANGUAGE ScopedTypeVariables #-}
10 {-# LANGUAGE OverloadedStrings #-}
11 {-# OPTIONS_GHC -fno-warn-tabs #-}
12 module Hcompta.Expr.Fun where
13
14 import Control.Monad (Monad(..))
15 import Control.Monad.IO.Class (MonadIO(..))
16 import Data.Bool
17 -- import Data.Either (Either(..))
18 -- import Data.Eq (Eq(..))
19 import Data.Function (($), (.), id)
20 import Data.IORef
21 -- import Data.Maybe (Maybe(..))
22 -- import Data.Monoid ((<>))
23 -- import Data.Proxy (Proxy(..))
24 -- import Data.String (String)
25 -- import Data.Type.Equality ((:~:)(Refl))
26 -- import Text.Show (Show(..))
27
28 import Hcompta.Expr.Dup
29
30 -- * Class 'Expr_Fun'
31
32 -- | /Tagless-final symantics/ for /lambda abstraction/
33 -- in /higher-order abstract syntax/ (HOAS),
34 -- and with argument @arg@ and result @res@ of functions @(->)@ inside 'repr',
35 -- wrapped into 'repr': to control the calling.
36 class Expr_Fun repr where
37 default app :: Monad repr => repr (repr arg -> repr res) -> repr arg -> repr res
38
39 default inline :: Monad repr => (repr arg -> repr res) -> repr (repr arg -> repr res)
40 default val :: Monad repr => (repr arg -> repr res) -> repr (repr arg -> repr res)
41 default lazy :: MonadIO repr => (repr arg -> repr res) -> repr (repr arg -> repr res)
42
43 default let_inline :: Monad repr => repr arg -> (repr arg -> repr res) -> repr res
44 default let_val :: Monad repr => repr arg -> (repr arg -> repr res) -> repr res
45 default let_lazy :: MonadIO repr => repr arg -> (repr arg -> repr res) -> repr res
46
47 app :: repr (repr arg -> repr res) -> repr arg -> repr res
48 app x y = x >>= ($ y)
49
50 -- | /call-by-name/ lambda
51 inline :: (repr arg -> repr res) -> repr (repr arg -> repr res)
52 inline = return
53 -- | /call-by-value/ lambda
54 val :: (repr arg -> repr res) -> repr (repr arg -> repr res)
55 val f = return (>>= f . return)
56 -- | /call-by-need/ lambda (aka. /lazyness/): lazy shares its argument, no matter what.
57 lazy :: (repr arg -> repr res) -> repr (repr arg -> repr res)
58 lazy f = return ((>>= f) . expr_fun_lazy_share)
59
60 -- | Convenient 'inline' wrapper.
61 let_inline :: repr arg -> (repr arg -> repr res) -> repr res
62 let_inline x y = inline y `app` x
63 -- | Convenient 'val' wrapper.
64 let_val :: repr arg -> (repr arg -> repr res) -> repr res
65 let_val x y = val y `app` x
66 -- | Convenient 'lazy' wrapper.
67 let_lazy :: repr arg -> (repr arg -> repr res) -> repr res
68 let_lazy x y = lazy y `app` x
69
70 ident :: repr a -> repr a
71 ident = id
72
73 -- | Utility for storing arguments of 'lazy' into an 'IORef'.
74 expr_fun_lazy_share :: MonadIO m => m a -> m (m a)
75 expr_fun_lazy_share m = do
76 r <- liftIO $ newIORef (False, m)
77 return $ do
78 (already_evaluated, m') <- liftIO $ readIORef r
79 if already_evaluated
80 then m'
81 else do
82 v <- m'
83 liftIO $ writeIORef r (True, return v)
84 return v
85
86 instance -- Expr_Fun Dup
87 ( Expr_Fun r1
88 , Expr_Fun r2
89 , Monad r1
90 , Monad r2
91 ) => Expr_Fun (Dup r1 r2) where
92 app (r1_f `Dup` r2_f) (x1 `Dup` x2) =
93 app (return $ \r1_a -> do
94 f <- r1_f
95 a <- r1_a
96 dup1 $ f (r1_a `Dup` return a)) x1
97 `Dup`
98 app (return $ \r2_a -> do
99 f <- r2_f
100 a <- r2_a
101 dup2 $ f (return a `Dup` r2_a)) x2
102 inline f = dup1 (inline f) `Dup` dup2 (inline f)
103 val f = dup1 (val f) `Dup` dup2 (val f)
104 lazy f = dup1 (lazy f) `Dup` dup2 (lazy f)
105 let_inline (x1 `Dup` x2) in_ =
106 let_inline x1 (\r1_a -> do
107 a <- r1_a
108 dup1 $ in_ $ r1_a `Dup` return a)
109 `Dup`
110 let_inline x2 (\r2_a -> do
111 a <- r2_a
112 dup2 $ in_ $ return a `Dup` r2_a)
113 let_val (x1 `Dup` x2) in_ =
114 let_val x1 (\r1_a -> do
115 a <- r1_a
116 dup1 $ in_ $ r1_a `Dup` return a)
117 `Dup`
118 let_val x2 (\r2_a -> do
119 a <- r2_a
120 dup2 $ in_ $ return a `Dup` r2_a)
121 let_lazy (x1 `Dup` x2) in_ =
122 let_lazy x1 (\r1_a -> do
123 a <- r1_a
124 dup1 $ in_ $ r1_a `Dup` return a)
125 `Dup`
126 let_lazy x2 (\r2_a -> do
127 a <- r2_a
128 dup2 $ in_ $ return a `Dup` r2_a)