{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}

-- | Very minimal ADT for outputting some S-Expressions.
module HsInspect.Sexp where

import Data.String (IsString, fromString)
import Data.Text (Text)
import qualified Data.Text as T
import FastString (unpackFS)
import Json (escapeJsonString)
import Module (ModuleName, moduleNameString)
import PackageConfig (PackageName(..), SourcePackageId(..))

data Sexp
  = SexpCons Sexp Sexp
  | SexpNil
  | SexpString Text
  | SexpSymbol Text
  | SexpInt Int

list :: [Sexp] -> Sexp
list :: [Sexp] -> Sexp
list = (Sexp -> Sexp -> Sexp) -> Sexp -> [Sexp] -> Sexp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Sexp -> Sexp -> Sexp
SexpCons Sexp
SexpNil

toList :: Sexp -> Maybe [Sexp]
toList :: Sexp -> Maybe [Sexp]
toList Sexp
SexpNil = [Sexp] -> Maybe [Sexp]
forall a. a -> Maybe a
Just []
toList (SexpCons Sexp
a Sexp
b) = (Sexp
a Sexp -> [Sexp] -> [Sexp]
forall a. a -> [a] -> [a]
:) ([Sexp] -> [Sexp]) -> Maybe [Sexp] -> Maybe [Sexp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sexp -> Maybe [Sexp]
toList Sexp
b
toList Sexp
_ = Maybe [Sexp]
forall a. Maybe a
Nothing

instance IsString Sexp where
  fromString :: String -> Sexp
fromString = Text -> Sexp
SexpSymbol (Text -> Sexp) -> (String -> Text) -> String -> Sexp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

alist :: [(Sexp, Sexp)] -> Sexp
alist :: [(Sexp, Sexp)] -> Sexp
alist [(Sexp, Sexp)]
els = [Sexp] -> Sexp
list ([Sexp] -> Sexp) -> [Sexp] -> Sexp
forall a b. (a -> b) -> a -> b
$ (Sexp, Sexp) -> [Sexp]
mkEl ((Sexp, Sexp) -> [Sexp]) -> [(Sexp, Sexp)] -> [Sexp]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(Sexp, Sexp)]
els
  where
    mkEl :: (Sexp, Sexp) -> [Sexp]
mkEl (Sexp
k, Sexp
v) = [Sexp -> Sexp -> Sexp
SexpCons Sexp
k Sexp
v]

