{-# 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 { psModuleName :: !Text , psImportLines :: !(Map Text ImportLine) , psTypes :: ![SumType lang] } deriving Show type PSModule = Module 'PureScript data ImportLine = ImportLine { importModule :: !Text , importAlias :: !(Maybe Text) , importTypes :: !(Set Text) } deriving Show type Modules = Map Text PSModule type ImportLines = Map Text ImportLine printModule :: Switches.Settings -> FilePath -> PSModule -> IO () printModule settings root m = do unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir T.writeFile mPath . moduleToText settings $ m where mFile = (joinPath . map T.unpack . T.splitOn "." $ psModuleName m) <> ".purs" mPath = root mFile mDir = takeDirectory mPath sumTypesToNeededPackages :: [SumType lang] -> Set Text sumTypesToNeededPackages = Set.unions . map sumTypeToNeededPackages sumTypeToNeededPackages :: SumType lang -> Set Text sumTypeToNeededPackages st = Set.filter (not . T.null) . Set.map _typePackage $ getUsedTypes st moduleToText :: Switches.Settings -> Module 'PureScript -> Text moduleToText settings m = T.unlines $ "-- File auto generated by purescript-bridge! --" : "module " <> psModuleName m <> " where\n" : map importLineToText allImports <> [ "" , "import Prelude" , "" ] <> map (sumTypeToText settings) (psTypes m) where otherImports = importsFromList $ _lensImports settings <> _genericsImports settings <> _argonautCodecsImports settings <> _foreignImports settings allImports = Map.elems $ mergeImportLines otherImports (psImportLines m) _genericsImports :: Switches.Settings -> [ImportLine] _genericsImports settings | Switches.genericsGenRep settings = [ ImportLine "Data.Generic.Rep" Nothing $ Set.fromList ["class Generic"] ] | otherwise = [ ImportLine "Data.Generic" Nothing $ Set.fromList ["class Generic"] ] _lensImports :: Switches.Settings -> [ImportLine] _lensImports settings | Switches.generateLenses settings = [ ImportLine "Data.Lens" Nothing $ Set.fromList ["Iso'", "Prism'", "Lens'", "prism'", "lens"] , ImportLine "Data.Lens.Iso.Newtype" Nothing $ Set.fromList ["_Newtype"] , ImportLine "Data.Lens.Record" Nothing $ Set.fromList ["prop"] ] <> baseline <> [ ImportLine "Type.Proxy" Nothing $ Set.fromList ["Proxy(Proxy)"] ] | otherwise = baseline where baseline = [ ImportLine "Data.Maybe" Nothing $ Set.fromList ["Maybe(..)"] , ImportLine "Data.Newtype" Nothing $ Set.fromList ["class Newtype"] ] _argonautCodecsImports :: Switches.Settings -> [ImportLine] _argonautCodecsImports settings | Switches.generateArgonautCodecs settings = [ ImportLine "Data.Argonaut.Aeson.Decode.Generic" Nothing $ Set.fromList [ "genericDecodeAeson" ] , ImportLine "Data.Argonaut.Aeson.Encode.Generic" Nothing $ Set.fromList [ "genericEncodeAeson" ] , ImportLine "Data.Argonaut.Aeson.Options" (Just "Argonaut") $ Set.fromList [ "defaultOptions" ] , ImportLine "Data.Argonaut.Decode.Class" Nothing $ Set.fromList [ "class DecodeJson", "class DecodeJsonField", "decodeJson" ] , ImportLine "Data.Argonaut.Encode.Class" Nothing $ Set.fromList [ "class EncodeJson", "encodeJson" ] ] | otherwise = mempty _foreignImports :: Switches.Settings -> [ImportLine] _foreignImports settings | (isJust . Switches.generateForeign) settings = [ ImportLine "Foreign.Class" Nothing $ Set.fromList ["class Decode", "class Encode"] , ImportLine "Foreign.Generic" Nothing $ Set.fromList ["defaultOptions", "genericDecode", "genericEncode"] ] | otherwise = mempty importLineToText :: ImportLine -> Text importLineToText = \case ImportLine importModule Nothing importTypes -> "import " <> importModule <> " (" <> typeList importTypes <> ")" ImportLine importModule (Just importAlias) _ -> "import " <> importModule <> " as " <> importAlias where typeList s = T.intercalate ", " (Set.toList s) sumTypeToText :: Switches.Settings -> SumType 'PureScript -> Text sumTypeToText settings st = sumTypeToTypeDecls settings st <> additionalCode where additionalCode = if Switches.generateLenses settings then lenses else mempty lenses = "\n" <> sep <> "\n" <> sumTypeToOptics st <> sep sep = T.replicate 80 "-" sumTypeToTypeDecls :: Switches.Settings -> SumType 'PureScript -> Text sumTypeToTypeDecls settings (SumType t cs is) = T.unlines $ dataOrNewtype <> " " <> typeInfoToText True t <> " =" : " " <> T.intercalate "\n | " (map (constructorToText 4) cs) <> "\n" : instances settings (SumType t cs (filter genForeign . filter genArgonautCodec $ is)) where dataOrNewtype = if isJust (nootype cs) then "newtype" else "data" genForeign :: Instance -> Bool genForeign = \case Encode -> check Decode -> check _ -> True where check = (isJust . Switches.generateForeign) settings genArgonautCodec :: Instance -> Bool genArgonautCodec = \case EncodeJson -> check DecodeJson -> check _ -> True where check = Switches.generateArgonautCodecs settings foreignOptionsToPurescript :: Maybe Switches.ForeignOptions -> Text foreignOptionsToPurescript = \case Nothing -> mempty Just (Switches.ForeignOptions{..}) -> " { unwrapSingleConstructors = " <> (T.toLower . T.pack . show $ unwrapSingleConstructors) <> " , unwrapSingleArguments = " <> (T.toLower . T.pack . show $ unwrapSingleArguments) <> " }" -- | Given a Purescript type, generate instances for typeclass -- instances it claims to have. instances :: Switches.Settings -> SumType 'PureScript -> [Text] instances settings st@(SumType t _ is) = map go is where go :: Instance -> Text go Encode = "instance encode" <> _typeName t <> " :: " <> extras <> "Encode " <> typeInfoToText False t <> " where\n" <> " encode = genericEncode $ defaultOptions" <> encodeOpts where encodeOpts = foreignOptionsToPurescript $ Switches.generateForeign settings stpLength = length sumTypeParameters extras | stpLength == 0 = mempty | otherwise = bracketWrap constraintsInner <> " => " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st constraintsInner = T.intercalate ", " $ map instances sumTypeParameters instances params = genericInstance settings params <> ", " <> encodeInstance params bracketWrap x = "(" <> x <> ")" go EncodeJson = "instance encodeJson" <> _typeName t <> " :: " <> extras <> "EncodeJson " <> typeInfoToText False t <> " where\n" <> " encodeJson = genericEncodeAeson Argonaut.defaultOptions" where encodeOpts = foreignOptionsToPurescript $ Switches.generateForeign settings stpLength = length sumTypeParameters extras | stpLength == 0 = mempty | otherwise = bracketWrap constraintsInner <> " => " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st constraintsInner = T.intercalate ", " $ map instances sumTypeParameters instances params = genericInstance settings params <> ", " <> encodeJsonInstance params bracketWrap x = "(" <> x <> ")" go Decode = "instance decode" <> _typeName t <> " :: " <> extras <> "Decode " <> typeInfoToText False t <> " where\n" <> " decode = genericDecode $ defaultOptions" <> decodeOpts where decodeOpts = foreignOptionsToPurescript $ Switches.generateForeign settings stpLength = length sumTypeParameters extras | stpLength == 0 = mempty | otherwise = bracketWrap constraintsInner <> " => " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st constraintsInner = T.intercalate ", " $ map instances sumTypeParameters instances params = genericInstance settings params <> ", " <> decodeInstance params bracketWrap x = "(" <> x <> ")" go DecodeJson = "instance decodeJson" <> _typeName t <> " :: " <> extras <> "DecodeJson " <> typeInfoToText False t <> " where\n" <> " decodeJson = genericDecodeAeson Argonaut.defaultOptions" where stpLength = length sumTypeParameters extras | stpLength == 0 = mempty | otherwise = bracketWrap constraintsInner <> " => " sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st constraintsInner = T.intercalate ", " $ map instances sumTypeParameters instances params = genericInstance settings params <> ", " <> decodeJsonInstance params <> ", " <> decodeJsonFieldInstance params bracketWrap x = "(" <> x <> ")" go i = "derive instance " <> T.toLower c <> _typeName t <> " :: " <> extras i <> c <> " " <> typeInfoToText False t <> postfix i where c = T.pack $ show i extras Generic | stpLength == 0 = mempty | stpLength == 1 = genericConstraintsInner <> " => " | otherwise = bracketWrap genericConstraintsInner <> " => " extras _ = "" postfix Newtype = " _" postfix Generic | Switches.genericsGenRep settings = " _" | otherwise = "" postfix _ = "" stpLength = length sumTypeParameters sumTypeParameters = filter (isTypeParam t) . Set.toList $ getUsedTypes st genericConstraintsInner = T.intercalate ", " $ map (genericInstance settings) sumTypeParameters bracketWrap x = "(" <> x <> ")" isTypeParam :: PSType -> PSType -> Bool isTypeParam t typ = _typeName typ `elem` map _typeName (_typeParameters t) encodeInstance :: PSType -> Text encodeInstance params = "Encode " <> typeInfoToText False params encodeJsonInstance :: PSType -> Text encodeJsonInstance params = "EncodeJson " <> typeInfoToText False params decodeInstance :: PSType -> Text decodeInstance params = "Decode " <> typeInfoToText False params decodeJsonInstance :: PSType -> Text decodeJsonInstance params = "DecodeJson " <> typeInfoToText False params decodeJsonFieldInstance :: PSType -> Text decodeJsonFieldInstance params = "DecodeJsonField " <> typeInfoToText False params genericInstance :: Switches.Settings -> PSType -> Text genericInstance settings params = if not (Switches.genericsGenRep settings) then "Generic " <> typeInfoToText False params else "Generic " <> typeInfoToText False params <> " r" <> mergedTypeInfoToText params sumTypeToOptics :: SumType 'PureScript -> Text sumTypeToOptics st = constructorOptics st <> recordOptics st constructorOptics :: SumType 'PureScript -> Text constructorOptics st = case st ^. sumTypeConstructors of [] -> mempty -- No work required. [c] -> constructorToOptic False typeInfo c cs -> T.unlines $ map (constructorToOptic True typeInfo) cs where typeInfo = st ^. sumTypeInfo recordOptics :: SumType 'PureScript -> Text -- Match on SumTypes with a single DataConstructor (that's a list of a single element) recordOptics st@(SumType _ [_] _) = T.unlines $ recordEntryToLens st <$> dcRecords where cs = st ^. sumTypeConstructors dcRecords = lensableConstructor ^.. traversed.sigValues._Right.traverse.filtered hasUnderscore hasUnderscore e = e ^. recLabel.to (T.isPrefixOf "_") lensableConstructor = filter singleRecordCons cs ^? _head singleRecordCons (DataConstructor _ (Right _)) = True singleRecordCons _ = False recordOptics _ = "" constructorToText :: Int -> DataConstructor 'PureScript -> Text constructorToText _ (DataConstructor n (Left [])) = n constructorToText _ (DataConstructor n (Left ts)) = n <> " " <> T.intercalate " " (map (typeInfoToText False) ts) constructorToText indentation (DataConstructor n (Right rs)) = n <> " {\n" <> spaces (indentation + 2) <> T.intercalate intercalation (map recordEntryToText rs) <> "\n" <> spaces indentation <> "}" where intercalation = "\n" <> spaces indentation <> "," <> " " spaces :: Int -> Text spaces c = T.replicate c " " typeNameAndForall :: TypeInfo 'PureScript -> (Text, Text) typeNameAndForall typeInfo = (typName, forAll) where typName = typeInfoToText False typeInfo forAllParams = typeInfo ^.. typeParameters.traversed.to (typeInfoToText False) forAll = case forAllParams of [] -> " :: " cs -> " :: forall " <> T.intercalate " " cs <> ". " fromEntries :: (RecordEntry a -> Text) -> [RecordEntry a] -> Text fromEntries mkElem rs = "{ " <> inners <> " }" where inners = T.intercalate ", " $ map mkElem rs mkFnArgs :: [RecordEntry 'PureScript] -> Text mkFnArgs [r] = r ^. recLabel mkFnArgs rs = fromEntries (\recE -> recE ^. recLabel <> ": " <> recE ^. recLabel) rs mkTypeSig :: [RecordEntry 'PureScript] -> Text mkTypeSig [] = "Unit" mkTypeSig [r] = typeInfoToText False $ r ^. recValue mkTypeSig rs = fromEntries recordEntryToText rs constructorToOptic :: Bool -> TypeInfo 'PureScript -> DataConstructor 'PureScript -> Text constructorToOptic otherConstructors typeInfo (DataConstructor n args) = case (args,otherConstructors) of (Left [c], False) -> pName <> forAll <> "Iso' " <> typName <> " " <> mkTypeSig (constructorTypes [c]) <> "\n" <> pName <> " = _Newtype" <> "\n" (Left cs, _) -> pName <> forAll <> "Prism' " <> typName <> " " <> mkTypeSig types <> "\n" <> pName <> " = prism' " <> getter <> " f\n" <> spaces 2 <> "where\n" <> spaces 4 <> "f " <> mkF cs <> otherConstructorFallThrough <> "\n" where mkF [] = n <> " = Just unit\n" mkF _ = "(" <> n <> " " <> T.unwords (map _recLabel types) <> ") = Just $ " <> mkFnArgs types <> "\n" getter | null cs = "(\\_ -> " <> n <> ")" | length cs == 1 = n | otherwise = "(\\{ " <> T.intercalate ", " cArgs <> " } -> " <> n <> " " <> T.intercalate " " cArgs <> ")" where cArgs = map (T.singleton . fst) $ zip ['a'..] cs types = constructorTypes cs (Right rs, False) -> pName <> forAll <> "Iso' " <> typName <> " { " <> recordSig rs <> "}\n" <> pName <> " = _Newtype\n" <> "\n" (Right rs, True) -> pName <> forAll <> "Prism' " <> typName <> " { " <> recordSig rs <> " }\n" <> pName <> " = prism' " <> n <> " f\n" <> spaces 2 <> "where\n" <> spaces 4 <> "f (" <> n <> " r) = Just r\n" <> otherConstructorFallThrough <> "\n" where recordSig rs = T.intercalate ", " (map recordEntryToText rs) constructorTypes cs = [RecordEntry (T.singleton label) t | (label, t) <- zip ['a'..] cs] (typName, forAll) = typeNameAndForall typeInfo pName = "_" <> n otherConstructorFallThrough | otherConstructors = spaces 4 <> "f _ = Nothing" | otherwise = "" recordEntryToLens :: SumType 'PureScript -> RecordEntry 'PureScript -> Text recordEntryToLens st e = if hasUnderscore then lensName <> forAll <> "Lens' " <> typName <> " " <> recType <> "\n" <> lensName <> " = _Newtype <<< prop (Proxy :: Proxy \"" <> recName <> "\")\n" else "" where (typName, forAll) = typeNameAndForall (st ^. sumTypeInfo) recName = e ^. recLabel lensName = T.drop 1 recName recType = typeInfoToText False (e ^. recValue) hasUnderscore = e ^. recLabel.to (T.isPrefixOf "_") recordEntryToText :: RecordEntry 'PureScript -> Text recordEntryToText e = _recLabel e <> " :: " <> typeInfoToText True (e ^. recValue) typeInfoToText :: Bool -> PSType -> Text typeInfoToText topLevel t = if needParens then "(" <> inner <> ")" else inner where inner = _typeName t <> if pLength > 0 then " " <> T.intercalate " " textParameters else "" params = _typeParameters t pLength = length params needParens = not topLevel && pLength > 0 textParameters = map (typeInfoToText False) params mergedTypeInfoToText :: PSType -> Text mergedTypeInfoToText t = _typeName t <> T.concat textParameters where params = _typeParameters t textParameters = map mergedTypeInfoToText params sumTypesToModules :: Modules -> [SumType 'PureScript] -> Modules sumTypesToModules = foldr sumTypeToModule sumTypeToModule :: SumType 'PureScript -> Modules -> Modules sumTypeToModule st@(SumType t _ _) = Map.alter (Just . updateModule) (_typeModule t) where updateModule Nothing = PSModule { psModuleName = _typeModule t , psImportLines = dropSelf $ typesToImportLines Map.empty (getUsedTypes st) , psTypes = [st] } updateModule (Just m) = m { psImportLines = dropSelf $ typesToImportLines (psImportLines m) (getUsedTypes st) , psTypes = st : psTypes m } dropSelf = Map.delete (_typeModule t) typesToImportLines :: ImportLines -> Set PSType -> ImportLines typesToImportLines = foldr typeToImportLines typeToImportLines :: PSType -> ImportLines -> ImportLines typeToImportLines t ls = typesToImportLines (update ls) (Set.fromList (_typeParameters t)) where update = if not (T.null (_typeModule t)) then Map.alter (Just . updateLine) (_typeModule t) else id updateLine Nothing = ImportLine (_typeModule t) Nothing (Set.singleton (_typeName t)) updateLine (Just (ImportLine m alias types)) = ImportLine m alias (Set.insert (_typeName t) types) importsFromList :: [ImportLine] -> Map Text ImportLine importsFromList ls = let pairs = zip (map importModule ls) ls merge a b = ImportLine (importModule a) (importAlias a) (importTypes a `Set.union` importTypes b) in Map.fromListWith merge pairs mergeImportLines :: ImportLines -> ImportLines -> ImportLines mergeImportLines = Map.unionWith mergeLines where mergeLines a b = ImportLine (importModule a) (importAlias a) (importTypes a `Set.union` importTypes b) unlessM :: Monad m => m Bool -> m () -> m () unlessM mbool action = mbool >>= flip unless action