src/Literate/Web/Semantics/Compiler.hs

   1 -- For Output
   2 {-# LANGUAGE DeriveFunctor #-}
   3
   4 module Literate.Web.Semantics.Compiler where
   5
   6 import Control.Applicative (Applicative (..))
   7 import Control.Monad (Monad (..), forM, forM_, join, sequence, (>=>))
   8 import Control.Monad.Classes qualified as MC
   9 import Control.Monad.Trans.Class qualified as MT
  10 import Control.Monad.Trans.Reader qualified as MT
  11 import Data.Bool
  12 import Data.ByteString.Lazy qualified as BSL
  13 import Data.Either (Either (..))
  14 import Data.Eq (Eq (..))
  15 import Data.Foldable (toList)
  16 import Data.Function (const, id, ($), (.))
  17 import Data.Functor (Functor (..), (<$>))
  18 import Data.Kind (Constraint, Type)
  19 import Data.List qualified as List
  20 import Data.Maybe (Maybe (..))
  21 import Data.Ord (Ord (..))
  22 import Data.Proxy (Proxy (..))
  23 import Data.Semigroup (Semigroup (..))
  24 import Data.String (fromString)
  25 import Data.Text (Text)
  26 import Data.Text qualified as Text
  27 import Data.Tuple (curry)
  28 import GHC.Generics (Generic)
  29 import GHC.Stack (HasCallStack)
  30 import Literate.Web.Syntaxes
  31 import Literate.Web.Types.MIME
  32 import Literate.Web.Types.URL
  33 import Symantic qualified as Sym
  34 import System.Directory qualified as Sys
  35 import System.FilePath qualified as Sys
  36 import System.FilePattern.Directory qualified as Sys
  37 import System.IO qualified as Sys
  38 import Text.Show (Show (..))
  39 import Type.Reflection ((:~:) (..))
  40
  41 -- * Type 'Compiler'
  42 newtype Compiler m a = Compiler {unCompiler :: m [Output a]}
  43   deriving (Functor)
  44
  45 compile ::
  46   MC.MonadExec Sys.IO m =>
  47   CompilerEnv ->
  48   Sym.ToFer (Compiler m) a ->
  49   Sym.ToF a (m BSL.ByteString) ->
  50   m ()
  51 compile CompilerEnv{..} router content = do
  52   outputs <- unCompiler $ Sym.tuplesOfFunctions router content
  53   MC.exec @Sys.IO $ Sys.removePathForcibly compilerEnvDest
  54   forM_ outputs $ \Output{..} -> do
  55     let destPath =
  56           ( List.intercalate "." $
  57               encodePath outputPath :
  58               ( if List.null outputExts
  59                   then ["txt"]
  60                   else Text.unpack . encodePathSegment <$> outputExts
  61               )
  62           )
  63     -- hPutStrLn stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
  64     MC.exec @Sys.IO $
  65       Sys.createDirectoryIfMissing True $
  66         compilerEnvDest Sys.</> Sys.takeDirectory destPath
  67     -- hPutStrLn stderr $ "write: " <> show destPath
  68     bsl <- outputData
  69     MC.exec @Sys.IO $
  70       BSL.writeFile (compilerEnvDest Sys.</> destPath) $
  71         bsl
  72
  73 manifest ::
  74   forall m a.
  75   Monad m =>
  76   Sym.ToFer (Compiler m) a ->
  77   Sym.ToF a (m BSL.ByteString) ->
  78   m [Sys.FilePath]
  79 manifest router content = do
  80   outputs <- unCompiler $ Sym.tuplesOfFunctions router content
  81   forM outputs $ \(Output{..} :: Output (m BSL.ByteString)) -> do
  82     let destPath =
  83           ( List.intercalate "." $
  84               encodePath outputPath :
  85               ( if List.null outputExts
  86                   then ["txt"]
  87                   else Text.unpack . encodePathSegment <$> outputExts
  88               )
  89           )
  90     return destPath
  91
  92 instance Applicative m => Applicative (Compiler m) where
  93   pure = Compiler . pure . pure . pure
  94   liftA2 f (Compiler a) (Compiler b) = Compiler (liftA2 (liftA2 (liftA2 f)) a b)
  95 instance Monad m => Monad (Compiler m) where
  96   return = pure
  97   Compiler mloa >>= a2mlob =
  98     Compiler $ do
  99       mloa >>= \loa ->
 100         (join <$>) $
 101           forM loa $ \oa -> do
 102             lob <- unCompiler $ a2mlob $ outputData oa
 103             forM lob $ \ob ->
 104               return
 105                 ob
 106                   { outputPath = outputPath oa <> outputPath ob
 107                   , outputExts = outputExts oa <> outputExts ob
 108                   }
 109 instance Applicative m => Sym.ProductFunctor (Compiler m) where
 110   (<.>) = liftA2 (,)
 111   (<.) = liftA2 const
 112   (.>) = liftA2 (const id)
 113 instance Applicative m => Sym.AlternativeFunctor (Compiler m) where
 114   Compiler a <|> Compiler b = Compiler (liftA2 (<>) a b)
 115 instance Applicative m => Sym.SumFunctor (Compiler m) where
 116   a <+> b = Left <$> a Sym.<|> Right <$> b
 117 instance Applicative m => Sym.Optionable (Compiler m) where
 118   optional ma = pure Nothing Sym.<|> (Just <$> ma)
 119 instance Applicative m => PathSegmentable (Compiler m) where
 120   pathSegment s = Compiler $ pure [Output{outputPath = [s], outputExts = [], outputData = ()}]
 121 instance
 122   ( Show a
 123   , Monad m
 124   , n ~ m
 125   , MimeTypes ts (MimeEncodable a)
 126   ) =>
 127   Responsable a ts n (m BSL.ByteString) (Sym.ToFer (Compiler m))
 128   where
 129   response =
 130     Sym.ToFer
 131       { tuplesOfFunctions = \(Refl, Response ma) ->
 132           Compiler $ do
 133             a <- ma
 134             pure $
 135               ( \(mt, MimeType (Proxy :: Proxy t)) ->
 136                   Output
 137                     { outputPath = []
 138                     , outputExts = [decodePathSegment (fileExtension @t)]
 139                     , outputData = pure $ mimeEncode @_ @t a
 140                     }
 141               )
 142                 <$> toList (mimeTypesMap @ts @(MimeEncodable a))
 143       , eithersOfTuples = Compiler $ pure []
 144       }
 145
 146 -- ** Type 'CompilerEnv'
 147 data CompilerEnv = CompilerEnv
 148   { compilerEnvDest :: Sys.FilePath
 149   , -- , compilerEnvSource :: Sys.FilePath
 150     compilerEnvIndex :: Sys.FilePath
 151     --, compilerEnvModel :: model
 152     -- , compilerEnvPath :: [PathSegment]
 153   }
 154   deriving (Show)
 155
 156 -- ** Type 'Output'
 157 data Output a = Output
 158   { outputPath :: [PathSegment]
 159   , outputExts :: [PathSegment]
 160   , outputData :: a
 161   -- , outputType :: MimeType (MimeEncodable a)
 162   }
 163   deriving (Functor, Show)
 164 instance Applicative Output where
 165   pure a =
 166     Output
 167       { outputPath = []
 168       , outputExts = []
 169       , outputData = a
 170       -- , outputType = mediaType @PlainText
 171       }
 172   oa2b <*> oa =
 173     Output
 174       { outputPath = outputPath oa2b <> outputPath oa
 175       , outputExts = outputExts oa2b <> outputExts oa
 176       , outputData = outputData oa2b (outputData oa)
 177       -- , outputType = outputType f <> outputType x
 178       }
 179
 180 -- -- pathSegments _ss = Compiler $
 181 -- --   MT.ReaderT $ \s ->
 182 -- --     -- TODO: assert Set.member s ss
 183 -- --     lift $
 184 -- --       MT.modify' $ \st ->
 185 -- --         st{compilerStatePath = compilerStatePath st </> Text.unpack (encodePathSegment s)}
 186 --
 187 -- {-
 188 -- instance
 189 --   TypeError (
 190 --     'Text "The instance (Capturable a Compiler)"
 191 --     ':$$: 'Text "is disabled when compiling to a static Web site."
 192 --     ':$$: 'Text "You can use (whenInterpreter @Compiler siteNotUsingCapturable siteUsingCapturable)"
 193 --     ':$$: 'Text "to replace calls to any method of Capturable."
 194 --   ) => Capturable a Compiler where
 195 --   capturePathSegment = undefined
 196 -- instance
 197 --   TypeError (
 198 --     'Text "The instance (Capturable a (Reader model Compiler))"
 199 --     ':$$: 'Text "is disabled when compiling to a static Web site."
 200 --     ':$$: 'Text "You can use (whenInterpreter @(Reader model Compiler) siteNotUsingCapturable siteUsingCapturable)"
 201 --     ':$$: 'Text "to replace calls to any method of Capturable."
 202 --   ) => Capturable a (Reader model Compiler) where
 203 --   capturePathSegment = undefined
 204 -- -}
 205 --
 206 -- -- choosePathSegments _s = Compiler $ MT.ReaderT $ \s -> return $ Endo (List.reverse s <>)
 207 -- {-
 208 -- instance Capturable Compiler where
 209 --   type CapturableConstraint Compiler =
 210 --   capturePathSegment _n = Compiler $ MT.ReaderT $ \s ->
 211 --     lift $ MT.modify' $ \st ->
 212 --       st{compilerStatePath = compilerStatePath st </> Text.unpack (encodePathSegment s)}
 213 -- -}
 214 -- {-
 215 -- instance Copyable Compiler where
 216 --   copy path = Compiler $
 217 --     lift $
 218 --       MT.ReaderT $ \env -> do
 219 --         lift $ do
 220 --           doesPathExist (compilerEnvSource env </> path) >>= \case
 221 --             True -> do
 222 --               Sys.hPutStrLn Sys.stderr $
 223 --                 "staticCopy: "
 224 --                   <> show
 225 --                     ( (compilerEnvSource env </> path)
 226 --                     , (compilerEnvDest env </> path)
 227 --                     )
 228 --               copyDirRecursively
 229 --                 path
 230 --                 (compilerEnvSource env </> path)
 231 --                 (compilerEnvDest env)
 232 --             False -> do
 233 --               Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource env </> path)
 234 -- instance Encodable fmt a => Contentable fmt a Compiler where
 235 --   content = Compiler $
 236 --     MT.ReaderT $ \a -> MT.ReaderT $ \env -> do
 237 --       st <- MT.get
 238 --       let destPath = compilerEnvDest env </> compilerStatePath st
 239 --       lift $ do
 240 --         -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
 241 --         createDirectoryIfMissing True (Sys.takeDirectory destPath)
 242 --         -- Sys.hPutStrLn Sys.stderr $ "write: " <> show destPath
 243 --         BSL.writeFile destPath $ encode @fmt a
 244 -- -}
 245 -- --instance Endable Compiler where
 246 -- --  end = Compiler $ return $ Endo id
 247 --
 248 -- --pathSegments _cs = Compiler $ MT.ReaderT $ \s -> return $ Endo (s :)
 249 -- -- instance Fileable Compiler where
 250 -- --   type FileableConstraint Compiler = Typeable
 251 -- --   static = Compiler $ MT.ReaderT $ \_a ->
 252 -- --     return $ Endo (\x -> x)
 253 --
 254 -- {-
 255 -- -- * The 'Compiler' interpreter
 256 --
 257 -- -- | Create files according to the given model of type 'a'.
 258 -- newtype Compiler a = Compiler
 259 --   { unCompiler :: [Comp a]
 260 --   }
 261 --   deriving (Show, Functor)
 262 --
 263 -- instance Applicative Compiler where
 264 --   pure = Compiler . pure . pure
 265 --   Compiler f <*> Compiler x = Compiler $ (<*>) <$> f <*> x
 266 --
 267 -- -- instance Monad Compiler where
 268 -- --   return = pure
 269 -- --   Compiler x >>= f = Compiler (x >>=)
 270 --
 271 -- compile :: Show a => Renderable a => Compiler a -> CompilerEnv -> Sys.IO ()
 272 -- compile compiler conf@CompilerEnv{..} = do
 273 --   createDirectoryIfMissing True compilerEnvDest
 274 --   let router = unCompiler compiler
 275 --   when (null router) $
 276 --     error "no router, nothing to compile"
 277 --   -- Sys.hPutStrLn Sys.stderr $ "conf: " <> show conf
 278 --   -- forM_ router $ \comp -> do
 279 --   --   Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
 280 --   forM_ router $ \Comp{..} -> do
 281 --     -- Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
 282 --     let routePath = pathOfPathSegments compPathSegments
 283 --      in case render compData of
 284 --           Left staticPath ->
 285 --             doesPathExist (compilerEnvSource </> staticPath) >>= \case
 286 --               True -> do
 287 --                 -- TODO: In current branch, we don't expect this to be a directory.
 288 --                 -- Although the user may pass it, but review before merge.
 289 --                 Sys.hPutStrLn Sys.stderr $
 290 --                   "staticCopy: "
 291 --                     <> show
 292 --                       ( (compilerEnvSource </> staticPath)
 293 --                       , (compilerEnvDest </> staticPath)
 294 --                       )
 295 --                 copyDirRecursively
 296 --                   staticPath
 297 --                   (compilerEnvSource </> staticPath)
 298 --                   (compilerEnvDest)
 299 --               False -> do
 300 --                 Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource </> staticPath)
 301 --           -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
 302 --           Right bs -> do
 303 --             let destPath = compilerEnvDest </> routePath
 304 --                            {-
 305 --                            maybe (routePath </> compilerEnvIndex)
 306 --                                  (routePath Sys.FilePath.<.>)
 307 --                                  (compType comp)
 308 --                           -}
 309 --             -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
 310 --             createDirectoryIfMissing True (Sys.takeDirectory destPath)
 311 --             -- Sys.hPutStrLn Sys.stderr $ "write: " <> show destPath
 312 --             BSL.writeFile destPath bs
 313 --
 314 -- -- ** Class 'Renderable'
 315 -- class Renderable a where
 316 --   render :: a -> Either Sys.FilePath BSL.ByteString
 317 -- instance Renderable () where
 318 --   render () =
 319 --     --Left $ pathOfPathSegments compPathSegments
 320 --     Right BSL.empty
 321 --
 322 -- -- ** Type 'Comp'
 323 -- data Comp a = Comp
 324 --   { compPathSegments :: [PathSegment] -- TODO: Endo? Seq?
 325 --   , compData :: a
 326 --   -- , compType :: MimeType (MimeEncodable a)
 327 --   }
 328 -- deriving instance Eq a => Eq (Comp a)
 329 -- deriving instance Ord a => Ord (Comp a)
 330 -- deriving instance Show a => Show (Comp a)
 331 -- deriving instance Functor Comp
 332 -- instance Applicative Comp where
 333 --   pure compData =
 334 --     Comp
 335 --       { compPathSegments = []
 336 --       , compData
 337 --       -- , compType = mediaType @PlainText
 338 --       }
 339 --   f <*> x =
 340 --     Comp
 341 --       { compPathSegments = compPathSegments f <> compPathSegments x
 342 --       , compData = compData f (compData x)
 343 --       -- , compType = compType f <> compType x
 344 --       }
 345 --
 346 -- instance IsoFunctor Compiler where
 347 --   (<%>) Iso{..} = (a2b <$>)
 348 -- instance ProductFunctor Compiler where
 349 --   (<.>) = liftA2 (,)
 350 --   (<.) = (<*)
 351 --   (.>) = (*>)
 352 -- instance SumFunctor Compiler where
 353 --   x <+> y =
 354 --     Compiler $
 355 --       (<>)
 356 --         ((Left <$>) <$> unCompiler x)
 357 --         ((Right <$>) <$> unCompiler y)
 358 -- instance Optionable Compiler where
 359 --   optional x =
 360 --     Compiler $
 361 --       Comp { compPathSegments = []
 362 --            , compData = Nothing
 363 --            -- , compType = Nothing
 364 --            } :
 365 --       ((Just <$>) <$> unCompiler x)
 366 -- instance PathSegmentable Compiler where
 367 --   pathSegment s = Compiler
 368 --     [
 369 --       Comp
 370 --         { compPathSegments = [s]
 371 --         , compData = ()
 372 --         -- , compType = PlainText
 373 --         }
 374 --     ]
 375 --   pathSegments ss =
 376 --     Compiler $
 377 --       [ Comp{ compPathSegments = [s]
 378 --             , compData = s
 379 --             -- , compType = Nothing
 380 --             }
 381 --       | s <- toList ss
 382 --       ]
 383 -- instance ContentTypeable PlainText () Compiler where
 384 --   contentType =
 385 --     Compiler
 386 --       [ Comp
 387 --           { compPathSegments = []
 388 --           , compData = ()
 389 --           --, compType = mediaType @PlainText
 390 --           }
 391 --       ]
 392 --
 393 -- -- instance Repeatable Compiler where
 394 -- --   many0 (Compiler x) =
 395 -- --     Compiler $
 396 -- --       ((\Comp{} -> Comp [] []) <$> x)
 397 -- --         <> ((\(Comp s a) -> Comp s [a]) <$> x)
 398 -- --         <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
 399 -- --   many1 (Compiler x) =
 400 -- --     Compiler $
 401 -- --       ((\(Comp s a) -> Comp s [a]) <$> x)
 402 -- --         <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
 403 -- -- instance Endable Compiler where
 404 -- --   end = Compiler [Comp [] ()]
 405 -- -- instance Capturable Compiler where
 406 -- --   capturePathSegment n = Compiler $ [Comp [n] n]
 407 -- -- instance Constantable c Compiler where
 408 -- --   constant = pure
 409 -- -}
 410 --
 411 copyDirRecursively ::
 412   ( --MonadIO m,
 413     --MonadUnliftIO m,
 414     --MonadLoggerIO m,
 415     HasCallStack
 416   ) =>
 417   -- | Source file path relative to CWD
 418   Sys.FilePath ->
 419   -- | Absolute path to source file to copy.
 420   Sys.FilePath ->
 421   -- | Directory *under* which the source file/dir will be copied
 422   Sys.FilePath ->
 423   Sys.IO ()
 424 copyDirRecursively srcRel srcAbs destParent = do
 425   Sys.doesFileExist srcAbs >>= \case
 426     True -> do
 427       Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a file", srcAbs)
 428       copyFileCreatingParents srcAbs (destParent Sys.</> srcRel)
 429     False ->
 430       Sys.doesDirectoryExist srcAbs >>= \case
 431         False -> do
 432           Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is neither a file nor directory", srcAbs)
 433           return ()
 434         -- throw $ StaticAssetMissing srcAbs
 435         True -> do
 436           Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a directory", srcAbs)
 437           Sys.createDirectoryIfMissing True (destParent Sys.</> srcRel)
 438           fs <- Sys.getDirectoryFiles srcAbs ["**"]
 439           forM_ fs $ \fp -> do
 440             let a = srcAbs Sys.</> fp
 441                 b = destParent Sys.</> srcRel Sys.</> fp
 442             copyFileCreatingParents a b
 443   where
 444     copyFileCreatingParents a b = do
 445       Sys.createDirectoryIfMissing True (Sys.takeDirectory b)
 446       Sys.copyFile a b