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 --   optional (Compiler ma) = Compiler $ (\as -> forNothing : (forJust <$> as)) <$> ma
 152 --     --pure Nothing Sym.<|> (Just <$> ma)
 153 --     where
 154 --     forNothing :: Output a -> Output (Maybe a)
 155 --     forNothing o = o{ outputData = fst }
 156 --     forJust :: Output a -> Output (Maybe a)
 157 --     forJust o = o{ outputData = outputData o . snd }
 158
 159 instance
 160   ( Generic a
 161   , Sym.RepOfEoT a
 162   , sem ~ Compiler m
 163   , Sym.IsToF a ~ 'False
 164   , eot ~ Sym.EoT (Sym.ADT a)
 165   , Sym.ToFable eot
 166   , Functor m
 167   ) =>
 168   Dataable a (Compiler m)
 169   where
 170   dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
 171   dataType (Compiler mos) = Compiler ((dataType <$>) <$> mos)
 172 instance
 173   ( Generic a
 174   , Sym.RepOfEoT a
 175   , sem ~ Output
 176   , Sym.IsToF a ~ 'False
 177   , eot ~ Sym.EoT (Sym.ADT a)
 178   , Sym.ToFable eot
 179   ) =>
 180   Dataable a Output
 181   where
 182   dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
 183   dataType o = o{outputData = \k -> (outputData o) $ Sym.tofOffun $ k . Sym.adtOfeot}
 184 instance Applicative m => PathSegmentable (Compiler m) where
 185   pathSegment s =
 186     Compiler $
 187       pure
 188         [ Output
 189             { outputPath =
 190                 OutputPath
 191                   { outputPathSegs = [s]
 192                   , outputPathExts = []
 193                   }
 194             , outputData = id
 195             }
 196         ]
 197 instance
 198   ( Applicative m
 199   , n ~ m
 200   , MimeTypes ts (MimeEncodable a)
 201   ) =>
 202   Responsable a ts n (Compiler m)
 203   where
 204   response =
 205     Compiler $
 206       pure $
 207         ( \(_mediaType, MimeType (Proxy :: Proxy t)) ->
 208             Output
 209               { outputPath =
 210                   OutputPath
 211                     { outputPathSegs = []
 212                     , outputPathExts = [decodePathSegment (fileExtension @t)]
 213                     }
 214               , outputData = \(CompilerEndpoint Refl (Response ma)) ->
 215                   mimeEncode @_ @t <$> ma
 216               }
 217         )
 218           <$> toList (mimeTypesMap @ts @(MimeEncodable a))
 219
 220 -- ** Type 'Output'
 221
 222 data Output a = Output
 223   { outputPath :: OutputPath
 224   , outputData :: forall next. (a --> next) -> next
 225   }
 226
 227 outputBuilder :: Output a -> (a --> m BSB.Builder) -> m BSB.Builder
 228 outputBuilder = outputData
 229
 230 outputPathRelative :: Output a -> OutputPath
 231 outputPathRelative out
 232   | List.null (outputPathExts outPath) = outPath{outputPathExts = ["txt"]}
 233   | otherwise = outPath
 234   where
 235     outPath = outputPath out
 236
 237 -- *** Type 'OutputPath'
 238 data OutputPath = OutputPath
 239   { outputPathSegs :: [PathSegment]
 240   , outputPathExts :: [PathSegment]
 241   }
 242   deriving (Eq, Ord, Show)
 243
 244 outputPathFile :: OutputPath -> Sys.FilePath
 245 outputPathFile outPath =
 246   List.intercalate "." $
 247     encodePath (outputPathSegs outPath)
 248       : (Text.unpack . encodePathSegment <$> outputPathExts outPath)
 249
 250 instance Semigroup OutputPath where
 251   x <> y =
 252     OutputPath
 253       { outputPathSegs = outputPathSegs x <> outputPathSegs y
 254       , outputPathExts = outputPathExts x <> outputPathExts y
 255       }
 256 instance Monoid OutputPath where
 257   mempty = OutputPath{outputPathSegs = [], outputPathExts = []}
 258
 259 instance Sym.ProductFunctor Output where
 260   a <.> b =
 261     Output
 262       { outputPath = outputPath a <> outputPath b
 263       , outputData = outputData b . outputData a
 264       }
 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
 276 -- compile :: Show a => Renderable a => Compiler a -> CompilerEnv -> Sys.IO ()
 277 -- compile compiler conf@CompilerEnv{..} = do
 278 --   createDirectoryIfMissing True compilerEnvDest
 279 --   let router = unCompiler compiler
 280 --   when (null router) $
 281 --     error "no router, nothing to compile"
 282 --   -- Sys.hPutStrLn Sys.stderr $ "conf: " <> show conf
 283 --   -- forM_ router $ \comp -> do
 284 --   --   Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
 285 --   forM_ router $ \Comp{..} -> do
 286 --     -- Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
 287 --     let routePath = pathOfPathSegments compPathSegments
 288 --      in case render compData of
 289 --           Left staticPath ->
 290 --             doesPathExist (compilerEnvSource </> staticPath) >>= \case
 291 --               True -> do
 292 --                 -- TODO: In current branch, we don't expect this to be a directory.
 293 --                 -- Although the user may pass it, but review before merge.
 294 --                 Sys.hPutStrLn Sys.stderr $
 295 --                   "staticCopy: "
 296 --                     <> show
 297 --                       ( (compilerEnvSource </> staticPath)
 298 --                       , (compilerEnvDest </> staticPath)
 299 --                       )
 300 --                 copyDirRecursively
 301 --                   staticPath
 302 --                   (compilerEnvSource </> staticPath)
 303 --                   (compilerEnvDest)
 304 --               False -> do
 305 --                 Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource </> staticPath)
 306 --           -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
 307 --           Right bs -> do
 308 --             let outputFullPath = compilerEnvDest </> routePath
 309 --                            {-
 310 --                            maybe (routePath </> compilerEnvIndex)
 311 --                                  (routePath Sys.FilePath.<.>)
 312 --                                  (compType comp)
 313 --                           -}
 314 --             -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory outputFullPath)
 315 --             createDirectoryIfMissing True (Sys.takeDirectory outputFullPath)
 316 --             -- Sys.hPutStrLn Sys.stderr $ "write: " <> show outputFullPath
 317 --             BSL.writeFile outputFullPath bs
 318
 319 copyDirRecursively ::
 320   HasCallStack =>
 321   -- | Source file path relative to CWD
 322   Sys.FilePath ->
 323   -- | Absolute path to source file to copy.
 324   Sys.FilePath ->
 325   -- | Directory *under* which the source file/dir will be copied
 326   Sys.FilePath ->
 327   Sys.IO ()
 328 copyDirRecursively srcRel srcAbs destParent = do
 329   Sys.doesFileExist srcAbs >>= \case
 330     True -> do
 331       Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a file" :: Text, srcAbs)
 332       copyFileCreatingParents srcAbs (destParent Sys.</> srcRel)
 333     False ->
 334       Sys.doesDirectoryExist srcAbs >>= \case
 335         False -> do
 336           Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is neither a file nor directory" :: Text, srcAbs)
 337           return ()
 338         -- throw $ StaticAssetMissing srcAbs
 339         True -> do
 340           Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a directory" :: Text, srcAbs)
 341           Sys.createDirectoryIfMissing True (destParent Sys.</> srcRel)
 342           fs <- Sys.getDirectoryFiles srcAbs ["**"]
 343           forM_ fs $ \fp -> do
 344             let
 345               a = srcAbs Sys.</> fp
 346               b = destParent Sys.</> srcRel Sys.</> fp
 347             copyFileCreatingParents a b
 348   where
 349     copyFileCreatingParents a b = do
 350       Sys.createDirectoryIfMissing True (Sys.takeDirectory b)
 351       Sys.copyFile a b