module PureScript.Bridge.Printer where
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.FilePath
import PureScript.Bridge.SumType
import PureScript.Bridge.TypeInfo
data PSModule = PSModule {
psModuleName :: Text
, psImportLines :: Map Text ImportLine
, psTypes :: [SumType]
} deriving Show
data ImportLine = ImportLine {
importModule :: Text
, importTypes :: Set Text
} deriving Show
type Modules = Map Text PSModule
type ImportLines = Map Text ImportLine
printModule :: FilePath -> PSModule -> IO ()
printModule root m = T.writeFile mPath . moduleToText $ m
where
mFile = joinPath . map T.unpack . T.splitOn "." $ psModuleName m
mPath = root </> mFile
moduleToText :: PSModule -> Text
moduleToText m = T.unlines $
"module " <> psModuleName m <> "where\n"
: map importLineToText (M.elems (psImportLines m))
++ [ "\n\n" ]
++ map sumTypeToText (psTypes m)
importLineToText :: ImportLine -> Text
importLineToText l = "import " <> importModule l <> "(" <> typeList <> ")"
where
typeList = T.intercalate ", " (S.toList (importTypes l))
sumTypeToText :: SumType -> Text
sumTypeToText (SumType t cs) = T.unlines $
"data " <> typeName t <> "="
: [ " " <> T.intercalate " | " (map (constructorToText 4) cs) ]
constructorToText :: Int -> DataConstructor -> Text
constructorToText _ (DataConstructor n (Left ts)) = n <> T.intercalate " " (map typeInfoToText ts)
constructorToText indentation (DataConstructor n (Right rs)) = T.unlines $
n <> " {"
: [spaces (indentation + 2) <> T.intercalate intercalation (map recordEntryToText rs)]
++ [ spaces indentation <> "}" ]
where
intercalation = "\n" <> spaces indentation <> "," <> spaces 2
spaces c = T.replicate c " "
recordEntryToText :: RecordEntry -> Text
recordEntryToText e = recLabel e <> " :: " <> typeInfoToText (recValue e)
typeInfoToText :: TypeInfo -> Text
typeInfoToText t = if length textParameters > 1 then "(" <> inner <> ")" else inner
where
inner = typeName t <> T.intercalate " " textParameters
textParameters = map typeInfoToText (typeParameters t)
sumTypesToModules :: Modules -> [SumType] -> Modules
sumTypesToModules = foldr sumTypeToModule
sumTypeToModule :: SumType -> Modules -> Modules
sumTypeToModule st@(SumType t _) = M.alter (Just. updateModule) (typeModule t)
where
updateModule Nothing = PSModule {
psModuleName = typeModule t
, psImportLines = typesToImportLines M.empty (getUsedTypes st)
, psTypes = [st]
}
updateModule (Just m) = m {
psImportLines = typesToImportLines (psImportLines m) (getUsedTypes st)
, psTypes = st : psTypes m
}
typesToImportLines :: ImportLines -> [TypeInfo] -> ImportLines
typesToImportLines = foldr typeToImportLines
typeToImportLines :: TypeInfo -> ImportLines -> ImportLines
typeToImportLines t = M.alter (Just . updateLine) (typeModule t)
where
updateLine Nothing = ImportLine (typeModule t) (S.singleton (typeName t))
updateLine (Just (ImportLine m types)) = ImportLine m $ S.insert (typeName t) types