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)