From 7d8615aaf7e79fb5dd8d06654bcf0028bc55d606 Mon Sep 17 00:00:00 2001 From: John Wiegley Date: Sat, 28 Jun 2014 16:30:47 -0700 Subject: [PATCH] First revision --- Nix.hs | 378 ++++++++++++++++++++++++++++++++++++++++++++++++++++ default.nix | 60 +++++++++ 2 files changed, 438 insertions(+) create mode 100644 Nix.hs create mode 100644 default.nix diff --git a/Nix.hs b/Nix.hs new file mode 100644 index 0000000..fe1bc4b --- /dev/null +++ b/Nix.hs @@ -0,0 +1,378 @@ +--{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +--{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +--{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +--{-# LANGUAGE ViewPatterns #-} + +module Nix where + +import Control.Applicative +import Control.Monad hiding (forM_) +--import Control.Monad.IO.Class +--import Control.Monad.Trans.Class +--import Control.Monad.Trans.Control +--import Control.Monad.Trans.Either +import Data.Char +import Data.Data +import Data.Foldable +import Data.Map (Map) +import qualified Data.Map as Map +--import Data.Monoid +import Data.Text hiding (concat, concatMap, head, map) +import Data.Text.IO +--import Data.Traversable +--import Data.Typeable +import GHC.Generics +import qualified Prelude +import Prelude hiding (readFile, concat, concatMap, elem) +import System.Environment +import System.IO.Memoize +-- import Text.Parsec hiding ((<|>), many, optional) +-- import Text.Parsec.Text +import Text.Trifecta +import Text.Parser.LookAhead + +--import Debug.Trace +trace :: a -> b -> b +trace _ x = x + +loeb :: Functor f => f (f a -> a) -> f a +loeb xs = ys where ys = fmap ($ ys) xs +{-# INLINE loeb #-} + +data NAtom + = NStr Text + | NInt Integer + | NPath FilePath + | NBool Bool + | NSym Text + | NNull + deriving (Eq, Ord, Generic, Typeable, Data) + +instance Show (NAtom) where + show (NStr s) = show s + show (NInt i) = show i + show (NPath p) = show p + show (NBool b) = if b then "true" else "false" + show (NSym s) = unpack s + show NNull = "null" + +atomText :: NAtom -> Text +atomText (NStr s) = s +atomText (NInt i) = pack (show i) +atomText (NPath p) = pack p +atomText (NBool b) = if b then "true" else "false" +atomText (NSym s) = s +atomText NNull = "null" + +dumpAtom :: NAtom -> String +dumpAtom (NStr s) = "NStr " ++ show s +dumpAtom (NInt i) = "NInt " ++ show i +dumpAtom (NPath p) = "NPath " ++ show p +dumpAtom (NBool b) = "NBool " ++ show b +dumpAtom (NSym s) = "NSym " ++ show s +dumpAtom NNull = "NNull" + +data NExprF r + = NConstant NAtom + + | NList [r] + | NConcat [r] + -- ^ A "concat" is a list of things which must combine to form a string. + | NArgSet (Map Text (Maybe r)) + | NSet Bool [(r, r)] + + | NLet r r + | NIf r r r + | NWith r r + | NAssert r r + + | NVar r + | NApp r r + | NAbs r r + -- ^ The untyped lambda calculus core + deriving (Ord, Eq, Generic, Typeable, Data) + +instance Functor NExprF where + fmap _ (NConstant a) = NConstant a + fmap f (NList r) = NList (fmap f r) + fmap f (NConcat r) = NConcat (fmap f r) + fmap f (NArgSet h) = NArgSet (fmap (fmap f) h) + fmap f (NSet b h) = NSet b $ map go h + where go (k, v) = (f k, f v) + fmap f (NLet r r1) = NLet (f r) (f r1) + fmap f (NIf r r1 r2) = NIf (f r) (f r1) (f r2) + fmap f (NWith r r1) = NWith (f r) (f r1) + fmap f (NAssert r r1) = NAssert (f r) (f r1) + fmap f (NVar r) = NVar (f r) + fmap f (NApp r r1) = NApp (f r) (f r1) + fmap f (NAbs r r1) = NAbs (f r) (f r1) + +newtype Fix (f :: * -> *) = Fix { outF :: f (Fix f) } + +cata :: Functor f => (f a -> a) -> Fix f -> a +cata f = f . fmap (cata f) . outF + +type NExpr = Fix NExprF + +newtype NEnv a = NEnv { getEnv :: Map a a } + +instance Show f => Show (NExprF f) where + show (NConstant x) = show x + + show (NList l) = "[ " ++ go l ++ " ]" + where + go [] = "" + go [x] = show x + go (x:xs) = show x ++ ", " ++ go xs + + show (NConcat l) = go l + where + go [] = "" + go [x] = show x + go (x:xs) = show x ++ " ++ " ++ go xs + + show (NArgSet h) = "{ " ++ go (Map.toList h) ++ " }" + where + go [] = "" + go [x] = showArg x + go (x:xs) = showArg x ++ ", " ++ go xs + + showArg (k, Nothing) = unpack k + showArg (k, Just v) = unpack k ++ " ? " ++ show v + + show (NSet b xs) = (if b then "rec " else "") + ++ "{ " ++ concatMap go xs ++ " }" + where + go (k, v) = show k ++ " = " ++ show v ++ "; " + + show (NLet v e) = "let " ++ show v ++ "; " ++ show e + show (NIf i t e) = "if " ++ show i ++ " then " ++ show t ++ " else " ++ show e + show (NWith c v) = "with " ++ show c ++ "; " ++ show v + show (NAssert e v) = "assert " ++ show e ++ "; " ++ show v + + show (NVar v) = show v + show (NApp f x) = show f ++ " " ++ show x + show (NAbs a b) = show a ++ ": " ++ show b + +dumpExpr :: NExpr -> String +dumpExpr = cata phi where + phi (NConstant x) = "NConstant " ++ dumpAtom x + phi (NList l) = "NList [" ++ show l ++ "]" + phi (NConcat l) = "NConcat " ++ show l + phi (NArgSet xs) = "NArgSet " ++ show xs + phi (NSet b xs) = "NSet " ++ show b ++ " " ++ show xs + phi (NLet v e) = "NLet " ++ v ++ " " ++ e + phi (NIf i t e) = "NIf " ++ i ++ " " ++ t ++ " " ++ e + phi (NWith c v) = "NWith " ++ c ++ " " ++ v + phi (NAssert e v) = "NAssert " ++ e ++ " " ++ v + phi (NVar v) = "NVar " ++ v + phi (NApp f x) = "NApp " ++ f ++ " " ++ x + phi (NAbs a b) = "NAbs " ++ a ++ " " ++ b + +mkInt :: Integer -> NExpr +mkInt = Fix . NConstant . NInt + +mkStr :: Text -> NExpr +mkStr = Fix . NConstant . NStr + +mkPath :: FilePath -> NExpr +mkPath = Fix . NConstant . NPath + +mkSym :: Text -> NExpr +mkSym = Fix . NConstant . NSym + +mkBool :: Bool -> NExpr +mkBool = Fix . NConstant . NBool + +mkNull :: NExpr +mkNull = Fix (NConstant NNull) + +instance Show (Fix NExprF) where + show (Fix f) = show f + +instance Eq (Fix NExprF) where + Fix x == Fix y = x == y + +instance Ord (Fix NExprF) where + compare (Fix x) (Fix y) = compare x y + +-- | Given an argument passed to a function, "fit" it within the arguments as +-- specified by the definition of the function. +-- +-- For example, a function may be defined as @{ foo, bar }: body@, in which +-- case the argument must be a set that provides at least the keys @foo@ and +-- @bar@. +fitArgument :: NExpr -> NExpr -> NExpr +fitArgument _ _ = undefined + +nixApp :: Parser NExpr +nixApp = go <$> some (whiteSpace *> nixTerm True) + where + go [x] = x + go (f:xs) = Fix (NApp f (go xs)) + +nixTerm :: Bool -> Parser NExpr +nixTerm allowLambdas = choice + [ mkInt <$> decimal "integer" + + , (string "true" *> pure (mkBool True)) "bool" + , (string "false" *> pure (mkBool False)) "bool" + , (string "null" *> pure mkNull) "null" + + , between (symbolic '(') (symbolic ')') nixApp + "parens" + + , between (symbolic '[') (symbolic ']') + (Fix . NList <$> many (nixTerm False)) + "list" + + , try (do chars <- some (satisfy isPathChar) + trace ("Path chars: " ++ show chars) $ return () + guard ('/' `elem` chars) + return $ mkPath chars) + + , maybeSetOrLambda allowLambdas + ] + +maybeSetOrLambda :: Bool -> Parser NExpr +maybeSetOrLambda allowLambdas = do + trace "maybeSetOrLambda" $ return () + x <- try (lookAhead symName) + <|> try (lookAhead (singleton <$> char '{')) + <|> return "" + if x == "rec" || x == "{" + then setOrArgs + else do + trace "might still have a lambda" $ return () + y <- try (lookAhead (symName *> whiteSpace *> symbolic ':' + *> return True)) + <|> return False + trace ("results are = " ++ show y) $ return () + if y + then if allowLambdas + then trace "looking for set" $ setOrArgs + else error "Unexpected lambda" + else trace "just want a string" $ (keyName "string") + +isPathChar :: Char -> Bool +isPathChar c = isAlpha c || c `Prelude.elem` ".:/" + +oneChar :: Parser NExpr +oneChar = mkStr . singleton <$> anyChar + +stringChar :: Parser NExpr +stringChar = char '\\' *> oneChar + <|> (string "${" *> nixApp <* char '}') + <|> (mkStr . pack <$> many (noneOf "\"\\")) + +symName :: Parser Text +symName = do + trace "symName" $ return () + chars <- some (satisfy (\c -> isAlpha c || c == '.')) + trace ("chars = " ++ show chars) $ return () + guard (isLower (head chars)) + trace ("chars2 = " ++ show chars) $ return () + return $ pack (trace ("chars: " ++ show chars) chars) + +stringish :: Parser NExpr +stringish + = (char '"' *> + (Fix . NConcat <$> manyTill stringChar (char '"'))) + <|> (char '$' *> between (symbolic '{') (symbolic '}') nixApp) + +keyName :: Parser NExpr +keyName = (stringish <|> (mkSym <$> symName)) <* whiteSpace + +nvPair :: Parser (NExpr, NExpr) +nvPair = (,) <$> keyName + <*> (symbolic '=' *> nixApp) + +argExpr :: Parser NExpr +argExpr = (Fix . NArgSet . Map.fromList <$> argList) + <|> ((mkSym <$> symName) "argname") + +argList :: Parser [(Text, Maybe NExpr)] +argList = between (symbolic '{') (symbolic '}') + ((argName <* whiteSpace) `sepBy` symbolic ',') + "arglist" + +argName :: Parser (Text, Maybe NExpr) +argName = (,) <$> (symName <* whiteSpace) + <*> optional (try (symbolic '?' *> nixApp)) + +whiteSymbolic :: Char -> Parser Char +whiteSymbolic c = whiteSpace *> symbolic c + +lookaheadForSet :: Parser Bool +lookaheadForSet = do + trace "lookaheadForSet" $ return () + x <- (symbolic '{' *> return True) <|> return False + if not x then return x else do + y <- (keyName *> return True) <|> return False + if not y then return y else + (symbolic '=' *> return True) <|> return False + +setOrArgs :: Parser NExpr +setOrArgs = do + trace "setOrArgs" $ return () + sawRec <- try (symbol "rec" *> pure True) <|> pure False + trace ("Do we have sawRec: " ++ show sawRec) $ return () + haveSet <- + if sawRec + then return True + else try (lookAhead lookaheadForSet) + trace ("Do we have a set: " ++ show haveSet) $ return () + if haveSet + then between (symbolic '{') (symbolic '}') + (Fix . NSet sawRec <$> nvPair `endBy` symbolic ';') + "set" + else do + trace "parsing arguments" $ return () + args <- argExpr "arguments" + trace ("args: " ++ show args) $ return () + symbolic ':' *> ((Fix .) . NAbs <$> pure args <*> nixApp) + <|> pure args + +-- symbol :: String -> Parser String +-- symbol str = string str <* whiteSpace + +-- symbolic :: Char -> Parser Char +-- symbolic c = char c <* whiteSpace + +-- decimal :: Parser Integer +-- decimal = read <$> some digit + +-- whiteSpace :: Parser () +-- whiteSpace = spaces + +-- parseFromFile :: Parser a -> FilePath -> IO (Maybe a) +-- parseFromFile p path = do +-- txt <- readFile path +-- case parse p path txt of +-- Left e -> error (show e) +-- Right r -> return $ Just r + +nix :: FilePath -> IO () +nix path = do + mpkgs <- parseFromFile nixApp path + forM_ mpkgs $ \pkgs -> do + mem <- once (return pkgs) + res <- join $ loeb (return (const mem)) + Prelude.print res + +main :: IO () +main = do + [path] <- getArgs + nix path diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..b787016 --- /dev/null +++ b/default.nix @@ -0,0 +1,60 @@ +{ cabal +, aeson +, conduit +, conduitCombinators +, conduitExtra +, logging +, monadLogger +, ioStorage +, lens +, optparseApplicative +, parallelIo +, regexPosix +, safe +, shelly +, systemFileio +, systemFilepath +, temporary +, text +, textFormat +, time +, unorderedContainers +, yaml +}: + +cabal.mkDerivation (self: { + pname = "pushme"; + version = "2.0.0"; + src = ./.; + isLibrary = false; + isExecutable = true; + buildDepends = [ + aeson + conduit + conduitCombinators + conduitExtra + logging + monadLogger + ioStorage + lens + optparseApplicative + parallelIo + regexPosix + safe + shelly + systemFileio + systemFilepath + temporary + text + textFormat + time + unorderedContainers + yaml + ]; + meta = { + homepage = "https://github.com/jwiegley/pushme"; + description = "Tool to synchronize multiple directories with rsync, zfs or git-annex"; + license = self.stdenv.lib.licenses.bsd3; + platforms = self.ghc.meta.platforms; + }; +})