cli/Hcompta/Expr/Lit.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# LANGUAGE MultiParamTypeClasses #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# OPTIONS_GHC -fno-warn-tabs #-}
   9 {-# OPTIONS_GHC -fno-warn-orphans #-}
  10 module Hcompta.Expr.Lit where
  11
  12 -- import Control.Applicative (Applicative(..))
  13 -- import Control.Monad (Monad(..))
  14 -- import Control.Monad.Trans.State.Strict as ST
  15 -- import Data.Bool
  16 -- import Data.Either (Either(..))
  17 -- import Data.Eq (Eq(..))
  18 -- import Data.Function (($), (.))
  19 -- import Data.Functor (Functor(..))
  20 -- import Data.Maybe (Maybe(..))
  21 -- import Data.Monoid ((<>))
  22 -- import Data.Proxy (Proxy(..))
  23 -- import Data.String (IsString(..))
  24 -- import Data.Text (Text)
  25 -- import qualified Data.Text as Text
  26 import Data.Text.Buildable (Buildable(..))
  27 -- import Data.Type.Equality ((:~:)(Refl))
  28 -- import GHC.Exts (IsList(..))
  29 -- import Prelude (undefined)
  30 -- import Text.Read (Read, reads)
  31 import Text.Show (Show(..))
  32
  33 -- import Hcompta.Lib.Control.Monad
  34 -- import qualified Hcompta.Lib.Control.Monad.Classes as MC
  35 -- import qualified Hcompta.Lib.Data.Text.Buildable as Build
  36
  37 import Hcompta.Expr.Dup
  38 -- import Hcompta.Expr.Fun
  39
  40 -- * Class 'Expr_Lit'
  41
  42 -- | /Tagless-final symantics/ to inject a meta-level term
  43 -- into and object-level expression.
  44 class Expr_Lit repr where
  45         lit :: (Buildable a, Show a) => a -> repr a
  46
  47 instance -- Expr_Lit Dup
  48  ( Expr_Lit r1
  49  , Expr_Lit r2
  50  ) => Expr_Lit (Dup r1 r2) where
  51         lit x = lit x `Dup` lit x
  52
  53 {-
  54 -- * Type 'Type_Lit'
  55
  56 -- | GADT for boolean type:
  57 --
  58 -- * singleton (bijective mapping between Haskell type @h@ and the GADT's terms),
  59 -- * and extensible (through @next@).
  60 data Type_Lit lit (next:: * -> *) h where
  61         Type_Lit      :: Type_Lit lit next lit
  62         Type_Lit_Next :: next h -> Type_Lit lit next h
  63 type Type_Fun_Lit lit repr next = Type_Fun repr (Type_Lit lit next)
  64 type Type_Fun_Lit_End lit repr = Type_Fun_Lit lit repr Type_Lit_End
  65
  66 instance -- Type_Eq
  67  Type_Eq next =>
  68  Type_Eq (Type_Lit lit next) where
  69         type_eq Type_Lit
  70                 Type_Lit = Just Refl
  71         type_eq (Type_Lit_Next x)
  72                 (Type_Lit_Next y) = x `type_eq` y
  73         type_eq _ _ = Nothing
  74 instance -- Type_from Tree
  75  ( Type_from Tree next
  76  , Buildable (Type_Lit_Name lit)
  77  ) => Type_from Tree (Type_Lit lit next) where
  78         type_from (Tree raw_lit []) k
  79          | raw_lit == Build.text (Type_Lit_Name::Type_Lit_Name lit)
  80          = k Type_Lit
  81         type_from raw k = type_from raw $ k . Type_Lit_Next
  82 instance -- From_Type Text
  83  ( From_Type Text next
  84  , Buildable (Type_Lit_Name lit)
  85  ) => From_Type Text (Type_Lit lit next) where
  86         from_type Type_Lit = Build.text (Type_Lit_Name::Type_Lit_Name lit)
  87         from_type (Type_Lit_Next t) = from_type t
  88 instance -- Expr_from Tree
  89  ( Expr_Lit repr
  90  , Type_from Tree next
  91  , Expr_from Tree repr next (Type_Fun_Lit lit repr next)
  92  , Read lit
  93  , Show lit
  94  , Buildable lit
  95  , Buildable (Type_Lit_Name lit)
  96  ) => Expr_from Tree repr (Type_Lit lit next) (Type_Fun_Lit lit repr next) where
  97         expr_from _pty _pvar _ctx (Tree lit_name [Tree raw_lit []]) k
  98          | lit_name == Build.text (Type_Lit_Name::Type_Lit_Name lit) = do
  99                 l <- repr_lit_read raw_lit
 100                 k (Type_Fun_Next Type_Lit) $ \_c -> lit l
 101         expr_from _pty pvar ctx raw k =
 102                 expr_from (Proxy::Proxy next) pvar ctx raw k
 103
 104 repr_lit_read :: Read a => Text -> Either Error_Type a
 105 repr_lit_read t =
 106         let s = Text.unpack t in
 107         case reads s of
 108          [(a, "")] -> Right a
 109          _         -> Left $ "Read error: " <> s
 110
 111 instance Monad m => Expr_Lit (ST.StateT s m) where
 112         lit = return
 113 instance Monad m => Expr_Lit (MC.WriterT w m) where
 114         lit = return
 115
 116 -- * Type 'Type_Lit_Name'
 117
 118 -- | Data type to get a name from a Haskell type-level literal type.
 119 data Type_Lit_Name lit = Type_Lit_Name
 120 instance Buildable (Type_Lit_Name Bool) where
 121         build _ = "Bool"
 122
 123 -- * Type 'Type_Lit_End'
 124
 125 -- | Data type to finalize a type at 'Type_Fun_Lit'.
 126 data Type_Lit_End h where
 127         Type_Lit_End :: Type_Lit_End ()
 128
 129 instance -- Type_Eq
 130  Type_Eq Type_Lit_End where
 131         type_eq Type_Lit_End
 132                 Type_Lit_End = Just Refl
 133 instance -- Type_from Tree
 134  Type_from Tree Type_Lit_End where
 135         type_from _ k = k Type_Lit_End
 136 instance -- Expr_from Tree
 137  Buildable (Type_Lit_Name lit)
 138  => Expr_from Tree repr Type_Lit_End (Type_Fun_Lit lit repr Type_Lit_End) where
 139         expr_from _pty _pvar _ctx raw _k =
 140                 Left $ "Error: invalid Type_Lit: "
 141                  <> Build.string (Type_Lit_Name::Type_Lit_Name lit) <> ": "
 142                  <> show raw
 143 -}
 144
 145 {-
 146 class Literal from to where
 147         literal :: from -> to
 148 instance Applicative repr => Literal a (repr a) where
 149         literal = pure
 150 instance (Applicative repr, IsString a) => Literal String (repr a) where
 151         literal = pure . fromString
 152 instance (Applicative repr, IsString a) => Literal [String] (repr [a]) where
 153         literal = pure . (fromString <$>)
 154 instance Applicative repr => Literal [a] (repr [a]) where
 155         literal = pure
 156 instance Monad repr => Literal [repr a] (repr [a]) where
 157         literal = sequence
 158 instance Literal a a where
 159         literal a = a
 160 -}
 161
 162 {-
 163 -- * Class 'List'
 164 class Monad repr => List repr where
 165         list :: [repr a] -> repr [a]
 166         list = sequence
 167 instance Monad m => List (ST.StateT s m)
 168 instance Monad m => List (WriterT w m)
 169
 170 instance (Monad m, Monad (repr m)) => List (repr (m:: * -> *)) where
 171         list = sequence
 172 -}
 173 -- instance IsList ([a])
 174
 175 {-
 176 -- Orphan instances for overloading
 177 instance (IsList a, List (repr m)) => IsList (repr (m:: * -> *) [a]) where
 178         type Item (repr m [a]) = repr m a
 179         fromList = list
 180         toList = undefined
 181 -}
 182
 183
 184 {- NOTE: conflicts with specific instance in Data.DList
 185 instance (IsList a, List repr) => IsList (repr [a]) where
 186         type Item (repr [a]) = repr a
 187         fromList = list
 188         toList = undefined
 189 -}
 190 {-
 191 instance (Monad repr, IsString a) => IsString (repr a) where
 192         fromString = return . fromString
 193 -}