{-| Utilities to manipulate Haskell AST -}
module Proto3.Suite.DotProto.Generate.Syntax where

import Language.Haskell.Syntax

haskellName, jsonpbName, grpcName, lrName, protobufName, protobufASTName, proxyName :: String -> HsQName
haskellName :: String -> HsQName
haskellName  String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"Hs")         (String -> HsName
HsIdent String
name)
jsonpbName :: String -> HsQName
jsonpbName   String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"HsJSONPB")   (String -> HsName
HsIdent String
name)
grpcName :: String -> HsQName
grpcName     String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"HsGRPC")     (String -> HsName
HsIdent String
name)
lrName :: String -> HsQName
lrName       String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"LR")         (String -> HsName
HsIdent String
name)
protobufName :: String -> HsQName
protobufName String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"HsProtobuf") (String -> HsName
HsIdent String
name)
protobufASTName :: String -> HsQName
protobufASTName String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"HsProtobufAST") (String -> HsName
HsIdent String
name)
proxyName :: String -> HsQName
proxyName    String
name = Module -> HsName -> HsQName
Qual (String -> Module
Module String
"Proxy")      (String -> HsName
HsIdent String
name)

haskellNS :: Module
haskellNS :: Module
haskellNS = String -> Module
Module String
"Hs"

--------------------------------------------------------------------------------
--
-- * Wrappers around haskell-src-exts constructors
--

apply :: HsExp -> [HsExp] -> HsExp
apply :: HsExp -> [HsExp] -> HsExp
apply HsExp
f = HsExp -> HsExp
paren (HsExp -> HsExp) -> ([HsExp] -> HsExp) -> [HsExp] -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsExp -> HsExp -> HsExp) -> HsExp -> [HsExp] -> HsExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsExp -> HsExp -> HsExp
HsApp HsExp
f

maybeModify :: HsExp -> Maybe HsExp -> HsExp
maybeModify :: HsExp -> Maybe HsExp -> HsExp
maybeModify HsExp
x Maybe HsExp
Nothing = HsExp
x
maybeModify HsExp
x (Just HsExp
f) = HsExp -> HsExp
paren (HsExp -> HsExp -> HsExp
HsApp HsExp
f (HsExp -> HsExp
paren HsExp
x))

paren :: HsExp -> HsExp
paren :: HsExp -> HsExp
paren e :: HsExp
e@(HsParen HsExp
_) = HsExp
e
paren HsExp
e = HsExp -> HsExp
HsParen HsExp
e

applicativeApply :: HsExp -> [HsExp] -> HsExp
applicativeApply :: HsExp -> [HsExp] -> HsExp
applicativeApply HsExp
f = (HsExp -> HsExp -> HsExp) -> HsExp -> [HsExp] -> HsExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsExp -> HsExp -> HsExp
snoc HsExp
nil
  where
    nil :: HsExp
nil = HsExp -> HsExp -> HsExp
HsApp HsExp
pureE HsExp
f

    snoc :: HsExp -> HsExp -> HsExp
snoc HsExp
g HsExp
x = HsExp -> HsQOp -> HsExp -> HsExp
HsInfixApp HsExp
g HsQOp
apOp HsExp
x

tyApp :: HsType -> [HsType] -> HsType
tyApp :: HsType -> [HsType] -> HsType
tyApp = (HsType -> HsType -> HsType) -> HsType -> [HsType] -> HsType
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HsType -> HsType -> HsType
HsTyApp

module_ :: Module -> Maybe [HsExportSpec] -> [HsImportDecl] -> [HsDecl] -> HsModule
module_ :: Module
-> Maybe [HsExportSpec] -> [HsImportDecl] -> [HsDecl] -> HsModule
module_ = SrcLoc
-> Module
-> Maybe [HsExportSpec]
-> [HsImportDecl]
-> [HsDecl]
-> HsModule
HsModule SrcLoc
defaultSrcLoc

