{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE PatternSynonyms #-}

module Data.UCL
( UCL(..)
, parseString
, parseFile
) where

import Foreign.C
import Foreign.Ptr
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Text.Foreign as TF
import Data.Text (Text)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Time.Clock (DiffTime)


newtype ParserHandle = ParserHandle (Ptr ())
newtype UCLObjectHandle = UCLObjectHandle (Ptr ())
newtype UCLIterHandle = UCLIterHandle (Ptr ())


foreign import ccall "ucl_parser_new" ucl_parser_new :: CInt -> IO ParserHandle
foreign import ccall "ucl_parser_add_string" ucl_parser_add_string :: ParserHandle -> CString -> CUInt -> IO Bool
foreign import ccall "ucl_parser_add_file" ucl_parser_add_file :: ParserHandle -> CString -> IO Bool
foreign import ccall "ucl_parser_get_object" ucl_parser_get_object :: ParserHandle -> IO UCLObjectHandle
foreign import ccall "ucl_parser_get_error" ucl_parser_get_error :: ParserHandle -> IO CString

foreign import ccall "ucl_object_iterate_new" ucl_object_iterate_new :: UCLObjectHandle -> IO UCLIterHandle
foreign import ccall "ucl_object_iterate_safe" ucl_object_iterate_safe :: UCLIterHandle -> Bool -> IO UCLObjectHandle
foreign import ccall "ucl_object_type" ucl_object_type :: UCLObjectHandle -> UCL_TYPE
foreign import ccall "ucl_object_key" ucl_object_key :: UCLObjectHandle -> CString
foreign import ccall "ucl_object_toint" ucl_object_toint :: UCLObjectHandle -> CInt
foreign import ccall "ucl_object_todouble" ucl_object_todouble :: UCLObjectHandle -> CDouble
foreign import ccall "ucl_object_tostring" ucl_object_tostring :: UCLObjectHandle -> CString
foreign import ccall "ucl_object_toboolean" ucl_object_toboolean :: UCLObjectHandle -> Bool

foreign import ccall "strlen" c_strlen :: CString -> IO CSize


type UCL_TYPE = CUInt
pattern UCL_OBJECT :: UCL_TYPE
pattern UCL_OBJECT = 0
pattern UCL_ARRAY :: UCL_TYPE
pattern UCL_ARRAY = 1
pattern UCL_INT :: UCL_TYPE
pattern UCL_INT = 2
pattern UCL_FLOAT :: UCL_TYPE
pattern UCL_FLOAT = 3
pattern UCL_STRING :: UCL_TYPE
pattern UCL_STRING = 4
pattern UCL_BOOLEAN :: UCL_TYPE
pattern UCL_BOOLEAN = 5
pattern UCL_TIME :: UCL_TYPE
pattern UCL_TIME = 6
pattern UCL_USERDATA :: UCL_TYPE
pattern UCL_USERDATA = 7
pattern UCL_NULL :: UCL_TYPE
pattern UCL_NULL = 8

peekCStringText :: CString -> IO Text
peekCStringText cstr = do
  len <- c_strlen cstr
  TF.peekCStringLen (cstr, fromIntegral len)


parseString' :: String -> IO (Either String UCLObjectHandle)
parseString' s = do
    cs <- newCString s
    p <- ucl_parser_new 0x0
    didParse <- ucl_parser_add_string p cs $ fromIntegral $ length s
    if didParse 
    then Right <$> ucl_parser_get_object p
    else Left <$> (ucl_parser_get_error p >>= peekCString)

parseFile' :: FilePath -> IO (Either String UCLObjectHandle)
parseFile' s = do
    cs <- newCString s
    p <- ucl_parser_new 0x0
    didParse <- ucl_parser_add_file p cs
    if didParse 
    then Right <$> ucl_parser_get_object p
    else Left <$> (ucl_parser_get_error p >>= peekCString)

-- TODO use Text or ByteString
-- | Parse a 'String' into a 'UCL', resolving includes, macros, variables...
--
-- >>> parseString "{a: [1,2], b: 3min, a: [4]}"
-- Right (UCLMap (fromList
--   [ (UCLText "a", UCLArray [UCLInt 1, UCLInt 2, UCLInt 4])
--   , (UCLText "b", UCLTime 180s                           )
--   ]))
--
-- This function is __not__ safe to call on untrusted input: configurations can
-- read files, make http requests, do "billion laughs" attacks, and possibly
-- crash the parser.
parseString :: String -> IO (Either String UCL)
parseString = fmap (fmap handleToUCL) . parseString'

-- | Parse the contents of a file into a 'UCL', resolving includes, macros,
-- variables...
--
-- This function is __not__ safe to call on untrusted input: configurations can
-- read files, make http requests, do "billion laughs" attacks, and possibly
-- crash the parser.
parseFile :: FilePath -> IO (Either String UCL)
parseFile = fmap (fmap handleToUCL) . parseFile'

-- | An UCL object
data UCL = UCLMap (Map UCL UCL)
         | UCLArray [UCL]
         | UCLInt Int
         | UCLDouble Double
         | UCLText Text
         | UCLBool Bool
         | UCLTime DiffTime
  deriving (Show, Eq, Ord)

handleToUCL :: UCLObjectHandle -> UCL
handleToUCL o = typedHandleToUCL (ucl_object_type o) o

typedHandleToUCL :: UCL_TYPE -> UCLObjectHandle -> UCL
typedHandleToUCL UCL_OBJECT   obj = UCLMap $ uclObjectToVector obj
typedHandleToUCL UCL_ARRAY    obj = UCLArray $ uclArrayToList obj
typedHandleToUCL UCL_INT      obj = UCLInt $ fromIntegral $ ucl_object_toint obj
typedHandleToUCL UCL_FLOAT    obj = UCLDouble $ realToFrac $ ucl_object_todouble obj
typedHandleToUCL UCL_STRING   obj = UCLText $ unsafePerformIO $ peekCStringText $ ucl_object_tostring obj
typedHandleToUCL UCL_BOOLEAN  obj = UCLBool $ ucl_object_toboolean obj
typedHandleToUCL UCL_TIME     obj = UCLTime $ realToFrac $ ucl_object_todouble obj
typedHandleToUCL UCL_USERDATA _   = error "Userdata object"
typedHandleToUCL UCL_NULL     _   = error "Null object"
typedHandleToUCL _            _   = error "Unknown Type"

uclObjectToVector :: UCLObjectHandle -> Map UCL UCL
uclObjectToVector o = unsafePerformIO $ do
  iter <- ucl_object_iterate_new o
  go iter Map.empty
  where 
    go it m = do
      obj <- ucl_object_iterate_safe it True
      case ucl_object_type obj of
        UCL_NULL -> pure m
        _        -> go it $ Map.insert (getUclKey obj) (handleToUCL obj) m
    getUclKey obj = UCLText $ unsafePerformIO $ peekCStringText $ ucl_object_key obj

uclArrayToList :: UCLObjectHandle -> [UCL]
uclArrayToList o = unsafePerformIO $ do
  iter <- ucl_object_iterate_new o
  go iter
  where 
    go it = do
      obj <- ucl_object_iterate_safe it True
      case ucl_object_type obj of
        UCL_NULL -> pure []
        _        -> (handleToUCL obj :) <$> go it