{-# LANGUAGE OverloadedStrings #-}

module Language.C.AST ( CType (..)
                      , CFunc (..)
                      , prettyHeaders
                      , cSettings
                      ) where

import           Data.Semigroup    ((<>))
import qualified Data.Set          as S
import qualified Data.Text         as T
import           Prettyprinter     (Doc, LayoutOptions (..), PageWidth (..), Pretty (..), tupled, (<+>))
import           Prettyprinter.Ext

cSettings :: LayoutOptions
cSettings :: LayoutOptions
cSettings = PageWidth -> LayoutOptions
LayoutOptions (PageWidth -> LayoutOptions) -> PageWidth -> LayoutOptions
forall a b. (a -> b) -> a -> b
$ Int -> Double -> PageWidth
AvailablePerLine Int
180 Double
0.8

data CHeader = StdBool -- ^ @stdbool.h@
             | StdInt -- ^ @stdint.h@
             deriving (CHeader -> CHeader -> Bool
(CHeader -> CHeader -> Bool)
-> (CHeader -> CHeader -> Bool) -> Eq CHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CHeader -> CHeader -> Bool
$c/= :: CHeader -> CHeader -> Bool
== :: CHeader -> CHeader -> Bool
$c== :: CHeader -> CHeader -> Bool
Eq, Eq CHeader
Eq CHeader
-> (CHeader -> CHeader -> Ordering)
-> (CHeader -> CHeader -> Bool)
-> (CHeader -> CHeader -> Bool)
-> (CHeader -> CHeader -> Bool)
-> (CHeader -> CHeader -> Bool)
-> (CHeader -> CHeader -> CHeader)
-> (CHeader -> CHeader -> CHeader)
-> Ord CHeader
CHeader -> CHeader -> Bool
CHeader -> CHeader -> Ordering
CHeader -> CHeader -> CHeader
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CHeader -> CHeader -> CHeader
$cmin :: CHeader -> CHeader -> CHeader
max :: CHeader -> CHeader -> CHeader
$cmax :: CHeader -> CHeader -> CHeader
>= :: CHeader -> CHeader -> Bool
$c>= :: CHeader -> CHeader -> Bool
> :: CHeader -> CHeader -> Bool
$c> :: CHeader -> CHeader -> Bool
<= :: CHeader -> CHeader -> Bool
$c<= :: CHeader -> CHeader -> Bool
< :: CHeader -> CHeader -> Bool
$c< :: CHeader -> CHeader -> Bool
compare :: CHeader -> CHeader -> Ordering
$ccompare :: CHeader -> CHeader -> Ordering
$cp1Ord :: Eq CHeader
Ord)

prettyInclude :: CHeader -> Doc ann
prettyInclude :: CHeader -> Doc ann
prettyInclude CHeader
StdBool = Doc ann
"#include <stdbool.h>"
prettyInclude CHeader
StdInt  = Doc ann
"#include <stdint.h>"

data CType = CInt
           | CBool
           | CUInt64
           | CInt8
           | CVoid
           | CVoidPtr
           -- ADTs etc.

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

prettyHeaders :: [CFunc] -> Doc ann
prettyHeaders :: [CFunc] -> Doc ann
prettyHeaders [CFunc]
es =
    let hs :: Set CHeader
hs = (CFunc -> Set CHeader) -> [CFunc] -> Set CHeader
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CFunc -> Set CHeader
mentionedFunc [CFunc]
es
        in [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
prettyLines ((CHeader -> Doc ann) -> [CHeader] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CHeader -> Doc ann
forall ann. CHeader -> Doc ann
prettyInclude (Set CHeader -> [CHeader]
forall a. Set a -> [a]
S.toList Set CHeader
hs))
            Doc ann -> Doc ann -> Doc ann
forall a. Doc a -> Doc a -> Doc a
<#> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
prettyLines ((CFunc -> Doc ann) -> [CFunc] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CFunc -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [CFunc]
es)

mentioned :: CType -> S.Set CHeader
mentioned :: CType -> Set CHeader
mentioned CType
CInt     = Set CHeader
forall a. Monoid a => a
mempty
mentioned CType
CBool    = CHeader -> Set CHeader
forall a. a -> Set a
S.singleton CHeader
StdBool
mentioned CType
CUInt64  = CHeader -> Set CHeader
forall a. a -> Set a
S.singleton CHeader
StdInt
mentioned CType
CVoid    = Set CHeader
forall a. Monoid a => a
mempty
mentioned CType
CVoidPtr = Set CHeader
forall a. Monoid a => a
mempty
mentioned CType
CInt8    = CHeader -> Set CHeader
forall a. a -> Set a
S.singleton CHeader
StdInt

mentionedFunc :: CFunc -> S.Set CHeader
mentionedFunc :: CFunc -> Set CHeader
mentionedFunc (CFunc Text
_ [CType]
args CType
ret) = (CType -> Set CHeader) -> [CType] -> Set CHeader
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CType -> Set CHeader
mentioned (CType
ret CType -> [CType] -> [CType]
forall a. a -> [a] -> [a]
: [CType]
args)

instance Pretty CType where
    pretty :: CType -> Doc ann
pretty CType
CInt     = Doc ann
"int"
    pretty CType
CBool    = Doc ann
"bool"
    pretty CType
CUInt64  = Doc ann
"uint64_t"
    pretty CType
CVoid    = Doc ann
"void"
    pretty CType
CVoidPtr = Doc ann
"void*"
    pretty CType
CInt8    = Doc ann
"int8_t"

instance Pretty CFunc where
    pretty :: CFunc -> Doc ann
pretty (CFunc Text
fname [CType]
args CType
retType) = Doc ann
"extern" Doc ann -> Doc ann -> Doc ann
forall a. Doc a -> Doc a -> Doc a
<+> CType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CType
retType Doc ann -> Doc ann -> Doc ann
forall a. Doc a -> Doc a -> Doc a
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
fname Doc ann -> Doc ann -> Doc ann
forall a. Doc a -> Doc a -> Doc a
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
tupled (CType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CType -> Doc ann) -> [CType] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CType]
args) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
";"