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
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
data Env a = Env { ePaths :: M.Map Identifier (Pathed ())
, eIDs :: M.Map FilePath Identifier
, eCur :: a
}
deriving Functor
class IDO a where
getId :: a -> Identifier
instance IDO String where
getId = id
instance IDO (Pathed a) where
getId = aId
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
:: (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
data Asset = Copy FilePath
| CopyDir FilePath
| Write Text
| WriteIO (IO Text)
| Concat [Asset]
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 ())
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"
generateAssets :: Bool
-> FilePath
-> 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
onlyUsed :: [Identifier] -> Assets -> Assets
onlyUsed used ass = M.elems $ M.intersection
(M.fromList $ (\x -> (aId x, x)) <$> ass)
$M.fromList $ (\x -> (x,())) <$> used