{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeAbstractions #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module TypedSession.State.GenDoc where

import qualified Data.List as L
import qualified Data.Set as Set
import Prettyprinter
import Prettyprinter.Render.String (renderString)
import TypedSession.State.Piple
import TypedSession.State.Render
import TypedSession.State.Type (Creat, Protocol, ProtocolError)

genRole :: forall r ann. (Enum r, Bounded r, Show r) => String -> Doc ann
genRole :: forall r ann. (Enum r, Bounded r, Show r) => String -> Doc ann
genRole String
rname =
  let rg :: [r]
rg = forall r. (Enum r, Bounded r) => [r]
rRange @r
      sRole :: Doc ann
sRole = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"S" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
rname)
      header :: Doc ann
header = Doc ann
"data" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
sRole Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"::" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
rname Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"-> Type where"
   in [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
        [ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
header Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [(String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"S" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> r -> String
forall a. Show a => a -> String
show r
r) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"::" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
sRole Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (r -> String
forall a. Show a => a -> String
show r
r)) | r
r <- [r]
rg]
        , Doc ann
"type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"instance" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"Sing" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
sRole
        ]
        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] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
          [ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest
              Int
2
              ( [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
                  [ Doc ann
"instance" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"SingI" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (r -> String
forall a. Show a => a -> String
show r
r) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
" where"
                  , Doc ann
"sing" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"S" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> r -> String
forall a. Show a => a -> String
show r
r)
                  ]
              )
          | r
r <- [r]
rg
          ]
        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
<> ( Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
              [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
                [ Doc ann
"instance SingToInt" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
rname Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"where"
                , Doc ann
"singToInt x = I# (dataToTag# x)"
                ]
           )

genSt :: forall r bst ann. String -> String -> PipleResult r bst -> Doc ann
genSt :: forall r bst ann. String -> String -> PipleResult r bst -> Doc ann
genSt String
protName String
bstName (PipleResult{Set Int
dnySet :: Set Int
dnySet :: forall r bst. PipleResult r bst -> Set Int
dnySet, stBound :: forall r bst. PipleResult r bst -> (Int, Int)
stBound = (Int
start, Int
end)}) =
  let
    protNameSt :: String
protNameSt = String
protName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"St"
    sProtNameSt :: String
sProtNameSt = String
"S" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
protName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"St"
    protSt :: Doc ann
protSt =
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
          [Doc ann
"data" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
protNameSt]
            [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ [ if
                  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 -> Doc ann
"= End"
                  | Int
i Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
dnySet -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"| S" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
bstName
                  | Bool
otherwise -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"| S" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
               | Int
i <- [Int
start .. Int
end]
               ]
    protSSt :: Doc ann
protSSt =
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
          [Doc ann
"data" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
sProtNameSt Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"::" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
protNameSt Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"-> Type where"]
            [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ [ if
                  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 -> Doc ann
"SEnd ::" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
sProtNameSt Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"End"
                  | Int
i Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
dnySet -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"SS" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ::") Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
sProtNameSt Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"(S" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" s)")
                  | Bool
otherwise -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"SS" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ::") Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
sProtNameSt Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"S" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)
               | Int
i <- [Int
start .. Int
end]
               ]
    instVal :: Int -> Doc ann
instVal Int
i =
      Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
          [ Doc ann
"instance SingI"
              Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ( if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1
                      then Doc ann
"End"
                      else
                        if Int
i
                          Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
dnySet
                          then Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"S" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" s")
                          else String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"S" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)
                  )
              Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"where"
          , Doc ann
"sing =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 then Doc ann
"SEnd" else String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
"SS" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)
          ]
    instVals :: Doc ann
instVals = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Int -> Doc ann
instVal Int
i | Int
i <- [Int
start .. Int
end]]
    stoInt :: Doc ann
