module Hydra.Ext.Haskell.Serde where
import Hydra.Util.Codetree.Script
import qualified Hydra.Util.Codetree.Ast as CT
import qualified Hydra.Ext.Haskell.Ast as H
import Hydra.Ext.Haskell.Operators
import qualified Data.Char as C
import qualified Data.List as L
import qualified Data.Maybe as Y
class ToTree a where
toTree :: a -> CT.Expr
instance ToTree H.Alternative where
toTree :: Alternative -> Expr
toTree (H.Alternative Pattern
pat CaseRhs
rhs Maybe LocalBindings
_) = Op -> Expr -> Expr -> Expr
ifx Op
caseOp (forall a. ToTree a => a -> Expr
toTree Pattern
pat) (forall a. ToTree a => a -> Expr
toTree CaseRhs
rhs)
instance ToTree H.CaseRhs where
toTree :: CaseRhs -> Expr
toTree (H.CaseRhs Expression
expr) = forall a. ToTree a => a -> Expr
toTree Expression
expr
instance ToTree H.Constructor where
toTree :: Constructor -> Expr
toTree Constructor
cons = case Constructor
cons of
H.ConstructorOrdinary (H.Constructor_Ordinary Name
name [Type]
types) -> [Expr] -> Expr
spaceSep [
forall a. ToTree a => a -> Expr
toTree Name
name,
[Expr] -> Expr
spaceSep (forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
types)]
H.ConstructorRecord (H.Constructor_Record Name
name [FieldWithComments]
fields) -> [Expr] -> Expr
spaceSep [
forall a. ToTree a => a -> Expr
toTree Name
name,
BlockStyle -> [Expr] -> Expr
curlyBracesList BlockStyle
halfBlockStyle (forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldWithComments]
fields)]
instance ToTree H.ConstructorWithComments where
toTree :: ConstructorWithComments -> Expr
toTree (H.ConstructorWithComments Constructor
body Maybe String
mc) = case Maybe String
mc of
Maybe String
Nothing -> forall a. ToTree a => a -> Expr
toTree Constructor
body
Just String
c -> [Expr] -> Expr
newlineSep [String -> Expr
cst forall a b. (a -> b) -> a -> b
$ String -> String
toHaskellComments String
c, forall a. ToTree a => a -> Expr
toTree Constructor
body]
instance ToTree H.DataDeclaration_Keyword where
toTree :: DataDeclaration_Keyword -> Expr
toTree DataDeclaration_Keyword
kw = case DataDeclaration_Keyword
kw of
DataDeclaration_Keyword
H.DataDeclaration_KeywordData -> String -> Expr
cst String
"data"
DataDeclaration_Keyword
H.DataDeclaration_KeywordNewtype -> String -> Expr
cst String
"newtype"
instance ToTree H.Declaration where
toTree :: Declaration -> Expr
toTree Declaration
decl = case Declaration
decl of
H.DeclarationData (H.DataDeclaration DataDeclaration_Keyword
kw [Assertion]
_ DeclarationHead
hd [ConstructorWithComments]
cons [Deriving]
deriv) -> Expr -> [Expr] -> Expr
indentBlock ([Expr] -> Expr
spaceSep [forall a. ToTree a => a -> Expr
toTree DataDeclaration_Keyword
kw, forall a. ToTree a => a -> Expr
toTree DeclarationHead
hd, String -> Expr
cst String
"="]) forall a b. (a -> b) -> a -> b
$
[Expr
constructors]
forall a. [a] -> [a] -> [a]
++ if forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Name]
derivCat then [] else [[Expr] -> Expr
spaceSep [String -> Expr
cst String
"deriving", Bool -> [Expr] -> Expr
parenList Bool
False (forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
derivCat)]]
where
derivCat :: [Name]
derivCat = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat forall a b. (a -> b) -> a -> b
$ Deriving -> [Name]
h forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Deriving]
deriv
where
h :: Deriving -> [Name]
h (H.Deriving [Name]
names) = [Name]
names
constructors :: Expr
constructors = BlockStyle -> [Expr] -> Expr
orSep BlockStyle
halfBlockStyle (forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorWithComments]
cons)
H.DeclarationType (H.TypeDeclaration DeclarationHead
hd Type
typ) -> [Expr] -> Expr
spaceSep [String -> Expr
cst String
"type", forall a. ToTree a => a -> Expr
toTree DeclarationHead
hd, String -> Expr
cst String
"=", forall a. ToTree a => a -> Expr
toTree Type
typ]
H.DeclarationValueBinding ValueBinding
vb -> forall a. ToTree a => a -> Expr
toTree ValueBinding
vb
H.DeclarationTypedBinding (H.TypedBinding (H.TypeSignature Name
name Type
htype) ValueBinding
vb) -> [Expr] -> Expr
newlineSep [
Op -> Expr -> Expr -> Expr
ifx Op
typeOp (forall a. ToTree a => a -> Expr
toTree Name
name) (forall a. ToTree a => a -> Expr
toTree Type
htype),
forall a. ToTree a => a -> Expr
toTree ValueBinding
vb]
instance ToTree H.DeclarationHead where
toTree :: DeclarationHead -> Expr
toTree DeclarationHead
hd = case DeclarationHead
hd of
H.DeclarationHeadApplication (H.DeclarationHead_Application DeclarationHead
fun Variable
op) -> [Expr] -> Expr
spaceSep [forall a. ToTree a => a -> Expr
toTree DeclarationHead
fun, forall a. ToTree a => a -> Expr
toTree Variable
op]
H.DeclarationHeadSimple Name
name -> forall a. ToTree a => a -> Expr
toTree Name
name
instance ToTree H.DeclarationWithComments where
toTree :: DeclarationWithComments -> Expr
toTree (H.DeclarationWithComments Declaration
body Maybe String
mc) = case Maybe String
mc of
Maybe String
Nothing -> forall a. ToTree a => a -> Expr
toTree Declaration
body
Just String
c -> [Expr] -> Expr
newlineSep [String -> Expr
cst forall a b. (a -> b) -> a -> b
$ String -> String
toHaskellComments String
c, forall a. ToTree a => a -> Expr
toTree Declaration
body]
instance ToTree H.Expression where
toTree :: Expression -> Expr
toTree Expression
expr = case Expression
expr of
H.ExpressionApplication Expression_Application
app -> forall a. ToTree a => a -> Expr
toTree Expression_Application
app
H.ExpressionCase Expression_Case
cases -> forall a. ToTree a => a -> Expr
toTree Expression_Case
cases
H.ExpressionConstructRecord Expression_ConstructRecord
r -> forall a. ToTree a => a -> Expr
toTree Expression_ConstructRecord
r
H.ExpressionDo [Statement]
statements -> Expr -> [Expr] -> Expr
indentBlock (String -> Expr
cst String
"do") forall a b. (a -> b) -> a -> b
$ forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Statement]
statements
H.ExpressionIf Expression_If
ifte -> forall a. ToTree a => a -> Expr
toTree Expression_If
ifte
H.ExpressionLiteral Literal
lit -> forall a. ToTree a => a -> Expr
toTree Literal
lit
H.ExpressionLambda Expression_Lambda
lam -> forall a. ToTree a => a -> Expr
toTree Expression_Lambda
lam
H.ExpressionList [Expression]
exprs -> BlockStyle -> [Expr] -> Expr
bracketList BlockStyle
halfBlockStyle forall a b. (a -> b) -> a -> b
$ forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expression]
exprs
H.ExpressionParens Expression
expr' -> Expr -> Expr
parenthesize forall a b. (a -> b) -> a -> b
$ forall a. ToTree a => a -> Expr
toTree Expression
expr'
H.ExpressionTuple [Expression]
exprs -> Bool -> [Expr] -> Expr
parenList Bool
False forall a b. (a -> b) -> a -> b
$ forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expression]
exprs
H.ExpressionVariable Name
name -> forall a. ToTree a => a -> Expr
toTree Name
name
instance ToTree H.Expression_Application where
toTree :: Expression_Application -> Expr
toTree (H.Expression_Application Expression
fun Expression
arg) = Op -> Expr -> Expr -> Expr
ifx Op
appOp (forall a. ToTree a => a -> Expr
toTree Expression
fun) (forall a. ToTree a => a -> Expr
toTree Expression
arg)
instance ToTree H.Expression_Case where
toTree :: Expression_Case -> Expr
toTree (H.Expression_Case Expression
cs [Alternative]
alts) = Op -> Expr -> Expr -> Expr
ifx Op
ofOp Expr
lhs Expr
rhs
where
lhs :: Expr
lhs = [Expr] -> Expr
spaceSep [String -> Expr
cst String
"case", forall a. ToTree a => a -> Expr
toTree Expression
cs]
rhs :: Expr
rhs = [Expr] -> Expr
newlineSep (forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Alternative]
alts)
ofOp :: Op
ofOp = Symbol -> Padding -> Precedence -> Associativity -> Op
CT.Op (String -> Symbol
CT.Symbol String
"of") (Ws -> Ws -> Padding
CT.Padding Ws
CT.WsSpace Ws
CT.WsBreakAndIndent) (Int -> Precedence
CT.Precedence Int
0) Associativity
CT.AssociativityNone
instance ToTree H.Expression_ConstructRecord where
toTree :: Expression_ConstructRecord -> Expr
toTree (H.Expression_ConstructRecord Name
name [FieldUpdate]
updates) = [Expr] -> Expr
spaceSep [forall a. ToTree a => a -> Expr
toTree Name
name, Brackets -> BlockStyle -> Expr -> Expr
brackets Brackets
curlyBraces BlockStyle
halfBlockStyle Expr
body]
where
body :: Expr
body = BlockStyle -> [Expr] -> Expr
commaSep BlockStyle
halfBlockStyle (FieldUpdate -> Expr
fromUpdate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldUpdate]
updates)
fromUpdate :: FieldUpdate -> Expr
fromUpdate (H.FieldUpdate Name
fn Expression
val) = Op -> Expr -> Expr -> Expr
ifx Op
defineOp (forall a. ToTree a => a -> Expr
toTree Name
fn) (forall a. ToTree a => a -> Expr
toTree Expression
val)
instance ToTree H.Expression_If where
toTree :: Expression_If -> Expr
toTree (H.Expression_If Expression
eif Expression
ethen Expression
eelse) = Op -> Expr -> Expr -> Expr
ifx Op
ifOp ([Expr] -> Expr
spaceSep [String -> Expr
cst String
"if", forall a. ToTree a => a -> Expr
toTree Expression
eif]) Expr
body
where
ifOp :: Op
ifOp = Symbol -> Padding -> Precedence -> Associativity -> Op
CT.Op (String -> Symbol
CT.Symbol String
"") (Ws -> Ws -> Padding
CT.Padding Ws
CT.WsNone Ws
CT.WsBreakAndIndent) (Int -> Precedence
CT.Precedence Int
0) Associativity
CT.AssociativityNone
body :: Expr
body = [Expr] -> Expr
newlineSep [[Expr] -> Expr
spaceSep [String -> Expr
cst String
"then", forall a. ToTree a => a -> Expr
toTree Expression
ethen], [Expr] -> Expr
spaceSep [String -> Expr
cst String
"else", forall a. ToTree a => a -> Expr
toTree Expression
eelse]]
instance ToTree H.Expression_Lambda where
toTree :: Expression_Lambda -> Expr
toTree (H.Expression_Lambda [Pattern]
bindings Expression
inner) = Op -> Expr -> Expr -> Expr
ifx Op
lambdaOp (String -> Expr -> Expr
prefix String
"\\" Expr
head) Expr
body
where
head :: Expr
head = [Expr] -> Expr
spaceSep (forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern]
bindings)
body :: Expr
body = forall a. ToTree a => a -> Expr
toTree Expression
inner
instance ToTree H.Field where
toTree :: Field -> Expr
toTree (H.Field Name
name Type
typ) = [Expr] -> Expr
spaceSep [forall a. ToTree a => a -> Expr
toTree Name
name, String -> Expr
cst String
"::", forall a. ToTree a => a -> Expr
toTree Type
typ]
instance ToTree H.FieldWithComments where
toTree :: FieldWithComments -> Expr
toTree (H.FieldWithComments Field
field Maybe String
mc) = case Maybe String
mc of
Maybe String
Nothing -> forall a. ToTree a => a -> Expr
toTree Field
field
Just String
c -> [Expr] -> Expr
newlineSep [String -> Expr
cst forall a b. (a -> b) -> a -> b
$ String -> String
toHaskellComments String
c, forall a. ToTree a => a -> Expr
toTree Field
field]
instance ToTree H.Import where
toTree :: Import -> Expr
toTree (H.Import Bool
qual (H.ModuleName String
name) Maybe ModuleName
mod Maybe Import_Spec
_) = [Expr] -> Expr
spaceSep forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
Y.catMaybes [
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Expr
cst String
"import",
if Bool
qual then forall a. a -> Maybe a
Just (String -> Expr
cst String
"qualified") else forall a. Maybe a
Nothing,
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> Expr
cst String
name,
(\(H.ModuleName String
m) -> String -> Expr
cst forall a b. (a -> b) -> a -> b
$ String
"as " forall a. [a] -> [a] -> [a]
++ String
m) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ModuleName
mod]
instance ToTree H.Literal where
toTree :: Literal -> Expr
toTree Literal
lit = String -> Expr
cst forall a b. (a -> b) -> a -> b
$ case Literal
lit of
H.LiteralChar Int
c -> forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Int -> Char
C.chr forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c
H.LiteralDouble Double
d -> forall a. Show a => a -> String
show Double
d
H.LiteralFloat Float
f -> forall a. Show a => a -> String
show Float
f
H.LiteralInt Int
i -> forall a. Show a => a -> String
show Int
i
H.LiteralInteger Integer
i -> forall a. Show a => a -> String
show Integer
i
H.LiteralString String
s -> forall a. Show a => a -> String
show String
s
instance ToTree H.Module where
toTree :: Module -> Expr
toTree (H.Module Maybe ModuleHead
mh [Import]
imports [DeclarationWithComments]
decls) = [Expr] -> Expr
doubleNewlineSep forall a b. (a -> b) -> a -> b
$
[Expr]
headerLine forall a. [a] -> [a] -> [a]
++ [Expr]
importLines forall a. [a] -> [a] -> [a]
++ [Expr]
declLines
where
headerLine :: [Expr]
headerLine = forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe [] (\ModuleHead
h -> [forall a. ToTree a => a -> Expr
toTree ModuleHead
h]) Maybe ModuleHead
mh
declLines :: [Expr]
declLines = forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DeclarationWithComments]
decls
importLines :: [Expr]
importLines = [[Expr] -> Expr
newlineSep forall a b. (a -> b) -> a -> b
$ forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Import]
imports | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Import]
imports)]
instance ToTree H.Name where
toTree :: Name -> Expr
toTree Name
name = String -> Expr
cst forall a b. (a -> b) -> a -> b
$ case Name
name of
H.NameImplicit QualifiedName
qn -> String
"?" forall a. [a] -> [a] -> [a]
++ QualifiedName -> String
writeQualifiedName QualifiedName
qn
H.NameNormal QualifiedName
qn -> QualifiedName -> String
writeQualifiedName QualifiedName
qn
H.NameParens QualifiedName
qn -> String
"(" forall a. [a] -> [a] -> [a]
++ QualifiedName -> String
writeQualifiedName QualifiedName
qn forall a. [a] -> [a] -> [a]
++ String
")"
instance ToTree H.ModuleHead where
toTree :: ModuleHead -> Expr
toTree (H.ModuleHead Maybe String
mc (H.ModuleName String
mname) [Export]
_) = case Maybe String
mc of
Maybe String
Nothing -> Expr
head
Just String
c -> [Expr] -> Expr
newlineSep [String -> Expr
cst forall a b. (a -> b) -> a -> b
$ String -> String
toHaskellComments String
c, String -> Expr
cst String
"", Expr
head]
where
head :: Expr
head = [Expr] -> Expr
spaceSep [String -> Expr
cst String
"module", String -> Expr
cst String
mname, String -> Expr
cst String
"where"]
instance ToTree H.Pattern where
toTree :: Pattern -> Expr
toTree Pattern
pat = case Pattern
pat of
H.PatternApplication Pattern_Application
app -> forall a. ToTree a => a -> Expr
toTree Pattern_Application
app
H.PatternList [Pattern]
pats -> BlockStyle -> [Expr] -> Expr
bracketList BlockStyle
halfBlockStyle forall a b. (a -> b) -> a -> b
$ forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern]
pats
H.PatternLiteral Literal
lit -> forall a. ToTree a => a -> Expr
toTree Literal
lit
H.PatternName Name
name -> forall a. ToTree a => a -> Expr
toTree Name
name
H.PatternParens Pattern
pat -> Expr -> Expr
parenthesize forall a b. (a -> b) -> a -> b
$ forall a. ToTree a => a -> Expr
toTree Pattern
pat
H.PatternTuple [Pattern]
pats -> Bool -> [Expr] -> Expr
parenList Bool
False forall a b. (a -> b) -> a -> b
$ forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern]
pats
Pattern
H.PatternWildcard -> String -> Expr
cst String
"_"
instance ToTree H.Pattern_Application where
toTree :: Pattern_Application -> Expr
toTree (H.Pattern_Application Name
name [Pattern]
pats) = [Expr] -> Expr
spaceSep forall a b. (a -> b) -> a -> b
$ forall a. ToTree a => a -> Expr
toTree Name
nameforall a. a -> [a] -> [a]
:(forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern]
pats)
instance ToTree H.RightHandSide where
toTree :: RightHandSide -> Expr
toTree (H.RightHandSide Expression
expr) = forall a. ToTree a => a -> Expr
toTree Expression
expr
instance ToTree H.Statement where
toTree :: Statement -> Expr
toTree (H.Statement Expression
expr) = forall a. ToTree a => a -> Expr
toTree Expression
expr
instance ToTree H.Type where
toTree :: Type -> Expr
toTree Type
htype = case Type
htype of
H.TypeApplication (H.Type_Application Type
lhs Type
rhs) -> Op -> Expr -> Expr -> Expr
ifx Op
appOp (forall a. ToTree a => a -> Expr
toTree Type
lhs) (forall a. ToTree a => a -> Expr
toTree Type
rhs)
H.TypeFunction (H.Type_Function Type
dom Type
cod) -> Op -> Expr -> Expr -> Expr
ifx Op
arrowOp (forall a. ToTree a => a -> Expr
toTree Type
dom) (forall a. ToTree a => a -> Expr
toTree Type
cod)
H.TypeList Type
htype -> BlockStyle -> [Expr] -> Expr
bracketList BlockStyle
inlineStyle [forall a. ToTree a => a -> Expr
toTree Type
htype]
H.TypeTuple [Type]
types -> Bool -> [Expr] -> Expr
parenList Bool
False forall a b. (a -> b) -> a -> b
$ forall a. ToTree a => a -> Expr
toTree forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
types
H.TypeVariable Name
name -> forall a. ToTree a => a -> Expr
toTree Name
name
instance ToTree H.ValueBinding where
toTree :: ValueBinding -> Expr
toTree ValueBinding
vb = case ValueBinding
vb of
H.ValueBindingSimple (H.ValueBinding_Simple Pattern
pat RightHandSide
rhs Maybe LocalBindings
_) -> Op -> Expr -> Expr -> Expr
ifx Op
defineOp (forall a. ToTree a => a -> Expr
toTree Pattern
pat) (forall a. ToTree a => a -> Expr
toTree RightHandSide
rhs)
instance ToTree H.Variable where
toTree :: Variable -> Expr
toTree (H.Variable Name
v) = forall a. ToTree a => a -> Expr
toTree Name
v
toHaskellComments :: String -> String
String
c = forall a. [a] -> [[a]] -> [a]
L.intercalate String
"\n" forall a b. (a -> b) -> a -> b
$ (String
"-- | " forall a. [a] -> [a] -> [a]
++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String]
L.lines String
c
writeQualifiedName :: H.QualifiedName -> String
writeQualifiedName :: QualifiedName -> String
writeQualifiedName (H.QualifiedName [NamePart]
qualifiers NamePart
unqual) = forall a. [a] -> [[a]] -> [a]
L.intercalate String
"." forall a b. (a -> b) -> a -> b
$ (NamePart -> String
h forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamePart]
qualifiers) forall a. [a] -> [a] -> [a]
++ [NamePart -> String
h NamePart
unqual]
where
h :: NamePart -> String
h (H.NamePart String
part) = String
part