@@ -8,7 +8,6 @@ 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
1211import Data.ByteString.Lazy as BL
1312import Data.Char as C
1413import Data.Default
@@ -128,28 +127,34 @@ instance Capitalizable Text where
128127 | T.null t = t
129128 | otherwise = T.singleton (C.toUpper (T.head t)) <> T.tail t
130129
130+data DataFlavour = QQ | Plain
131+
131132-- TODO: improve after moving some XML types to xml-isogen
132−simpleTypeToIsoType :: SimpleAtomicType -> Text
133−simpleTypeToIsoType STAnyURI = "[t|Text|]"
134−simpleTypeToIsoType STBase64Binary = "[t|ByteString|]"
135−simpleTypeToIsoType STBoolean = "[t|Bool|]"
136−simpleTypeToIsoType STDate = "[t|Date \"%YYYYj\"|]"
137−simpleTypeToIsoType STDateTime = "[t|Text|]"
138−simpleTypeToIsoType STDateTimeStamp = "[t|Text|]"
139−simpleTypeToIsoType (STDecimal _) = "[t|Integer|]"
140−simpleTypeToIsoType STDouble = "[t|Double|]"
141−simpleTypeToIsoType (STDuration _) = "[t|Integer|]"
142−simpleTypeToIsoType STFloat = "[t|Float|]"
143−simpleTypeToIsoType STGDay = "[t|Day|]"
144−simpleTypeToIsoType STGMonth = "[t|Text|]"
145−simpleTypeToIsoType STGMonthDay = "[t|Text|]"
146−simpleTypeToIsoType STGYear = "[t|Text|]"
147−simpleTypeToIsoType STGYearMonth = "[t|Text|]"
148−simpleTypeToIsoType STHexBinary = "[t|Text|]"
149−simpleTypeToIsoType STNOTATION = "[t|Text|]"
150−simpleTypeToIsoType STQName = "[t|Text|]"
151−simpleTypeToIsoType (STString _) = "[t|Text|]"
152−simpleTypeToIsoType STTime = "[t|Text|]"
133+simpleTypeToIsoType :: DataFlavour -> SimpleAtomicType -> Text
134+simpleTypeToIsoType fl = \case
135+ STAnyURI -> wrap fl "Text"
136+ STBase64Binary -> wrap fl "ByteString"
137+ STBoolean -> wrap fl "Bool"
138+ STDate -> wrap fl "Date \"%YYYYj\""
139+ STDateTime -> wrap fl "Text"
140+ STDateTimeStamp -> wrap fl "Text"
141+ (STDecimal _) -> wrap fl "Integer"
142+ STDouble -> wrap fl "Double"
143+ (STDuration _) -> wrap fl "Integer"
144+ STFloat -> wrap fl "Float"
145+ STGDay -> wrap fl "Day"
146+ STGMonth -> wrap fl "Text"
147+ STGMonthDay -> wrap fl "Text"
148+ STGYear -> wrap fl "Text"
149+ STGYearMonth -> wrap fl "Text"
150+ STHexBinary -> wrap fl "Text"
151+ STNOTATION -> wrap fl "Text"
152+ STQName -> wrap fl "Text"
153+ (STString _) -> wrap fl "Text"
154+ STTime -> wrap fl "Text"
155+ where
156+ wrap QQ t = "[t|" <> t <> "|]"
157+ wrap Plain t = t
153158
154159tellGen
155160 :: [Text] -- generated code
@@ -195,7 +200,7 @@ typeName (InlineComplex dt) = result
195200 where
196201 result = case dt of
197202 TypeComplex (ComplexType n _ _ _) -> n
198− TypeSimple (STAtomic _ sat _ _) -> Just $ simpleTypeToIsoType sat
203+ TypeSimple (STAtomic _ sat _ _) -> Just $ simpleTypeToIsoType QQ sat
199204typeName (DatatypeRef t) = Just t
200205
201206generateIsoRecord :: Element -> GenMonad ()
@@ -211,12 +216,11 @@ generateIsoRecord (Element (_, laxName) xtype minOc maxOc annotations) = do
211216data CommentType = Haddock | Regular
212217
213218toComment :: CommentType -> [Annotation] -> Text
214−toComment ct ann = case texts' of
219+toComment ct ann = case texts of
215220 [] -> ""
216221 (h:tl) -> T.unlines ((prefix <> h) : fmap ("-- "<>) tl)
217222 where
218223 texts = stripTexts $ F.concatMap (wrap80 . fromDocumentation) ann
219− texts' = trace (show texts) texts
220224 stripTexts = \case
221225 [] -> []
222226 l@(h:tl) -> if T.all (\x -> x == ' ' || x == '\n') h then stripTexts tl else l
@@ -277,19 +281,27 @@ generateIsoDatatype
277281 isEnumeration (Enumeration _) = True
278282 fromEnumeration (Enumeration x) = x
279283 enums = Prelude.filter isEnumeration restrictions
280− typeStr = simpleTypeToIsoType sat
284+ typeStr = simpleTypeToIsoType QQ sat
281285 if Prelude.length enums > 0
282286 then tellGen
283287 (generateEnum
284288 (quote $ capitalize name)
285289 (F.concatMap fromEnumeration enums))
286290 comment
287− else pure ()
288− -- tellGen typeStr (Simple sat) (generateNewtype iName sat)
291+ else do
292+ tellGen (generateNewtype iName sat) comment
289293
290−-- generateNewtype :: Text -> SimpleAtomicType -> Text
291−-- generateNewtype n =
292−-- "newtype " <> capitalize n <> " = "
294+generateNewtype :: Text -> SimpleAtomicType -> [Text]
295+generateNewtype n sat =
296+ let
297+ cons = "Xml" <> capitalize n
298+ decons = "un" <> cons
299+ in
300+ [ "newtype " <> cons
301+ , " = " <> cons
302+ , " { " <> decons <> " :: " <> simpleTypeToIsoType Plain sat
303+ , " } deriving (FromDom, ToXML)"
304+ ]
293305
294306generateEnum
295307 :: Text -- type name
@@ -302,23 +314,33 @@ generateEnum name enums =
302314 in pure header <> eFields
303315
304316-- | Returns Just baseTypeName if type is simple, Nothing - otherwise
305−lookupSimpleType
317+lookupSimpleBaseType
306318 :: DatatypeRef
307319 -> GenMonad (Maybe SimpleAtomicType)
308−lookupSimpleType (InlineComplex _) = pure Nothing
309−lookupSimpleType (DatatypeRef tyName) = do
320+lookupSimpleBaseType (InlineComplex _) = pure Nothing
321+lookupSimpleBaseType (DatatypeRef tyName) = do
310322 M.lookup tyName <$> ask >>= \case
311323 Just (TypeComplex _) -> pure Nothing
312324 Just (TypeSimple (STAtomic _ sat _ _)) -> pure $ Just sat
313325 Nothing -> error $ "can't look up type: " <> show tyName
314326
327+lookupSimpleType
328+ :: DatatypeRef
329+ -> GenMonad (Maybe Text)
330+lookupSimpleType (InlineComplex _) = pure Nothing
331+lookupSimpleType (DatatypeRef tyName) = do
332+ M.lookup tyName <$> ask >>= \case
333+ Just (TypeComplex _) -> pure Nothing
334+ Just (TypeSimple (STAtomic nam _ _ _)) -> pure $ Just nam
335+ Nothing -> error $ "can't look up type: " <> show tyName
336+
315337generateIsoField :: Element -> GenMonad Text
316338generateIsoField (Element (_, name) xtype minOc maxOc annotations) = do
317339 let
318340 qualifier = toQualifier minOc maxOc
319341 line <- lookupSimpleType xtype >>= \case
320− Just baseTypeName -> do
321− pure $ quote name <> " " <> simpleTypeToIsoType baseTypeName
342+ Just tyName -> do
343+ pure $ quote name <> " [t|Xml" <> tyName <> "|]"
322344 Nothing -> case xtype of
323345 InlineComplex dt -> do
324346 generateIsoDatatype (Just $ capitalize name) dt annotations