module SyntaxTrees.Purescript.FnDef where

import Data.List                      (intercalate)
import SyntaxTrees.Purescript.Common  (Literal, QCtor, QCtorOp, QVar, QVarOp,
                                       Var, VarOp)
import SyntaxTrees.Purescript.Pattern (Pattern, showPatternNested)
import SyntaxTrees.Purescript.Type    (Type)
import Utils.List                     (mix)
import Utils.String                   (Wrapper (Wrapper), joinWords, str,
                                       wrapBlock, wrapContext, wrapCsv,
                                       wrapCurlyCsv, wrapParens, wrapParensCsv,
                                       wrapSpaces, wrapSquareCsv, (+++))



data FnSig
  = FnSig
      { FnSig -> Var
name  :: Var
      , FnSig -> Type
type' :: Type
      }

data FnDef
  = FnDef
      { FnDef -> [Var]
names :: [Var]
      , FnDef -> [Pattern]
args  :: [Pattern]
      , FnDef -> MaybeGuardedFnBody
body  :: MaybeGuardedFnBody
      }

data InfixFnDef
  = InfixFnDef
      { InfixFnDef -> Associativity
associativity :: Associativity
      , InfixFnDef -> Integer
precedence    :: Integer
      , InfixFnDef -> Var
fnName        :: Var
      , InfixFnDef -> VarOp
opName        :: VarOp
      }

data FnDefOrSig
  = Def FnDef
  | Sig FnSig

data FnBody
  = FnApply
      { FnBody -> FnBody
fn   :: FnBody
      , FnBody -> [FnBody]
args :: [FnBody]
      }
  | InfixFnApply
      { FnBody -> [FnOp]
fnOps :: [FnOp]
      , args  :: [FnBody]
      }
  | LeftOpSection
      { FnBody -> FnOp
fnOp :: FnOp
      , FnBody -> FnBody
arg  :: FnBody
      }
  | RightOpSection
      { arg  :: FnBody
      , fnOp :: FnOp
      }
  | LambdaExpr
      { FnBody -> [Pattern]
patterns :: [Pattern]
      , FnBody -> FnBody
body     :: FnBody
      }
  | LetExpr
      { FnBody -> [FnDefOrSig]
fnBindings :: [FnDefOrSig]
      , body       :: FnBody
      }
  | WhereExpr
      { body       :: FnBody
      , fnBindings :: [FnDefOrSig]
      }
  | IfExpr
      { FnBody -> FnBody
cond       :: FnBody
      , FnBody -> FnBody
ifBranch   :: FnBody
      , FnBody -> FnBody
elseBranch :: FnBody
      }
  | MultiWayIfExpr
      { FnBody -> [GuardedFnBody]
whenExprs :: [GuardedFnBody]
      }
  | DoExpr
      { FnBody -> [DoStep]
steps :: [DoStep]
      }
  | CaseOfExpr
      { FnBody -> FnBody
matchee :: FnBody
      , FnBody -> [CaseBinding]
cases   :: [CaseBinding]
      }
  | LambdaCaseExpr
      { cases :: [CaseBinding]
      }
  | RecordCreate
      { FnBody -> FnBody
ctor        :: FnBody
      , FnBody -> [(Var, FnBody)]
namedFields :: [(Var, FnBody)]
      }
  | RecordUpdate
      { FnBody -> FnBody
var         :: FnBody
      , namedFields :: [(Var, FnBody)]
      }
  | TypeAnnotation FnBody Type
  | ArrayRange FnBody FnBody
  | Tuple [FnBody]
  | Array [FnBody]
  | FnOp' FnOp
  | FnVar' FnVar
  | Literal' Literal

data FnVar
  = Selector Var
  | Selection QVar [Var]
  | Var' QVar
  | Ctor' QCtor

data FnOp
  = VarOp' QVarOp
  | CtorOp' QCtorOp

data DoStep
  = DoBinding [Var] FnBody
  | LetBinding [FnDefOrSig]
  | Body FnBody

data CaseBinding
  = CaseBinding Pattern MaybeGuardedFnBody

data MaybeGuardedFnBody
  = Guarded [GuardedFnBody]
  | Standard FnBody

data GuardedFnBody
  = GuardedFnBody
      { GuardedFnBody -> Guard
guard :: Guard
      , GuardedFnBody -> FnBody
body  :: FnBody
      }

