Syntax.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PatternSynonyms #-}
{-# Language ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Config.Suckless.Syntax
  ( Syntax(..)
  , Id(..)
  , Literal(..)
  , Opaque(..)
  , HasContext
  , C(..)
  , Context(..)
  , IsContext(..)
  , IsLiteral(..)
  , ByteStringSorts(..)
  , mkOpaque
  , isOpaqueOf
  , fromOpaque
  , fromOpaqueThrow
  , isByteString
  , SyntaxTypeError(..)
  , nil
  , mkList
  , mkBool
  , synToText
  , MkId(..)
  , MkForm(..)
  , MkSym(..)
  , MkInt(..)
  , MkStr(..)
  , MkDouble(..)
  , MkSyntax(..)
  , pattern SymbolVal
  , pattern ListVal
  , pattern LitIntVal
  , pattern LitStrVal
  , pattern LitBoolVal
  , pattern LitScientificVal
  , pattern StringLike
  , pattern TextLike
  , pattern StringLikeList
  , pattern TextLikeList
  , pattern IntLikeList
  , pattern Nil
  , pattern OpaqueVal
  , pattern MatchOpaqueVal
  )
  where

import Data.Data
import Data.Dynamic
import Data.Kind
import Data.String
import Data.Text (Text)
import Data.Scientific
import GHC.Generics (Generic(..))
import Data.Maybe
import Data.Aeson
import Data.Aeson.Key as Aeson
import Data.Aeson.KeyMap qualified as Aeson
import Data.Vector qualified as V
import Data.Traversable (forM)
import Data.Text qualified as Text
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.Function
import Data.Functor
import Control.Applicative
import Control.Exception
import Type.Reflection
import Control.Monad.IO.Class
import System.IO.Unsafe (unsafePerformIO)
import Data.IORef
import Data.Word

import Prettyprinter

pattern SymbolVal :: Id -> Syntax c
pattern SymbolVal v <- Symbol _ v

-- pattern LitVal :: forall {c}. Id -> Li
pattern LitIntVal :: Integer -> Syntax c
pattern LitIntVal v <- Literal _ (LitInt v)

pattern LitScientificVal :: Scientific -> Syntax c
pattern LitScientificVal v <- Literal _ (LitScientific v)

pattern LitStrVal :: Text -> Syntax c
pattern LitStrVal v <- Literal _ (LitStr v)

pattern LitBoolVal :: Bool -> Syntax c
pattern LitBoolVal v <- Literal _ (LitBool v)

pattern ListVal :: [Syntax c] -> Syntax c
pattern ListVal v <- List _ v

stringLike :: Syntax c -> Maybe String
stringLike = \case
  LitStrVal s -> Just $ Text.unpack s
  SymbolVal (Id s) -> Just $ Text.unpack s
  _ -> Nothing

textLike :: Syntax c -> Maybe Text
textLike = \case
  LitStrVal s -> Just s
  SymbolVal (Id s) -> Just s
  x -> Nothing

intLike :: Syntax c -> Maybe Integer
intLike = \case
  LitIntVal s -> Just s
  _ -> Nothing

stringLikeList :: [Syntax c] -> [String]
stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes


intLikeList :: [Syntax c] -> [Integer]
intLikeList syn = [ intLike s | s <- syn ] & takeWhile isJust & catMaybes

textLikeList :: [Syntax c] -> [Text]
textLikeList syn = [ textLike s | s <- syn ] & takeWhile isJust & catMaybes

data ByteStringSorts = ByteStringLazy LBS.ByteString | ByteStringStrict ByteString

pattern StringLike :: forall {c} . String -> Syntax c
pattern StringLike e <- (stringLike -> Just e)

pattern TextLike :: forall {c} . Text -> Syntax c
pattern TextLike e <- (textLike -> Just e)

pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
pattern StringLikeList e <- (stringLikeList -> e)


pattern TextLikeList :: forall {c} . [Text] -> [Syntax c]
pattern TextLikeList e <- (textLikeList -> e)

pattern IntLikeList :: forall {c} . [Integer] -> [Syntax c]
pattern IntLikeList e <- (intLikeList -> e)

pattern Nil :: forall {c} . Syntax c
pattern Nil <- ListVal []

pattern OpaqueVal :: forall {c} . Opaque -> Syntax c
pattern OpaqueVal box <- OpaqueValue box

-- by @qnikst, thanks, dude
pattern MatchOpaqueVal :: forall c a . (IsContext c, Typeable a) => a -> Syntax c
pattern MatchOpaqueVal o <- (OpaqueVal (fromOpaque -> Just o))

data family Context c :: Type

isOpaqueOf :: forall a c . (Typeable a, IsContext c) => Syntax c -> Maybe a
isOpaqueOf = \case
 OpaqueValue box -> fromOpaque @a box
 _ -> Nothing

isByteString :: Syntax c -> Maybe ByteStringSorts
isByteString = \case
  OpaqueValue box -> do
    let lbs = fromOpaque @LBS.ByteString box <&> ByteStringLazy
    let bs = fromOpaque @ByteString box <&> ByteStringStrict
    lbs <|> bs

  _ -> Nothing

class IsContext c where
  noContext :: Context c

data instance Context () = EmptyContext

instance IsContext () where
  noContext = EmptyContext

class HasContext c a where

class IsLiteral a where
  mkLit :: a -> Literal

class IsContext c => ToSyntax c a where
  toSyntax :: a -> Syntax c

newtype Id =
  Id Text
  deriving newtype (IsString,Pretty,Semigroup,Monoid)
  deriving stock (Data,Generic,Show,Eq,Ord)

type ForOpaque a = (Typeable a, Eq a)

data Opaque = forall a. ForOpaque a =>
  Opaque
  { opaqueProxy :: !(Proxy a)
  , opaqueId    :: !Word64
  , opaqueRep   :: !SomeTypeRep
  , opaqueDyn   :: !Dynamic
  }

opaqueIdIORef :: IORef Word64
opaqueIdIORef = unsafePerformIO (newIORef 1)
{-# NOINLINE opaqueIdIORef #-}

mkOpaque :: forall c a m . (MonadIO m, ForOpaque a) => a -> m (Syntax c)
mkOpaque x = do
  n <- liftIO $ atomicModifyIORef opaqueIdIORef (\n -> (succ n,n))
  pure $ OpaqueValue $ Opaque (Proxy :: Proxy a) n (someTypeRep (Proxy :: Proxy a)) (toDyn x)

data SyntaxTypeError =
  UnexpectedType String
  deriving stock (Show,Typeable)

instance Exception SyntaxTypeError

fromOpaque :: forall a. Typeable a => Opaque -> Maybe a
fromOpaque (Opaque{..}) = fromDynamic opaqueDyn

fromOpaqueThrow :: forall a m . (MonadIO m, Typeable a) => String -> Opaque -> m a
fromOpaqueThrow s (Opaque{..}) = do
  let o = fromDynamic @a opaqueDyn
  liftIO $ maybe (throwIO (UnexpectedType s)) pure o

instance Eq Opaque where
  (Opaque p1 _  t1 d1) == (Opaque _ _ t2 d2) =
    t1 == t2 && unpack p1 d1 == unpack p1 d2
    where
      unpack :: forall a . (Typeable a) => Proxy a -> Dynamic -> Maybe a
      unpack _ = fromDynamic @a

-- Partial Data implementation for Opaque
instance Data Opaque where
  gfoldl _ z (Opaque{..}) = z (Opaque{..})

  -- Can not be unfolded
  gunfold _ z _ = z (Opaque (Proxy :: Proxy ()) 0 (someTypeRep (Proxy :: Proxy ())) (toDyn ()))

  toConstr _ = opaqueConstr
  dataTypeOf _ = opaqueDataType

opaqueConstr :: Constr
opaqueConstr = mkConstr opaqueDataType "Opaque" [] Prefix

opaqueDataType :: DataType
opaqueDataType = mkDataType "Opaque" [opaqueConstr]


data Literal =
    LitStr   Text
  | LitInt   Integer
  | LitScientific Scientific
  | LitBool   Bool
  deriving stock (Eq,Ord,Data,Generic,Show)

instance IsLiteral Text where
  mkLit = LitStr

instance IsLiteral Bool where
  mkLit = LitBool

instance IsLiteral Integer where
  mkLit = LitInt

data C = C
         deriving stock (Eq,Ord,Show,Data,Typeable,Generic)

-- simple, yet sufficient context
--  Integer may be offset, maybe line number,
--  token number, whatever
--  it's up to parser to use this context for
--  error printing, etc
newtype instance (Context C) =
  SimpleContext { fromSimpleContext :: Maybe Integer }
  deriving stock (Eq,Ord,Show,Data,Typeable,Generic)

instance IsContext C where
  noContext = SimpleContext Nothing

data Syntax c
  = List    (Context c) [Syntax c]
  | Symbol  (Context c) Id
  | Literal (Context c) Literal
  | OpaqueValue Opaque
  deriving stock (Generic,Typeable)

instance Eq (Syntax c) where
  (==) (Literal _ a) (Literal _ b) = a == b
  (==) (Symbol _ a)  (Symbol _ b) = a == b
  (==) (List _ a)    (List _ b) = a == b
  (==) (OpaqueValue a) (OpaqueValue b) = a == b
  (==) _ _ = False

deriving instance (Data c, Data (Context c)) => Data (Syntax c)

instance Pretty (Syntax c) where
  pretty (Literal _ ast) = pretty ast
  pretty (Symbol _ s)    = pretty s
  pretty (List _ (x:xs)) = parens $ align $ sep ( fmap pretty (x:xs) )
  pretty (List _ [])     = parens mempty
  pretty (OpaqueValue v) = "#opaque:" <> viaShow (opaqueRep v) <> ":" <> pretty (opaqueId v)

instance Pretty Literal where
  pretty = \case
    LitStr s  -> dquotes (pretty s)
    LitInt i  -> pretty i
    LitScientific v  -> viaShow v

    LitBool b | b          -> "#t"
              | otherwise  -> "#f"


instance ToJSON Literal where
    toJSON (LitStr s)       = String s
    toJSON (LitInt i)       = Number (fromInteger i)
    toJSON (LitScientific s) = Number s
    toJSON (LitBool b)      = Bool b

instance ToJSON (Syntax c) where
    toJSON (OpaqueValue{}) = Null
    toJSON (Symbol _ (Id "#nil")) = Null
    toJSON (Symbol _ (Id s)) = String s
    toJSON (Literal _ l) = toJSON l
    toJSON (List _ items) =
        case items of
            (Symbol _ "object" : rest) ->
                object $ mapMaybe pairToKeyValue rest
            _ -> Array . V.fromList $ fmap toJSON items

      where
        pairToKeyValue :: Syntax c -> Maybe (Key, Value)
        pairToKeyValue (List _ [SymbolVal (Id k), SymbolVal ":", v]) = Just (fromText k .= toJSON v)
        pairToKeyValue (List _ [LitStrVal k, SymbolVal ":", v]) = Just (fromText k .= toJSON v)
        pairToKeyValue _ = Nothing


instance IsContext c => FromJSON (Syntax c) where
    parseJSON (String t) = pure $ Literal noContext (LitStr t)
    parseJSON (Number n)
        | isInteger n = pure $ Literal noContext (LitInt (floor n))
        | otherwise   = pure $ Literal noContext (LitScientific n)
    parseJSON (Bool b)  = pure $ Literal noContext (LitBool b)
    parseJSON (Array a) = List noContext <$> mapM parseJSON (V.toList a)
    parseJSON (Object o) = do
        pairs <- forM (Aeson.toList o) $ \(key, value) -> do
            valueSyntax <- parseJSON value
            pure $ List noContext [ Symbol noContext (Id (toText key))
                                  , Symbol noContext ":"
                                  , valueSyntax
                                  ]
        pure $ List noContext (Symbol noContext (Id "object") : pairs)
    parseJSON _ = fail "Cannot parse JSON to Syntax"

class MkId a where
  mkId :: a -> Id

instance MkId Text where
  mkId = Id

instance MkId String where
  mkId  = Id . Text.pack

class IsContext c => MkSym c a where
  mkSym :: a -> Syntax c

instance IsContext c => MkSym c String where
  mkSym s = Symbol noContext (Id $ Text.pack s)

instance IsContext c => MkSym c Text where
  mkSym s = Symbol noContext (Id s)

instance MkId (Text,Int) where
  mkId (p, i) = Id (p <> Text.pack (show i))

instance MkId (String,Integer) where
  mkId (p, i) = Id (Text.pack (p  <> show i))

instance IsContext c => MkSym c Id where
  mkSym = Symbol noContext

instance {-# OVERLAPPABLE #-} (IsContext c, Pretty a) => MkSym c a where
  mkSym a = Symbol noContext (mkId (show $ pretty a))

class IsContext c => MkStr c s where
  mkStr :: s -> Syntax c

instance IsContext c => MkStr c String where
  mkStr s = Literal noContext $ LitStr (Text.pack s)

instance IsContext c => MkStr c Text where
  mkStr s = Literal noContext $ LitStr s

instance IsContext c => MkStr c [Text] where
  mkStr s = mkStr $ mconcat s

instance IsContext c => MkStr c [String] where
  mkStr s = mkStr $ mconcat s

instance IsContext c => MkStr c [Doc ann] where
  mkStr s = mkStr $ show (hsep s)

mkBool :: forall c . IsContext c => Bool -> Syntax c
mkBool v = Literal noContext (LitBool v)

nil :: forall c . IsContext c => Syntax c
nil = List noContext []

class IsContext c => MkForm c a where
 mkForm :: a-> [Syntax c] -> Syntax c

instance (IsContext c, MkSym c s) => MkForm c s where
 mkForm s sy = List noContext ( mkSym @c s :  sy )

mkList :: forall c. IsContext c => [Syntax c] -> Syntax c
mkList = List noContext

class IsContext c => MkInt c s where
  mkInt :: s -> Syntax c

class IsContext c => MkDouble c s where
  mkDouble :: s -> Syntax c

instance (IsContext c, RealFrac s) => MkDouble c s where
  mkDouble v = Literal noContext $ LitScientific (realToFrac v)

instance (Integral i, IsContext c) => MkInt c i where
  mkInt n = Literal noContext $ LitInt (fromIntegral n)

class MkSyntax c a where
  mkSyntax :: a -> Syntax c

instance IsContext c => MkSyntax c (Syntax c) where
  mkSyntax = id

instance IsContext c => MkSyntax c Value where
  mkSyntax Null = nil
  mkSyntax (Number n) = mkDouble n
  mkSyntax (String n) = mkStr n
  mkSyntax (Bool b) = mkBool b
  mkSyntax (Array ns) = mkList [ mkSyntax n | n <- V.toList ns]
  mkSyntax (Object kv) = mkList [ mkList [mkSym (Aeson.toText k), mkSyntax v] | (k,v) <- Aeson.toList kv]



synToText :: forall c . IsContext c => Syntax c -> Text
synToText = \case
  ListVal  xs        -> foldMap synToText xs
  TextLike  x        -> x
  LitIntVal x        -> Text.pack (show x)
  LitScientificVal x -> Text.pack (show x)
  LitBoolVal f       -> Text.pack (show (pretty f))
  OpaqueValue{}      -> Text.pack "#opaque"
{-# COMPLETE ListVal, TextLike, LitIntVal, LitScientificVal, LitBoolVal, OpaqueValue #-}