{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | Interpreter to serialize an expression into a 'Text'. module Language.Symantic.Repr.Text where import Data.Monoid ((<>)) import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text import Language.Symantic.Expr -- * Type 'Repr_Text' -- | Interpreter's data. newtype Repr_Text (lam:: * -> *) h = Repr_Text { unRepr_Text -- Inherited attributes: :: Precedence -> Repr_Text_Lambda_Depth -- Synthetised attributes: -> Text } type Repr_Text_Lambda_Depth = Int -- | Interpreter. text_from_expr :: Repr_Text lam h -> Text text_from_expr r = unRepr_Text r precedence_Toplevel 0 {- instance Show (Repr_Text lam a) where show = text_from_expr -} type instance Lambda_from_Repr (Repr_Text lam) = lam instance Sym_Lambda_App lam (Repr_Text lam) where app (Repr_Text f) (Repr_Text x) = Repr_Text $ \p v -> let p' = precedence_App in paren p p' $ f p' v <> " " <> x p' v instance Sym_Lambda_Inline lam (Repr_Text lam) where inline = repr_text_fun "!" let_inline = repr_text_let "!" instance Sym_Lambda_Val lam (Repr_Text lam) where val = repr_text_fun "" let_val = repr_text_let "" instance Sym_Lambda_Lazy lam (Repr_Text lam) where lazy = repr_text_fun "~" let_lazy = repr_text_let "~" -- ** Helpers for 'Sym_Lambda' instances repr_text_fun :: Text -> (Repr_Text lam a2 -> Repr_Text lam a1) -> Repr_Text lam a repr_text_fun mode e = Repr_Text $ \p v -> let p' = precedence_Lambda in let x = "x" <> Text.pack (show v) in paren p p' $ "\\" <> mode <> x <> " -> " <> unRepr_Text (e (Repr_Text $ \_p _v -> x)) p' (succ v) repr_text_let :: Text -> Repr_Text lam a1 -> (Repr_Text lam a3 -> Repr_Text lam a2) -> Repr_Text lam a repr_text_let mode e in_ = Repr_Text $ \p v -> let p' = precedence_Let in let x = "x" <> Text.pack (show v) in paren p p' $ "let" <> mode <> " " <> x <> " = " <> unRepr_Text e p (succ v) <> " in " <> unRepr_Text (in_ (Repr_Text $ \_p _v -> x)) p (succ v) instance Sym_Bool (Repr_Text lam) where bool a = Repr_Text $ \_p _v -> Text.pack (show a) not (Repr_Text x) = Repr_Text $ \p v -> let p' = precedence_Not in paren p p' $ "!" <> x p' v (&&) (Repr_Text x) (Repr_Text y) = Repr_Text $ \p v -> let p' = precedence_And in paren p p' $ x p' v <> " && " <> y p' v (||) (Repr_Text x) (Repr_Text y) = Repr_Text $ \p v -> let p' = precedence_Or in paren p p' $ x p' v <> " || " <> y p' v xor (Repr_Text x) (Repr_Text y) = Repr_Text $ \p v -> let p' = precedence_Xor in paren p p' $ "xor " <> x p' v <> " " <> y p' v instance Sym_Int (Repr_Text lam) where int a = Repr_Text $ \_p _v -> Text.pack (show a) abs (Repr_Text x) = Repr_Text $ \p v -> let p' = precedence_App in paren p p' $ "abs " <> x p' v negate (Repr_Text x) = Repr_Text $ \p v -> let p' = precedence_Neg in paren p p' $ "-" <> x p' v (+) (Repr_Text x) (Repr_Text y) = Repr_Text $ \p v -> let p' = precedence_Add in paren p p' $ x p' v <> " + " <> y p' v (-) (Repr_Text x) (Repr_Text y) = Repr_Text $ \p v -> let p' = precedence_Sub in paren p p' $ x p' v <> " - " <> y p' v (*) (Repr_Text x) (Repr_Text y) = Repr_Text $ \p v -> let p' = precedence_Mul in paren p p' $ x p' v <> " * " <> y p' v mod (Repr_Text x) (Repr_Text y) = Repr_Text $ \p v -> let p' = precedence_Mod in paren p p' $ x p' v <> " % " <> y p' v instance Sym_Maybe (Repr_Text lam) where nothing = Repr_Text $ \_p _v -> "nothing" just (Repr_Text a) = Repr_Text $ \p v -> let p' = precedence_App in paren p p' $ "just " <> a (p') v instance Sym_Maybe_Lam lam (Repr_Text lam) where maybe (Repr_Text n) (Repr_Text j) (Repr_Text m) = Repr_Text $ \p v -> let p' = precedence_App in paren p p' $ "maybe" <> " " <> n p' v <> " " <> j p' v <> " " <> m p' v instance Sym_If (Repr_Text lam) where if_ (Repr_Text cond) (Repr_Text ok) (Repr_Text ko) = Repr_Text $ \p v -> let p' = precedence_If in paren p p' $ "if " <> cond p' v <> " then " <> ok p' v <> " else " <> ko p' v instance Sym_When (Repr_Text lam) where when (Repr_Text cond) (Repr_Text ok) = Repr_Text $ \p v -> let p' = precedence_If in paren p p' $ "when " <> cond p' v <> " " <> ok p' v instance Sym_Eq (Repr_Text lam) where (==) (Repr_Text x) (Repr_Text y) = Repr_Text $ \p v -> let p' = precedence_Eq in paren p p' $ x p' v <> " == " <> y p' v instance Sym_Ord (Repr_Text lam) where compare (Repr_Text x) (Repr_Text y) = Repr_Text $ \p v -> let p' = precedence_Eq in paren p p' $ "compare " <> x p' v <> " " <> y p' v instance Sym_List (Repr_Text lam) where list_empty = Repr_Text $ \_p _v -> "[]" list_cons (Repr_Text x) (Repr_Text xs) = Repr_Text $ \p v -> let p' = precedence_App in paren p p' $ x p' v <> ":" <> xs p' v list l = Repr_Text $ \_p v -> let p' = precedence_Toplevel in "[" <> Text.intercalate ", " ((\(Repr_Text a) -> a p' v) Prelude.<$> l) <> "]" instance Sym_List_Lam lam (Repr_Text lam) where list_filter (Repr_Text f) (Repr_Text l) = Repr_Text $ \p v -> let p' = precedence_App in paren p p' $ "list_filter " <> f p' v <> ":" <> l p' v instance Sym_Tuple2 (Repr_Text lam) where tuple2 (Repr_Text a) (Repr_Text b) = Repr_Text $ \_p v -> let p' = precedence_Toplevel in "(" <> a p' v <> ", " <> b p' v <> ")" instance Monad lam => Sym_Map (Repr_Text lam) where map_from_list (Repr_Text l) = Repr_Text $ \_p v -> let p' = precedence_App in "map_from_list " <> l p' v instance Monad lam => Sym_Map_Lam lam (Repr_Text lam) where map_map (Repr_Text f) (Repr_Text m) = Repr_Text $ \_p v -> let p' = precedence_App in "map_map " <> f p' v <> " " <> m p' v instance Monad lam => Sym_Functor lam (Repr_Text lam) where fmap (Repr_Text f) (Repr_Text m) = Repr_Text $ \_p v -> let p' = precedence_App in "fmap " <> f p' v <> " " <> m p' v instance (Sym_Applicative_Lam lam (Repr_Text lam), Applicative lam) => Sym_Applicative (Repr_Text lam) where pure (Repr_Text a) = Repr_Text $ \_p v -> let p' = precedence_App in "pure " <> a p' v instance Monad lam => Sym_Applicative_Lam lam (Repr_Text lam) where (<*>) (Repr_Text fg) (Repr_Text fa) = Repr_Text $ \p v -> let p' = precedence_LtStarGt in paren p p' $ fg p' v <> " <*> " <> fa p' v instance Monad lam => Sym_Traversable lam (Repr_Text lam) where traverse (Repr_Text g) (Repr_Text ta) = Repr_Text $ \p v -> let p' = precedence_App in paren p p' $ "traverse " <> g p' v <> " " <> ta p' v -- ** Type 'Precedence' newtype Precedence = Precedence Int deriving (Eq, Ord, Show) precedence_pred :: Precedence -> Precedence precedence_pred (Precedence p) = Precedence (pred p) precedence_succ :: Precedence -> Precedence precedence_succ (Precedence p) = Precedence (succ p) paren :: (Monoid s, IsString s) => Precedence -> Precedence -> s -> s paren prec prec' x = if prec >= prec' then fromString "(" <> x <> fromString ")" else x precedence_Toplevel :: Precedence precedence_Toplevel = Precedence 0 precedence_Lambda :: Precedence precedence_Lambda = Precedence 1 precedence_If :: Precedence precedence_If = Precedence 2 precedence_Let :: Precedence precedence_Let = Precedence 3 precedence_Eq :: Precedence precedence_Eq = Precedence 4 precedence_LtStarGt :: Precedence precedence_LtStarGt = precedence_Eq precedence_Or :: Precedence precedence_Or = Precedence 5 precedence_Xor :: Precedence precedence_Xor = precedence_Or precedence_And :: Precedence precedence_And = Precedence 6 precedence_Add :: Precedence precedence_Add = precedence_And precedence_Sub :: Precedence precedence_Sub = precedence_Add precedence_Mul :: Precedence precedence_Mul = Precedence 7 precedence_Mod :: Precedence precedence_Mod = precedence_Mul precedence_App :: Precedence precedence_App = Precedence 8 precedence_Not :: Precedence precedence_Not = Precedence 9 precedence_Neg :: Precedence precedence_Neg = precedence_Not precedence_Atomic :: Precedence precedence_Atomic = Precedence maxBound