Skip to content

Commit

Permalink
Merge pull request #15 from boothead/master
Browse files Browse the repository at this point in the history 
Generate Prisms and Lenses for ps types
  • Loading branch information
@eskimor
eskimor authored Jan 14, 2017
2 parents 113c711 + f4cb168 commit ea9aeb8
Show file tree
Hide file tree
Showing 6 changed files with 256 additions and 9 deletions.
1 change: 1 addition & 0 deletions .gitignore
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,3 +20,4 @@ cabal.sandbox.config
dist
dist-*
shell.nix
stack.yaml
3 changes: 2 additions & 1 deletion src/Language/PureScript/Bridge.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ module Language.PureScript.Bridge (

import Control.Applicative
import qualified Data.Map as M
import qualified Data.Set as Set
import qualified Data.Text.IO as T


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

Expand Down
122 changes: 116 additions & 6 deletions src/Language/PureScript/Bridge/Printer.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@

module Language.PureScript.Bridge.Printer where

import Control.Lens
import Control.Monad
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
Expand Down Expand Up @@ -57,22 +58,37 @@ moduleToText :: Module 'PureScript -> Text
moduleToText m = T.unlines $
"-- File auto generated by purescript-bridge! --"
: "module " <> psModuleName m <> " where\n"
: map importLineToText (Map.elems (psImportLines m))
++ [ "\nimport Data.Generic (class Generic)\n\n" ]
: map importLineToText allImports
++ [ ""
, "import Prelude"
, "import Data.Generic (class Generic)"
, ""
]
++ map sumTypeToText (psTypes m)
where
otherImports = importsFromList _lensImports
allImports = Map.elems $ mergeImportLines otherImports (psImportLines m)

_lensImports :: [ImportLine]
_lensImports = [
ImportLine "Data.Maybe" $ Set.fromList ["Maybe(..)"]
-- , ImportLine "Prelude" mempty
, ImportLine "Data.Lens" $ Set.fromList ["PrismP", "LensP", "prism'", "lens"]
]

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

sumTypeToText :: SumType 'PureScript -> Text
sumTypeToText st@(SumType t cs) = T.unlines $
sumTypeToText st@(SumType t cs) = (T.unlines $
"data " <> typeInfoToText True t <> " ="
: " " <> T.intercalate "\n | " (map (constructorToText 4) cs)
: [ "\nderive instance generic" <> _typeName t <> " :: " <> genericConstrains <> genericInstance t ]
: [ "\nderive instance generic" <> _typeName t <> " :: " <> genericConstrains <> genericInstance t ])
<> "\n" <> sep <> "\n" <> sumTypeToPrismsAndLenses st <> sep
where
sep = T.replicate 80 "-"
genericInstance = ("Generic " <>) . typeInfoToText False
genericConstrains
| stpLength == 0 = mempty
Expand All @@ -86,6 +102,26 @@ sumTypeToText st@(SumType t cs) = T.unlines $
sumTypeParameters = filter isTypeParam . Set.toList $ getUsedTypes st
isTypeParam typ = _typeName typ `elem` map _typeName (_typeParameters t)

sumTypeToPrismsAndLenses :: SumType 'PureScript -> Text
sumTypeToPrismsAndLenses st = sumTypeToPrisms st <> sumTypeToLenses st

sumTypeToPrisms :: SumType 'PureScript -> Text
sumTypeToPrisms st = T.unlines $ map (constructorToPrism moreThan1 st) cs
where
cs = st ^. sumTypeConstructors
moreThan1 = length cs > 1


sumTypeToLenses :: SumType 'PureScript -> Text
sumTypeToLenses st = T.unlines $ recordEntryToLens st <$> dcName <*> dcRecords
where
cs = st ^. sumTypeConstructors
dcName = lensableConstructor ^.. traversed.sigConstructor
dcRecords = lensableConstructor ^.. traversed.sigValues._Right.traverse.filtered hasUnderscore
hasUnderscore e = e ^. recLabel.to (T.isPrefixOf "_")
lensableConstructor = filter singleRecordCons cs ^? _head
singleRecordCons (DataConstructor _ (Right _)) = True
singleRecordCons _ = False

constructorToText :: Int -> DataConstructor 'PureScript -> Text
constructorToText _ (DataConstructor n (Left ts)) = n <> " " <> T.intercalate " " (map (typeInfoToText False) ts)
Expand All @@ -95,10 +131,84 @@ constructorToText indentation (DataConstructor n (Right rs)) =
<> spaces indentation <> "}"
where
intercalation = "\n" <> spaces indentation <> "," <> " "
spaces c = T.replicate c " "

spaces :: Int -> Text
spaces c = T.replicate c " "


typeNameAndForall :: SumType 'PureScript -> (Text, Text)
typeNameAndForall st = (typName, forAll)
where
typName = typeInfoToText False (st ^. sumTypeInfo)
forAllParams = st ^.. sumTypeInfo.typeParameters.traversed.to (typeInfoToText False)
forAll = case forAllParams of
[] -> " :: "
cs -> " :: forall " <> T.intercalate " " cs <> ". "
-- textParameters = map (typeInfoToText False) params

fromEntries :: (RecordEntry a -> Text) -> [RecordEntry a] -> Text
fromEntries mkElem rs = "{ " <> inners <> " }"
where
inners = T.intercalate ", " $ map mkElem rs

mkFnArgs :: [RecordEntry 'PureScript] -> Text
mkFnArgs [r] = r ^. recLabel
mkFnArgs rs = fromEntries (\recE -> recE ^. recLabel <> ": " <> recE ^. recLabel) rs

mkTypeSig :: [RecordEntry 'PureScript] -> Text
mkTypeSig [] = "Unit"
mkTypeSig [r] = typeInfoToText False $ r ^. recValue
mkTypeSig rs = fromEntries recordEntryToText rs

constructorToPrism :: Bool -> SumType 'PureScript -> DataConstructor 'PureScript -> Text
constructorToPrism otherConstructors st (DataConstructor n args) =
case args of
Left cs -> pName <> forAll <> "PrismP " <> typName <> " " <> mkTypeSig types <> "\n"
<> pName <> " = prism' " <> getter <> " f\n"
<> spaces 2 <> "where\n"
<> spaces 4 <> "f " <> mkF cs
<> otherConstructorFallThrough
where
mkF [] = n <> " = Just unit\n"
mkF _ = "(" <> n <> " " <> T.unwords (map _recLabel types) <> ") = Just $ " <> mkFnArgs types <> "\n"
getter | cs == [] = "(\\_ -> " <> n <> ")"
| length cs == 1 = n
| otherwise = "(\\{ " <> T.intercalate ", " cArgs <> " } -> " <> n <> " " <> T.intercalate " " cArgs <> ")"
where
cArgs = map (T.singleton . fst) $ zip ['a'..] cs
types = [RecordEntry (T.singleton label) t | (label, t) <- zip ['a'..] cs]
Right rs -> pName <> forAll <> "PrismP " <> typName <> " { " <> recordSig <> "}\n"
<> pName <> " = prism' " <> n <> " f\n"
<> spaces 2 <> "where\n"
<> spaces 4 <> "f (" <> n <> " r) = Just r\n"
<> otherConstructorFallThrough
where
recordSig = T.intercalate ", " (map recordEntryToText rs)
where
(typName, forAll) = typeNameAndForall st
pName = "_" <> n
otherConstructorFallThrough | otherConstructors = spaces 4 <> "f _ = Nothing\n"
| otherwise = "\n"

recordEntryToLens :: SumType 'PureScript -> Text -> RecordEntry 'PureScript -> Text
recordEntryToLens st constructorName e =
case hasUnderscore of
False -> ""
True ->
lensName <> forAll <> "LensP " <> typName <> " " <> recType <> "\n"
<> lensName <> " = lens get set\n where\n"
<> spaces 4 <> "get (" <> constructorName <> " r) = r." <> recName <> "\n"
<> spaces 4 <> "set (" <> constructorName <> " r) = " <> setter
where
(typName, forAll) = typeNameAndForall st
setter = constructorName <> " <<< r { " <> recName <> " = _ }\n"
recName = e ^. recLabel
lensName = T.drop 1 recName
recType = typeInfoToText False (e ^. recValue)
hasUnderscore = e ^. recLabel.to (T.isPrefixOf "_")

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


typeInfoToText :: Bool -> PSType -> Text
Expand Down
102 changes: 100 additions & 2 deletions test/Spec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@ module Main where

import Control.Monad (unless)
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Proxy
import qualified Data.Text as T
import Language.PureScript.Bridge
Expand Down Expand Up @@ -61,11 +62,12 @@ allTests =
, "module TestData where"
, ""
, "import Data.Either (Either)"
, "import Data.Maybe (Maybe)"
, "import Data.Lens (LensP, PrismP, lens, prism')"
, "import Data.Maybe (Maybe, Maybe(..))"
, ""
, "import Prelude"
, "import Data.Generic (class Generic)"
, ""
, ""
, "data Bar a b m c ="
, " Bar1 (Maybe a)"
, " | Bar2 (Either a b)"
Expand All @@ -76,6 +78,102 @@ allTests =
, ""
, "derive instance genericBar :: (Generic a, Generic b, Generic (m b)) => Generic (Bar a b m c)"
, ""
, "--------------------------------------------------------------------------------"
, "_Bar1 :: forall a b m c. PrismP (Bar a b m c) (Maybe a)"
, "_Bar1 = prism' Bar1 f"
, " where"
, " f (Bar1 a) = Just $ a"
, " f _ = Nothing"
, ""
, "_Bar2 :: forall a b m c. PrismP (Bar a b m c) (Either a b)"
, "_Bar2 = prism' Bar2 f"
, " where"
, " f (Bar2 a) = Just $ a"
, " f _ = Nothing"
, ""
, "_Bar3 :: forall a b m c. PrismP (Bar a b m c) a"
, "_Bar3 = prism' Bar3 f"
, " where"
, " f (Bar3 a) = Just $ a"
, " f _ = Nothing"
, ""
, "_Bar4 :: forall a b m c. PrismP (Bar a b m c) { myMonadicResult :: m b}"
, "_Bar4 = prism' Bar4 f"
, " where"
, " f (Bar4 r) = Just r"
, " f _ = Nothing"
, ""
, "--------------------------------------------------------------------------------"
]
in m `shouldBe` txt
it "test generation of Prisms" $
let bar = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C)))
foo = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo))
barPrisms = sumTypeToPrisms bar
fooPrisms = sumTypeToPrisms foo
txt = T.unlines [
"_Bar1 :: forall a b m c. PrismP (Bar a b m c) (Maybe a)"
, "_Bar1 = prism' Bar1 f"
, " where"
, " f (Bar1 a) = Just $ a"
, " f _ = Nothing"
, ""
, "_Bar2 :: forall a b m c. PrismP (Bar a b m c) (Either a b)"
, "_Bar2 = prism' Bar2 f"
, " where"
, " f (Bar2 a) = Just $ a"
, " f _ = Nothing"
, ""
, "_Bar3 :: forall a b m c. PrismP (Bar a b m c) a"
, "_Bar3 = prism' Bar3 f"
, " where"
, " f (Bar3 a) = Just $ a"
, " f _ = Nothing"
, ""
, "_Bar4 :: forall a b m c. PrismP (Bar a b m c) { myMonadicResult :: m b}"
, "_Bar4 = prism' Bar4 f"
, " where"
, " f (Bar4 r) = Just r"
, " f _ = Nothing"
, ""
, "_Foo :: PrismP Foo Unit"
, "_Foo = prism' (\\_ -> Foo) f"
, " where"
, " f Foo = Just unit"
, " f _ = Nothing"
, ""
, "_Bar :: PrismP Foo Int"
, "_Bar = prism' Bar f"
, " where"
, " f (Bar a) = Just $ a"
, " f _ = Nothing"
, ""
, "_FooBar :: PrismP Foo { a :: Int, b :: String }"
, "_FooBar = prism' (\\{ a, b } -> FooBar a b) f"
, " where"
, " f (FooBar a b) = Just $ { a: a, b: b }"
, " f _ = Nothing"
, ""
]
in (barPrisms <> fooPrisms) `shouldBe` txt
it "tests generation of lenses" $
let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (SingleRecord A B)))
bar = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C)))
barLenses = sumTypeToLenses bar
recTypeLenses = sumTypeToLenses recType
txt = T.unlines [
"a :: forall a b. LensP (SingleRecord a b) a"
, "a = lens get set"
, " where"
, " get (SingleRecord r) = r._a"
, " set (SingleRecord r) = SingleRecord <<< r { _a = _ }"
, ""
, "b :: forall a b. LensP (SingleRecord a b) b"
, "b = lens get set"
, " where"
, " get (SingleRecord r) = r._b"
, " set (SingleRecord r) = SingleRecord <<< r { _b = _ }"
, ""
]
in (barLenses <> recTypeLenses) `shouldBe` txt

