Skip to content

Commit ea9aeb8

Browse files
eskimoreskimor
authored
Merge pull request #15 from boothead/master
Generate Prisms and Lenses for ps types
2 parents 113c711 + f4cb168 commit ea9aeb8

File tree

6 files changed

+256
-9
lines changed

6 files changed

+256
-9
lines changed

‎.gitignore

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,3 +20,4 @@ cabal.sandbox.config
2020
dist
2121
dist-*
2222
shell.nix
23+
stack.yaml

‎src/Language/PureScript/Bridge.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ module Language.PureScript.Bridge (
1111

1212
import Control.Applicative
1313
import qualified Data.Map as M
14+
import qualified Data.Set as Set
1415
import qualified Data.Text.IO as T
1516

1617

@@ -73,7 +74,7 @@ writePSTypes root br sts = do
7374
let modules = M.elems $ sumTypesToModules M.empty bridged
7475
mapM_ (printModule root) modules
7576
T.putStrLn "The following purescript packages are needed by the generated code:\n"
76-
let packages = sumTypesToNeededPackages bridged
77+
let packages = Set.insert "purescript-profunctor-lenses" $ sumTypesToNeededPackages bridged
7778
mapM_ (T.putStrLn . mappend " - ") packages
7879
T.putStrLn "\nSuccessfully created your PureScript modules!"
7980

‎src/Language/PureScript/Bridge/Printer.hs

Lines changed: 116 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44

55
module Language.PureScript.Bridge.Printer where
66

7+
import Control.Lens
78
import Control.Monad
89
import Data.Map.Strict (Map)
910
import qualified Data.Map.Strict as Map
@@ -57,22 +58,37 @@ moduleToText :: Module 'PureScript -> Text
5758
moduleToText m = T.unlines $
5859
"-- File auto generated by purescript-bridge! --"
5960
: "module " <> psModuleName m <> " where\n"
60-
: map importLineToText (Map.elems (psImportLines m))
61-
++ [ "\nimport Data.Generic (class Generic)\n\n" ]
61+
: map importLineToText allImports
62+
++ [ ""
63+
, "import Prelude"
64+
, "import Data.Generic (class Generic)"
65+
, ""
66+
]
6267
++ map sumTypeToText (psTypes m)
68+
where
69+
otherImports = importsFromList _lensImports
70+
allImports = Map.elems $ mergeImportLines otherImports (psImportLines m)
6371

72+
_lensImports :: [ImportLine]
73+
_lensImports = [
74+
ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"]
75+
-- , ImportLine "Prelude" mempty
76+
, ImportLine "Data.Lens" $ Set.fromList ["PrismP", "LensP", "prism'", "lens"]
77+
]
6478

6579
importLineToText :: ImportLine -> Text
6680
importLineToText l = "import " <> importModule l <> " (" <> typeList <> ")"
6781
where
6882
typeList = T.intercalate ", " (Set.toList (importTypes l))
6983

7084
sumTypeToText :: SumType 'PureScript -> Text
71-
sumTypeToText st@(SumType t cs) = T.unlines $
85+
sumTypeToText st@(SumType t cs) = (T.unlines $
7286
"data " <> typeInfoToText True t <> " ="
7387
: " " <> T.intercalate "\n | " (map (constructorToText 4) cs)
74-
: [ "\nderive instance generic" <> _typeName t <> " :: " <> genericConstrains <> genericInstance t ]
88+
: [ "\nderive instance generic" <> _typeName t <> " :: " <> genericConstrains <> genericInstance t ])
89+
<> "\n" <> sep <> "\n" <> sumTypeToPrismsAndLenses st <> sep
7590
where
91+
sep = T.replicate 80 "-"
7692
genericInstance = ("Generic " <>) . typeInfoToText False
7793
genericConstrains
7894
| stpLength == 0 = mempty
@@ -86,6 +102,26 @@ sumTypeToText st@(SumType t cs) = T.unlines $
86102
sumTypeParameters = filter isTypeParam . Set.toList $ getUsedTypes st
87103
isTypeParam typ = _typeName typ `elem` map _typeName (_typeParameters t)
88104

105+
sumTypeToPrismsAndLenses :: SumType 'PureScript -> Text
106+
sumTypeToPrismsAndLenses st = sumTypeToPrisms st <> sumTypeToLenses st
107+
108+
sumTypeToPrisms :: SumType 'PureScript -> Text
109+
sumTypeToPrisms st = T.unlines $ map (constructorToPrism moreThan1 st) cs
110+
where
111+
cs = st ^. sumTypeConstructors
112+
moreThan1 = length cs > 1
113+
114+
115+
sumTypeToLenses :: SumType 'PureScript -> Text
116+
sumTypeToLenses st = T.unlines $ recordEntryToLens st <$> dcName <*> dcRecords
117+
where
118+
cs = st ^. sumTypeConstructors
119+
dcName = lensableConstructor ^.. traversed.sigConstructor
120+
dcRecords = lensableConstructor ^.. traversed.sigValues._Right.traverse.filtered hasUnderscore
121+
hasUnderscore e = e ^. recLabel.to (T.isPrefixOf "_")
122+
lensableConstructor = filter singleRecordCons cs ^? _head
123+
singleRecordCons (DataConstructor _ (Right _)) = True
124+
singleRecordCons _ = False
89125

90126
constructorToText :: Int -> DataConstructor 'PureScript -> Text
91127
constructorToText _ (DataConstructor n (Left ts)) = n <> " " <> T.intercalate " " (map (typeInfoToText False) ts)
@@ -95,10 +131,84 @@ constructorToText indentation (DataConstructor n (Right rs)) =
95131
<> spaces indentation <> "}"
96132
where
97133
intercalation = "\n" <> spaces indentation <> "," <> " "
98-
spaces c = T.replicate c " "
134+
135+
spaces :: Int -> Text
136+
spaces c = T.replicate c " "
137+
138+
139+
typeNameAndForall :: SumType 'PureScript -> (Text, Text)
140+
typeNameAndForall st = (typName, forAll)
141+
where
142+
typName = typeInfoToText False (st ^. sumTypeInfo)
143+
forAllParams = st ^.. sumTypeInfo.typeParameters.traversed.to (typeInfoToText False)
144+
forAll = case forAllParams of
145+
[] -> " :: "
146+
cs -> " :: forall " <> T.intercalate " " cs <> ". "
147+
-- textParameters = map (typeInfoToText False) params
148+
149+
fromEntries :: (RecordEntry a -> Text) -> [RecordEntry a] -> Text
150+
fromEntries mkElem rs = "{ " <> inners <> " }"
151+
where
152+
inners = T.intercalate ", " $ map mkElem rs
153+
154+
mkFnArgs :: [RecordEntry 'PureScript] -> Text
155+
mkFnArgs [r] = r ^. recLabel
156+
mkFnArgs rs = fromEntries (\recE -> recE ^. recLabel <> ": " <> recE ^. recLabel) rs
157+
158+
mkTypeSig :: [RecordEntry 'PureScript] -> Text
159+
mkTypeSig [] = "Unit"
160+
mkTypeSig [r] = typeInfoToText False $ r ^. recValue
161+
mkTypeSig rs = fromEntries recordEntryToText rs
162+
163+
constructorToPrism :: Bool -> SumType 'PureScript -> DataConstructor 'PureScript -> Text
164+
constructorToPrism otherConstructors st (DataConstructor n args) =
165+
case args of
166+
Left cs -> pName <> forAll <> "PrismP " <> typName <> " " <> mkTypeSig types <> "\n"
167+
<> pName <> " = prism' " <> getter <> " f\n"
168+
<> spaces 2 <> "where\n"
169+
<> spaces 4 <> "f " <> mkF cs
170+
<> otherConstructorFallThrough
171+
where
172+
mkF [] = n <> " = Just unit\n"
173+
mkF _ = "(" <> n <> " " <> T.unwords (map _recLabel types) <> ") = Just $ " <> mkFnArgs types <> "\n"
174+
getter | cs == [] = "(\\_ -> " <> n <> ")"
175+
| length cs == 1 = n
176+
| otherwise = "(\\{ " <> T.intercalate ", " cArgs <> " } -> " <> n <> " " <> T.intercalate " " cArgs <> ")"
177+
where
178+
cArgs = map (T.singleton . fst) $ zip ['a'..] cs
179+
types = [RecordEntry (T.singleton label) t | (label, t) <- zip ['a'..] cs]
180+
Right rs -> pName <> forAll <> "PrismP " <> typName <> " { " <> recordSig <> "}\n"
181+
<> pName <> " = prism' " <> n <> " f\n"
182+
<> spaces 2 <> "where\n"
183+
<> spaces 4 <> "f (" <> n <> " r) = Just r\n"
184+
<> otherConstructorFallThrough
185+
where
186+
recordSig = T.intercalate ", " (map recordEntryToText rs)
187+
where
188+
(typName, forAll) = typeNameAndForall st
189+
pName = "_" <> n
190+
otherConstructorFallThrough | otherConstructors = spaces 4 <> "f _ = Nothing\n"
191+
| otherwise = "\n"
192+
193+
recordEntryToLens :: SumType 'PureScript -> Text -> RecordEntry 'PureScript -> Text
194+
recordEntryToLens st constructorName e =
195+
case hasUnderscore of
196+
False -> ""
197+
True ->
198+
lensName <> forAll <> "LensP " <> typName <> " " <> recType <> "\n"
199+
<> lensName <> " = lens get set\n where\n"
200+
<> spaces 4 <> "get (" <> constructorName <> " r) = r." <> recName <> "\n"
201+
<> spaces 4 <> "set (" <> constructorName <> " r) = " <> setter
202+
where
203+
(typName, forAll) = typeNameAndForall st
204+
setter = constructorName <> " <<< r { " <> recName <> " = _ }\n"
205+
recName = e ^. recLabel
206+
lensName = T.drop 1 recName
207+
recType = typeInfoToText False (e ^. recValue)
208+
hasUnderscore = e ^. recLabel.to (T.isPrefixOf "_")
99209

100210
recordEntryToText :: RecordEntry 'PureScript -> Text
101-
recordEntryToText e = _recLabel e <> " :: " <> typeInfoToText True (_recValue e)
211+
recordEntryToText e = _recLabel e <> " :: " <> typeInfoToText True (e ^. recValue)
102212

103213

104214
typeInfoToText :: Bool -> PSType -> Text

‎test/Spec.hs

Lines changed: 100 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module Main where
1010

1111
import Control.Monad (unless)
1212
import qualified Data.Map as Map
13+
import Data.Monoid ((<>))
1314
import Data.Proxy
1415
import qualified Data.Text as T
1516
import Language.PureScript.Bridge
@@ -61,11 +62,12 @@ allTests =
6162
, "module TestData where"
6263
, ""
6364
, "import Data.Either (Either)"
64-
, "import Data.Maybe (Maybe)"
65+
, "import Data.Lens (LensP, PrismP, lens, prism')"
66+
, "import Data.Maybe (Maybe, Maybe(..))"
6567
, ""
68+
, "import Prelude"
6669
, "import Data.Generic (class Generic)"
6770
, ""
68-
, ""
6971
, "data Bar a b m c ="
7072
, " Bar1 (Maybe a)"
7173
, " | Bar2 (Either a b)"
@@ -76,6 +78,102 @@ allTests =
7678
, ""
7779
, "derive instance genericBar :: (Generic a, Generic b, Generic (m b)) => Generic (Bar a b m c)"
7880
, ""
81+
, "--------------------------------------------------------------------------------"
82+
, "_Bar1 :: forall a b m c. PrismP (Bar a b m c) (Maybe a)"
83+
, "_Bar1 = prism' Bar1 f"
84+
, " where"
85+
, " f (Bar1 a) = Just $ a"
86+
, " f _ = Nothing"
87+
, ""
88+
, "_Bar2 :: forall a b m c. PrismP (Bar a b m c) (Either a b)"
89+
, "_Bar2 = prism' Bar2 f"
90+
, " where"
91+
, " f (Bar2 a) = Just $ a"
92+
, " f _ = Nothing"
93+
, ""
94+
, "_Bar3 :: forall a b m c. PrismP (Bar a b m c) a"
95+
, "_Bar3 = prism' Bar3 f"
96+
, " where"
97+
, " f (Bar3 a) = Just $ a"
98+
, " f _ = Nothing"
99+
, ""
100+
, "_Bar4 :: forall a b m c. PrismP (Bar a b m c) { myMonadicResult :: m b}"
101+
, "_Bar4 = prism' Bar4 f"
102+
, " where"
103+
, " f (Bar4 r) = Just r"
104+
, " f _ = Nothing"
105+
, ""
106+
, "--------------------------------------------------------------------------------"
79107
]
80108
in m `shouldBe` txt
109+
it "test generation of Prisms" $
110+
let bar = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C)))
111+
foo = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo))
112+
barPrisms = sumTypeToPrisms bar
113+
fooPrisms = sumTypeToPrisms foo
114+
txt = T.unlines [
115+
"_Bar1 :: forall a b m c. PrismP (Bar a b m c) (Maybe a)"
116+
, "_Bar1 = prism' Bar1 f"
117+
, " where"
118+
, " f (Bar1 a) = Just $ a"
119+
, " f _ = Nothing"
120+
, ""
121+
, "_Bar2 :: forall a b m c. PrismP (Bar a b m c) (Either a b)"
122+
, "_Bar2 = prism' Bar2 f"
123+
, " where"
124+
, " f (Bar2 a) = Just $ a"
125+
, " f _ = Nothing"
126+
, ""
127+
, "_Bar3 :: forall a b m c. PrismP (Bar a b m c) a"
128+
, "_Bar3 = prism' Bar3 f"
129+
, " where"
130+
, " f (Bar3 a) = Just $ a"
131+
, " f _ = Nothing"
132+
, ""
133+
, "_Bar4 :: forall a b m c. PrismP (Bar a b m c) { myMonadicResult :: m b}"
134+
, "_Bar4 = prism' Bar4 f"
135+
, " where"
136+
, " f (Bar4 r) = Just r"
137+
, " f _ = Nothing"
138+
, ""
139+
, "_Foo :: PrismP Foo Unit"
140+
, "_Foo = prism' (\\_ -> Foo) f"
141+
, " where"
142+
, " f Foo = Just unit"
143+
, " f _ = Nothing"
144+
, ""
145+
, "_Bar :: PrismP Foo Int"
146+
, "_Bar = prism' Bar f"
147+
, " where"
148+
, " f (Bar a) = Just $ a"
149+
, " f _ = Nothing"
150+
, ""
151+
, "_FooBar :: PrismP Foo { a :: Int, b :: String }"
152+
, "_FooBar = prism' (\\{ a, b } -> FooBar a b) f"
153+
, " where"
154+
, " f (FooBar a b) = Just $ { a: a, b: b }"
155+
, " f _ = Nothing"
156+
, ""
157+
]
158+
in (barPrisms <> fooPrisms) `shouldBe` txt
159+
it "tests generation of lenses" $
160+
let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (SingleRecord A B)))
161+
bar = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C)))
162+
barLenses = sumTypeToLenses bar
163+
recTypeLenses = sumTypeToLenses recType
164+
txt = T.unlines [
165+
"a :: forall a b. LensP (SingleRecord a b) a"
166+
, "a = lens get set"
167+
, " where"
168+
, " get (SingleRecord r) = r._a"
169+
, " set (SingleRecord r) = SingleRecord <<< r { _a = _ }"
170+
, ""
171+
, "b :: forall a b. LensP (SingleRecord a b) b"
172+
, "b = lens get set"
173+
, " where"
174+
, " get (SingleRecord r) = r._b"
175+
, " set (SingleRecord r) = SingleRecord <<< r { _b = _ }"
176+
, ""
177+
]
178+
in (barLenses <> recTypeLenses) `shouldBe` txt
81179

