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