@@ -8,6 +8,7 @@ import Control.Monad.RWS.CPS (RWS, execRWS)
88import Control.Monad.Reader
99import Control.Monad.State.Strict
1010import Control.Monad.Writer.CPS (Writer, tell, execWriter)
11+import Debug.Trace
1112import Data.ByteString.Lazy as BL
1213import Data.Char as C
1314import Data.Default
@@ -29,7 +30,7 @@ class References a where
2930 references :: a -> [Text]
3031
3132instance References Datatype where
32− references (TypeComplex (ComplexType _ _ mmgs)) =
33+ references (TypeComplex (ComplexType _ _ _ mmgs)) =
3334 case mmgs of
3435 Just mgs -> case mgs of
3536 CTSequence els -> F.concatMap references els
@@ -39,7 +40,7 @@ instance References Datatype where
3940 references (TypeSimple _) = []
4041
4142instance References Element where
42− references (Element _ t _ _) = references t
43+ references (Element _ t _ _ _) = references t
4344
4445instance References DatatypeRef where
4546 references (DatatypeRef ty) = [ty]
@@ -152,9 +153,10 @@ simpleTypeToIsoType STTime = "[t|Text|]"
152153
153154tellGen
154155 :: [Text] -- generated code
156+ -> Text -- comment
155157 -> GenMonad ()
156−tellGen code = do
157− tell $ "\n" <> T.unlines code
158+tellGen code comment = do
159+ tell $ "\n" <> comment <> T.unlines code
158160
159161runGen :: DatatypeMap -> GenMonad a -> Text
160162runGen dm act = execWriter $ runReaderT act dm
@@ -165,7 +167,7 @@ generateIsoXml xsd@(XSD (e,d)) =
165167 (dList, el) = untwistDeps e d
166168 in (header <>) . runGen d $ do
167169 for_ dList $ \(t,d) -> do
168− generateIsoDatatype (Just t) d
170+ generateIsoDatatype (Just t) d []
169171 for_ el generateIsoRecord
170172
171173toQualifier :: Int -> Maybe Int -> Text
@@ -192,53 +194,98 @@ typeName :: DatatypeRef -> Maybe Text
192194typeName (InlineComplex dt) = result
193195 where
194196 result = case dt of
195− TypeComplex (ComplexType n _ _) -> n
196− TypeSimple (STAtomic _ sat _) -> Just $ simpleTypeToIsoType sat
197+ TypeComplex (ComplexType n _ _ _) -> n
198+ TypeSimple (STAtomic _ sat _ _) -> Just $ simpleTypeToIsoType sat
197199typeName (DatatypeRef t) = Just t
198200
199−-- | Push the record to the state and return field dsl
200201generateIsoRecord :: Element -> GenMonad ()
201−generateIsoRecord (Element (_, laxName) xtype minOc maxOc) = do
202+generateIsoRecord (Element (_, laxName) xtype minOc maxOc annotations) = do
202203 written <- ask
203204 case xtype of
204− InlineComplex dt -> generateIsoDatatype (Just laxName) dt
205+ InlineComplex dt -> generateIsoDatatype (Just laxName) dt annotations
205206 DatatypeRef nam -> if M.member nam written
206207 then pure ()
207208 else error $ "Implementation failure: "
208209 <> show nam <> " type never encountered before"
209210
211+data CommentType = Haddock | Regular
212+
213+toComment :: CommentType -> [Annotation] -> Text
214+toComment ct ann = case texts' of
215+ [] -> ""
216+ (h:tl) -> T.unlines ((prefix <> h) : fmap ("-- "<>) tl)
217+ where
218+ texts = stripTexts $ F.concatMap (wrap80 . fromDocumentation) ann
219+ texts' = trace (show texts) texts
220+ stripTexts = \case
221+ [] -> []
222+ l@(h:tl) -> if T.all (\x -> x == ' ' || x == '\n') h then stripTexts tl else l
223+ prefix = case ct of
224+ Haddock -> "-- | "
225+ Regular -> "-- "
226+
227+fromDocumentation :: Annotation -> Text
228+fromDocumentation (Documentation t) = t
229+
230+wrap80 :: Text -> [Text]
231+wrap80 = L.foldl' go [] . T.split (==' ')
232+ where
233+ go [] e = [e]
234+ go l e =
235+ let last' = L.last l
236+ in if (T.length last') + T.length e >= 73 -- 80 minus "-- | " and ' '
237+ then l <> pure e
238+ else L.init l <> [L.last l <> " " <> e]
239+
210240generateIsoDatatype
211− :: (Maybe Text) -- ^ Explicitly provided name
241+ :: (Maybe Text) -- ^ Explicitly provided name, used for inline complexType's
212242 -> Datatype
243+ -> [Annotation]
213244 -> GenMonad ()
214245 -- ^ (type name for lookups, generated code)
215−generateIsoDatatype eName (TypeComplex (ComplexType iName attrs mGroupSchema)) = do
216− name <- case eName of
217− Just name -> pure name
218− Nothing -> case iName of
219− Just name' -> pure name'
220− Nothing -> error $ "[generateIsoDatatype] no name was provided"
221− case mGroupSchema of
222− Just groupSchema -> case groupSchema of
223− CTSequence elems -> do
224− fields <- for elems generateIsoField
225− let header = (quote $ capitalize name) <> " =:= record Both"
226− tellGen $ pure header <> fields
227−generateIsoDatatype eName (TypeSimple (STAtomic iName sat restrictions)) = do
228− name <- case eName of
229− Just name -> pure name
230− Nothing -> pure iName
231− let
232− isEnumeration (Enumeration _) = True
233− fromEnumeration (Enumeration x) = x
234− enums = Prelude.filter isEnumeration restrictions
235− typeStr = simpleTypeToIsoType sat
236− if Prelude.length enums > 0
237− then tellGen (generateEnum
238− (quote $ capitalize name)
239− (F.concatMap fromEnumeration enums))
240− else pure ()
241− -- tellGen typeStr (Simple sat) (generateNewtype iName sat)
246+generateIsoDatatype
247+ eName
248+ (TypeComplex (ComplexType iName attrs annotations mGroupSchema))
249+ annotationsRec = do
250+ name <- case eName of
251+ Just name -> pure name
252+ Nothing -> case iName of
253+ Just name' -> pure name'
254+ Nothing -> error $ "[generateIsoDatatype] no name was provided"
255+ case mGroupSchema of
256+ Just groupSchema -> case groupSchema of
257+ CTSequence elems -> do
258+ fields <- for elems generateIsoField
259+ let
260+ comment = toComment Haddock $ annotationsRec
261+ <> [Documentation ""]
262+ <> annotations
263+ header = (quote $ capitalize name) <> " =:= record Both"
264+ tellGen (header : fields) comment
265+generateIsoDatatype
266+ eName
267+ (TypeSimple (STAtomic iName sat annotations restrictions))
268+ annotationsRec = do
269+ name <- case eName of
270+ Just name -> pure name
271+ Nothing -> pure iName
272+ let
273+ comment =
274+ toComment Haddock $ annotationsRec
275+ <> [Documentation ""]
276+ <> annotations
277+ isEnumeration (Enumeration _) = True
278+ fromEnumeration (Enumeration x) = x
279+ enums = Prelude.filter isEnumeration restrictions
280+ typeStr = simpleTypeToIsoType sat
281+ if Prelude.length enums > 0
282+ then tellGen
283+ (generateEnum
284+ (quote $ capitalize name)
285+ (F.concatMap fromEnumeration enums))
286+ comment
287+ else pure ()
288+ -- tellGen typeStr (Simple sat) (generateNewtype iName sat)
242289
243290-- generateNewtype :: Text -> SimpleAtomicType -> Text
244291-- generateNewtype n =
@@ -262,11 +309,11 @@ lookupSimpleType (InlineComplex _) = pure Nothing
262309lookupSimpleType (DatatypeRef tyName) = do
263310 M.lookup tyName <$> ask >>= \case
264311 Just (TypeComplex _) -> pure Nothing
265− Just (TypeSimple (STAtomic _ sat _)) -> pure $ Just sat
312+ Just (TypeSimple (STAtomic _ sat _ _)) -> pure $ Just sat
266313 Nothing -> error $ "can't look up type: " <> show tyName
267314
268315generateIsoField :: Element -> GenMonad Text
269−generateIsoField (Element (_, name) xtype minOc maxOc) = do
316+generateIsoField (Element (_, name) xtype minOc maxOc annotations) = do
270317 let
271318 qualifier = toQualifier minOc maxOc
272319 line <- lookupSimpleType xtype >>= \case
@@ -274,10 +321,10 @@ generateIsoField (Element (_, name) xtype minOc maxOc) = do
274321 pure $ quote name <> " " <> simpleTypeToIsoType baseTypeName
275322 Nothing -> case xtype of
276323 InlineComplex dt -> do
277− generateIsoDatatype (Just $ capitalize name) dt
324+ generateIsoDatatype (Just $ capitalize name) dt annotations
278325 pure $ quote name
279326 DatatypeRef ref ->
280− pure $ quote name <> " [t|" <> capitalize ref <> "|]"
327+ pure $ quote name <> " [t|Xml" <> capitalize ref <> "|]"
281328 pure $ " " <> qualifier <> " " <> line
282329
283330main :: IO ()