src/Literate/Web/Semantics/Compiler.hs

   1 -- For Dataable instances
   2 {-# LANGUAGE InstanceSigs #-}
   3 -- For Output
   4 {-# LANGUAGE RankNTypes #-}
   5 -- For Dataable instances
   6 {-# LANGUAGE UndecidableInstances #-}
   7
   8 module Literate.Web.Semantics.Compiler where
   9
  10 import Control.Applicative (Applicative (..))
  11 import Control.Monad (Monad (..), forM_)
  12 import Control.Monad.Classes qualified as MC
  13 import Data.Bool
  14 import Data.ByteString.Lazy qualified as BSL
  15 import Data.Either (Either (..))
  16 import Data.Eq (Eq)
  17 import Data.Foldable (toList)
  18 import Data.Function (id, ($), (.))
  19 import Data.Functor (Functor (..), (<$>))
  20 import Data.List qualified as List
  21 import Data.Map.Strict qualified as Map
  22 import Data.Maybe (Maybe (..))
  23 import Data.Monoid (Monoid (..))
  24 import Data.Ord (Ord)
  25 import Data.Proxy (Proxy (..))
  26 import Data.Semigroup (Semigroup (..))
  27 import Data.Text (Text)
  28 import Data.Text qualified as Text
  29 import Data.Tuple (fst, snd)
  30 import GHC.Generics (Generic)
  31 import GHC.Stack (HasCallStack)
  32 import Symantic qualified as Sym
  33 import System.Directory qualified as Sys
  34 import System.FilePath qualified as Sys
  35 import System.FilePattern.Directory qualified as Sys
  36 import System.IO qualified as Sys
  37 import Text.Show (Show (..))
  38 import Type.Reflection ((:~:) (..))
  39
  40 import Literate.Web.Syntaxes
  41 import Literate.Web.Types.MIME
  42 import Literate.Web.Types.URL
  43
  44 -- * Type 'Compiler'
  45
  46 -- | Interpreter building a static Web site.
  47 --
  48 -- Embed a 'Monad' @m@ to give access to a model if need be.
  49 newtype Compiler m a = Compiler {unCompiler :: m [Output a]}
  50
  51 type instance Sym.ToFEndpoint (Compiler m) a next = (next :~: m BSL.ByteString, a)
  52
  53 compilerEndpoint :: a -> Sym.ToFEndpoint (Compiler m) a (m BSL.ByteString)
  54 compilerEndpoint = (Refl,)
  55
  56 compiler :: Compiler m (m BSL.ByteString) -> Compiler m (m BSL.ByteString)
  57 compiler = id
  58
  59 compile ::
  60   MC.MonadExec Sys.IO m =>
  61   CompilerEnv ->
  62   Compiler m a ->
  63   (a --> m BSL.ByteString) ->
  64   m ()
  65 compile CompilerEnv{..} router content = do
  66   outputs <- unCompiler router
  67   MC.exec @Sys.IO $ Sys.removePathForcibly compilerEnvDest
  68   forM_ outputs $ \out -> do
  69     let outFullPath = outputPathFile (outputPathRelative out)
  70     -- MC.exec $ Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory outFullPath)
  71     MC.exec @Sys.IO $
  72       Sys.createDirectoryIfMissing True $
  73         compilerEnvDest Sys.</> Sys.takeDirectory outFullPath
  74     -- MC.exec $ Sys.hPutStrLn Sys.stderr $ "write: " <> show outFullPath
  75     bsl <- outputData out content
  76     MC.exec @Sys.IO $ BSL.writeFile (compilerEnvDest Sys.</> outFullPath) bsl
  77
  78 siteManifest :: Monad m => Compiler m a -> m [Sys.FilePath]
  79 siteManifest router = (outputPathFile . outputPathRelative <$>) <$> unCompiler router
  80
  81 siteMap ::
  82   Monad m =>
  83   Compiler m a ->
  84   (a --> m BSL.ByteString) ->
  85   m (Map.Map OutputPath (m BSL.ByteString))
  86 siteMap router content = do
  87   outputs <- unCompiler router
  88   return $
  89     Map.fromList
  90       [ (outputPathRelative out, outputData out content)
  91       | out <- outputs
  92       ]
  93
  94 -- ** Type 'CompilerEnv'
  95 data CompilerEnv = CompilerEnv
  96   { compilerEnvDest :: Sys.FilePath
  97   , -- , compilerEnvSource :: Sys.FilePath
  98     compilerEnvIndex :: Sys.FilePath
  99     -- , compilerEnvModel :: model
 100     -- , compilerEnvPath :: [PathSegment]
 101   }
 102   deriving (Show)
 103
 104 -- instance Applicative m => Applicative (Compiler m) where
 105 --   pure = Compiler . pure . pure . pure
 106 --   liftA2 f (Compiler a) (Compiler b) = Compiler (liftA2 (liftA2 (liftA2 f)) a b)
 107 -- instance Monad m => Monad (Compiler m) where
 108 --   return = pure
 109 --   Compiler mloa >>= a2mlob =
 110 --     Compiler $ do
 111 --       mloa >>= \loa ->
 112 --         (join <$>) $
 113 --           forM loa $ \oa -> do
 114 --             lob <- unCompiler $ a2mlob $ outputData oa
 115 --             forM lob $ \ob ->
 116 --               return
 117 --                 ob
 118 --                   { outputPath = outputPath oa <> outputPath ob
 119 --                   , outputExts = outputExts oa <> outputExts ob
 120 --                   }
 121 instance Applicative m => Sym.ProductFunctor (Compiler m) where
 122   Compiler a <.> Compiler b = Compiler $ liftA2 (liftA2 (<.>)) a b
 123   Compiler a <. Compiler b = Compiler $ liftA2 (liftA2 (<.)) a b
 124   Compiler a .> Compiler b = Compiler $ liftA2 (liftA2 (.>)) a b
 125
 126 -- instance Applicative m => Sym.AlternativeFunctor (Compiler m) where
 127 --  Compiler a <|> Compiler b = Compiler (liftA2 (<>) a b)
 128
 129 instance Applicative m => Sym.SumFunctor (Compiler m) where
 130   Compiler a <+> Compiler b = Compiler $ liftA2 (\as bs -> (a2e <$> as) <> (b2e <$> bs)) a b
 131     where
 132       a2e :: Output a -> Output (Either a b)
 133       a2e o = o{outputData = outputData o . fst}
 134       b2e :: Output b -> Output (Either a b)
 135       b2e o = o{outputData = outputData o . snd}
 136
 137 instance (Applicative m, Sym.ToFable a) => Optionable a (Compiler m) where
 138   optional (Compiler ma) = Compiler $ (\as -> forNothing : (forJust <$> as)) <$> ma
 139     where
 140       forNothing :: Output (Maybe a)
 141       forNothing = Output{outputPath = mempty, outputData = ($ Nothing)}
 142       forJust :: Output a -> Output (Maybe a)
 143       forJust o = o{outputData = \k -> outputData o $ Sym.tofOffun $ k . Just}
 144
 145 --   optional (Compiler ma) = Compiler $ (\as -> forNothing : (forJust <$> as)) <$> ma
 146 --     --pure Nothing Sym.<|> (Just <$> ma)
 147 --     where
 148 --     forNothing :: Output a -> Output (Maybe a)
 149 --     forNothing o = o{ outputData = fst }
 150 --     forJust :: Output a -> Output (Maybe a)
 151 --     forJust o = o{ outputData = outputData o . snd }
 152
 153 instance
 154   ( Generic a
 155   , Sym.RepOfEoT a
 156   , sem ~ Compiler m
 157   , Sym.IsToF a ~ 'False
 158   , eot ~ Sym.EoT (Sym.ADT a)
 159   , Sym.ToFable eot
 160   , Functor m
 161   ) =>
 162   Dataable a (Compiler m)
 163   where
 164   dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
 165   dataType (Compiler mos) = Compiler ((dataType <$>) <$> mos)
 166 instance
 167   ( Generic a
 168   , Sym.RepOfEoT a
 169   , sem ~ Output
 170   , Sym.IsToF a ~ 'False
 171   , eot ~ Sym.EoT (Sym.ADT a)
 172   , Sym.ToFable eot
 173   ) =>
 174   Dataable a Output
 175   where
 176   dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
 177   dataType o = o{outputData = \k -> (outputData o) $ Sym.tofOffun $ k . Sym.adtOfeot}
 178 instance Applicative m => PathSegmentable (Compiler m) where
 179   pathSegment s =
 180     Compiler $
 181       pure
 182         [ Output
 183             { outputPath =
 184                 OutputPath
 185                   { outputPathSegs = [s]
 186                   , outputPathExts = []
 187                   }
 188             , outputData = id
 189             }
 190         ]
 191 instance
 192   ( Applicative m
 193   , n ~ m
 194   , MimeTypes ts (MimeEncodable a)
 195   ) =>
 196   Responsable a ts n (Compiler m)
 197   where
 198   response =
 199     Compiler $
 200       pure $
 201         ( \(_mediaType, MimeType (Proxy :: Proxy t)) ->
 202             Output
 203               { outputPath =
 204                   OutputPath
 205                     { outputPathSegs = []
 206                     , outputPathExts = [decodePathSegment (fileExtension @t)]
 207                     }
 208               , outputData = \(Refl, Response ma) -> mimeEncode @_ @t <$> ma
 209               }
 210         )
 211           <$> toList (mimeTypesMap @ts @(MimeEncodable a))
 212
 213 -- ** Type 'Output'
 214
 215 data Output a = Output
 216   { outputPath :: OutputPath
 217   , outputData :: forall next. (a --> next) -> next
 218   }
 219
 220 outputBSL :: Output a -> (a --> m BSL.ByteString) -> m BSL.ByteString
 221 outputBSL = outputData
 222
 223 outputPathRelative :: Output a -> OutputPath
 224 outputPathRelative out
 225   | List.null (outputPathExts outPath) = outPath{outputPathExts = ["txt"]}
 226   | otherwise = outPath
 227   where
 228     outPath = outputPath out
 229
 230 -- *** Type 'OutputPath'
 231 data OutputPath = OutputPath
 232   { outputPathSegs :: [PathSegment]
 233   , outputPathExts :: [PathSegment]
 234   }
 235   deriving (Eq, Ord)
 236
 237 outputPathFile :: OutputPath -> Sys.FilePath
 238 outputPathFile outPath =
 239   List.intercalate "." $
 240     encodePath (outputPathSegs outPath)
 241       : (Text.unpack . encodePathSegment <$> outputPathExts outPath)
 242
 243 instance Semigroup OutputPath where
 244   x <> y =
 245     OutputPath
 246       { outputPathSegs = outputPathSegs x <> outputPathSegs y
 247       , outputPathExts = outputPathExts x <> outputPathExts y
 248       }
 249 instance Monoid OutputPath where
 250   mempty = OutputPath{outputPathSegs = [], outputPathExts = []}
 251
 252 instance Sym.ProductFunctor Output where
 253   a <.> b =
 254     Output
 255       { outputPath = outputPath a <> outputPath b
 256       , outputData = outputData b . outputData a
 257       }
 258   a <. b =
 259     Output
 260       { outputPath = outputPath a <> outputPath b
 261       , outputData = outputData b . outputData a
 262       }
 263   a .> b =
 264     Output
 265       { outputPath = outputPath a <> outputPath b
 266       , outputData = outputData b . outputData a
 267       }
 268
 269 -- compile :: Show a => Renderable a => Compiler a -> CompilerEnv -> Sys.IO ()
 270 -- compile compiler conf@CompilerEnv{..} = do
 271 --   createDirectoryIfMissing True compilerEnvDest
 272 --   let router = unCompiler compiler
 273 --   when (null router) $
 274 --     error "no router, nothing to compile"
 275 --   -- Sys.hPutStrLn Sys.stderr $ "conf: " <> show conf
 276 --   -- forM_ router $ \comp -> do
 277 --   --   Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
 278 --   forM_ router $ \Comp{..} -> do
 279 --     -- Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
 280 --     let routePath = pathOfPathSegments compPathSegments
 281 --      in case render compData of
 282 --           Left staticPath ->
 283 --             doesPathExist (compilerEnvSource </> staticPath) >>= \case
 284 --               True -> do
 285 --                 -- TODO: In current branch, we don't expect this to be a directory.
 286 --                 -- Although the user may pass it, but review before merge.
 287 --                 Sys.hPutStrLn Sys.stderr $
 288 --                   "staticCopy: "
 289 --                     <> show
 290 --                       ( (compilerEnvSource </> staticPath)
 291 --                       , (compilerEnvDest </> staticPath)
 292 --                       )
 293 --                 copyDirRecursively
 294 --                   staticPath
 295 --                   (compilerEnvSource </> staticPath)
 296 --                   (compilerEnvDest)
 297 --               False -> do
 298 --                 Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource </> staticPath)
 299 --           -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
 300 --           Right bs -> do
 301 --             let outputFullPath = compilerEnvDest </> routePath
 302 --                            {-
 303 --                            maybe (routePath </> compilerEnvIndex)
 304 --                                  (routePath Sys.FilePath.<.>)
 305 --                                  (compType comp)
 306 --                           -}
 307 --             -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory outputFullPath)
 308 --             createDirectoryIfMissing True (Sys.takeDirectory outputFullPath)
 309 --             -- Sys.hPutStrLn Sys.stderr $ "write: " <> show outputFullPath
 310 --             BSL.writeFile outputFullPath bs
 311
 312 copyDirRecursively ::
 313   HasCallStack =>
 314   -- | Source file path relative to CWD
 315   Sys.FilePath ->
 316   -- | Absolute path to source file to copy.
 317   Sys.FilePath ->
 318   -- | Directory *under* which the source file/dir will be copied
 319   Sys.FilePath ->
 320   Sys.IO ()
 321 copyDirRecursively srcRel srcAbs destParent = do
 322   Sys.doesFileExist srcAbs >>= \case
 323     True -> do
 324       Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a file" :: Text, srcAbs)
 325       copyFileCreatingParents srcAbs (destParent Sys.</> srcRel)
 326     False ->
 327       Sys.doesDirectoryExist srcAbs >>= \case
 328         False -> do
 329           Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is neither a file nor directory" :: Text, srcAbs)
 330           return ()
 331         -- throw $ StaticAssetMissing srcAbs
 332         True -> do
 333           Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a directory" :: Text, srcAbs)
 334           Sys.createDirectoryIfMissing True (destParent Sys.</> srcRel)
 335           fs <- Sys.getDirectoryFiles srcAbs ["**"]
 336           forM_ fs $ \fp -> do
 337             let
 338               a = srcAbs Sys.</> fp
 339               b = destParent Sys.</> srcRel Sys.</> fp
 340             copyFileCreatingParents a b
 341   where
 342     copyFileCreatingParents a b = do
 343       Sys.createDirectoryIfMissing True (Sys.takeDirectory b)
 344       Sys.copyFile a b