data Guard
  = Guard [PatternGuard]
  | Otherwise

data PatternGuard
  = PatternGuard Pattern FnBody
  | SimpleGuard FnBody

data Associativity
  = LAssoc
  | RAssoc


instance Show FnSig where
  show :: FnSig -> String
show (FnSig Var
x Type
y) =
    [String] -> String
joinWords [forall a. Show a => a -> String
show Var
x,
               String
"::",
               forall a. Show a => a -> String
show Type
y]

instance Show FnDef where
  show :: FnDef -> String
show (FnDef [Var]
x [Pattern]
y MaybeGuardedFnBody
z) =
    [String] -> String
joinWords [forall a. Show a => [a] -> String
wrapCsv [Var]
x,
               forall a. [a] -> [[a]] -> [a]
intercalate String
" " (Pattern -> String
showPatternNested forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern]
y),
               String -> MaybeGuardedFnBody -> String
showMaybeGuardedFnBody String
"=" MaybeGuardedFnBody
z]

instance Show InfixFnDef where
  show :: InfixFnDef -> String
show (InfixFnDef Associativity
x Integer
y Var
z VarOp
t) =
    [String] -> String
joinWords [forall a. Show a => a -> String
show Associativity
x,
               forall a. Show a => a -> String
show Integer
y,
               forall a. Show a => a -> String
show Var
z,
               String
"as",
               forall a. Show a => a -> String
show VarOp
t]

instance Show FnDefOrSig where
  show :: FnDefOrSig -> String
show (Def FnDef
x) = forall a. Show a => a -> String
show FnDef
x
  show (Sig FnSig
x) = forall a. Show a => a -> String
show FnSig
x

instance Show FnBody where

  show :: FnBody -> String
show (FnApply FnBody
fn [FnBody]
args) =
    [String] -> String
joinWords [FnBody -> String
showNestedFnBody FnBody
fn,
               forall a. [a] -> [[a]] -> [a]
intercalate String
" " forall a b. (a -> b) -> a -> b
$ FnBody -> String
showNestedFnBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnBody]
args]

  show (InfixFnApply [FnOp]
fnOps [FnBody]
args) =
    forall a. [a] -> [[a]] -> [a]
intercalate String
"" forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a] -> [a]
mix (FnBody -> String
showNestedInfixFnBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnBody]
args)
                         (ShowS
wrapSpaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FnOp]
fnOps)

  show (LeftOpSection FnOp
x FnBody
y) =
    [String] -> String
joinWords [String
"_",
              forall a. Show a => a -> String
show FnOp
x,
              FnBody -> String
showNestedFnBody FnBody
y]

  show (RightOpSection FnBody
x FnOp
y) =
    [String] -> String
joinWords [FnBody -> String
showNestedFnBody FnBody
x,
               forall a. Show a => a -> String
show FnOp
y,
               String
"_"]

  show (LambdaExpr [Pattern]
x FnBody
y) =
    [String] -> String
joinWords [String
"\\" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
" " (Pattern -> String
showPatternNested forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pattern]
x),
               String
"->",
               forall a. Show a => a -> String
show FnBody
y]

  show (LetExpr [FnDefOrSig]
x FnBody
y) =
    String
"\n" forall a. [a] -> [a] -> [a]
++ ShowS
wrapContext (String
"let" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
wrapBlock [FnDefOrSig]
x forall a. [a] -> [a] -> [a]
++ String
"in" forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show FnBody
y)

  show (WhereExpr FnBody
x [FnDefOrSig]
y) =
    forall a. Show a => a -> String
show FnBody
x forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ ShowS
wrapContext (String
"where" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
wrapBlock [FnDefOrSig]
y)

  show (IfExpr FnBody
x FnBody
y FnBody
z) =
    String
"if" String -> ShowS
+++ forall a. Show a => a -> String
show FnBody
x String -> ShowS
+++
    String
"then" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
wrapBlock [FnBody
y] forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
    String
"else" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
wrapBlock [FnBody
z]

  show (MultiWayIfExpr [GuardedFnBody]
x) =
    String
"if" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
wrapBlock (String -> Wrapper
Wrapper forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"|" ++) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            String -> GuardedFnBody -> String
showGuardedFnBody String
"->" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GuardedFnBody]
x)

  show (DoExpr [DoStep]
x) =
    String
