deiko-config (empty) → 0.5.0.0
raw patch · 14 files changed
+1406/−0 lines, 14 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, exceptions, mtl, parsec, text, transformers
Files
- Data/Config.hs +267/−0
- Data/Config/Internal/AST.hs +41/−0
- Data/Config/Internal/DkM.hs +67/−0
- Data/Config/Internal/Parser.hs +265/−0
- Data/Config/Internal/Pos.hs +50/−0
- Data/Config/Internal/Reg.hs +29/−0
- Data/Config/Internal/Register.hs +139/−0
- Data/Config/Internal/Rename.hs +75/−0
- Data/Config/Internal/Scoped.hs +26/−0
- Data/Config/Internal/Typecheck.hs +288/−0
- Data/Config/Internal/Typed.hs +84/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- deiko-config.cabal +43/−0
+ Data/Config.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Config+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Config+ ( Config+ , loadConfig+ , getInteger+ , getParsec+ , getString+ , getBool+ , getStrings+ , getBools+ , getIntegers+ , getParsecs+ ) where++--------------------------------------------------------------------------------+import Control.Applicative+import Control.Exception+import Control.Monad.Trans+import Data.Typeable++--------------------------------------------------------------------------------+import Control.Monad.Catch+import qualified Data.Map as M+import Data.Text (Text, unpack)+import qualified Data.Text.IO as T+import Text.Parsec (Parsec)+import qualified Text.Parsec.Char as Char+import Text.Parsec.Combinator+import Text.Parsec.Pos (newPos)+import qualified Text.Parsec.Prim as Prim+import Text.Parsec.Text ()++--------------------------------------------------------------------------------+import Data.Config.Internal.AST+import Data.Config.Internal.Parser+import Data.Config.Internal.Pos+import Data.Config.Internal.Scoped+import Data.Config.Internal.Reg+import Data.Config.Internal.Register+import Data.Config.Internal.Rename+import Data.Config.Internal.Typecheck+import Data.Config.Internal.Typed++{- Here's an example:++> -- app.conf+> # This is a comment+>+> foo.bar = ${toto}+>+> toto = false+>+> rawString = """+> This is a multi-+> lines String+> """+>+> another.string = "I'm a String"+>+> one.more.string = one more string+>+> nested {+> list: [ one+> , 1+> , "both"]+>+> homing = {+> pass: { b: feez } { a: "Prop"}+> }+>+> another: [1,2,3] [4,5,6]+> }++> -- Example.hs+> {-# LANGUAGE OverloadedStrings #-}+>+> import Data.Config+>+> data Foo = Foo { fooPort :: Int, fooAddr :: String }+>+> main :: IO ()+> main = do+> foo <- loadFooProps+> withFoo foo+>+> where+> loadFooProps = do+> config <- 'loadConfig' "conf/baz.conf"+> port <- 'getInteger' "foo.port" config+> addr <- 'getString' "foo.addr" config+> return (Foo port addr)+>+> withFoo :: Foo -> IO ()+> withFoo = ...+-}+--------------------------------------------------------------------------------+newtype Config = Config { unConf :: Reg }++--------------------------------------------------------------------------------+type Extractor a = forall m. MonadThrow m => Text -> Config -> AST Typed -> m a++--------------------------------------------------------------------------------+newtype ConfigError = ConfigError String deriving Typeable++--------------------------------------------------------------------------------+instance Show ConfigError where+ show (ConfigError s) = s++--------------------------------------------------------------------------------+instance Exception ConfigError++--------------------------------------------------------------------------------+loadConfig :: (MonadIO m, MonadThrow m) => FilePath -> m Config+loadConfig path+ = do txt <- liftIO $ T.readFile path+ pse <- parse path txt+ let action+ = do ps <- pse+ (tys, pts) <- typecheck $ rename ps+ return $ register tys pts+ case action of+ Left e -> throwM e+ Right reg -> return $ Config reg++--------------------------------------------------------------------------------+-- | API+--------------------------------------------------------------------------------+getString :: MonadThrow m => Text -> Config -> m Text+getString key conf = getValue string key conf++--------------------------------------------------------------------------------+getInteger :: MonadThrow m => Text -> Config -> m Integer+getInteger key conf = getParsec integerParsec key conf++--------------------------------------------------------------------------------+getBool :: MonadThrow m => Text -> Config -> m Bool+getBool key conf = getParsec boolParsec key conf++--------------------------------------------------------------------------------+getParsec :: MonadThrow m+ => (forall s. Parsec Text s a)+ -> Text+ -> Config+ -> m a+getParsec action key conf = getValue (parsec action) key conf++--------------------------------------------------------------------------------+getStrings :: MonadThrow m => Text -> Config -> m [Text]+getStrings key conf = getValues string key conf++--------------------------------------------------------------------------------+getIntegers :: MonadThrow m => Text -> Config -> m [Integer]+getIntegers key conf = getParsecs integerParsec key conf++--------------------------------------------------------------------------------+getBools :: MonadThrow m => Text -> Config -> m [Bool]+getBools key conf = getParsecs boolParsec key conf++--------------------------------------------------------------------------------+getParsecs :: MonadThrow m+ => (forall s. Parsec Text s a)+ -> Text+ -> Config+ -> m [a]+getParsecs action key conf = getValues (parsec action) key conf++--------------------------------------------------------------------------------+-- | Utilities+--------------------------------------------------------------------------------+getValue :: MonadThrow m => Extractor a -> Text -> Config -> m a+getValue extr key conf+ = maybe (throwM $ propertyNotFound key) go (M.lookup key reg)+ where+ reg = regAST $ unConf conf+ go ast = extr key conf (simplify (unConf conf) ast)++--------------------------------------------------------------------------------+getValues :: MonadThrow m => Extractor a -> Text -> Config -> m [a]+getValues extr key conf = getValue (list extr) key conf++--------------------------------------------------------------------------------+string :: Extractor Text+string key _ (AST expr t)+ = case expr of+ ID s -> return s+ STRING s -> return s+ _ -> throwM (wrongType key pos stringType ty)+ where+ pos = scopePos $ typedScope t+ ty = typedType t++--------------------------------------------------------------------------------+list :: Extractor a -> Extractor [a]+list extr key conf (AST expr t)+ = case expr of+ LIST xs -> mapM (extr key conf) xs+ _ -> throwM (wrongType key pos someListType ty)+ where+ pos = scopePos $ typedScope t+ ty = typedType t++--------------------------------------------------------------------------------+integerParsec :: Parsec Text s Integer+integerParsec = fmap read (many1 Char.digit <* eof)++--------------------------------------------------------------------------------+boolParsec :: Parsec Text s Bool+boolParsec+ = ( fmap (const True) (Char.string "true")+ <|> fmap (const True) (Char.string "True")+ <|> fmap (const True) (Char.string "yes")+ <|> fmap (const True) (Char.string "Yes")+ <|> fmap (const False) (Char.string "false")+ <|> fmap (const False) (Char.string "False")+ <|> fmap (const False) (Char.string "no")+ <|> fmap (const False) (Char.string "No")+ <|> onOff+ ) <* eof+ where+ msg = " when parsing on|off or On|Off"+ onOff+ = do _ <- Char.char 'o' <|> Char.char 'O'+ c <- Char.anyChar+ case c of+ 'n' -> return True+ 'f' -> Char.char 'f' >> return False+ _ -> Prim.unexpected (show c ++ msg)++--------------------------------------------------------------------------------+parsec :: Parsec Text () a -> Extractor a+parsec action key conf a@(AST _ ty)+ = do s <- string key conf a+ let pos = scopePos $ typedScope ty+ upd _ = newPos (unpack key) (startLine pos) (startCol pos)+ ini = Prim.setPosition . upd =<< Prim.getPosition+ err e = throwM $ ConfigError (ctxStr key pos ++ show e)+ result = Prim.parse (ini >> action) "" s+ either err return result++--------------------------------------------------------------------------------+propertyNotFound :: Text -> ConfigError+propertyNotFound k = ConfigError msg where+ msg = "Property " ++ unpack k ++ " is not found"++--------------------------------------------------------------------------------+wrongType :: Text -> Pos -> Type -> Type -> ConfigError+wrongType key pos tye tyf = ConfigError msg where+ msg = ctxStr key pos +++ "When accessing, expected " ++ show tye +++ " but had " ++ show tyf ++ " instead"++--------------------------------------------------------------------------------+ctxStr :: Text -> Pos -> String+ctxStr e pos = unpack e ++ show pos ++ " "
+ Data/Config/Internal/AST.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleContexts #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Config.Internal.AST+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Config.Internal.AST where++--------------------------------------------------------------------------------+import Data.Text (Text)++--------------------------------------------------------------------------------+-- | Declarations+--------------------------------------------------------------------------------+data Expr p t+ = ID Text+ | STRING Text+ | LIST [p t]+ | SUBST Text+ | MERGE (p t) (p t)+ | OBJECT [Prop p t] deriving Show++--------------------------------------------------------------------------------+data AST t+ = AST+ { astExpr :: Expr AST t+ , astTag :: t+ } deriving Show++--------------------------------------------------------------------------------+data Prop p t+ = Prop+ { propName :: !Text+ , propAST :: p t+ } deriving Show
+ Data/Config/Internal/DkM.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Config.Internal.DkM+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Config.Internal.DkM where++--------------------------------------------------------------------------------+import Control.Applicative+import Control.Monad+import Control.Monad.Reader+import Control.Monad.State++--------------------------------------------------------------------------------+newtype DkM e s a = DkM { runDkM :: e -> s -> IO (a, s) }++--------------------------------------------------------------------------------+-- | Instances+--------------------------------------------------------------------------------+instance Functor (DkM e s) where+ fmap f (DkM k)+ = DkM $ \e s -> fmap (\(a, s') -> (f a, s')) (k e s)++--------------------------------------------------------------------------------+instance Applicative (DkM e s) where+ pure = return+ (<*>) = ap++--------------------------------------------------------------------------------+instance Monad (DkM e s) where+ return a = DkM $ \_ s -> return (a, s)++ DkM k >>= f+ = DkM $ \e s -> do+ (a, !s') <- k e s+ runDkM (f a) e s'++--------------------------------------------------------------------------------+instance MonadState s (DkM e s) where+ state k = DkM $ \_ s -> return $ k s++--------------------------------------------------------------------------------+instance MonadReader e (DkM e s) where+ ask = DkM $ \e s -> return (e, s)++ local f (DkM k) = DkM $ \e s -> k (f e) s++--------------------------------------------------------------------------------+instance MonadIO (DkM e s) where+ liftIO m = DkM $ \_ s -> fmap (\a -> (a, s)) m++--------------------------------------------------------------------------------+execDkM :: DkM e s a -> e -> s -> IO s+execDkM m e s = fmap snd (runDkM m e s)++--------------------------------------------------------------------------------+evalDkM :: DkM e s a -> e -> s -> IO a+evalDkM m e s = fmap fst (runDkM m e s)
+ Data/Config/Internal/Parser.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Config.Internal.Parser+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Config.Internal.Parser (parse) where++--------------------------------------------------------------------------------+import Control.Applicative ((<*>), (<$), (<$>))+import Control.Exception hiding (try)+import Data.Functor (void)+import Data.Monoid ((<>))+import Data.Typeable++--------------------------------------------------------------------------------+import Data.Text (Text, pack)+import qualified Data.Text as T+import Text.Parsec hiding (parse)+import Text.Parsec.Text ()+import qualified Text.Parsec.Token as P++--------------------------------------------------------------------------------+import Data.Config.Internal.AST+import Data.Config.Internal.Pos++--------------------------------------------------------------------------------+newtype PlainError = PlainError String deriving Typeable++--------------------------------------------------------------------------------+instance Show PlainError where+ show (PlainError s) = s++--------------------------------------------------------------------------------+instance Exception PlainError++--------------------------------------------------------------------------------+parse :: Monad m => FilePath -> Text -> m (Either SomeException [Prop AST Pos])+parse path input+ = do ps <- runParserT parsePROPS () path input+ return $ either (Left . SomeException . PlainError . show) Right ps++--------------------------------------------------------------------------------+-- | Language definition+--------------------------------------------------------------------------------+langDef :: Monad m => P.GenLanguageDef Text u m+langDef+ = P.LanguageDef+ { P.commentStart = ""+ , P.commentEnd = ""+ , P.commentLine = ""+ , P.nestedComments = False+ , P.identStart = letter <|> char '_'+ , P.identLetter = alphaNum <|> oneOf "-_"+ , P.opStart = P.opLetter langDef+ , P.opLetter = oneOf ":.{}[]="+ , P.reservedNames = []+ , P.reservedOpNames = []+ , P.caseSensitive = True+ }++--------------------------------------------------------------------------------+-- | Token parser+--------------------------------------------------------------------------------+tokenParser :: Monad m => P.GenTokenParser Text u m+tokenParser = P.makeTokenParser langDef++--------------------------------------------------------------------------------+-- | Property based parsing+--------------------------------------------------------------------------------+parsePROPS :: Monad m => ParsecT Text u m [Prop AST Pos]+parsePROPS = do+ skipMany (parseCOMMENT >> whitespace)+ whitespace+ properties+ where+ properties = commonPROPS eof++--------------------------------------------------------------------------------+parsePROP :: Monad m => ParsecT Text u m (Prop AST Pos)+parsePROP = do+ AST (ID i) _ <- parseIDENT+ v <- parseOBJECT <|> do { _ <- equal; optional whitespace; parseVALUE }+ return $ Prop i v+ where+ equal = char '=' <|> char ':'++--------------------------------------------------------------------------------+parseOBJECT :: Monad m => ParsecT Text u m (AST Pos)+parseOBJECT = do+ ps <- getPosition+ pp <- between (char '{') (char '}') $ do+ skipMany (parseCOMMENT >> whitespace)+ whitespace+ p <- objProperties+ skipMany (parseCOMMENT >> whitespace)+ whitespace+ return p+ pe <- getPosition+ return $ AST (OBJECT pp) (mkPos ps pe)+ where+ objProperties = option [] $ commonPROPS (void $ lookAhead $ char '}')++--------------------------------------------------------------------------------+commonPROPS :: Monad m => ParsecT Text u m () -> ParsecT Text u m [Prop AST Pos]+commonPROPS end = do+ p <- parsePROP+ skipMany (parseCOMMENT >> whitespace)+ whitespace+ ps <- ([] <$ end) <|>+ do { optional $ do+ _ <- comma+ whitespace+ optional parseCOMMENT+ whitespace+ ; commonPROPS end+ }+ return (p:ps)++--------------------------------------------------------------------------------+parseIDENT :: Monad m => ParsecT Text u m (AST Pos)+parseIDENT = do+ p <- getPosition+ i <- ident++ let ti = pack i+ ls = fromIntegral $ sourceLine p+ cs = fromIntegral $ sourceColumn p+ ce1 = T.length ti+ a1 = AST (ID ti) (Line ls cs ce1)++ t <- optionMaybe (dot >> parseIDENT)++ let onTail (AST (ID is) (Line _ _ ce2))+ = AST (ID (ti <> "." <> is)) (Line ls cs ce2)+ onTail _+ = error "impossible situation onTail"++ return $ maybe a1 onTail t+ where+ dot = char '.'+ ident = P.identifier tokenParser++--------------------------------------------------------------------------------+parseVALUE :: Monad m => ParsecT Text u m (AST Pos)+parseVALUE =+ chainr1 inner $ do+ _ <- try $ ((many1 $ char ' ') >> notFollowedBy (oneOf "\n}],;"))+ return mkMerge+ where+ inner = parseLIST <|> parseOBJECT <|> parseSUBST <|> parseSTRING++ mkMerge x@(AST _ px) y@(AST _ py)+ = let ls = startLine px+ le = endLine py+ cs = startCol px+ ce = endCol py+ pos = if ls == le+ then Line ls cs ce+ else Multi ls le cs ce in+ AST (MERGE x y) pos++--------------------------------------------------------------------------------+parseLIST :: Monad m => ParsecT Text u m (AST Pos)+parseLIST = do+ ps <- getPosition+ vs <- between (char '[') (char ']') $ do+ skipMany (parseCOMMENT >> whitespace)+ whitespace+ commaSep $ do+ optional whitespace+ v <- parseVALUE+ skipMany (parseCOMMENT >> whitespace)+ optional whitespace+ return v++ pe <- getPosition+ return $ AST (LIST vs) (mkPos ps pe)+ where+ commaSep = P.commaSep tokenParser++--------------------------------------------------------------------------------+parseCOMMENT :: Monad m => ParsecT Text u m ()+parseCOMMENT = do+ _ <- string "#"+ skipMany (satisfy (/= '\n'))++--------------------------------------------------------------------------------+parseSUBST :: Monad m => ParsecT Text u m (AST Pos)+parseSUBST = do+ ps <- getPosition+ _ <- string "${"+ AST (ID i) _ <- parseIDENT+ _ <- char '}'+ pe <- getPosition+ return $ AST (SUBST i) (mkPos ps pe)++--------------------------------------------------------------------------------+-- | String literal parsing+--------------------------------------------------------------------------------+parseSTRING :: Monad m => ParsecT Text u m (AST Pos)+parseSTRING = parseMultiSTRING <|> parseSimpleSTRING <|> parseNakedSTRING++--------------------------------------------------------------------------------+-- | Parse anything between """, newlines included+parseMultiSTRING :: Monad m => ParsecT Text u m (AST Pos)+parseMultiSTRING = do+ ps <- getPosition+ s <- between (try $ tripleQuote) tripleQuote $ do+ let loop = do+ xs <- many $ noneOf "\""+ (xs <$ (lookAhead tripleQuote)) <|>+ (\c cs -> xs ++ c:cs) <$> char '"' <*> loop+ loop+ pe <- getPosition+ return $ AST (STRING $ pack s) (mkPos ps pe)+ where+ tripleQuote = string "\"\"\""++--------------------------------------------------------------------------------+-- | Parse anything between " as long as it doesn't include newline+parseSimpleSTRING :: Monad m => ParsecT Text u m (AST Pos)+parseSimpleSTRING = do+ ps <- getPosition+ s <- between simpleQuote simpleQuote (many $ noneOf "\"\n")+ pe <- getPosition+ return $ AST (STRING $ pack s) (mkPos ps pe)+ where+ simpleQuote = char '"'++--------------------------------------------------------------------------------+parseNakedSTRING :: Monad m => ParsecT Text u m (AST Pos)+parseNakedSTRING = do+ ps <- getPosition+ s <- many1 $ noneOf " #,{}[]\n"+ pe <- getPosition+ return $ AST (STRING $ pack s) (mkPos ps pe)++--------------------------------------------------------------------------------+-- | Utilities+--------------------------------------------------------------------------------+whitespace :: Monad m => ParsecT Text u m ()+whitespace = P.whiteSpace tokenParser++--------------------------------------------------------------------------------+comma :: Monad m => ParsecT Text u m ()+comma = void $ char ','++--------------------------------------------------------------------------------+mkPos :: SourcePos -> SourcePos -> Pos+mkPos ps pe =+ let ls = fromIntegral $ sourceLine ps+ cs = fromIntegral $ sourceColumn ps+ le = fromIntegral $ sourceLine pe+ ce = fromIntegral $ sourceColumn pe in+ if ls == le+ then Line ls cs ce+ else Multi ls le cs ce
+ Data/Config/Internal/Pos.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Config.Internal.Pos+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Config.Internal.Pos where++--------------------------------------------------------------------------------+data Pos+ = Line { lineStart :: Int+ , lineColStart :: Int+ , lineColEnd :: Int+ }+ | Multi { multiLineStart :: Int+ , multiLineEnd :: Int+ , multiColStart :: Int+ , multiColEnd :: Int+ }++--------------------------------------------------------------------------------+instance Show Pos where+ show = showPos++--------------------------------------------------------------------------------+startLine, startCol, endLine, endCol :: Pos -> Int+startLine (Line l _ _) = l+startLine (Multi l _ _ _) = l++startCol (Line _ c _) = c+startCol (Multi _ c _ _) = c++endLine (Line l _ _) = l+endLine (Multi _ l _ _) = l++endCol (Line _ _ c) = c+endCol (Multi _ _ _ c) = c++--------------------------------------------------------------------------------+showPos :: Pos -> String+showPos (Line s c n)+ = show s ++ ":" ++ show c ++ "-" ++ show n ++ ":"+showPos (Multi ls le cs ce)+ = show ls ++ "-" ++ show le ++ ":" ++ show cs ++ "-" ++ show ce ++ ":"
+ Data/Config/Internal/Reg.hs view
@@ -0,0 +1,29 @@+--------------------------------------------------------------------------------+-- |+-- Module : Data.Config.Internal.Reg+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Config.Internal.Reg where++--------------------------------------------------------------------------------+import Data.Map.Strict++--------------------------------------------------------------------------------+import Data.Text (Text)++--------------------------------------------------------------------------------+import Data.Config.Internal.AST+import Data.Config.Internal.Typed++--------------------------------------------------------------------------------+data Reg+ = Reg+ { regTypes :: !(Map Text Type)+ , regAST :: !(Map Text (AST Typed))+ }
+ Data/Config/Internal/Register.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Config.Internal.Register+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Config.Internal.Register (register, simplify) where++--------------------------------------------------------------------------------+import Data.List hiding (insert)++--------------------------------------------------------------------------------+import Data.Map.Strict+import Data.Text (Text, append)++--------------------------------------------------------------------------------+import Data.Config.Internal.AST+import Data.Config.Internal.Reg+import Data.Config.Internal.Typed++--------------------------------------------------------------------------------+type Rg = Map Text (AST Typed)++--------------------------------------------------------------------------------+register :: Map Text Type -> [Prop AST Typed] -> Reg+register tys ps = Reg tys (registerProps empty ps) where++--------------------------------------------------------------------------------+registerProps :: Rg -> [Prop AST Typed] -> Rg+registerProps mast []+ = mast+registerProps mast ((Prop n v):xs)+ = let (mast', v') = registerAST mast v in+ registerProps (insert n v' mast') xs++--------------------------------------------------------------------------------+registerAST :: Rg -> AST Typed -> (Rg, AST Typed)+registerAST reg ast@(AST expr t)+ = case expr of+ OBJECT ps -> registerObject reg t ps+ MERGE l r -> registerAST reg $ merging t l r+ _ -> (reg, ast)++--------------------------------------------------------------------------------+registerObject :: Rg -> Typed -> [Prop AST Typed] -> (Rg, AST Typed)+registerObject reg ty ps+ = (registerProps reg ps, AST (OBJECT ps) ty)++--------------------------------------------------------------------------------+simplify :: Reg -> AST Typed -> AST Typed+simplify conf ast@(AST expr ty)+ = case expr of+ LIST xs -> simplifyList conf ty xs+ SUBST s -> reg ! s+ MERGE l r -> simplifyMerge conf ty l r+ OBJECT ps -> simplifyObject conf ty ps+ _ -> ast+ where+ reg = regAST conf++--------------------------------------------------------------------------------+simplifyList :: Reg -> Typed -> [AST Typed] -> AST Typed+simplifyList conf ty xs+ = AST (LIST (fmap (simplify conf) xs)) ty++--------------------------------------------------------------------------------+simplifyMerge :: Reg -> Typed -> AST Typed -> AST Typed -> AST Typed+simplifyMerge conf ty l r+ = loop l r where+ loop ll@(AST la _) rr@(AST ra _)+ = case (la, ra) of+ (SUBST s, _) -> loop (reg ! s) rr+ (_, SUBST s) -> loop ll (reg ! s)+ (ID il, ID ir) -> mergeId ty il ir+ (STRING sl, STRING sr) -> mergeString ty sl sr+ (ID i, STRING s) -> mergeString ty i s+ (STRING s, ID i) -> mergeString ty s i+ (LIST xs, LIST vs) -> mergeList ty xs vs+ (OBJECT p, OBJECT v) -> mergeObject ty p v+ (MERGE ml mr, _) ->+ let ll' = simplifyMerge conf ty ml mr in+ loop ll' rr+ (_, MERGE ml mr) ->+ let rr' = simplifyMerge conf ty ml mr in+ loop ll rr'+ _ -> error absurdMsg++ reg = regAST conf+ absurdMsg+ = "impossible situation. Data.Config.Internal.Register.simplifyMerge"++--------------------------------------------------------------------------------+simplifyObject :: Reg -> Typed -> [Prop AST Typed] -> AST Typed+simplifyObject conf ty xs+ = let xs' = fmap (\(Prop n v) -> Prop n (simplify conf v)) xs in+ AST (OBJECT xs') ty++--------------------------------------------------------------------------------+merging :: Typed -> AST Typed -> AST Typed -> AST Typed+merging ty l r+ = loop l r where+ loop ll@(AST la _) rr@(AST ra _)+ = case (la, ra) of+ (ID il, ID ir) -> mergeId ty il ir+ (STRING sl, STRING sr) -> mergeString ty sl sr+ (ID i, STRING s) -> mergeString ty i s+ (STRING s, ID i) -> mergeString ty s i+ (LIST xs, LIST vs) -> mergeList ty xs vs+ (OBJECT p, OBJECT v) -> mergeObject ty p v+ (MERGE ml mr, _) ->+ let ll' = merging ty ml mr in+ loop ll' rr+ (_, MERGE ml mr) ->+ let rr' = merging ty ml mr in+ loop ll rr'+ _ -> AST (MERGE ll rr) ty++--------------------------------------------------------------------------------+mergeId :: Typed ->Text -> Text -> AST Typed+mergeId ty x y = AST (ID (x `append` " " `append` y)) ty++--------------------------------------------------------------------------------+mergeString :: Typed -> Text -> Text -> AST Typed+mergeString ty x y = AST (STRING (x `append` " " `append` y)) ty++--------------------------------------------------------------------------------+mergeList :: Typed -> [AST Typed] -> [AST Typed] -> AST Typed+mergeList ty xs vs = AST (LIST (xs ++ vs)) ty++--------------------------------------------------------------------------------+mergeObject :: Typed -> [Prop AST Typed] -> [Prop AST Typed] -> AST Typed+mergeObject ty ps vs = AST (OBJECT (nubBy go (vs ++ ps))) ty where+ go p p' = (propName p) == (propName p')
+ Data/Config/Internal/Rename.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Config.Internal.Rename+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Config.Internal.Rename (rename) where++--------------------------------------------------------------------------------+import Prelude hiding (null)++--------------------------------------------------------------------------------+import Data.Text (Text, append, null)++--------------------------------------------------------------------------------+import Data.Config.Internal.AST+import Data.Config.Internal.Pos+import Data.Config.Internal.Scoped++--------------------------------------------------------------------------------+infixr 7 <.>++--------------------------------------------------------------------------------+(<.>) :: Text -> Text -> Text+(<.>) a b+ | null a = b+ | otherwise = a `append` ("." `append` b)++--------------------------------------------------------------------------------+rename :: [Prop AST Pos] -> [Prop AST Scoped]+rename = fmap renameProp++--------------------------------------------------------------------------------+renameProp :: Prop AST Pos -> Prop AST Scoped+renameProp (Prop n v) = Prop n (renameAST n n v)++--------------------------------------------------------------------------------+renameAST :: Text -> Text -> AST Pos -> AST Scoped+renameAST prop scope (AST expr pos) =+ case expr of+ ID i -> AST (ID i) $ Scoped prop scope pos+ STRING i -> AST (STRING i) $ Scoped prop scope pos+ LIST xs -> renameList prop scope xs pos+ SUBST i -> AST (SUBST i) $ Scoped prop scope pos+ MERGE l r -> renameMerge prop scope l r pos+ OBJECT ps -> renameObject prop scope ps pos++--------------------------------------------------------------------------------+renameList :: Text -> Text -> [AST Pos] -> Pos -> AST Scoped+renameList prop scope xs pos+ = let xs' = fmap (renameAST prop "") xs in+ AST (LIST xs') $ Scoped prop scope pos++--------------------------------------------------------------------------------+renameMerge :: Text -> Text -> AST Pos -> AST Pos -> Pos -> AST Scoped+renameMerge prop scope l r pos+ = let sl = renameAST prop scope l+ sr = renameAST prop scope r in+ AST (MERGE sl sr) $ Scoped prop scope pos++--------------------------------------------------------------------------------+renameObject :: Text -> Text -> [Prop AST Pos] -> Pos -> AST Scoped+renameObject prop scope ps pos+ = let go (Prop n v)+ = let scope' = scope <.> n+ v' = renameAST prop scope' v in+ Prop scope' v'+ ps' = fmap go ps in+ AST (OBJECT ps') $ Scoped prop scope pos
+ Data/Config/Internal/Scoped.hs view
@@ -0,0 +1,26 @@+--------------------------------------------------------------------------------+-- |+-- Module : Data.Config.Internal.Scoped+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Config.Internal.Scoped where++--------------------------------------------------------------------------------+import Data.Text (Text)++--------------------------------------------------------------------------------+import Data.Config.Internal.Pos++--------------------------------------------------------------------------------+data Scoped+ = Scoped+ { scopeProp :: !Text+ , scopeName :: !Text+ , scopePos :: !Pos+ } deriving Show
+ Data/Config/Internal/Typecheck.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Config.Internal.Typecheck+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Config.Internal.Typecheck (typecheck) where++--------------------------------------------------------------------------------+import Control.Exception+import Data.Foldable+import Data.Typeable++--------------------------------------------------------------------------------+import Control.Monad.State.Strict+import qualified Data.Map.Strict as M+import Data.Text (Text, unpack)++--------------------------------------------------------------------------------+import Data.Config.Internal.AST+import Data.Config.Internal.Scoped+import Data.Config.Internal.Typed++--------------------------------------------------------------------------------+type TyM a = State TyState a+type Types = M.Map Text Type++--------------------------------------------------------------------------------+data TyState+ = TyState+ { _tyVarId :: !Int+ , _tyConstrs :: ![Constraint]+ , _tyErrors :: ![TyError]+ , _tyMap :: !Types+ }++--------------------------------------------------------------------------------+data Constraint+ = Equality (AST Scoped) (AST Scoped) Type Type+ | Existence (AST Scoped) Text++--------------------------------------------------------------------------------+data TyError+ = Mismatch (AST Scoped) Type Type+ | Undefined (AST Scoped) Text deriving Typeable++--------------------------------------------------------------------------------+newtype TypecheckError = TypecheckError [TyError] deriving Typeable++--------------------------------------------------------------------------------+instance Show TyError where+ show (Mismatch s etyp ctyp)+ = prop +++ ":" +++ show pos +++ " Expecting " +++ show etyp +++ " but having " +++ show ctyp+ where+ prop = unpack $ scopeProp $ astTag s+ pos = scopePos $ astTag s+ show (Undefined s t)+ = prop +++ ":" +++ show pos +++ " Property " +++ unpack t +++ " is undefined"+ where+ prop = unpack $ scopeProp $ astTag s+ pos = scopePos $ astTag s++--------------------------------------------------------------------------------+instance Show TypecheckError where+ show (TypecheckError xs)+ = foldMap (\x -> show x ++ "\n") xs++--------------------------------------------------------------------------------+instance Exception TyError++--------------------------------------------------------------------------------+instance Exception TypecheckError++--------------------------------------------------------------------------------+typecheck :: [Prop AST Scoped] -> Either SomeException (Types, [Prop AST Typed])+typecheck ps+ = let (ps', s) = runState (typecheckProps ps) start+ tys = _tyMap s in+ case _tyErrors s of+ errs | null errs -> Right (tys, ps')+ | otherwise -> Left $ SomeException $ TypecheckError errs+ where+ start+ = TyState+ { _tyVarId = resetVarId+ , _tyConstrs = []+ , _tyErrors = []+ , _tyMap = M.empty+ }++--------------------------------------------------------------------------------+resetVarId :: Int+resetVarId = 1++--------------------------------------------------------------------------------+typecheckProps :: [Prop AST Scoped] -> TyM [Prop AST Typed]+typecheckProps ps+ = do ps' <- mapM typecheckProp ps+ s <- get+ let constrs = _tyConstrs s++ typecheckConstrs constrs+ return ps'++--------------------------------------------------------------------------------+typecheckConstrs :: [Constraint] -> TyM ()+typecheckConstrs [] = return ()+typecheckConstrs (c:cs)+ = do tys <- gets _tyMap+ case c of+ Equality a b (RefTy t) y ->+ case M.lookup t tys of+ Nothing ->+ do tyReportError (Undefined a t)+ typecheckConstrs cs+ Just typ ->+ do tyRegisterType t typ+ typecheckConstrs (Equality a b typ y:cs)+ Equality a b x y@(RefTy _) ->+ typecheckConstrs (Equality b a y x:cs)+ Equality a b x y ->+ case checkType a b x y of+ Right match+ | match -> typecheckConstrs cs+ | otherwise ->+ do tyReportError (Mismatch a x y)+ typecheckConstrs cs+ _ -> error "impossible situation. typecheckConstrs"+ Existence a t ->+ case M.lookup t tys of+ Nothing ->+ do tyReportError (Undefined a t)+ typecheckConstrs cs+ _ -> typecheckConstrs cs++--------------------------------------------------------------------------------+typecheckProp :: Prop AST Scoped -> TyM (Prop AST Typed)+typecheckProp (Prop n v)+ = do v' <- typecheckAST v+ let vtype = typedType $ astTag v'++ tyRegisterType n vtype+ tySetVarId resetVarId+ return $ Prop n v'++--------------------------------------------------------------------------------+typecheckAST :: AST Scoped -> TyM (AST Typed)+typecheckAST ast@(AST expr scope)+ = case expr of+ ID i -> return $ AST (ID i) (Typed (LitTy StringLit) scope)+ STRING s -> return $ AST (STRING s) (Typed (LitTy StringLit) scope)+ LIST xs -> typecheckList scope xs+ SUBST s -> typecheckSubst ast s+ MERGE l r -> typecheckMerge scope l r+ OBJECT ps -> typecheckObject scope ps++--------------------------------------------------------------------------------+typecheckSubst :: AST Scoped -> Text -> TyM (AST Typed)+typecheckSubst ast key+ = do tyAddConstr (Existence ast key)+ return $ AST (SUBST key) (Typed (RefTy key) (astTag ast))++--------------------------------------------------------------------------------+typecheckList :: Scoped -> [AST Scoped] -> TyM (AST Typed)+typecheckList scope []+ = do vid <- tyGetAndIncrVarId+ let typ = ForAllTy vid (TyVarTy vid)+ return $ AST (LIST []) (Typed (AppTy ListTy typ) scope)+typecheckList scope (x:xs)+ = do x' <- typecheckAST x+ tyxs <- typecheckList scope xs+ let (LIST xs') = astExpr tyxs+ xtype = typedType $ astTag x'+ (AppTy _ xstype) = typedType $ astTag tyxs++ typecheckType x (AST (LIST xs) scope) xtype xstype+ return $ AST (LIST (x':xs')) (Typed (AppTy ListTy xtype) scope)++--------------------------------------------------------------------------------+typecheckMerge :: Scoped -> AST Scoped -> AST Scoped -> TyM (AST Typed)+typecheckMerge scope x y+ = do x' <- typecheckAST x+ y' <- typecheckAST y+ let xtype = typedType $ astTag x'+ ytype = typedType $ astTag y'++ typecheckType x y xtype ytype+ return $ AST (MERGE x' y') (Typed xtype scope)++--------------------------------------------------------------------------------+typecheckObject :: Scoped -> [Prop AST Scoped] -> TyM (AST Typed)+typecheckObject scope ps+ = do ps' <- mapM typecheckProp ps+ return $ AST (OBJECT ps') (Typed (LitTy ObjectLit) scope)++--------------------------------------------------------------------------------+typecheckType :: AST Scoped -> AST Scoped -> Type -> Type -> TyM ()+typecheckType a b tyexp typ+ = case checkType a b tyexp typ of+ Left c -> tyAddConstr c+ Right match+ | match -> return ()+ | otherwise -> tyReportError (Mismatch a tyexp typ)++--------------------------------------------------------------------------------+checkType :: AST Scoped -> AST Scoped -> Type -> Type -> Either Constraint Bool+checkType a b x@(RefTy _) y = Left (Equality a b x y)+checkType a b x y@(RefTy _) = Left (Equality a b x y)+checkType _ _ (ForAllTy _ _) _ = Right True+checkType _ _ _ (ForAllTy _ _) = Right True+checkType a b (AppTy x xs) (AppTy y ys) = checkAppType a b x xs y ys+checkType _ _ x y = Right (x == y)++--------------------------------------------------------------------------------+checkAppType :: AST Scoped+ -> AST Scoped+ -> Type+ -> Type+ -> Type+ -> Type+ -> Either Constraint Bool+checkAppType a b x xs y ys+ | x == y = checkType a b xs ys+ | otherwise = Right False++--------------------------------------------------------------------------------+-- | Utilities+--------------------------------------------------------------------------------+tyUpdateVarId :: (Int -> Int) -> TyState -> TyState+tyUpdateVarId k s+ = let p = _tyVarId s in s { _tyVarId = k p }++--------------------------------------------------------------------------------+tyUpdateErrors :: ([TyError] -> [TyError]) -> TyState -> TyState+tyUpdateErrors k s+ = let p = _tyErrors s in s { _tyErrors = k p }++--------------------------------------------------------------------------------+tyUpdateConstrs :: ([Constraint] -> [Constraint]) -> TyState -> TyState+tyUpdateConstrs k s+ = let p = _tyConstrs s in s { _tyConstrs = k p }++--------------------------------------------------------------------------------+tyUpdateTyMap :: (M.Map Text Type -> M.Map Text Type) -> TyState -> TyState+tyUpdateTyMap k s+ = let p = _tyMap s in s { _tyMap = k p }++--------------------------------------------------------------------------------+tyGetAndIncrVarId :: TyM Int+tyGetAndIncrVarId+ = do i <- gets _tyVarId+ modify (tyUpdateVarId succ)+ return i++--------------------------------------------------------------------------------+tySetVarId :: Int -> TyM ()+tySetVarId i = modify (tyUpdateVarId (const i))++--------------------------------------------------------------------------------+tyAddConstr :: Constraint -> TyM ()+tyAddConstr c = modify (tyUpdateConstrs (c:))++--------------------------------------------------------------------------------+tyReportError :: TyError -> TyM ()+tyReportError e = modify (tyUpdateErrors (e:))++--------------------------------------------------------------------------------+tyRegisterType :: Text -> Type -> TyM ()+tyRegisterType k t = modify (tyUpdateTyMap (M.insert k t))
+ Data/Config/Internal/Typed.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Config.Internal.Typed+-- Copyright : (C) 2014 Yorick Laupa+-- License : (see the file LICENSE)+--+-- Maintainer : Yorick Laupa <yo.eight@gmail.com>+-- Stability : provisional+-- Portability : non-portable+--+--------------------------------------------------------------------------------+module Data.Config.Internal.Typed where++--------------------------------------------------------------------------------+import Data.Array+import Data.Text (Text, unpack)++--------------------------------------------------------------------------------+import Data.Config.Internal.Scoped++--------------------------------------------------------------------------------+type Var = Int++--------------------------------------------------------------------------------+data Type+ = TyVarTy Var+ | ListTy+ | AppTy Type Type+ | ForAllTy Var Type+ | RefTy Text+ | LitTy TypeLit+ deriving Eq++--------------------------------------------------------------------------------+data TypeLit+ = StringLit+ | ObjectLit+ deriving Eq++--------------------------------------------------------------------------------+data Typed+ = Typed+ { typedType :: Type+ , typedScope :: Scoped+ }++--------------------------------------------------------------------------------+instance Show Type where+ show = showType++--------------------------------------------------------------------------------+letters :: Array Int String+letters+ = array (1, 26) (fmap (\(i, c) -> (i, [c])) $ zip [1..] ['a'..'z'])++--------------------------------------------------------------------------------+showType :: Type -> String+showType (TyVarTy v)+ = letters ! v+showType ListTy+ = "List"+showType (AppTy h l)+ = showType h ++ "[" ++ showType l ++ "]"+showType (ForAllTy v t)+ = "forall " ++ (letters ! v) ++ ". " ++ showType t+showType (RefTy t)+ = "${" ++ unpack t ++ "} type"+showType (LitTy l)+ = case l of+ StringLit -> "String"+ ObjectLit -> "Object"++--------------------------------------------------------------------------------+stringType :: Type+stringType = LitTy StringLit++--------------------------------------------------------------------------------+objectType :: Type+objectType = LitTy ObjectLit++--------------------------------------------------------------------------------+someListType :: Type+someListType = ForAllTy 1 (AppTy ListTy (TyVarTy 1))
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Yorick Laupa++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Yorick Laupa nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ deiko-config.cabal view
@@ -0,0 +1,43 @@+name: deiko-config+version: 0.5.0.0+synopsis: Small and typesafe configuration library.+description: Small and typesafe configuration library. The library provides good error messages and comes with a bottom-up typechecker in order to catch more configuration errors.+license: BSD3+license-file: LICENSE+author: Yorick Laupa+maintainer: yo.eight@gmail.com+homepage: http://github.com/YoEight/deiko-config+bug-reports: https://github.com/YoEight/deiko-config/issues+copyright: Copyright (C) 2014 Yorick Laupa+stability: experimental+category: Data+build-type: Simple+cabal-version: >=1.18++source-repository head+ type: git+ location: git://github.com/YoEight/deiko-config.git++library+ default-language: Haskell2010+ exposed-modules: Data.Config+ other-modules: Data.Config.Internal.AST+ Data.Config.Internal.DkM+ Data.Config.Internal.Parser+ Data.Config.Internal.Pos+ Data.Config.Internal.Reg+ Data.Config.Internal.Register+ Data.Config.Internal.Rename+ Data.Config.Internal.Scoped+ Data.Config.Internal.Typed+ Data.Config.Internal.Typecheck+ build-depends:+ base >= 4.7 && < 5,+ array >= 0.5 && < 0.6,+ mtl >= 2.0 && < 3.0,+ parsec >= 3.1.2,+ text >= 1.0 && < 1.2,+ transformers >= 0.3 && < 0.6,+ containers,+ exceptions+ ghc-options: -Wall