{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLabels #-}

module Language.Haskell.Codegen where

import Control.Lens
import Data.Generics.Labels ()
import Data.List
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Internal
import GHC.Generics

type Ann = Maybe Text

io :: Type
io :: Type
io = Text -> Type
Type "IO"

prettyDoc :: Ann -> Doc ann
prettyDoc :: Ann -> Doc ann
prettyDoc (Just d :: Text
d) =
  let ls :: [Text]
ls = Text -> [Text]
T.lines Text
d
      ds :: [Doc ann]
ds = (Text -> Doc ann) -> [Text] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines [Text]
ls
   in "-- |" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann
forall a. (a -> a -> a) -> [a] -> a
foldl1' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
(<>) (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
intersperse (Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> "--" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> "--") [Doc ann]
ds) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
prettyDoc Nothing = Doc ann
forall a. Monoid a => a
mempty

data ADT
  = ADT
      { ADT -> Text
name :: Text,
        ADT -> Ann
ann :: Ann,
        ADT -> [Constr]
constr :: [Constr]
      }
  deriving (Int -> ADT -> ShowS
[ADT] -> ShowS
ADT -> String
(Int -> ADT -> ShowS)
-> (ADT -> String) -> ([ADT] -> ShowS) -> Show ADT
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ADT] -> ShowS
$cshowList :: [ADT] -> ShowS
show :: ADT -> String
$cshow :: ADT -> String
showsPrec :: Int -> ADT -> ShowS
$cshowsPrec :: Int -> ADT -> ShowS
Show, ADT -> ADT -> Bool
(ADT -> ADT -> Bool) -> (ADT -> ADT -> Bool) -> Eq ADT
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ADT -> ADT -> Bool
$c/= :: ADT -> ADT -> Bool
== :: ADT -> ADT -> Bool
$c== :: ADT -> ADT -> Bool
Eq, (forall x. ADT -> Rep ADT x)
-> (forall x. Rep ADT x -> ADT) -> Generic ADT
forall x. Rep ADT x -> ADT
forall x. ADT -> Rep ADT x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ADT x -> ADT
$cfrom :: forall x. ADT -> Rep ADT x
Generic)

constructors :: ADT -> Int
constructors :: ADT -> Int
constructors ADT {..} = [Constr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Constr]
constr

prettyConstrs :: [Doc ann] -> Doc ann
prettyConstrs :: [Doc ann] -> Doc ann
prettyConstrs [] = Doc ann
forall a. Monoid a => a
mempty
prettyConstrs (x :: Doc ann
x : xs :: [Doc ann]
xs) =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
    [ (Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann
forall a. (a -> a -> a) -> [a] -> a
foldl1' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
(<>) (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
intersperse (Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> "| ") (("=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
x) Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [Doc ann]
xs)),
      "deriving (Show, Eq, Generic)"
    ]

instance Pretty ADT where
  pretty :: ADT -> Doc ann
pretty ADT {..} =
    let doc :: Doc ann
doc = Ann -> Doc ann
forall ann. Ann -> Doc ann
prettyDoc Ann
ann
        n :: Doc ann
n = Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines Text
name
        cs :: [Doc ann]
cs = (Constr -> Doc ann) -> [Constr] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Constr -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Constr]
constr
     in Doc ann
doc
          Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
            [ "data" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
n,
              Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent 2 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
prettyConstrs [Doc ann]
cs)
            ]

-- >>> pretty $ ADT "A" (Just "A") [Constr "A" Nothing [("a", Type "A"), ("b", Type "A")], Constr "B" Nothing []]

data Field
  = Field
      { Field -> Text
name :: Text,
        Field -> Ann
ann :: Ann,
        Field -> Type
ty :: Type
      }
  deriving (Int -> Field -> ShowS
[Field] -> ShowS
Field -> String
(Int -> Field -> ShowS)
-> (Field -> String) -> ([Field] -> ShowS) -> Show Field
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Field] -> ShowS
$cshowList :: [Field] -> ShowS
show :: Field -> String
$cshow :: Field -> String
showsPrec :: Int -> Field -> ShowS
$cshowsPrec :: Int -> Field -> ShowS
Show, Field -> Field -> Bool
(Field -> Field -> Bool) -> (Field -> Field -> Bool) -> Eq Field
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Field -> Field -> Bool
$c/= :: Field -> Field -> Bool
== :: Field -> Field -> Bool
$c== :: Field -> Field -> Bool
Eq, (forall x. Field -> Rep Field x)
-> (forall x. Rep Field x -> Field) -> Generic Field
forall x. Rep Field x -> Field
forall x. Field -> Rep Field x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Field x -> Field
$cfrom :: forall x. Field -> Rep Field x
Generic)

