module Csound.Dynamic.Render.Pretty(
    Doc, vcatSep,
    ppCsdFile, ppGen, ppNotes, ppInstr, ppStmt, ppTotalDur,
    PrettyE(..), PrettyShowE(..),
    ppE
) where

import Control.Monad.Trans.State.Strict
import qualified Data.IntMap as IM

import Text.PrettyPrint.Leijen.Text
import Csound.Dynamic.Types
import Csound.Dynamic.Tfm.InferTypes qualified as R(Var(..))
import Data.Text (Text)
import Data.Text qualified as Text
import Text.Show.Pretty (ppShow)
import Data.Fix (foldFix)
import Data.ByteString.Base64 qualified as Base64
import Data.Text.Encoding qualified as Text

vcatSep :: [Doc] -> Doc
vcatSep :: [Doc] -> Doc
vcatSep = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
line

binaries, unaries :: Text -> [Doc] -> Doc

binaries :: Text -> [Doc] -> Doc
binaries Text
op [Doc]
as = Text -> Doc -> Doc -> Doc
binary Text
op ([Doc]
as [Doc] -> TabDepth -> Doc
forall a. HasCallStack => [a] -> TabDepth -> a
!! TabDepth
0) ([Doc]
as [Doc] -> TabDepth -> Doc
forall a. HasCallStack => [a] -> TabDepth -> a
!! TabDepth
1)
unaries :: Text -> [Doc] -> Doc
unaries  Text
op [Doc]
as = Text -> Doc -> Doc
unary  Text
op ([Doc]
as [Doc] -> TabDepth -> Doc
forall a. HasCallStack => [a] -> TabDepth -> a
!! TabDepth
0)

binary :: Text -> Doc -> Doc -> Doc
binary :: Text -> Doc -> Doc -> Doc
binary Text
op Doc
a Doc
b = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
a Doc -> Doc -> Doc
<+> Text -> Doc
textStrict Text
op Doc -> Doc -> Doc
<+> Doc
b

unary :: Text -> Doc -> Doc
unary :: Text -> Doc -> Doc
unary Text
op Doc
a = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
textStrict Text
op Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
a

func :: Text -> Doc -> Doc
func :: Text -> Doc -> Doc
func Text
op Doc
a = Text -> Doc
textStrict Text
op Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens Doc
a

ppCsdFile :: Doc -> Doc -> Doc -> [Plugin] -> Doc
ppCsdFile :: Doc -> Doc -> Doc -> [Plugin] -> Doc
ppCsdFile Doc
flags Doc
orc Doc
sco [Plugin]
plugins =
    Text -> Doc -> Doc
tag Text
"CsoundSynthesizer" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcatSep [
        Text -> Doc -> Doc
tag Text
"CsOptions" Doc
flags,
        Text -> Doc -> Doc
tag Text
"CsInstruments" Doc
orc,
        Text -> Doc -> Doc
tag Text
"CsScore" Doc
sco,
        [Plugin] -> Doc
ppPlugins [Plugin]
plugins
        ]

ppPlugins :: [Plugin] -> Doc
ppPlugins :: [Plugin] -> Doc
ppPlugins [Plugin]
plugins = [Doc] -> Doc
vcatSep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Plugin -> Doc) -> [Plugin] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Plugin Text
name Text
body) -> Text -> Doc -> Doc
tag Text
name (Text -> Doc
textStrict Text
body)) [Plugin]
plugins

tag :: Text -> Doc -> Doc
tag :: Text -> Doc -> Doc
tag Text
name Doc
content = [Doc] -> Doc
vcatSep [
    Char -> Doc
char Char
'<' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
textStrict Text
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Char -> Doc
char Char
'>',
    Doc
content,
    Text -> Doc
text Text
"</" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
textStrict Text
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Char -> Doc
char Char
'>']

ppNotes :: InstrId -> [CsdEvent] -> Doc
ppNotes :: InstrId -> [CsdEvent] -> Doc
ppNotes InstrId
instrId = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([CsdEvent] -> [Doc]) -> [CsdEvent] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CsdEvent -> Doc) -> [CsdEvent] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InstrId -> CsdEvent -> Doc
ppNote InstrId
instrId)

ppNote :: InstrId -> CsdEvent -> Doc
ppNote :: InstrId -> CsdEvent -> Doc
ppNote InstrId
instrId CsdEvent
evt = Char -> Doc
char Char
'i'
    Doc -> Doc -> Doc
<+> InstrId -> Doc
ppInstrId InstrId
instrId
    Doc -> Doc -> Doc
<+> Double -> Doc
double (CsdEvent -> Double
csdEventStart CsdEvent
evt) Doc -> Doc -> Doc
<+> Double -> Doc
double (CsdEvent -> Double
csdEventDur CsdEvent
evt)
    Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((Prim -> Doc) -> [Prim] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prim -> Doc
ppPrim ([Prim] -> [Doc]) -> [Prim] -> [Doc]
forall a b. (a -> b) -> a -> b
$ CsdEvent -> [Prim]
csdEventContent CsdEvent
evt)

ppPrim :: Prim -> Doc
ppPrim :: Prim -> Doc
ppPrim Prim
x = case Prim
x of
    P TabDepth
n -> Char -> Doc
char Char
'p' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> TabDepth -> Doc
int TabDepth
n
    PrimInstrId InstrId
a -> InstrId -> Doc
ppInstrId InstrId
a
    PString TabDepth
a -> TabDepth -> Doc
int TabDepth
a
    PrimInt TabDepth
n -> TabDepth -> Doc
int TabDepth
n
    PrimDouble Double
d -> Double -> Doc
double Double
d
    PrimString Text
s -> Doc -> Doc
dquotes (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
textStrict Text
s
    PrimVar Rate
targetRate Var
v -> Rate -> Rate -> Doc -> Doc
ppConverter Rate
targetRate (Var -> Rate
varRate Var
v) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Var -> Doc
ppVar Var
v
    where
        ppConverter :: Rate -> Rate -> Doc -> Doc
ppConverter Rate
dst Rate
src Doc
t
            | Rate
dst Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
src = Doc
t
            | Rate
dst Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Ar Bool -> Bool -> Bool
&& Rate
src Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Kr = Doc -> Doc
a(Doc
t)
            | Rate
dst Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Ar Bool -> Bool -> Bool
&& Rate
src Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Ir = Doc -> Doc
a(Doc -> Doc
k(Doc
t))
            | Rate
dst Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Kr  = Doc -> Doc
k(Doc
t)
            | Rate
dst Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Ir Bool -> Bool -> Bool
&& Rate
src Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Kr = Doc -> Doc
i(Doc
t)
            | Rate
dst Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Ir Bool -> Bool -> Bool
&& Rate
src Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Ar = Doc -> Doc
i(Doc -> Doc
k(Doc
t))
            | Bool
otherwise = Doc
t
            where
                tfm :: Char -> Doc -> Doc
tfm Char
ch Doc
v = [Doc] -> Doc
hcat [Char -> Doc
char Char
ch, Doc -> Doc
parens Doc
v]
                a :: Doc -> Doc
a = Char -> Doc -> Doc
tfm Char
'a'
                k :: Doc -> Doc
k = Char -> Doc -> Doc
tfm Char
'k'
                i :: Doc -> Doc
i = Char -> Doc -> Doc
tfm Char
'i'


ppGen :: Int -> Gen -> Doc
ppGen :: TabDepth -> Gen -> Doc
ppGen TabDepth
tabId Gen
ft = Char -> Doc
char Char
'f'
    Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>  TabDepth -> Doc
int TabDepth
tabId
    Doc -> Doc -> Doc
<+> TabDepth -> Doc
int TabDepth
0
    Doc -> Doc -> Doc
<+> (TabDepth -> Doc
int (TabDepth -> Doc) -> TabDepth -> Doc
forall a b. (a -> b) -> a -> b
$ Gen -> TabDepth
genSize Gen
ft)
    Doc -> Doc -> Doc
<+> (GenId -> Doc
ppGenId (GenId -> Doc) -> GenId -> Doc
forall a b. (a -> b) -> a -> b
$ Gen -> GenId
genId Gen
ft)
    Doc -> Doc -> Doc
<+> (Doc -> (Text -> Doc) -> Maybe Text -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty (Text -> Doc
textStrict (Text -> Doc) -> (Text -> Text) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack ([Char] -> Text) -> (Text -> [Char]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
forall a. Show a => a -> [Char]
show) (Maybe Text -> Doc) -> Maybe Text -> Doc
forall a b. (a -> b) -> a -> b
$ Gen -> Maybe Text
genFile Gen
ft)
    Doc -> Doc -> Doc
<+> ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Double -> Doc) -> [Double] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Double -> Doc
double ([Double] -> [Doc]) -> [Double] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Gen -> [Double]
genArgs Gen
ft)