importDecl_ :: Module -> Bool -> Maybe Module -> Maybe (Bool, [HsImportSpec]) -> HsImportDecl
importDecl_ :: Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
importDecl_ = SrcLoc
-> Module
-> Bool
-> Maybe Module
-> Maybe (Bool, [HsImportSpec])
-> HsImportDecl
HsImportDecl SrcLoc
defaultSrcLoc

dataDecl_ :: String -> [HsConDecl] -> [HsQName] -> HsDecl
dataDecl_ :: String -> [HsConDecl] -> [HsQName] -> HsDecl
dataDecl_ String
messageName [constructor :: HsConDecl
constructor@(HsRecDecl SrcLoc
_ HsName
_ [([HsName], HsBangType)
_])] =
  SrcLoc
-> HsContext
-> HsName
-> [HsName]
-> HsConDecl
-> [HsQName]
-> HsDecl
HsNewTypeDecl SrcLoc
defaultSrcLoc [] (String -> HsName
HsIdent String
messageName) [] HsConDecl
constructor
dataDecl_ String
messageName [HsConDecl]
constructors =
  SrcLoc
-> HsContext
-> HsName
-> [HsName]
-> [HsConDecl]
-> [HsQName]
-> HsDecl
HsDataDecl SrcLoc
defaultSrcLoc [] (String -> HsName
HsIdent String
messageName) [] [HsConDecl]
constructors

recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl
recDecl_ :: HsName -> [([HsName], HsBangType)] -> HsConDecl
recDecl_ = SrcLoc -> HsName -> [([HsName], HsBangType)] -> HsConDecl
HsRecDecl SrcLoc
defaultSrcLoc

conDecl_ :: HsName -> [HsBangType] -> HsConDecl
conDecl_ :: HsName -> [HsBangType] -> HsConDecl
conDecl_ = SrcLoc -> HsName -> [HsBangType] -> HsConDecl
HsConDecl SrcLoc
defaultSrcLoc

instDecl_ :: HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ :: HsQName -> [HsType] -> [HsDecl] -> HsDecl
instDecl_ = SrcLoc -> HsContext -> HsQName -> [HsType] -> [HsDecl] -> HsDecl
HsInstDecl SrcLoc
defaultSrcLoc []

match_ :: HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ :: HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
match_ = SrcLoc -> HsName -> [HsPat] -> HsRhs -> [HsDecl] -> HsMatch
HsMatch SrcLoc
defaultSrcLoc

unqual_ :: String -> HsQName
unqual_ :: String -> HsQName
unqual_ = HsName -> HsQName
UnQual (HsName -> HsQName) -> (String -> HsName) -> String -> HsQName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsName
HsIdent

uvar_ :: String -> HsExp
uvar_ :: String -> HsExp
uvar_ = HsQName -> HsExp
HsVar (HsQName -> HsExp) -> (String -> HsQName) -> String -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
unqual_

protobufType_, primType_, protobufStringType_, protobufBytesType_ :: String -> HsType
protobufType_ :: String -> HsType
protobufType_ = HsQName -> HsType
HsTyCon (HsQName -> HsType) -> (String -> HsQName) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
protobufName
primType_ :: String -> HsType
primType_ = HsQName -> HsType
HsTyCon (HsQName -> HsType) -> (String -> HsQName) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
haskellName
protobufStringType_ :: String -> HsType
protobufStringType_ = HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"String") (HsType -> HsType) -> (String -> HsType) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsQName -> HsType
HsTyCon (HsQName -> HsType) -> (String -> HsQName) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
haskellName
protobufBytesType_ :: String -> HsType
protobufBytesType_ = HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Bytes") (HsType -> HsType) -> (String -> HsType) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsQName -> HsType
HsTyCon (HsQName -> HsType) -> (String -> HsQName) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
haskellName