warpM :: Type -> Type
warpM :: Type -> Type
warpM (App (Type "[]") t' :: Type
t') = Type -> Type -> Type
App (Text -> Type
Type "[]") (Type -> Type
warpM Type
t')
warpM t :: Type
t = Type -> Type -> Type
App (Text -> Type
Type "Maybe") Type
t

instance Pretty Field where
  pretty :: Field -> Doc ann
pretty Field {..} =
    Ann -> Doc ann
forall ann. Ann -> Doc ann
prettyDoc Ann
ann
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines Text
name Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "::" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
ty

data Constr
  = Constr
      { Constr -> Text
name :: Text,
        Constr -> Ann
ann :: Ann,
        Constr -> [Field]
fields :: [Field]
      }
  deriving (Int -> Constr -> ShowS
[Constr] -> ShowS
Constr -> String
(Int -> Constr -> ShowS)
-> (Constr -> String) -> ([Constr] -> ShowS) -> Show Constr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Constr] -> ShowS
$cshowList :: [Constr] -> ShowS
show :: Constr -> String
$cshow :: Constr -> String
showsPrec :: Int -> Constr -> ShowS
$cshowsPrec :: Int -> Constr -> ShowS
Show, Constr -> Constr -> Bool
(Constr -> Constr -> Bool)
-> (Constr -> Constr -> Bool) -> Eq Constr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Constr -> Constr -> Bool
$c/= :: Constr -> Constr -> Bool
== :: Constr -> Constr -> Bool
$c== :: Constr -> Constr -> Bool
Eq, (forall x. Constr -> Rep Constr x)
-> (forall x. Rep Constr x -> Constr) -> Generic Constr
forall x. Rep Constr x -> Constr
forall x. Constr -> Rep Constr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Constr x -> Constr
$cfrom :: forall x. Constr -> Rep Constr x
Generic)

arity :: Constr -> Int
arity :: Constr -> Int
arity = [Field] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Field] -> Int) -> (Constr -> [Field]) -> Constr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constr -> [Field]
fields

instance Pretty Constr where
  pretty :: Constr -> Doc ann
pretty Constr {..} =
    let doc :: Doc ann
doc = Ann -> Doc ann
forall ann. Ann -> Doc ann
prettyDoc Ann
ann
        n :: Doc ann
n = Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines Text
name
        fs :: Doc ann
fs = (Doc ann -> Doc ann -> Doc ann) -> Doc ann -> [Doc ann] -> Doc ann
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
(<>) Doc ann
forall a. Monoid a => a
mempty (Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
intersperse ("," Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line) ((Field -> Doc ann) -> [Field] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Field -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Field]
fields))
     in Doc ann
doc
          Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
            [ Doc ann
n,
              Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent 2 ("{" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align Doc ann
fs Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> "}")
            ]

data Type
  = Type Text
  | Arr Type Type
  | App Type Type
  deriving (Int -> Type -> ShowS
[Type] -> ShowS
Type -> String
(Int -> Type -> ShowS)
-> (Type -> String) -> ([Type] -> ShowS) -> Show Type
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Type] -> ShowS
$cshowList :: [Type] -> ShowS
show :: Type -> String
$cshow :: Type -> String
showsPrec :: Int -> Type -> ShowS
$cshowsPrec :: Int -> Type -> ShowS
Show, Type -> Type -> Bool
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq, (forall x. Type -> Rep Type x)
-> (forall x. Rep Type x -> Type) -> Generic Type
forall x. Rep Type x -> Type
forall x. Type -> Rep Type x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Type x -> Type
$cfrom :: forall x. Type -> Rep Type x
Generic)