toAList :: Sexp -> Maybe [(Text, Sexp)]
toAList :: Sexp -> Maybe [(Text, Sexp)]
toAList Sexp
SexpNil = [(Text, Sexp)] -> Maybe [(Text, Sexp)]
forall a. a -> Maybe a
Just []
toAList (SexpCons (SexpCons (SexpSymbol Text
k) Sexp
v) Sexp
rest) = ((Text
k, Sexp
v) (Text, Sexp) -> [(Text, Sexp)] -> [(Text, Sexp)]
forall a. a -> [a] -> [a]
:) ([(Text, Sexp)] -> [(Text, Sexp)])
-> Maybe [(Text, Sexp)] -> Maybe [(Text, Sexp)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sexp -> Maybe [(Text, Sexp)]
toAList Sexp
rest
toAList Sexp
_ = Maybe [(Text, Sexp)]
forall a. Maybe a
Nothing

class ToSexp a where
  toSexp :: a -> Sexp

instance ToSexp Sexp where
  toSexp :: Sexp -> Sexp
toSexp = Sexp -> Sexp
forall a. a -> a
id

instance ToSexp Text where
  toSexp :: Text -> Sexp
toSexp = Text -> Sexp
SexpString

instance ToSexp Bool where
  toSexp :: Bool -> Sexp
toSexp Bool
False = Sexp
SexpNil
  toSexp Bool
True = Text -> Sexp
SexpSymbol Text
"t"

instance ToSexp Int where
  toSexp :: Int -> Sexp
toSexp = Int -> Sexp
SexpInt

instance ToSexp a => ToSexp [a] where
  toSexp :: [a] -> Sexp
toSexp [a]
as = [Sexp] -> Sexp
list ([Sexp] -> Sexp) -> [Sexp] -> Sexp
forall a b. (a -> b) -> a -> b
$ a -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp (a -> Sexp) -> [a] -> [Sexp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
as

instance (ToSexp a1, ToSexp a2) => ToSexp (a1, a2) where
  toSexp :: (a1, a2) -> Sexp
toSexp (a1
a1, a2
a2) = [Sexp] -> Sexp
list [a1 -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp a1
a1, a2 -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp a2
a2]

instance (ToSexp a1, ToSexp a2, ToSexp a3) => ToSexp (a1, a2, a3) where
  toSexp :: (a1, a2, a3) -> Sexp
toSexp (a1
a1, a2
a2, a3
a3) = [Sexp] -> Sexp
list [a1 -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp a1
a1, a2 -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp a2
a2, a3 -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp a3
a3]

instance ToSexp a => ToSexp (Maybe a) where
  toSexp :: Maybe a -> Sexp
toSexp (Just a
a) = a -> Sexp
forall a. ToSexp a => a -> Sexp
toSexp a
a
  toSexp Maybe a
Nothing = Sexp
SexpNil

instance ToSexp SourcePackageId where
  toSexp :: SourcePackageId -> Sexp
toSexp (SourcePackageId FastString
fs) = Text -> Sexp
SexpString (Text -> Sexp) -> (String -> Text) -> String -> Sexp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Sexp) -> String -> Sexp
forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS FastString
fs

instance ToSexp ModuleName where
  toSexp :: ModuleName -> Sexp
toSexp = Text -> Sexp
SexpString (Text -> Sexp) -> (ModuleName -> Text) -> ModuleName -> Sexp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (ModuleName -> String) -> ModuleName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
moduleNameString

instance ToSexp PackageName where
  toSexp :: PackageName -> Sexp
toSexp (PackageName FastString
fs) = Text -> Sexp
SexpString (Text -> Sexp) -> (String -> Text) -> String -> Sexp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Sexp) -> String -> Sexp
forall a b. (a -> b) -> a -> b
$ FastString -> String
unpackFS FastString
fs

filterNil :: Sexp -> Sexp
filterNil :: Sexp -> Sexp
filterNil Sexp
SexpNil = Sexp
SexpNil
filterNil (SexpCons (SexpCons (SexpSymbol Text
_) Sexp
SexpNil) Sexp
rest) = Sexp -> Sexp
filterNil Sexp
rest
filterNil (SexpCons Sexp
car Sexp
cdr) = (Sexp -> Sexp -> Sexp
SexpCons (Sexp -> Sexp
filterNil Sexp
car) (Sexp -> Sexp
filterNil Sexp
cdr))
filterNil (SexpString Text
s) = Text -> Sexp
SexpString Text
s
filterNil (SexpSymbol Text
s) = Text -> Sexp
SexpSymbol Text
s
filterNil (SexpInt Int
i) = Int -> Sexp
SexpInt Int
i

render :: Sexp -> Text
render :: Sexp -> Text
render Sexp
SexpNil = Text
"nil"
render (Sexp -> Maybe [Sexp]
toList -> Just [Sexp]
ss) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
" " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Sexp -> Text
render (Sexp -> Text) -> [Sexp] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Sexp]
ss) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")\n"
render (SexpCons Sexp
a Sexp
b) = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sexp -> Text
render Sexp
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" . " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Sexp -> Text
render Sexp
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")\n"
render (SexpString Text
s) = Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
escapeJsonString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
render (SexpSymbol Text
a) = String -> Text
T.pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
escapeJsonString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
a
render (SexpInt Int
i) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i
-- TODO write our own escapeString to avoid a ghc dep and improve perf