{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Salak.Types where
import Control.Applicative ((<|>))
import Control.Monad.State
import Data.Attoparsec.Text
import qualified Data.IntMap.Strict as MI
import Data.List (intercalate)
import qualified Data.Map.Strict as M
import Data.Maybe
import qualified Data.PQueue.Min as Q
import Data.Scientific (Scientific)
import Data.Text (Text)
import qualified Data.Text as T
type Priority = Int
data Value
= VStr Priority !Text
| VNum Priority !Scientific
| VBool Priority !Bool
deriving (Eq, Show, Ord)
type QV = Q.MinQueue Value
getPriority :: Value -> Priority
getPriority (VStr p _) = p
getPriority (VNum p _) = p
getPriority (VBool p _) = p
data Reload = Reload
{ sourceName :: Text
, reload :: Priority -> IO Source
}
instance Show Reload where
show (Reload s _) = T.unpack s
emptyReload :: Text -> Reload
emptyReload s = Reload s (\_ -> return emptySource)
type PriorityEnv = MI.IntMap Reload
nullSource :: Source -> Bool
nullSource (Source _ q is ts) = Q.null q && MI.null is && M.null ts
getQ :: Source -> QV
getQ (Source _ q _ _) = q
replaceQ :: String -> Priority -> QV -> QV -> ([String], QV)
replaceQ s i nq q =
let (a,b) = Q.partition ((==i) . getPriority) q
in if a == nq then ([], q) else case Q.getMin nq of
Just v -> ([ (if Q.null a then "Add " else "Mod ") ++ s], Q.insert v b)
_ -> (if Q.null a then [] else ["Del " ++ s], b)
data Source' v = Source [String] v (MI.IntMap (Source' v)) (M.Map Text (Source' v)) deriving (Eq, Functor)
type Source = Source' QV
instance Show Source where
show = unlines . go ""
where
go p (Source _ q is ts) = (if Q.null q then [] else [ p ++ "=" ++ show q ])
++ concat ((\(k,v) -> go (p ++ "[" ++ show k ++ "]") v) <$> MI.toList is)
++ concat ((\(k,v) -> go (if null p then T.unpack k else p ++ "." ++ T.unpack k) v) <$> M.toList ts)
emptySource :: Source
emptySource = Source [] Q.empty MI.empty M.empty
instance Foldable Source' where
foldr f b s@(Source _ _ is ts) = foldr go (foldr go (go s b) is) ts
where
go (Source _ q _ _) = f q
foldSource :: (Value -> b -> b) -> b -> Source -> b
foldSource f = foldr (\q b -> maybe b (`f` b) $ Q.getMin q)
sizeSouce :: Source -> Int
sizeSouce = foldSource (const (+1)) 0
extractErr :: Source -> ([String], Source)
extractErr (Source es q is ts) =
let (ise, is') = MI.mapAccum go es is
(tse, ts') = M.mapAccum go ise ts
in (tse, Source [] q is' ts')
where
go e s = let (e', s') = extractErr s in (e ++ e', s')
replace = replace' []
replace' :: [Selector] -> Priority -> Source -> Source -> Source
replace' ss i (Source _ nq nis nts) (Source es q is ts) =
let (ms, q') = replaceQ (toKey ss) i nq q
(isa,isb) = MI.partition nullSource $ MI.mapWithKey (g2.SNum) $ MI.unionWithKey (go.SNum) (f 0 nis) (f 1 is)
(tsa,tsb) = M.partition nullSource $ M.mapWithKey (g2.STxt) $ M.unionWithKey (go.STxt) (f 0 nts) (f 1 ts)
in Source (g $ Source (es ++ ms) Q.empty isa tsa) q' isb tsb
where
f x = ((x::Int,) <$>)
g = fst . extractErr
go st (_, s) (_, s') = (2, replace' (st:ss) i s s')
g2 st (0, s) = replace' (st:ss) i s emptySource
g2 st (1, s) = replace' (st:ss) i emptySource s
g2 _ (_, s) = s
data Selector
= STxt !Text
| SNum !Int
deriving Eq
instance Show Selector where
show (STxt x) = T.unpack x
show (SNum i) = "[" ++ show i ++ "]"
toKey :: [Selector] -> String
toKey = intercalate "." . go . reverse
where
go (a@(STxt _):b@(SNum _):cs) = (show a ++ show b) : go cs
go (a:bs) = show a : go bs
go [] = []
selectors :: Text -> Either String [Selector]
selectors = go . parse exprs . flip T.snoc '\n'
where
go (Done i r) = if i /= "\n" then Left $ "uncomplete parse" ++ T.unpack i else Right r
go a = Left (show a)
exprs :: Parser [Selector]
exprs = concat <$> ( (expr <|> return []) `sepBy` char '.')
expr :: Parser [Selector]
expr = do
name <- T.pack <$> do
a <- choice [letter, digit]
b <- many' (choice [letter, digit, char '-', char '_'])
return (a:b)
(paren decimal >>= \i -> return [STxt name, SNum i]) <|> return [STxt name]
where
paren e = do
_ <- char '['
ex <- e
_ <- char ']'
return ex
addErr :: String -> Source -> Source
addErr e (Source es a b c) = Source (e:es) a b c
insert :: Text -> Value -> Source -> Source
insert k v s = case selectors k of
Left e -> addErr e s
Right k' -> insert' k' v s
insert' :: [Selector] -> Value -> Source -> Source
insert' [] v (Source es q is ts) = Source es (Q.insert v q) is ts
insert' (STxt n:ss) v (Source es q is ts) = Source es q is $ M.alter (Just . insert' ss v . fromMaybe emptySource) n ts
insert' (SNum i:ss) v (Source es q is ts) = Source es q (MI.alter (Just . insert' ss v . fromMaybe emptySource) i is) ts
data SourcePack = SourcePack [Selector] Int Source PriorityEnv deriving Show
emptySourcePack = SourcePack [] 0 emptySource MI.empty
mapSource :: (Source -> Source) -> SourcePack -> SourcePack
mapSource f (SourcePack ss i s it) = SourcePack ss i (f s) it
select :: SourcePack -> Selector -> SourcePack
select (SourcePack ss i (Source _ _ _ ts) it) s@(STxt n) = SourcePack (s:ss) i (fromMaybe emptySource $ M.lookup n ts) it
select (SourcePack ss i (Source _ _ is _) it) s@(SNum n) = SourcePack (s:ss) i (fromMaybe emptySource $ MI.lookup n is) it
addErr' :: String -> SourcePack -> SourcePack
addErr' e = mapSource (addErr e)
extractErr' :: SourcePack -> ([String], SourcePack)
extractErr' (SourcePack ss i s it) = let (es, s') = extractErr s in (es, SourcePack ss i s' it)
loadFile :: Reload -> SourcePack -> (Priority -> Source -> Source) -> SourcePack
loadFile name (SourcePack ss i s env) go = SourcePack ss (i+1) (go i s) $ MI.insert i name env
load
:: (Functor f, Foldable f)
=> Reload
-> f a
-> (Priority -> a -> (Text, Value))
-> SourcePack
-> SourcePack
load name fa f sp = loadFile name sp $ \i s -> foldl (go i) s fa
where
go i s a = let (k,v) = f i a in insert k v s
loadMock :: Monad m => [(Text, Text)] -> SourcePackT m ()
loadMock fs = modify $ load (emptyReload "") fs (\i (k,v) -> (k, VStr i v))
type SourcePackT = StateT SourcePack
runSourcePackT :: Monad m => SourcePackT m a -> m ([String], SourcePack)
runSourcePackT ac = extractErr' <$> execStateT ac emptySourcePack