cli/Hcompta/Repr/Text/Write.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.Text.Write where
  19
  20 import Data.Eq (Eq(..))
  21 import Data.Function (($), (.))
  22 import Data.Int (Int)
  23 import Data.Monoid ((<>))
  24 import Data.Ord (Ord(..))
  25 import Data.Text.Buildable (Buildable(..))
  26 import qualified Data.Text.Lazy as TL
  27 import qualified Data.Text.Lazy.Builder as TL
  28 import Prelude (pred, succ)
  29 import Text.Show (Show(..))
  30
  31 import Hcompta.Expr
  32
  33 -- * Type 'Repr_Text_Write'
  34
  35 -- | /Tagless-final interpreter/
  36 -- to evaluate an expression to a 'TL.Builder'.
  37 newtype Repr_Text_Write h
  38  =      Repr_Text_Write
  39  {    unRepr_Text_Write
  40         :: Precedence -> Var_Depth -- inherited attributes
  41         -> TL.Builder              -- synthetised attributes
  42  }
  43 {-
  44 data Write_Inh
  45  =   Write_Inh
  46  {   Write_Precedence :: Precedence
  47  ,   Write_Var_Depth  :: Var_Depth
  48  }
  49 data Write_Syn
  50  =   Write_Syn
  51  {   Write_Syn_Text :: TL.Builder
  52  }
  53 -}
  54 type Var_Depth = Int
  55
  56 repr_text_write :: Repr_Text_Write a -> TL.Builder
  57 repr_text_write x = unRepr_Text_Write x precedence_Toplevel 0
  58 instance Show (Repr_Text_Write a) where
  59         show = TL.unpack . TL.toLazyText . repr_text_write
  60
  61 instance Expr_Lit Repr_Text_Write where
  62         lit a = Repr_Text_Write $ \_p _v -> build a
  63 instance Expr_Bool Repr_Text_Write where
  64         and (Repr_Text_Write x) (Repr_Text_Write y) =
  65                 Repr_Text_Write $ \p v ->
  66                         let p' = precedence_And in
  67                         paren p p' $ x p' v <> " & " <> y p' v
  68         or (Repr_Text_Write x) (Repr_Text_Write y) =
  69                 Repr_Text_Write $ \p v ->
  70                         let p' = precedence_Or in
  71                         paren p p'  $ x p' v <> " | " <> y p' v
  72         neg (Repr_Text_Write x) =
  73                 Repr_Text_Write $ \p v ->
  74                         let p' = precedence_Neg in
  75                         paren p p' $ "!" <> x (precedence_succ p') v
  76 instance Expr_Fun Repr_Text_Write where
  77         app (Repr_Text_Write f) (Repr_Text_Write x) = Repr_Text_Write $ \p v ->
  78                 let p' = precedence_App in
  79                 paren p p' $
  80                 f p' v <> " " <> x p' v
  81         lazy       = repr_text_write_fun "~"
  82         val        = repr_text_write_fun ""
  83         inline     = repr_text_write_fun "!"
  84         let_lazy   = repr_text_write_let "~"
  85         let_val    = repr_text_write_let ""
  86         let_inline = repr_text_write_let "!"
  87
  88 -- ** Instance 'Fun' helpers
  89 repr_text_write_fun :: TL.Builder -> (Repr_Text_Write a2 -> Repr_Text_Write a1) -> Repr_Text_Write a
  90 repr_text_write_fun mode e =
  91         Repr_Text_Write $ \p v ->
  92                 let p' = precedence_Fun in
  93                 let x = "x" <> build v in
  94                 paren p p' $
  95                 "\\" <> mode <> x <> " -> " <>
  96                 unRepr_Text_Write (e (Repr_Text_Write $ \_p _v -> x)) p' (succ v)
  97 repr_text_write_let
  98  :: TL.Builder
  99  -> Repr_Text_Write a1
 100  -> (Repr_Text_Write a3 -> Repr_Text_Write a2)
 101  -> Repr_Text_Write a
 102 repr_text_write_let mode e in_ =
 103         Repr_Text_Write $ \p v ->
 104                 let p' = precedence_Let in
 105                 let x = "x" <> build v in
 106                 paren p p' $
 107                 "let" <> mode <> " " <> x <> " = " <> unRepr_Text_Write e p (succ v) <> " in " <>
 108                 unRepr_Text_Write (in_ (Repr_Text_Write $ \_p _v -> x)) p (succ v)
 109
 110 instance Expr_If Repr_Text_Write where
 111         if_
 112          (Repr_Text_Write cond)
 113          (Repr_Text_Write ok)
 114          (Repr_Text_Write ko) =
 115                 Repr_Text_Write $ \p v ->
 116                         let p' = precedence_If in
 117                         paren p p' $
 118                         "if " <> cond p' v <>
 119                         " then " <> ok p' v <>
 120                         " else " <> ko p' v
 121         when_ (Repr_Text_Write cond) (Repr_Text_Write ok) =
 122                 Repr_Text_Write $ \p v ->
 123                         let p' = precedence_If in
 124                         paren p p' $
 125                         "when " <> cond p' v <>
 126                         " " <> ok p' v
 127
 128 -- ** Type 'Precedence'
 129
 130 -- TODO: use an Enum?
 131 newtype Precedence = Precedence Int
 132  deriving (Eq, Ord, Show)
 133 precedence_pred :: Precedence -> Precedence
 134 precedence_pred (Precedence p) = Precedence (pred p)
 135 precedence_succ :: Precedence -> Precedence
 136 precedence_succ (Precedence p) = Precedence (succ p)
 137 paren :: Precedence -> Precedence -> TL.Builder -> TL.Builder
 138 paren prec prec' x =
 139         if prec >= prec'
 140          then "(" <> x <> ")"
 141          else x
 142
 143 precedence_Toplevel :: Precedence
 144 precedence_Toplevel  = Precedence 0
 145 precedence_Fun      :: Precedence
 146 precedence_Fun       = Precedence 1
 147 precedence_Let      :: Precedence
 148 precedence_Let       = Precedence 2
 149 precedence_If       :: Precedence
 150 precedence_If        = Precedence 3
 151 precedence_Or       :: Precedence
 152 precedence_Or        = Precedence 4
 153 precedence_And      :: Precedence
 154 precedence_And       = Precedence 5
 155 precedence_App      :: Precedence
 156 precedence_App       = Precedence 6
 157 precedence_Neg      :: Precedence
 158 precedence_Neg       = Precedence 7
 159 precedence_Atomic   :: Precedence
 160 precedence_Atomic    = Precedence 8