{-# 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
" }"



-- | Given a Purescript type, generate instances for typeclass
-- instances it claims to have.
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 -- No work required.
    [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
-- Match on SumTypes with a single DataConstructor (that's a list of a single element)
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