{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Unused LANGUAGE pragma" #-}

-- |
-- Module      :   Grisette.Internal.Core.Data.SExpr
-- Copyright   :   (c) Sirui Lu 2024
-- License     :   BSD-3-Clause (see the LICENSE file)
--
-- Maintainer  :   siruilu@cs.washington.edu
-- Stability   :   Experimental
-- Portability :   GHC only
module Grisette.Internal.Core.Data.SExpr
  ( SExpr (..),
    showsSExprWithParens,
    parseFileLocation,
    fileLocation,
  )
where

import Control.DeepSeq (NFData)
import qualified Data.Binary as Binary
import Data.Bytes.Serial (Serial (deserialize, serialize))
import Data.Hashable (Hashable)
import qualified Data.Serialize as Cereal
import Data.Serialize.Text ()
import qualified Data.Text as T
import Debug.Trace.LocationTH (__LOCATION__)
import GHC.Generics (Generic)
import Language.Haskell.TH.Syntax (Lift, unsafeTExpCoerce)
import Language.Haskell.TH.Syntax.Compat (SpliceQ, liftSplice)

-- | S-expression data type. Used for symbol metadata.
data SExpr = Atom T.Text | List [SExpr] | NumberAtom Integer | BoolAtom Bool
  deriving stock (SExpr -> SExpr -> Bool
(SExpr -> SExpr -> Bool) -> (SExpr -> SExpr -> Bool) -> Eq SExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SExpr -> SExpr -> Bool
== :: SExpr -> SExpr -> Bool
$c/= :: SExpr -> SExpr -> Bool
/= :: SExpr -> SExpr -> Bool
Eq, Eq SExpr
Eq SExpr =>
(SExpr -> SExpr -> Ordering)
-> (SExpr -> SExpr -> Bool)
-> (SExpr -> SExpr -> Bool)
-> (SExpr -> SExpr -> Bool)
-> (SExpr -> SExpr -> Bool)
-> (SExpr -> SExpr -> SExpr)
-> (SExpr -> SExpr -> SExpr)
-> Ord SExpr
SExpr -> SExpr -> Bool
SExpr -> SExpr -> Ordering
SExpr -> SExpr -> SExpr
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
$ccompare :: SExpr -> SExpr -> Ordering
compare :: SExpr -> SExpr -> Ordering
$c< :: SExpr -> SExpr -> Bool
< :: SExpr -> SExpr -> Bool
$c<= :: SExpr -> SExpr -> Bool
<= :: SExpr -> SExpr -> Bool
$c> :: SExpr -> SExpr -> Bool
> :: SExpr -> SExpr -> Bool
$c>= :: SExpr -> SExpr -> Bool
>= :: SExpr -> SExpr -> Bool
$cmax :: SExpr -> SExpr -> SExpr
max :: SExpr -> SExpr -> SExpr
$cmin :: SExpr -> SExpr -> SExpr
min :: SExpr -> SExpr -> SExpr
Ord, (forall x. SExpr -> Rep SExpr x)
-> (forall x. Rep SExpr x -> SExpr) -> Generic SExpr
forall x. Rep SExpr x -> SExpr
forall x. SExpr -> Rep SExpr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SExpr -> Rep SExpr x
from :: forall x. SExpr -> Rep SExpr x
$cto :: forall x. Rep SExpr x -> SExpr
to :: forall x. Rep SExpr x -> SExpr
Generic, (forall (m :: * -> *). Quote m => SExpr -> m Exp)
-> (forall (m :: * -> *). Quote m => SExpr -> Code m SExpr)
-> Lift SExpr
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => SExpr -> m Exp
forall (m :: * -> *). Quote m => SExpr -> Code m SExpr
$clift :: forall (m :: * -> *). Quote m => SExpr -> m Exp
lift :: forall (m :: * -> *). Quote m => SExpr -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => SExpr -> Code m SExpr
liftTyped :: forall (m :: * -> *). Quote m => SExpr -> Code m SExpr
Lift)
  deriving anyclass (Eq SExpr
Eq SExpr =>
(Int -> SExpr -> Int) -> (SExpr -> Int) -> Hashable SExpr
Int -> SExpr -> Int
SExpr -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> SExpr -> Int
hashWithSalt :: Int -> SExpr -> Int
$chash :: SExpr -> Int
hash :: SExpr -> Int
Hashable, SExpr -> ()
(SExpr -> ()) -> NFData SExpr
forall a. (a -> ()) -> NFData a
$crnf :: SExpr -> ()
rnf :: SExpr -> ()
NFData, (forall (m :: * -> *). MonadPut m => SExpr -> m ())
-> (forall (m :: * -> *). MonadGet m => m SExpr) -> Serial SExpr
forall a.
(forall (m :: * -> *). MonadPut m => a -> m ())
-> (forall (m :: * -> *). MonadGet m => m a) -> Serial a
forall (m :: * -> *). MonadGet m => m SExpr
forall (m :: * -> *). MonadPut m => SExpr -> m ()
$cserialize :: forall (m :: * -> *). MonadPut m => SExpr -> m ()
serialize :: forall (m :: * -> *). MonadPut m => SExpr -> m ()
$cdeserialize :: forall (m :: * -> *). MonadGet m => m SExpr
deserialize :: forall (m :: * -> *). MonadGet m => m SExpr
Serial)

instance Cereal.Serialize SExpr where
  put :: Putter SExpr
put = Putter SExpr
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => SExpr -> m ()
serialize
  get :: Get SExpr
get = Get SExpr
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m SExpr
deserialize

instance Binary.Binary SExpr where
  put :: SExpr -> Put
put = SExpr -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => SExpr -> m ()
serialize
  get :: Get SExpr
get = Get SExpr
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m SExpr
deserialize

instance Show SExpr where
  showsPrec :: Int -> SExpr -> ShowS
showsPrec Int
_ = Char -> Char -> SExpr -> ShowS
showsSExprWithParens Char
'(' Char
')'

unwordsS :: [ShowS] -> ShowS
unwordsS :: [ShowS] -> ShowS
unwordsS [] = ShowS
forall a. a -> a
id
unwordsS [ShowS
x] = ShowS
x
unwordsS (ShowS
x : [ShowS]
xs) = ShowS
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ShowS] -> ShowS
unwordsS [ShowS]
xs