instance Pretty Type where
  pretty :: Type -> Doc ann
pretty (Type t :: Text
t) = Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines Text
t
  pretty (Arr ty :: Type
ty ty' :: Type
ty') = Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
ty Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "->" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
ty'
  pretty (App (Type "[]") ty :: Type
ty) = "[" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
ty Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> "]"
  pretty (App tyCon :: Type
tyCon ty :: Type
ty) = "(" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
tyCon Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ")" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "(" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
ty Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ")"

data TypeSig
  = Result
      { TypeSig -> Type
ty :: Type,
        TypeSig -> Ann
ann :: Ann
      }
  | Conn
      { ty :: Type,
        ann :: Ann,
        TypeSig -> TypeSig
res :: TypeSig
      }
  deriving (Int -> TypeSig -> ShowS
[TypeSig] -> ShowS
TypeSig -> String
(Int -> TypeSig -> ShowS)
-> (TypeSig -> String) -> ([TypeSig] -> ShowS) -> Show TypeSig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeSig] -> ShowS
$cshowList :: [TypeSig] -> ShowS
show :: TypeSig -> String
$cshow :: TypeSig -> String
showsPrec :: Int -> TypeSig -> ShowS
$cshowsPrec :: Int -> TypeSig -> ShowS
Show, TypeSig -> TypeSig -> Bool
(TypeSig -> TypeSig -> Bool)
-> (TypeSig -> TypeSig -> Bool) -> Eq TypeSig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeSig -> TypeSig -> Bool
$c/= :: TypeSig -> TypeSig -> Bool
== :: TypeSig -> TypeSig -> Bool
$c== :: TypeSig -> TypeSig -> Bool
Eq, (forall x. TypeSig -> Rep TypeSig x)
-> (forall x. Rep TypeSig x -> TypeSig) -> Generic TypeSig
forall x. Rep TypeSig x -> TypeSig
forall x. TypeSig -> Rep TypeSig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TypeSig x -> TypeSig
$cfrom :: forall x. TypeSig -> Rep TypeSig x
Generic)

instance Pretty TypeSig where
  pretty :: TypeSig -> Doc ann
pretty (Result ty :: Type
ty doc :: Ann
doc) =
    Ann -> Doc ann
forall ann. Ann -> Doc ann
prettyDoc Ann
doc Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> "Sem r" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "(" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> "Error ∪" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
ty Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ")"
  pretty (Conn ty :: Type
ty doc :: Ann
doc res :: TypeSig
res) =
    Ann -> Doc ann
forall ann. Ann -> Doc ann
prettyDoc Ann
doc
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
        [ Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
ty Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "->",
          TypeSig -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TypeSig
res
        ]

type Annotated = (Type, Ann)

formArr :: [Annotated] -> Annotated -> TypeSig
formArr :: [Annotated] -> Annotated -> TypeSig
formArr [] (ty :: Type
ty, ann :: Ann
ann) = Type -> Ann -> TypeSig
Result Type
ty Ann
ann
formArr ((ty :: Type
ty, ann :: Ann
ann) : xs :: [Annotated]
xs) a :: Annotated
a = Type -> Ann -> TypeSig -> TypeSig
Conn Type
ty Ann
ann ([Annotated] -> Annotated -> TypeSig
formArr [Annotated]
xs Annotated
a)

data FunDef
  = FunDef
      { FunDef -> Text
name :: Text,
        FunDef -> Ann
ann :: Ann,
        FunDef -> Constr
constr :: Constr,
        FunDef -> Type
res :: Type
      }
  deriving (Int -> FunDef -> ShowS
[FunDef] -> ShowS
FunDef -> String
(Int -> FunDef -> ShowS)
-> (FunDef -> String) -> ([FunDef] -> ShowS) -> Show FunDef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FunDef] -> ShowS
$cshowList :: [FunDef] -> ShowS
show :: FunDef -> String
$cshow :: FunDef -> String
showsPrec :: Int -> FunDef -> ShowS
$cshowsPrec :: Int -> FunDef -> ShowS
Show, FunDef -> FunDef -> Bool
(FunDef -> FunDef -> Bool)
-> (FunDef -> FunDef -> Bool) -> Eq FunDef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FunDef -> FunDef -> Bool
$c/= :: FunDef -> FunDef -> Bool
== :: FunDef -> FunDef -> Bool
$c== :: FunDef -> FunDef -> Bool
Eq, (forall x. FunDef -> Rep FunDef x)
-> (forall x. Rep FunDef x -> FunDef) -> Generic FunDef
forall x. Rep FunDef x -> FunDef
forall x. FunDef -> Rep FunDef x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FunDef x -> FunDef
$cfrom :: forall x. FunDef -> Rep FunDef x
Generic)

