src/Literate/Web/Semantics/Compiler.hs

   1 -- For CompilerToF
   2 {-# LANGUAGE AllowAmbiguousTypes #-}
   3 -- For CompilerToF
   4 {-# LANGUAGE ConstraintKinds #-}
   5 -- For Dataable
   6 {-# LANGUAGE InstanceSigs #-}
   7 -- For Output
   8 {-# LANGUAGE RankNTypes #-}
   9 -- For CompilerToF
  10 {-# LANGUAGE UndecidableInstances #-}
  11
  12 module Literate.Web.Semantics.Compiler where
  13
  14 import Control.Applicative (Applicative (..))
  15 import Control.Monad (Monad (..), forM_)
  16 import Control.Monad.Classes qualified as MC
  17 import Data.Bool
  18 import Data.ByteString.Lazy qualified as BSL
  19 import Data.Either (Either (..))
  20 import Data.Foldable (toList)
  21 import Data.Function (id, ($), (.))
  22 import Data.Functor (Functor (..), (<$>))
  23 import Data.List qualified as List
  24 import Data.Maybe (Maybe (..))
  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 Literate.Web.Syntaxes
  33 import Literate.Web.Types.MIME
  34 import Literate.Web.Types.URL
  35 import Symantic qualified as Sym
  36 import System.Directory qualified as Sys
  37 import System.FilePath qualified as Sys
  38 import System.FilePattern.Directory qualified as Sys
  39 import System.IO qualified as Sys
  40 import Text.Show (Show (..))
  41 import Type.Reflection ((:~:) (..))
  42
  43 -- * Type 'Compiler'
  44
  45 -- | Interpreter building a static Web site.
  46 --
  47 -- Embed a 'Monad' @m@ to give access to a model if need be.
  48 newtype Compiler m a = Compiler {unCompiler :: m [Output a]}
  49
  50 type instance Sym.ToFEndpoint (Compiler m) a next = (next :~: m BSL.ByteString, a)
  51
  52 contentEndpoint :: a -> Sym.ToFEndpoint (Compiler m) a (m BSL.ByteString)
  53 contentEndpoint = (Refl,)
  54
  55 compile ::
  56   (MC.MonadExec Sys.IO m) =>
  57   CompilerEnv ->
  58   Compiler m a ->
  59   (a --> m BSL.ByteString) ->
  60   m ()
  61 compile CompilerEnv{..} router content = do
  62   outputs <- unCompiler router
  63   MC.exec @Sys.IO $ Sys.removePathForcibly compilerEnvDest
  64   forM_ outputs $ \Output{..} -> do
  65     let destPath =
  66           ( List.intercalate "." $
  67               encodePath outputPath
  68                 : ( if List.null outputExts
  69                       then ["txt"]
  70                       else Text.unpack . encodePathSegment <$> outputExts
  71                   )
  72           )
  73     -- hPutStrLn stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
  74     MC.exec @Sys.IO $
  75       Sys.createDirectoryIfMissing True $
  76         compilerEnvDest Sys.</> Sys.takeDirectory destPath
  77     -- hPutStrLn stderr $ "write: " <> show destPath
  78     bsl <- outputData content
  79     MC.exec @Sys.IO $
  80       BSL.writeFile (compilerEnvDest Sys.</> destPath) $
  81         bsl
  82
  83 outputBSL :: Output a -> (a --> m BSL.ByteString) -> m BSL.ByteString
  84 outputBSL = outputData
  85
  86 compiler :: Compiler m (m BSL.ByteString) -> Compiler m (m BSL.ByteString)
  87 compiler = id
  88
  89 -- compile2 ::
  90 --   MC.MonadExec Sys.IO m =>
  91 --   CompilerEnv ->
  92 --   Compiler m (m BSL.ByteString) ->
  93 --   m ()
  94 -- compile2 CompilerEnv{..} router = do
  95 --   outputs <- unCompiler router
  96 --   MC.exec @Sys.IO $ Sys.removePathForcibly compilerEnvDest
  97 --   -- FIXME: use pipes
  98 --   forM_ outputs $ \Output{..} -> do
  99 --     let destPath =
 100 --           ( List.intercalate "." $
 101 --               encodePath outputPath :
 102 --               ( if List.null outputExts
 103 --                   then ["txt"]
 104 --                   else Text.unpack . encodePathSegment <$> outputExts
 105 --               )
 106 --           )
 107 --     -- hPutStrLn stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
 108 --     MC.exec @Sys.IO $
 109 --       Sys.createDirectoryIfMissing True $
 110 --         compilerEnvDest Sys.</> Sys.takeDirectory destPath
 111 --     -- hPutStrLn stderr $ "write: " <> show destPath
 112 --     outputBSL <- outputData content
 113 --     MC.exec @Sys.IO $
 114 --       BSL.writeFile (compilerEnvDest Sys.</> destPath) $
 115 --         outputBSL
 116
 117 manifest :: forall m a. (Monad m) => Compiler m a -> m [Sys.FilePath]
 118 manifest router = do
 119   outputs <- unCompiler router
 120   return
 121     [ destPath
 122     | out <- outputs
 123     , let destPath =
 124             ( List.intercalate "." $
 125                 encodePath (outputPath out)
 126                   : ( if List.null (outputExts out)
 127                         then ["txt"]
 128                         else Text.unpack . encodePathSegment <$> outputExts out
 129                     )
 130             )
 131     ]
 132
 133 -- instance Applicative m => Applicative (Compiler m) where
 134 --   pure = Compiler . pure . pure . pure
 135 --   liftA2 f (Compiler a) (Compiler b) = Compiler (liftA2 (liftA2 (liftA2 f)) a b)
 136 -- instance Monad m => Monad (Compiler m) where
 137 --   return = pure
 138 --   Compiler mloa >>= a2mlob =
 139 --     Compiler $ do
 140 --       mloa >>= \loa ->
 141 --         (join <$>) $
 142 --           forM loa $ \oa -> do
 143 --             lob <- unCompiler $ a2mlob $ outputData oa
 144 --             forM lob $ \ob ->
 145 --               return
 146 --                 ob
 147 --                   { outputPath = outputPath oa <> outputPath ob
 148 --                   , outputExts = outputExts oa <> outputExts ob
 149 --                   }
 150 instance (Applicative m) => Sym.ProductFunctor (Compiler m) where
 151   Compiler a <.> Compiler b = Compiler $ liftA2 (liftA2 (<.>)) a b
 152   Compiler a <. Compiler b = Compiler $ liftA2 (liftA2 (<.)) a b
 153   Compiler a .> Compiler b = Compiler $ liftA2 (liftA2 (.>)) a b
 154
 155 -- instance Applicative m => Sym.AlternativeFunctor (Compiler m) where
 156 --  Compiler a <|> Compiler b = Compiler (liftA2 (<>) a b)
 157 instance (Applicative m) => Sym.SumFunctor (Compiler m) where
 158   Compiler a <+> Compiler b = Compiler $ liftA2 (\as bs -> (a2e <$> as) <> (b2e <$> bs)) a b
 159     where
 160       a2e :: Output a -> Output (Either a b)
 161       a2e o = o{outputData = outputData o . fst}
 162       b2e :: Output b -> Output (Either a b)
 163       b2e o = o{outputData = outputData o . snd}
 164
 165 instance (Applicative m, Sym.ToFable a) => Optionable a (Compiler m) where
 166   optional (Compiler ma) = Compiler $ (\as -> (a2n <$> as) <> (a2j <$> as)) <$> ma
 167     where
 168       a2n :: Output a -> Output (Maybe a)
 169       a2n o = o{outputData = ($ Nothing)}
 170       a2j :: Output a -> Output (Maybe a)
 171       a2j o = o{outputData = \k -> outputData o $ Sym.tofOffun $ k . Just}
 172
 173 --   optional (Compiler ma) = Compiler $ (\as -> (a2n <$> as) <> (a2j <$> as)) <$> ma
 174 --     --pure Nothing Sym.<|> (Just <$> ma)
 175 --     where
 176 --     a2n :: Output a -> Output (Maybe a)
 177 --     a2n o = o{ outputData = fst }
 178 --     a2j :: Output a -> Output (Maybe a)
 179 --     a2j o = o{ outputData = outputData o . snd }
 180 --
 181
 182 instance
 183   ( Generic a
 184   , Sym.RepOfEoT a
 185   , sem ~ Compiler m
 186   , Sym.IsToF a ~ 'False
 187   , eot ~ Sym.EoT (Sym.ADT a)
 188   , Sym.ToFable eot
 189   , Functor m
 190   ) =>
 191   Dataable a (Compiler m)
 192   where
 193   dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
 194   dataType (Compiler mos) = Compiler ((dataType <$>) <$> mos)
 195 instance
 196   ( Generic a
 197   , Sym.RepOfEoT a
 198   , sem ~ Output
 199   , Sym.IsToF a ~ 'False
 200   , eot ~ Sym.EoT (Sym.ADT a)
 201   , Sym.ToFable eot
 202   ) =>
 203   Dataable a Output
 204   where
 205   dataType :: sem (Sym.EoT (Sym.ADT a)) -> sem a
 206   dataType o = o{outputData = \k -> (outputData o) $ Sym.tofOffun $ k . Sym.adtOfeot}
 207 instance (Applicative m) => PathSegmentable (Compiler m) where
 208   pathSegment s =
 209     Compiler $
 210       pure
 211         [ Output
 212             { outputPath = [s]
 213             , outputExts = []
 214             , outputData = id
 215             }
 216         ]
 217 instance
 218   ( Applicative m
 219   , n ~ m
 220   , MimeTypes ts (MimeEncodable a)
 221   ) =>
 222   Responsable a ts n (Compiler m)
 223   where
 224   response =
 225     Compiler $
 226       pure $
 227         ( \(_mediaType, MimeType (Proxy :: Proxy t)) ->
 228             Output
 229               { outputPath = []
 230               , outputExts = [decodePathSegment (fileExtension @t)]
 231               , outputData = \(Refl, Response ma) -> mimeEncode @_ @t <$> ma
 232               }
 233         )
 234           <$> toList (mimeTypesMap @ts @(MimeEncodable a))
 235
 236 -- ** Type 'CompilerEnv'
 237 data CompilerEnv = CompilerEnv
 238   { compilerEnvDest :: Sys.FilePath
 239   , -- , compilerEnvSource :: Sys.FilePath
 240     compilerEnvIndex :: Sys.FilePath
 241     -- , compilerEnvModel :: model
 242     -- , compilerEnvPath :: [PathSegment]
 243   }
 244   deriving (Show)
 245
 246 -- ** Type 'Output'
 247
 248 -- TODO: use Seq instead of []
 249 data Output a = Output
 250   { outputPath :: [PathSegment]
 251   , outputExts :: [PathSegment]
 252   , outputData :: forall next. (a --> next) -> next
 253   }
 254 instance Sym.ProductFunctor Output where
 255   a <.> b =
 256     Output
 257       { outputPath = outputPath a <> outputPath b
 258       , outputExts = outputExts a <> outputExts b
 259       , outputData = outputData b . outputData a
 260       }
 261   a <. b =
 262     Output
 263       { outputPath = outputPath a <> outputPath b
 264       , outputExts = outputExts a <> outputExts b
 265       , outputData = outputData b . outputData a
 266       }
 267   a .> b =
 268     Output
 269       { outputPath = outputPath a <> outputPath b
 270       , outputExts = outputExts a <> outputExts b
 271       , outputData = outputData b . outputData a
 272       }
 273
 274 -- compile :: Show a => Renderable a => Compiler a -> CompilerEnv -> Sys.IO ()
 275 -- compile compiler conf@CompilerEnv{..} = do
 276 --   createDirectoryIfMissing True compilerEnvDest
 277 --   let router = unCompiler compiler
 278 --   when (null router) $
 279 --     error "no router, nothing to compile"
 280 --   -- Sys.hPutStrLn Sys.stderr $ "conf: " <> show conf
 281 --   -- forM_ router $ \comp -> do
 282 --   --   Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
 283 --   forM_ router $ \Comp{..} -> do
 284 --     -- Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
 285 --     let routePath = pathOfPathSegments compPathSegments
 286 --      in case render compData of
 287 --           Left staticPath ->
 288 --             doesPathExist (compilerEnvSource </> staticPath) >>= \case
 289 --               True -> do
 290 --                 -- TODO: In current branch, we don't expect this to be a directory.
 291 --                 -- Although the user may pass it, but review before merge.
 292 --                 Sys.hPutStrLn Sys.stderr $
 293 --                   "staticCopy: "
 294 --                     <> show
 295 --                       ( (compilerEnvSource </> staticPath)
 296 --                       , (compilerEnvDest </> staticPath)
 297 --                       )
 298 --                 copyDirRecursively
 299 --                   staticPath
 300 --                   (compilerEnvSource </> staticPath)
 301 --                   (compilerEnvDest)
 302 --               False -> do
 303 --                 Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource </> staticPath)
 304 --           -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
 305 --           Right bs -> do
 306 --             let destPath = compilerEnvDest </> routePath
 307 --                            {-
 308 --                            maybe (routePath </> compilerEnvIndex)
 309 --                                  (routePath Sys.FilePath.<.>)
 310 --                                  (compType comp)
 311 --                           -}
 312 --             -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
 313 --             createDirectoryIfMissing True (Sys.takeDirectory destPath)
 314 --             -- Sys.hPutStrLn Sys.stderr $ "write: " <> show destPath
 315 --             BSL.writeFile destPath bs
 316
 317 copyDirRecursively ::
 318   (HasCallStack) =>
 319   -- | Source file path relative to CWD
 320   Sys.FilePath ->
 321   -- | Absolute path to source file to copy.
 322   Sys.FilePath ->
 323   -- | Directory *under* which the source file/dir will be copied
 324   Sys.FilePath ->
 325   Sys.IO ()
 326 copyDirRecursively srcRel srcAbs destParent = do
 327   Sys.doesFileExist srcAbs >>= \case
 328     True -> do
 329       Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a file" :: Text, srcAbs)
 330       copyFileCreatingParents srcAbs (destParent Sys.</> srcRel)
 331     False ->
 332       Sys.doesDirectoryExist srcAbs >>= \case
 333         False -> do
 334           Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is neither a file nor directory" :: Text, srcAbs)
 335           return ()
 336         -- throw $ StaticAssetMissing srcAbs
 337         True -> do
 338           Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a directory" :: Text, srcAbs)
 339           Sys.createDirectoryIfMissing True (destParent Sys.</> srcRel)
 340           fs <- Sys.getDirectoryFiles srcAbs ["**"]
 341           forM_ fs $ \fp -> do
 342             let 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