1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
--- --------------------------------------------------------------------------
--- Pretty-printing of AbstractCurry.
---
--- This library provides a pretty-printer for AbstractCurry modules.
---
--- @author  Yannik Potdevin (with changes by Michael Hanus)
--- @version June 2018
--- --------------------------------------------------------------------------

module AbstractCurry.Pretty
    ( Qualification, Options, LayoutChoice(..)

    , defaultOptions
    , setPageWith, setIndentWith
    , setNoQualification, setFullQualification, setImportQualification
    , setOnDemandQualification
    , setModName, setLayoutChoice

    , showCProg, prettyCurryProg, ppCurryProg

    , ppMName, ppExports, ppImports

    , ppCOpDecl, ppCTypeDecl, ppCFuncDecl, ppCFuncDeclWithoutSig, ppCRhs
    , ppCFuncSignature, ppCQualTypeExpr, ppCTypeExpr, ppCRules, ppCRule
    , ppCPattern, ppCLiteral, ppCExpr
    , ppCStatement, ppQFunc, ppFunc, ppQType, ppType)
    where

import AbstractCurry.Select hiding (varsOfLDecl, varsOfFDecl, varsOfStat)
import AbstractCurry.Types
import AbstractCurry.Transform (typesOfCurryProg, funcsOfCurryProg)
import Function                (on)
import List                    (partition, union, scanl, last, nub, (\\))
import Maybe                   (isJust, fromJust)

import Text.Pretty hiding      ( list, listSpaced, tupled, tupledSpaced, set
                               , setSpaced )

type Collection a = [a]

data Qualification
    = Full      -- ^ Fully qualify every identifier, including those of the
                --   processed module and Prelude.
    | Imports   -- ^ Fully qualify external identifiers, do not qualify local
                --   identifiers and those of Prelude.
    | OnDemand  -- ^ Fully qualify only identifiers which need to be.
    | None      -- ^ Do not qualify any function.
 deriving Eq

--- The choice for a generally preferred layout.
--- @cons PreferNestedLayout - prefer a layout where the arguments of
---                            long expressions are vertically aligned
--- @cons PreferFilledLayout - prefer a layout where the arguments of
---                            long expressions are filled as long as possible
---                            into one line
data LayoutChoice = PreferNestedLayout  -- ^ Prefer
                                        -- a                      f a
                                        -- + b      respectively    b
                                        --   + ...                  c
                                        -- if an expression does not fit the page
                  | PreferFilledLayout  -- ^ Prefer
                                        -- a + b                  f a b
                                        -- + c + d  respectively  c d
                                        -- if an expression does not fit the page

data Options = Options
    { pageWidth         :: Int
    , indentationWidth  :: Int
    , qualification     :: Qualification
    , moduleName        :: String
    {- Debugging flag (show signature of local functions or not). -}
    , showLocalSigs     :: Bool
    , layoutChoice      :: LayoutChoice
    {- A collection of all to this module visible types (i.e. all imported
       [prelude too] and self defined types) -- used to determine how to qualify,
       if Qualification`OnDemand` was chosen. -}


    , visibleTypes      :: Collection QName
    {- A collection of all to this module visible functions and constructors
       (i.e. all imported [prelude too] and self defined ones) -- used to
       determine how to qualify, if Qualification `OnDemand` was chosen. -}


    , visibleFunctions  :: Collection QName
    {- A collection of currently visible (depending on context) variables.
       Used to determine how to qualify, if Qualification `OnDemand` was chosen.
    -}


    , visibleVariables  :: Collection CVarIName
    }

--- The default options to pretty print a module. These are:
--- * page width: 78 characters
--- * indentation width: 2 characters
--- * qualification method: qualify all imported names (except prelude names)
--- * layout choice: prefer nested layout (see 'LayoutChoice')
--- These options can be changed by corresponding setters
--- ('setPageWith', 'setIndentWith', `set...Qualification`, 'setLayoutChoice').
---
--- Note: If these default options are used for pretty-print operations
--- other than 'prettyCurryProg' or 'ppCurryProg', then one has to set
--- the current module name explicitly by 'setModName'!
defaultOptions :: Options
defaultOptions =
  Options { pageWidth        = 78
          , indentationWidth = 2
          , qualification    = Imports
          , moduleName       = ""
          , showLocalSigs    = False
          , layoutChoice     = PreferNestedLayout
          , visibleTypes     = emptyCol
          , visibleFunctions = emptyCol
          , visibleVariables = emptyCol }

--- Sets the page width of the pretty printer options.
setPageWith :: Int -> Options -> Options
setPageWith pw o = o { pageWidth = pw }

--- Sets the indentation width of the pretty printer options.
setIndentWith :: Int -> Options -> Options
setIndentWith iw o = o { indentationWidth = iw }

--- Sets the qualification method to be used to print identifiers to
--- "import qualification" (which is the default).
--- In this case, all identifiers imported from other modules (except
--- for the identifiers of the prelude) are fully qualified.
setImportQualification :: Options -> Options
setImportQualification o = o { qualification = Imports }

--- Sets the qualification method to be used to print identifiers to
--- "unqualified".
--- In this case, no identifiers is printed with its module qualifier.
--- This might lead to name conflicts or unintended references
--- if some identifiers in the pretty-printed module are in conflict
--- with imported identifiers.
setNoQualification :: Options -> Options
setNoQualification o = o { qualification = None }

--- Sets the qualification method to be used to print identifiers to
--- "fully qualified".
--- In this case, every identifiers, including those of the processed module
--- and the prelude, are fully qualified.
setFullQualification :: Options -> Options
setFullQualification o = o { qualification = Full }

--- Sets the qualification method to be used to print identifiers to
--- "qualification on demand".
--- In this case, an identifier is qualified only if it is necessary
--- to avoid a name conflict, e.g., if a local identifier has the same
--- names as an imported identifier. Since it is necessary to know
--- the names of all identifiers defined in the current module (to be pretty
--- printed) and imported from other modules, the first argument
--- is the list of modules consisting of the current module and
--- all imported modules (including the prelude).
--- The current module must always be the head of this list.
setOnDemandQualification :: [CurryProg] -> Options -> Options
setOnDemandQualification mods o =
  setRelatedMods mods (o { qualification = OnDemand })

