-- For CompilerToF
{-# LANGUAGE ConstraintKinds #-}
-- For Output
{-# LANGUAGE DeriveFunctor #-}
-- For CompilerToF
{-# LANGUAGE UndecidableInstances #-}
-- For CompilerToF
{-# LANGUAGE AllowAmbiguousTypes #-}
-- For Output
{-# LANGUAGE RankNTypes #-}
-- For Dataable__
{-# LANGUAGE InstanceSigs #-}

module Literate.Web.Semantics.Compiler where

import Control.Applicative (Applicative (..))
import Control.Monad (Monad (..), forM, forM_, join, sequence, (>=>))
import Control.Monad.Classes qualified as MC
import Control.Monad.Trans.Class qualified as MT
import Control.Monad.Trans.Reader qualified as MT
import Data.Bool
import Data.ByteString.Lazy qualified as BSL
import Data.Either (Either (..))
import Data.Eq (Eq (..))
import Data.Foldable (toList)
import Data.Function (const, id, ($), (.))
import Data.Functor (Functor (..), (<$>))
import Data.Kind (Constraint, Type)
import Data.List qualified as List
import Data.Maybe (Maybe (..))
import Data.Ord (Ord (..))
import Data.Proxy (Proxy (..))
import Data.Semigroup (Semigroup (..))
import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Tuple (curry, fst, snd)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Literate.Web.Syntaxes
import Literate.Web.Types.MIME
import Literate.Web.Types.URL
import Symantic qualified as Sym
import System.Directory qualified as Sys
import System.FilePath qualified as Sys
import System.FilePattern.Directory qualified as Sys
import System.IO qualified as Sys
import Text.Show (Show (..))
import Type.Reflection ((:~:) (..))
import Prelude (undefined)

-- * Type 'Compiler'
newtype Compiler m a = Compiler {unCompiler :: {-FIXME: is m required?-}m [Output a]}
  -- deriving (Functor)

compile ::
  MC.MonadExec Sys.IO m =>
  CompilerEnv ->
  Compiler m a ->
  CompilerToF a (m BSL.ByteString) ->
  m ()
compile CompilerEnv{..} router content = do
  outputs <- unCompiler router
  MC.exec @Sys.IO $ Sys.removePathForcibly compilerEnvDest
  forM_ outputs $ \Output{..} -> do
    let destPath =
          ( List.intercalate "." $
              encodePath outputPath :
              ( if List.null outputExts
                  then ["txt"]
                  else Text.unpack . encodePathSegment <$> outputExts
              )
          )
    -- hPutStrLn stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
    MC.exec @Sys.IO $
      Sys.createDirectoryIfMissing True $
        compilerEnvDest Sys.</> Sys.takeDirectory destPath
    -- hPutStrLn stderr $ "write: " <> show destPath
    bsl <- outputData content
    MC.exec @Sys.IO $
      BSL.writeFile (compilerEnvDest Sys.</> destPath) $
        bsl


compi :: Compiler m (m BSL.ByteString) -> Compiler m (m BSL.ByteString)
compi = id

-- compile2 ::
--   MC.MonadExec Sys.IO m =>
--   CompilerEnv ->
--   Compiler m (m BSL.ByteString) ->
--   m ()
-- compile2 CompilerEnv{..} router = do
--   outputs <- unCompiler router
--   MC.exec @Sys.IO $ Sys.removePathForcibly compilerEnvDest
--   -- FIXME: use pipes
--   forM_ outputs $ \Output{..} -> do
--     let destPath =
--           ( List.intercalate "." $
--               encodePath outputPath :
--               ( if List.null outputExts
--                   then ["txt"]
--                   else Text.unpack . encodePathSegment <$> outputExts
--               )
--           )
--     -- hPutStrLn stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
--     MC.exec @Sys.IO $
--       Sys.createDirectoryIfMissing True $
--         compilerEnvDest Sys.</> Sys.takeDirectory destPath
--     -- hPutStrLn stderr $ "write: " <> show destPath
--     outputBSL <- outputData content
--     MC.exec @Sys.IO $
--       BSL.writeFile (compilerEnvDest Sys.</> destPath) $
--         outputBSL

manifest :: forall m a. Monad m => Compiler m a -> m [Sys.FilePath]
manifest router = do
  outputs <- unCompiler router
  return
    [ destPath
    | out <- outputs
    , let destPath =
            ( List.intercalate "." $
                encodePath (outputPath out) :
                ( if List.null (outputExts out)
                    then ["txt"]
                    else Text.unpack . encodePathSegment <$> outputExts out
                )
            )
    ]

-- instance Applicative m => Applicative (Compiler m) where
--   pure = Compiler . pure . pure . pure
--   liftA2 f (Compiler a) (Compiler b) = Compiler (liftA2 (liftA2 (liftA2 f)) a b)
-- instance Monad m => Monad (Compiler m) where
--   return = pure
--   Compiler mloa >>= a2mlob =
--     Compiler $ do
--       mloa >>= \loa ->
--         (join <$>) $
--           forM loa $ \oa -> do
--             lob <- unCompiler $ a2mlob $ outputData oa
--             forM lob $ \ob ->
--               return
--                 ob
--                   { outputPath = outputPath oa <> outputPath ob
--                   , outputExts = outputExts oa <> outputExts ob
--                   }
instance Applicative m => Sym.ProductFunctor (Compiler m) where
  Compiler a <.> Compiler b = Compiler $ liftA2 (liftA2 (<.>)) a b
  Compiler a <. Compiler b = Compiler $ liftA2 (liftA2 (<.)) a b
  Compiler a .> Compiler b = Compiler $ liftA2 (liftA2 (.>)) a b
--instance Applicative m => Sym.AlternativeFunctor (Compiler m) where
--  Compiler a <|> Compiler b = Compiler (liftA2 (<>) a b)
instance Applicative m => Sym.SumFunctor (Compiler m) where
  Compiler a <+> Compiler b = Compiler $ liftA2 (\as bs -> (a2e <$> as) <> (b2e <$> bs)) a b
    where
    a2e :: Output a -> Output (Either a b)
    a2e o = o{ outputData = outputData o . fst }
    b2e :: Output b -> Output (Either a b)
    b2e o = o{ outputData = outputData o . snd }

instance (Applicative m, CompilerUnToF a) => Optionable a (Compiler m) where
  optional (Compiler ma) = Compiler $ (\as -> (a2n <$> as) <> (a2j <$> as)) <$> ma
    where
    a2n :: Output a -> Output (Maybe a)
    a2n o = o{ outputData = ($ Nothing) }
    a2j :: Output a -> Output (Maybe a)
    a2j o = o{ outputData = \k -> outputData o $ compilerUnToF @(CompilerIsToF a) $ k . Just }
--   optional (Compiler ma) = Compiler $ (\as -> (a2n <$> as) <> (a2j <$> as)) <$> ma
--     --pure Nothing Sym.<|> (Just <$> ma)
--     where
--     a2n :: Output a -> Output (Maybe a)
--     a2n o = o{ outputData = fst }
--     a2j :: Output a -> Output (Maybe a)
--     a2j o = o{ outputData = outputData o . snd }
--
-- ** Class 'CompilerUnToF'
type CompilerUnToF a = CompilerUnToFIf (CompilerIsToF a) a
class CompilerUnToFIf (t :: Bool) a where
  compilerUnToF :: (a -> next) -> CompilerToFIf t a next
instance CompilerUnToFIf 'True () where
  compilerUnToF = ($ ())
instance (CompilerUnToF a, CompilerUnToF b) => CompilerUnToFIf 'True (a, b) where
  compilerUnToF ab2n = compilerUnToF @(CompilerIsToF a) $ \a -> compilerUnToF @(CompilerIsToF b) $ \b -> ab2n (a,b)
instance (CompilerUnToF a, CompilerUnToF b) => CompilerUnToFIf 'True (Either a b) where
  compilerUnToF e2n = ( compilerUnToF @(CompilerIsToF a) $ e2n . Left
                      , compilerUnToF @(CompilerIsToF b) $ e2n . Right
                      )
instance CompilerUnToFIf 'False a where
  compilerUnToF = id

instance
  ( Generic a
  , Sym.RepOfEoT a
  , sem ~ Compiler m
  , CompilerIsToF a ~ 'False
  , e ~ Sym.EoT (Sym.ADT a)
  , CompilerUnToF e
  , Functor m
  ) => Dataable__ a (Compiler m) where
  data__ :: sem (Sym.EoT (Sym.ADT a)) -> sem a
  data__ (Compiler e) = Compiler ((data__ <$>) <$> e)
instance
  ( Generic a
  --, Sym.EoTOfRep a
  , Sym.RepOfEoT a
  , sem ~ Output
  , CompilerIsToF a ~ 'False
  --, CompilerIsToF eot ~ 'False
  , eot ~ Sym.EoT (Sym.ADT a)
  , CompilerUnToF eot
  ) => Dataable__ a Output where
  data__ :: sem (Sym.EoT (Sym.ADT a)) -> sem a
  data__ o = o { outputData = \k -> (outputData o) $ compilerUnToF @(CompilerIsToF eot) $ k . Sym.adtOfeot }
instance Applicative m => PathSegmentable (Compiler m) where
  pathSegment s = Compiler $ pure
    [
      Output
        { outputPath = [s]
        , outputExts = []
        , outputData = id
        }
    ]
instance
  ( Show a
  , Monad m
  , n ~ m
  , end ~ m BSL.ByteString
  , MimeTypes ts (MimeEncodable a)
  ) =>
  Responsable a ts n end (Compiler m)
  where
  response = Compiler $ pure $
    ( \(_mediaType, MimeType (Proxy :: Proxy t)) ->
        Output
          { outputPath = []
          , outputExts = [decodePathSegment (fileExtension @t)]
          , outputData = \(Refl, Response ma) -> do
              a <- ma
              pure $ mimeEncode @_ @t a
          }
    )
      <$> toList (mimeTypesMap @ts @(MimeEncodable a))

-- ** Type 'CompilerEnv'
data CompilerEnv = CompilerEnv
  { compilerEnvDest :: Sys.FilePath
  , -- , compilerEnvSource :: Sys.FilePath
    compilerEnvIndex :: Sys.FilePath
    --, compilerEnvModel :: model
    -- , compilerEnvPath :: [PathSegment]
  }
  deriving (Show)

-- ** Type 'Output'
-- TODO: use Seq instead of []
data Output a = Output
  { outputPath :: [PathSegment]
  , outputExts :: [PathSegment]
  , outputData :: forall next. CompilerToF a next -> next
  --, outputBSL :: BSL.ByteString
  -- , outputType :: MimeType (MimeEncodable a)
  }

-- instance Sym.SumFunctor Output where
--   a <+> b = Output
--     { outputPath = outputPath a <> outputPath b
--     , outputExts = outputExts a <> outputExts b
--     , outputData = \(a2n, b2n) -> outputData a a2n
--     }
instance Sym.ProductFunctor Output where
  a <.> b = Output
    { outputPath = outputPath a <> outputPath b
    , outputExts = outputExts a <> outputExts b
    , outputData = outputData b . outputData a
    }
  a <. b = Output
    { outputPath = outputPath a <> outputPath b
    , outputExts = outputExts a <> outputExts b
    , outputData = outputData b . outputData a
    }
  a .> b = Output
    { outputPath = outputPath a <> outputPath b
    , outputExts = outputExts a <> outputExts b
    , outputData = outputData b . outputData a
    }
--   deriving (Functor, Show)
-- instance Applicative Output where
--   pure a =
--     Output
--       { outputPath = []
--       , outputExts = []
--       , outputData = a
--       --, outputBSL = ""
--       -- , outputType = mediaType @PlainText
--       }
--   oa2b <*> oa =
--     Output
--       { outputPath = outputPath oa2b <> outputPath oa
--       , outputExts = outputExts oa2b <> outputExts oa
--       , outputData = outputData oa2b (outputData oa)
--       --, outputBSL = outputBSL oa2b <> outputBSL oa
--       }


-- * Type family 'CompilerToF'
type CompilerToF a next = CompilerToFIf (CompilerIsToF a) a next
type family CompilerToFIf t a next :: Type where
-- For '<.>': curry.
  CompilerToFIf 'True (a, b) next = CompilerToF a (CompilerToF b next)
-- For '<+>', request both branches.
  CompilerToFIf 'True (Either l r) next = (CompilerToF l next, CompilerToF r next)
  --CompilerToFIf 'True (Maybe a) next = (CompilerToF () next, CompilerToF a next)
-- Useless to ask '()' as argument.
  CompilerToFIf 'True () next = next
-- Enable a different return value for each function.
  CompilerToFIf 'True (Sym.Endpoint end a) next = (next :~: end, a)
-- Everything else becomes a new argument.
  CompilerToFIf 'False a next = a -> next


-- | This 'Bool' is added to 'ToFIf' to avoid overlapping instances.
type family CompilerIsToF a :: Bool where
  CompilerIsToF () = 'True
  CompilerIsToF (a, b) = 'True
  CompilerIsToF (Either l r) = 'True
  --CompilerIsToF (Maybe a) = 'True
  CompilerIsToF (Sym.Endpoint end a) = 'True
  CompilerIsToF a = 'False


-- -- pathSegments _ss = Compiler $
-- --   MT.ReaderT $ \s ->
-- --     -- TODO: assert Set.member s ss
-- --     lift $
-- --       MT.modify' $ \st ->
-- --         st{compilerStatePath = compilerStatePath st </> Text.unpack (encodePathSegment s)}
--
-- {-
-- instance
--   TypeError (
--     'Text "The instance (Capturable a Compiler)"
--     ':$$: 'Text "is disabled when compiling to a static Web site."
--     ':$$: 'Text "You can use (whenInterpreter @Compiler siteNotUsingCapturable siteUsingCapturable)"
--     ':$$: 'Text "to replace calls to any method of Capturable."
--   ) => Capturable a Compiler where
--   capturePathSegment = undefined
-- instance
--   TypeError (
--     'Text "The instance (Capturable a (Reader model Compiler))"
--     ':$$: 'Text "is disabled when compiling to a static Web site."
--     ':$$: 'Text "You can use (whenInterpreter @(Reader model Compiler) siteNotUsingCapturable siteUsingCapturable)"
--     ':$$: 'Text "to replace calls to any method of Capturable."
--   ) => Capturable a (Reader model Compiler) where
--   capturePathSegment = undefined
-- -}
--
-- -- choosePathSegments _s = Compiler $ MT.ReaderT $ \s -> return $ Endo (List.reverse s <>)
-- {-
-- instance Capturable Compiler where
--   type CapturableConstraint Compiler =
--   capturePathSegment _n = Compiler $ MT.ReaderT $ \s ->
--     lift $ MT.modify' $ \st ->
--       st{compilerStatePath = compilerStatePath st </> Text.unpack (encodePathSegment s)}
-- -}
-- {-
-- instance Copyable Compiler where
--   copy path = Compiler $
--     lift $
--       MT.ReaderT $ \env -> do
--         lift $ do
--           doesPathExist (compilerEnvSource env </> path) >>= \case
--             True -> do
--               Sys.hPutStrLn Sys.stderr $
--                 "staticCopy: "
--                   <> show
--                     ( (compilerEnvSource env </> path)
--                     , (compilerEnvDest env </> path)
--                     )
--               copyDirRecursively
--                 path
--                 (compilerEnvSource env </> path)
--                 (compilerEnvDest env)
--             False -> do
--               Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource env </> path)
-- instance Encodable fmt a => Contentable fmt a Compiler where
--   content = Compiler $
--     MT.ReaderT $ \a -> MT.ReaderT $ \env -> do
--       st <- MT.get
--       let destPath = compilerEnvDest env </> compilerStatePath st
--       lift $ do
--         -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
--         createDirectoryIfMissing True (Sys.takeDirectory destPath)
--         -- Sys.hPutStrLn Sys.stderr $ "write: " <> show destPath
--         BSL.writeFile destPath $ encode @fmt a
-- -}
-- --instance Endable Compiler where
-- --  end = Compiler $ return $ Endo id
--
-- --pathSegments _cs = Compiler $ MT.ReaderT $ \s -> return $ Endo (s :)
-- -- instance Fileable Compiler where
-- --   type FileableConstraint Compiler = Typeable
-- --   static = Compiler $ MT.ReaderT $ \_a ->
-- --     return $ Endo (\x -> x)
--
-- {-
-- -- * The 'Compiler' interpreter
--
-- -- | Create files according to the given model of type 'a'.
-- newtype Compiler a = Compiler
--   { unCompiler :: [Comp a]
--   }
--   deriving (Show, Functor)
--
-- instance Applicative Compiler where
--   pure = Compiler . pure . pure
--   Compiler f <*> Compiler x = Compiler $ (<*>) <$> f <*> x
--
-- -- instance Monad Compiler where
-- --   return = pure
-- --   Compiler x >>= f = Compiler (x >>=)
--
-- compile :: Show a => Renderable a => Compiler a -> CompilerEnv -> Sys.IO ()
-- compile compiler conf@CompilerEnv{..} = do
--   createDirectoryIfMissing True compilerEnvDest
--   let router = unCompiler compiler
--   when (null router) $
--     error "no router, nothing to compile"
--   -- Sys.hPutStrLn Sys.stderr $ "conf: " <> show conf
--   -- forM_ router $ \comp -> do
--   --   Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
--   forM_ router $ \Comp{..} -> do
--     -- Sys.hPutStrLn Sys.stderr $ "route: " <> show comp
--     let routePath = pathOfPathSegments compPathSegments
--      in case render compData of
--           Left staticPath ->
--             doesPathExist (compilerEnvSource </> staticPath) >>= \case
--               True -> do
--                 -- TODO: In current branch, we don't expect this to be a directory.
--                 -- Although the user may pass it, but review before merge.
--                 Sys.hPutStrLn Sys.stderr $
--                   "staticCopy: "
--                     <> show
--                       ( (compilerEnvSource </> staticPath)
--                       , (compilerEnvDest </> staticPath)
--                       )
--                 copyDirRecursively
--                   staticPath
--                   (compilerEnvSource </> staticPath)
--                   (compilerEnvDest)
--               False -> do
--                 Sys.hPutStrLn Sys.stderr $ "error: path does not exist: " <> (compilerEnvSource </> staticPath)
--           -- log LevelWarn $ toText $ "? " <> staticPath <> " (missing)"
--           Right bs -> do
--             let destPath = compilerEnvDest </> routePath
--                            {-
--                            maybe (routePath </> compilerEnvIndex)
--                                  (routePath Sys.FilePath.<.>)
--                                  (compType comp)
--                           -}
--             -- Sys.hPutStrLn Sys.stderr $ "mkdir: " <> show (Sys.takeDirectory destPath)
--             createDirectoryIfMissing True (Sys.takeDirectory destPath)
--             -- Sys.hPutStrLn Sys.stderr $ "write: " <> show destPath
--             BSL.writeFile destPath bs
--
-- -- ** Class 'Renderable'
-- class Renderable a where
--   render :: a -> Either Sys.FilePath BSL.ByteString
-- instance Renderable () where
--   render () =
--     --Left $ pathOfPathSegments compPathSegments
--     Right BSL.empty
--
-- -- ** Type 'Comp'
-- data Comp a = Comp
--   { compPathSegments :: [PathSegment] -- TODO: Endo? Seq?
--   , compData :: a
--   -- , compType :: MimeType (MimeEncodable a)
--   }
-- deriving instance Eq a => Eq (Comp a)
-- deriving instance Ord a => Ord (Comp a)
-- deriving instance Show a => Show (Comp a)
-- deriving instance Functor Comp
-- instance Applicative Comp where
--   pure compData =
--     Comp
--       { compPathSegments = []
--       , compData
--       -- , compType = mediaType @PlainText
--       }
--   f <*> x =
--     Comp
--       { compPathSegments = compPathSegments f <> compPathSegments x
--       , compData = compData f (compData x)
--       -- , compType = compType f <> compType x
--       }
--
-- instance IsoFunctor Compiler where
--   (<%>) Iso{..} = (a2b <$>)
-- instance ProductFunctor Compiler where
--   (<.>) = liftA2 (,)
--   (<.) = (<*)
--   (.>) = (*>)
-- instance SumFunctor Compiler where
--   x <+> y =
--     Compiler $
--       (<>)
--         ((Left <$>) <$> unCompiler x)
--         ((Right <$>) <$> unCompiler y)
-- instance Optionable Compiler where
--   optional x =
--     Compiler $
--       Comp { compPathSegments = []
--            , compData = Nothing
--            -- , compType = Nothing
--            } :
--       ((Just <$>) <$> unCompiler x)
-- instance PathSegmentable Compiler where
--   pathSegment s = Compiler
--     [
--       Comp
--         { compPathSegments = [s]
--         , compData = ()
--         -- , compType = PlainText
--         }
--     ]
--   pathSegments ss =
--     Compiler $
--       [ Comp{ compPathSegments = [s]
--             , compData = s
--             -- , compType = Nothing
--             }
--       | s <- toList ss
--       ]
-- instance ContentTypeable PlainText () Compiler where
--   contentType =
--     Compiler
--       [ Comp
--           { compPathSegments = []
--           , compData = ()
--           --, compType = mediaType @PlainText
--           }
--       ]
--
-- -- instance Repeatable Compiler where
-- --   many0 (Compiler x) =
-- --     Compiler $
-- --       ((\Comp{} -> Comp [] []) <$> x)
-- --         <> ((\(Comp s a) -> Comp s [a]) <$> x)
-- --         <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
-- --   many1 (Compiler x) =
-- --     Compiler $
-- --       ((\(Comp s a) -> Comp s [a]) <$> x)
-- --         <> ((\(Comp s a) -> Comp (s <> s) [a, a]) <$> x)
-- -- instance Endable Compiler where
-- --   end = Compiler [Comp [] ()]
-- -- instance Capturable Compiler where
-- --   capturePathSegment n = Compiler $ [Comp [n] n]
-- -- instance Constantable c Compiler where
-- --   constant = pure
-- -}
--
copyDirRecursively ::
  ( --MonadIO m,
    --MonadUnliftIO m,
    --MonadLoggerIO m,
    HasCallStack
  ) =>
  -- | Source file path relative to CWD
  Sys.FilePath ->
  -- | Absolute path to source file to copy.
  Sys.FilePath ->
  -- | Directory *under* which the source file/dir will be copied
  Sys.FilePath ->
  Sys.IO ()
copyDirRecursively srcRel srcAbs destParent = do
  Sys.doesFileExist srcAbs >>= \case
    True -> do
      Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a file", srcAbs)
      copyFileCreatingParents srcAbs (destParent Sys.</> srcRel)
    False ->
      Sys.doesDirectoryExist srcAbs >>= \case
        False -> do
          Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is neither a file nor directory", srcAbs)
          return ()
        -- throw $ StaticAssetMissing srcAbs
        True -> do
          Sys.hPutStrLn Sys.stderr $ "copyDirRecursively: " <> show ("srcAbs is a directory", srcAbs)
          Sys.createDirectoryIfMissing True (destParent Sys.</> srcRel)
          fs <- Sys.getDirectoryFiles srcAbs ["**"]
          forM_ fs $ \fp -> do
            let a = srcAbs Sys.</> fp
                b = destParent Sys.</> srcRel Sys.</> fp
            copyFileCreatingParents a b
  where
    copyFileCreatingParents a b = do
      Sys.createDirectoryIfMissing True (Sys.takeDirectory b)
      Sys.copyFile a b