-- | Haskell operator precendence and associativity are drawn from:
--   https://self-learning-java-tutorial.blogspot.com/2016/04/haskell-operator-precedence.html
-- Other operators were investigated using GHCi, e.g. ":info (->)"
-- Operator names are drawn (loosely) from:
--   https://stackoverflow.com/questions/7746894/are-there-pronounceable-names-for-common-haskell-operators

module Hydra.Langs.Haskell.Serde where

import Hydra.Ast
import Hydra.Tools.Serialization
import Hydra.Langs.Haskell.Operators
import qualified Hydra.Langs.Haskell.Ast as H

import qualified Data.Char as C
import qualified Data.List as L
import qualified Data.Maybe as Y


class ToTree a where
  toTree :: a -> 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 (Pattern -> Expr
forall a. ToTree a => a -> Expr
toTree Pattern
pat) (CaseRhs -> Expr
forall a. ToTree a => a -> Expr
toTree CaseRhs
rhs)

instance ToTree H.Assertion where
  toTree :: Assertion -> Expr
toTree Assertion
sert = case Assertion
sert of
    H.AssertionClass Assertion_Class
cls -> Assertion_Class -> Expr
forall a. ToTree a => a -> Expr
toTree Assertion_Class
cls
    H.AssertionTuple [Assertion]
serts -> Bool -> [Expr] -> Expr
parenList Bool
False (Assertion -> Expr
forall a. ToTree a => a -> Expr
toTree (Assertion -> Expr) -> [Assertion] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Assertion]
serts)

instance ToTree H.Assertion_Class where
  toTree :: Assertion_Class -> Expr
toTree (H.Assertion_Class Name
name [Type]
types) = [Expr] -> Expr
spaceSep [Name -> Expr
forall a. ToTree a => a -> Expr
toTree Name
name, BlockStyle -> [Expr] -> Expr
commaSep BlockStyle
halfBlockStyle (Type -> Expr
forall a. ToTree a => a -> Expr
toTree (Type -> Expr) -> [Type] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
types)]

instance ToTree H.CaseRhs where
  toTree :: CaseRhs -> Expr
