Assets.hs

{-# LANGUAGE OverloadedStrings
, TemplateHaskell
, MultiParamTypeClasses
, FlexibleInstances
, NoMonomorphismRestriction
, StandaloneDeriving
, ExistentialQuantification
, FlexibleContexts
, DeriveFunctor
, DeriveTraversable
, DeriveFoldable
 #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- | Low-level module for Assets that are used to build websites.
module Lykah.Assets
  (
   Identifier
  ,Pathed (..)
  ,Env(ePaths,eIDs,eCur)
  ,Asset(..)
  ,strip
  ,IDO
  ,uniquify
  ,root
  ,isRoot
  ,getId
  ,reference
  ,Assets
  ,lookupId
  ,lookupNamedId
  ,generateAssets
  ,onlyUsed
  ,Text
  ,module Control.Applicative
  ,module Control.Arrow
  ,module Control.Monad
  ,module Control.Monad.Reader
  ,module Control.Monad.Trans
  ,module Control.Monad.RWS
  ,module Data.Char
  ,module Data.Either
  ,module Data.Function
  ,module Data.List
  ,module Data.Tuple
  ,module Data.Maybe
  ,module Data.Monoid
  ,module Data.Ord
  ,module Data.String
  ,module Data.Time.Calendar
  ,module Data.Time.Format
  ,module Data.Time.LocalTime
  ,module System.Directory
  ,module System.FilePath
  ,module Text.Printf
  ) where

import           Control.Applicative
import           Control.Arrow
import           Control.Monad
import           Control.Monad.Identity
import           Control.Monad.RWS
import           Control.Monad.Reader
import           Control.Monad.State
import           Control.Monad.Trans
import           Data.Char
import           Data.Either
import           Data.Foldable hiding (mapM_)
import           Data.Function
import           Data.List
import qualified Data.Map.Strict as M
import           Data.Maybe
import           Data.Monoid
import           Data.Ord
import           Data.String
import           Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as T
import           Data.Time.Calendar
import           Data.Time.Format
import           Data.Time.LocalTime
import           Data.Tuple
import           System.Directory
import           System.File.Tree (getDirectory, copyTo_)
import           System.FilePath
import           Text.Printf
  
-- copyDirectory source target = getDirectory source >>= copyTo_ target


type Identifier = String

data Pathed c =  Pathed { aPath :: FilePath
                        , aId :: Identifier
                        , aName :: Maybe Text
                        , aParent :: Maybe (Pathed ())
                        , aContent :: c
                        }
              deriving (Show,Functor) 

deriving instance Traversable Pathed
deriving instance Foldable Pathed

-- | Environment for the currently rendered Ehtml's asset
data Env a = Env { ePaths :: M.Map Identifier (Pathed ())
                   -- ^ all available resources by ID
                 , eIDs :: M.Map FilePath Identifier 
                   -- ^ the reverse: mapping Path to IDs (unused so far) 
                 , eCur :: a
                   -- ^ the environment of the currently rendered
                   -- asset
                 }
             deriving Functor


class IDO a where
  getId :: a -> Identifier

instance IDO String where
  getId = id

instance IDO (Pathed a) where
  getId = aId

-- | returns top-most parent
root :: Pathed a -> Pathed ()
root p@Pathed{aParent=Nothing} = strip p
root Pathed{aParent=(Just p)} = root p

isRoot :: Pathed c -> Bool
isRoot = isNothing . aParent

lookupNamedId :: (MonadWriter [Identifier] m,MonadReader (Env a) m)
            => Identifier -> m (Pathed ())
lookupNamedId = fmap f . lookupId
  where f p@Pathed{aName=Just _} = p
        f p@Pathed{aName=Nothing} =
          error $ printf "Identifier %s provides no name." $ aId p

-- | reference a Pathed value to ensure it is included in output
reference
  :: (IDO a, MonadWriter [Identifier] m, MonadTrans t) => a -> t m ()
reference i = lift $ tell [getId i]
  
lookupId :: (MonadWriter [Identifier] m,MonadReader (Env a) m)
            => Identifier -> m (Pathed ())
lookupId x =  do
  paths <- reader ePaths
  maybe (error $ printf "Identifier %s not found in %s." x $
         unlines $ show <$> M.elems paths)
    (\p -> tell [x] >> return p) $ x `M.lookup` paths
  
-- | 
-- is the result of the 'render' method from the 'Content' class
data Asset = Copy FilePath -- ^ the asset can be generated by copying
                            -- this file
            | CopyDir FilePath-- ^ the asset can be generated by copying
                            -- this directory
            | Write Text -- ^ the asset can be generated by writing
                         -- this text
            | WriteIO (IO Text) -- ^ the asset can be generated by writing
                            -- the result of an IO action
            | Concat [Asset] -- ^ the asset can be generated by concatenating
              -- the contents described by a list of assets

instance Monoid Asset where
  mempty = Concat mempty
  mappend a b = Concat $ on (++) toConcatList a b

toConcatList :: Asset -> [Asset]
toConcatList (Concat x)  = x
toConcatList x = [x]

type Assets = [Pathed Asset]


strip :: Pathed a -> Pathed ()
strip = fmap (const ())

-- | generate a map of Pathed objects with unique IDs and paths
uniquify :: [Pathed ()] -> Env ()
uniquify x = Env (fst $ execState action (M.empty,M.empty)) undefined ()
  where action =  modify $ \(ids,paths) ->
          (M.unionWithKey check1 ids   $ M.fromListWithKey check1 p1
          ,M.unionWithKey check2 paths $ M.fromListWithKey check2 p2)
        p1 = fmap (\p -> (aId p, p)) x
        p2 = fmap (\p -> (aId p, aPath p)) x
        check name iid a b =  error $ printf
                        ("Conflicting %s for '%s':\n%v\n%v")
                        (name :: String) iid (show a) $ show b
        check1 = check "IDs"
        check2 = check "Paths"

  
-- | Generates all assets and their depending assets in the target dir
-- (careful: removes preexisting target dir)
generateAssets :: Bool -- ^ Debug
               -> FilePath -- ^ target directory
               -> Assets -> IO ()
generateAssets debug dir assets  = do
  ef1 <- doesFileExist dir
  ef2 <- doesDirectoryExist dir
  when (ef1 || ef2) $ removeDirectoryRecursive  dir
  when debug $ printf "Output dir: %s\n" dir
  mapM_ (performeAction . modifyAss)  assets
  where
    modifyAss a@(Pathed{aPath = f}) = a{aPath=f'}
      where f' = if hasTrailingPathSeparator f then
                   f </> "index.html"
                 else f
    performeAction p@(Pathed{aPath=target, aId=aid}) = do
      createDirectoryIfMissing True $ takeDirectory at
      action' $ aContent p
      where
        action' (WriteIO action) = action >>= action' . Write
        action' (Write content) = do
          when debug $ printf "Writing content of '%s' to file %s\n" aid at
          T.writeFile at content
        action' (Copy source) = do
          when debug $ printf "Copying '%s' from %s to %s\n" source aid at
          copyFile source at
        action' (CopyDir source) = do
          when debug $ printf "Recursively copying '%s' from %s to %s\n" source aid at
          getDirectory source >>= copyTo_ at 
        action' x@(Concat _) = do
          when debug $ printf "Writing %s to %s\n" aid at
          extractContent x >>= T.writeFile at
        extractContent (Write text) = return text
        extractContent (WriteIO action) = action
        extractContent (Copy source) = T.readFile source
        extractContent (Concat xs) = T.concat <$> mapM extractContent xs
        extractContent (CopyDir _) = error "extractConcat (CopyDir _) not implemented"
        at = dir </> target


-- | Extract only these assets of a list of IDs that are actually used
onlyUsed :: [Identifier] -> Assets -> Assets
onlyUsed used ass  = M.elems $ M.intersection
                     (M.fromList $ (\x -> (aId x, x)) <$> ass)
                     $M.fromList $ (\x -> (x,()))     <$> used