cli/Hcompta/Repr/Meta.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE InstanceSigs #-}
   5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE NamedFieldPuns #-}
   8 {-# LANGUAGE NoIncoherentInstances #-}
   9 {-# LANGUAGE NoMonomorphismRestriction #-}
  10 {-# LANGUAGE OverloadedLists #-}
  11 {-# LANGUAGE OverloadedStrings #-}
  12 {-# LANGUAGE ScopedTypeVariables #-}
  13 {-# LANGUAGE TupleSections #-}
  14 {-# LANGUAGE TypeFamilies #-}
  15 {-# LANGUAGE NoUndecidableInstances #-}
  16 {-# OPTIONS_GHC -fno-warn-tabs #-}
  17
  18 module Hcompta.Repr.Meta where
  19
  20 import Control.Applicative (Applicative(..))
  21 -- import Control.Exception.Safe (MonadThrow, MonadCatch, MonadMask)
  22 -- import qualified Control.Exception.Safe as Exn
  23 import Control.Monad (Monad(..))
  24 -- import qualified Control.Monad.Classes as MC
  25 -- import qualified Control.Monad.Classes.Write as MC
  26 import Control.Monad.IO.Class (MonadIO(..))
  27 -- import Control.Monad.Trans.Class
  28 -- import Control.Monad.Trans.State.Strict as ST
  29 import Data.Bool
  30 -- import Data.Either (Either(..))
  31 import Data.Eq (Eq(..))
  32 -- import Data.Foldable (asum)
  33 import Data.Function (($), (.))
  34 import Data.Functor (Functor(..))
  35 -- import Data.Int (Int)
  36 -- import qualified Data.List as List
  37 -- import Data.Maybe (Maybe(..), fromMaybe)
  38 -- import Data.Monoid ((<>))
  39 -- import Data.Ord (Ord(..))
  40 -- import Data.Text (Text)
  41 -- import qualified Data.Text as Text
  42 -- import Data.Text.Buildable (Buildable(..))
  43 -- import qualified Data.Text.Lazy.Builder as TL (Builder)
  44 -- import Prelude (pred, succ)
  45 -- import Text.Show (Show(..))
  46
  47 import Hcompta.Expr
  48 import Hcompta.Lib.Control.Monad
  49 -- import Hcompta.Lib.Data.Monoid (Monoid1)
  50 -- import Hcompta.Lib.Data.Text as Text
  51
  52 -- * Type 'Write'
  53
  54 -- | Meta-circular /tagless-final interpreter/,
  55 -- producing an Haskell term of type @h@.
  56 newtype Meta m h
  57  =      Meta
  58  {    unMeta :: m h }
  59  deriving (Applicative, Functor, Monad, MonadIO)
  60
  61 run :: Meta m h -> m h
  62 run = unMeta
  63
  64 instance Monad m => Expr_Lit (Meta m) where
  65         lit = Meta . return
  66 instance Monad m => Expr_Bool (Meta m) where
  67         and = liftM2Join $ \x y -> Meta $ return $ x && y
  68         or  = liftM2Join $ \x y -> Meta $ return $ x || y
  69         neg = liftMJoin  $ \x   -> Meta $ return $ not x
  70 instance Monad m => Expr_Eq (Meta m) where
  71         eq = liftM2Join $ \x y -> Meta $ return $ x == y
  72 instance MonadIO m => Expr_Fun (Meta m)