-- | Show an S-expression with specific parentheses.
showsSExprWithParens :: Char -> Char -> SExpr -> ShowS
showsSExprWithParens :: Char -> Char -> SExpr -> ShowS
showsSExprWithParens Char
_ Char
_ (Atom Text
s) = String -> ShowS
showString (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s
showsSExprWithParens Char
lp Char
rp (List [SExpr]
l) =
  String -> ShowS
showString [Char
lp] ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ShowS] -> ShowS
unwordsS ((SExpr -> ShowS) -> [SExpr] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map SExpr -> ShowS
forall a. Show a => a -> ShowS
shows [SExpr]
l) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
showString [Char
rp])
showsSExprWithParens Char
_ Char
_ (NumberAtom Integer
n) = Integer -> ShowS
forall a. Show a => a -> ShowS
shows Integer
n
showsSExprWithParens Char
_ Char
_ (BoolAtom Bool
b) = String -> ShowS
showString (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ if Bool
b then String
"#t" else String
"#f"

-- | Parse a file location string into an S-expression.
parseFileLocation :: String -> SExpr
parseFileLocation :: String -> SExpr
parseFileLocation String
str =
  let r :: String
r = ShowS
forall a. [a] -> [a]
reverse String
str
      (String
s2, String
r1) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') String
r
      (String
s1, String
r2) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. HasCallStack => [a] -> [a]
tail String
r1
      (String
l, String
p) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. HasCallStack => [a] -> [a]
tail String
r2
   in [SExpr] -> SExpr
List
        [ Text -> SExpr
Atom Text
"grisette-file-location",
          Text -> SExpr
Atom (Text -> SExpr) -> Text -> SExpr
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. HasCallStack => [a] -> [a]
tail String
p,
          Integer -> SExpr
NumberAtom (Integer -> SExpr) -> Integer -> SExpr
forall a b. (a -> b) -> a -> b
$ String -> Integer
forall a. Read a => String -> a
read (String -> Integer) -> String -> Integer
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse String
l,
          [SExpr] -> SExpr
List
            [ Integer -> SExpr
NumberAtom (Integer -> SExpr) -> Integer -> SExpr
forall a b. (a -> b) -> a -> b
$ String -> Integer
forall a. Read a => String -> a
read (String -> Integer) -> String -> Integer
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse String
s1,
              Integer -> SExpr
NumberAtom (Integer -> SExpr) -> Integer -> SExpr
forall a b. (a -> b) -> a -> b
$ String -> Integer
forall a. Read a => String -> a
read (String -> Integer) -> String -> Integer
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse String
s2
            ]
        ]

-- | Get the file location of the splice.
fileLocation :: SpliceQ SExpr
fileLocation :: SpliceQ SExpr
fileLocation =
  [||String -> SExpr
parseFileLocation $$(Q (TExp String) -> Splice Q String
forall a (m :: * -> *). m (TExp a) -> Splice m a
liftSplice (Q (TExp String) -> Splice Q String)
-> Q (TExp String) -> Splice Q String
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q (TExp String)
forall a (m :: * -> *). Quote m => m Exp -> m (TExp a)
unsafeTExpCoerce Q Exp
__LOCATION__)||]