toTree (H.CaseRhs Expression
expr) = 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 [
      Name -> Expr
forall a. ToTree a => a -> Expr
toTree Name
name,
      [Expr] -> Expr
spaceSep (Type -> Expr
forall a. ToTree a => a -> Expr
toTree (Type -> Expr) -> [Type] -> [Expr]
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 [
      Name -> Expr
forall a. ToTree a => a -> Expr
toTree Name
name,
      Maybe String -> BlockStyle -> [Expr] -> Expr
curlyBracesList Maybe String
forall a. Maybe a
Nothing BlockStyle
halfBlockStyle (FieldWithComments -> Expr
forall a. ToTree a => a -> Expr
toTree (FieldWithComments -> Expr) -> [FieldWithComments] -> [Expr]
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 -> Constructor -> Expr
forall a. ToTree a => a -> Expr
toTree Constructor
body
    Just String
c -> [Expr] -> Expr
newlineSep [String -> Expr
cst (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String -> String
toHaskellComments String
c, Constructor -> Expr
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
indentBlock ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$
        [[Expr] -> Expr
spaceSep [DataDeclaration_Keyword -> Expr
forall a. ToTree a => a -> Expr
toTree DataDeclaration_Keyword
kw, DeclarationHead -> Expr
forall a. ToTree a => a -> Expr
toTree DeclarationHead
hd, String -> Expr
cst String
"="], Expr
constructors]
        [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ if [Name] -> Bool
forall a. [a] -> Bool
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 (Name -> Expr
forall a. ToTree a => a -> Expr
toTree (Name -> Expr) -> [Name] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
derivCat)]]
      where
        derivCat :: [Name]
derivCat = [[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[Name]] -> [Name]) -> [[Name]] -> [Name]
forall a b. (a -> b) -> a -> b
$ Deriving -> [Name]
h (Deriving -> [Name]) -> [Deriving] -> [[Name]]
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 (ConstructorWithComments -> Expr
forall a. ToTree a => a -> Expr
toTree (ConstructorWithComments -> Expr)
-> [ConstructorWithComments] -> [Expr]
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", DeclarationHead -> Expr
forall a. ToTree a => a -> Expr
toTree DeclarationHead
hd, String -> Expr
cst String
"=", Type -> Expr
forall a. ToTree a => a -> Expr
toTree Type
typ]
    H.DeclarationValueBinding ValueBinding
vb -> ValueBinding -> Expr
forall a. ToTree a => a -> Expr
toTree ValueBinding
vb
    H.DeclarationTypedBinding (H.TypedBinding (H.TypeSignature Name
name Type
htype) ValueBinding
vb) -> [Expr] -> Expr
newlineSep [ -- TODO: local bindings
        Op -> Expr -> Expr -> Expr
ifx Op
typeOp (Name -> Expr
forall a. ToTree a => a -> Expr
toTree Name
name) (Type -> Expr
forall a. ToTree a => a -> Expr
toTree Type
htype),
        ValueBinding -> Expr
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 [DeclarationHead -> Expr
forall a. ToTree a => a -> Expr
toTree DeclarationHead
fun, Variable -> Expr
forall a. ToTree a => a -> Expr
toTree Variable
op]
--    H.DeclarationHeadParens ... ->
    H.DeclarationHeadSimple Name
name -> Name -> Expr
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 -> Declaration -> Expr
forall a. ToTree a => a -> Expr
toTree Declaration
body
    Just String
c -> [Expr] -> Expr
newlineSep [String -> Expr
cst (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String -> String
toHaskellComments String
c, Declaration -> Expr
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 -> Expression_Application -> Expr
forall a. ToTree a => a -> Expr
toTree Expression_Application
app
      H.ExpressionCase Expression_Case
cases -> Expression_Case -> Expr
forall a. ToTree a => a -> Expr
toTree Expression_Case
cases
      H.ExpressionConstructRecord Expression_ConstructRecord
r -> Expression_ConstructRecord -> Expr
forall a. ToTree a => a -> Expr
toTree Expression_ConstructRecord
r
      H.ExpressionDo [Statement]
statements -> [Expr] -> Expr
indentBlock ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ [String -> Expr
cst String
"do"] [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ (Statement -> Expr
forall a. ToTree a => a -> Expr
toTree (Statement -> Expr) -> [Statement] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Statement]
statements)
      H.ExpressionIf Expression_If
ifte -> Expression_If -> Expr
forall a. ToTree a => a -> Expr
toTree Expression_If
ifte
    --  H.ExpressionInfixApplication Term_InfixApplication
      H.ExpressionLiteral Literal
lit -> Literal -> Expr
forall a. ToTree a => a -> Expr
toTree Literal
lit
      -- Note: the need for extra parens may point to an operator precedence issue
      H.ExpressionLambda Expression_Lambda
lam -> Expr -> Expr
parenthesize (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expression_Lambda -> Expr
forall a. ToTree a => a -> Expr
toTree Expression_Lambda
lam
    --  H.ExpressionLeftSection Term_Section
      H.ExpressionLet (H.Expression_Let [LocalBinding]
bindings Expression
inner) -> [Expr] -> Expr
indentBlock [
          String -> Expr
cst String
"",
          [Expr] -> Expr
spaceSep [String -> Expr
cst String
"let", String -> [Expr] -> Expr
customIndentBlock String
"    " (LocalBinding -> Expr
encodeBinding (LocalBinding -> Expr) -> [LocalBinding] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocalBinding]
bindings)],
          [Expr] -> Expr
spaceSep [String -> Expr
cst String
"in", Expression -> Expr
forall a. ToTree a => a -> Expr
toTree Expression
inner]]
        where
          -- Note: indentation should depend on the length of the pattern
          encodeBinding :: LocalBinding -> Expr
encodeBinding = String -> Expr -> Expr
indentSubsequentLines String
"      " (Expr -> Expr) -> (LocalBinding -> Expr) -> LocalBinding -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalBinding -> Expr
forall a. ToTree a => a -> Expr
toTree
      H.ExpressionList [Expression]
exprs -> BlockStyle -> [Expr] -> Expr
bracketList BlockStyle
halfBlockStyle ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ Expression -> Expr
forall a. ToTree a => a -> Expr
toTree (Expression -> Expr) -> [Expression] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expression]
exprs
      H.ExpressionParens Expression
expr' -> Expr -> Expr
parenthesize (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Expression -> Expr
forall a. ToTree a => a -> Expr
toTree Expression
expr'
    --  H.ExpressionPrefixApplication Term_PrefixApplication
    --  H.ExpressionRightSection Term_Section
      H.ExpressionTuple [Expression]
exprs -> Bool -> [Expr] -> Expr
parenList Bool
False ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ Expression -> Expr
forall a. ToTree a => a -> Expr
toTree (Expression -> Expr) -> [Expression] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expression]
exprs
    --  H.ExpressionTypeSignature Term_TypeSignature
    --  H.ExpressionUpdateRecord Term_UpdateRecord
      H.ExpressionVariable Name
name -> Name -> Expr
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 (Expression -> Expr
forall a. ToTree a => a -> Expr
toTree Expression
fun) (Expression -> Expr
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", Expression -> Expr
forall a. ToTree a => a -> Expr
toTree Expression
cs]
      rhs :: Expr
rhs = [Expr] -> Expr
newlineSep (Alternative -> Expr
forall a. ToTree a => a -> Expr
toTree (Alternative -> Expr) -> [Alternative] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Alternative]
alts)
      ofOp :: Op
ofOp = Symbol -> Padding -> Precedence -> Associativity -> Op
Op (String -> Symbol
Symbol String
"of") (Ws -> Ws -> Padding
Padding Ws
WsSpace (Ws -> Padding) -> Ws -> Padding
forall a b. (a -> b) -> a -> b
$ String -> Ws
WsBreakAndIndent String
"  ") (Int -> Precedence
Precedence Int
0) Associativity
AssociativityNone

instance ToTree H.Expression_ConstructRecord where
  toTree :: Expression_ConstructRecord -> Expr
toTree (H.Expression_ConstructRecord Name
name [FieldUpdate]
updates) = [Expr] -> Expr
spaceSep [Name -> Expr
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 (FieldUpdate -> Expr) -> [FieldUpdate] -> [Expr]
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 (Name -> Expr
forall a. ToTree a => a -> Expr
toTree Name
fn) (Expression -> Expr
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", Expression -> Expr
forall a. ToTree a => a -> Expr
toTree Expression
eif]) Expr
body
    where
      ifOp :: Op
ifOp = Symbol -> Padding -> Precedence -> Associativity -> Op
Op (String -> Symbol
Symbol String
"") (Ws -> Ws -> Padding
Padding Ws
WsNone (Ws -> Padding) -> Ws -> Padding
forall a b. (a -> b) -> a -> b
$ String -> Ws
WsBreakAndIndent String
"  ") (Int -> Precedence
Precedence Int
0) Associativity
AssociativityNone
      body :: Expr
body = [Expr] -> Expr
newlineSep [[Expr] -> Expr
spaceSep [String -> Expr
cst String
"then", Expression -> Expr
forall a. ToTree a => a -> Expr
toTree Expression
ethen], [Expr] -> Expr
spaceSep [String -> Expr
cst String
"else", Expression -> Expr
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 (Pattern -> Expr
forall a. ToTree a => a -> Expr
toTree (Pattern -> Expr) -> [Pattern] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern]
bindings)
      body :: Expr
body = Expression -> Expr
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 [Name -> Expr
forall a. ToTree a => a -> Expr
toTree Name
name, String -> Expr
cst String
"::", Type -> Expr
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 -> Field -> Expr
forall a. ToTree a => a -> Expr
toTree Field
field
      Just String
c -> [Expr] -> Expr
newlineSep [String -> Expr
cst (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String -> String
toHaskellComments String
c, Field -> Expr
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 ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ [Maybe Expr] -> [Expr]
forall a. [Maybe a] -> [a]
Y.catMaybes [
      Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ String -> Expr
cst String
"import",
      if Bool
qual then Expr -> Maybe Expr
forall a. a -> Maybe a
Just (String -> Expr
cst String
"qualified") else Maybe Expr
forall a. Maybe a
Nothing,
      Expr -> Maybe Expr
forall a. a -> Maybe a
Just (Expr -> Maybe Expr) -> Expr -> Maybe Expr
forall a b. (a -> b) -> a -> b
$ String -> Expr
cst String
name,
      (\(H.ModuleName String
m) -> String -> Expr
cst (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ String
"as " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
m) (ModuleName -> Expr) -> Maybe ModuleName -> Maybe Expr
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 (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ case Literal
lit of
    H.LiteralChar Int
c -> Char -> String
forall a. Show a => a -> String
show (Char -> String) -> Char -> String
forall a b. (a -> b) -> a -> b
$ Int -> Char
C.chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c
    H.LiteralDouble Double
d -> if Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 then String
"(0" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" else Double -> String
forall a. Show a => a -> String
show Double
d
    H.LiteralFloat Float
f -> if Float
f Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0 then String
"(0" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Float -> String
forall a. Show a => a -> String
show Float
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" else Float -> String
forall a. Show a => a -> String
show Float
f
    H.LiteralInt Int
i -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then String
"(0" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" else Int -> String
forall a. Show a => a -> String
show Int
i
    H.LiteralInteger Integer
i -> Integer -> String
forall a. Show a => a -> String
show Integer
i
    H.LiteralString String
s -> String -> String
forall a. Show a => a -> String
show String
s

instance ToTree H.LocalBinding where
  toTree :: LocalBinding -> Expr
toTree LocalBinding
binding = case LocalBinding
binding of
    H.LocalBindingSignature TypeSignature
ts -> TypeSignature -> Expr
forall a. ToTree a => a -> Expr
toTree TypeSignature
ts
    H.LocalBindingValue ValueBinding
vb -> ValueBinding -> Expr
forall a. ToTree a => a -> Expr
toTree ValueBinding
vb

instance ToTree H.Module where
  toTree :: Module -> Expr
toTree (H.Module Maybe ModuleHead
mh [Import]
imports [DeclarationWithComments]
decls) = [Expr] -> Expr
doubleNewlineSep ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$
      [Expr]
headerLine [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [Expr]
importLines [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [Expr]
declLines
    where
      headerLine :: [Expr]
headerLine = [Expr] -> (ModuleHead -> [Expr]) -> Maybe ModuleHead -> [Expr]
forall b a. b -> (a -> b) -> Maybe a -> b
Y.maybe [] (\ModuleHead
h -> [ModuleHead -> Expr
forall a. ToTree a => a -> Expr
toTree ModuleHead
h]) Maybe ModuleHead
mh
      declLines :: [Expr]
declLines = DeclarationWithComments -> Expr
forall a. ToTree a => a -> Expr
toTree (DeclarationWithComments -> Expr)
-> [DeclarationWithComments] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DeclarationWithComments]
decls
      importLines :: [Expr]
importLines = [[Expr] -> Expr
newlineSep ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ Import -> Expr
forall a. ToTree a => a -> Expr
toTree (Import -> Expr) -> [Import] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Import]
imports | Bool -> Bool
not ([Import] -> Bool
forall a. [a] -> Bool
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 (String -> Expr) -> String -> Expr
forall a b. (a -> b) -> a -> b
$ case Name
name of
    H.NameImplicit QualifiedName
qn -> String
"?" String -> String -> 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
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ QualifiedName -> String
writeQualifiedName QualifiedName
qn String -> String -> String
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 (String -> Expr) -> String -> Expr
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 -> Pattern_Application -> Expr
forall a. ToTree a => a -> Expr
toTree Pattern_Application
app
--      H.PatternAs (H.Pattern_As ) ->
      H.PatternList [Pattern]
pats -> BlockStyle -> [Expr] -> Expr
bracketList BlockStyle
halfBlockStyle ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ Pattern -> Expr
forall a. ToTree a => a -> Expr
toTree (Pattern -> Expr) -> [Pattern] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern]
pats
      H.PatternLiteral Literal
lit -> Literal -> Expr
forall a. ToTree a => a -> Expr
toTree Literal
lit
      H.PatternName Name
name -> Name -> Expr
forall a. ToTree a => a -> Expr
toTree Name
name
      H.PatternParens Pattern
pat -> Expr -> Expr
parenthesize (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Pattern -> Expr
forall a. ToTree a => a -> Expr
toTree Pattern
pat
--      H.PatternRecord (H.Pattern_Record ) ->
      H.PatternTuple [Pattern]
pats -> Bool -> [Expr] -> Expr
parenList Bool
False ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ Pattern -> Expr
forall a. ToTree a => a -> Expr
toTree (Pattern -> Expr) -> [Pattern] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern]
pats
--      H.PatternTyped (H.Pattern_Typed ) ->
      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 ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ Name -> Expr
forall a. ToTree a => a -> Expr
toTree Name
nameExpr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
:(Pattern -> Expr
forall a. ToTree a => a -> Expr
toTree (Pattern -> Expr) -> [Pattern] -> [Expr]
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) = Expression -> Expr
forall a. ToTree a => a -> Expr
toTree Expression
expr

instance ToTree H.Statement where
  toTree :: Statement -> Expr
toTree (H.Statement Expression
expr) = 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 (Type -> Expr
forall a. ToTree a => a -> Expr
toTree Type
lhs) (Type -> Expr
forall a. ToTree a => a -> Expr
toTree Type
rhs)
    H.TypeCtx (H.Type_Context Assertion
ctx Type
typ) -> Op -> Expr -> Expr -> Expr
ifx Op
assertOp (Assertion -> Expr
forall a. ToTree a => a -> Expr
toTree Assertion
ctx) (Type -> Expr
forall a. ToTree a => a -> Expr
toTree Type
typ)
    H.TypeFunction (H.Type_Function Type
dom Type
cod) -> Op -> Expr -> Expr -> Expr
ifx Op
arrowOp (Type -> Expr
forall a. ToTree a => a -> Expr
toTree Type
dom) (Type -> Expr
forall a. ToTree a => a -> Expr
toTree Type
cod)
--  H.TypeInfix Type_Infix
    H.TypeList Type
htype -> BlockStyle -> [Expr] -> Expr
bracketList BlockStyle
inlineStyle [Type -> Expr
forall a. ToTree a => a -> Expr
toTree Type
htype]
--  H.TypeParens Type
    H.TypeTuple [Type]
types -> Bool -> [Expr] -> Expr
parenList Bool
False ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ Type -> Expr
forall a. ToTree a => a -> Expr
toTree (Type -> Expr) -> [Type] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
types
    H.TypeVariable Name
name -> Name -> Expr
forall a. ToTree a => a -> Expr
toTree Name
name

instance ToTree H.TypeSignature where
  toTree :: TypeSignature -> Expr
toTree (H.TypeSignature Name
name Type
typ) = [Expr] -> Expr
spaceSep [Name -> Expr
forall a. ToTree a => a -> Expr
toTree Name
name, String -> Expr
cst String
"::", Type -> Expr
forall a. ToTree a => a -> Expr
toTree Type
typ]

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
local) -> case Maybe LocalBindings
local of
        Maybe LocalBindings
Nothing -> Expr
body
        Just (H.LocalBindings [LocalBinding]
bindings) -> [Expr] -> Expr
indentBlock [Expr
body, [Expr] -> Expr
indentBlock ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ [String -> Expr
cst String
"where"] [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ (LocalBinding -> Expr
forall a. ToTree a => a -> Expr
toTree (LocalBinding -> Expr) -> [LocalBinding] -> [Expr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LocalBinding]
bindings)]
      where
        body :: Expr
body = Op -> Expr -> Expr -> Expr
ifx Op
defineOp (Pattern -> Expr
forall a. ToTree a => a -> Expr
toTree Pattern
pat) (RightHandSide -> Expr
forall a. ToTree a => a -> Expr
toTree RightHandSide
rhs)

instance ToTree H.Variable where
  toTree :: Variable -> Expr
toTree (H.Variable Name
v) = Name -> Expr
forall a. ToTree a => a -> Expr
toTree Name
v

toHaskellComments :: String -> String
toHaskellComments :: String -> String
toHaskellComments String
c = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String
"-- | " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> [String] -> [String]
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) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (NamePart -> String
h (NamePart -> String) -> [NamePart] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamePart]
qualifiers) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [NamePart -> String
h NamePart
unqual]
  where
    h :: NamePart -> String
h (H.NamePart String
part) = String
part