--- Sets the name of the current module in the pretty printer options.
setModName :: MName -> Options -> Options
setModName m o = o { moduleName = m }

--- Sets the preferred layout in the pretty printer options.
setLayoutChoice :: LayoutChoice -> Options -> Options
setLayoutChoice lc o = o { layoutChoice = lc }

--- Sets the related modules in the pretty printer options. See 'options' to
--- read a specification of "related modules".
setRelatedMods :: [CurryProg] -> Options -> Options
setRelatedMods [] o = o
setRelatedMods (currentMod:imports) o =
    o { visibleTypes = vts, visibleFunctions = vfs }
    where vts = fromList $ map typeName (types currentMod)
                        ++ collect publicTypeNames
          vfs = fromList $ concat [ map funcName $ functions currentMod
                                  , collect publicFuncNames
                                  , map consName $ constructors currentMod
                                  , collect publicConsNames ]
          collect proj = foldr union [] $ map proj imports

--- precedence of top level (pattern or application) context -- lowest
tlPrec      :: Int
tlPrec      = 0
--- precedence of infix (pattern or application) context
infAppPrec  :: Int
infAppPrec  = 1
--- precedence of standard prefix (pattern or application) context
prefAppPrec :: Int
prefAppPrec = 2
--- precedence of atoms (variables, literals, tuples, lists ...)
highestPrec :: Int
highestPrec = 3

--- Shows a pretty formatted version of an abstract Curry Program.
--- The options for pretty-printing are the 'defaultOptions' (and therefore the
--- restrictions mentioned there apply here too).
--- @param prog - a curry prog
--- @return a string, which represents the input program `prog`
showCProg :: CurryProg -> String
showCProg = prettyCurryProg defaultOptions

--- Pretty-print the document generated by 'ppCurryProg', using the page width
--- specified by given options.
prettyCurryProg :: Options -> CurryProg -> String
prettyCurryProg opts cprog = showWidth (pageWidth opts) $ ppCurryProg opts cprog

