@@ -1,6 +1,7 @@
11{-# LANGUAGE FlexibleInstances #-}
22{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TupleSections #-}
45
56module Main
67 ( main
@@ -26,6 +27,9 @@ import System.IO
2627import Text.XSD
2728
2829
30+makeNamePrefix :: Text -> Text
31+makeNamePrefix = T.map C.toLower . T.filter (\c -> C.isUpper c || C.isDigit c)
32+
2933data GenType = Parser | Generator | Both
3034 deriving (Read, Show)
3135
@@ -36,6 +40,27 @@ genTypeToText Both = "Both"
3640
3741type GenMonad = ReaderT DatatypeMap (Writer Text)
3842
43+class Fields a where
44+ fields :: a -> [Text]
45+
46+instance Fields Datatype where
47+ fields (TypeComplex ty) = fields ty
48+ fields (TypeSimple ty) = fields ty
49+
50+instance Fields SimpleType where
51+ fields ty@(STAtomic tyName _ _ restrictions) = if shouldBeNewtype ty
52+ then [getNewtypeUnconsName tyName]
53+ else getEnumeratedCode restrictions
54+
55+instance Fields ComplexType where
56+ fields (ComplexType _ _ _ (Just g)) = fields g
57+ fields (ComplexType _ _ _ Nothing) = []
58+
59+instance Fields ModelGroupSchema where
60+ fields (CTSequence els) = snd . name <$> els
61+ fields (CTChoice els) = snd . name <$> els
62+ fields (CTAll els) = snd . name <$> els
63+
3964class References a where
4065 references :: a -> [Text]
4166
@@ -80,11 +105,46 @@ proceed' el = do
80105untwistDeps :: [Element] -> DatatypeMap -> ([(Text, Datatype)], [Element])
81106untwistDeps e dm = (dList, e')
82107 where
83− dList = nub $ execWriter $ do
108+ dList = disambiguateNames . nub . execWriter $ do
84109 (a, _) <- runStateT sortDatatypesByDeps (dm, S.empty)
85110 return a
86111 (_, e') = execRWS sortElemsByDeps (M.fromList dList) e
87112
113+type Abbreviation = Text
114+type Subelement = Text
115+type DisambiguaterMonad = State (M.Map Abbreviation (S.Set Subelement))
116+
117+-- | If any two datatypes with the same name abbreviation ('makeNamePrefix')
118+-- have any fields in common, then one of them gets a \"2\" appended to it
119+-- (\"_2\" if the last character of the name was a digit).
120+-- Repeat the same process until there are no conflicts.
121+-- If we have already appended a \"2\" to a datatype and it still has conflicts,
122+-- we change the 2 to a 3, a 3 to a 4 and so on.
123+disambiguateNames :: [(Text, Datatype)] -> [(Text, Datatype)]
124+disambiguateNames = flip evalState mempty . mapM disambiguateName
125+ where
126+ disambiguateName :: (Text, Datatype) -> DisambiguaterMonad (Text, Datatype)
127+ disambiguateName (tyName', dt) = do
128+ let rNames = S.fromList $ fields dt
129+ (, dt) <$> attempt tyName' rNames 1
130+ where
131+ attempt :: Abbreviation -> S.Set Subelement -> Int -> DisambiguaterMonad Text
132+ attempt tyName fieldNames n = do
133+ processedTypes <- get
134+ let
135+ newTyName
136+ | n == 1 = tyName
137+ | shouldSeparateNumber = tyName <> "_" <> T.pack (show n)
138+ | otherwise = tyName <> T.pack (show n)
139+ abr = makeNamePrefix newTyName
140+ case M.lookup abr processedTypes of
141+ Just usedNames ->
142+ if S.null $ S.intersection fieldNames usedNames
143+ then modify (M.adjust (S.union fieldNames) abr) >> return newTyName
144+ else attempt tyName fieldNames (n + 1)
145+ Nothing -> modify (M.insert abr fieldNames) >> return newTyName
146+ shouldSeparateNumber = isDigit $ T.last tyName'
147+
88148sortElemsByDeps :: PreElemMonad ()
89149sortElemsByDeps = do
90150 els <- get
@@ -223,15 +283,6 @@ header genType = T.unlines $
223283quote :: Text -> Text
224284quote t = "\"" <> t <> "\""
225285
226−-- | Nothing means unknown name
227−typeName :: DatatypeRef -> Maybe Text
228−typeName (InlineComplex dt) = result
229− where
230− result = case dt of
231− TypeComplex (ComplexType n _ _ _) -> n
232− TypeSimple (STAtomic _ sat _ _) -> Just $ simpleTypeToIsoType QQ sat
233−typeName (DatatypeRef t) = Just t
234−
235286generateIsoRecord :: GenType -> Element -> GenMonad ()
236287generateIsoRecord
237288 genType
@@ -275,7 +326,7 @@ wrap80 = L.foldl' go [] . T.split (==' ')
275326
276327generateIsoDatatype
277328 :: GenType
278− -> (Maybe Text) -- ^ Explicitly provided name, used for inline complexType's
329+ -> Text
279330 -> Datatype
280331 -> [Annotation]
281332 -> GenMonad ()
@@ -283,65 +334,75 @@ generateIsoDatatype
283334generateIsoDatatype
284335 genType
285336 eName
286− (TypeComplex (ComplexType iName attrs annotations mGroupSchema))
337+ (TypeComplex (ComplexType _ _ tyAnnotations mGroupSchema))
287338 annotationsRec = do
288− name <- case eName of
289− Just name -> pure name
290− Nothing -> case iName of
291− Just name' -> pure name'
292− Nothing -> error $ "[generateIsoDatatype] no name was provided"
293339 case mGroupSchema of
294340 Just groupSchema -> case groupSchema of
295− CTSequence elems -> do
296− fields <- for elems (generateIsoField genType)
341+ CTSequence elements -> do
342+ tyFields <- for elements (generateIsoField genType)
297343 let
298344 comment = toComment Haddock $ annotationsRec
299345 <> [Documentation ""]
300− <> annotations
301− header =
302− (quote $ capitalize name)
346+ <> tyAnnotations
347+ tyHeader =
348+ quote (capitalize eName)
303349 <> " =:= record "
304350 <> genTypeToText genType
305− tellGen (header : fields) comment
351+ tellGen (tyHeader : tyFields) comment
352+ CTChoice _ -> error "'Choice' group not supported yet"
353+ CTAll _ -> error "'All' group not supported yet"
354+ Nothing -> error $ "No group schema provided for type: " <> T.unpack eName
306355generateIsoDatatype
307356 genType
308357 eName
309− (TypeSimple (STAtomic iName sat annotations restrictions))
358+ (TypeSimple ty@(STAtomic iName sat tyAnnotations restrictions))
310359 annotationsRec = do
311− name <- case eName of
312− Just name -> pure name
313− Nothing -> pure iName
360+ let eName = eName
314361 let
315362 comment =
316363 toComment Haddock $ annotationsRec
317364 <> [Documentation ""]
318− <> annotations
319− isEnumeration (Enumeration _) = True
320− fromEnumeration (Enumeration x) = x
321− enums = Prelude.filter isEnumeration restrictions
322− typeStr = simpleTypeToIsoType QQ sat
323− if Prelude.length enums > 0
365+ <> tyAnnotations
366+ if not (shouldBeNewtype ty)
324367 then tellGen
325368 (generateEnum
326− (quote $ capitalize name)
327− (F.concatMap fromEnumeration enums))
369+ (quote $ capitalize eName)
370+ (getEnumeratedCode restrictions))
328371 comment
329372 else
330373 tellGen (generateNewtype genType iName sat) comment
331374
375+getEnumeratedCode :: [Restriction] -> [Text]
376+getEnumeratedCode = F.concatMap fromEnumeration . Prelude.filter isEnumeration
377+ where
378+ fromEnumeration (Enumeration x) = x
379+
380+isEnumeration :: Restriction -> Bool
381+isEnumeration (Enumeration _) = True
382+
383+shouldBeNewtype :: SimpleType -> Bool
384+shouldBeNewtype (STAtomic _ _ _ restrictions) =
385+ not . Prelude.any isEnumeration $ restrictions
386+
387+getNewtypeConsName :: Text -> Text
388+getNewtypeConsName = ("Xml" <>) . capitalize
389+
390+getNewtypeUnconsName :: Text -> Text
391+getNewtypeUnconsName = ("un" <>) . getNewtypeConsName
392+
332393generateNewtype :: GenType -> Text -> SimpleAtomicType -> [Text]
333394generateNewtype genType n sat =
334395 let
335− cons = "Xml" <> capitalize n
336− decons = "un" <> cons
337− parser =
396+ constructor = getNewtypeConsName n
397+ decons = getNewtypeUnconsName n
398+ parser =
338399 [ ""
339− , "instance FromDom " <> cons <> " where"
340− , " fromDom = " <> cons <> " <$> fromDom"
400+ , "instance FromDom " <> constructor <> " where"
401+ , " fromDom = " <> constructor <> " <$> fromDom"
341402 ]
342403 in
343− [ "newtype " <> cons
344− , " = " <> cons
404+ [ "newtype " <> constructor
405+ , " = " <> constructor
345406 , " { " <> decons <> " :: " <> simpleTypeToIsoType Plain sat
346407 , " } deriving (Show, Eq, NFData" <> case genType of
347408 Parser -> ")"
@@ -360,17 +421,6 @@ generateEnum enumName enums =
360421 eFields = ("& "<>) <$> enums
361422 in pure enumHeader <> eFields
362423
363−-- | Returns Just baseTypeName if type is simple, Nothing - otherwise
364−lookupSimpleBaseType
365− :: DatatypeRef
366− -> GenMonad (Maybe SimpleAtomicType)
367−lookupSimpleBaseType (InlineComplex _) = pure Nothing
368−lookupSimpleBaseType (DatatypeRef tyName) = do
369− M.lookup tyName <$> ask >>= \case
370− Just (TypeComplex _) -> pure Nothing
371− Just (TypeSimple (STAtomic _ sat _ _)) -> pure $ Just sat
372− Nothing -> error $ "can't look up type: " <> show tyName
373−
374424lookupSimpleType
375425 :: DatatypeRef
376426 -> GenMonad (Maybe Text)
@@ -382,19 +432,21 @@ lookupSimpleType (DatatypeRef tyName) =
382432 Nothing -> error $ "can't look up type: " <> show tyName
383433
384434generateIsoField :: GenType -> Element -> GenMonad Text
385−generateIsoField genType (Element (_, name) xtype minOc maxOc annotations) = do
386− let
387− qualifier = toQualifier minOc maxOc
388− line <- lookupSimpleType xtype >>= \case
389− Just tyName -> do
390− pure $ quote name <> " [t|Xml" <> tyName <> "|]"
391− Nothing -> case xtype of
392− InlineComplex dt -> do
393− generateIsoDatatype genType (Just $ capitalize name) dt annotations
394− pure $ quote name
395− DatatypeRef ref ->
396− pure $ quote name <> " [t|Xml" <> capitalize ref <> "|]"
397− pure $ " " <> qualifier <> " " <> line
435+generateIsoField
436+ genType
437+ (Element (_, fieldName) fieldXtype minOc maxOc fieldAnnotations) = do
438+ let
439+ qualifier = toQualifier minOc maxOc
440+ line <- lookupSimpleType fieldXtype >>= \case
441+ Just tyName ->
442+ pure $ quote fieldName <> " [t|Xml" <> tyName <> "|]"
443+ Nothing -> case fieldXtype of
444+ InlineComplex dt -> do
445+ generateIsoDatatype genType (capitalize fieldName) dt fieldAnnotations
446+ pure $ quote fieldName
447+ DatatypeRef ref ->
448+ pure $ quote fieldName <> " [t|Xml" <> capitalize ref <> "|]"
449+ pure $ " " <> qualifier <> " " <> line
398450
399451main :: IO ()
400452main = do