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