--- Pretty-print a CurryProg (the representation of a program, written in Curry,
--- using AbstractCurry) according to given options.
--- This function will overwrite the module name given by options
--- with the name specified as the first component of `CurryProg`.
--- The list of imported modules is extended to all modules mentioned
--- in the program if qualified pretty printing is used.
--- This is necessary to avoid errors w.r.t. names re-exported by modules.
ppCurryProg :: Options -> CurryProg -> Doc
ppCurryProg opts cprog@(CurryProg m ms dfltdecl clsdecls instdecls ts fs os) =
  vsepBlank
    [ (nest' opts' $ sep [ text "module" <+> ppMName m, ppExports opts' ts fs])
       </> where_
    , ppImports opts' allImports
    , vcatMap (ppCOpDecl opts') os
    , ppCDefaultDecl opts' dfltdecl
    , vsepBlankMap (ppCClassDecl opts') clsdecls
    , vsepBlankMap (ppCInstanceDecl opts') instdecls
    , vsepBlankMap (ppCTypeDecl opts') ts
    , vsepBlankMap (ppCFuncDecl opts') fs ]
 where
   opts' = opts { moduleName = m }
   allModNames = filter (not . null)
                   (union (nub (map fst (typesOfCurryProg cprog)))
                          (nub (map fst (funcsOfCurryProg cprog))))
   allImports = if qualification opts == None
                then ms
                else nub (ms ++ allModNames) \\ [m]

--- Pretty-print a module name (just a string).
ppMName :: MName -> Doc
ppMName = text

--- Pretty-print exports, i.e. all type and function declarations which are
--- public.
--- extract the type and function declarations which are public and gather their
--- qualified names in a list.
ppExports :: Options -> [CTypeDecl] -> [CFuncDecl] -> Doc
ppExports opts ts fs
    | null pubTs  && null pubFs  = parens empty -- nothing is exported
    | null privTs && null privFs
                  && null privCs = empty        -- everything is exported
    | otherwise                  = filledTupledSpaced $ map tDeclToDoc pubTs
                                                     ++ map fDeclToDoc pubFs
    where (pubTs, privTs)  = partition isPublicTypeDecl ts
          (pubFs, privFs)  = partition isPublicFuncDecl fs
          privCs           = filter ((== Private) . consVis)
                           . concatMap typeCons $ ts
          isPublicTypeDecl = (== Public) . typeVis
          isPublicFuncDecl = (== Public) . funcVis
          tDeclToDoc       = on' (<>)
                                 (ppQTypeParsIfInfix opts . typeName)
                                 (ppConsExports opts . typeCons)
          fDeclToDoc = ppQFuncParsIfInfix opts . funcName

-- internal use only
ppConsExports :: Options -> [CConsDecl] -> Doc
ppConsExports opts cDecls
    | null pubCs  = empty
    | null privCs = parens $ dot <> dot
    | otherwise   = filledTupled $ map cDeclToDoc pubCs
    where (pubCs, privCs)  = partition isPublicConsDecl cDecls
          isPublicConsDecl = (== Public) . consVis
          cDeclToDoc       = ppQFuncParsIfInfix opts . consName


--- Pretty-print imports (list of module names) by prepending the word "import"
--- to the module name. If the qualification mode is 'Imports' or 'Full',
--- then the imports are declared as `qualified`.
ppImports :: Options -> [MName] -> Doc
ppImports opts imps = vcatMap (\m -> text importmode <+> ppMName m)
                           (filter (/= "Prelude") imps)
 where
   importmode = if qualification opts `elem` [Imports,Full]
                then "import qualified"
                else "import"

--- Pretty-print operator precedence declarations.
ppCOpDecl :: Options -> COpDecl -> Doc
ppCOpDecl _ (COp qn fix p) =
    hsep [ppCFixity fix, int p, genericPPName (bquotesIf . not . isInfixId) qn]

--- Pretty-print the fixity of a function.
ppCFixity :: CFixity -> Doc
ppCFixity CInfixOp  = text "infix"
ppCFixity CInfixlOp = text "infixl"
ppCFixity CInfixrOp = text "infixr"

--- Pretty-print operator precedence declarations.
ppCDefaultDecl :: Options -> Maybe CDefaultDecl -> Doc
ppCDefaultDecl _ Nothing = empty
ppCDefaultDecl opts (Just (CDefaultDecl texps)) =
  text "default" <+> filledTupled (map (ppCTypeExpr opts) texps)

--- Pretty-print a class declaration.
ppCClassDecl :: Options -> CClassDecl -> Doc
ppCClassDecl opts (CClass qn _ ctxt tvar funcs) =
  hsep [ text "class", ppCContext opts ctxt, ppType qn, ppCTVarIName opts tvar
       , text "where"]
  <$!$> indent' opts (vsepBlankMap (ppCFuncClassDecl opts) funcs)

--- Pretty-print an instance declaration.
ppCInstanceDecl :: Options -> CInstanceDecl -> Doc
ppCInstanceDecl opts (CInstance qn ctxt texp funcs) =
  hsep [ text "instance", ppCContext opts ctxt
       , ppQType opts qn, ppCTypeExpr' 2 opts texp, text "where"]
  <$!$> indent' opts (vsepBlankMap (ppCFuncDeclWithoutSig opts) funcs)

--- Pretty-print type declarations, like `data ... = ...`, `type ... = ...` or
--- `newtype ... = ...`.
ppCTypeDecl :: Options -> CTypeDecl -> Doc
ppCTypeDecl opts (CType qn _ tVars cDecls derivings) =
  hsep [ text "data", ppType qn, ppCTVarINames opts tVars
       , if null cDecls then empty else ppCConsDecls opts cDecls]
  <$!$> ppDeriving opts derivings
ppCTypeDecl opts (CTypeSyn qn _ tVars tExp)
    = hsep [ text "type", ppType qn, ppCTVarINames opts tVars
           , align $ equals <+> ppCTypeExpr opts tExp]
ppCTypeDecl opts (CNewType qn _ tVars cDecl derivings) =
  hsep [ text "newtype", ppType qn, ppCTVarINames opts tVars, equals
       , ppCConsDecl opts cDecl]
  <$!$> ppDeriving opts derivings

--- Pretty-print deriving clause.
ppDeriving :: Options -> [QName] -> Doc
ppDeriving _    []   = empty
ppDeriving opts [cn] = text " deriving" <+> ppQType opts cn
ppDeriving opts cls@(_:_:_) =
  text " deriving" <+> alignedTupled (map (ppQType opts) cls)

--- Pretty-print a list of constructor declarations, including the `=` sign.
ppCConsDecls :: Options -> [CConsDecl] -> Doc
ppCConsDecls opts cDecls =
    align . sep $ [equals <+> ppCConsDecl opts (head cDecls)]
               ++ map ((bar <+>) . (ppCConsDecl opts)) (tail cDecls)

--- Pretty-print a constructor declaration.
ppCConsDecl :: Options -> CConsDecl -> Doc
ppCConsDecl opts (CCons   ctvars ctxt qn _ tExps ) =
  hsep [ ppForallTVars opts ctvars, ppCContext opts ctxt
       , ppFunc qn, hsepMap (ppCTypeExpr' 2 opts) tExps]
ppCConsDecl opts (CRecord ctvars ctxt qn _ fDecls) =
  hsep [ ppForallTVars opts ctvars, ppCContext opts ctxt
       , ppFunc qn <+> alignedSetSpaced (map (ppCFieldDecl opts) fDecls)]

--- Pretty-print a variable (existiantial) quantifiction.
ppForallTVars :: Options -> [CTVarIName] -> Doc
ppForallTVars _ [] = empty
ppForallTVars opts tvars@(_:_) =
  text "forall" <+> hsep (map (ppCTVarIName opts) tvars) <+> text "."

--- Pretty-print a record field declaration (`field :: type`).
ppCFieldDecl :: Options -> CFieldDecl -> Doc
ppCFieldDecl opts (CField qn _ tExp) = hsep [ ppFunc qn
                                            , doubleColon
                                            , ppCTypeExpr opts tExp ]

--- Pretty-print a document comment.
ppCDocComment :: String -> Doc
ppCDocComment cmt = vsepMap (text . ("--- " ++)) (lines cmt)

--- Pretty-print a function declaration occurring in a class declaration.
ppCFuncClassDecl :: Options -> CFuncDecl -> Doc
ppCFuncClassDecl opts fDecl@(CFunc qn _ _ tExp rs) =
    ppCFuncSignature opts qn tExp
    <$!$> ppCRulesWithoutExternal funcDeclOpts qn rs
 where funcDeclOpts = addFuncNamesToOpts (funcNamesOfFDecl fDecl) opts
ppCFuncClassDecl opts (CmtFunc cmt qn a v tExp rs) =
    ppCDocComment cmt <$!$> ppCFuncClassDecl opts (CFunc qn a v tExp rs)

--- Pretty-print a function declaration.
ppCFuncDecl :: Options -> CFuncDecl -> Doc
ppCFuncDecl opts fDecl@(CFunc qn _ _ tExp _) =
    ppCFuncSignature opts qn tExp <$!$> ppCFuncDeclWithoutSig opts fDecl
ppCFuncDecl opts (CmtFunc cmt qn a v tExp rs) =
    ppCDocComment cmt <$!$> ppCFuncDecl opts (CFunc qn a v tExp rs)

--- Pretty-print a function declaration without signature.
ppCFuncDeclWithoutSig :: Options -> CFuncDecl -> Doc
ppCFuncDeclWithoutSig opts fDecl@(CFunc qn _ _ _ rs) =
    ppCRules funcDeclOpts qn rs
    where funcDeclOpts = addFuncNamesToOpts (funcNamesOfFDecl fDecl) opts
ppCFuncDeclWithoutSig opts (CmtFunc cmt qn a v tExp rs) =
    ppCDocComment cmt <$!$> ppCFuncDeclWithoutSig opts (CFunc qn a v tExp rs)

--- Pretty-print a function signature according to given options.
ppCFuncSignature :: Options -> QName -> CQualTypeExpr -> Doc
ppCFuncSignature opts qn tExp
    | isUntyped tExp = empty
    | otherwise = nest' opts
                $ sep [ genericPPName parsIfInfix qn
                      , align $ doubleColon <+> ppCQualTypeExpr opts tExp ]
 where
  isUntyped te = te == CQualType (CContext []) (CTCons (pre "untyped"))

--- Pretty-print a qualified type expression.
ppCQualTypeExpr :: Options -> CQualTypeExpr -> Doc
ppCQualTypeExpr opts (CQualType clsctxt texp) =
  ppCContext opts clsctxt <+> ppCTypeExpr opts texp

--- Pretty-print a class context.
ppCContext :: Options -> CContext -> Doc
ppCContext _ (CContext []) = empty
ppCContext opts (CContext [clscon]) =
  ppCConstraint opts clscon <+> text "=>"
ppCContext opts (CContext ctxt@(_:_:_)) =
  alignedTupled (map (ppCConstraint opts) ctxt) <+> text "=>"

--- Pretty-print a single class constraint.
ppCConstraint :: Options -> CConstraint -> Doc
ppCConstraint opts (cn,texp) =
  ppQType opts cn <+> ppCTypeExpr' prefAppPrec opts texp

--- Pretty-print a type expression.
ppCTypeExpr :: Options -> CTypeExpr -> Doc
ppCTypeExpr = ppCTypeExpr' tlPrec

-- Internal use only: Pretty-print a type expression and make use of supplied
-- precedence context. The supplied number represents the precedence of the
-- enclosing expression. Higher values mean more precedence, so if the nested
-- expression has lower precedence than the enclosing expression, the nested one
-- has to be enclosed in parentheses.
ppCTypeExpr' :: Int -> Options -> CTypeExpr -> Doc
ppCTypeExpr' _ opts (CTVar     tvar) = ppCTVarIName opts tvar
ppCTypeExpr' p opts (CFuncType tExp1 tExp2) =
    parensIf (p > tlPrec)
  $ sep [ ppCTypeExpr' 1 opts tExp1, rarrow <+> ppCTypeExpr opts tExp2]
ppCTypeExpr' _ opts (CTCons qn) = ppQType opts qn

ppCTypeExpr' p opts texp@(CTApply tcon targ) =
  maybe (parensIf (p >= 2) $ ppCTypeExpr' 2 opts tcon
                         <+> ppCTypeExpr' 2 opts targ)
        (\qn -> ppCTypeTConApply qn (argsOfApply texp))
        (funOfApply texp)
 where
  ppCTypeTConApply qn targs
    | isListCons qn  = brackets . ppCTypeExpr opts . head $ targs -- assume singleton
    | isTupleCons qn = alignedTupled $ map (ppCTypeExpr opts) targs
    | otherwise      = parensIf (p >= 2)
                     $ ppQType opts qn
                   <+> hsepMap (ppCTypeExpr' 2 opts) targs

  funOfApply te = case te of CTApply (CTCons qn) _ -> Just qn
                             CTApply tc _          -> funOfApply tc
                             _                     -> Nothing

  argsOfApply te = case te of
    CTApply (CTCons _) ta -> [ta]
    CTApply tc         ta -> argsOfApply tc ++ [ta]
    _                     -> [] -- should not occur

--- Pretty-print a list of type variables horizontally separating them
--- by `space`.
ppCTVarINames :: Options -> [CTVarIName] -> Doc
ppCTVarINames opts = hsepMap (ppCTVarIName opts)

--- Pretty-print a type variable (currently the Int is ignored).
ppCTVarIName :: Options -> CTVarIName -> Doc
ppCTVarIName _ (_, tvar) = text tvar

--- Pretty-print a list of function rules, concatenated vertically.
--- If there are no rules, an external rule is printed.
ppCRules :: Options -> QName -> [CRule] -> Doc
ppCRules opts qn rs
    | null rs   = genericPPName parsIfInfix qn <+> text "external"
    | otherwise = vcatMap (ppCRule opts qn) rs

--- Pretty-print a list of function rules, concatenated vertically.
--- If there are no rules, an empty document is returned.
ppCRulesWithoutExternal :: Options -> QName -> [CRule] -> Doc
ppCRulesWithoutExternal opts qn rs =
  if null rs then empty else vcatMap (ppCRule opts qn) rs

--- Pretty-print a rule of a function. Given a function
--- `f x y = x * y`, then `x y = x * y` is a rule consisting of `x y` as list of
--- patterns and `x * y` as right hand side.
ppCRule :: Options -> QName -> CRule -> Doc
ppCRule opts qn rule@(CRule ps rhs) =
    (nest' opts $ sep [ ppCPattern opts (CPComb qn ps) {- exploit similarity
                                                          between left hand side
                                                          of rule and constructor
                                                          pattern -}



                        <+> (case rhs of
                                  CSimpleRhs  _ _ -> equals
                                  CGuardedRhs _ _ -> empty )
                      , ppFuncRhs rhsOpts rhs ] )
 $$ if null lDecls
       then empty
       else indent' opts $ ppWhereDecl whereOpts lDecls
    where lDecls    = ldeclsOfRule rule
          whereOpts = addVarsToOpts (concatMap varsOfPat ps) opts
          rhsOpts   = last $ optsWithIncreasingNamespaces
                                varsOfLDecl
                                funcNamesOfLDecl
                                lDecls
                                whereOpts

--- Pretty-print a pattern expression.
ppCPattern :: Options -> CPattern -> Doc
ppCPattern = ppCPattern' tlPrec

-- Internal use only: Pretty-print a pattern expression and make use of supplied
-- precedence context. The supplied number represents the precedence of the
-- enclosing pattern. Higher values mean more precedence, so if the nested
-- pattern has lower precedence than the enclosing pattern, the nested one has
-- to be enclosed in parentheses.
ppCPattern' :: Int -> Options -> CPattern -> Doc
ppCPattern' _ opts (CPVar  pvar) = ppCVarIName opts pvar
ppCPattern' _ opts (CPLit  lit ) = ppCLiteral opts lit
ppCPattern' p opts pat@(CPComb qn ps)
    | null ps        = parsIfInfix qn qnDoc
    | isApp qn       = parensIf (p >= prefAppPrec)
                     $ ppCPattern' infAppPrec opts (ps !! 0)
                   <+> ppCPattern' prefAppPrec opts (ps !! 1)
    | isTupleCons qn = filledTupled . map (ppCPattern opts) $ ps
    | isFinLis pat   = let ps' = fromJust $ extractFiniteListPattern pat
                       in  alignedList . map (ppCPattern opts) $ ps'
    | isInfixId qn   =
        case ps of [l, r] -> parensIf (p >= infAppPrec)
                           $ hsep [ ppCPattern' p' opts l, qnDoc
                                  , ppCPattern' p' opts r ]
                   _      -> prefixApp
    | otherwise      = prefixApp
    where qnDoc     = ppQFunc opts qn
          isApp     = (== ("Prelude", "apply"))
          p'        = if isInfixId qn then infAppPrec else prefAppPrec
          prefixApp = parensIf (p >= prefAppPrec) . nest' opts
                    $ sep [ parsIfInfix qn qnDoc
                          , align . (case layoutChoice opts of
                                          PreferFilledLayout -> fillSep
                                          PreferNestedLayout -> sep)
                                  . map (ppCPattern' p' opts) $ ps ]
          isFinLis  = isJust . extractFiniteListPattern
ppCPattern' _ opts (CPAs pvar p)
    = hcat [ppCVarIName opts pvar, at, ppCPattern' highestPrec opts p]
ppCPattern' p opts (CPFuncComb qn ps) = ppCPattern' p opts (CPComb qn ps)
ppCPattern' _ opts (CPLazy     p     ) = tilde <> ppCPattern' highestPrec opts p
ppCPattern' _ opts (CPRecord   qn rps) =
    ppQFunc opts qn <+> alignedSetSpaced (map (ppCFieldPattern opts) rps)

--- Pretty-print a pattern variable (currently the Int is ignored).
ppCVarIName :: Options -> CVarIName -> Doc
ppCVarIName _ (_, pvar) = text pvar

--- Pretty-print given literal (Int, Float, ...).
ppCLiteral :: Options -> CLiteral -> Doc
ppCLiteral _ (CIntc i)    = int i
ppCLiteral _ (CFloatc f)  = float f
ppCLiteral _ (CCharc c)   = text $ show c
ppCLiteral _ (CStringc s)
    | null s    = text "\"\"" -- necessary for pakcs
    | otherwise = text $ show s

--- Pretty-print a record pattern
ppCFieldPattern :: Options -> CField CPattern -> Doc
ppCFieldPattern opts (qn, p) = ppQFunc opts qn <+> equals <+> ppCPattern opts p

--- Pretty-print the right hand side of a rule (or case expression), including
--- the d sign, where `d` is the relation (as doc) between the left hand side
--- and the right hand side -- usually this is one of `=`, `->`.
--- If the right hand side contains local declarations, they will be pretty
--- printed too, further indented.
ppCRhs :: Doc -> Options -> CRhs -> Doc
ppCRhs d opts rhs = case rhs of
        CSimpleRhs  exp   lDecls ->
            (nest' opts $ sep [d, ppCExpr (expAndGuardOpts lDecls) exp])
         $$ maybePPlDecls lDecls
        CGuardedRhs conds lDecls ->
            ppCGuardedRhs (expAndGuardOpts lDecls) d conds
         $$ maybePPlDecls lDecls
    where expAndGuardOpts ls = last $ optsWithIncreasingNamespaces
                                        varsOfLDecl
                                        funcNamesOfLDecl
                                        ls
                                        opts
          maybePPlDecls ls   = if null ls
                                  then empty
                                  else indent' opts (ppWhereDecl opts ls)

--- Like 'ppCRhs', but do not pretty-print local declarations.
--- Instead give caller the choice how to handle the declarations. For example
--- the function 'ppCRule' uses this to prevent local declarations from being
--- further indented.
ppFuncRhs :: Options -> CRhs -> Doc
{- No further enrichment of options necessary -- it was done in 'ppCRule' -}
ppFuncRhs opts (CSimpleRhs  exp _)   = ppCExpr opts exp
ppFuncRhs opts (CGuardedRhs conds _) = ppCGuardedRhs opts equals conds

ppCaseRhs :: Options -> CRhs -> Doc
ppCaseRhs = ppCRhs rarrow

--- Pretty-print guard, i.e. the `| cond d exp` part of a right hand side, where
--- `d` is the relation (as doc) between `cond` and `exp` -- usually this is
--- one of `=`, `->`.
ppCGuardedRhs :: Options -> Doc -> [(CExpr, CExpr)] -> Doc
ppCGuardedRhs opts d = align . vvsepMap ppCGuard
    where ppCGuard (e1, e2) = sep [ bar <+> ppCExpr opts e1
                                  , d   <+> ppCExpr opts e2 ]

--- Pretty-print local declarations . If the second argument is `text "where"`,
--- pretty-print a `where` block. If the second argument is `text "let"`,
--- pretty-print a `let` block without `in`.
ppCLocalDecls :: Options -> Doc -> [CLocalDecl] -> Doc
ppCLocalDecls opts d lDecls =
    (d <+>) . align . vvsepMap (ppCLocalDecl lDeclOpts) $ lDecls
    where lDeclOpts = last $ optsWithIncreasingNamespaces
                                varsOfLDecl
                                funcNamesOfLDecl
                                lDecls
                                opts

--- Pretty-print local declarations (the part that follows the `where` keyword).
ppCLocalDecl :: Options -> CLocalDecl -> Doc
ppCLocalDecl opts (CLocalFunc fDecl) =
    if showLocalSigs opts
       then ppCFuncDecl opts fDecl
       else ppCFuncDeclWithoutSig opts fDecl
ppCLocalDecl opts (CLocalPat  p rhs) =
    hsep [ ppCPattern opts p, ppCRhs equals rhsOpts rhs ]
    where rhsOpts = addVarsToOpts (varsOfPat p) opts
ppCLocalDecl opts (CLocalVars pvars) =
    (<+> text "free") $ hsep $ punctuate comma $ map (ppCVarIName opts) pvars

--- Pretty-print a `where` block, in which the word `where` stands alone in a
--- single line, above the following declarations.
ppWhereDecl :: Options -> [CLocalDecl] -> Doc
ppWhereDecl opts lDecls = (where_ $$)
                        . indent' opts
                        . vvsepMap (ppCLocalDecl lDeclOpts) $ lDecls
    where lDeclOpts = last $ optsWithIncreasingNamespaces
                                varsOfLDecl
                                funcNamesOfLDecl
                                lDecls
                                opts

--- Pretty-print a `let` block without `in`. In contrast to 'ppWhereDecl', the
--- word `let` is in the same line as the first local declaration.
ppLetDecl :: Options -> [CLocalDecl] -> Doc
ppLetDecl opts = ppCLocalDecls opts (text "let")

--- Pretty-print an expression.
ppCExpr :: Options -> CExpr -> Doc
ppCExpr = ppCExpr' tlPrec

-- Internal use only: Pretty-print an expression and make use of supplied
-- precedence context. The supplied number represents the precedence of the
-- enclosing expression. Higher values mean more precedence, so if the nested
-- expression has lower precedence than the enclosing expression, the nested one
-- has to be enclosed in parentheses.
ppCExpr' :: Int -> Options -> CExpr -> Doc
ppCExpr' _ opts (CVar     pvar) = ppCVarIName opts pvar
ppCExpr' _ opts (CLit     lit ) = ppCLiteral opts lit
ppCExpr' _ opts (CSymbol  qn  ) = ppQFuncParsIfInfix opts qn
ppCExpr' p opts app@(CApply f exp)
    | isITE app
        = parensIf (p > tlPrec)
        $ let (c, t, e) = fromJust $ extractITE app
          in  text "if" <+> (align $ sep [ ppCExpr opts c
                                         , text "then" <+> ppCExpr opts t
                                         , text "else" <+> ppCExpr opts e])
    | isTup app = let args = fromJust $ extractTuple app
                  in  alignedTupled (map (ppCExpr opts) args)
    | isFinLis app =
      let elems = fromJust $ extractFiniteListExp app
      in  (case layoutChoice opts of
             PreferNestedLayout -> alignedList
             PreferFilledLayout -> filledList )
            (map (ppCExpr opts) elems)
    | isInf app
        = parensIf (p >= infAppPrec)
        $ let (op, l, r) = fromJust $ extractInfix app
          in  (case layoutChoice opts of
                    PreferNestedLayout -> ppNestedWay
                    PreferFilledLayout -> ppFilledWay)
                (ppCExpr' infAppPrec opts l)
                (ppQFunc opts op)
                (ppCExpr' infAppPrec opts r)
    | otherwise = parensIf (p >= prefAppPrec)
                $ (case layoutChoice opts of
                        PreferNestedLayout -> ppNestedWay
                        PreferFilledLayout -> ppFilledWay)
                    (ppCExpr' infAppPrec opts f)
                    empty
                    (ppCExpr' prefAppPrec opts exp)
    where isITE    = isJust . extractITE
          isInf    = isJust . extractInfix
          isTup    = isJust . extractTuple
          isFinLis = isJust . extractFiniteListExp
          ppNestedWay l sepa r = align . nest 1 $ sep [l, sepa <+> r]
          ppFilledWay l sepa r = nest 1 $ fillSep [l, sepa, r]
ppCExpr' p opts (CLambda ps exp) =
    parensIf (p > tlPrec) . nest' opts
  $ sep [ backslash <> hsepMap (ppCPattern' prefAppPrec opts) ps
                   <+> rarrow
        , ppCExpr expOpts exp]
    where expOpts = addVarsToOpts (concatMap varsOfPat ps) opts
ppCExpr' p opts (CLetDecl lDecls exp) =
    parensIf (p > tlPrec) . align
    {- 'ppLetDecl' itself ensures the correct handling of opts -}
  $ sep [ ppLetDecl opts lDecls, text "in" <+> ppCExpr expOpts exp]
    where expOpts = last $ optsWithIncreasingNamespaces
                            varsOfLDecl
                            funcNamesOfLDecl
                            lDecls
                            opts
ppCExpr' p opts (CDoExpr stms) =
    parensIf (p > tlPrec)
  $ text "do" <+> align (vvsep $ zipWith ppCStatement statOptsList stms)
    where statOptsList = optsWithIncreasingNamespaces
                            varsOfStat
                            funcNamesOfStat
                            stms
                            opts
ppCExpr' _ opts (CListComp exp stms) =
    brackets $ hsep [ ppCExpr expOpts exp, bar
                    , hsep $ punctuate (comma <> space)
                                       (zipWith ppCStatement statOptsList stms)]
    where expOpts      = last statOptsList
          statOptsList = optsWithIncreasingNamespaces
                            varsOfStat
                            funcNamesOfStat
                            stms
                            opts

ppCExpr' p opts (CCase cType exp cases) =
    parensIf (p > tlPrec) . align . nest' opts
  $ sep [ ppCCaseType cType <+> ppCExpr opts exp <+> text "of"
        , ppCases opts cases]
ppCExpr' p opts (CTyped exp tExp) =
    parensIf (p > tlPrec)
  $ hsep [ppCExpr opts exp, doubleColon, ppCQualTypeExpr opts tExp]
ppCExpr' _ opts (CRecConstr qn rFields) =
    ppQFunc opts qn <+> ppRecordFields opts rFields
ppCExpr' p opts (CRecUpdate exp rFields) = ppCExpr' p opts exp
                                       <+> ppRecordFields opts rFields

ppCStatement :: Options -> CStatement -> Doc
ppCStatement opts (CSExpr exp       ) = ppCExpr opts exp
ppCStatement opts (CSPat  pat    exp) = ppCPattern opts pat
                                    <+> larrow
                                    <+> ppCExpr opts exp
ppCStatement opts (CSLet  lDecls    ) = ppLetDecl opts lDecls

--- Pretty-print `case`, `fcase` keywords.
ppCCaseType :: CCaseType -> Doc
ppCCaseType CRigid = text "case"
ppCCaseType CFlex  = text "fcase"

--- Pretty-print a list of case expressions, i.e. the `p1 -> e1`,...,`pn -> en`,
--- transitions, vertically aligned.
ppCases :: Options -> [(CPattern, CRhs)] -> Doc
ppCases opts = align . vvsepMap (ppCase opts)

--- Pretty-print a case expression.
ppCase :: Options -> (CPattern, CRhs) -> Doc
ppCase opts (p, rhs) = ppCPattern opts p <+> ppCaseRhs rhsOpts rhs
    where rhsOpts = addVarsToOpts (varsOfPat p) opts

--- Pretty-print record field assignments like this:
---     { lab1 = exp1, ..., labn expn }
--- if it fits the page, or
---     { lab1 = exp1
---     , ...
---     , labn = expn }
--- otherwise.
ppRecordFields :: Options -> [CField CExpr] -> Doc
ppRecordFields opts = alignedSetSpaced . map (ppRecordField opts)

--- Pretty-print a record field assignment (`fieldLabel = exp`).
ppRecordField :: Options -> CField CExpr -> Doc
ppRecordField opts (qn, exp) = ppQFunc opts qn <+> equals <+> ppCExpr opts exp

--- Pretty-print a QName qualified according to given options.
--- @param visNames - Depending on call, this is the namespace of visible types
---                   or of visible functions. Used to determine if `qn` is
---                   ambiguous, in case the qualification method 'OnDemand' was
---                   chosen
--- @param visVars - The in current context visible variables.
--- @param g - A doc tranformer used to manipulate (f.e. surround with
---            parentheses) the QName, after it was (maybe) qualified.
--- @param opts - The options to use.
--- @param qn - The `QName` to pretty-print.
--- @return A pretty-printed `QName`, maybe qualified (depending on settings).
genericPPQName :: Collection QName
               -> Collection CVarIName
               -> (QName -> Doc -> Doc)
               -> Options
               -> QName
               -> Doc
genericPPQName visNames visVars g opts qn@(m, f)
    | qnIsBuiltIn = name
    | null m      = name -- assume local declaration
    | otherwise   =
        case qualification opts of
             Full     -> qName
             Imports  -> if m == moduleName opts || m == "Prelude"
                            then name
                            else qName
             OnDemand -> if m == moduleName opts
                            then name
                            else odName -- at this point we know qn is imported
             None     -> name
    where qnIsBuiltIn = or (map ($ qn) [ isUnitCons , isListCons
                                       , isTupleCons, isConsCons ])
          name        = g qn (text f)
          qName       = g qn $ ppMName m <> dot <> text f
          odName      = if isShadowed qn || isAmbiguous qn
                           then qName
                           else name
          isAmbiguous n = anyCol (on' (&&) (sameName n) (diffMod n)) visNames
          isShadowed n  = anyCol (sameName n) visVars
          diffMod       = (/=) `on` fst
          sameName (_,x) (_,y) = x == y

genericPPName :: (QName -> Doc -> Doc) -> QName -> Doc
genericPPName f qn = f qn $ text . snd $ qn

--- Pretty-print a function name or constructor name qualified according to
--- given options. Use 'ppQType' or 'ppType' for pretty-printing type names.
ppQFunc :: Options -> QName -> Doc
ppQFunc opts = genericPPQName (visibleFunctions opts)
                              (visibleVariables opts)
                              (flip const)
                              opts

--- Like 'ppQFunc', but surround name with parentheses if it is an infix
--- identifier.
ppQFuncParsIfInfix :: Options -> QName -> Doc
ppQFuncParsIfInfix opts = genericPPQName (visibleFunctions opts)
                                         (visibleVariables opts)
                                         parsIfInfix
                                         opts

--- Pretty-print a function name or constructor name non-qualified.
--- Use 'ppQType' or 'ppType' for pretty-printing type names.
ppFunc :: QName -> Doc
ppFunc = genericPPName (flip const)

--- Pretty-print a type (`QName`) qualified according to given options.
ppQType :: Options -> QName -> Doc
ppQType opts = genericPPQName (visibleTypes opts) emptyCol (flip const) opts

--- Like 'ppQType', but surround name with parentheses if it is an infix
--- identifier.
ppQTypeParsIfInfix :: Options -> QName -> Doc
ppQTypeParsIfInfix opts =
    genericPPQName (visibleTypes opts) emptyCol parsIfInfix opts

--- Pretty-print a type (`QName`) non-qualified.
ppType :: QName -> Doc
ppType = genericPPName (flip const)

-- Helping function (diagnosis)
--- Check whether an operator is an infix identifier.
isInfixId :: QName -> Bool
isInfixId = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd

--- Check whether an identifier represents the unit constructor
isUnitCons :: QName -> Bool
isUnitCons (_, i) = i == "()"

--- Check whether an identifier represents the empty list constructor
isListCons :: QName -> Bool
isListCons (_, i) = i == "[]"

--- Check whether an identifier represents the list constructor `:`
isConsCons :: QName -> Bool
isConsCons (_, i) = i == ":"

--- Check whether an identifier represents a tuple constructor
isTupleCons :: QName -> Bool
isTupleCons (_, i) = i == mkTuple (length i)
  where mkTuple n = '(' : replicate (n - 2) ',' ++ ")"

--- Check if given application tree represents an if then else construct.
--- If so, return the condition, the "then expression" and the "else expression".
--- Otherwise, return `Nothing`.
extractITE :: CExpr -> Maybe (CExpr, CExpr, CExpr)
extractITE e = case e of
                    CApply (CApply (CApply (CSymbol ("Prelude","if_then_else"))
                                            cond)
                                    tExp)
                            fExp -> Just (cond, tExp, fExp)
                    _            -> Nothing

--- Check if given application tree represents an infix operator application.
--- If so, return the operator, its left and its right argument. Otherwise,
--- return `Nothing`.
extractInfix :: CExpr -> Maybe (QName, CExpr, CExpr)
extractInfix e
    = case e of CApply (CApply (CSymbol s)
                                 e1)
                        e2
                    | isInfixId s -> Just (s, e1, e2)
                _                 -> Nothing

--- Check if given application tree represents a tuple contructor application.
--- If so, return the constructor and its arguments in a list. Otherwise, return
--- `Nothing`.
extractTuple :: CExpr -> Maybe [CExpr]
extractTuple = extractTuple' []
    where extractTuple' es exp
            = case exp of
                   CApply  f e                 -> extractTuple' (e:es) f
                   CSymbol s   | isTupleCons s -> Just es
                   _                           -> Nothing

--- Check if given application tree represents a finite list `[x1, ..., xn]`.
--- If so, return the list elements in a list. Otherwise, return `Nothing`.
extractFiniteListExp :: CExpr -> Maybe [CExpr]
extractFiniteListExp = extractFiniteListExp' []
    where extractFiniteListExp' es exp =
            case exp of
                 CApply (CApply (CSymbol f)
                                 e)
                         arg | isConsCons f -> extractFiniteListExp' (e:es) arg
                 CSymbol s   | isListCons s -> Just $ reverse es
                 _                          -> Nothing

--- Check if given construct pattern represents a finite list `[x1, ..., xn]`.
--- If so, return the list elements in a list. Otherwise, return `Nothing`.
extractFiniteListPattern :: CPattern -> Maybe [CPattern]
extractFiniteListPattern = extractFiniteListPattern' []
    where extractFiniteListPattern' es pat =
            case pat of
                 CPComb qn [e, t] | isConsCons qn
                                  -> extractFiniteListPattern' (e:es) t
                 CPComb qn []     | isListCons qn
                                  -> Just $ reverse es
                 _                -> Nothing

-- Helping functions (pretty-printing)
hsepMap :: (a -> Doc) -> [a] -> Doc
hsepMap f = hsep . map f

vcatMap :: (a -> Doc) -> [a] -> Doc
vcatMap f = vcat . map f

vsepMap :: (a -> Doc) -> [a] -> Doc
vsepMap f = vsep . map f

vsepBlankMap :: (a -> Doc) -> [a] -> Doc
vsepBlankMap f = vsepBlank . map f

vvsep :: [Doc] -> Doc
vvsep = compose (<$!$>)

vvsepMap :: (a -> Doc) -> [a] -> Doc
vvsepMap f = vvsep . map f

fillSepMap :: (a -> Doc) -> [a] -> Doc
fillSepMap f = fillSep . map f

encloseSepSpaced :: Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSepSpaced l r s = encloseSep (l <> space) (space <> r) (s <> space)

alignedList :: [Doc] -> Doc
alignedList = encloseSep lbracket rbracket comma

filledList :: [Doc] -> Doc
filledList = fillEncloseSep lbracket rbracket comma

alignedSetSpaced :: [Doc] -> Doc
alignedSetSpaced = encloseSepSpaced lbrace rbrace comma

alignedTupled :: [Doc] -> Doc
alignedTupled = encloseSep lparen rparen comma

filledTupled :: [Doc] -> Doc
filledTupled = fillEncloseSep lparen rparen comma

filledTupledSpaced :: [Doc] -> Doc
filledTupledSpaced = fillEncloseSepSpaced lparen rparen comma

nest' :: Options -> Doc -> Doc
nest' opts = nest (indentationWidth opts)

indent' :: Options -> Doc -> Doc
indent' opts = indent (indentationWidth opts)

bquotesIf :: Bool -> Doc -> Doc
bquotesIf b d = if b then bquotes d else d

parsIfInfix :: QName -> Doc -> Doc
parsIfInfix = parensIf . isInfixId

larrow :: Doc
larrow = text "<-"

where_ :: Doc
where_ = text "where"

nil :: Doc
nil = text "[]"

-- Helping functions (various)
on' :: (b -> b -> c) -> (a -> b) -> (a -> b) -> a -> c
on' comb f g x = f x `comb` g x

-- Helping functions (CRUD functions for Collection)
emptyCol :: Collection a
emptyCol = []

appendCol :: Collection a -> Collection a -> Collection a
appendCol = (++)

anyCol :: (a -> Bool) -> Collection a -> Bool
anyCol = any

fromList :: [a] -> Collection a
fromList = id

-- Helping functions (management of visible names)
addVarsToOpts :: [CVarIName] -> Options -> Options
addVarsToOpts vs o =
    o { visibleVariables = fromList vs `appendCol` visibleVariables o }

addFuncNamesToOpts :: [QName] -> Options -> Options
addFuncNamesToOpts ns o =
    o { visibleFunctions = fromList ns `appendCol` visibleFunctions o }

addVarsAndFuncNamesToOpts :: [CVarIName] -> [QName] -> Options -> Options
addVarsAndFuncNamesToOpts vs ns = addVarsToOpts vs . addFuncNamesToOpts ns

--- Generates a list of options with increasing numbers of visible variables
--- and function names. Resulting lists are useful to match the scopes of
--- do expressions and list comprehensions, where latter statements see previous
--- variables and functions names, but prior elements do not see subsequent
--- variables and function names.
--- Note that `last $ optsWithIncreasingNamespaces varsOf funcNamesOf xs opts`
--- are options which contain all variables and function names of xs.
--- @param varsOf - a projection function
--- @param funcNamesOf - a projection function
--- @xs - a list [x1, x2, ...] of elements to which the projection functions
---       will be applied
--- @param opts - root options
--- @return a list `[opts0, opts1, opts2, ...]`, where
---         `opts == opts0`,
---         `opts1 == opts0` plus vars and funcNames of `x1`,
---         `opts2 == opts1` plus vars and funcNames of `x2`,
---         ...
optsWithIncreasingNamespaces :: (a -> [CVarIName])
                             -> (a -> [QName])
                             -> [a]
                             -> Options
                             -> [Options]
optsWithIncreasingNamespaces varsOf funcNamesOf xs opts =
    scanl (flip . uncurry $ addVarsAndFuncNamesToOpts) opts varsAndFuncNamesOfXs
    where varsAndFuncNamesOfXs = map varsOf xs `zip` map funcNamesOf xs

-- Helping function (gather variables occurring in argument)
--- In contrast to `AbstractCurry.Select.varsOfLDecl`, this function does not
--- include variables of right hand sides.
varsOfLDecl :: CLocalDecl -> [CVarIName]
varsOfLDecl (CLocalFunc f      ) = varsOfFDecl f
varsOfLDecl (CLocalPat  p     _) = varsOfPat p
varsOfLDecl (CLocalVars lvars  ) = lvars

--- In contrast to `AbstractCurry.Select.varsOfFDecl`, this function does not
--- include variables of right hand sides.
varsOfFDecl :: CFuncDecl -> [CVarIName]
varsOfFDecl (CFunc     _ _ _ _ r) = concatMap varsOfRule r
varsOfFDecl (CmtFunc _ _ _ _ _ r) = concatMap varsOfRule r
    where varsOfRule (CRule pats _) = concatMap varsOfPat pats

--- In contrast to `AbstractCurry.Select.varsOfStat`, this function does not
--- include variables of right hand sides.
varsOfStat :: CStatement -> [CVarIName]
varsOfStat (CSExpr _   ) = []
varsOfStat (CSPat  p  _) = varsOfPat p
varsOfStat (CSLet  ld  ) = concatMap varsOfLDecl ld