protobufFixedType_, protobufSignedType_, protobufWrappedType_ :: HsType -> HsType
protobufFixedType_ :: HsType -> HsType
protobufFixedType_ = HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Fixed")
protobufSignedType_ :: HsType -> HsType
protobufSignedType_ = HsType -> HsType -> HsType
HsTyApp (String -> HsType
protobufType_ String
"Signed")
protobufWrappedType_ :: HsType -> HsType
protobufWrappedType_ = HsType -> HsType -> HsType
HsTyApp (HsQName -> HsType
HsTyCon (String -> HsQName
protobufName String
"Wrapped"))

type_ :: String -> HsType
type_ :: String -> HsType
type_ = HsQName -> HsType
HsTyCon (HsQName -> HsType) -> (String -> HsQName) -> String -> HsType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsQName
unqual_

patVar :: String -> HsPat
patVar :: String -> HsPat
patVar =  HsName -> HsPat
HsPVar (HsName -> HsPat) -> (String -> HsName) -> String -> HsPat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsName
HsIdent

alt_ :: HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
alt_ :: HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
alt_ = SrcLoc -> HsPat -> HsGuardedAlts -> [HsDecl] -> HsAlt
HsAlt SrcLoc
defaultSrcLoc

str_ :: String -> HsExp
str_ :: String -> HsExp
str_ = HsLiteral -> HsExp
HsLit (HsLiteral -> HsExp) -> (String -> HsLiteral) -> String -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsLiteral
HsString

-- | For some reason, haskell-src-exts needs this 'SrcLoc' parameter
--   for some data constructors. Its value does not affect
--   pretty-printed output
defaultSrcLoc :: SrcLoc
defaultSrcLoc :: SrcLoc
defaultSrcLoc = String -> Int -> Int -> SrcLoc
SrcLoc String
"<generated>" Int
0 Int
0

--------------------------------------------------------------------------------
--
-- * Common Haskell expressions, constructors, and operators
--

dotProtoFieldC, primC, repeatedC, nestedRepeatedC, namedC, mapC,
  fieldNumberC, singleC, dotsC, pathC, qualifiedC, anonymousC, dotProtoOptionC,
  identifierC, stringLitC, intLitC, floatLitC, boolLitC, trueC, falseC, nothingC,
  justC, forceEmitC,  encodeMessageFieldE, fromStringE, decodeMessageFieldE,
  pureE, returnE, mappendE, memptyE, msumE, atE, oneofE, fmapE :: HsExp

dotProtoFieldC :: HsExp
dotProtoFieldC       = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"DotProtoField")
primC :: HsExp
primC                = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"Prim")
repeatedC :: HsExp
repeatedC            = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"Repeated")
nestedRepeatedC :: HsExp
nestedRepeatedC      = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"NestedRepeated")
namedC :: HsExp
namedC               = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"Named")
mapC :: HsExp
mapC                 = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"Map")
fieldNumberC :: HsExp
fieldNumberC         = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"FieldNumber")
singleC :: HsExp
singleC              = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"Single")
pathC :: HsExp
pathC                = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"Path")
dotsC :: HsExp
dotsC                = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"Dots")
qualifiedC :: HsExp
qualifiedC           = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"Qualified")
anonymousC :: HsExp
anonymousC           = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"Anonymous")
dotProtoOptionC :: HsExp
dotProtoOptionC      = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"DotProtoOption")
identifierC :: HsExp
identifierC          = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"Identifier")
stringLitC :: HsExp
stringLitC           = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"StringLit")
intLitC :: HsExp
intLitC              = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"IntLit")
floatLitC :: HsExp
floatLitC            = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"FloatLit")
boolLitC :: HsExp
boolLitC             = HsQName -> HsExp
HsVar (String -> HsQName
protobufASTName String
"BoolLit")
forceEmitC :: HsExp
forceEmitC           = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"ForceEmit")
encodeMessageFieldE :: HsExp
encodeMessageFieldE  = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"encodeMessageField")
decodeMessageFieldE :: HsExp
decodeMessageFieldE  = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"decodeMessageField")
atE :: HsExp
atE                  = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"at")
oneofE :: HsExp
oneofE               = HsQName -> HsExp
HsVar (String -> HsQName
protobufName String
"oneof")

