{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Main where
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Proxy
import qualified Data.Text as T
import Language.PureScript.Bridge
import Language.PureScript.Bridge.TypeParameters
import Test.Hspec (Spec, describe,
hspec, it)
import Test.Hspec.Expectations.Pretty
import TestData
main :: IO ()
main = hspec $ allTests
allTests :: Spec
allTests =
describe "buildBridge" $ do
it "tests with Int" $
let bst = buildBridge defaultBridge (mkTypeInfo (Proxy :: Proxy Int))
ti = TypeInfo { _typePackage = "purescript-prim"
, _typeModule = "Prim"
, _typeName = "Int"
, _typeParameters = []}
in bst `shouldBe` ti
it "tests with custom type Foo" $
let bst = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo))
st = SumType
TypeInfo { _typePackage = "" , _typeModule = "TestData" , _typeName = "Foo" , _typeParameters = [] }
[ DataConstructor { _sigConstructor = "Foo" , _sigValues = Left [] }
, DataConstructor
{ _sigConstructor = "Bar"
, _sigValues = Left [ TypeInfo { _typePackage = "purescript-prim" , _typeModule = "Prim" , _typeName = "Int" , _typeParameters = [] } ]
}
, DataConstructor
{ _sigConstructor = "FooBar"
, _sigValues = Left [ TypeInfo { _typePackage = "purescript-prim" , _typeModule = "Prim" , _typeName = "Int" , _typeParameters = [] }
, TypeInfo { _typePackage = "purescript-prim" , _typeModule = "Prim" , _typeName = "String" , _typeParameters = [] }
]
}
]
in bst `shouldBe` st
it "tests generation of for custom type Foo" $
let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo))
recTypeText = sumTypeToText recType
txt = T.stripEnd $
T.unlines [ "data Foo ="
, " Foo"
, " | Bar Int"
, " | FooBar Int String"
, ""
, "derive instance genericFoo :: Generic Foo"
, ""
, ""
, "--------------------------------------------------------------------------------"
, "_Foo :: Prism' Foo Unit"
, "_Foo = prism' (\\_ -> Foo) f"
, " where"
, " f Foo = Just unit"
, " f _ = Nothing"
, ""
, "_Bar :: Prism' Foo Int"
, "_Bar = prism' Bar f"
, " where"
, " f (Bar a) = Just $ a"
, " f _ = Nothing"
, ""
, "_FooBar :: Prism' 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 recTypeText `shouldBe` txt
it "tests the generation of a whole (dummy) module" $
let advanced = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C)))
modules = sumTypeToModule advanced Map.empty
m = head . map moduleToText . Map.elems $ modules
txt = T.unlines [ "-- File auto generated by purescript-bridge! --"
, "module TestData where"
, ""
, "import Data.Either (Either)"
, "import Data.Lens (Iso', Lens', Prism', lens, prism')"
, "import Data.Lens.Iso.Newtype (_Newtype)"
, "import Data.Lens.Record (prop)"
, "import Data.Maybe (Maybe, Maybe(..))"
, "import Data.Newtype (class Newtype)"
, "import Data.Symbol (SProxy(SProxy))"
, ""
, "import Prelude"
, "import Data.Generic (class Generic)"
, ""
, "data Bar a b m c ="
, " Bar1 (Maybe a)"
, " | Bar2 (Either a b)"
, " | Bar3 a"
, " | Bar4 {"
, " myMonadicResult :: m b"
, " }"
, ""
, "derive instance genericBar :: (Generic a, Generic b, Generic (m b)) => Generic (Bar a b m c)"
, ""
, ""
, "--------------------------------------------------------------------------------"
, "_Bar1 :: forall a b m c. Prism' (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. Prism' (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. Prism' (Bar a b m c) a"
, "_Bar3 = prism' Bar3 f"
, " where"
, " f (Bar3 a) = Just $ a"
, " f _ = Nothing"
, ""
, "_Bar4 :: forall a b m c. Prism' (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 constructor optics" $
let bar = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C)))
foo = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy Foo))
barOptics = constructorOptics bar
fooOptics = constructorOptics foo
txt = T.unlines [
"_Bar1 :: forall a b m c. Prism' (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. Prism' (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. Prism' (Bar a b m c) a"
, "_Bar3 = prism' Bar3 f"
, " where"
, " f (Bar3 a) = Just $ a"
, " f _ = Nothing"
, ""
, "_Bar4 :: forall a b m c. Prism' (Bar a b m c) { myMonadicResult :: m b }"
, "_Bar4 = prism' Bar4 f"
, " where"
, " f (Bar4 r) = Just r"
, " f _ = Nothing"
, ""
, "_Foo :: Prism' Foo Unit"
, "_Foo = prism' (\\_ -> Foo) f"
, " where"
, " f Foo = Just unit"
, " f _ = Nothing"
, ""
, "_Bar :: Prism' Foo Int"
, "_Bar = prism' Bar f"
, " where"
, " f (Bar a) = Just $ a"
, " f _ = Nothing"
, ""
, "_FooBar :: Prism' 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 (barOptics <> fooOptics) `shouldBe` txt
it "tests generation of record optics" $
let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (SingleRecord A B)))
bar = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (Bar A B M1 C)))
barOptics = recordOptics bar
recTypeOptics = recordOptics recType
txt = T.unlines [
"a :: forall a b. Lens' (SingleRecord a b) a"
, "a = _Newtype <<< prop (SProxy :: SProxy \"_a\")"
, ""
, "b :: forall a b. Lens' (SingleRecord a b) b"
, "b = _Newtype <<< prop (SProxy :: SProxy \"_b\")"
, ""
]
in (barOptics <> recTypeOptics) `shouldBe` txt
it "tests generation of newtypes for record data type" $
let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy (SingleRecord A B)))
recTypeText = sumTypeToText recType
txt = T.stripEnd $
T.unlines [ "newtype SingleRecord a b ="
, " SingleRecord {"
, " _a :: a"
, " , _b :: b"
, " , c :: String"
, " }"
, ""
, "derive instance genericSingleRecord :: (Generic a, Generic b) => Generic (SingleRecord a b)"
, ""
, "derive instance newtypeSingleRecord :: Newtype (SingleRecord a b) _"
, ""
, ""
, "--------------------------------------------------------------------------------"
, "_SingleRecord :: forall a b. Iso' (SingleRecord a b) { _a :: a, _b :: b, c :: String}"
, "_SingleRecord = _Newtype"
,""
, "a :: forall a b. Lens' (SingleRecord a b) a"
, "a = _Newtype <<< prop (SProxy :: SProxy \"_a\")"
, ""
, "b :: forall a b. Lens' (SingleRecord a b) b"
, "b = _Newtype <<< prop (SProxy :: SProxy \"_b\")"
, ""
, "--------------------------------------------------------------------------------"
]
in recTypeText `shouldBe` txt
it "tests generation of newtypes for haskell newtype" $
let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy SomeNewtype))
recTypeText = sumTypeToText recType
txt = T.stripEnd $
T.unlines [ "newtype SomeNewtype ="
, " SomeNewtype Int"
, ""
, "derive instance genericSomeNewtype :: Generic SomeNewtype"
, ""
, "derive instance newtypeSomeNewtype :: Newtype SomeNewtype _"
, ""
, ""
, "--------------------------------------------------------------------------------"
, "_SomeNewtype :: Iso' SomeNewtype Int"
, "_SomeNewtype = _Newtype"
, "--------------------------------------------------------------------------------"
]
in recTypeText `shouldBe` txt
it "tests generation of newtypes for haskell data type with one argument" $
let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy SingleValueConstr))
recTypeText = sumTypeToText recType
txt = T.stripEnd $
T.unlines [ "newtype SingleValueConstr ="
, " SingleValueConstr Int"
, ""
, "derive instance genericSingleValueConstr :: Generic SingleValueConstr"
, ""
, "derive instance newtypeSingleValueConstr :: Newtype SingleValueConstr _"
, ""
, ""
, "--------------------------------------------------------------------------------"
, "_SingleValueConstr :: Iso' SingleValueConstr Int"
, "_SingleValueConstr = _Newtype"
, "--------------------------------------------------------------------------------"
]
in recTypeText `shouldBe` txt
it "tests that sum types with multiple constructors don't generate record optics" $
let recType = bridgeSumType (buildBridge defaultBridge) (mkSumType (Proxy :: Proxy TwoRecords))
recTypeOptics = recordOptics recType
in recTypeOptics `shouldBe` "" -- No record optics for multi-constructors