"do" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
wrapBlock [DoStep]
x

  show (CaseOfExpr FnBody
x [CaseBinding]
y) =
    [String] -> String
joinWords [String
"case",
              forall a. Show a => a -> String
show FnBody
x,
              String
"of",
              forall a. Show a => [a] -> String
wrapBlock [CaseBinding]
y]

  show (LambdaCaseExpr [CaseBinding]
x) =
    String
"\\case" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
wrapBlock [CaseBinding]
x

  show (RecordCreate FnBody
x [(Var, FnBody)]
y) =
    [String] -> String
joinWords [forall a. Show a => a -> String
show FnBody
x,
               forall a. Show a => [a] -> String
wrapCurlyCsv forall a b. (a -> b) -> a -> b
$ String -> Wrapper
Wrapper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a}. (Show a, Show a) => (a, a) -> String
format forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, FnBody)]
y]
    where
      format :: (a, a) -> String
format (a
z, a
t) = forall a. Show a => a -> String
show a
z forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
+++ forall a. Show a => a -> String
show a
t

  show (RecordUpdate FnBody
x [(Var, FnBody)]
y) =
    [String] -> String
joinWords [forall a. Show a => a -> String
show FnBody
x,
               forall a. Show a => [a] -> String
wrapCurlyCsv forall a b. (a -> b) -> a -> b
$ String -> Wrapper
Wrapper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a}. (Show a, Show a) => (a, a) -> String
format forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Var, FnBody)]
y]
    where
      format :: (a, a) -> String
format (a
z, a
t) = forall a. Show a => a -> String
show a
z String -> ShowS
+++ String
"=" String -> ShowS
+++ forall a. Show a => a -> String
show a
t

  show (TypeAnnotation FnBody
x Type
y) = [String] -> String
joinWords [forall a. Show a => a -> String
show FnBody
x, String
"::", forall a. Show a => a -> String
show Type
y]
  show (ArrayRange FnBody
x FnBody
y) = [String] -> String
joinWords [forall a. Show a => a -> String
show FnBody
x, String
"..", forall a. Show a => a -> String
show FnBody
y]
  show (Tuple [FnBody]
x) = forall a. Show a => [a] -> String
wrapParensCsv [FnBody]
x
  show (Array [FnBody]
x) = forall a. Show a => [a] -> String
wrapSquareCsv [FnBody]
x
  show (FnOp' FnOp
x) = ShowS
wrapParens forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show FnOp
x
  show (FnVar' FnVar
x) = forall a. Show a => a -> String
show FnVar
x
  show (Literal' Literal
x) = forall a. Show a => a -> String
show Literal
x


instance Show FnVar where
  show :: FnVar -> String
show (Selector Var
x)    = String
"." forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Var
x
  show (Selection QVar
x [Var]
y) = forall a. [a] -> [[a]] -> [a]
intercalate String
"." (forall a. Show a => a -> String
show QVar
x forall a. a -> [a] -> [a]
: (forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Var]
y))
  show (Var' QVar
x)        = forall a. Show a => a -> String
show QVar
x
  show (Ctor' QCtor
x)       = forall a. Show a => a -> String
show QCtor
x

instance Show FnOp where
  show :: FnOp -> String
show (VarOp' QVarOp
x)  = forall a. Show a => a -> String
show QVarOp
x
  show (CtorOp' QCtorOp
x) = forall a. Show a => a -> String
show QCtorOp
x

instance Show DoStep where

  show :: DoStep -> String
show (DoBinding [Var]
x FnBody
y) =
    [String] -> String
joinWords [forall a. Show a => [a] -> String
wrapCsv [Var]
x,
               String
"<-",
               forall a. Show a => a -> String
show FnBody
y]

  show (LetBinding [FnDefOrSig]
x) = String
"let" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> String
wrapBlock [FnDefOrSig]
x

  show (Body FnBody
x) = forall a. Show a => a -> String
show FnBody
x

instance Show CaseBinding where
  show :: CaseBinding -> String
show (CaseBinding Pattern
x MaybeGuardedFnBody
y) =
    [String] -> String
joinWords [forall a. Show a => a -> String
show Pattern
x,
               String -> MaybeGuardedFnBody -> String
showMaybeGuardedFnBody String
"->" MaybeGuardedFnBody
y]

instance Show Guard where
  show :: Guard -> String