trueC :: HsExp
trueC                = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"True")
falseC :: HsExp
falseC               = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"False")
nothingC :: HsExp
nothingC             = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"Nothing")
justC :: HsExp
justC                = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"Just")
fromStringE :: HsExp
fromStringE          = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"fromString")
pureE :: HsExp
pureE                = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"pure")
returnE :: HsExp
returnE              = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"return")
mappendE :: HsExp
mappendE             = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"mappend")
memptyE :: HsExp
memptyE              = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"mempty")
msumE :: HsExp
msumE                = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"msum")
fmapE :: HsExp
fmapE                = HsQName -> HsExp
HsVar (String -> HsQName
haskellName String
"fmap")

apOp :: HsQOp
apOp :: HsQOp
apOp  = HsQName -> HsQOp
HsQVarOp (HsName -> HsQName
UnQual (String -> HsName
HsSymbol String
"<*>"))

fmapOp :: HsQOp
fmapOp :: HsQOp
fmapOp  = HsQName -> HsQOp
HsQVarOp (HsName -> HsQName
UnQual (String -> HsName
HsSymbol String
"<$>"))

composeOp :: HsQOp
composeOp :: HsQOp
composeOp = HsQName -> HsQOp
HsQVarOp (Module -> HsName -> HsQName
Qual Module
haskellNS (String -> HsName
HsSymbol String
"."))

bindOp :: HsQOp
bindOp :: HsQOp
bindOp = HsQName -> HsQOp
HsQVarOp (Module -> HsName -> HsQName
Qual Module
haskellNS (String -> HsName
HsSymbol String
">>="))

altOp :: HsQOp
altOp :: HsQOp
altOp = HsQName -> HsQOp
HsQVarOp (HsName -> HsQName
UnQual (String -> HsName
HsSymbol String
"<|>"))

toJSONPBOp :: HsQOp
toJSONPBOp :: HsQOp
toJSONPBOp = HsQName -> HsQOp
HsQVarOp (HsName -> HsQName
UnQual (String -> HsName
HsSymbol String
".="))

parseJSONPBOp :: HsQOp
parseJSONPBOp :: HsQOp
parseJSONPBOp = HsQName -> HsQOp
HsQVarOp (HsName -> HsQName
UnQual (String -> HsName
HsSymbol String
".:"))

neConsOp :: HsQOp
neConsOp :: HsQOp
neConsOp = HsQName -> HsQOp
HsQVarOp (Module -> HsName -> HsQName
Qual Module
haskellNS (String -> HsName
HsSymbol String
":|"))

intE :: Integral a => a -> HsExp
intE :: a -> HsExp
intE a
x = (if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then HsExp -> HsExp
HsParen else HsExp -> HsExp
forall a. a -> a
id) (HsExp -> HsExp) -> (a -> HsExp) -> a -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsLiteral -> HsExp
HsLit (HsLiteral -> HsExp) -> (a -> HsLiteral) -> a -> HsExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> HsLiteral
HsInt (Integer -> HsLiteral) -> (a -> Integer) -> a -> HsLiteral
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> HsExp) -> a -> HsExp
forall a b. (a -> b) -> a -> b
$ a
x

intP :: Integral a => a -> HsPat
intP :: a -> HsPat
intP a
x = (if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then HsPat -> HsPat
HsPParen else HsPat -> HsPat
forall a. a -> a
id) (HsPat -> HsPat) -> (a -> HsPat) -> a -> HsPat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsLiteral -> HsPat
HsPLit (HsLiteral -> HsPat) -> (a -> HsLiteral) -> a -> HsPat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> HsLiteral
HsInt (Integer -> HsLiteral) -> (a -> Integer) -> a -> HsLiteral
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> HsPat) -> a -> HsPat
forall a b. (a -> b) -> a -> b
$ a
x