{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
module Language.PureScript.Bridge.Printer where
import Control.Lens
import Control.Monad
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Monoid ((<>))
import Data.Set (Set)
import Data.Maybe (isJust)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.Directory
import System.FilePath
import Language.PureScript.Bridge.SumType
import Language.PureScript.Bridge.TypeInfo
import qualified Language.PureScript.Bridge.CodeGenSwitches as Switches
data Module (lang :: Language) = PSModule {
forall (lang :: Language). Module lang -> Text
psModuleName :: !Text
, forall (lang :: Language). Module lang -> Map Text ImportLine
psImportLines :: !(Map Text ImportLine)
, forall (lang :: Language). Module lang -> [SumType lang]
psTypes :: ![SumType lang]
} deriving Int -> Module lang -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (lang :: Language). Int -> Module lang -> ShowS
forall (lang :: Language). [Module lang] -> ShowS
forall (lang :: Language). Module lang -> String
showList :: [Module lang] -> ShowS
$cshowList :: forall (lang :: Language). [Module lang] -> ShowS
show :: Module lang -> String
$cshow :: forall (lang :: Language). Module lang -> String
showsPrec :: Int -> Module lang -> ShowS
$cshowsPrec :: forall (lang :: Language). Int -> Module lang -> ShowS
Show
type PSModule = Module 'PureScript
data ImportLine = ImportLine {
ImportLine -> Text
importModule :: !Text
, ImportLine -> Maybe Text
importAlias :: !(Maybe Text)
, ImportLine -> Set Text
importTypes :: !(Set Text)
} deriving Int -> ImportLine -> ShowS
[ImportLine] -> ShowS
ImportLine -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImportLine] -> ShowS
$cshowList :: [ImportLine] -> ShowS
show :: ImportLine -> String
$cshow :: ImportLine -> String
showsPrec :: Int -> ImportLine -> ShowS
$cshowsPrec :: Int -> ImportLine -> ShowS
Show
type Modules = Map Text PSModule
type ImportLines = Map Text ImportLine
printModule :: Switches.Settings -> FilePath -> PSModule -> IO ()
printModule :: Settings -> String -> PSModule -> IO ()
printModule Settings
settings String
root PSModule
m = do
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (String -> IO Bool
doesDirectoryExist String
mDir) forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
mDir
String -> Text -> IO ()
T.writeFile String
mPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> PSModule -> Text
moduleToText Settings
settings forall a b. (a -> b) -> a -> b
$ PSModule
m
where
mFile :: String
mFile = ([String] -> String
joinPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
"." forall a b. (a -> b) -> a -> b
$ forall (lang :: Language). Module lang -> Text
psModuleName PSModule
m) forall a. Semigroup a => a -> a -> a
<> String
".purs"
mPath :: String
mPath = String
root String -> ShowS
</> String
mFile
mDir :: String
mDir = ShowS
takeDirectory String
mPath
sumTypesToNeededPackages :: [SumType lang] -> Set Text
sumTypesToNeededPackages :: forall (lang :: Language). [SumType lang] -> Set Text
sumTypesToNeededPackages = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (lang :: Language). SumType lang -> Set Text
sumTypeToNeededPackages
sumTypeToNeededPackages :: SumType lang -> Set Text
sumTypeToNeededPackages :: forall (lang :: Language). SumType lang -> Set Text
sumTypeToNeededPackages SumType lang
st =
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (lang :: Language). TypeInfo lang -> Text
_typePackage forall a b. (a -> b) -> a -> b
$ forall (lang :: Language). SumType lang -> Set (TypeInfo lang)
getUsedTypes SumType lang
st
moduleToText :: Switches.Settings -> Module 'PureScript -> Text
moduleToText :: Settings -> PSModule -> Text
moduleToText Settings
settings PSModule
m = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
Text
"-- File auto generated by purescript-bridge! --"
forall a. a -> [a] -> [a]
: Text
"module " forall a. Semigroup a => a -> a -> a
<> forall (lang :: Language). Module lang -> Text
psModuleName PSModule
m forall a. Semigroup a => a -> a -> a
<> Text
" where\n"
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ImportLine -> Text
importLineToText [ImportLine]
allImports
forall a. Semigroup a => a -> a -> a
<> [ Text
""
, Text
"import Prelude"
, Text
""
]
forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (Settings -> SumType 'PureScript -> Text
sumTypeToText Settings
settings) (forall (lang :: Language). Module lang -> [SumType lang]
psTypes PSModule
m)
where
otherImports :: Map Text ImportLine
otherImports = [ImportLine] -> Map Text ImportLine
importsFromList forall a b. (a -> b) -> a -> b
$
Settings -> [ImportLine]
_lensImports Settings
settings
forall a. Semigroup a => a -> a -> a
<> Settings -> [ImportLine]
_genericsImports Settings
settings
forall a. Semigroup a => a -> a -> a
<> Settings -> [ImportLine]
_argonautCodecsImports Settings
settings
forall a. Semigroup a => a -> a -> a
<> Settings -> [ImportLine]
_foreignImports Settings
settings
allImports :: [ImportLine]
allImports = forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Map Text ImportLine -> Map Text ImportLine -> Map Text ImportLine
mergeImportLines Map Text ImportLine
otherImports (forall (lang :: Language). Module lang -> Map Text ImportLine
psImportLines PSModule
m)
_genericsImports :: Switches.Settings -> [ImportLine]
_genericsImports :: Settings -> [ImportLine]
_genericsImports Settings
settings
| Settings -> Bool
Switches.genericsGenRep Settings
settings =
[ Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Generic.Rep" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Text
"class Generic"] ]
| Bool
otherwise =
[ Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Generic" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Text
"class Generic"] ]
_lensImports :: Switches.Settings -> [ImportLine]
_lensImports :: Settings -> [ImportLine]
_lensImports Settings
settings
| Settings -> Bool
Switches.generateLenses Settings
settings =
[ Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Lens" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Text
"Iso'", Text
"Prism'", Text
"Lens'", Text
"prism'", Text
"lens"]
, Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Lens.Iso.Newtype" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Text
"_Newtype"]
, Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Lens.Record" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Text
"prop"]
] forall a. Semigroup a => a -> a -> a
<> [ImportLine]
baseline forall a. Semigroup a => a -> a -> a
<>
[ Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Type.Proxy" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Text
"Proxy(Proxy)"]
]
| Bool
otherwise = [ImportLine]
baseline
where
baseline :: [ImportLine]
baseline =
[ Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Maybe" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Text
"Maybe(..)"]
, Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Newtype" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Text
"class Newtype"]
]
_argonautCodecsImports :: Switches.Settings -> [ImportLine]
_argonautCodecsImports :: Settings -> [ImportLine]
_argonautCodecsImports Settings
settings
| Settings -> Bool
Switches.generateArgonautCodecs Settings
settings =
[ Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Argonaut.Aeson.Decode.Generic" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [ Text
"genericDecodeAeson" ]
, Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Argonaut.Aeson.Encode.Generic" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [ Text
"genericEncodeAeson" ]
, Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Argonaut.Aeson.Options" (forall a. a -> Maybe a
Just Text
"Argonaut") forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [ Text
"defaultOptions" ]
, Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Argonaut.Decode.Class" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [ Text
"class DecodeJson", Text
"class DecodeJsonField", Text
"decodeJson" ]
, Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Data.Argonaut.Encode.Class" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [ Text
"class EncodeJson", Text
"encodeJson" ]
]
| Bool
otherwise = forall a. Monoid a => a
mempty
_foreignImports :: Switches.Settings -> [ImportLine]
_foreignImports :: Settings -> [ImportLine]
_foreignImports Settings
settings
| (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Maybe ForeignOptions
Switches.generateForeign) Settings
settings =
[ Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Foreign.Class" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Text
"class Decode", Text
"class Encode"]
, Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
"Foreign.Generic" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Text
"defaultOptions", Text
"genericDecode", Text
"genericEncode"]
]
| Bool
otherwise = forall a. Monoid a => a
mempty
importLineToText :: ImportLine -> Text
importLineToText :: ImportLine -> Text
importLineToText = \case
ImportLine Text
importModule Maybe Text
Nothing Set Text
importTypes ->
Text
"import " forall a. Semigroup a => a -> a -> a
<> Text
importModule forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> Set Text -> Text
typeList Set Text
importTypes forall a. Semigroup a => a -> a -> a
<> Text
")"
ImportLine Text
importModule (Just Text
importAlias) Set Text
_ ->
Text
"import " forall a. Semigroup a => a -> a -> a
<> Text
importModule forall a. Semigroup a => a -> a -> a
<> Text
" as " forall a. Semigroup a => a -> a -> a
<> Text
importAlias
where
typeList :: Set Text -> Text
typeList Set Text
s = Text -> [Text] -> Text
T.intercalate Text
", " (forall a. Set a -> [a]
Set.toList Set Text
s)
sumTypeToText :: Switches.Settings -> SumType 'PureScript -> Text
sumTypeToText :: Settings -> SumType 'PureScript -> Text
sumTypeToText Settings
settings SumType 'PureScript
st =
Settings -> SumType 'PureScript -> Text
sumTypeToTypeDecls Settings
settings SumType 'PureScript
st forall a. Semigroup a => a -> a -> a
<> Text
additionalCode
where
additionalCode :: Text
additionalCode =
if Settings -> Bool
Switches.generateLenses Settings
settings then Text
lenses else forall a. Monoid a => a
mempty
lenses :: Text
lenses = Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
sep forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> SumType 'PureScript -> Text
sumTypeToOptics SumType 'PureScript
st forall a. Semigroup a => a -> a -> a
<> Text
sep
sep :: Text
sep = Int -> Text -> Text
T.replicate Int
80 Text
"-"
sumTypeToTypeDecls :: Switches.Settings -> SumType 'PureScript -> Text
sumTypeToTypeDecls :: Settings -> SumType 'PureScript -> Text
sumTypeToTypeDecls Settings
settings (SumType PSType
t [DataConstructor 'PureScript]
cs [Instance]
is) = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
Text
dataOrNewtype forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
True PSType
t forall a. Semigroup a => a -> a -> a
<> Text
" ="
forall a. a -> [a] -> [a]
: Text
" " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\n | " (forall a b. (a -> b) -> [a] -> [b]
map (Int -> DataConstructor 'PureScript -> Text
constructorToText Int
4) [DataConstructor 'PureScript]
cs) forall a. Semigroup a => a -> a -> a
<> Text
"\n"
forall a. a -> [a] -> [a]
: Settings -> SumType 'PureScript -> [Text]
instances Settings
settings (forall (lang :: Language).
TypeInfo lang
-> [DataConstructor lang] -> [Instance] -> SumType lang
SumType PSType
t [DataConstructor 'PureScript]
cs (forall a. (a -> Bool) -> [a] -> [a]
filter Instance -> Bool
genForeign forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter Instance -> Bool
genArgonautCodec forall a b. (a -> b) -> a -> b
$ [Instance]
is))
where
dataOrNewtype :: Text
dataOrNewtype = if forall a. Maybe a -> Bool
isJust (forall (lang :: Language). [DataConstructor lang] -> Maybe Instance
nootype [DataConstructor 'PureScript]
cs) then Text
"newtype" else Text
"data"
genForeign :: Instance -> Bool
genForeign :: Instance -> Bool
genForeign = \case
Instance
Encode -> Bool
check
Instance
Decode -> Bool
check
Instance
_ -> Bool
True
where check :: Bool
check = (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Maybe ForeignOptions
Switches.generateForeign) Settings
settings
genArgonautCodec :: Instance -> Bool
genArgonautCodec :: Instance -> Bool
genArgonautCodec = \case
Instance
EncodeJson -> Bool
check
Instance
DecodeJson -> Bool
check
Instance
_ -> Bool
True
where check :: Bool
check = Settings -> Bool
Switches.generateArgonautCodecs Settings
settings
foreignOptionsToPurescript :: Maybe Switches.ForeignOptions -> Text
foreignOptionsToPurescript :: Maybe ForeignOptions -> Text
foreignOptionsToPurescript = \case
Maybe ForeignOptions
Nothing -> forall a. Monoid a => a
mempty
Just (Switches.ForeignOptions{Bool
unwrapSingleArguments :: ForeignOptions -> Bool
unwrapSingleConstructors :: ForeignOptions -> Bool
unwrapSingleArguments :: Bool
unwrapSingleConstructors :: Bool
..}) ->
Text
" { unwrapSingleConstructors = "
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Bool
unwrapSingleConstructors)
forall a. Semigroup a => a -> a -> a
<> Text
" , unwrapSingleArguments = "
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Bool
unwrapSingleArguments)
forall a. Semigroup a => a -> a -> a
<> Text
" }"
instances :: Switches.Settings -> SumType 'PureScript -> [Text]
instances :: Settings -> SumType 'PureScript -> [Text]
instances Settings
settings st :: SumType 'PureScript
st@(SumType PSType
t [DataConstructor 'PureScript]
_ [Instance]
is) = forall a b. (a -> b) -> [a] -> [b]
map Instance -> Text
go [Instance]
is
where
go :: Instance -> Text
go :: Instance -> Text
go Instance
Encode = Text
"instance encode" forall a. Semigroup a => a -> a -> a
<> forall (lang :: Language). TypeInfo lang -> Text
_typeName PSType
t forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
extras forall a. Semigroup a => a -> a -> a
<> Text
"Encode " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
t forall a. Semigroup a => a -> a -> a
<> Text
" where\n" forall a. Semigroup a => a -> a -> a
<>
Text
" encode = genericEncode $ defaultOptions" forall a. Semigroup a => a -> a -> a
<> Text
encodeOpts
where
encodeOpts :: Text
encodeOpts =
Maybe ForeignOptions -> Text
foreignOptionsToPurescript forall a b. (a -> b) -> a -> b
$ Settings -> Maybe ForeignOptions
Switches.generateForeign Settings
settings
stpLength :: Int
stpLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [PSType]
sumTypeParameters
extras :: Text
extras | Int
stpLength forall a. Eq a => a -> a -> Bool
== Int
0 = forall a. Monoid a => a
mempty
| Bool
otherwise = forall {a}. (Semigroup a, IsString a) => a -> a
bracketWrap Text
constraintsInner forall a. Semigroup a => a -> a -> a
<> Text
" => "
sumTypeParameters :: [PSType]
sumTypeParameters = forall a. (a -> Bool) -> [a] -> [a]
filter (PSType -> PSType -> Bool
isTypeParam PSType
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (lang :: Language). SumType lang -> Set (TypeInfo lang)
getUsedTypes SumType 'PureScript
st
constraintsInner :: Text
constraintsInner = Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PSType -> Text
instances [PSType]
sumTypeParameters
instances :: PSType -> Text
instances PSType
params = Settings -> PSType -> Text
genericInstance Settings
settings PSType
params forall a. Semigroup a => a -> a -> a
<> Text
", " forall a. Semigroup a => a -> a -> a
<> PSType -> Text
encodeInstance PSType
params
bracketWrap :: a -> a
bracketWrap a
x = a
"(" forall a. Semigroup a => a -> a -> a
<> a
x forall a. Semigroup a => a -> a -> a
<> a
")"
go Instance
EncodeJson = Text
"instance encodeJson" forall a. Semigroup a => a -> a -> a
<> forall (lang :: Language). TypeInfo lang -> Text
_typeName PSType
t forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
extras forall a. Semigroup a => a -> a -> a
<> Text
"EncodeJson " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
t forall a. Semigroup a => a -> a -> a
<> Text
" where\n" forall a. Semigroup a => a -> a -> a
<>
Text
" encodeJson = genericEncodeAeson Argonaut.defaultOptions"
where
encodeOpts :: Text
encodeOpts =
Maybe ForeignOptions -> Text
foreignOptionsToPurescript forall a b. (a -> b) -> a -> b
$ Settings -> Maybe ForeignOptions
Switches.generateForeign Settings
settings
stpLength :: Int
stpLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [PSType]
sumTypeParameters
extras :: Text
extras | Int
stpLength forall a. Eq a => a -> a -> Bool
== Int
0 = forall a. Monoid a => a
mempty
| Bool
otherwise = forall {a}. (Semigroup a, IsString a) => a -> a
bracketWrap Text
constraintsInner forall a. Semigroup a => a -> a -> a
<> Text
" => "
sumTypeParameters :: [PSType]
sumTypeParameters = forall a. (a -> Bool) -> [a] -> [a]
filter (PSType -> PSType -> Bool
isTypeParam PSType
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (lang :: Language). SumType lang -> Set (TypeInfo lang)
getUsedTypes SumType 'PureScript
st
constraintsInner :: Text
constraintsInner = Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PSType -> Text
instances [PSType]
sumTypeParameters
instances :: PSType -> Text
instances PSType
params = Settings -> PSType -> Text
genericInstance Settings
settings PSType
params forall a. Semigroup a => a -> a -> a
<> Text
", " forall a. Semigroup a => a -> a -> a
<> PSType -> Text
encodeJsonInstance PSType
params
bracketWrap :: a -> a
bracketWrap a
x = a
"(" forall a. Semigroup a => a -> a -> a
<> a
x forall a. Semigroup a => a -> a -> a
<> a
")"
go Instance
Decode = Text
"instance decode" forall a. Semigroup a => a -> a -> a
<> forall (lang :: Language). TypeInfo lang -> Text
_typeName PSType
t forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
extras forall a. Semigroup a => a -> a -> a
<> Text
"Decode " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
t forall a. Semigroup a => a -> a -> a
<> Text
" where\n" forall a. Semigroup a => a -> a -> a
<>
Text
" decode = genericDecode $ defaultOptions" forall a. Semigroup a => a -> a -> a
<> Text
decodeOpts
where
decodeOpts :: Text
decodeOpts =
Maybe ForeignOptions -> Text
foreignOptionsToPurescript forall a b. (a -> b) -> a -> b
$ Settings -> Maybe ForeignOptions
Switches.generateForeign Settings
settings
stpLength :: Int
stpLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [PSType]
sumTypeParameters
extras :: Text
extras | Int
stpLength forall a. Eq a => a -> a -> Bool
== Int
0 = forall a. Monoid a => a
mempty
| Bool
otherwise = forall {a}. (Semigroup a, IsString a) => a -> a
bracketWrap Text
constraintsInner forall a. Semigroup a => a -> a -> a
<> Text
" => "
sumTypeParameters :: [PSType]
sumTypeParameters = forall a. (a -> Bool) -> [a] -> [a]
filter (PSType -> PSType -> Bool
isTypeParam PSType
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (lang :: Language). SumType lang -> Set (TypeInfo lang)
getUsedTypes SumType 'PureScript
st
constraintsInner :: Text
constraintsInner = Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PSType -> Text
instances [PSType]
sumTypeParameters
instances :: PSType -> Text
instances PSType
params = Settings -> PSType -> Text
genericInstance Settings
settings PSType
params forall a. Semigroup a => a -> a -> a
<> Text
", " forall a. Semigroup a => a -> a -> a
<> PSType -> Text
decodeInstance PSType
params
bracketWrap :: a -> a
bracketWrap a
x = a
"(" forall a. Semigroup a => a -> a -> a
<> a
x forall a. Semigroup a => a -> a -> a
<> a
")"
go Instance
DecodeJson = Text
"instance decodeJson" forall a. Semigroup a => a -> a -> a
<> forall (lang :: Language). TypeInfo lang -> Text
_typeName PSType
t forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Text
extras forall a. Semigroup a => a -> a -> a
<> Text
"DecodeJson " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
t forall a. Semigroup a => a -> a -> a
<> Text
" where\n" forall a. Semigroup a => a -> a -> a
<>
Text
" decodeJson = genericDecodeAeson Argonaut.defaultOptions"
where
stpLength :: Int
stpLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [PSType]
sumTypeParameters
extras :: Text
extras | Int
stpLength forall a. Eq a => a -> a -> Bool
== Int
0 = forall a. Monoid a => a
mempty
| Bool
otherwise = forall {a}. (Semigroup a, IsString a) => a -> a
bracketWrap Text
constraintsInner forall a. Semigroup a => a -> a -> a
<> Text
" => "
sumTypeParameters :: [PSType]
sumTypeParameters = forall a. (a -> Bool) -> [a] -> [a]
filter (PSType -> PSType -> Bool
isTypeParam PSType
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (lang :: Language). SumType lang -> Set (TypeInfo lang)
getUsedTypes SumType 'PureScript
st
constraintsInner :: Text
constraintsInner = Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PSType -> Text
instances [PSType]
sumTypeParameters
instances :: PSType -> Text
instances PSType
params = Settings -> PSType -> Text
genericInstance Settings
settings PSType
params forall a. Semigroup a => a -> a -> a
<> Text
", " forall a. Semigroup a => a -> a -> a
<> PSType -> Text
decodeJsonInstance PSType
params forall a. Semigroup a => a -> a -> a
<> Text
", " forall a. Semigroup a => a -> a -> a
<> PSType -> Text
decodeJsonFieldInstance PSType
params
bracketWrap :: a -> a
bracketWrap a
x = a
"(" forall a. Semigroup a => a -> a -> a
<> a
x forall a. Semigroup a => a -> a -> a
<> a
")"
go Instance
i = Text
"derive instance " forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.toLower Text
c forall a. Semigroup a => a -> a -> a
<> forall (lang :: Language). TypeInfo lang -> Text
_typeName PSType
t forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Instance -> Text
extras Instance
i forall a. Semigroup a => a -> a -> a
<> Text
c forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
t forall a. Semigroup a => a -> a -> a
<> forall {a}. IsString a => Instance -> a
postfix Instance
i
where c :: Text
c = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Instance
i
extras :: Instance -> Text
extras Instance
Generic | Int
stpLength forall a. Eq a => a -> a -> Bool
== Int
0 = forall a. Monoid a => a
mempty
| Int
stpLength forall a. Eq a => a -> a -> Bool
== Int
1 = Text
genericConstraintsInner forall a. Semigroup a => a -> a -> a
<> Text
" => "
| Bool
otherwise = forall {a}. (Semigroup a, IsString a) => a -> a
bracketWrap Text
genericConstraintsInner forall a. Semigroup a => a -> a -> a
<> Text
" => "
extras Instance
_ = Text
""
postfix :: Instance -> a
postfix Instance
Newtype = a
" _"
postfix Instance
Generic
| Settings -> Bool
Switches.genericsGenRep Settings
settings = a
" _"
| Bool
otherwise = a
""
postfix Instance
_ = a
""
stpLength :: Int
stpLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [PSType]
sumTypeParameters
sumTypeParameters :: [PSType]
sumTypeParameters = forall a. (a -> Bool) -> [a] -> [a]
filter (PSType -> PSType -> Bool
isTypeParam PSType
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall (lang :: Language). SumType lang -> Set (TypeInfo lang)
getUsedTypes SumType 'PureScript
st
genericConstraintsInner :: Text
genericConstraintsInner = Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Settings -> PSType -> Text
genericInstance Settings
settings) [PSType]
sumTypeParameters
bracketWrap :: a -> a
bracketWrap a
x = a
"(" forall a. Semigroup a => a -> a -> a
<> a
x forall a. Semigroup a => a -> a -> a
<> a
")"
isTypeParam :: PSType -> PSType -> Bool
isTypeParam :: PSType -> PSType -> Bool
isTypeParam PSType
t PSType
typ = forall (lang :: Language). TypeInfo lang -> Text
_typeName PSType
typ forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall (lang :: Language). TypeInfo lang -> Text
_typeName (forall (lang :: Language). TypeInfo lang -> [TypeInfo lang]
_typeParameters PSType
t)
encodeInstance :: PSType -> Text
encodeInstance :: PSType -> Text
encodeInstance PSType
params = Text
"Encode " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
params
encodeJsonInstance :: PSType -> Text
encodeJsonInstance :: PSType -> Text
encodeJsonInstance PSType
params = Text
"EncodeJson " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
params
decodeInstance :: PSType -> Text
decodeInstance :: PSType -> Text
decodeInstance PSType
params = Text
"Decode " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
params
decodeJsonInstance :: PSType -> Text
decodeJsonInstance :: PSType -> Text
decodeJsonInstance PSType
params = Text
"DecodeJson " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
params
decodeJsonFieldInstance :: PSType -> Text
decodeJsonFieldInstance :: PSType -> Text
decodeJsonFieldInstance PSType
params = Text
"DecodeJsonField " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
params
genericInstance :: Switches.Settings -> PSType -> Text
genericInstance :: Settings -> PSType -> Text
genericInstance Settings
settings PSType
params =
if Bool -> Bool
not (Settings -> Bool
Switches.genericsGenRep Settings
settings) then
Text
"Generic " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
params
else
Text
"Generic " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
False PSType
params forall a. Semigroup a => a -> a -> a
<> Text
" r" forall a. Semigroup a => a -> a -> a
<> PSType -> Text
mergedTypeInfoToText PSType
params
sumTypeToOptics :: SumType 'PureScript -> Text
sumTypeToOptics :: SumType 'PureScript -> Text
sumTypeToOptics SumType 'PureScript
st = SumType 'PureScript -> Text
constructorOptics SumType 'PureScript
st forall a. Semigroup a => a -> a -> a
<> SumType 'PureScript -> Text
recordOptics SumType 'PureScript
st
constructorOptics :: SumType 'PureScript -> Text
constructorOptics :: SumType 'PureScript -> Text
constructorOptics SumType 'PureScript
st =
case SumType 'PureScript
st forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *) (lang :: Language).
Functor f =>
([DataConstructor lang] -> f [DataConstructor lang])
-> SumType lang -> f (SumType lang)
sumTypeConstructors of
[] -> forall a. Monoid a => a
mempty
[DataConstructor 'PureScript
c] -> Bool -> PSType -> DataConstructor 'PureScript -> Text
constructorToOptic Bool
False PSType
typeInfo DataConstructor 'PureScript
c
[DataConstructor 'PureScript]
cs -> [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Bool -> PSType -> DataConstructor 'PureScript -> Text
constructorToOptic Bool
True PSType
typeInfo) [DataConstructor 'PureScript]
cs
where
typeInfo :: PSType
typeInfo = SumType 'PureScript
st forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *) (lang :: Language).
Functor f =>
(TypeInfo lang -> f (TypeInfo lang))
-> SumType lang -> f (SumType lang)
sumTypeInfo
recordOptics :: SumType 'PureScript -> Text
recordOptics :: SumType 'PureScript -> Text
recordOptics st :: SumType 'PureScript
st@(SumType PSType
_ [DataConstructor 'PureScript
_] [Instance]
_) = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ SumType 'PureScript -> RecordEntry 'PureScript -> Text
recordEntryToLens SumType 'PureScript
st forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RecordEntry 'PureScript]
dcRecords
where
cs :: [DataConstructor 'PureScript]
cs = SumType 'PureScript
st forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *) (lang :: Language).
Functor f =>
([DataConstructor lang] -> f [DataConstructor lang])
-> SumType lang -> f (SumType lang)
sumTypeConstructors
dcRecords :: [RecordEntry 'PureScript]
dcRecords = Maybe (DataConstructor 'PureScript)
lensableConstructor forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversedforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (lang1 :: Language) (lang2 :: Language).
Lens
(DataConstructor lang1)
(DataConstructor lang2)
(Either [TypeInfo lang1] [RecordEntry lang1])
(Either [TypeInfo lang2] [RecordEntry lang2])
sigValuesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall c a b. Prism (Either c a) (Either c b) a b
_Rightforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverseforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) a.
(Choice p, Applicative f) =>
(a -> Bool) -> Optic' p f a a
filtered forall {lang :: Language}. RecordEntry lang -> Bool
hasUnderscore
hasUnderscore :: RecordEntry lang -> Bool
hasUnderscore RecordEntry lang
e = RecordEntry lang
e forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (RecordEntry lang) Text
recLabelforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Text -> Text -> Bool
T.isPrefixOf Text
"_")
lensableConstructor :: Maybe (DataConstructor 'PureScript)
lensableConstructor = forall a. (a -> Bool) -> [a] -> [a]
filter forall {lang :: Language}. DataConstructor lang -> Bool
singleRecordCons [DataConstructor 'PureScript]
cs forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. Cons s s a a => Traversal' s a
_head
singleRecordCons :: DataConstructor lang -> Bool
singleRecordCons (DataConstructor Text
_ (Right [RecordEntry lang]
_)) = Bool
True
singleRecordCons DataConstructor lang
_ = Bool
False
recordOptics SumType 'PureScript
_ = Text
""
constructorToText :: Int -> DataConstructor 'PureScript -> Text
constructorToText :: Int -> DataConstructor 'PureScript -> Text
constructorToText Int
_ (DataConstructor Text
n (Left [])) = Text
n
constructorToText Int
_ (DataConstructor Text
n (Left [PSType]
ts)) = Text
n forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " (forall a b. (a -> b) -> [a] -> [b]
map (Bool -> PSType -> Text
typeInfoToText Bool
False) [PSType]
ts)
constructorToText Int
indentation (DataConstructor Text
n (Right [RecordEntry 'PureScript]
rs)) =
Text
n forall a. Semigroup a => a -> a -> a
<> Text
" {\n"
forall a. Semigroup a => a -> a -> a
<> Int -> Text
spaces (Int
indentation forall a. Num a => a -> a -> a
+ Int
2) forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
intercalation (forall a b. (a -> b) -> [a] -> [b]
map RecordEntry 'PureScript -> Text
recordEntryToText [RecordEntry 'PureScript]
rs) forall a. Semigroup a => a -> a -> a
<> Text
"\n"
forall a. Semigroup a => a -> a -> a
<> Int -> Text
spaces Int
indentation forall a. Semigroup a => a -> a -> a
<> Text
"}"
where
intercalation :: Text
intercalation = Text
"\n" forall a. Semigroup a => a -> a -> a
<> Int -> Text
spaces Int
indentation forall a. Semigroup a => a -> a -> a
<> Text
"," forall a. Semigroup a => a -> a -> a
<> Text
" "
spaces :: Int -> Text
spaces :: Int -> Text
spaces Int
c = Int -> Text -> Text
T.replicate Int
c Text
" "
typeNameAndForall :: TypeInfo 'PureScript -> (Text, Text)
typeNameAndForall :: PSType -> (Text, Text)
typeNameAndForall PSType
typeInfo = (Text
typName, Text
forAll)
where
typName :: Text
typName = Bool -> PSType -> Text
typeInfoToText Bool
False PSType
typeInfo
forAllParams :: [Text]
forAllParams = PSType
typeInfo forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (lang1 :: Language) (lang2 :: Language).
Lens
(TypeInfo lang1) (TypeInfo lang2) [TypeInfo lang1] [TypeInfo lang2]
typeParametersforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversedforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Bool -> PSType -> Text
typeInfoToText Bool
False)
forAll :: Text
forAll = case [Text]
forAllParams of
[] -> Text
" :: "
[Text]
cs -> Text
" :: forall " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " [Text]
cs forall a. Semigroup a => a -> a -> a
<> Text
". "
fromEntries :: (RecordEntry a -> Text) -> [RecordEntry a] -> Text
fromEntries :: forall (a :: Language).
(RecordEntry a -> Text) -> [RecordEntry a] -> Text
fromEntries RecordEntry a -> Text
mkElem [RecordEntry a]
rs = Text
"{ " forall a. Semigroup a => a -> a -> a
<> Text
inners forall a. Semigroup a => a -> a -> a
<> Text
" }"
where
inners :: Text
inners = Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map RecordEntry a -> Text
mkElem [RecordEntry a]
rs
mkFnArgs :: [RecordEntry 'PureScript] -> Text
mkFnArgs :: [RecordEntry 'PureScript] -> Text
mkFnArgs [RecordEntry 'PureScript
r] = RecordEntry 'PureScript
r forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (RecordEntry lang) Text
recLabel
mkFnArgs [RecordEntry 'PureScript]
rs = forall (a :: Language).
(RecordEntry a -> Text) -> [RecordEntry a] -> Text
fromEntries (\RecordEntry 'PureScript
recE -> RecordEntry 'PureScript
recE forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (RecordEntry lang) Text
recLabel forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> RecordEntry 'PureScript
recE forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (RecordEntry lang) Text
recLabel) [RecordEntry 'PureScript]
rs
mkTypeSig :: [RecordEntry 'PureScript] -> Text
mkTypeSig :: [RecordEntry 'PureScript] -> Text
mkTypeSig [] = Text
"Unit"
mkTypeSig [RecordEntry 'PureScript
r] = Bool -> PSType -> Text
typeInfoToText Bool
False forall a b. (a -> b) -> a -> b
$ RecordEntry 'PureScript
r forall s a. s -> Getting a s a -> a
^. forall (lang1 :: Language) (lang2 :: Language).
Lens
(RecordEntry lang1)
(RecordEntry lang2)
(TypeInfo lang1)
(TypeInfo lang2)
recValue
mkTypeSig [RecordEntry 'PureScript]
rs = forall (a :: Language).
(RecordEntry a -> Text) -> [RecordEntry a] -> Text
fromEntries RecordEntry 'PureScript -> Text
recordEntryToText [RecordEntry 'PureScript]
rs
constructorToOptic :: Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Text
constructorToOptic :: Bool -> PSType -> DataConstructor 'PureScript -> Text
constructorToOptic Bool
otherConstructors PSType
typeInfo (DataConstructor Text
n Either [PSType] [RecordEntry 'PureScript]
args) =
case (Either [PSType] [RecordEntry 'PureScript]
args,Bool
otherConstructors) of
(Left [PSType
c], Bool
False) ->
Text
pName forall a. Semigroup a => a -> a -> a
<> Text
forAll forall a. Semigroup a => a -> a -> a
<> Text
"Iso' " forall a. Semigroup a => a -> a -> a
<> Text
typName forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> [RecordEntry 'PureScript] -> Text
mkTypeSig (forall {lang :: Language}. [TypeInfo lang] -> [RecordEntry lang]
constructorTypes [PSType
c]) forall a. Semigroup a => a -> a -> a
<> Text
"\n"
forall a. Semigroup a => a -> a -> a
<> Text
pName forall a. Semigroup a => a -> a -> a
<> Text
" = _Newtype"
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
(Left [PSType]
cs, Bool
_) ->
Text
pName forall a. Semigroup a => a -> a -> a
<> Text
forAll forall a. Semigroup a => a -> a -> a
<> Text
"Prism' " forall a. Semigroup a => a -> a -> a
<> Text
typName forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> [RecordEntry 'PureScript] -> Text
mkTypeSig [RecordEntry 'PureScript]
types forall a. Semigroup a => a -> a -> a
<> Text
"\n"
forall a. Semigroup a => a -> a -> a
<> Text
pName forall a. Semigroup a => a -> a -> a
<> Text
" = prism' " forall a. Semigroup a => a -> a -> a
<> Text
getter forall a. Semigroup a => a -> a -> a
<> Text
" f\n"
forall a. Semigroup a => a -> a -> a
<> Int -> Text
spaces Int
2 forall a. Semigroup a => a -> a -> a
<> Text
"where\n"
forall a. Semigroup a => a -> a -> a
<> Int -> Text
spaces Int
4 forall a. Semigroup a => a -> a -> a
<> Text
"f " forall a. Semigroup a => a -> a -> a
<> forall {a}. [a] -> Text
mkF [PSType]
cs
forall a. Semigroup a => a -> a -> a
<> Text
otherConstructorFallThrough
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
where
mkF :: [a] -> Text
mkF [] = Text
n forall a. Semigroup a => a -> a -> a
<> Text
" = Just unit\n"
mkF [a]
_ = Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (forall a b. (a -> b) -> [a] -> [b]
map forall (lang :: Language). RecordEntry lang -> Text
_recLabel [RecordEntry 'PureScript]
types) forall a. Semigroup a => a -> a -> a
<> Text
") = Just $ " forall a. Semigroup a => a -> a -> a
<> [RecordEntry 'PureScript] -> Text
mkFnArgs [RecordEntry 'PureScript]
types forall a. Semigroup a => a -> a -> a
<> Text
"\n"
getter :: Text
getter | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PSType]
cs = Text
"(\\_ -> " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
")"
| forall (t :: * -> *) a. Foldable t => t a -> Int
length [PSType]
cs forall a. Eq a => a -> a -> Bool
== Int
1 = Text
n
| Bool
otherwise = Text
"(\\{ " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
cArgs forall a. Semigroup a => a -> a -> a
<> Text
" } -> " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " [Text]
cArgs forall a. Semigroup a => a -> a -> a
<> Text
")"
where
cArgs :: [Text]
cArgs = forall a b. (a -> b) -> [a] -> [b]
map (Char -> Text
T.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Char
'a'..] [PSType]
cs
types :: [RecordEntry 'PureScript]
types = forall {lang :: Language}. [TypeInfo lang] -> [RecordEntry lang]
constructorTypes [PSType]
cs
(Right [RecordEntry 'PureScript]
rs, Bool
False) ->
Text
pName forall a. Semigroup a => a -> a -> a
<> Text
forAll forall a. Semigroup a => a -> a -> a
<> Text
"Iso' " forall a. Semigroup a => a -> a -> a
<> Text
typName forall a. Semigroup a => a -> a -> a
<> Text
" { " forall a. Semigroup a => a -> a -> a
<> [RecordEntry 'PureScript] -> Text
recordSig [RecordEntry 'PureScript]
rs forall a. Semigroup a => a -> a -> a
<> Text
"}\n"
forall a. Semigroup a => a -> a -> a
<> Text
pName forall a. Semigroup a => a -> a -> a
<> Text
" = _Newtype\n"
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
(Right [RecordEntry 'PureScript]
rs, Bool
True) ->
Text
pName forall a. Semigroup a => a -> a -> a
<> Text
forAll forall a. Semigroup a => a -> a -> a
<> Text
"Prism' " forall a. Semigroup a => a -> a -> a
<> Text
typName forall a. Semigroup a => a -> a -> a
<> Text
" { " forall a. Semigroup a => a -> a -> a
<> [RecordEntry 'PureScript] -> Text
recordSig [RecordEntry 'PureScript]
rs forall a. Semigroup a => a -> a -> a
<> Text
" }\n"
forall a. Semigroup a => a -> a -> a
<> Text
pName forall a. Semigroup a => a -> a -> a
<> Text
" = prism' " forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
" f\n"
forall a. Semigroup a => a -> a -> a
<> Int -> Text
spaces Int
2 forall a. Semigroup a => a -> a -> a
<> Text
"where\n"
forall a. Semigroup a => a -> a -> a
<> Int -> Text
spaces Int
4 forall a. Semigroup a => a -> a -> a
<> Text
"f (" forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<> Text
" r) = Just r\n"
forall a. Semigroup a => a -> a -> a
<> Text
otherConstructorFallThrough
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
where
recordSig :: [RecordEntry 'PureScript] -> Text
recordSig [RecordEntry 'PureScript]
rs = Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map RecordEntry 'PureScript -> Text
recordEntryToText [RecordEntry 'PureScript]
rs)
constructorTypes :: [TypeInfo lang] -> [RecordEntry lang]
constructorTypes [TypeInfo lang]
cs = [forall (lang :: Language).
Text -> TypeInfo lang -> RecordEntry lang
RecordEntry (Char -> Text
T.singleton Char
label) TypeInfo lang
t | (Char
label, TypeInfo lang
t) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Char
'a'..] [TypeInfo lang]
cs]
(Text
typName, Text
forAll) = PSType -> (Text, Text)
typeNameAndForall PSType
typeInfo
pName :: Text
pName = Text
"_" forall a. Semigroup a => a -> a -> a
<> Text
n
otherConstructorFallThrough :: Text
otherConstructorFallThrough | Bool
otherConstructors = Int -> Text
spaces Int
4 forall a. Semigroup a => a -> a -> a
<> Text
"f _ = Nothing"
| Bool
otherwise = Text
""
recordEntryToLens :: SumType 'PureScript -> RecordEntry 'PureScript -> Text
recordEntryToLens :: SumType 'PureScript -> RecordEntry 'PureScript -> Text
recordEntryToLens SumType 'PureScript
st RecordEntry 'PureScript
e =
if Bool
hasUnderscore
then Text
lensName forall a. Semigroup a => a -> a -> a
<> Text
forAll forall a. Semigroup a => a -> a -> a
<> Text
"Lens' " forall a. Semigroup a => a -> a -> a
<> Text
typName forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text
recType forall a. Semigroup a => a -> a -> a
<> Text
"\n"
forall a. Semigroup a => a -> a -> a
<> Text
lensName forall a. Semigroup a => a -> a -> a
<> Text
" = _Newtype <<< prop (Proxy :: Proxy \"" forall a. Semigroup a => a -> a -> a
<> Text
recName forall a. Semigroup a => a -> a -> a
<> Text
"\")\n"
else Text
""
where
(Text
typName, Text
forAll) = PSType -> (Text, Text)
typeNameAndForall (SumType 'PureScript
st forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *) (lang :: Language).
Functor f =>
(TypeInfo lang -> f (TypeInfo lang))
-> SumType lang -> f (SumType lang)
sumTypeInfo)
recName :: Text
recName = RecordEntry 'PureScript
e forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (RecordEntry lang) Text
recLabel
lensName :: Text
lensName = Int -> Text -> Text
T.drop Int
1 Text
recName
recType :: Text
recType = Bool -> PSType -> Text
typeInfoToText Bool
False (RecordEntry 'PureScript
e forall s a. s -> Getting a s a -> a
^. forall (lang1 :: Language) (lang2 :: Language).
Lens
(RecordEntry lang1)
(RecordEntry lang2)
(TypeInfo lang1)
(TypeInfo lang2)
recValue)
hasUnderscore :: Bool
hasUnderscore = RecordEntry 'PureScript
e forall s a. s -> Getting a s a -> a
^. forall (lang :: Language). Lens' (RecordEntry lang) Text
recLabelforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Text -> Text -> Bool
T.isPrefixOf Text
"_")
recordEntryToText :: RecordEntry 'PureScript -> Text
recordEntryToText :: RecordEntry 'PureScript -> Text
recordEntryToText RecordEntry 'PureScript
e = forall (lang :: Language). RecordEntry lang -> Text
_recLabel RecordEntry 'PureScript
e forall a. Semigroup a => a -> a -> a
<> Text
" :: " forall a. Semigroup a => a -> a -> a
<> Bool -> PSType -> Text
typeInfoToText Bool
True (RecordEntry 'PureScript
e forall s a. s -> Getting a s a -> a
^. forall (lang1 :: Language) (lang2 :: Language).
Lens
(RecordEntry lang1)
(RecordEntry lang2)
(TypeInfo lang1)
(TypeInfo lang2)
recValue)
typeInfoToText :: Bool -> PSType -> Text
typeInfoToText :: Bool -> PSType -> Text
typeInfoToText Bool
topLevel PSType
t = if Bool
needParens then Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
inner forall a. Semigroup a => a -> a -> a
<> Text
")" else Text
inner
where
inner :: Text
inner = forall (lang :: Language). TypeInfo lang -> Text
_typeName PSType
t forall a. Semigroup a => a -> a -> a
<>
if Int
pLength forall a. Ord a => a -> a -> Bool
> Int
0
then Text
" " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
" " [Text]
textParameters
else Text
""
params :: [PSType]
params = forall (lang :: Language). TypeInfo lang -> [TypeInfo lang]
_typeParameters PSType
t
pLength :: Int
pLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [PSType]
params
needParens :: Bool
needParens = Bool -> Bool
not Bool
topLevel Bool -> Bool -> Bool
&& Int
pLength forall a. Ord a => a -> a -> Bool
> Int
0
textParameters :: [Text]
textParameters = forall a b. (a -> b) -> [a] -> [b]
map (Bool -> PSType -> Text
typeInfoToText Bool
False) [PSType]
params
mergedTypeInfoToText :: PSType -> Text
mergedTypeInfoToText :: PSType -> Text
mergedTypeInfoToText PSType
t =
forall (lang :: Language). TypeInfo lang -> Text
_typeName PSType
t forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat [Text]
textParameters
where
params :: [PSType]
params = forall (lang :: Language). TypeInfo lang -> [TypeInfo lang]
_typeParameters PSType
t
textParameters :: [Text]
textParameters = forall a b. (a -> b) -> [a] -> [b]
map PSType -> Text
mergedTypeInfoToText [PSType]
params
sumTypesToModules :: Modules -> [SumType 'PureScript] -> Modules
sumTypesToModules :: Modules -> [SumType 'PureScript] -> Modules
sumTypesToModules = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SumType 'PureScript -> Modules -> Modules
sumTypeToModule
sumTypeToModule :: SumType 'PureScript -> Modules -> Modules
sumTypeToModule :: SumType 'PureScript -> Modules -> Modules
sumTypeToModule st :: SumType 'PureScript
st@(SumType PSType
t [DataConstructor 'PureScript]
_ [Instance]
_) = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe PSModule -> PSModule
updateModule) (forall (lang :: Language). TypeInfo lang -> Text
_typeModule PSType
t)
where
updateModule :: Maybe PSModule -> PSModule
updateModule Maybe PSModule
Nothing = PSModule {
psModuleName :: Text
psModuleName = forall (lang :: Language). TypeInfo lang -> Text
_typeModule PSType
t
, psImportLines :: Map Text ImportLine
psImportLines = forall {a}. Map Text a -> Map Text a
dropSelf forall a b. (a -> b) -> a -> b
$ Map Text ImportLine -> Set PSType -> Map Text ImportLine
typesToImportLines forall k a. Map k a
Map.empty (forall (lang :: Language). SumType lang -> Set (TypeInfo lang)
getUsedTypes SumType 'PureScript
st)
, psTypes :: [SumType 'PureScript]
psTypes = [SumType 'PureScript
st]
}
updateModule (Just PSModule
m) = PSModule
m {
psImportLines :: Map Text ImportLine
psImportLines = forall {a}. Map Text a -> Map Text a
dropSelf forall a b. (a -> b) -> a -> b
$ Map Text ImportLine -> Set PSType -> Map Text ImportLine
typesToImportLines (forall (lang :: Language). Module lang -> Map Text ImportLine
psImportLines PSModule
m) (forall (lang :: Language). SumType lang -> Set (TypeInfo lang)
getUsedTypes SumType 'PureScript
st)
, psTypes :: [SumType 'PureScript]
psTypes = SumType 'PureScript
st forall a. a -> [a] -> [a]
: forall (lang :: Language). Module lang -> [SumType lang]
psTypes PSModule
m
}
dropSelf :: Map Text a -> Map Text a
dropSelf = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (forall (lang :: Language). TypeInfo lang -> Text
_typeModule PSType
t)
typesToImportLines :: ImportLines -> Set PSType -> ImportLines
typesToImportLines :: Map Text ImportLine -> Set PSType -> Map Text ImportLine
typesToImportLines = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PSType -> Map Text ImportLine -> Map Text ImportLine
typeToImportLines
typeToImportLines :: PSType -> ImportLines -> ImportLines
typeToImportLines :: PSType -> Map Text ImportLine -> Map Text ImportLine
typeToImportLines PSType
t Map Text ImportLine
ls = Map Text ImportLine -> Set PSType -> Map Text ImportLine
typesToImportLines (Map Text ImportLine -> Map Text ImportLine
update Map Text ImportLine
ls) (forall a. Ord a => [a] -> Set a
Set.fromList (forall (lang :: Language). TypeInfo lang -> [TypeInfo lang]
_typeParameters PSType
t))
where
update :: Map Text ImportLine -> Map Text ImportLine
update = if Bool -> Bool
not (Text -> Bool
T.null (forall (lang :: Language). TypeInfo lang -> Text
_typeModule PSType
t))
then forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ImportLine -> ImportLine
updateLine) (forall (lang :: Language). TypeInfo lang -> Text
_typeModule PSType
t)
else forall a. a -> a
id
updateLine :: Maybe ImportLine -> ImportLine
updateLine Maybe ImportLine
Nothing = Text -> Maybe Text -> Set Text -> ImportLine
ImportLine (forall (lang :: Language). TypeInfo lang -> Text
_typeModule PSType
t) forall a. Maybe a
Nothing (forall a. a -> Set a
Set.singleton (forall (lang :: Language). TypeInfo lang -> Text
_typeName PSType
t))
updateLine (Just (ImportLine Text
m Maybe Text
alias Set Text
types)) =
Text -> Maybe Text -> Set Text -> ImportLine
ImportLine Text
m Maybe Text
alias (forall a. Ord a => a -> Set a -> Set a
Set.insert (forall (lang :: Language). TypeInfo lang -> Text
_typeName PSType
t) Set Text
types)
importsFromList :: [ImportLine] -> Map Text ImportLine
importsFromList :: [ImportLine] -> Map Text ImportLine
importsFromList [ImportLine]
ls = let
pairs :: [(Text, ImportLine)]
pairs = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map ImportLine -> Text
importModule [ImportLine]
ls) [ImportLine]
ls
merge :: ImportLine -> ImportLine -> ImportLine
merge ImportLine
a ImportLine
b = Text -> Maybe Text -> Set Text -> ImportLine
ImportLine (ImportLine -> Text
importModule ImportLine
a) (ImportLine -> Maybe Text
importAlias ImportLine
a) (ImportLine -> Set Text
importTypes ImportLine
a forall a. Ord a => Set a -> Set a -> Set a
`Set.union` ImportLine -> Set Text
importTypes ImportLine
b)
in
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith ImportLine -> ImportLine -> ImportLine
merge [(Text, ImportLine)]
pairs
mergeImportLines :: ImportLines -> ImportLines -> ImportLines
mergeImportLines :: Map Text ImportLine -> Map Text ImportLine -> Map Text ImportLine
mergeImportLines = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ImportLine -> ImportLine -> ImportLine
mergeLines
where
mergeLines :: ImportLine -> ImportLine -> ImportLine
mergeLines ImportLine
a ImportLine
b = Text -> Maybe Text -> Set Text -> ImportLine
ImportLine (ImportLine -> Text
importModule ImportLine
a) (ImportLine -> Maybe Text
importAlias ImportLine
a) (ImportLine -> Set Text
importTypes ImportLine
a forall a. Ord a => Set a -> Set a -> Set a
`Set.union` ImportLine -> Set Text
importTypes ImportLine
b)
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM m Bool
mbool m ()
action = m Bool
mbool forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless m ()
action