‎test/TestData.hs

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,11 @@ data Bar a b m c = Bar1 (Maybe a) | Bar2 (Either a b) | Bar3 a
4444
| Bar4 { myMonadicResult :: m b }
4545
deriving (Generic, Typeable, Show)
4646

47+
data SingleRecord a b = SingleRecord {
48+
_a :: a
49+
, _b :: b
50+
, c :: String
51+
} deriving(Generic, Typeable, Show)
4752

4853
a :: HaskellType
4954
a = mkTypeInfo (Proxy :: Proxy (Either String Int))

‎test/out.txt

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
module Main where
2+
3+
_Bar1 :: PrismP (Bar a b m c) (Maybe a)
4+
_Bar1 = prism' Bar1 f
5+
where
6+
f a = Just $ Bar1 a
7+
_Bar2 :: PrismP (Bar a b m c) (Either a b)
8+
_Bar2 = prism' Bar2 f
9+
where
10+
f a = Just $ Bar2 a
11+
_Bar3 :: PrismP (Bar a b m c) a
12+
_Bar3 = prism' Bar3 f
13+
where
14+
f a = Just $ Bar3 a
15+
_Bar4 :: PrismP (Bar a b m c) { myMonadicResult :: m b}
16+
_Bar4 = prism' Bar4 f
17+
where
18+
f (Bar4 r) = Just r
19+
f _ = Nothing
20+
21+
_Foo :: PrismP Foo { }
22+
_Foo = prism' Foo f
23+
where
24+
f _ = Just Foo
25+
_Bar :: PrismP Foo Int
26+
_Bar = prism' Bar f
27+
where
28+
f a = Just $ Bar a
29+
_FooBar :: PrismP Foo { a :: Int, b :: String }
30+
_FooBar = prism' FooBar f
31+
where
32+
f { a: a, b: b } = Just $ FooBar a b

0 commit comments

Comments
 (0)