{-# OPTIONS_GHC -Wno-partial-fields #-}

-- | define syntax
module Data.Serde.Internal.Syn
  ( -- * parsing
    Parsed (..),
    parse,
    parsetypeexts,

    -- * syntax
    Syn (..),
    SynFld (..),
    ViaInfo (..),

    -- * re-export
    Name,
    Type,
  )
where

import Data.Serde.Internal.ISyn
import Language.Haskell.Exts.Simple.Extension
import Language.Haskell.Exts.Simple.Parser hiding (parse)
import Language.Haskell.Exts.Simple.Syntax
import Text.Megaparsec qualified as M

-- | parsed data
data Parsed = Parsed
  { Parsed -> [Syn]
declarations :: [Syn],
    Parsed -> Derive
derives :: Derive
  }
  deriving (Int -> Parsed -> ShowS
[Parsed] -> ShowS
Parsed -> String
(Int -> Parsed -> ShowS)
-> (Parsed -> String) -> ([Parsed] -> ShowS) -> Show Parsed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Parsed -> ShowS
showsPrec :: Int -> Parsed -> ShowS
$cshow :: Parsed -> String
show :: Parsed -> String
$cshowList :: [Parsed] -> ShowS
showList :: [Parsed] -> ShowS
Show)

-- | a declaration
data Syn
  = SynData
      { Syn -> Name
synnam :: Name, -- type/con name
        Syn -> [SynFld]
synflds :: [SynFld], -- fields
        Syn -> [Name]
synders :: [Name] -- deriving classes
      }
  | SynNewtype
      { synnam :: Name,
        Syn -> Either ViaInfo SynFld
synfld :: Either ViaInfo SynFld,
        synders :: [Name]
      }
  | SynAlias
      { synnam :: Name,
        Syn -> Type
syndest :: Type -- destination type
      }
  deriving (Int -> Syn -> ShowS
[Syn] -> ShowS
Syn -> String
(Int -> Syn -> ShowS)
-> (Syn -> String) -> ([Syn] -> ShowS) -> Show Syn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Syn -> ShowS
showsPrec :: Int -> Syn -> ShowS
$cshow :: Syn -> String
show :: Syn -> String
$cshowList :: [Syn] -> ShowS
showList :: [Syn] -> ShowS
Show)

-- | field information
data SynFld = SynFld
  { SynFld -> Name
synfnam :: Name, -- field name
    SynFld -> Type
synftyp :: Type, -- target type
    SynFld -> Maybe Type
synfvia :: Maybe Type -- via type if any
  }
  deriving (Int -> SynFld -> ShowS
[SynFld] -> ShowS
SynFld -> String
(Int -> SynFld -> ShowS)
-> (SynFld -> String) -> ([SynFld] -> ShowS) -> Show SynFld
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SynFld -> ShowS
showsPrec :: Int -> SynFld -> ShowS
$cshow :: SynFld -> String
show :: SynFld -> String
$cshowList :: [SynFld] -> ShowS
showList :: [SynFld] -> ShowS
Show)

-- we use a parser that's independent of GHC's parser
-- so we declare our own extensions
pm1 :: ParseMode
pm1 :: ParseMode
pm1 =
  ParseMode
defaultParseMode
    { extensions =
        [ EnableExtension DataKinds,
          EnableExtension TypeApplications
        ]
    }

-- | go from type string to 'Exts'.'Type'
--
-- you need to use a function from "Data.Serde.Type" to convert this to a TH.'TH.Type'
parsetypeexts :: String -> Type
parsetypeexts :: String -> Type
parsetypeexts String
s = case ParseMode -> String -> ParseResult Type
parseTypeWithMode ParseMode
pm1 String
s of
  ParseOk Type
x -> Type
x
  ParseFailed SrcLoc
_ String
e -> String -> Type
forall a. HasCallStack => String -> a
error (String -> Type) -> String -> Type
forall a b. (a -> b) -> a -> b
$ String
"parsetypeexts: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
e

-- | convert intermediate syntax to syntax
fromisyn :: Derive -> ISyn -> Syn
fromisyn :: Derive -> ISyn -> Syn
fromisyn Derive
der0 = do
  let der :: [Name]
der = Derive -> [Name]
fromderive Derive
der0
  \case
    ISynData String
n [ISynFld]
fs -> Name -> [SynFld] -> [Name] -> Syn
SynData (String -> Name
name String
n) ((ISynFld -> SynFld) -> [ISynFld] -> [SynFld]
forall a b. (a -> b) -> [a] -> [b]
map ISynFld -> SynFld
fromisynfld [ISynFld]
fs) [Name]
der
    ISynNewtype String
n (IField ISynFld
f) ->
      Name -> Either ViaInfo SynFld -> [Name] -> Syn
SynNewtype (String -> Name
name String
n) (SynFld -> Either ViaInfo SynFld
forall a b. b -> Either a b
Right (ISynFld -> SynFld
fromisynfld ISynFld
f)) [Name]
der
    ISynNewtype String
n (IType ViaInfo
v) -> case ViaInfo -> Either Type (Type, Type)
fromviainfo ViaInfo
v of
      Left Type
_ -> Name -> Either ViaInfo SynFld -> [Name] -> Syn
SynNewtype (String -> Name
name String
n) (ViaInfo -> Either ViaInfo SynFld
forall a b. a -> Either a b
Left ViaInfo
v) [Name]
der
      Right (Type
s, Type
u) ->
        Name -> Either ViaInfo SynFld -> [Name] -> Syn
SynNewtype (String -> Name
name String
n) (SynFld -> Either ViaInfo SynFld
forall a b. b -> Either a b
Right (Name -> Type -> Maybe Type -> SynFld
SynFld (String -> Name
name String
n) Type
s (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
u))) [Name]
der
    ISynAlias String
n String
d -> Name -> Type -> Syn
SynAlias (String -> Name
name String
n) (String -> Type
parsetypeexts String
d)
  where
    name :: String -> Name
name = String -> Name
Ident
    fromderive :: Derive -> [Name]
fromderive = (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Name
name ([String] -> [Name]) -> (Derive -> [String]) -> Derive -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Derive -> [String]
getderive
    fromisynfld :: ISynFld -> SynFld
fromisynfld (ISynFld String
n ViaInfo
t) = case ViaInfo -> Either Type (Type, Type)
fromviainfo ViaInfo
t of
      Left Type
v -> Name -> Type -> Maybe Type -> SynFld
SynFld (String -> Name
name String
n) Type
v Maybe Type
forall a. Maybe a
Nothing
      Right (Type
s, Type
u) -> Name -> Type -> Maybe Type -> SynFld
SynFld (String -> Name
name String
n) Type
s (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
u)
    fromviainfo :: ViaInfo -> Either Type (Type, Type)
fromviainfo (Plain String
t) = Type -> Either Type (Type, Type)
forall a b. a -> Either a b
Left (String -> Type
parsetypeexts String
t)
    fromviainfo (WithVia String
t String
s) = (Type, Type) -> Either Type (Type, Type)
forall a b. b -> Either a b
Right (String -> Type
parsetypeexts String
t, String -> Type
parsetypeexts String
s)

-- | parse quasi-quoted syntax
parse :: String -> Either String Parsed
parse :: String -> Either String Parsed
parse String
s =
  let res :: Either (ParseErrorBundle String Void) (Derive, [ISyn])
res = Parsec Void String (Derive, [ISyn])
-> String
-> String
-> Either (ParseErrorBundle String Void) (Derive, [ISyn])
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
M.runParser (Parsec Void String (Derive, [ISyn])
parsetop Parsec Void String (Derive, [ISyn])
-> ParsecT Void String Identity ()
-> Parsec Void String (Derive, [ISyn])
forall a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
M.eof) String
"" String
s
   in case Either (ParseErrorBundle String Void) (Derive, [ISyn])
res of
        Right (Derive
de, (ISyn -> Syn) -> [ISyn] -> [Syn]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Derive -> ISyn -> Syn
fromisyn Derive
de) -> [Syn]
ds) ->
          Parsed -> Either String Parsed
forall a b. b -> Either a b
Right (Parsed -> Either String Parsed) -> Parsed -> Either String Parsed
forall a b. (a -> b) -> a -> b
$ [Syn] -> Derive -> Parsed
Parsed [Syn]
ds Derive
de
        Left ParseErrorBundle String Void
e -> String -> Either String Parsed
forall a b. a -> Either a b
Left (String -> Either String Parsed) -> String -> Either String Parsed
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
M.errorBundlePretty ParseErrorBundle String Void
e