Interface.hs 4.1 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121
  1. module Gidl.Backend.Ivory.Interface where
  2. import Data.Monoid
  3. import Data.List (intercalate, nub)
  4. import Data.Char (toUpper)
  5. import Gidl.Types
  6. import Gidl.Interface
  7. import Gidl.Schema
  8. import Gidl.Backend.Ivory.Types
  9. import Ivory.Artifact
  10. import Text.PrettyPrint.Mainland
  11. interfaceModule :: [String] -> InterfaceRepr -> Artifact
  12. interfaceModule modulepath ir =
  13. artifactPath (intercalate "/" modulepath) $
  14. artifactText ((ifModuleName ir) ++ ".hs") $
  15. prettyLazyText 80 $
  16. stack
  17. [ text "{-# LANGUAGE DeriveDataTypeable #-}"
  18. , empty
  19. , text "module"
  20. <+> im (ifModuleName ir)
  21. <+> text "where"
  22. , empty
  23. , stack $ typeimports ++ extraimports
  24. , empty
  25. , schemaDoc (ifModuleName ir) (producerSchema ir)
  26. , empty
  27. , schemaDoc (ifModuleName ir) (consumerSchema ir)
  28. ]
  29. where
  30. im mname = mconcat $ punctuate dot
  31. $ map text (modulepath ++ [mname])
  32. tm mname = mconcat $ punctuate dot
  33. $ map text (typepath modulepath ++ ["Types", mname])
  34. where typepath = reverse . drop 1 . reverse
  35. typeimports = map (importDecl tm)
  36. $ nub
  37. $ map importType
  38. $ interfaceTypes ir
  39. extraimports = [ text "import Data.Serialize"
  40. , text "import Data.Typeable"
  41. , text "import Data.Data"
  42. , text "import qualified Test.QuickCheck as Q" ]
  43. schemaDoc :: String -> Schema -> Doc
  44. schemaDoc interfaceName (Schema schemaName []) =
  45. text "-- Cannot define" <+> text schemaName <+> text "schema for"
  46. <+> text interfaceName <+> text "interface: schema is empty"
  47. schemaDoc interfaceName (Schema schemaName schema) = stack
  48. [ text "-- Define" <+> text schemaName <+> text "schema for"
  49. <+> text interfaceName <+> text "interface"
  50. , text "data" <+> text typeName
  51. , indent 2 $ encloseStack equals deriv (text "|")
  52. [ text (constructorName n) <+> text (typeHaskellType t)
  53. | (_, (Message n t)) <- schema
  54. ]
  55. , empty
  56. , text ("put" ++ typeName) <+> colon <> colon <+> text "Putter" <+> text typeName
  57. , stack
  58. [ text ("put" ++ typeName)
  59. <+> parens (text (constructorName n) <+> text "m")
  60. <+> equals
  61. <+> text "put" <> text (cerealSize Bits32) <+> ppr h <+> text ">>"
  62. <+> text "put" <+> text "m"
  63. | (h, Message n _) <- schema ]
  64. , empty
  65. , text ("get" ++ typeName) <+> colon <> colon <+> text "Get" <+> text typeName
  66. , text ("get" ++ typeName) <+> equals <+> text "do"
  67. , indent 2 $ stack
  68. [ text "a" <+> text "<- get" <> text (cerealSize Bits32)
  69. , text "case a of"
  70. , indent 2 $ stack $
  71. [ ppr h <+> text "-> do" </> (indent 2 (stack
  72. [ text "m <- get"
  73. , text "return" <+> parens (text (constructorName n) <+> text "m")
  74. ]))
  75. | (h,Message n _) <- schema
  76. ] ++
  77. [ text "_ -> fail"
  78. <+> dquotes (text "encountered unknown tag in get" <> text typeName)
  79. ]
  80. ]
  81. , empty
  82. , serializeInstance typeName
  83. , empty
  84. , text ("arbitrary" ++ typeName) <+> colon <> colon <+> text "Q.Gen" <+> text typeName
  85. , text ("arbitrary" ++ typeName) <+> equals
  86. , indent 2 $ text "Q.oneof" <+> encloseStack lbracket rbracket comma
  87. [ text "do" </> (indent 4 (stack
  88. [ text "a <- Q.arbitrary"
  89. , text "return" <+> parens (text (constructorName n) <+> text "a")
  90. ]))
  91. | (_, Message n _) <- schema
  92. ]
  93. , empty
  94. , arbitraryInstance typeName
  95. ]
  96. where
  97. constructorName n = userTypeModuleName n ++ schemaName
  98. deriv = text "deriving (Eq, Show, Data, Typeable)"
  99. typeName = interfaceName ++ schemaName
  100. ifModuleName :: InterfaceRepr -> String
  101. ifModuleName (InterfaceRepr iname _) = aux iname
  102. where
  103. aux :: String -> String
  104. aux = first_cap . u_to_camel
  105. first_cap (s:ss) = (toUpper s) : ss
  106. first_cap [] = []
  107. u_to_camel ('_':'i':[]) = []
  108. u_to_camel ('_':[]) = []
  109. u_to_camel ('_':a:as) = (toUpper a) : u_to_camel as
  110. u_to_camel (a:as) = a : u_to_camel as
  111. u_to_camel [] = []