SExpr.hs

{-# 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 (Eq, Ord, Generic, Lift)
  deriving anyclass (Hashable, NFData, Serial)

instance Cereal.Serialize SExpr where
  put = serialize
  get = deserialize

instance Binary.Binary SExpr where
  put = serialize
  get = deserialize

instance Show SExpr where
  showsPrec _ = showsSExprWithParens '(' ')'

unwordsS :: [ShowS] -> ShowS
unwordsS [] = id
unwordsS [x] = x
unwordsS (x : xs) = x . showString " " . unwordsS xs

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

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

-- | Get the file location of the splice.
fileLocation :: SpliceQ SExpr
fileLocation =
  [||parseFileLocation $$(liftSplice $ unsafeTExpCoerce __LOCATION__)||]