getAnn :: Field -> Annotated
getAnn :: Field -> Annotated
getAnn Field {..} = (Type
ty, Ann
ann)

flattenSig :: FunDef -> Doc ann
flattenSig :: FunDef -> Doc ann
flattenSig FunDef {..} =
  let n :: Doc ann
n = Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines Text
name
      doc :: Doc ann
doc = Ann -> Doc ann
forall ann. Ann -> Doc ann
prettyDoc Ann
ann
      sig :: Doc ann
sig = TypeSig -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (TypeSig -> Doc ann) -> TypeSig -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Annotated] -> Annotated -> TypeSig
formArr ((Field -> Annotated) -> [Field] -> [Annotated]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Field -> Annotated
getAnn (Constr -> [Field]
fields Constr
constr)) (Type
res, Ann
forall a. Maybe a
Nothing)
   in [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ann
doc Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
n Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "::",
          Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent 2 "Member TDLib r =>",
          Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent 2 Doc ann
sig
        ]

vars :: Int -> Doc ann
vars :: Int -> Doc ann
vars i :: Int
i = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Int -> Doc ann) -> [Int] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Doc ann
forall a. IsString a => String -> a
fromString (String -> Doc ann) -> (Int -> String) -> Int -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (Int -> String) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [1 .. Int
i]

flattenBody :: FunDef -> Doc ann
flattenBody :: FunDef -> Doc ann
flattenBody FunDef {..} =
  let n :: Doc ann
n = Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines Text
name
      c :: Doc ann
c = Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines (Constr
constr Constr -> Getting Text Constr Text -> Text
forall s a. s -> Getting a s a -> a
^. IsLabel "name" (Getting Text Constr Text)
Getting Text Constr Text
#name)
      ar :: Int
ar = Constr -> Int
arity Constr
constr
      v :: Doc ann
v = Int -> Doc ann
forall ann. Int -> Doc ann
vars Int
ar
   in [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
n, Doc ann
v, "=", "runCmd $", Doc ann
c, Doc ann
v]

flattenPrint :: FunDef -> Doc ann
flattenPrint :: FunDef -> Doc ann
flattenPrint def :: FunDef
def =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
    [ FunDef -> Doc ann
forall ann. FunDef -> Doc ann
flattenSig FunDef
def,
      FunDef -> Doc ann
forall ann. FunDef -> Doc ann
flattenBody FunDef
def
    ]

simplePretty :: FunDef -> Doc ann
simplePretty :: FunDef -> Doc ann
simplePretty FunDef {..} =
  let doc :: Doc ann
doc = Ann -> Doc ann
forall ann. Ann -> Doc ann
prettyDoc Ann
ann
      n :: Doc ann
n = Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines Text
name
      cmd :: Doc ann
cmd = Text -> Doc ann
forall ann. Text -> Doc ann
unsafeTextWithoutNewlines (Constr
constr Constr -> Getting Text Constr Text -> Text
forall s a. s -> Getting a s a -> a
^. IsLabel "name" (Getting Text Constr Text)
Getting Text Constr Text
#name)
      resTy :: Doc ann
resTy = Type -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Type
res
   in Doc ann
doc
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
          [ Doc ann
n Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "::" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "Member TDLib r" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "=>" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
cmd Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "->" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "Sem r (Error ∪ " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
resTy Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ")",
            Doc ann
n Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> "runCmd"
          ]

instance Pretty FunDef where
  pretty :: FunDef -> Doc ann
pretty d :: FunDef
d@FunDef {..} = FunDef -> Doc ann
forall ann. FunDef -> Doc ann
flattenPrint FunDef
d