{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -- | Interpreter to serialize an expression into a 'String'. module Language.LOL.Symantic.Repr.String where import Data.Monoid ((<>)) import Data.String (IsString(..)) import Language.LOL.Symantic.Expr -- * Type 'Repr_String' -- | Interpreter's data. newtype Repr_String (lam:: * -> *) h = Repr_String { unRepr_String -- Inherited attributes: :: Precedence -> Repr_String_Lambda_Depth -- Synthetised attributes: -> String } type Repr_String_Lambda_Depth = Int -- | Interpreter. string_from_expr :: Repr_String lam h -> String string_from_expr r = unRepr_String r precedence_Toplevel 0 instance Show (Repr_String lam a) where show = string_from_expr instance Sym_Lambda lam (Repr_String lam) where type Lambda_from_Repr (Repr_String lam) = lam app (Repr_String f) (Repr_String x) = Repr_String $ \p v -> let p' = precedence_App in paren p p' $ f p' v <> " " <> x p' v inline = repr_string_fun "!" val = repr_string_fun "" lazy = repr_string_fun "~" let_inline = repr_string_let "!" let_val = repr_string_let "" let_lazy = repr_string_let "~" -- ** Helpers for 'Sym_Lambda' instances repr_string_fun :: String -> (Repr_String lam a2 -> Repr_String lam a1) -> Repr_String lam a repr_string_fun mode e = Repr_String $ \p v -> let p' = precedence_Lambda in let x = "x" <> show v in paren p p' $ "\\" <> mode <> x <> " -> " <> unRepr_String (e (Repr_String $ \_p _v -> x)) p' (succ v) repr_string_let :: String -> Repr_String lam a1 -> (Repr_String lam a3 -> Repr_String lam a2) -> Repr_String lam a repr_string_let mode e in_ = Repr_String $ \p v -> let p' = precedence_Let in let x = "x" <> show v in paren p p' $ "let" <> mode <> " " <> x <> " = " <> unRepr_String e p (succ v) <> " in " <> unRepr_String (in_ (Repr_String $ \_p _v -> x)) p (succ v) instance Sym_Bool (Repr_String lam) where bool a = Repr_String $ \_p _v -> show a not (Repr_String x) = Repr_String $ \p v -> let p' = precedence_Not in paren p p' $ "!" <> x (precedence_succ p') v and (Repr_String x) (Repr_String y) = Repr_String $ \p v -> let p' = precedence_And in paren p p' $ x p' v <> " & " <> y p' v or (Repr_String x) (Repr_String y) = Repr_String $ \p v -> let p' = precedence_Or in paren p p' $ x p' v <> " | " <> y p' v {-xor (Repr_String x) (Repr_String y) = Repr_String $ \p v -> let p' = precedence_Xor in paren p p' $ x p' v <> " * " <> y p' v -} instance Sym_Int (Repr_String lam) where int a = Repr_String $ \_p _v -> show a neg (Repr_String x) = Repr_String $ \p v -> let p' = precedence_Neg in paren p p' $ "-" <> x (precedence_succ p') v add (Repr_String x) (Repr_String y) = Repr_String $ \p v -> let p' = precedence_Add in paren p p' $ x p' v <> " + " <> y p' v instance Sym_Maybe lam (Repr_String lam) where maybe (Repr_String n) (Repr_String j) (Repr_String m) = Repr_String $ \p v -> let p' = precedence_Lambda in paren p p' $ "maybe " <> n (precedence_succ p') v <> j (precedence_succ p') v <> m (precedence_succ p') v instance Sym_Maybe_Cons (Repr_String lam) where nothing = Repr_String $ \_p _v -> "nothing" just (Repr_String a) = Repr_String $ \p v -> let p' = precedence_Lambda in paren p p' $ "just " <> a (precedence_succ p') v {- instance Sym_If Repr_String where if_ (Repr_String cond) (Repr_String ok) (Repr_String ko) = Repr_String $ \p v -> let p' = precedence_If in paren p p' $ "if " <> cond p' v <> " then " <> ok p' v <> " else " <> ko p' v when_ (Repr_String cond) (Repr_String ok) = Repr_String $ \p v -> let p' = precedence_If in paren p p' $ "when " <> cond p' v <> " " <> ok 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_Let :: Precedence precedence_Let = Precedence 2 precedence_If :: Precedence precedence_If = Precedence 3 precedence_Or :: Precedence precedence_Or = Precedence 4 precedence_Add :: Precedence precedence_Add = precedence_Or precedence_Xor :: Precedence precedence_Xor = Precedence 5 precedence_And :: Precedence precedence_And = Precedence 6 precedence_App :: Precedence precedence_App = Precedence 7 precedence_Not :: Precedence precedence_Not = Precedence 8 precedence_Neg :: Precedence precedence_Neg = precedence_Not precedence_Atomic :: Precedence precedence_Atomic = Precedence 9