stoInt =
      ( Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
          [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
            [ Doc ann
"instance SingToInt" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
protNameSt Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"where"
            , Doc ann
"singToInt x = I# (dataToTag# x)"
            ]
      )
   in
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
      [ Doc ann
protSt
      , Doc ann
protSSt
      , Doc ann
"type instance Sing =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
sProtNameSt
      , Doc ann
instVals
      , Doc ann
stoInt
      ]

genProtIns :: forall r bst ann. (Enum r, Bounded r, Show bst, Show r) => String -> String -> PipleResult r bst -> Doc ann
genProtIns :: forall r bst ann.
(Enum r, Bounded r, Show bst, Show r) =>
String -> String -> PipleResult r bst -> Doc ann
genProtIns String
roleName String
protName PipleResult{Protocol (MsgT1 r bst) r bst
msgT1 :: Protocol (MsgT1 r bst) r bst
msgT1 :: forall r bst. PipleResult r bst -> Protocol (MsgT1 r bst) r bst
msgT1} =
  let
    protNameSt :: String
protNameSt = String
protName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"St"
    typeDone :: [Doc ann]
typeDone = [Doc ann
"type Done" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (r -> String
forall a. Show a => a -> String
show r
r) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"= End" | r
r <- forall r. (Enum r, Bounded r) => [r]
rRange @r]
   in
    Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ann
"instance Protocol" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
roleName Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
protNameSt Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"where"
        , [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann]
typeDone
        , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
            [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
              [ Doc ann
"data Msg" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
roleName Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
protNameSt Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"from send recv where"
              , [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep (String -> String -> Protocol (MsgT1 r bst) r bst -> [Doc ann]
forall r bst ann.
(Show r, Show bst) =>
String -> String -> Protocol (MsgT1 r bst) r bst -> [Doc ann]
genDoc String
roleName String
protName Protocol (MsgT1 r bst) r bst
msgT1)
              ]
        ]

genGraph :: (Enum r, Bounded r, Show bst, Ord r, Show r) => StrFillEnv -> PipleResult r bst -> String
genGraph :: forall r bst.
(Enum r, Bounded r, Show bst, Ord r, Show r) =>
StrFillEnv -> PipleResult r bst -> String
genGraph StrFillEnv
sfe PipleResult{Protocol (MsgT r bst) r bst
msgT :: Protocol (MsgT r bst) r bst
msgT :: forall r bst. PipleResult r bst -> Protocol (MsgT r bst) r bst
msgT} = StrFillEnv
-> XStringFill (MsgT r bst) r bst
-> Protocol (MsgT r bst) r bst
-> String
forall r eta bst.
(ForallX Show eta, Show bst, Enum r, Bounded r, Show r) =>
StrFillEnv -> XStringFill eta r bst -> Protocol eta r bst -> String
runRender StrFillEnv
sfe (StrFillEnv -> XStringFill (MsgT r bst) r bst
forall r bst.
(Show bst, Ord r, Enum r, Bounded r) =>
StrFillEnv -> XStringFill (MsgT r bst) r bst
stMsgT StrFillEnv
sfe) Protocol (MsgT r bst) r bst
msgT

genAllDoc'
  :: forall r bst ann
   . (Enum r, Bounded r, Ord r, Show r, Show bst)
  => StrFillEnv
  -> Protocol Creat r bst
  -> String -- role name
  -> String -- protocol name
  -> String -- bst name
  -> [String] -- module Name
  -> Either (ProtocolError r bst) (Doc ann)
genAllDoc' :: forall r bst ann.
(Enum r, Bounded r, Ord r, Show r, Show bst) =>
StrFillEnv
-> Protocol Creat r bst
-> String
-> String
-> String
-> [String]
-> Either (ProtocolError r bst) (Doc ann)
genAllDoc' StrFillEnv
sfe Protocol Creat r bst
prot String
rName String
pName String
bstName [String]
moduleNames = case Protocol Creat r bst
-> Either (ProtocolError r bst) (PipleResult r bst)
forall r bst.
(Enum r, Bounded r, Eq r, Ord r) =>
Protocol Creat r bst
-> Either (ProtocolError r bst) (PipleResult r bst)
piple Protocol Creat r bst
prot of
  Left ProtocolError r bst
e -> ProtocolError r bst -> Either (ProtocolError r bst) (Doc ann)
forall a b. a -> Either a b
Left ProtocolError r bst
e
  Right PipleResult r bst
pipResult1 ->
    Doc ann -> Either (ProtocolError r bst) (Doc ann)
forall a b. b -> Either a b
Right (Doc ann -> Either (ProtocolError r bst) (Doc ann))
-> Doc ann -> Either (ProtocolError r bst) (Doc ann)
forall a b. (a -> b) -> a -> b
$
      [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ann
"{-# LANGUAGE DataKinds #-}"
        , Doc ann
"{-# LANGUAGE FlexibleInstances #-}"
        , Doc ann
"{-# LANGUAGE GADTs #-}"
        , Doc ann
"{-# LANGUAGE MagicHash #-}"
        , Doc ann
"{-# LANGUAGE MultiParamTypeClasses #-}"
        , Doc ann
"{-# LANGUAGE TypeFamilies #-}"
        , Doc ann
"module" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"." [String]
moduleNames) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"where"
        , Doc ann
"import Data.IFunctor (Sing, SingI (sing))"
        , Doc ann
"import Data.Kind"
        , Doc ann
"import GHC.Exts (dataToTag#)"
        , Doc ann
"import GHC.Int (Int (I#))"
        , Doc ann
"import TypedProtocol.Core"
        , Doc ann
"{-"
        , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ StrFillEnv -> PipleResult r bst -> String
forall r bst.
(Enum r, Bounded r, Show bst, Ord r, Show r) =>
StrFillEnv -> PipleResult r bst -> String
genGraph StrFillEnv
sfe PipleResult r bst
pipResult1
        , Doc ann
"-}"
        , forall r ann. (Enum r, Bounded r, Show r) => String -> Doc ann
genRole @r String
rName
        , String -> String -> PipleResult r bst -> Doc ann
forall r bst ann. String -> String -> PipleResult r bst -> Doc ann
genSt String
pName String
bstName PipleResult r bst
pipResult1
        , String -> String -> PipleResult r bst -> Doc ann
forall r bst ann.
(Enum r, Bounded r, Show bst, Show r) =>
String -> String -> PipleResult r bst -> Doc ann
genProtIns String
rName String
pName PipleResult r bst
pipResult1
        ]

genAllDoc
  :: forall r bst
   . (Enum r, Bounded r, Ord r, Show r, Show bst)
  => StrFillEnv
  -> Protocol Creat r bst
  -> String -- role name
  -> String -- protocol name
  -> String -- bst name
  -> [String] -- module names
  -> Either (ProtocolError r bst) String
genAllDoc :: forall r bst.
(Enum r, Bounded r, Ord r, Show r, Show bst) =>
StrFillEnv
-> Protocol Creat r bst
-> String
-> String
-> String
-> [String]
-> Either (ProtocolError r bst) String
genAllDoc StrFillEnv
sfe Protocol Creat r bst
a String
b String
c String
d [String]
e =
  SimpleDocStream Any -> String
forall ann. SimpleDocStream ann -> String
renderString (SimpleDocStream Any -> String)
-> (Doc Any -> SimpleDocStream Any) -> Doc Any -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions
    (Doc Any -> String)
-> Either (ProtocolError r bst) (Doc Any)
-> Either (ProtocolError r bst) String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrFillEnv
-> Protocol Creat r bst
-> String
-> String
-> String
-> [String]
-> Either (ProtocolError r bst) (Doc Any)
forall r bst ann.
(Enum r, Bounded r, Ord r, Show r, Show bst) =>
StrFillEnv
-> Protocol Creat r bst
-> String
-> String
-> String
-> [String]
-> Either (ProtocolError r bst) (Doc ann)
genAllDoc' StrFillEnv
sfe Protocol Creat r bst
a String
b String
c String
d [String]
e

genAllFile
  :: forall r bst
   . (Enum r, Bounded r, Ord r, Show r, Show bst)
  => StrFillEnv
  -> Protocol Creat r bst
  -> String -- role name
  -> String -- protocol name
  -> String -- bst name
  -> [String] -- module names
  -> IO ()
genAllFile :: forall r bst.
(Enum r, Bounded r, Ord r, Show r, Show bst) =>
StrFillEnv
-> Protocol Creat r bst
-> String
-> String
-> String
-> [String]
-> IO ()
genAllFile StrFillEnv
sfe Protocol Creat r bst
a String
b String
c String
d [String]
e = case StrFillEnv
-> Protocol Creat r bst
-> String
-> String
-> String
-> [String]
-> Either (ProtocolError r bst) String
forall r bst.
(Enum r, Bounded r, Ord r, Show r, Show bst) =>
StrFillEnv
-> Protocol Creat r bst
-> String
-> String
-> String
-> [String]
-> Either (ProtocolError r bst) String
genAllDoc StrFillEnv
sfe Protocol Creat r bst
a String
b String
c String
d [String]
e of
  Left ProtocolError r bst
er -> ProtocolError r bst -> IO ()
forall a. Show a => a -> IO ()
print ProtocolError r bst
er
  Right String
st -> do
    let name :: String
name = case [String]
e of
          [] -> String
"Type"
          [String]
xs -> [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
xs
    String -> String -> IO ()
writeFile String
name String
st