diff --git a/Data/Config.hs b/Data/Config.hs new file mode 100644 --- /dev/null +++ b/Data/Config.hs @@ -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 +-- 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 ++ " " diff --git a/Data/Config/Internal/AST.hs b/Data/Config/Internal/AST.hs new file mode 100644 --- /dev/null +++ b/Data/Config/Internal/AST.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE FlexibleContexts #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Config.Internal.AST +-- Copyright : (C) 2014 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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 diff --git a/Data/Config/Internal/DkM.hs b/Data/Config/Internal/DkM.hs new file mode 100644 --- /dev/null +++ b/Data/Config/Internal/DkM.hs @@ -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 +-- 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) diff --git a/Data/Config/Internal/Parser.hs b/Data/Config/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/Data/Config/Internal/Parser.hs @@ -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 +-- 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 diff --git a/Data/Config/Internal/Pos.hs b/Data/Config/Internal/Pos.hs new file mode 100644 --- /dev/null +++ b/Data/Config/Internal/Pos.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Config.Internal.Pos +-- Copyright : (C) 2014 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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 ++ ":" diff --git a/Data/Config/Internal/Reg.hs b/Data/Config/Internal/Reg.hs new file mode 100644 --- /dev/null +++ b/Data/Config/Internal/Reg.hs @@ -0,0 +1,29 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Config.Internal.Reg +-- Copyright : (C) 2014 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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)) + } diff --git a/Data/Config/Internal/Register.hs b/Data/Config/Internal/Register.hs new file mode 100644 --- /dev/null +++ b/Data/Config/Internal/Register.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Config.Internal.Register +-- Copyright : (C) 2014 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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') diff --git a/Data/Config/Internal/Rename.hs b/Data/Config/Internal/Rename.hs new file mode 100644 --- /dev/null +++ b/Data/Config/Internal/Rename.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Config.Internal.Rename +-- Copyright : (C) 2014 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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 diff --git a/Data/Config/Internal/Scoped.hs b/Data/Config/Internal/Scoped.hs new file mode 100644 --- /dev/null +++ b/Data/Config/Internal/Scoped.hs @@ -0,0 +1,26 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Config.Internal.Scoped +-- Copyright : (C) 2014 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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 diff --git a/Data/Config/Internal/Typecheck.hs b/Data/Config/Internal/Typecheck.hs new file mode 100644 --- /dev/null +++ b/Data/Config/Internal/Typecheck.hs @@ -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 +-- 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)) diff --git a/Data/Config/Internal/Typed.hs b/Data/Config/Internal/Typed.hs new file mode 100644 --- /dev/null +++ b/Data/Config/Internal/Typed.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Config.Internal.Typed +-- Copyright : (C) 2014 Yorick Laupa +-- License : (see the file LICENSE) +-- +-- Maintainer : Yorick Laupa +-- 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)) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/deiko-config.cabal b/deiko-config.cabal new file mode 100644 --- /dev/null +++ b/deiko-config.cabal @@ -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