Config.hs

module Network.Anticiv.Config where

import Control.Monad
import Data.Chatty.Atoms
import Data.Chatty.TST
import Data.List
import Text.Chatty.Parser
import Text.Chatty.Parser.Carrier
import Text.Chatty.Scanner
import Text.CTPL

data ValueRef = StrVal (Atom String) | IntVal (Atom Int) | StrList (Atom [String]) | Ctpl0 (Atom String) deriving Eq
data ValueTemp = StrValT String | IntValT Int | StrListT [String] | CtplT String | Ctpl0T String deriving (Eq,Show)
data Key = RefLeaf ValueRef | TempLeaf ValueTemp | Group Config | Module Config | Vocab Config

type Config = TST Key

instance Show ValueRef

parseConf :: ChParser m => m Config
parseConf = do
  keys <- many parseKey
  return $ foldr (uncurry tstInsert) EmptyTST keys

oneOf :: ChParser m => [Char] -> m Char
oneOf ks = do
  k <- request
  if k `elem` ks then return k else pabort

ident :: ChParser m => m String
ident = some $ oneOf (['A'..'Z']++['a'..'z']++"-")

parseKey :: ChParser m => m (String, Key)
parseKey = do
  let grabl = do
        k <- request
        if k=='\n' then pabort else return k
      comment = do
        many white
        matchs "#"
        many grabl
        match '\n'
  many comment
  parseLeaf ??? parseGroup ??? parseModule ??? parseVocab

parseLeaf :: ChParser m => m (String, Key)
parseLeaf = do
  many white
  nm <- ident
  many white
  match '='
  let parseInt = do
        many white
        ds <- some digit
        return $ IntValT $ foldl1 (\l r -> l*10+r) ds
      grabq = (do
        k <- request
        case k of
          '"' -> pabort
          '\\' -> do
            k <- request
            ks <- grabq
            return (k:ks)
          _ -> do
            ks <- grabq
            return (k:ks)) ?? return []
      parseStr = do
        many white
        match '"'
        ks <- grabq
        match '"'
        return $ StrValT ks
      parseStrList = do
        many white
        match '('
        many white
        strs <- many parseStr
        many white
        match ')'
        return $ StrListT $ map (\(StrValT s) -> s) strs
      parseCtpl = do
        many white
        matchs "CTPL"
        many white
        match '"'
        cs <- grabq
        match '"'
        return $ CtplT cs
      parseCtpl0 = do
        many white
        matchs "CTPL0"
        many white
        match '"'
        cs <- grabq
        match '"'
        return $ Ctpl0T cs
  v <- parseInt ?? parseStr ?? parseStrList ??? parseCtpl ??? parseCtpl0
  many white
  match ';'
  return (nm,TempLeaf v)

parseGroup :: ChParser m => m (String, Key)
parseGroup = do
  many white
  matchs "Group"
  many white
  nm <- ident
  many white
  match '{'
  sub <- parseConf
  many white
  match '}'
  return (nm,Group sub)

parseModule :: ChParser m => m (String, Key)
parseModule = do
  many white
  matchs "Module"
  many white
  nm <- ident
  many white
  match '{'
  sub <- parseConf
  many white
  match '}'
  return (nm,Module sub)

parseVocab :: ChParser m => m (String, Key)
parseVocab = do
  many white
  matchs "Vocab"
  many white
  nm <- ident
  many white
  match '{'
  sub <- parseConf
  many white
  match '}'
  return (nm,Vocab sub)

readConf :: (ChScanner m,ChAtoms m) => m (Maybe Config)
readConf = do
  inp <- mscanL
  case runCarrierT inp parseConf of
    [] -> return Nothing
    (c:_) -> tmap atomify c >>= return . Just

instance Functor TST where
  fmap f EmptyTST = EmptyTST
  fmap f (TST c Nothing l m r) = TST c Nothing (fmap f l) (fmap f m) (fmap f r)
  fmap f (TST c (Just h) l m r) = TST c (Just $ f h) (fmap f l) (fmap f m) (fmap f r)

tmap :: Monad m => (a -> m b) -> TST a -> m (TST b)
tmap _ EmptyTST = return EmptyTST
tmap f (TST c Nothing l m r) = do
  l' <- tmap f l
  m' <- tmap f m
  r' <- tmap f r
  return $ TST c Nothing l' m' r'
tmap f (TST c (Just h) l m r) = do
  l' <- tmap f l
  m' <- tmap f m
  r' <- tmap f r
  h' <- f h
  return $ TST c (Just h') l' m' r'

atomify :: ChAtoms m => Key -> m Key
atomify (RefLeaf r) = return $ RefLeaf r
atomify (Group c) = tmap atomify c >>= return . Group
atomify (Module c) = tmap atomify c >>= return . Module
atomify (Vocab c) = return $ Vocab c
atomify (TempLeaf (IntValT i)) = do
  a <- newAtom
  putAtom a i
  return $ RefLeaf $ IntVal a
atomify (TempLeaf (StrValT s)) = do
  a <- newAtom
  putAtom a s
  return $ RefLeaf $ StrVal a
atomify (TempLeaf (StrListT l)) = do
  a <- newAtom
  putAtom a l
  return $ RefLeaf $ StrList a
atomify (TempLeaf (CtplT s)) = do
  a <- newAtom
  case compileCTPL s of
    Succ s' -> putAtom a s'
    SyntaxFault -> error "Error compiling CTPL script: Syntax fault."
    NoSuchProc s -> error ("Error compiling CTPL script: No such proc: "++s)
  return $ RefLeaf $ Ctpl0 a
atomify (TempLeaf (Ctpl0T s)) = do
  a <- newAtom
  putAtom a s
  return $ RefLeaf $ Ctpl0 a

getKey :: String -> Config -> Maybe Key
getKey s cx = case p of
  [] -> Nothing
  (c:_) -> Just c
  where p = runCarrierT s $ do
          let leaf c = do
                nm <- ident
                case tstLookup nm c of
                  Just k@RefLeaf{} -> return k
                  Just k@TempLeaf{} -> return k
                  _ -> pabort
              modu c = do
                match '%'
                nm <- ident
                match '/'
                case tstLookup nm c of
                  Just (Module k) -> kget k
                  _ -> pabort
              group c = do
                nm <- ident
                match '/'
                case tstLookup nm c of
                  Just (Group k) -> kget k
                  _ -> pabort
              vocab c = do
                nm <- ident
                match ':'
                case tstLookup nm c of
                  Just (Vocab k) -> kget k
                  _ -> pabort
              kget c = leaf c ??? modu c ??? group c ??? vocab c
          kget cx

mgetKey :: String -> String -> Config -> Maybe Key
mgetKey m s c =
  case getKey ("%"++m++"/"++s) c of
    Just k -> Just k
    Nothing -> getKey s c

getFirstKey :: [String] -> Config -> Maybe Key
getFirstKey [] _ = Nothing
getFirstKey (k:ks) c
  | Just x <- getKey k c = Just x
  | otherwise = getFirstKey ks c

mgetFirstKey :: String -> [String] -> Config -> Maybe Key
mgetFirstKey m ks c = flip getFirstKey c $ do
  k <- ks
  ["%"++m++"/"++k, k]