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.Builder qualified as BSB
  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 (..), fromMaybe)
  23 import Data.Monoid (Last (..), 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 data CompilerEndpoint m a next = CompilerEndpoint
  52   { compilerEndpointProof :: next :~: m BSB.Builder
  53   , compilerEndpointData :: a
  54   }
  55 type instance Sym.ToFEndpoint (Compiler m) a next = CompilerEndpoint m a next
  56
  57 compilerEndpoint :: a -> CompilerEndpoint m a (m BSB.Builder)
  58 compilerEndpoint = CompilerEndpoint Refl
  59
  60 compiler :: Compiler m (m BSB.Builder) -> Compiler m (m BSB.Builder)
  61 compiler = id
  62
  63 compile ::
  64   MC.MonadExec Sys.IO m =>
  65   CompilerEnv ->
  66   Compiler m a ->
  67   (a --> m BSB.Builder) ->
  68   m ()
  69 compile CompilerEnv{..} router content = do
  70   outputs <- unCompiler router
  71   MC.exec @Sys.IO $ Sys.removePathForcibly compilerEnvDest
  72   forM_ outputs $ \out -> do
  73     let outFullPath = outputPathFile (outputPathRelative out)
  74     -- MC.exec $ Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory outFullPath)
  75     MC.exec @Sys.IO $
  76       Sys.createDirectoryIfMissing True $
  77         compilerEnvDest Sys.</> Sys.takeDirectory outFullPath
  78     -- MC.exec $ Sys.hPutStrLn Sys.stderr $ "write: " <> show outFullPath
  79     bsb <- outputData out content
  80     MC.exec @Sys.IO do
  81       Sys.withBinaryFile (compilerEnvDest Sys.</> outFullPath) Sys.WriteMode $ \h -> do
  82         BSB.hPutBuilder h bsb
  83
  84 siteManifest :: Monad m => Compiler m a -> m [Sys.FilePath]
  85 siteManifest router = (outputPathFile . outputPathRelative <$>) <$> unCompiler router
  86
  87 siteMap ::
  88   Monad m =>
  89   Compiler m a ->
  90   (a --> m BSB.Builder) ->
  91   m (Map.Map OutputPath (MediaType, m BSB.Builder))
  92 siteMap router content = do
  93   outputs <- unCompiler router
  94   return $
  95     Map.fromList
  96       [ ( outputPathRelative out
  97         ,
  98           ( outputType out & getLast & fromMaybe (mediaTypeFor (Proxy @HTML))
  99           , outputData out content
 100           )
 101         )
 102       | out <- outputs
 103       ]
 104
 105 -- ** Type 'CompilerEnv'
 106 data CompilerEnv = CompilerEnv
 107   { compilerEnvDest :: Sys.FilePath
 108   , -- , compilerEnvSource :: Sys.FilePath
 109     compilerEnvIndex :: Sys.FilePath
 110     -- , compilerEnvModel :: model
 111     -- , compilerEnvPath :: [PathSegment]
 112   }
 113   deriving (Show)
 114
 115 -- instance Applicative m => Applicative (Compiler m) where
 116 --   pure = Compiler . pure . pure . pure
 117 --   liftA2 f (Compiler a) (Compiler b) = Compiler (liftA2 (liftA2 (liftA2 f)) a b)
 118 -- instance Monad m => Monad (Compiler m) where
 119 --   return = pure
 120 --   Compiler mloa >>= a2mlob =
 121 --     Compiler $ do
 122 --       mloa >>= \loa ->
 123 --         (join <$>) $
 124 --           forM loa $ \oa -> do
 125 --             lob <- unCompiler $ a2mlob $ outputData oa
 126 --             forM lob $ \ob ->
 127 --               return
 128 --                 ob
 129 --                   { outputPath = outputPath oa <> outputPath ob
 130 --                   , outputExts = outputExts oa <> outputExts ob
 131 --                   }
 132 instance Applicative m => Sym.ProductFunctor (Compiler m) where
 133   Compiler a <.> Compiler b = Compiler $ liftA2 (liftA2 (<.>)) a b
 134   Compiler a <. Compiler b = Compiler $ liftA2 (liftA2 (<.)) a b
 135   Compiler a .> Compiler b = Compiler $ liftA2 (liftA2 (.>)) a b
 136
 137 -- instance Applicative m => Sym.AlternativeFunctor (Compiler m) where
 138 --  Compiler a <|> Compiler b = Compiler (liftA2 (<>) a b)
 139
 140 instance Applicative m => Sym.SumFunctor (Compiler m) where
 141   Compiler a <+> Compiler b = Compiler $ liftA2 (\as bs -> (a2e <$> as) <> (b2e <$> bs)) a b
 142     where
 143       a2e :: Output a -> Output (Either a b)
 144       a2e o = o{outputData = outputData o . fst}
 145       b2e :: Output b -> Output (Either a b)
 146       b2e o = o{outputData = outputData o . snd}
 147
 148 instance (Applicative m, Sym.ToFable a) => Optionable a (Compiler m) where
 149   optional (Compiler ma) = Compiler $ (\as -> forNothing : (forJust <$> as)) <$> ma
 150     where
 151       forNothing :: Output (Maybe a)
 152       forNothing =
 153         Output
 154           { outputPath = mempty
 155           , outputType = mempty
 156           , outputData = ($ Nothing)
 157           }
 158       forJust :: Output a -> Output (Maybe a)
 159       forJust o = o{outputData = \k -> outputData o $ Sym.tofOffun $ k . Just}
 160
 161 instance Functor m => Sym.Voidable (Compiler m) where
 162   void _a (Compiler ma) =
 163     Compiler $
 164       (\os -> (\o -> o{outputData = id}) <$> os) <$> ma
 165
 166 --   optional (Compiler ma) = Compiler $ (\as -> forNothing : (forJust <$> as)) <$> ma
 167 --     --pure Nothing Sym.<|> (Just <$> ma)
 168 --     where
 169 --     forNothing :: Output a -> Output (Maybe a)
 170 --     forNothing o = o{ outputData = fst }
 171 --     forJust :: Output a -> Output (Maybe a)
 172 --     forJust o = o{ outputData = outputData o . snd }
 173
 174 instance
 175   ( Generic a
 176   , Sym.RepOfEoT a
 177   , sem ~ Compiler m
 178   , Sym.IsToF a ~ 'False
 179   , eot ~ Sym.EoT (Sym.ADT a)
 180   , Sym.ToFable eot
 181   , Functor m
 182   ) =>
 183   Dataable a (Compiler m)
 184   where
 185   dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
 186   dataType (Compiler mos) = Compiler ((dataType <$>) <$> mos)
 187 instance
 188   ( Generic a
 189   , Sym.RepOfEoT a
 190   , sem ~ Output
 191   , Sym.IsToF a ~ 'False
 192   , eot ~ Sym.EoT (Sym.ADT a)
 193   , Sym.ToFable eot
 194   ) =>
 195   Dataable a Output
 196   where
 197   dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
 198   dataType o = o{outputData = \k -> (outputData o) $ Sym.tofOffun $ k . Sym.adtOfeot}
 199 instance Applicative m => PathSegmentable (Compiler m) where
 200   pathSegment s =
 201     Compiler $
 202       pure
 203         [ Output
 204             { outputPath =
 205                 OutputPath
 206                   { outputPathSegs = [s]
 207                   , outputPathExts = []
 208                   }
 209             , outputType = mempty
 210             , outputData = id
 211             }
 212         ]
 213 instance
 214   ( Applicative m
 215   , n ~ m
 216   , MimeTypes ts (MimeEncodable a)
 217   ) =>
 218   Responsable a ts n (Compiler m)
 219   where
 220   response =
 221     Compiler $
 222       pure $
 223         ( \(mediaType_, MimeType (Proxy :: Proxy t)) ->
 224             Output
 225               { outputPath =
 226                   OutputPath
 227                     { outputPathSegs = []
 228                     , outputPathExts = [decodePathSegment (fileExtension @t)]
 229                     }
 230               , outputType = Last $ Just mediaType_
 231               , outputData = \(CompilerEndpoint Refl (Response ma)) ->
 232                   mimeEncode @_ @t <$> ma
 233               }
 234         )
 235           <$> toList (mimeTypesMap @ts @(MimeEncodable a))
 236
 237 -- ** Type 'Output'
 238
 239 data Output a = Output
 240   { outputPath :: OutputPath
 241   , outputType :: Last MediaType
 242   , outputData :: forall next. (a --> next) -> next
 243   }
 244
 245 outputBuilder :: Output a -> (a --> m BSB.Builder) -> m BSB.Builder
 246 outputBuilder = outputData
 247
 248 outputPathRelative :: Output a -> OutputPath
 249 outputPathRelative out
 250   | List.null (outputPathExts outPath) = outPath{outputPathExts = ["txt"]}
 251   | otherwise = outPath
 252   where
 253     outPath = outputPath out
 254
 255 -- *** Type 'OutputPath'
 256 data OutputPath = OutputPath
 257   { outputPathSegs :: [PathSegment]
 258   , outputPathExts :: [PathSegment]
 259   }
 260   deriving (Eq, Ord, Show)
 261
 262 outputPathFile :: OutputPath -> Sys.FilePath
 263 outputPathFile outPath =
 264   List.intercalate "." $
 265     encodePath (outputPathSegs outPath)
 266       : (Text.unpack . encodePathSegment <$> outputPathExts outPath)
 267
 268 instance Semigroup OutputPath where
 269   x <> y =
 270     OutputPath
 271       { outputPathSegs = outputPathSegs x <> outputPathSegs y
 272       , outputPathExts = outputPathExts x <> outputPathExts y
 273       }
 274 instance Monoid OutputPath where
 275   mempty = OutputPath{outputPathSegs = [], outputPathExts = []}
 276
 277 instance Sym.ProductFunctor Output where
 278   a <.> b =
 279     Output
 280       { outputPath = outputPath a <> outputPath b
 281       , outputType = outputType a <> outputType b
 282       , outputData = outputData b . outputData a
 283       }
 284   a <. b =
 285     Output
 286       { outputPath = outputPath a <> outputPath b
 287       , outputType = outputType a <> outputType b
 288       , outputData = outputData b . outputData a
 289       }
 290   a .> b =
 291     Output
 292       { outputPath = outputPath a <> outputPath b
 293       , outputType = outputType a <> outputType b
 294       , outputData = outputData b . outputData a
 295       }
 296
 297 -- compile :: Show a => Renderable a => Compiler a -> CompilerEnv -> Sys.IO ()
 298 -- compile compiler conf@CompilerEnv{..} = do
 299 --   createDirectoryIfMissing True compilerEnvDest
 300 --   let router = unCompiler compiler
 301 --   when (null router) $
 302 --     error "no router, nothing to compile"
 303 --   -- Sys.hPutStrLn Sys.stderr $ "conf: " <> show conf
 304 --   -- forM_ router $ \comp -> do
 305 --   --   Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
 306 --   forM_ router $ \Comp{..} -> do
 307 --     -- Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
 308 --     let routePath = pathOfPathSegments compPathSegments
 309 --      in case render compData of
 310 --           Left staticPath ->
 311 --             doesPathExist (compilerEnvSource </> staticPath) >>= \case
 312 --               True -> do
 313 --                 -- TODO: In current branch, we don't expect this to be a directory.
 314 --                 -- Although the user may pass it, but review before merge.
 315 --                 Sys.hPutStrLn Sys.stderr $
 316 --                   "staticCopy: "
 317 --                     <> show
 318 --                       ( (compilerEnvSource </> staticPath)
 319 --                       , (compilerEnvDest </> staticPath)
 320 --                       )
 321 --                 copyDirRecursively
 322 --                   staticPath
 323 --                   (compilerEnvSource </> staticPath)
 324 --                   (compilerEnvDest)
 325 --               False -> do
 326 --                 Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource </> staticPath)
 327 --           -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
 328 --           Right bs -> do
 329 --             let outputFullPath = compilerEnvDest </> routePath
 330 --                            {-
 331 --                            maybe (routePath </> compilerEnvIndex)
 332 --                                  (routePath Sys.FilePath.<.>)
 333 --                                  (compType comp)
 334 --                           -}
 335 --             -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory outputFullPath)
 336 --             createDirectoryIfMissing True (Sys.takeDirectory outputFullPath)
 337 --             -- Sys.hPutStrLn Sys.stderr $ "write: " <> show outputFullPath
 338 --             BSL.writeFile outputFullPath bs
 339
 340 copyDirRecursively ::
 341   HasCallStack =>
 342   -- | Source file path relative to CWD
 343   Sys.FilePath ->
 344   -- | Absolute path to source file to copy.
 345   Sys.FilePath ->
 346   -- | Directory *under* which the source file/dir will be copied
 347   Sys.FilePath ->
 348   Sys.IO ()
 349 copyDirRecursively srcRel srcAbs destParent = do
 350   Sys.doesFileExist srcAbs >>= \case
 351     True -> do
 352       Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a file" :: Text, srcAbs)
 353       copyFileCreatingParents srcAbs (destParent Sys.</> srcRel)
 354     False ->
 355       Sys.doesDirectoryExist srcAbs >>= \case
 356         False -> do
 357           Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is neither a file nor directory" :: Text, srcAbs)
 358           return ()
 359         -- throw $ StaticAssetMissing srcAbs
 360         True -> do
 361           Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a directory" :: Text, srcAbs)
 362           Sys.createDirectoryIfMissing True (destParent Sys.</> srcRel)
 363           fs <- Sys.getDirectoryFiles srcAbs ["**"]
 364           forM_ fs $ \fp -> do
 365             let
 366               a = srcAbs Sys.</> fp
 367               b = destParent Sys.</> srcRel Sys.</> fp
 368             copyFileCreatingParents a b
 369   where
 370     copyFileCreatingParents a b = do
 371       Sys.createDirectoryIfMissing True (Sys.takeDirectory b)
 372       Sys.copyFile a b