blob: 121aa4531fd158c2590409d0afc28a8c1564e2fc (
plain) (
blame)
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
|
{-# LANGUAGE OverloadedStrings #-}
module Text.Edifact.Scaffolder.Messages.Implementation
( -- *
toImplementation
) where
import Text.Edifact.Scaffolder.Commons
import Text.Edifact.Scaffolder.Messages.Types
import Control.Monad.State.Strict (State, evalState, gets,
modify)
import Data.List.NonEmpty as NE (NonEmpty (..),
fromList, head,
toList, (<|))
import Formatting
toImplementation :: MessageCode -> NonEmpty Dependency -> [Text]
toImplementation _ =
let closeList deps = deps <> [ "]" ]
in closeList . render . fmap concat . traverse callDependency . NE.toList
render :: Rendering a -> a
render r =
let initialState = RenderingContext 0 0 :| []
in evalState r initialState
type Trail = NonEmpty
data RenderingContext = RenderingContext { listPosition :: Int
, indentLevel :: Int
}
type Rendering = State (Trail RenderingContext)
callDependency :: Dependency -> Rendering [Text]
callDependency (Dependency element) = renderElement element
increment :: Rendering ()
increment =
let mapHead f (v :| t) = f v :| t
in modify (mapHead (\ ctx -> ctx { listPosition = listPosition ctx + 1 }))
pushIndent :: Rendering ()
pushIndent =
let indentState t@(previous :| _) = RenderingContext 0 (indentLevel previous + 2) <| t
in modify indentState
popIndent :: Rendering ()
popIndent =
let pop (_ :| []) = error "Incoherent state: can't unindent anymore (this shouldn't happen)"
pop (_ :| up) = NE.fromList up
in modify pop
getCurrentIndex :: Rendering Int
getCurrentIndex = gets (listPosition . NE.head)
getCurrentIndentation :: Rendering Int
getCurrentIndentation = gets (indentLevel . NE.head)
renderElement :: Element -> Rendering [Text]
renderElement (Segment code positional) =
let output index indentation =
[ sformat (fIndentation % fIndex % " " % fPositional % " " % fSegmentParserFunction) indentation index positional code
]
in output <$> getCurrentIndex
<*> getCurrentIndentation
<* increment
renderElement (GroupStart code positional) =
let output index indentation =
[ sformat (fIndentation % fIndex % " " % fPositional % " (") indentation index positional
, sformat (fIndentation % fSegmentGroupFunction) (indentation + 1) code
]
in output <$> getCurrentIndex
<*> getCurrentIndentation
<* increment
<* pushIndent
renderElement (GroupEnd _) =
let output indentation =
[ sformat (fIndentation % "]") indentation
, sformat (fIndentation % ")") (indentation - 1)
]
in output <$> getCurrentIndentation
<* popIndent
fIndentation :: Format r (Int -> r)
fIndentation =
let buildIndentation n = fromString (replicate (n * 2) ' ')
in later buildIndentation
fIndex :: Format r (Int -> r)
fIndex =
let buildIndex 0 = "["
buildIndex _ = ","
in later buildIndex
fPositional :: Format r (Positional -> r)
fPositional =
let buildPositional (Positional p r) = bprint (quoted fPosition % " .@ " % fRepetition) p r
in later buildPositional
fSegmentGroupFunction :: Format r (GroupCode -> r)
fSegmentGroupFunction = "segmentGroup " % quoted fGroupCode
fRepetition :: Format r (Repetition -> r)
fRepetition =
let buildRepetition (Repetition Mandatory 1) = bprint "once"
buildRepetition (Repetition Optional 1) = bprint "maybeOnce"
buildRepetition (Repetition Mandatory c) = bprint ("repeatedAtLeastOnce" % " " % fCardinality) c
buildRepetition (Repetition Optional c) = bprint ("repeated" % " " % fCardinality) c
in later buildRepetition
fCardinality :: Format r (Cardinality -> r)
fCardinality = mapf getCardinality int
|