5 changes: 5 additions & 0 deletions test/TestData.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -44,6 +44,11 @@ data Bar a b m c = Bar1 (Maybe a) | Bar2 (Either a b) | Bar3 a
| Bar4 { myMonadicResult :: m b }
deriving (Generic, Typeable, Show)

data SingleRecord a b = SingleRecord {
_a :: a
, _b :: b
, c :: String
} deriving(Generic, Typeable, Show)

a :: HaskellType
a = mkTypeInfo (Proxy :: Proxy (Either String Int))
Expand Down
32 changes: 32 additions & 0 deletions test/out.txt
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,32 @@
module Main where

_Bar1 :: PrismP (Bar a b m c) (Maybe a)
_Bar1 = prism' Bar1 f
where
f a = Just $ Bar1 a
_Bar2 :: PrismP (Bar a b m c) (Either a b)
_Bar2 = prism' Bar2 f
where
f a = Just $ Bar2 a
_Bar3 :: PrismP (Bar a b m c) a
_Bar3 = prism' Bar3 f
where
f a = Just $ Bar3 a
_Bar4 :: PrismP (Bar a b m c) { myMonadicResult :: m b}
_Bar4 = prism' Bar4 f
where
f (Bar4 r) = Just r
f _ = Nothing

_Foo :: PrismP Foo { }
_Foo = prism' Foo f
where
f _ = Just Foo
_Bar :: PrismP Foo Int
_Bar = prism' Bar f
where
f a = Just $ Bar a
_FooBar :: PrismP Foo { a :: Int, b :: String }
_FooBar = prism' FooBar f
where
f { a: a, b: b } = Just $ FooBar a b

0 comments on commit ea9aeb8

Please sign in to comment.