show (Guard [PatternGuard]
x)   = forall a. Show a => String -> [a] -> String
str (String
"\n" forall a. [a] -> [a] -> [a]
++ String
",") [PatternGuard]
x
  show (Guard
Otherwise) = String
"otherwise"

instance Show PatternGuard where
  show :: PatternGuard -> String
show (PatternGuard Pattern
x FnBody
y) =
    [String] -> String
joinWords [forall a. Show a => a -> String
show Pattern
x,
               String
"<-",
               forall a. Show a => a -> String
show FnBody
y]
  show (SimpleGuard FnBody
x) = forall a. Show a => a -> String
show FnBody
x

instance Show Associativity where
  show :: Associativity -> String
show Associativity
LAssoc = String
"infixl"
  show Associativity
RAssoc = String
"infixr"


showMaybeGuardedFnBody :: String -> MaybeGuardedFnBody -> String
showMaybeGuardedFnBody :: String -> MaybeGuardedFnBody -> String
showMaybeGuardedFnBody String
op (Guarded [GuardedFnBody]
x) =
  forall a. Show a => [a] -> String
wrapBlock forall a b. (a -> b) -> a -> b
$ String -> Wrapper
Wrapper forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"|" ++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> GuardedFnBody -> String
showGuardedFnBody String
op forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GuardedFnBody]
x
showMaybeGuardedFnBody String
op (Standard FnBody
x) = String
op String -> ShowS
+++ forall a. Show a => a -> String
show FnBody
x

showGuardedFnBody :: String -> GuardedFnBody -> String
showGuardedFnBody :: String -> GuardedFnBody -> String
showGuardedFnBody String
op (GuardedFnBody Guard
x FnBody
y) =
  [String] -> String
joinWords [forall a. Show a => a -> String
show Guard
x,
            String
op,
            forall a. Show a => a -> String
show FnBody
y]

showNestedFnBody :: FnBody -> String
showNestedFnBody :: FnBody -> String
showNestedFnBody FnBody
x = ShowS
transformFn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show FnBody
x
  where
    transformFn :: ShowS
transformFn = if Bool
shouldWrap then ShowS
wrapParens else forall a. a -> a
id
    shouldWrap :: Bool
shouldWrap = case FnBody
x of
      FnApply FnBody
_ [FnBody]
_        -> Bool
True
      InfixFnApply [FnOp]
_ [FnBody]
_   -> Bool
True
      LeftOpSection FnOp
_ FnBody
_  -> Bool
True
      RightOpSection FnBody
_ FnOp
_ -> Bool
True
      LambdaExpr [Pattern]
_ FnBody
_     -> Bool
True
      LetExpr [FnDefOrSig]
_ FnBody
_        -> Bool
True
      WhereExpr FnBody
_ [FnDefOrSig]
_      -> Bool
True
      RecordCreate FnBody
_ [(Var, FnBody)]
_   -> Bool
True
      RecordUpdate FnBody
_ [(Var, FnBody)]
_   -> Bool
True
      ArrayRange FnBody
_ FnBody
_     -> Bool
True
      TypeAnnotation FnBody
_ Type
_ -> Bool
True
      FnBody
_                  -> Bool
False

showNestedInfixFnBody :: FnBody -> String
showNestedInfixFnBody :: FnBody -> String
showNestedInfixFnBody FnBody
x = ShowS
transformFn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show FnBody
x
  where
    transformFn :: ShowS
transformFn = if Bool
shouldWrap then ShowS
wrapParens else forall a. a -> a
id
    shouldWrap :: Bool
shouldWrap = case FnBody
x of
      InfixFnApply [FnOp]
_ [FnBody]
_   -> Bool
True
      LeftOpSection FnOp
_ FnBody
_  -> Bool
True
      RightOpSection FnBody
_ FnOp
_ -> Bool
True
      LambdaExpr [Pattern]
_ FnBody
_     -> Bool
True
      LetExpr [FnDefOrSig]
_ FnBody
_        -> Bool
True
      WhereExpr FnBody
_ [FnDefOrSig]
_      -> Bool
True
      RecordCreate FnBody
_ [(Var, FnBody)]
_   -> Bool
True
      RecordUpdate FnBody
_ [(Var, FnBody)]
_   -> Bool
True
      ArrayRange FnBody
_ FnBody
_     -> Bool
True
      TypeAnnotation FnBody
_ Type
_ -> Bool
True
      FnBody
_                  -> Bool
False