ppGenId :: GenId -> Doc
ppGenId :: GenId -> Doc
ppGenId GenId
x = case GenId
x of
    IntGenId TabDepth
a      -> TabDepth -> Doc
int TabDepth
a
    StringGenId Text
a   -> Doc -> Doc
dquotes (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
textStrict Text
a

ppInstr :: InstrId -> Doc -> Doc
ppInstr :: InstrId -> Doc -> Doc
ppInstr InstrId
instrId Doc
body = [Doc] -> Doc
vcat [
    Text -> Doc
text Text
"instr" Doc -> Doc -> Doc
<+> InstrId -> Doc
ppInstrHeadId InstrId
instrId,
    Doc
body,
    Text -> Doc
text Text
"endin"]

ppInstrHeadId :: InstrId -> Doc
ppInstrHeadId :: InstrId -> Doc
ppInstrHeadId InstrId
x = case InstrId
x of
    InstrId Maybe TabDepth
den TabDepth
nom -> TabDepth -> Doc
int TabDepth
nom Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> (TabDepth -> Doc) -> Maybe TabDepth -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty TabDepth -> Doc
forall {a}. Show a => a -> Doc
ppAfterDot Maybe TabDepth
den
    InstrLabel Text
name -> Text -> Doc
textStrict Text
name
    where ppAfterDot :: a -> Doc
ppAfterDot a
a = Text -> Doc
textStrict (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ (Char
'.'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: ) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. Show a => a -> [Char]
show a
a

ppInstrId :: InstrId -> Doc
ppInstrId :: InstrId -> Doc
ppInstrId InstrId
x = case InstrId
x of
    InstrId Maybe TabDepth
den TabDepth
nom -> TabDepth -> Doc
int TabDepth
nom Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> (TabDepth -> Doc) -> Maybe TabDepth -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty TabDepth -> Doc
forall {a}. Show a => a -> Doc
ppAfterDot Maybe TabDepth
den
    InstrLabel Text
name -> Doc -> Doc
dquotes (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
textStrict Text
name
    where ppAfterDot :: a -> Doc
ppAfterDot a
a = Text -> Doc
textStrict (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ (Char
'.'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: ) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. Show a => a -> [Char]
show a
a

type TabDepth = Int

ppStmt :: [R.Var] -> Exp R.Var -> State TabDepth Doc
ppStmt :: [Var] -> Exp Var -> State TabDepth Doc
ppStmt [Var]
outs Exp Var
expr = State TabDepth Doc
-> (State TabDepth Doc -> State TabDepth Doc)
-> Maybe (State TabDepth Doc)
-> State TabDepth Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Doc -> Exp Var -> State TabDepth Doc
ppExp ([Var] -> Doc
ppOuts [Var]
outs) Exp Var
expr) State TabDepth Doc -> State TabDepth Doc
forall a. a -> a
id ([Var] -> Exp Var -> Maybe (State TabDepth Doc)
maybeStringCopy [Var]
outs Exp Var
expr)

maybeStringCopy :: [R.Var] -> Exp R.Var -> Maybe (State TabDepth Doc)
maybeStringCopy :: [Var] -> Exp Var -> Maybe (State TabDepth Doc)
maybeStringCopy [Var]
outs Exp Var
expr = case ([Var]
outs, Exp Var
expr) of
    ([R.Var Rate
Sr TabDepth
_], ExpPrim (PrimVar Rate
_rate Var
var)) -> State TabDepth Doc -> Maybe (State TabDepth Doc)
forall a. a -> Maybe a
Just (State TabDepth Doc -> Maybe (State TabDepth Doc))
-> State TabDepth Doc -> Maybe (State TabDepth Doc)
forall a b. (a -> b) -> a -> b
$ Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc
ppStringCopy ([Var] -> Doc
ppOuts [Var]
outs) (Var -> Doc
ppVar Var
var)
    ([R.Var Rate
Sr TabDepth
_], ReadVar Var
var) -> State TabDepth Doc -> Maybe (State TabDepth Doc)
forall a. a -> Maybe a
Just (State TabDepth Doc -> Maybe (State TabDepth Doc))
-> State TabDepth Doc -> Maybe (State TabDepth Doc)
forall a b. (a -> b) -> a -> b
$ Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc
ppStringCopy ([Var] -> Doc
ppOuts [Var]
outs) (Var -> Doc
ppVar Var
var)
    ([], WriteVar Var
outVar PrimOr Var
a) | Var -> Rate
varRate Var
outVar Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Sr  -> State TabDepth Doc -> Maybe (State TabDepth Doc)
forall a. a -> Maybe a
Just (State TabDepth Doc -> Maybe (State TabDepth Doc))
-> State TabDepth Doc -> Maybe (State TabDepth Doc)
forall a b. (a -> b) -> a -> b
$ Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc
ppStringCopy (Var -> Doc
ppVar Var
outVar) (PrimOr Var -> Doc
ppPrimOrVar PrimOr Var
a)
    ([R.Var Rate
Sr TabDepth
_], ReadArr Var
var ArrIndex (PrimOr Var)
as) -> State TabDepth Doc -> Maybe (State TabDepth Doc)
forall a. a -> Maybe a
Just (State TabDepth Doc -> Maybe (State TabDepth Doc))
-> State TabDepth Doc -> Maybe (State TabDepth Doc)
forall a b. (a -> b) -> a -> b
$ Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc
ppStringCopy ([Var] -> Doc
ppOuts [Var]
outs) (Var -> [Doc] -> Doc
ppReadArr Var
var ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (PrimOr Var -> Doc) -> ArrIndex (PrimOr Var) -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimOr Var -> Doc
ppPrimOrVar ArrIndex (PrimOr Var)
as)
    ([], WriteArr Var
outVar ArrIndex (PrimOr Var)
bs PrimOr Var
a) | Var -> Rate
varRate Var
outVar Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Sr -> State TabDepth Doc -> Maybe (State TabDepth Doc)
forall a. a -> Maybe a
Just (State TabDepth Doc -> Maybe (State TabDepth Doc))
-> State TabDepth Doc -> Maybe (State TabDepth Doc)
forall a b. (a -> b) -> a -> b
$ Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc
ppStringCopy (Var -> [Doc] -> Doc
ppArrIndex Var
outVar ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (PrimOr Var -> Doc) -> ArrIndex (PrimOr Var) -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimOr Var -> Doc
ppPrimOrVar ArrIndex (PrimOr Var)
bs) (PrimOr Var -> Doc
ppPrimOrVar PrimOr Var
a)
    ([Var], Exp Var)
_ -> Maybe (State TabDepth Doc)
forall a. Maybe a
Nothing

ppStringCopy :: Doc -> Doc -> Doc
ppStringCopy :: Doc -> Doc -> Doc
ppStringCopy Doc
outs Doc
src = Doc -> Text -> [Doc] -> Doc
ppOpc Doc
outs Text
"strcpyk" [Doc
src]

ppExp :: Doc -> Exp R.Var -> State TabDepth Doc
ppExp :: Doc -> Exp Var -> State TabDepth Doc
ppExp Doc
res Exp Var
expr = case (PrimOr Var -> Doc) -> Exp Var -> MainExp Doc
forall a b. (a -> b) -> MainExp a -> MainExp b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimOr Var -> Doc
ppPrimOrVar Exp Var
expr of
    ExpPrim (PString TabDepth
n)             -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> TabDepth -> Doc
ppStrget Doc
res TabDepth
n
    ExpPrim Prim
p                       -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc
res Doc -> Doc -> Doc
$= Prim -> Doc
ppPrim Prim
p
    Tfm Info
info [Doc
a, Doc
b] | Info -> Bool
isInfix  Info
info -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc
res Doc -> Doc -> Doc
$= Text -> Doc -> Doc -> Doc
binary (Info -> Text
infoName Info
info) Doc
a Doc
b
    Tfm Info
info [Doc]
xs     | Info -> Bool
isPrefix Info
info -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc
res Doc -> Doc -> Doc
$= Text -> [Doc] -> Doc
prefix (Info -> Text
infoName Info
info) [Doc]
xs
    Tfm Info
info [Doc]
xs                     -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Text -> [Doc] -> Doc
ppOpc Doc
res (Info -> Text
infoName Info
info) [Doc]
xs
    ConvertRate Rate
to Maybe Rate
from Doc
x           -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Rate -> Maybe Rate -> Doc -> Doc
ppConvertRate Doc
res Rate
to Maybe Rate
from Doc
x
    If IfRate
_ifRate CondInfo Doc
info Doc
t Doc
e             -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc -> Doc -> Doc
ppIf Doc
res (CondInfo Doc -> Doc
ppCond CondInfo Doc
info) Doc
t Doc
e
    ExpNum (PreInline NumOp
op [Doc]
as)        -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc
res Doc -> Doc -> Doc
$= NumOp -> [Doc] -> Doc
ppNumOp NumOp
op [Doc]
as
    WriteVar Var
v Doc
a                    -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Var -> Doc
ppVar Var
v Doc -> Doc -> Doc
$= Doc
a
    InitVar Var
v Doc
a                     -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Text -> [Doc] -> Doc
ppOpc (Var -> Doc
ppVar Var
v) Text
"init" [Doc
a]
    ReadVar Var
v                       -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc
res Doc -> Doc -> Doc
$= Var -> Doc
ppVar Var
v

    InitArr Var
v [Doc]
as                    -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Text -> [Doc] -> Doc
ppOpc (TabDepth -> Doc -> Doc
ppArrVar ([Doc] -> TabDepth
forall a. [a] -> TabDepth
forall (t :: * -> *) a. Foldable t => t a -> TabDepth
length [Doc]
as) (Var -> Doc
ppVar Var
v)) Text
"init" [Doc]
as
    ReadArr Var
v [Doc]
as                    -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ if (Var -> Rate
varRate Var
v Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
/= Rate
Sr) then Doc
res Doc -> Doc -> Doc
$= Var -> [Doc] -> Doc
ppReadArr Var
v [Doc]
as else Doc
res Doc -> Doc -> Doc
<+> Text -> Doc
text Text
"strcpy" Doc -> Doc -> Doc
<+> Var -> [Doc] -> Doc
ppReadArr Var
v [Doc]
as
    WriteArr Var
v [Doc]
as Doc
b                 -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Var -> [Doc] -> Doc -> Doc
ppWriteArr Var
v [Doc]
as Doc
b
    WriteInitArr Var
v [Doc]
as Doc
b             -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Var -> [Doc] -> Doc -> Doc
ppWriteInitArr Var
v [Doc]
as Doc
b
    TfmArr Bool
isInit Var
v Info
op [Doc
a,Doc
b]| Info -> Bool
isInfix  Info
op  -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Bool -> Var -> Doc
ppTfmArrOut Bool
isInit Var
v Doc -> Doc -> Doc
<+> Text -> Doc -> Doc -> Doc
binary (Info -> Text
infoName Info
op) Doc
a Doc
b
    TfmArr Bool
isInit Var
v Info
op [Doc]
args | Info -> Bool
isPrefix Info
op  -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Bool -> Var -> Doc
ppTfmArrOut Bool
isInit Var
v Doc -> Doc -> Doc
<+> Text -> [Doc] -> Doc
prefix (Info -> Text
infoName Info
op) [Doc]
args
    TfmArr Bool
isInit Var
v Info
op [Doc]
xs                  -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Text -> [Doc] -> Doc
ppOpc (Bool -> Var -> Doc
ppTfmArrOut Bool
isInit Var
v) (Info -> Text
infoName Info
op) [Doc]
xs

    InitPureArr Rate
_outRate IfRate
_procRate [Doc]
initVals -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Text -> [Doc] -> Doc
ppOpc (TabDepth -> Doc -> Doc
ppArrVar TabDepth
1 Doc
res) Text
"fillarray" [Doc]
initVals
    ReadPureArr Rate
outRate IfRate
_procRate Doc
arr Doc
index -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ if (Rate
outRate Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
/= Rate
Sr) then Doc
res Doc -> Doc -> Doc
$= Doc -> [Doc] -> Doc
ppReadPureArr Doc
arr [Doc
index] else Doc
res Doc -> Doc -> Doc
<+> Text -> Doc
text Text
"strcpy" Doc -> Doc -> Doc
<+> Doc -> [Doc] -> Doc
ppReadPureArr Doc
arr [Doc
index]

    IfBegin IfRate
_ CondInfo Doc
a                     -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
succTab          (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
"if "     Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> CondInfo Doc -> Doc
ppCond CondInfo Doc
a Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
text Text
" then"
    IfBlock IfRate
_ CondInfo Doc
cond (CodeBlock Doc
th) ->  Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc -> Doc
ppIf1 Doc
res (CondInfo Doc -> Doc
ppCond CondInfo Doc
cond)  Doc
th
    IfElseBlock IfRate
_ CondInfo Doc
cond (CodeBlock Doc
th) (CodeBlock Doc
el) -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc -> Doc -> Doc
ppIf Doc
res (CondInfo Doc -> Doc
ppCond CondInfo Doc
cond)  Doc
th Doc
el
--     ElseIfBegin a                   -> left >> (succTab $ text "elseif " <> ppCond a <> text " then")
    MainExp Doc
ElseBegin                       -> State TabDepth ()
left State TabDepth () -> State TabDepth Doc -> State TabDepth Doc
forall a b.
StateT TabDepth Identity a
-> StateT TabDepth Identity b -> StateT TabDepth Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
succTab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
"else")
    MainExp Doc
IfEnd                           -> State TabDepth ()
left State TabDepth () -> State TabDepth Doc -> State TabDepth Doc
forall a b.
StateT TabDepth Identity a
-> StateT TabDepth Identity b -> StateT TabDepth Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab     (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
"endif")
    UntilBlock IfRate
_ CondInfo Doc
cond (CodeBlock Doc
th) -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc -> Doc
ppUntil Doc
res (CondInfo Doc -> Doc
ppCond CondInfo Doc
cond)  Doc
th
    WhileBlock IfRate
_ CondInfo Doc
cond (CodeBlock Doc
th) -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc -> Doc
ppWhile Doc
res (CondInfo Doc -> Doc
ppCond CondInfo Doc
cond)  Doc
th
    WhileRefBlock Var
var (CodeBlock Doc
th) -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Var -> Doc -> Doc
ppWhileRef Doc
res Var
var Doc
th

    UntilBegin IfRate
_ CondInfo Doc
a                  -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
succTab          (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
"until " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> CondInfo Doc -> Doc
ppCond CondInfo Doc
a Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
text Text
" do"
    MainExp Doc
UntilEnd                        -> State TabDepth ()
left State TabDepth () -> State TabDepth Doc -> State TabDepth Doc
forall a b.
StateT TabDepth Identity a
-> StateT TabDepth Identity b -> StateT TabDepth Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab     (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
"od")
    WhileBegin IfRate
_ CondInfo Doc
a                  -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
succTab          (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
"while " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> CondInfo Doc -> Doc
ppCond CondInfo Doc
a Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
text Text
" do"
    WhileRefBegin Var
var               -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
succTab          (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
"while " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Var -> Doc
ppVar Var
var Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Text -> Doc
text Text
"1" Doc -> Doc -> Doc
<+> Text -> Doc
text Text
"do"
    MainExp Doc
WhileEnd                        -> State TabDepth ()
left State TabDepth () -> State TabDepth Doc -> State TabDepth Doc
forall a b.
StateT TabDepth Identity a
-> StateT TabDepth Identity b -> StateT TabDepth Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab     (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
"od")
    InitMacrosString Text
name Text
initValue -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc
initMacros (Text -> Doc
textStrict Text
name) (Text -> Doc
textStrict Text
initValue)
    InitMacrosDouble Text
name Double
initValue -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc
initMacros (Text -> Doc
textStrict Text
name) (Double -> Doc
double Double
initValue)
    InitMacrosInt Text
name TabDepth
initValue    -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc
initMacros (Text -> Doc
textStrict Text
name) (TabDepth -> Doc
int TabDepth
initValue)
    ReadMacrosString Text
name           -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc
res Doc -> Doc -> Doc
<+> Text -> Doc
text Text
"strcpy" Doc -> Doc -> Doc
<+> Text -> Doc
readMacro Text
name
    ReadMacrosDouble Text
name           -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc
res Doc -> Doc -> Doc
$= Text -> Doc
readMacro Text
name
    ReadMacrosInt Text
name              -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc
res Doc -> Doc -> Doc
$= Text -> Doc
readMacro Text
name
    MainExp Doc
EmptyExp                        -> Doc -> State TabDepth Doc
forall a. a -> StateT TabDepth Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
empty
    Verbatim Text
str                    -> Doc -> State TabDepth Doc
forall a. a -> StateT TabDepth Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
textStrict Text
str

    Select Rate
_rate TabDepth
_n Doc
a                 -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc
res Doc -> Doc -> Doc
$= (Doc
"SELECTS" Doc -> Doc -> Doc
<+> Doc
a)
    MainExp Doc
Starts                          -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc
res Doc -> Doc -> Doc
$= Doc
"STARTS"
    Seq Doc
a Doc
b                         -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep [Doc
"SEQ", Doc
a, Doc
b]
    Ends Doc
_a                          -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab (Doc -> State TabDepth Doc) -> Doc -> State TabDepth Doc
forall a b. (a -> b) -> a -> b
$ Doc
"ENDS"
    ExpBool BoolExp Doc
_                        -> Doc -> State TabDepth Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab Doc
"ExpBool"

    -- x -> error $ "unknown expression: " ++ show x

-- pp macros

readMacro :: Text -> Doc
readMacro :: Text -> Doc
readMacro Text
name = Char -> Doc
char Char
'$' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
textStrict Text
name

initMacros :: Doc -> Doc -> Doc
initMacros :: Doc -> Doc -> Doc
initMacros Doc
name Doc
initValue = [Doc] -> Doc
vcat
    [ Text -> Doc
text Text
"#ifndef" Doc -> Doc -> Doc
<+> Doc
name
    , Text -> Doc
text Text
"#define " Doc -> Doc -> Doc
<+> Doc
name Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'#' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
initValue Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Char -> Doc
char Char
'#'
    , Text -> Doc
text Text
"#end"
    ]

-- pp arrays

ppTfmArrOut :: Bool -> Var -> Doc
ppTfmArrOut :: Bool -> Var -> Doc
ppTfmArrOut Bool
isInit Var
v = Var -> Doc
ppVar Var
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> (if Bool
isInit then (Text -> Doc
text Text
"[]") else Doc
empty)

ppArrIndex :: Var -> [Doc] -> Doc
ppArrIndex :: Var -> [Doc] -> Doc
ppArrIndex Var
v [Doc]
as = Var -> Doc
ppVar Var
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ([Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> Doc
brackets [Doc]
as)

ppArrVar :: Int -> Doc -> Doc
ppArrVar :: TabDepth -> Doc -> Doc
ppArrVar TabDepth
n Doc
v = Doc
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ([Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ TabDepth -> Doc -> [Doc]
forall a. TabDepth -> a -> [a]
replicate TabDepth
n (Doc -> [Doc]) -> Doc -> [Doc]
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
"[]")

ppReadArr :: Var -> [Doc] -> Doc
ppReadArr :: Var -> [Doc] -> Doc
ppReadArr Var
v [Doc]
as = Var -> [Doc] -> Doc
ppArrIndex Var
v [Doc]
as

ppReadPureArr :: Doc -> [Doc] -> Doc
ppReadPureArr :: Doc -> [Doc] -> Doc
ppReadPureArr Doc
v [Doc]
as = Doc
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ([Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> Doc
brackets [Doc]
as)

ppWriteArr :: Var -> ArrIndex Doc -> Doc -> Doc
ppWriteArr :: Var -> [Doc] -> Doc -> Doc
ppWriteArr Var
v [Doc]
as Doc
b = Var -> [Doc] -> Doc
ppArrIndex Var
v [Doc]
as Doc -> Doc -> Doc
<+> Doc
equalsWord Doc -> Doc -> Doc
<+> Doc
b
    where equalsWord :: Doc
equalsWord = if (Var -> Rate
varRate Var
v Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Sr) then Text -> Doc
text Text
"strcpy" else Doc
equals

ppWriteInitArr :: Var -> [Doc] -> Doc -> Doc
ppWriteInitArr :: Var -> [Doc] -> Doc -> Doc
ppWriteInitArr Var
v [Doc]
as Doc
b = Var -> [Doc] -> Doc
ppArrIndex Var
v [Doc]
as Doc -> Doc -> Doc
<+> Doc
initWord Doc -> Doc -> Doc
<+> Doc
b
    where initWord :: Doc
initWord = Text -> Doc
text (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ if (Var -> Rate
varRate Var
v Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
Sr) then Text
"strcpy" else Text
"init"

-------------------------------------

tab :: Monad m => Doc -> StateT TabDepth m Doc
tab :: forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab Doc
doc = (TabDepth -> Doc)
-> StateT TabDepth m TabDepth -> StateT TabDepth m Doc
forall a b. (a -> b) -> StateT TabDepth m a -> StateT TabDepth m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> TabDepth -> Doc
shiftByTab Doc
doc) StateT TabDepth m TabDepth
forall (m :: * -> *) s. Monad m => StateT s m s
get

tabWidth :: TabDepth
tabWidth :: TabDepth
tabWidth = TabDepth
4

shiftByTab :: Doc -> TabDepth -> Doc
shiftByTab :: Doc -> TabDepth -> Doc
shiftByTab Doc
doc TabDepth
n
    | TabDepth
n TabDepth -> TabDepth -> Bool
forall a. Eq a => a -> a -> Bool
== TabDepth
0    = Doc
doc
    | Bool
otherwise = TabDepth -> Doc -> Doc
indent (TabDepth
tabWidth TabDepth -> TabDepth -> TabDepth
forall a. Num a => a -> a -> a
* TabDepth
n) Doc
doc

left :: State TabDepth ()
left :: State TabDepth ()
left = (TabDepth -> TabDepth) -> State TabDepth ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify TabDepth -> TabDepth
forall a. Enum a => a -> a
pred

succTab :: Monad m => Doc -> StateT TabDepth m Doc
succTab :: forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
succTab Doc
doc = do
    Doc
a <- Doc -> StateT TabDepth m Doc
forall (m :: * -> *). Monad m => Doc -> StateT TabDepth m Doc
tab Doc
doc
    (TabDepth -> TabDepth) -> StateT TabDepth m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify TabDepth -> TabDepth
forall a. Enum a => a -> a
succ
    Doc -> StateT TabDepth m Doc
forall a. a -> StateT TabDepth m a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
a

prefix :: Text -> [Doc] -> Doc
prefix :: Text -> [Doc] -> Doc
prefix Text
name [Doc]
args = Text -> Doc
textStrict Text
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
tupled [Doc]
args

ppCond :: Inline CondOp Doc -> Doc
ppCond :: CondInfo Doc -> Doc
ppCond = (CondOp -> [Doc] -> Doc) -> CondInfo Doc -> Doc
forall a. (a -> [Doc] -> Doc) -> Inline a Doc -> Doc
ppInline CondOp -> [Doc] -> Doc
ppCondOp

($=) :: Doc -> Doc -> Doc
$= :: Doc -> Doc -> Doc
($=) Doc
a Doc
b = Doc
a Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Doc
b

ppOuts :: [R.Var] -> Doc
ppOuts :: [Var] -> Doc
ppOuts [Var]
xs = [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Var -> Doc) -> [Var] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Doc
ppRatedVar [Var]
xs

ppPrimOrVar :: PrimOr R.Var -> Doc
ppPrimOrVar :: PrimOr Var -> Doc
ppPrimOrVar PrimOr Var
x = (Prim -> Doc) -> (Var -> Doc) -> Either Prim Var -> Doc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Prim -> Doc
ppPrim Var -> Doc
ppRatedVar (Either Prim Var -> Doc) -> Either Prim Var -> Doc
forall a b. (a -> b) -> a -> b
$ PrimOr Var -> Either Prim Var
forall a. PrimOr a -> Either Prim a
unPrimOr PrimOr Var
x

ppStrget :: Doc -> Int -> Doc
ppStrget :: Doc -> TabDepth -> Doc
ppStrget Doc
out TabDepth
n = Doc -> Text -> [Doc] -> Doc
ppOpc Doc
out Text
"strget" [Char -> Doc
char Char
'p' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> TabDepth -> Doc
int TabDepth
n]

ppIf :: Doc -> Doc -> Doc -> Doc -> Doc
ppIf :: Doc -> Doc -> Doc -> Doc -> Doc
ppIf Doc
res Doc
p Doc
t Doc
e = [Doc] -> Doc
vcat
    [ Text -> Doc
text Text
"if" Doc -> Doc -> Doc
<+> Doc
p Doc -> Doc -> Doc
<+> Text -> Doc
text Text
"then"
    , Text -> Doc
text Text
"    " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
res Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> Doc
t
    , Text -> Doc
text Text
"else"
    , Text -> Doc
text Text
"    " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
res Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> Doc
e
    , Text -> Doc
text Text
"endif"
    ]

ppIf1, ppWhile, ppUntil :: Doc -> Doc -> Doc -> Doc

ppIf1 :: Doc -> Doc -> Doc -> Doc
ppIf1 = Text -> Doc -> Doc -> Doc -> Doc
ppIfBy Text
"if"
ppWhile :: Doc -> Doc -> Doc -> Doc
ppWhile = Text -> Doc -> Doc -> Doc -> Doc
ppIfBy Text
"while"
ppUntil :: Doc -> Doc -> Doc -> Doc
ppUntil = Text -> Doc -> Doc -> Doc -> Doc
ppIfBy Text
"until"

ppIfBy :: Text -> Doc -> Doc -> Doc -> Doc
ppIfBy :: Text -> Doc -> Doc -> Doc -> Doc
ppIfBy Text
leadTag Doc
res Doc
p Doc
t = [Doc] -> Doc
vcat
    [ Text -> Doc
textStrict Text
leadTag Doc -> Doc -> Doc
<+> Doc
p Doc -> Doc -> Doc
<+> Text -> Doc
text Text
"then"
    , Text -> Doc
text Text
"    " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
res Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> Doc
t
    , Text -> Doc
text Text
"endif"
    ]

ppWhileRef :: Doc -> Var -> Doc -> Doc
ppWhileRef :: Doc -> Var -> Doc -> Doc
ppWhileRef Doc
res Var
p Doc
t = [Doc] -> Doc
vcat
    [ Text -> Doc
textStrict Text
"while" Doc -> Doc -> Doc
<+> Var -> Doc
ppVar Var
p Doc -> Doc -> Doc
<+> Text -> Doc
text Text
"then"
    , Text -> Doc
text Text
"    " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
res Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> Doc
t
    , Text -> Doc
text Text
"endif"
    ]

ppOpc :: Doc -> Text -> [Doc] -> Doc
ppOpc :: Doc -> Text -> [Doc] -> Doc
ppOpc Doc
out Text
name [Doc]
xs = Doc
out Doc -> Doc -> Doc
<+> Text -> [Doc] -> Doc
ppProc Text
name [Doc]
xs

ppProc :: Text -> [Doc] -> Doc
ppProc :: Text -> [Doc] -> Doc
ppProc Text
name [Doc]
xs = Text -> Doc
textStrict Text
name Doc -> Doc -> Doc
<+> ([Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma [Doc]
xs)

ppVar :: Var -> Doc
ppVar :: Var -> Doc
ppVar Var
v = case Var
v of
    Var VarType
ty Rate
rate Text
name   -> VarType -> Doc
ppVarType VarType
ty Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Rate -> Doc
ppRate Rate
rate Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
textStrict (Char -> Text -> Text
Text.cons (VarType -> Char
varPrefix VarType
ty) Text
name)
    VarVerbatim Rate
_ Text
name -> Text -> Doc
textStrict Text
name

varPrefix :: VarType -> Char
varPrefix :: VarType -> Char
varPrefix VarType
x = case VarType
x of
    VarType
LocalVar  -> Char
'l'
    VarType
GlobalVar -> Char
'g'

ppVarType :: VarType -> Doc
ppVarType :: VarType -> Doc
ppVarType VarType
x = case VarType
x of
    VarType
LocalVar  -> Doc
empty
    VarType
GlobalVar -> Char -> Doc
char Char
'g'

ppConvertRate :: Doc -> Rate -> Maybe Rate -> Doc -> Doc
ppConvertRate :: Doc -> Rate -> Maybe Rate -> Doc -> Doc
ppConvertRate Doc
out Rate
to Maybe Rate
from Doc
var = case (Rate
to, Maybe Rate
from) of
    (Rate
Ar, Just Rate
Kr) -> Doc -> Doc
upsamp Doc
var
    (Rate
Ar, Just Rate
Ir) -> Doc -> Doc
upsamp (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
toK Doc
var
    (Rate
Kr, Just Rate
Ar) -> Doc -> Doc
downsamp Doc
var
    (Rate
Kr, Just Rate
Ir) -> Doc
out Doc -> Doc -> Doc
$= Doc
var
    (Rate
Ir, Just Rate
Ar) -> Doc -> Doc
downsamp Doc
var
    (Rate
Ir, Just Rate
Kr) -> Doc
out Doc -> Doc -> Doc
$= Doc -> Doc
toI Doc
var
    (Rate
Ar, Maybe Rate
Nothing) -> Doc
out Doc -> Doc -> Doc
$= Doc -> Doc
toA Doc
var
    (Rate
Kr, Maybe Rate
Nothing) -> Doc
out Doc -> Doc -> Doc
$= Doc -> Doc
toK Doc
var
    (Rate
Ir, Maybe Rate
Nothing) -> Doc
out Doc -> Doc -> Doc
$= Doc -> Doc
toI Doc
var
    (Rate
a, Just Rate
b) | Rate
a Rate -> Rate -> Bool
forall a. Eq a => a -> a -> Bool
== Rate
b -> Doc
out Doc -> Doc -> Doc
$= Doc
var
    (Rate
a, Maybe Rate
b)   -> [Char] -> Doc
forall a. HasCallStack => [Char] -> a
error ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"bug: no rate conversion from " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe Rate -> [Char]
forall a. Show a => a -> [Char]
show Maybe Rate
b [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Rate -> [Char]
forall a. Show a => a -> [Char]
show Rate
a [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
    where
        upsamp :: Doc -> Doc
upsamp Doc
x = Doc -> Text -> [Doc] -> Doc
ppOpc Doc
out Text
"upsamp" [Doc
x]
        downsamp :: Doc -> Doc
downsamp Doc
x = Doc -> Text -> [Doc] -> Doc
ppOpc Doc
out Text
"downsamp" [Doc
x]
        toA :: Doc -> Doc
toA = Text -> Doc -> Doc
func Text
"a"
        toK :: Doc -> Doc
toK = Text -> Doc -> Doc
func Text
"k"
        toI :: Doc -> Doc
toI = Text -> Doc -> Doc
func Text
"i"

-- expressions

ppInline :: (a -> [Doc] -> Doc) -> Inline a Doc -> Doc
ppInline :: forall a. (a -> [Doc] -> Doc) -> Inline a Doc -> Doc
ppInline a -> [Doc] -> Doc
ppNode Inline a Doc
a = InlineExp a -> Doc
iter (InlineExp a -> Doc) -> InlineExp a -> Doc
forall a b. (a -> b) -> a -> b
$ Inline a Doc -> InlineExp a
forall op arg. Inline op arg -> InlineExp op
inlineExp Inline a Doc
a
    where iter :: InlineExp a -> Doc
iter InlineExp a
x = case InlineExp a
x of
              InlinePrim TabDepth
n        -> Inline a Doc -> IntMap Doc
forall op arg. Inline op arg -> IntMap arg
inlineEnv Inline a Doc
a IntMap Doc -> TabDepth -> Doc
forall a. IntMap a -> TabDepth -> a
IM.! TabDepth
n
              InlineExp a
op [InlineExp a]
args   -> a -> [Doc] -> Doc
ppNode a
op ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (InlineExp a -> Doc) -> [InlineExp a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap InlineExp a -> Doc
iter [InlineExp a]
args

-- booleans

ppCondOp :: CondOp -> [Doc] -> Doc
ppCondOp :: CondOp -> [Doc] -> Doc
ppCondOp CondOp
op = case CondOp
op of
    CondOp
TrueOp            -> Doc -> [Doc] -> Doc
forall a b. a -> b -> a
const (Doc -> [Doc] -> Doc) -> Doc -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
"(1 == 1)"
    CondOp
FalseOp           -> Doc -> [Doc] -> Doc
forall a b. a -> b -> a
const (Doc -> [Doc] -> Doc) -> Doc -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> Doc
text Text
"(0 == 1)"
    CondOp
And               -> Text -> [Doc] -> Doc
bi Text
"&&"
    CondOp
Or                -> Text -> [Doc] -> Doc
bi Text
"||"
    CondOp
Equals            -> Text -> [Doc] -> Doc
bi Text
"=="
    CondOp
NotEquals         -> Text -> [Doc] -> Doc
bi Text
"!="
    CondOp
Less              -> Text -> [Doc] -> Doc
bi Text
"<"
    CondOp
Greater           -> Text -> [Doc] -> Doc
bi Text
">"
    CondOp
LessEquals        -> Text -> [Doc] -> Doc
bi Text
"<="
    CondOp
GreaterEquals     -> Text -> [Doc] -> Doc
bi Text
">="
    where bi :: Text -> [Doc] -> Doc
bi  = Text -> [Doc] -> Doc
binaries

-- numeric

ppNumOp :: NumOp -> [Doc] -> Doc
ppNumOp :: NumOp -> [Doc] -> Doc
ppNumOp NumOp
op = case  NumOp
op of
    NumOp
Add -> Text -> [Doc] -> Doc
bi Text
"+"
    NumOp
Sub -> Text -> [Doc] -> Doc
bi Text
"-"
    NumOp
Mul -> Text -> [Doc] -> Doc
bi Text
"*"
    NumOp
Div -> Text -> [Doc] -> Doc
bi Text
"/"
    NumOp
Neg -> Text -> [Doc] -> Doc
uno Text
"-"
    NumOp
Pow -> Text -> [Doc] -> Doc
bi Text
"^"
    NumOp
Mod -> Text -> [Doc] -> Doc
bi Text
"%"
    where
        bi :: Text -> [Doc] -> Doc
bi  = Text -> [Doc] -> Doc
binaries
        uno :: Text -> [Doc] -> Doc
uno = Text -> [Doc] -> Doc
unaries

ppRatedVar :: R.Var -> Doc
ppRatedVar :: Var -> Doc
ppRatedVar Var
v = Rate -> Doc
ppRate (Var -> Rate
R.varType Var
v) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> TabDepth -> Doc
int (Var -> TabDepth
R.varId Var
v)

ppRate :: Rate -> Doc
ppRate :: Rate -> Doc
ppRate Rate
x = case Rate -> Rate
removeArrRate Rate
x of
    Rate
Sr -> Char -> Doc
char Char
'S'
    Rate
_  -> Rate -> Doc
phi Rate
x
    where phi :: Rate -> Doc
phi = Text -> Doc
textStrict (Text -> Doc) -> (Rate -> Text) -> Rate -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.toLower (Text -> Text) -> (Rate -> Text) -> Rate -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack ([Char] -> Text) -> (Rate -> [Char]) -> Rate -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rate -> [Char]
forall a. Show a => a -> [Char]
show

ppTotalDur :: Double -> Doc
ppTotalDur :: Double -> Doc
ppTotalDur Double
d = Text -> Doc
text Text
"f0" Doc -> Doc -> Doc
<+> Double -> Doc
double Double
d

--------------------------------------------------------------
-- debug

newtype PrettyShowE = PrettyShowE E
newtype PrettyE = PrettyE E

instance Show PrettyShowE where
  show :: PrettyShowE -> [Char]
show (PrettyShowE E
expr) = E -> [Char]
forall a. Show a => a -> [Char]
ppShow E
expr

instance Show PrettyE where
  show :: PrettyE -> [Char]
show (PrettyE E
expr) = Doc -> [Char]
forall a. Show a => a -> [Char]
show (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ E -> Doc
ppE E
expr

ppE :: E -> Doc
ppE :: E -> Doc
ppE = (RatedExp Doc -> Doc) -> E -> Doc
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix RatedExp Doc -> Doc
go
  where
    go :: RatedExp Doc -> Doc
    go :: RatedExp Doc -> Doc
go RatedExp Doc
x = Doc -> RatedExp Doc -> Doc
fromExp (RatedExp Doc -> Doc
fromInfo RatedExp Doc
x) RatedExp Doc
x

    fromInfo :: RatedExp Doc -> Doc
    fromInfo :: RatedExp Doc -> Doc
fromInfo RatedExp{Maybe TabDepth
Maybe Rate
ByteString
Exp Doc
ratedExpHash :: ByteString
ratedExpRate :: Maybe Rate
ratedExpDepends :: Maybe TabDepth
ratedExpExp :: Exp Doc
ratedExpHash :: forall a. RatedExp a -> ByteString
ratedExpRate :: forall a. RatedExp a -> Maybe Rate
ratedExpDepends :: forall a. RatedExp a -> Maybe TabDepth
ratedExpExp :: forall a. RatedExp a -> Exp a
..} =
      [Doc] -> Doc
hsep
        [ ByteString -> Doc
ppHash ByteString
ratedExpHash
        , Doc -> (Rate -> Doc) -> Maybe Rate -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty Rate -> Doc
ppRate Maybe Rate
ratedExpRate
        , Doc -> (TabDepth -> Doc) -> Maybe TabDepth -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty TabDepth -> Doc
forall a. Pretty a => a -> Doc
pretty Maybe TabDepth
ratedExpDepends
        ]

    ppHash :: ByteString -> Doc
ppHash = Text -> Doc
textStrict (Text -> Doc) -> (ByteString -> Text) -> ByteString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TabDepth -> Text -> Text
Text.take TabDepth
4 (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Text.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode

    fromExp :: Doc -> RatedExp Doc -> Doc
    fromExp :: Doc -> RatedExp Doc -> Doc
fromExp Doc
info RatedExp{Maybe TabDepth
Maybe Rate
ByteString
Exp Doc
ratedExpHash :: forall a. RatedExp a -> ByteString
ratedExpRate :: forall a. RatedExp a -> Maybe Rate
ratedExpDepends :: forall a. RatedExp a -> Maybe TabDepth
ratedExpExp :: forall a. RatedExp a -> Exp a
ratedExpHash :: ByteString
ratedExpRate :: Maybe Rate
ratedExpDepends :: Maybe TabDepth
ratedExpExp :: Exp Doc
..} = TabDepth -> Doc -> Doc
indent TabDepth
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
post (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      case Exp Doc
ratedExpExp of
        ExpPrim Prim
p -> Prim -> Doc
ppPrim Prim
p
        Exp Doc
EmptyExp -> Text -> Doc
textStrict Text
"EMPTY_EXPR"
        Tfm Info
inf [PrimOr Doc]
args -> Info -> [PrimOr Doc] -> Doc
ppTfm Info
inf [PrimOr Doc]
args
        ConvertRate Rate
to Maybe Rate
from PrimOr Doc
a -> Rate -> Maybe Rate -> PrimOr Doc -> Doc
ppConvert Rate
to Maybe Rate
from PrimOr Doc
a
        Select Rate
r TabDepth
n PrimOr Doc
a -> Rate -> TabDepth -> PrimOr Doc -> Doc
forall {a}. Pretty a => Rate -> a -> PrimOr Doc -> Doc
ppSelect Rate
r TabDepth
n PrimOr Doc
a
        If IfRate
rate CondInfo (PrimOr Doc)
cond PrimOr Doc
th PrimOr Doc
el -> IfRate -> CondInfo (PrimOr Doc) -> PrimOr Doc -> PrimOr Doc -> Doc
ppIff IfRate
rate CondInfo (PrimOr Doc)
cond PrimOr Doc
th PrimOr Doc
el
        ExpBool BoolExp (PrimOr Doc)
args -> [Doc] -> Doc
hsep [Doc
"some bool expr", [Char] -> Doc
forall a. Pretty a => a -> Doc
pretty ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$ BoolExp (PrimOr Doc) -> [Char]
forall a. Show a => a -> [Char]
show BoolExp (PrimOr Doc)
args]
        ExpNum NumExp (PrimOr Doc)
arg -> NumExp (PrimOr Doc) -> Doc
ppExpNum NumExp (PrimOr Doc)
arg
        InitVar Var
v PrimOr Doc
a -> Var -> PrimOr Doc -> Doc
ppInitVar Var
v PrimOr Doc
a
        ReadVar Var
v -> Doc
"ReadVar" Doc -> Doc -> Doc
<+> Var -> Doc
ppVar Var
v
        WriteVar Var
v PrimOr Doc
a -> Var -> Doc
ppVar Var
v Doc -> Doc -> Doc
$= PrimOr Doc -> Doc
pp PrimOr Doc
a

        -- TODO
        InitArr Var
_v [PrimOr Doc]
_size -> Doc
forall a. HasCallStack => a
undefined
        ReadArr Var
_v [PrimOr Doc]
_index -> Doc
forall a. HasCallStack => a
undefined
        WriteArr Var
_v [PrimOr Doc]
_index PrimOr Doc
_ -> Doc
forall a. HasCallStack => a
undefined
        WriteInitArr Var
_v [PrimOr Doc]
_index PrimOr Doc
_ -> Doc
forall a. HasCallStack => a
undefined
        TfmArr Bool
_isInit Var
_v Info
_info [PrimOr Doc]
_args -> Doc
forall a. HasCallStack => a
undefined

        InitPureArr Rate
_outRate IfRate
_procRate [PrimOr Doc]
_vals -> Doc
forall a. HasCallStack => a
undefined
        ReadPureArr Rate
_outRate IfRate
_procRate PrimOr Doc
_arr PrimOr Doc
_index -> Doc
forall a. HasCallStack => a
undefined

        IfBegin IfRate
rate CondInfo (PrimOr Doc)
cond -> [Doc] -> Doc
hsep [Doc
"IF", Rate -> Doc
ppRate (Rate -> Doc) -> Rate -> Doc
forall a b. (a -> b) -> a -> b
$ IfRate -> Rate
fromIfRate IfRate
rate, CondInfo Doc -> Doc
ppCond (CondInfo Doc -> Doc) -> CondInfo Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (PrimOr Doc -> Doc) -> CondInfo (PrimOr Doc) -> CondInfo Doc
forall a b. (a -> b) -> Inline CondOp a -> Inline CondOp b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimOr Doc -> Doc
pp CondInfo (PrimOr Doc)
cond, Doc
"\n"]

        IfBlock IfRate
rate CondInfo (PrimOr Doc)
cond (CodeBlock PrimOr Doc
th) -> Doc -> IfRate -> CondInfo (PrimOr Doc) -> PrimOr Doc -> Doc
ppIfBlockBy Doc
"IF-BLOCK" IfRate
rate CondInfo (PrimOr Doc)
cond PrimOr Doc
th
        IfElseBlock IfRate
rate CondInfo (PrimOr Doc)
cond (CodeBlock PrimOr Doc
th) (CodeBlock PrimOr Doc
el) ->
          Doc -> [Doc] -> Doc
ppFun ([Doc] -> Doc
hsep [Doc
"IF-BLOCK", Rate -> Doc
ppRate (Rate -> Doc) -> Rate -> Doc
forall a b. (a -> b) -> a -> b
$ IfRate -> Rate
fromIfRate IfRate
rate, CondInfo Doc -> Doc
ppCond (CondInfo Doc -> Doc) -> CondInfo Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (PrimOr Doc -> Doc) -> CondInfo (PrimOr Doc) -> CondInfo Doc
forall a b. (a -> b) -> Inline CondOp a -> Inline CondOp b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimOr Doc -> Doc
pp CondInfo (PrimOr Doc)
cond ])
            [ PrimOr Doc -> Doc
pp PrimOr Doc
th
            , Doc
"ELSE-BLOCK"
            , PrimOr Doc -> Doc
pp PrimOr Doc
el
            , Doc
"END-BLOCK"
            ]
        Exp Doc
ElseBegin -> Doc
"ELSE"
        Exp Doc
IfEnd -> Doc
"END_IF"
        UntilBegin IfRate
rate CondInfo (PrimOr Doc)
cond -> [Doc] -> Doc
hsep [Doc
"UNTIL", Rate -> Doc
ppRate (Rate -> Doc) -> Rate -> Doc
forall a b. (a -> b) -> a -> b
$ IfRate -> Rate
fromIfRate IfRate
rate, CondInfo Doc -> Doc
ppCond (CondInfo Doc -> Doc) -> CondInfo Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (PrimOr Doc -> Doc) -> CondInfo (PrimOr Doc) -> CondInfo Doc
forall a b. (a -> b) -> Inline CondOp a -> Inline CondOp b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimOr Doc -> Doc
pp CondInfo (PrimOr Doc)
cond, Doc
"\n"]
        Exp Doc
UntilEnd -> Doc
"END_UNTIL"
        WhileBegin IfRate
rate CondInfo (PrimOr Doc)
cond -> [Doc] -> Doc
hsep [Doc
"WHILE", Rate -> Doc
ppRate (Rate -> Doc) -> Rate -> Doc
forall a b. (a -> b) -> a -> b
$ IfRate -> Rate
fromIfRate IfRate
rate, CondInfo Doc -> Doc
ppCond (CondInfo Doc -> Doc) -> CondInfo Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (PrimOr Doc -> Doc) -> CondInfo (PrimOr Doc) -> CondInfo Doc
forall a b. (a -> b) -> Inline CondOp a -> Inline CondOp b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimOr Doc -> Doc
pp CondInfo (PrimOr Doc)
cond, Doc
"\n"]
        WhileRefBegin Var
v -> [Doc] -> Doc
hsep [Doc
"WHILE_REF", Var -> Doc
ppVar Var
v]
        Exp Doc
WhileEnd -> Doc
"END_WHILE"

        UntilBlock IfRate
rate CondInfo (PrimOr Doc)
cond (CodeBlock PrimOr Doc
th) -> Doc -> IfRate -> CondInfo (PrimOr Doc) -> PrimOr Doc -> Doc
ppIfBlockBy Doc
"UNTIL-BLOCK" IfRate
rate CondInfo (PrimOr Doc)
cond PrimOr Doc
th
        WhileBlock IfRate
rate CondInfo (PrimOr Doc)
cond (CodeBlock PrimOr Doc
th) -> Doc -> IfRate -> CondInfo (PrimOr Doc) -> PrimOr Doc -> Doc
ppIfBlockBy Doc
"WHILE-BLOCK" IfRate
rate CondInfo (PrimOr Doc)
cond PrimOr Doc
th
        WhileRefBlock Var
var (CodeBlock PrimOr Doc
th) -> Var -> PrimOr Doc -> Doc
ppWhileRefBlock Var
var PrimOr Doc
th

        Verbatim Text
txt -> Doc -> [Doc] -> Doc
ppFun Doc
"VERBATIM" [Text -> Doc
textStrict Text
txt]
        Exp Doc
Starts -> Doc
"STARTS"
        Seq PrimOr Doc
a PrimOr Doc
b -> [Doc] -> Doc
vcat [Doc
"SEQ", PrimOr Doc -> Doc
pp PrimOr Doc
a, PrimOr Doc -> Doc
pp PrimOr Doc
b]
        Ends PrimOr Doc
a -> [Doc] -> Doc
vcat [Doc
"ENDS", PrimOr Doc -> Doc
pp PrimOr Doc
a]
        InitMacrosInt Text
_name TabDepth
_n  -> Doc
forall a. HasCallStack => a
undefined
        InitMacrosDouble Text
_name Double
_d -> Doc
forall a. HasCallStack => a
undefined
        InitMacrosString Text
_name Text
_str -> Doc
forall a. HasCallStack => a
undefined
        ReadMacrosInt Text
_name -> Doc
forall a. HasCallStack => a
undefined
        ReadMacrosDouble Text
_name -> Doc
forall a. HasCallStack => a
undefined
        ReadMacrosString Text
_name -> Doc
forall a. HasCallStack => a
undefined
      where
        post :: Doc -> Doc
post Doc
a = [Doc] -> Doc
hsep [[Doc] -> Doc
hcat [Doc
"{",Doc
info, Doc
"}:"], Doc
a]

    ppIfBlockBy :: Doc -> IfRate -> CondInfo (PrimOr Doc) -> PrimOr Doc -> Doc
ppIfBlockBy Doc
leadTag IfRate
rate CondInfo (PrimOr Doc)
cond PrimOr Doc
th =
      Doc -> [Doc] -> Doc
ppFun ([Doc] -> Doc
hsep [Doc
leadTag, Rate -> Doc
ppRate (Rate -> Doc) -> Rate -> Doc
forall a b. (a -> b) -> a -> b
$ IfRate -> Rate
fromIfRate IfRate
rate, CondInfo Doc -> Doc
ppCond (CondInfo Doc -> Doc) -> CondInfo Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (PrimOr Doc -> Doc) -> CondInfo (PrimOr Doc) -> CondInfo Doc
forall a b. (a -> b) -> Inline CondOp a -> Inline CondOp b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimOr Doc -> Doc
pp CondInfo (PrimOr Doc)
cond ])
        [ PrimOr Doc -> Doc
pp PrimOr Doc
th
        , Doc
"END-BLOCK"
        ]

    ppWhileRefBlock :: Var -> PrimOr Doc -> Doc
ppWhileRefBlock Var
var PrimOr Doc
th =
      Doc -> [Doc] -> Doc
ppFun ([Doc] -> Doc
hsep [Doc
"WHILE-REF-BLOCK", Var -> Doc
ppVar Var
var])
        [ PrimOr Doc -> Doc
pp PrimOr Doc
th
        , Doc
"END-BLOCK"
        ]

    ppTfm :: Info -> [PrimOr Doc] -> Doc
ppTfm Info
info [PrimOr Doc]
args = Doc -> [Doc] -> Doc
ppFun (Text -> Doc
textStrict (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ Info -> Text
infoName Info
info) ((PrimOr Doc -> Doc) -> [PrimOr Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimOr Doc -> Doc
pp [PrimOr Doc]
args)

    ppConvert :: Rate -> Maybe Rate -> PrimOr Doc -> Doc
ppConvert Rate
to Maybe Rate
from PrimOr Doc
a =
      Doc -> [Doc] -> Doc
ppFun ([Doc] -> Doc
hsep [Text -> Doc
textStrict Text
"Convert-rate", Rate -> Doc
ppRate Rate
to, Doc -> (Rate -> Doc) -> Maybe Rate -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Monoid a => a
mempty Rate -> Doc
ppRate Maybe Rate
from]) [PrimOr Doc -> Doc
pp PrimOr Doc
a]

    ppSelect :: Rate -> a -> PrimOr Doc -> Doc
ppSelect Rate
rate a
n PrimOr Doc
arg =
      Doc -> [Doc] -> Doc
ppFun ([Doc] -> Doc
hsep [Doc
"select", Rate -> Doc
ppRate Rate
rate, a -> Doc
forall a. Pretty a => a -> Doc
pretty a
n]) [PrimOr Doc -> Doc
pp PrimOr Doc
arg]

    ppIff :: IfRate -> CondInfo (PrimOr Doc) -> PrimOr Doc -> PrimOr Doc -> Doc
ppIff IfRate
rate CondInfo (PrimOr Doc)
cond PrimOr Doc
th PrimOr Doc
el =
      [Doc] -> Doc
vcat
        [ [Doc] -> Doc
hsep [Doc
"if", Rate -> Doc
ppRate (IfRate -> Rate
fromIfRate IfRate
rate), CondInfo Doc -> Doc
ppCond (CondInfo Doc -> Doc) -> CondInfo Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (PrimOr Doc -> Doc) -> CondInfo (PrimOr Doc) -> CondInfo Doc
forall a b. (a -> b) -> Inline CondOp a -> Inline CondOp b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimOr Doc -> Doc
pp CondInfo (PrimOr Doc)
cond]
        , TabDepth -> Doc -> Doc
indent TabDepth
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
            [ Doc
"then" Doc -> Doc -> Doc
<+> PrimOr Doc -> Doc
pp PrimOr Doc
th
            , Doc
"else" Doc -> Doc -> Doc
<+> PrimOr Doc -> Doc
pp PrimOr Doc
el
            ]
        ]

    ppExpNum :: NumExp (PrimOr Doc) -> Doc
ppExpNum (PreInline NumOp
op [PrimOr Doc]
as) = NumOp -> [Doc] -> Doc
ppNumOp NumOp
op ((PrimOr Doc -> Doc) -> [PrimOr Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimOr Doc -> Doc
pp [PrimOr Doc]
as)

    ppInitVar :: Var -> PrimOr Doc -> Doc
ppInitVar Var
v PrimOr Doc
a =
      Doc -> [Doc] -> Doc
ppFun ([Doc] -> Doc
hsep [Doc
"InitVar", Var -> Doc
ppVar Var
v]) [PrimOr Doc -> Doc
pp PrimOr Doc
a]

    ppFun :: Doc -> [Doc] -> Doc
ppFun Doc
name [Doc]
args =
      [Doc] -> Doc
vcat
        [ Doc
name
        , TabDepth -> Doc -> Doc
indent TabDepth
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat [Doc]
args
        ]

    pp :: PrimOr Doc -> Doc
pp = (Prim -> Doc) -> (Doc -> Doc) -> Either Prim Doc -> Doc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Prim -> Doc
ppPrim Doc -> Doc
forall a. a -> a
id (Either Prim Doc -> Doc)
-> (PrimOr Doc -> Either Prim Doc) -> PrimOr Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimOr Doc -> Either Prim Doc
forall a. PrimOr a -> Either Prim a
unPrimOr