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