{-# LANGUAGE OverloadedStrings #-}

module CGen (CType(..), TTE(..), tCTy, pCty) where

import           A
import           Control.Exception (Exception)
import           Data.Bifunctor    (first)
import qualified Data.Text         as T
import           Prettyprinter     (Doc, Pretty (..), braces, parens, softline', tupled, (<+>))
import           Prettyprinter.Ext

data CType = CR | CI | CB | Af | Ai | Ab

instance Pretty CType where
    pretty :: forall ann. CType -> Doc ann
pretty CType
CR=Doc ann
"F"; pretty CType
CI=Doc ann
"J"; pretty CType
CB=Doc ann
"B"; pretty CType
Af=Doc ann
"Af"; pretty CType
Ai=Doc ann
"Ai"; pretty CType
Ab=Doc ann
"Ab"

data CF = CF !T.Text [CType] CType

instance Pretty CF where
    pretty :: forall ann. CF -> Doc ann
pretty (CF Text
n [CType]
ins CType
out) =
        let args :: [(CType, Char)]
args = [CType] -> String -> [(CType, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CType]
ins [Char
'a'..] in
        Doc ann
"extern" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> CType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. CType -> Doc ann
pretty CType
out Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty Text
n Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
tupled (CType -> Doc ann
forall {a}. IsString a => CType -> a
px(CType -> Doc ann) -> [CType] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>[CType]
ins) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";"
            Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<#> CType -> Doc ann
forall {a}. IsString a => CType -> a
px CType
out Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty Text
n Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"_wrapper" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
tupled (((CType, Char) -> Doc ann) -> [(CType, Char)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(CType
t,Char
var) -> CType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. CType -> Doc ann
pretty CType
t Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Char -> Doc ann
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
var) [(CType, Char)]
args)
            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
softline' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces
                (((CType, Char) -> Doc ann) -> [(CType, Char)] -> Doc ann
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (CType, Char) -> Doc ann
forall {a} {ann}. Pretty a => (CType, a) -> Doc ann
d [(CType, Char)]
args
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> CType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. CType -> Doc ann
pretty CType
out Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"res" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> CType -> Doc ann -> Doc ann
forall {ann}. CType -> Doc ann -> Doc ann
ax CType
out (Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty Text
nDoc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
tupled (Char -> Doc ann
forall {a} {ann}. Pretty a => a -> Doc ann
l(Char -> Doc ann)
-> ((CType, Char) -> Char) -> (CType, Char) -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(CType, Char) -> Char
forall a b. (a, b) -> b
snd((CType, Char) -> Doc ann) -> [(CType, Char)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>[(CType, Char)]
args))Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>Doc ann
";"
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ((CType, Char) -> Doc ann) -> [(CType, Char)] -> Doc ann
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (CType, Char) -> Doc ann
forall {a} {ann}. Pretty a => (CType, a) -> Doc ann
f [(CType, Char)]
args
                Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"R res;")
        where px :: CType -> a
px CType
CR=a
"F"; px CType
CI=a
"J"; px CType
CB=a
"B"; px CType
_=a
"U"
              ax :: CType -> Doc ann -> Doc ann
ax CType
Af=(Doc ann
"poke_af"Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>)(Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens;ax CType
Ai=(Doc ann
"poke_ai"Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>)(Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens;ax CType
Ab=String -> Doc ann -> Doc ann
forall a. HasCallStack => String -> a
error String
"not implemented.";ax CType
_=Doc ann -> Doc ann
forall a. a -> a
id
              d :: (CType, a) -> Doc ann
d (CType
t,a
var) = CType -> Doc ann
forall {a}. IsString a => CType -> a
px CType
t Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc ann
forall {a} {ann}. Pretty a => a -> Doc ann
l a
var Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> CType -> Doc ann -> Doc ann
forall {ann}. CType -> Doc ann -> Doc ann
ax CType
t (a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
var) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";"
              f :: (CType, a) -> Doc ann
f (CType
Af,a
var) = Doc ann
"free" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (a -> Doc ann
forall {a} {ann}. Pretty a => a -> Doc ann
l a
var) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";"
              f (CType
Ai,a
var) = Doc ann
"free" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (a -> Doc ann
forall {a} {ann}. Pretty a => a -> Doc ann
l a
var) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";"
              f (CType
Ab,a
var) = Doc ann
"free" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (a -> Doc ann
forall {a} {ann}. Pretty a => a -> Doc ann
l a
var) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";"
              f (CType, a)
_        = Doc ann
forall a. Monoid a => a
mempty
              l :: a -> Doc ann
l a
var = Doc ann
"_" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
var

-- type translation error
data TTE = HO | Poly | FArg | ArrFn deriving Int -> TTE -> ShowS
[TTE] -> ShowS
TTE -> String
(Int -> TTE -> ShowS)
-> (TTE -> String) -> ([TTE] -> ShowS) -> Show TTE
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TTE -> ShowS
showsPrec :: Int -> TTE -> ShowS
$cshow :: TTE -> String
show :: TTE -> String
$cshowList :: [TTE] -> ShowS
showList :: [TTE] -> ShowS
Show

instance Pretty TTE where
    pretty :: forall ann. TTE -> Doc ann
pretty TTE
HO = Doc ann
"Higher order"; pretty TTE
Poly = Doc ann
"Too polymorphic"; pretty TTE
FArg = Doc ann
"Function as argument"; pretty TTE
ArrFn = Doc ann
"Arrays of functions are not supported."

pCty :: T.Text -> T a -> Either TTE (Doc ann)
pCty :: forall a ann. Text -> T a -> Either TTE (Doc ann)
pCty Text
nm T a
t = (Doc ann
"#include<apple_abi.h>" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<#>) (Doc ann -> Doc ann) -> (CF -> Doc ann) -> CF -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. CF -> Doc ann
pretty (CF -> Doc ann) -> Either TTE CF -> Either TTE (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> T a -> Either TTE CF
forall a. Text -> T a -> Either TTE CF
nmtCTy Text
nm T a
t

nmtCTy :: T.Text -> T a -> Either TTE CF
nmtCTy :: forall a. Text -> T a -> Either TTE CF
nmtCTy Text
nm T a
t = do{(ins,out) <- T a -> Either TTE ([T a], T a)
forall a. T a -> Either TTE ([T a], T a)
irTy (T a -> T a
forall a. T a -> T a
rLi T a
t); CF nm<$>traverse cTy ins<*>cTy out}

tCTy :: T a -> Either TTE ([CType], CType)
tCTy :: forall a. T a -> Either TTE ([CType], CType)
tCTy T a
t = do{(ins,out) <- T a -> Either TTE ([T a], T a)
forall a. T a -> Either TTE ([T a], T a)
irTy (T a -> T a
forall a. T a -> T a
rLi T a
t); (,)<$>traverse cTy ins<*>cTy out}

cTy :: T a -> Either TTE CType
cTy :: forall a. T a -> Either TTE CType
cTy T a
F                 = CType -> Either TTE CType
forall a. a -> Either TTE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CType
CR
cTy T a
I                 = CType -> Either TTE CType
forall a. a -> Either TTE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CType
CI
cTy T a
B                 = CType -> Either TTE CType
forall a. a -> Either TTE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CType
CB
cTy (Arr Sh a
_ T a
F)         = CType -> Either TTE CType
forall a. a -> Either TTE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CType
Af
cTy (Arr Sh a
_ T a
I)         = CType -> Either TTE CType
forall a. a -> Either TTE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CType
Ai
cTy (Arr Sh a
_ T a
B)         = CType -> Either TTE CType
forall a. a -> Either TTE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CType
Ab
cTy (Arrow Arrow{} T a
_) = TTE -> Either TTE CType
forall a b. a -> Either a b
Left TTE
FArg
cTy (Arr Sh a
_ Arrow{})   = TTE -> Either TTE CType
forall a b. a -> Either a b
Left TTE
ArrFn

instance Exception TTE where

irTy :: T a -> Either TTE ([T a], T a)
irTy :: forall a. T a -> Either TTE ([T a], T a)
irTy T a
F                 = ([T a], T a) -> Either TTE ([T a], T a)
forall a. a -> Either TTE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], T a
forall a. T a
F)
irTy T a
I                 = ([T a], T a) -> Either TTE ([T a], T a)
forall a. a -> Either TTE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], T a
forall a. T a
I)
irTy T a
B                 = ([T a], T a) -> Either TTE ([T a], T a)
forall a. a -> Either TTE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], T a
forall a. T a
B)
irTy t :: T a
t@Arr{}           = ([T a], T a) -> Either TTE ([T a], T a)
forall a. a -> Either TTE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], T a
t)
irTy (Arrow Arrow{} T a
_) = TTE -> Either TTE ([T a], T a)
forall a b. a -> Either a b
Left TTE
HO
irTy (Arrow T a
t0 T a
t1)     = ([T a] -> [T a]) -> ([T a], T a) -> ([T a], T a)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (T a
t0T a -> [T a] -> [T a]
forall a. a -> [a] -> [a]
:) (([T a], T a) -> ([T a], T a))
-> Either TTE ([T a], T a) -> Either TTE ([T a], T a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> T a -> Either TTE ([T a], T a)
forall a. T a -> Either TTE ([T a], T a)
irTy T a
t1
irTy TVar{}            = TTE -> Either TTE ([T a], T a)
forall a b. a -> Either a b
Left TTE
Poly
irTy Ρ{}               = TTE -> Either TTE ([T a], T a)
forall a b. a -> Either a b
Left TTE
Poly