scaffolder/src/Text/Edifact/Scaffolder/Commons/Language.hs

   1 {-# LANGUAGE DerivingStrategies         #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE OverloadedLists            #-}
   4 {-# LANGUAGE OverloadedStrings          #-}
   5
   6 module Text.Edifact.Scaffolder.Commons.Language
   7   ( -- *
   8     saveHaskellModule
   9   , includeSpecification
  10     -- *
  11   , scaffoldModule
  12     -- *
  13   , getRootModuleName
  14   , getRootModuleNameFor
  15     -- *
  16   , scaffoldElements
  17   , ElementWithDefinition
  18     -- *
  19   , parentModule
  20     -- *
  21   , haddockDependencies
  22     -- *
  23   , reexportDependencies
  24     -- *
  25   , importDependencies
  26   , importCombinators
  27   , importNotYetImplementedHelper
  28     -- *
  29   , moduleDeclaration
  30   , Export(..)
  31     -- *
  32   , reexportAlias
  33   , singleImport
  34   , ImportGroup(..)
  35   , Import(..)
  36   , ImportName(..)
  37   , ModuleAlias(..)
  38   , LanguageExtension(..)
  39   ) where
  40
  41 import           Text.Edifact.Scaffolder.Commons.Formatters (fModuleName,
  42                                                              parens,
  43                                                              simpleQuoted)
  44 import           Text.Edifact.Scaffolder.Commons.Logging    (say)
  45 import           Text.Edifact.Scaffolder.Commons.Text       (commaSeparated,
  46                                                              extensions,
  47                                                              formatSpecification,
  48                                                              indent, newline)
  49 import           Text.Edifact.Scaffolder.Commons.Types      (LanguageExtension (..),
  50                                                              ModuleName (..),
  51                                                              Scaffolding,
  52                                                              getRevision,
  53                                                              hostModule,
  54                                                              revision,
  55                                                              targetDirectory,
  56                                                              (<.>))
  57
  58 import           Control.Monad                              ((>=>))
  59 import           Control.Monad.IO.Class                     (liftIO)
  60 import           Control.Monad.Reader                       (asks)
  61 import           Data.Bifunctor                             (bimap)
  62 import           Data.Foldable                              (traverse_)
  63 import           Data.List                                  (intercalate,
  64                                                              uncons)
  65 import           Data.List.NonEmpty                         (NonEmpty, nonEmpty)
  66 import qualified Data.List.NonEmpty                         as NE (cons, toList)
  67 import           Data.List.Split                            (splitOn)
  68 import           Data.String                                (IsString (..))
  69 import           Data.Text                                  as T (Text, drop,
  70                                                                   lines,
  71                                                                   unlines)
  72 import qualified Data.Text.IO                               as TIO (readFile,
  73                                                                     writeFile)
  74 import           Data.Tuple                                 (swap)
  75 import           Formatting                                 as F (Format,
  76                                                                   bprint, later,
  77                                                                   mapf, sformat,
  78                                                                   stext, (%))
  79 import           System.Directory                           (createDirectoryIfMissing)
  80 import           System.FilePath                            ((</>))
  81 import           System.Process                             (callCommand)
  82
  83 getRootModuleName :: Scaffolding ModuleName
  84 getRootModuleName =
  85   let prefix host rev = host <.> ModuleName (getRevision rev)
  86   in asks (prefix . hostModule) <*> asks revision
  87
  88 getRootModuleNameFor :: ModuleName -> Scaffolding ModuleName
  89 getRootModuleNameFor name =
  90   let suffix root = root <.> name
  91   in suffix <$> getRootModuleName
  92
  93 saveHaskellModule :: ModuleName -> [Text] -> Scaffolding ()
  94 saveHaskellModule mn body =
  95   let sources = T.unlines body
  96       saveModule file = liftIO (saveFile file >> stylishHaskell file)
  97       saveFile = flip TIO.writeFile sources
  98       stylishHaskell file = callCommand ("stylish-haskell -i " <> file)
  99       doNothing = pure ()
 100   in say ("module " % fModuleName) mn >> mkSourceFile mn >>= maybe doNothing saveModule
 101
 102 mkSourceFile :: ModuleName -> Scaffolding (Maybe FilePath)
 103 mkSourceFile = locateSourceFile >=> traverse prepareHierarchy
 104
 105 type FileInDirectory = (Directory, FileName)
 106 type Directory = FilePath
 107 type FileName = FilePath
 108
 109 prepareHierarchy :: FileInDirectory -> Scaffolding FilePath
 110 prepareHierarchy (directory, file) =
 111   let fullPath = directory </> file
 112   in fullPath <$ liftIO (createDirectoryIfMissing True directory)
 113
 114 locateSourceFile :: ModuleName -> Scaffolding (Maybe FileInDirectory)
 115 locateSourceFile (ModuleName mn) =
 116   let hierarchy = splitOn "." mn
 117       toFile n = n <> ".hs"
 118       path :: Directory -> Maybe (Directory, FileName)
 119       path directory = fmap toFile . swap . fmap (foldl (</>) directory . reverse) <$> uncons (reverse hierarchy)
 120   in asks (path . targetDirectory)
 121
 122 includeSpecification :: FilePath -> Scaffolding [Text]
 123 includeSpecification = fmap (formatSpecification . T.lines) . liftIO . TIO.readFile
 124
 125 type ElementWithDefinition elt = (FilePath, elt)
 126
 127 scaffoldElements :: (NonEmpty (ElementWithDefinition element) -> Scaffolding ())
 128                  -> (          ElementWithDefinition element  -> Scaffolding ())
 129                  -> ([         ElementWithDefinition element] -> Scaffolding ())
 130 scaffoldElements parentScaffolder elementScaffolder =
 131   let doNothing = pure ()
 132       scaffolder elts = parentScaffolder elts >> traverse_ elementScaffolder elts
 133   in maybe doNothing scaffolder . nonEmpty
 134
 135 parentModule :: ModuleName -> ModuleAlias -> (ModuleName -> element -> ModuleName) -> NonEmpty (ElementWithDefinition element) -> Scaffolding ()
 136 parentModule elementName alias nameModule elements =
 137   getRootModuleNameFor elementName >>= generateRootModule alias nameModule (snd <$> elements)
 138
 139 generateRootModule :: ModuleAlias -> (ModuleName -> element -> ModuleName) -> NonEmpty element -> ModuleName -> Scaffolding ()
 140 generateRootModule alias nameModule codes mn =
 141   let importElement code = ImportAll (ImportAs (nameModule mn code) alias)
 142       imports = [ ImportGroup (importElement <$> codes) ]
 143       exports = [ reexportAlias alias ]
 144   in saveHaskellModule mn $
 145        moduleDeclaration mn exports imports
 146
 147 haddockDependencies :: Format Text (elt -> Text) -> NonEmpty elt -> Scaffolding [Text]
 148 haddockDependencies formatter elts =
 149   let formattedDependencies = commaSeparated . fmap (sformat (simpleQuoted formatter))
 150       formatHaddock = sformat ("-- Dependencies: " % F.stext % ".")
 151   in pure [ "--"
 152           , formatHaddock (formattedDependencies elts)
 153           ]
 154
 155 reexportDependencies :: Format Text (elt -> Text) -> NonEmpty elt -> Scaffolding [Export]
 156 reexportDependencies formatter =
 157   let mkReexport = Name . sformat formatter
 158       prependTitle = NE.cons (Comment "* Dependencies")
 159   in pure . NE.toList . prependTitle . fmap mkReexport
 160
 161 importDependencies :: ModuleName -> Format Text (elt -> Text) -> NonEmpty elt -> Scaffolding Import
 162 importDependencies moduleName formatter elts =
 163   let imports = NE.toList (sformat formatter <$> elts)
 164       mkImport mn = Import (BasicImport mn) imports
 165   in mkImport <$> getRootModuleNameFor moduleName
 166
 167 importCombinators :: ImportGroup
 168 importCombinators =
 169   ImportGroup
 170     [ ImportAll "Text.Edifact.Parsing"
 171     , Import    "Text.Edifact.Types"   [ "Value" ]
 172     ]
 173
 174 importNotYetImplementedHelper :: ImportGroup
 175 importNotYetImplementedHelper =
 176   ImportGroup
 177     [ Import "Text.Edifact.Parsing.Commons" [ "notYetImplemented" ]
 178     ]
 179
 180 moduleDeclaration :: ModuleName -> [Export] -> [ImportGroup] -> [Text]
 181 moduleDeclaration moduleName exports imports =
 182   let decl mn [] = [sformat ("module " % fModuleName % " where") mn]
 183       decl mn ex = sformat ("module " % fModuleName) mn
 184                  : renderExports ex
 185   in intercalate newline [ decl moduleName exports
 186                          , renderImports imports
 187                          ]
 188
 189 machineGeneratedWarning :: [Text]
 190 machineGeneratedWarning =
 191   [ "---- Machine generated code."
 192   , "---- Output of edi-parser-scaffolder"
 193   ]
 194
 195 scaffoldModule :: ModuleName -> [LanguageExtension] -> [Export] -> [ImportGroup] -> [Text] -> Scaffolding ()
 196 scaffoldModule mn exts exports imports code =
 197   saveHaskellModule mn $
 198     intercalate newline
 199       [ extensions exts
 200       , machineGeneratedWarning
 201       , moduleDeclaration mn exports imports
 202       , code
 203       ]
 204
 205 renderExports :: [Export] -> [Text]
 206 renderExports exports =
 207   let formatExport (First e)     = sformat ("  " % fExport) e
 208       formatExport (Following e) = sformat (", " % fExport) e
 209       formatExport (Skipped e)   = sformat ("  " % fExport) e
 210       fExport =
 211         let f (Comment t) = bprint ("-- " % stext) t
 212             f (Name    t) = bprint stext t
 213         in later f
 214       parensOnFirstLine [] = []
 215       parensOnFirstLine (firstLine : rest) = ("(" <> T.drop 1 firstLine) : rest
 216       ls = parensOnFirstLine (formatExport <$> tag exports) <> [ ") where" ]
 217   in indent <$> ls
 218
 219 data Export = Name    Text
 220             | Comment Text
 221
 222 instance IsString Export where
 223   fromString = Name . fromString
 224
 225 data Tag a = First     a
 226            | Following a
 227            | Skipped   a
 228
 229 tag :: [Export] -> [Tag Export]
 230 tag =
 231   let skipAll = fmap Skipped
 232       tagFirst []             = []
 233       tagFirst (elt : others) = First elt : tagOthers others
 234       tagOthers = fmap tagOther
 235       tagOther v | isComment v = Skipped v
 236                  | otherwise   = Following v
 237       merge (xs, ys) = xs <> ys
 238   in merge . bimap skipAll tagFirst . span isComment
 239
 240 isComment :: Export -> Bool
 241 isComment (Comment _) = True
 242 isComment _           = False
 243
 244 newtype ModuleAlias = ModuleAlias { getModuleAlias :: Text } deriving newtype (IsString)
 245
 246 singleImport :: Import -> ImportGroup
 247 singleImport = ImportGroup . pure
 248
 249 newtype ImportGroup = ImportGroup (NonEmpty Import) deriving newtype Semigroup
 250
 251 data Import = Import    ImportName [Text]
 252             | ImportAll ImportName
 253
 254 data ImportName = BasicImport       ModuleName
 255                 | ImportAs          ModuleName ModuleAlias
 256                 | ImportQualified   ModuleName
 257                 | ImportQualifiedAs ModuleName ModuleAlias
 258
 259 instance IsString ImportName where
 260   fromString = BasicImport . fromString
 261
 262 renderImports :: [ImportGroup] -> [Text]
 263 renderImports = intercalate newline . fmap renderImportGroup
 264
 265 reexportAlias :: ModuleAlias -> Export
 266 reexportAlias = Name . sformat ("module " % fModuleAlias)
 267
 268 renderImportGroup :: ImportGroup -> [Text]
 269 renderImportGroup (ImportGroup imports) = NE.toList (renderImport <$> imports)
 270
 271 renderImport :: Import -> Text
 272 renderImport (ImportAll name)            = sformat fImportName name
 273 renderImport (Import    name references) =
 274   sformat (fImportName % " " % parens stext) name (commaSeparated references)
 275
 276 fImportName :: Format r (ImportName -> r)
 277 fImportName =
 278   let
 279       build (BasicImport       name)       = bprint ("import " % fModuleName) name
 280       build (ImportAs          name alias) = bprint ("import " % fModuleName % " as " % fModuleAlias) name alias
 281       build (ImportQualified   name)       = bprint ("import qualified " % fModuleName) name
 282       build (ImportQualifiedAs name alias) = bprint ("import qualified " % fModuleName % " as " % fModuleAlias) name alias
 283   in later build
 284
 285 fModuleAlias :: Format r (ModuleAlias -> r)
 286 fModuleAlias = mapf getModuleAlias stext