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