@@ -0,0 +1,188 @@
1+module Main (main) where
2+
3+import Control.Monad.Writer.Strict
4+import Data.Aeson hiding (Options)
5+import Data.Aeson.Key qualified as Key
6+import Data.Aeson.KeyMap qualified as KeyMap
7+import Data.Aeson.Types (Parser)
8+import Data.Map.Lazy qualified as M
9+import Data.Vector (Vector)
10+import Data.Vector qualified as V
11+import Data.Yaml as Yaml
12+import Elm (makeElmModuleFromETypeDef)
13+import Elm.TyRep
14+import Language.PureScript.Bridge hiding (SumType)
15+import Language.PureScript.Bridge qualified as PS
16+import Language.PureScript.Bridge.CodeGenSwitches qualified as PSS
17+import Language.PureScript.Bridge.PSTypes
18+import Options.Generic
19+import Relude
20+
21+main :: IO ()
22+main = do
23+ Options {input, elmOutput, psOutput} <- getRecord "elm-ps-bridge"
24+ bridge :: Map Text Datatype <- Yaml.decodeFileThrow input
25+ writeFile elmOutput $ elm bridge
26+ writeFileText psOutput $ ps bridge
27+
28+data Datatype
29+ = SumDatatype SumType
30+ | ProductType (Map Text Datatype)
31+ | BoolType
32+ | IntType
33+ | FloatType
34+ | StringType
35+ deriving stock (Show)
36+
37+newtype SumType = SumType (Map Text (Maybe Datatype))
38+ deriving stock (Show)
39+
40+parseSumType :: Vector Value -> Parser SumType
41+parseSumType = fmap (SumType . fold) . traverse parseConstructor . V.toList
42+ where
43+ parseConstructor (String s) = pure $ one (s, Nothing)
44+ parseConstructor (Object o) | [(Key.toText -> k, v)] <- KeyMap.toList o = one . (k,) . Just <$> parseJSON v
45+ parseConstructor (Object _) = fail "Sum types can only have one name per constructor"
46+ parseConstructor _ = fail "Sum Bad sum type ;("
47+
48+instance FromJSON Datatype where
49+ parseJSON (Array a) = SumDatatype <$> parseSumType a
50+ parseJSON (Object o) = ProductType <$> traverse parseJSON (M.mapKeysMonotonic Key.toText $ KeyMap.toMap o)
51+ parseJSON (String "Bool") = pure BoolType
52+ parseJSON (String "Int") = pure IntType
53+ parseJSON (String "Float") = pure FloatType
54+ parseJSON (String "String") = pure StringType
55+ parseJSON _ = fail "Bad datatype ;("
56+
57+data Options = Options
58+ { input :: FilePath,
59+ elmOutput :: FilePath,
60+ psOutput :: FilePath
61+ }
62+ deriving stock (Generic, Show)
63+ deriving anyclass (ParseRecord)
64+
65+elm :: Map Text Datatype -> String
66+elm datattypes =
67+ let (_, types) = runWriter $ traverse (uncurry elmType) $ M.toList datattypes
68+ in makeElmModuleFromETypeDef "Bridge" types
69+
70+elmType :: Text -> Datatype -> Writer [ETypeDef] EType
71+elmType name BoolType = pure $ ETyCon $ ETCon "Bool"
72+elmType name IntType = pure $ ETyCon $ ETCon "Int"
73+elmType name FloatType = pure $ ETyCon $ ETCon "Float"
74+elmType name StringType = pure $ ETyCon $ ETCon "String"
75+elmType name (ProductType fields) = do
76+ fields' <- traverse (\(k, v) -> (toString k,) <$> elmType (name <> "_" <> k) v) $ M.toList fields
77+ tell
78+ [ ETypeAlias
79+ EAlias
80+ { ea_name =
81+ ETypeName
82+ { et_name = toString name,
83+ et_args = []
84+ },
85+ ea_fields = fields',
86+ ea_omit_null = False,
87+ ea_newtype = False,
88+ ea_unwrap_unary = False
89+ }
90+ ]
91+ pure $ ETyCon $ ETCon $ toString name
92+elmType name (SumDatatype (SumType sums)) = do
93+ sums' <- traverse (\(k, v) -> (toString k,) <$> traverse (elmType (name <> "_" <> k)) v) $ M.toList sums
94+ tell
95+ [ ETypeSum
96+ ESum
97+ { es_name =
98+ ETypeName
99+ { et_name = toString name,
100+ et_args = []
101+ },
102+ es_constructors =
103+ sums' <&> \(name, value) ->
104+ STC
105+ { _stcName = name,
106+ _stcEncoded = name,
107+ _stcFields = Anonymous $ maybeToList value
108+ },
109+ es_omit_null = False,
110+ es_unary_strings = True,
111+ es_type = defSumEncoding
112+ }
113+ ]
114+ pure $ ETyCon $ ETCon $ toString name
115+
116+psType :: Text -> Datatype -> Writer [PS.SumType PureScript] (PS.TypeInfo PureScript)
117+psType _ BoolType = pure psBool
118+psType _ IntType = pure psInt
119+psType _ FloatType = pure psNumber
120+psType _ StringType = pure psString
121+psType name (SumDatatype (SumType sums)) = do
122+ sums' <- traverse (\(k, v) -> (k,) <$> traverse (psType (name <> "_" <> k)) v) $ M.toList sums
123+ let ti =
124+ TypeInfo
125+ { _typePackage = "bridge",
126+ _typeModule = "Bridge",
127+ _typeName = name,
128+ _typeParameters = []
129+ }
130+ tell
131+ [ PS.SumType
132+ ti
133+ ( sums' <&> \(name, value) ->
134+ DataConstructor
135+ { _sigConstructor = name,
136+ _sigValues = Left $ maybeToList value
137+ }
138+ )
139+ allInstances
140+ ]
141+ pure ti
142+psType name (ProductType fields) = do
143+ fields' <- traverse (\(k, v) -> (k,) <$> psType (name <> "_" <> k) v) $ M.toList fields
144+ let ti =
145+ TypeInfo
146+ { _typePackage = "bridge",
147+ _typeModule = "Bridge",
148+ _typeName = name,
149+ _typeParameters = []
150+ }
151+ tell
152+ [ PS.SumType
153+ ti
154+ [ DataConstructor
155+ { _sigConstructor = name,
156+ _sigValues =
157+ Right $
158+ fields' <&> \(name, value) ->
159+ RecordEntry
160+ { _recLabel = name,
161+ _recValue = value
162+ }
163+ }
164+ ]
165+ allInstances
166+ ]
167+ pure ti
168+
169+allInstances :: [PS.Instance]
170+allInstances =
171+ [ PS.Encode,
172+ PS.Decode,
173+ PS.Generic,
174+ PS.Newtype,
175+ PS.Eq,
176+ PS.Ord
177+ ]
178+
179+ps :: Map Text Datatype -> Text
180+ps datattypes =
181+ let (_, types) = runWriter $ traverse (uncurry psType) $ M.toList datattypes
182+ in moduleToText
183+ PSS.defaultSettings
184+ PSModule
185+ { psModuleName = "Bridge",
186+ psImportLines = mempty,
187+ psTypes = types
188+ }