fb-util-0.1.0.1: Util/ToExp.hs

{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

{-# LANGUAGE CPP #-}
module Util.ToExp
  ( ToExp(..)
  , intE
  , fracE
  , con
  , recConstr
  , fun
  , (=.=)
  , (=.==)
  , (=.=?)
  , (=$=)
  , (=$==)
  , pp
  , ppShow
  ) where

import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as BS
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Int
import Data.Scientific
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import qualified Data.Vector.Storable as SVector
import Language.Haskell.Exts hiding (intE)
#if MIN_VERSION_aeson(2,0,0)
import Util.Aeson
#endif
import Util.Text

infixl 1 =.=
infixl 1 =.==
infixl 1 =.=?
infixl 2 =$=
infixl 2 =$==

intE :: Integer -> Exp ()
intE n = (if n < 0 then paren else id) $
           Lit () (Int () n (show n))

fracE :: Rational -> Exp ()
fracE n = (if n < 0 then paren else id) $
            Lit () (Frac () n (show n))

con :: String -> Exp ()
con = Con () . UnQual () . name

recConstr :: String -> [FieldUpdate ()] -> Exp ()
recConstr recname = RecConstr () (UnQual () $ name recname)

fun :: String -> Exp ()
fun = function

-- | Function used to generate FieldUpdate for record constructors.
(=.=) :: ToExp a => String -> a -> FieldUpdate ()
field =.= value = FieldUpdate () (UnQual () $ name field) (toExp value)

(=.==) :: String -> Exp () -> FieldUpdate ()
(=.==) = (=.=)

(=.=?) :: String -> Maybe (Exp ()) -> FieldUpdate ()
(=.=?) = (=.=)

(=$=) :: ToExp a => Exp () -> a -> Exp ()
f =$= x = app f (toExp x)

(=$==) :: Exp () -> Exp () -> Exp ()
(=$==) = (=$=)

class ToExp a where
  toExp :: a -> Exp ()

instance ToExp (Exp ()) where
  toExp = id

instance ToExp () where
  toExp () = tuple []

instance ToExp Bool where
  toExp = con . show

instance ToExp Int where
  toExp = intE . fromIntegral

instance ToExp Double where
  toExp = fracE . realToFrac

instance ToExp Text where
  toExp = strE . Text.unpack

instance ToExp TextAndByteString where
  toExp s = fun "mkTextAndByteString" =$= toByteString s

instance ToExp BS.ByteString where
  toExp = strE . BS.unpack

instance (ToExp a, ToExp b) => ToExp (a, b) where
  toExp (a, b) = tuple [toExp a, toExp b]

instance ToExp a => ToExp (Maybe a) where
  toExp = maybe (con "Nothing") (con "Just" =$=)

instance ToExp a => ToExp [a] where
  toExp = listE . map toExp

instance ToExp Int64 where
  toExp = intE . fromIntegral

instance ToExp Char where
  toExp = charE


instance ToExp a => ToExp (Vector.Vector a) where
  toExp v = fun "Vector.fromList" =$= Vector.toList v

instance (SVector.Storable a, ToExp a)
    => ToExp (SVector.Vector a) where
  toExp v = fun "SVector.fromList" =$= SVector.toList v

#if MIN_VERSION_aeson(2,0,0)
instance ToExp A.Key where
  toExp k = fun "fromText" =$= toExp (keyToText k)

instance ToExp v => ToExp (KeyMap v) where
  toExp m = fun "fromList" =$= objectToList m
#endif

instance (ToExp k, ToExp v) => ToExp (HashMap k v) where
  toExp m = fun "HashMap.fromList" =$= HashMap.toList m

instance ToExp A.Value where
  toExp A.Null = con "Null"
  toExp (A.Bool b) = con "Bool" =$= b
  toExp (A.Number n) = con "Number" =$==
    either toExp toExp (floatingOrInteger n :: Either Double Int)
  toExp (A.String s) = con "String" =$= s
  toExp (A.Array a) = con "Array" =$= a
  toExp (A.Object o) = con "Object" =$= o

-- TODO(t16157798): remove the OneLineMode; currently dumpCacheAsHaskellFn
-- depends on the output being a single line only
pp :: ToExp a => a -> String
pp x = prettyPrintStyleMode oneline defaultMode $ (noLoc <$ toExp x)
  where
  oneline = Style{ mode = OneLineMode, lineLength = 0, ribbonsPerLine = 0 }

-- To define a Show instance based on ToExp, use ppShow instead of pp;
-- the correct definition would define showsPrec and depending on the
-- operator precedence of the enclosing context and on the precedence inside
-- the expression would choose to parenthesize it or not.
-- YOLO. Let's just always parenthesize to be on the safe side.
--
-- > instance Show Foo where
-- >  show = ppShow
ppShow :: ToExp a => a -> String
ppShow x = pp $ paren (toExp x)