antiquotes + improve pretty printer + restructure
This commit improves the pretty printing and adds support for
antiquotes. It also fixes an issue with the parser that caused `[if true
then false else true]` to parse successfully, even though that is not a
valid nix expression.
The pretty printer now produces a lot more readable output and also
supports operator precedences.
The changes to the AST are:
* strings are no longer atomic, because they may contain other
expressions in the form of antiquotes. For strings, the new type
NString is introduced and the constructor NStr is added to NExprF
* the unused NVar constructor of NExprF is removed
* operators are now represented uniformly so that the pretty printer
can lookup information about operators (in particular, associativity
and precedence)
* the NArgs constructor is removed. The first argument of the NAbs
constructor now directly represents the lambda arguments.
* the select and the hasattr operator are moved into NExpr because
they are special (they only accept a selector as second argument, and
select also supports 'or')
The list of operators is now in Types.hs and Parser.hs re-uses that list
to build the parser. This is required because the pretty printer and
parser both need access to operator precedences.
Parser and evaluator also support dynamic attributes and attributes with
dots now. As an example, `let b.a = 3; b.c = { e = {}; }; b.c.e.${"f"} =
4; in b` is parsed and evaluated correctly. As a side effect, NSym
values now don't evaluate to themselves anymore, but instead to the
value retrieved by looking up the variable in the current environment.
Support for evaluating `inherit` bindings was removed because it was
broken before (`{ inherit a; }` would evaluate to a set where the
attribute `a` had the value `NSym a`, not the value of `a`).
The manual Show instances for the AST were replaced by derived
ones, because the manual instances often resulted in output were it was
difficult to determine the missing parentheses.
This commit is contained in:
Benno Fünfstück
parent
4550c1a05a
commit
a6bacc3150
1
Nix.hs
1
Nix.hs
|
|
@ -17,6 +17,7 @@ nix path = do
|
|||
Success n -> do
|
||||
displayIO stdout $ renderPretty 0.4 80 (prettyNix n)
|
||||
top <- evalExpr n (Fix (NVSet Map.empty)) -- evaluate top level
|
||||
putStrLn ""
|
||||
print top
|
||||
|
||||
main :: IO ()
|
||||
|
|
|
|||
97
Nix/Eval.hs
97
Nix/Eval.hs
|
|
@ -2,55 +2,54 @@ module Nix.Eval where
|
|||
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
import Control.Monad hiding (mapM)
|
||||
import Control.Monad hiding (mapM, sequence)
|
||||
import Data.Foldable (foldl')
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Traversable as T
|
||||
import Nix.Types
|
||||
import Prelude hiding (mapM)
|
||||
import Prelude hiding (mapM, sequence)
|
||||
|
||||
buildArgument :: NValue -> NValue -> NValue
|
||||
buildArgument paramSpec arg =
|
||||
-- Having the typed lambda calculus would make this code much safer.
|
||||
Fix $ NVSet $ case paramSpec of
|
||||
Fix (NVArgSet s) ->
|
||||
case arg of
|
||||
Fix (NVSet s') ->
|
||||
Map.foldlWithKey' (go s') Map.empty s
|
||||
_ -> error "Unexpected function environment"
|
||||
Fix (NVConstant (NSym name)) -> Map.singleton name arg
|
||||
_ -> error $ "Unexpected param spec: " ++ show paramSpec
|
||||
buildArgument :: Formals NValue -> NValue -> NValue
|
||||
buildArgument paramSpec arg = either error (Fix . NVSet) $ case paramSpec of
|
||||
FormalName name -> return $ Map.singleton name arg
|
||||
FormalSet s -> lookupParamSet s
|
||||
FormalLeftAt name s -> Map.insert name arg <$> lookupParamSet s
|
||||
FormalRightAt s name -> Map.insert name arg <$> lookupParamSet s
|
||||
where
|
||||
go env m k v = case Map.lookup k env of
|
||||
Nothing
|
||||
| Just v' <- v -> Map.insert k v' m
|
||||
| otherwise -> error $ "Could not find " ++ show k
|
||||
Just v' -> Map.insert k v' m
|
||||
go env k def = maybe (Left err) return $ Map.lookup k env <|> def
|
||||
where err = "Could not find " ++ show k
|
||||
|
||||
lookupParamSet (FormalParamSet s) = case arg of
|
||||
Fix (NVSet env) -> Map.traverseWithKey (go env) s
|
||||
_ -> Left "Unexpected function environment"
|
||||
|
||||
evalExpr :: NExpr -> NValue -> IO NValue
|
||||
evalExpr = cata phi
|
||||
where
|
||||
phi :: NExprF (NValue -> IO NValue) -> NValue -> IO NValue
|
||||
phi (NConstant (NSym var)) = \env -> case env of
|
||||
Fix (NVSet s) -> maybe err return $ Map.lookup var s
|
||||
_ -> error "invalid evaluation environment"
|
||||
where err = error ("Undefined variable: " ++ show var)
|
||||
phi (NConstant x) = const $ return $ Fix $ NVConstant x
|
||||
phi (NStr str) = fmap (Fix . NVStr) . flip evalString str
|
||||
phi (NOper _x) = error "Operators are not yet defined"
|
||||
phi (NSelect _x _attr _or) = error "Select expressions are not yet supported"
|
||||
phi (NHasAttr _x _attr) = error "Has attr expressions are not yet supported"
|
||||
|
||||
phi (NList l) = \env ->
|
||||
Fix . NVList <$> mapM ($ env) l
|
||||
|
||||
-- phi (NConcat l) = \env ->
|
||||
-- Fix . NVConstant . NStr . T.concat
|
||||
-- <$> mapM (fmap valueText . ($ env)) l
|
||||
|
||||
phi (NArgs s) = \env -> Fix . NVArgSet <$> mapM (T.sequence . fmap ($ env)) (formalsAsMap s)
|
||||
|
||||
-- TODO: recursive sets
|
||||
phi (NSet _b binds) = \env ->
|
||||
Fix . NVSet <$> evalBinds env binds
|
||||
Fix . NVSet <$> evalBinds True env binds
|
||||
|
||||
-- TODO: recursive binding
|
||||
phi (NLet binds e) = \env -> case env of
|
||||
(Fix (NVSet env')) -> do
|
||||
letenv <- evalBinds env binds
|
||||
letenv <- evalBinds False env binds
|
||||
let newenv = Map.union letenv env'
|
||||
e . Fix . NVSet $ newenv
|
||||
_ -> error "invalid evaluation environment"
|
||||
|
|
@ -77,8 +76,6 @@ evalExpr = cata phi
|
|||
(NVConstant (NBool False)) -> error "assertion failed"
|
||||
_ -> error "assertion condition must be boolean"
|
||||
|
||||
phi (NVar _v) = error "var: not implemented"
|
||||
|
||||
phi (NApp fun x) = \env -> do
|
||||
fun' <- fun env
|
||||
case fun' of
|
||||
|
|
@ -92,14 +89,42 @@ evalExpr = cata phi
|
|||
-- jww (2014-06-28): arglists should not receive the current
|
||||
-- environment, but rather should recursively view their own arg
|
||||
-- set
|
||||
args <- a env
|
||||
args <- traverse ($ env) a
|
||||
return $ Fix $ NVFunction args b
|
||||
|
||||
evalBinds :: NValue -> [Binding (NValue -> IO NValue)] ->
|
||||
evalString :: NValue -> NString (NValue -> IO NValue) -> IO Text
|
||||
evalString env (NString parts)
|
||||
= Text.concat <$> mapM (runAntiquoted return (fmap valueText . ($ env))) parts
|
||||
|
||||
evalBinds :: Bool -> NValue -> [Binding (NValue -> IO NValue)] ->
|
||||
IO (Map.Map Text NValue)
|
||||
evalBinds env xs =
|
||||
Map.fromList <$> mapM (fmap (first valueText)) (concatMap go xs) where
|
||||
go :: Binding (NValue -> IO NValue) -> [IO (NValue, NValue)]
|
||||
go (NamedVar x y) = [liftM2 (,) (x env) (y env)]
|
||||
go (Inherit ys) = map (\y -> (,) <$> y env <*> y env) ys
|
||||
go (ScopedInherit x ys) = map (\y -> (,) <$> x env <*> y env) ys
|
||||
evalBinds allowDynamic env xs = buildResult <$> sequence (concatMap go xs) where
|
||||
buildResult :: [([Text], NValue)] -> Map.Map Text NValue
|
||||
buildResult = foldl' insert Map.empty . map (first reverse) where
|
||||
insert _ ([], _) = error "invalid selector with no components"
|
||||
insert m (p:ps, v) = modifyPath ps (insertIfNotMember p v) where
|
||||
alreadyDefinedErr = error $ "attribute " ++ attr ++ " already defined"
|
||||
attr = show $ Text.intercalate "." $ reverse (p:ps)
|
||||
|
||||
modifyPath :: [Text] -> (Map.Map Text NValue -> Map.Map Text NValue) -> Map.Map Text NValue
|
||||
modifyPath [] f = f m
|
||||
modifyPath (x:parts) f = modifyPath parts $ \m' -> case Map.lookup x m' of
|
||||
Nothing -> Map.singleton x $ g Map.empty
|
||||
Just (Fix (NVSet m'')) -> Map.insert x (g m'') m'
|
||||
Just _ -> alreadyDefinedErr
|
||||
where g = Fix . NVSet . f
|
||||
|
||||
insertIfNotMember k x m'
|
||||
| Map.notMember k m' = Map.insert k x m'
|
||||
| otherwise = alreadyDefinedErr
|
||||
|
||||
-- TODO: Inherit
|
||||
go :: Binding (NValue -> IO NValue) -> [IO ([Text], NValue)]
|
||||
go (NamedVar x y) = [liftM2 (,) (evalSelector allowDynamic env x) (y env)]
|
||||
|
||||
evalSelector :: Bool -> NValue -> NSelector (NValue -> IO NValue) -> IO [Text]
|
||||
evalSelector dyn e = mapM evalKeyName where
|
||||
evalKeyName (StaticKey k) = return k
|
||||
evalKeyName (DynamicKey k)
|
||||
| dyn = runAntiquoted (evalString e) (fmap valueText . ($ e)) k
|
||||
| otherwise = error "dynamic attribute not allowed in this context"
|
||||
|
|
|
|||
150
Nix/Parser.hs
150
Nix/Parser.hs
|
|
@ -6,55 +6,61 @@ import Control.Applicative
|
|||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Foldable
|
||||
import Data.List (foldl1')
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text hiding (head, map, foldl1')
|
||||
import Data.Text hiding (head, map, foldl1', foldl')
|
||||
import Nix.Types
|
||||
import Nix.Parser.Library
|
||||
import Prelude hiding (elem)
|
||||
|
||||
-- | The lexer for this parser is defined in 'Nix.Parser.Library'.
|
||||
nixApp :: Parser NExpr
|
||||
nixApp = go <$> someTill (whiteSpace *> nixExpr True) (try (lookAhead stop))
|
||||
nixApp = go <$> some (whiteSpace *> nixExpr)
|
||||
where
|
||||
go [] = error "some has failed us"
|
||||
go [x] = x
|
||||
go (f:x:xs) = go (Fix (NApp f x) : xs)
|
||||
|
||||
stop = () <$ oneOf "=,;])}" <|> stopWords <|> eof
|
||||
nixExpr :: Parser NExpr
|
||||
nixExpr = nixExprWith nixOperators
|
||||
|
||||
nixExpr :: Bool -> Parser NExpr
|
||||
nixExpr = buildExpressionParser table . nixTermOrAttr
|
||||
nixExprWith :: [Either NSpecialOp [NOperatorDef]] -> Parser NExpr
|
||||
nixExprWith = foldl' makeParser nixTerm
|
||||
where
|
||||
table =
|
||||
[ [ prefix "-" NNeg ]
|
||||
-- , [ prefix "~" NSubpath ] -- deprecated
|
||||
, [ binary "?" NHasAttr AssocNone ]
|
||||
, [ binary "++" NConcat AssocRight ]
|
||||
, [ binary "*" NMult AssocLeft, binary "/" NDiv AssocLeft ]
|
||||
, [ binary "+" NPlus AssocLeft, binary "-" NMinus AssocLeft ]
|
||||
, [ prefix "!" NNot ]
|
||||
, [ binary "//" NUpdate AssocRight ]
|
||||
, [ binary "<" NLt AssocLeft, binary ">" NGt AssocLeft
|
||||
, binary "<=" NLte AssocLeft, binary ">=" NGte AssocLeft ]
|
||||
, [ binary "==" NEq AssocNone, binary "!=" NNEq AssocNone ]
|
||||
, [ binary "&&" NAnd AssocLeft ]
|
||||
, [ binary "||" NOr AssocLeft ]
|
||||
, [ binary "->" NImpl AssocNone ]
|
||||
]
|
||||
makeParser term (Left NSelectOp) = nixSelect term
|
||||
makeParser term (Left NAppOp) = term
|
||||
makeParser term (Left NHasAttrOp) = nixHasAttr term
|
||||
makeParser term (Right ops) = buildExpressionParser [map buildOp ops] term
|
||||
|
||||
binary name fun =
|
||||
Infix $ (\x y -> Fix (NOper (fun x y))) <$ reservedOp name
|
||||
prefix name fun =
|
||||
Prefix $ Fix . NOper . fun <$ reservedOp name
|
||||
-- postfix name fun = Postfix (Fix . NOper . fun <$ symbol name)
|
||||
buildOp (NUnaryDef n op) = Prefix $ Fix . NOper . NUnary op <$ reservedOp n
|
||||
buildOp (NBinaryDef n op a) = Infix (mkOper <$ reservedOp n) (toAssoc a)
|
||||
where mkOper r1 = Fix . NOper . NBinary op r1
|
||||
|
||||
nixTermOrAttr :: Bool -> Parser NExpr
|
||||
nixTermOrAttr = buildExpressionParser table . nixTerm where
|
||||
table = [[Infix ((\x y -> Fix (NOper (NAttr x y))) <$ reservedOp ".") AssocLeft]]
|
||||
toAssoc NAssocNone = AssocNone
|
||||
toAssoc NAssocLeft = AssocLeft
|
||||
toAssoc NAssocRight = AssocRight
|
||||
|
||||
nixTerm :: Bool -> Parser NExpr
|
||||
nixTerm allowLambdas = choice
|
||||
nixAntiquoted :: Parser a -> Parser (Antiquoted a NExpr)
|
||||
nixAntiquoted p = Plain <$> p
|
||||
<|> Antiquoted <$> (try (string "${") *> whiteSpace *> nixApp <* symbolic '}')
|
||||
|
||||
nixSelector :: Parser (NSelector NExpr)
|
||||
nixSelector = keyName `sepBy1` symbolic '.'
|
||||
|
||||
nixSelect :: Parser NExpr -> Parser NExpr
|
||||
nixSelect term = build
|
||||
<$> term
|
||||
<*> optional ((,) <$> (char '.' *> nixSelector) <*> optional (reserved "or" *> nixApp))
|
||||
where
|
||||
build t Nothing = t
|
||||
build t (Just (s,o)) = Fix $ NSelect t s o
|
||||
|
||||
nixHasAttr :: Parser NExpr -> Parser NExpr
|
||||
nixHasAttr term = build <$> term <*> optional (reservedOp "?" *> nixSelector) where
|
||||
build t Nothing = t
|
||||
build t (Just s) = Fix $ NHasAttr t s
|
||||
|
||||
nixTerm :: Parser NExpr
|
||||
nixTerm = choice
|
||||
[ nixInt
|
||||
, nixParens
|
||||
, nixList
|
||||
|
|
@ -63,8 +69,13 @@ nixTerm allowLambdas = choice
|
|||
, nixBool
|
||||
, nixNull
|
||||
, nixPath -- can be expensive due to back-tracking
|
||||
, setLambdaStringOrSym allowLambdas
|
||||
]
|
||||
, try nixLambda <|> nixSet
|
||||
, nixStringExpr
|
||||
, nixSym
|
||||
] <* whiteSpace
|
||||
|
||||
nixSym :: Parser NExpr
|
||||
nixSym = mkSym <$> identifier
|
||||
|
||||
nixInt :: Parser NExpr
|
||||
nixInt = mkInt <$> decimal <?> "integer"
|
||||
|
|
@ -81,7 +92,10 @@ nixParens :: Parser NExpr
|
|||
nixParens = parens nixApp <?> "parens"
|
||||
|
||||
nixList :: Parser NExpr
|
||||
nixList = brackets (Fix . NList <$> many (nixTermOrAttr False <* whiteSpace)) <?> "list"
|
||||
nixList = brackets (Fix . NList <$> many (listTerm <* whiteSpace)) <?> "list" where
|
||||
listTerm = nixSelect $ choice
|
||||
[ nixInt, nixParens, nixList, nixSet, nixBool, nixNull, nixPath, nixStringExpr
|
||||
, nixSym ]
|
||||
|
||||
nixPath :: Parser NExpr
|
||||
nixPath = try $ fmap mkPath $ mfilter ('/' `elem`) $ some (oneOf "A-Za-z_0-9.:/")
|
||||
|
|
@ -97,28 +111,37 @@ nixIf = fmap Fix $ NIf
|
|||
<*> (whiteSpace *> reserved "then" *> nixApp)
|
||||
<*> (whiteSpace *> reserved "else" *> nixApp)
|
||||
|
||||
-- | This is a bit tricky because we don't know whether we're looking at a set
|
||||
-- or a lambda until we've looked ahead a bit. And then it may be neither,
|
||||
-- in which case we fall back to expected a plain string or identifier.
|
||||
setLambdaStringOrSym :: Bool -> Parser NExpr
|
||||
setLambdaStringOrSym True = try nixLambda <|> setLambdaStringOrSym False
|
||||
setLambdaStringOrSym False = try nixSet <|> keyName
|
||||
|
||||
nixLambda :: Parser NExpr
|
||||
nixLambda = Fix <$> (NAbs <$> (argExpr <?> "arguments") <*> nixApp)
|
||||
|
||||
stringish :: Parser NExpr
|
||||
stringish = (char '"' *> (merge <$> manyTill stringChar (char '"')))
|
||||
<|> (char '$' *> braces nixApp)
|
||||
nixStringExpr :: Parser NExpr
|
||||
nixStringExpr = Fix . NStr <$> nixString
|
||||
|
||||
nixString :: Parser (NString NExpr)
|
||||
nixString = NString . merge <$> (char '"' *> manyTill stringChar (symbolic '"'))
|
||||
where
|
||||
merge = foldl1' (\x y -> Fix (NOper (NConcat x y)))
|
||||
merge [] = [Plain ""]
|
||||
merge [x] = [x]
|
||||
merge (Plain a : Plain b : rs) = merge (Plain (a `append` b) : rs)
|
||||
merge (x : rs) = x : merge rs
|
||||
|
||||
stringChar = char '\\' *> (mkStr . singleton <$> anyChar)
|
||||
<|> (try (string "${") *> nixApp <* char '}')
|
||||
<|> (mkStr . pack <$> many (noneOf "\"\\"))
|
||||
stringChar = char '\\' *> (Plain . singleton <$> escapeCode)
|
||||
<|> Antiquoted <$> (try (string "${") *> nixApp <* char '}')
|
||||
<|> Plain . singleton <$> char '$'
|
||||
<|> Plain . pack <$> some (noneOf "\"\\$")
|
||||
|
||||
argExpr :: Parser NExpr
|
||||
argExpr = Fix . NArgs <$> choice
|
||||
escapeCode = choice $ map (\(x,y) -> x <$ char y)
|
||||
[ ('\n', 'n')
|
||||
, ('\r', 'r')
|
||||
, ('\t', 't')
|
||||
, ('\\', '\\')
|
||||
, ('$' , '$')
|
||||
, ('"' , '"')
|
||||
, ('\'', '\'')
|
||||
]
|
||||
|
||||
argExpr :: Parser (Formals NExpr)
|
||||
argExpr = choice
|
||||
[ idOrAtPattern <$> identifier <* whiteSpace <*> optional (symbolic '@' *> paramSet)
|
||||
, setOrAtPattern <$> paramSet <* whiteSpace <*> optional (symbolic '@' *> identifier)
|
||||
] <* symbolic ':'
|
||||
|
|
@ -127,11 +150,11 @@ argExpr = Fix . NArgs <$> choice
|
|||
paramSet = FormalParamSet . Map.fromList <$> argList
|
||||
|
||||
argList :: Parser [(Text, Maybe NExpr)]
|
||||
argList = braces ((argName <* whiteSpace) `sepBy` symbolic ',') <?> "arglist"
|
||||
argList = braces ((argName <* whiteSpace) `sepBy` symbolic ',') <?> "arglist"
|
||||
|
||||
argName :: Parser (Text, Maybe NExpr)
|
||||
argName = (,) <$> identifier <* whiteSpace
|
||||
<*> optional (symbolic '?' *> nixExpr False)
|
||||
<*> optional (symbolic '?' *> nixApp)
|
||||
|
||||
idOrAtPattern :: Text -> Maybe (FormalParamSet NExpr) -> Formals NExpr
|
||||
idOrAtPattern i Nothing = FormalName i
|
||||
|
|
@ -142,18 +165,17 @@ argExpr = Fix . NArgs <$> choice
|
|||
setOrAtPattern s (Just i) = FormalRightAt s i
|
||||
|
||||
nixBinders :: Parser [Binding NExpr]
|
||||
nixBinders = choice
|
||||
[ reserved "inherit" *> whiteSpace *> (scopedInherit <|> inherit) <?> "inherited binding"
|
||||
, namedVar
|
||||
] `endBy` symbolic ';'
|
||||
where
|
||||
scopedInherit = try (symbolic '(') *>
|
||||
(ScopedInherit <$> nixExpr False <* symbolic ')' <*> many keyName) <?> "scoped inherit binding"
|
||||
inherit = Inherit <$> many keyName
|
||||
namedVar = NamedVar <$> keyName <*> (symbolic '=' *> nixApp) <?> "variable binding"
|
||||
nixBinders = (inherit <|> namedVar) `endBy` symbolic ';' where
|
||||
inherit = Inherit <$> (reserved "inherit" *> optional scope) <*> many nixSelector
|
||||
<?> "inherited binding"
|
||||
namedVar = NamedVar <$> nixSelector <*> (symbolic '=' *> nixApp)
|
||||
<?> "variable binding"
|
||||
scope = parens nixApp <?> "inherit scope"
|
||||
|
||||
keyName :: Parser NExpr
|
||||
keyName = (stringish <|> (mkSym <$> identifier)) <* whiteSpace
|
||||
keyName :: Parser (NKeyName NExpr)
|
||||
keyName = dynamicKey <|> staticKey where
|
||||
staticKey = StaticKey <$> identifier
|
||||
dynamicKey = DynamicKey <$> nixAntiquoted nixString
|
||||
|
||||
nixSet :: Parser NExpr
|
||||
nixSet = Fix <$> (NSet <$> isRec <*> (braces nixBinders <?> "set")) where
|
||||
|
|
|
|||
|
|
@ -72,14 +72,14 @@ reserved :: (TokenParsing m, Monad m) => String -> m ()
|
|||
reserved = reserve identStyle
|
||||
|
||||
reservedOp :: TokenParsing m => String -> m ()
|
||||
reservedOp o = token $ try $
|
||||
reservedOp o = token $ try $ () <$
|
||||
highlight ReservedOperator (string o) <* (notFollowedBy opLetter <?> "end of " ++ o)
|
||||
|
||||
opStart :: CharParsing m => m Char
|
||||
opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
|
||||
|
||||
opLetter :: CharParsing m => m Char
|
||||
opLetter = oneOf "@"
|
||||
opLetter = oneOf "@>-+"
|
||||
|
||||
identStart :: CharParsing m => m Char
|
||||
identStart = letter <|> char '_'
|
||||
|
|
|
|||
168
Nix/Pretty.hs
168
Nix/Pretty.hs
|
|
@ -1,79 +1,131 @@
|
|||
module Nix.Pretty where
|
||||
|
||||
import Data.Map (toList)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text, unpack)
|
||||
import Nix.Types
|
||||
import Text.PrettyPrint.ANSI.Leijen
|
||||
|
||||
prettyBind :: Binding NExpr -> Doc
|
||||
prettyBind (NamedVar n v) = prettyNix n <+> equals <+> prettyNix v <> semi
|
||||
prettyBind (Inherit ns) = text "inherit" <+> fillSep (map prettyNix ns) <> semi
|
||||
prettyBind (ScopedInherit s ns) = text "inherit" <+> parens (prettyNix s) <+> fillSep (map prettyNix ns) <> semi
|
||||
-- | This type represents a pretty printed nix expression
|
||||
-- together with some information about the expression.
|
||||
data NixDoc = NixDoc
|
||||
{ -- | The rendered expression, without any parentheses.
|
||||
withoutParens :: Doc
|
||||
|
||||
prettyFormals :: Formals NExpr -> Doc
|
||||
-- | The root operator is the operator at the root of
|
||||
-- the expression tree. For example, in '(a * b) + c', '+' would be the root
|
||||
-- operator. It is needed to determine if we need to wrap the expression in
|
||||
-- parentheses.
|
||||
, rootOp :: OperatorInfo
|
||||
}
|
||||
|
||||
-- | A simple expression is never wrapped in parentheses. The expression
|
||||
-- behaves as if it's root operator had a precedence higher than all
|
||||
-- other operators (including function application).
|
||||
simpleExpr :: Doc -> NixDoc
|
||||
simpleExpr = flip NixDoc $ OperatorInfo maxBound NAssocNone "simple expr"
|
||||
|
||||
-- | An expression that behaves as if it's root operator
|
||||
-- had a precedence lower than all other operators.
|
||||
-- That ensures that the expression is wrapped in parantheses in
|
||||
-- almost always, but it's still rendered without parentheses
|
||||
-- in cases where parentheses are never required (such as in the LHS
|
||||
-- of a binding).
|
||||
leastPrecedence :: Doc -> NixDoc
|
||||
leastPrecedence = flip NixDoc $ OperatorInfo minBound NAssocNone "least precedence"
|
||||
|
||||
appOpNonAssoc :: OperatorInfo
|
||||
appOpNonAssoc = appOp { associativity = NAssocNone }
|
||||
|
||||
wrapParens :: OperatorInfo -> NixDoc -> Doc
|
||||
wrapParens op sub
|
||||
| precedence (rootOp sub) > precedence op = withoutParens sub
|
||||
| precedence (rootOp sub) == precedence op
|
||||
&& associativity (rootOp sub) == associativity op
|
||||
&& associativity op /= NAssocNone = withoutParens sub
|
||||
| otherwise = parens $ withoutParens sub
|
||||
|
||||
prettyString :: NString NixDoc -> Doc
|
||||
prettyString (NString parts) = dquotes . hcat . map prettyPart $ parts
|
||||
where prettyPart (Plain t) = text . unpack $ t
|
||||
prettyPart (Antiquoted r) = text "$" <> braces (withoutParens r)
|
||||
|
||||
prettyFormals :: Formals NixDoc -> Doc
|
||||
prettyFormals (FormalName n) = text $ unpack n
|
||||
prettyFormals (FormalSet s) = prettyParamSet s
|
||||
prettyFormals (FormalLeftAt n s) = text (unpack n) <> text "@" <> prettyParamSet s
|
||||
prettyFormals (FormalRightAt s n) = prettyParamSet s <> text "@" <> text (unpack n)
|
||||
|
||||
prettyParamSet :: FormalParamSet NExpr -> Doc
|
||||
prettyParamSet (FormalParamSet args) = lbrace <+> hcat (map prettySetArg $ toList args) <+> rbrace
|
||||
prettyParamSet :: FormalParamSet NixDoc -> Doc
|
||||
prettyParamSet (FormalParamSet args) =
|
||||
lbrace <+> hcat (map prettySetArg $ toList args) <+> rbrace
|
||||
|
||||
prettySetArg :: (Text, Maybe NExpr) -> Doc
|
||||
prettyBind :: Binding NixDoc -> Doc
|
||||
prettyBind (NamedVar n v) = prettySelector n <+> equals <+> withoutParens v <> semi
|
||||
prettyBind (Inherit s ns)
|
||||
= text "inherit" <+> scope <> fillSep (map prettySelector ns) <> semi
|
||||
where scope = maybe empty ((<> space) . parens . withoutParens) s
|
||||
|
||||
prettyKeyName :: NKeyName NixDoc -> Doc
|
||||
prettyKeyName (StaticKey key) = text . unpack $ key
|
||||
prettyKeyName (DynamicKey key) = runAntiquoted prettyString withoutParens key
|
||||
|
||||
prettySelector :: NSelector NixDoc -> Doc
|
||||
prettySelector = hcat . punctuate dot . map prettyKeyName
|
||||
|
||||
prettySetArg :: (Text, Maybe NixDoc) -> Doc
|
||||
prettySetArg (n, Nothing) = text (unpack n)
|
||||
prettySetArg (n, Just v) = text (unpack n) <+> text "?" <+> prettyNix v
|
||||
prettySetArg (n, Just v) = text (unpack n) <+> text "?" <+> withoutParens v
|
||||
|
||||
infixOper :: NExpr -> String -> NExpr -> Doc
|
||||
infixOper l op r = prettyNix l <+> text op <+> prettyNix r
|
||||
prettyOper :: NOperF NixDoc -> NixDoc
|
||||
prettyOper (NBinary op r1 r2) = flip NixDoc opInfo $ hsep
|
||||
[ wrapParens (f NAssocLeft) r1
|
||||
, text $ operatorName opInfo
|
||||
, wrapParens (f NAssocRight) r2
|
||||
]
|
||||
where
|
||||
opInfo = getBinaryOperator op
|
||||
f x
|
||||
| associativity opInfo /= x = opInfo { associativity = NAssocNone }
|
||||
| otherwise = opInfo
|
||||
prettyOper (NUnary op r1) =
|
||||
NixDoc (text (operatorName opInfo) <> wrapParens opInfo r1) opInfo
|
||||
where opInfo = getUnaryOperator op
|
||||
|
||||
prettyOper :: NOperF NExpr -> Doc
|
||||
prettyOper (NNot r) = text "!" <> prettyNix r
|
||||
prettyOper (NNeg r) = text "-" <> prettyNix r
|
||||
prettyOper (NEq r1 r2) = infixOper r1 "==" r2
|
||||
prettyOper (NNEq r1 r2) = infixOper r1 "!=" r2
|
||||
prettyOper (NLt r1 r2) = infixOper r1 "<" r2
|
||||
prettyOper (NLte r1 r2) = infixOper r1 "<=" r2
|
||||
prettyOper (NGt r1 r2) = infixOper r1 ">" r2
|
||||
prettyOper (NGte r1 r2) = infixOper r1 ">=" r2
|
||||
prettyOper (NAnd r1 r2) = infixOper r1 "&&" r2
|
||||
prettyOper (NOr r1 r2) = infixOper r1 "||" r2
|
||||
prettyOper (NImpl r1 r2) = infixOper r1 ">" r2
|
||||
prettyOper (NUpdate r1 r2) = infixOper r1 "//" r2
|
||||
prettyOper (NHasAttr r1 r2) = infixOper r1 "?" r2
|
||||
prettyOper (NAttr r1 r2) = prettyNix r1 <> text "." <> prettyNix r2
|
||||
|
||||
prettyOper (NPlus r1 r2) = infixOper r1 "+" r2
|
||||
prettyOper (NMinus r1 r2) = infixOper r1 "-" r2
|
||||
prettyOper (NMult r1 r2) = infixOper r1 "*" r2
|
||||
prettyOper (NDiv r1 r2) = infixOper r1 "/" r2
|
||||
|
||||
prettyOper (NConcat r1 r2) = infixOper r1 "++" r2
|
||||
|
||||
prettyAtom :: NAtom -> Doc
|
||||
prettyAtom (NStr s) = dquotes $ text $ unpack s
|
||||
prettyAtom atom = text $ unpack $ atomText atom
|
||||
prettyAtom :: NAtom -> NixDoc
|
||||
prettyAtom atom = simpleExpr $ text $ unpack $ atomText atom
|
||||
|
||||
prettyNix :: NExpr -> Doc
|
||||
prettyNix (Fix expr) = go expr where
|
||||
go (NConstant atom) = prettyAtom atom
|
||||
go (NOper oper) = prettyOper oper
|
||||
go (NList xs) = lbracket <+> fillSep (map prettyNix xs) <+> rbracket
|
||||
prettyNix = withoutParens . cata phi where
|
||||
phi :: NExprF NixDoc -> NixDoc
|
||||
phi (NConstant atom) = prettyAtom atom
|
||||
phi (NStr str) = simpleExpr $ prettyString str
|
||||
phi (NList xs) = simpleExpr $ group $
|
||||
nest 2 (vsep $ lbracket : map (wrapParens appOpNonAssoc) xs) <$> rbracket
|
||||
phi (NSet rec xs) = simpleExpr $ group $
|
||||
nest 2 (vsep $ prefix rec <> lbrace : map prettyBind xs) <$> rbrace
|
||||
where
|
||||
prefix Rec = text "rec" <> space
|
||||
prefix NonRec = empty
|
||||
phi (NAbs args body) = leastPrecedence $
|
||||
(prettyFormals args <> colon) </> withoutParens body
|
||||
|
||||
go (NArgs fs) = prettyFormals fs
|
||||
phi (NOper oper) = prettyOper oper
|
||||
phi (NSelect r attr o) = (if isJust o then leastPrecedence else flip NixDoc selectOp) $
|
||||
wrapParens selectOp r <> dot <> prettySelector attr <> ordoc
|
||||
where ordoc = maybe empty ((space <>) . withoutParens) o
|
||||
phi (NHasAttr r attr)
|
||||
= NixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp
|
||||
phi (NApp fun arg)
|
||||
= NixDoc (wrapParens appOp fun <+> wrapParens appOpNonAssoc arg) appOp
|
||||
|
||||
go (NSet rec xs) =
|
||||
(case rec of Rec -> "rec"; NonRec -> empty)
|
||||
<+> lbrace <+> vcat (map prettyBind xs) <+> rbrace
|
||||
|
||||
go (NLet _binds _body) = text "let"
|
||||
go (NIf cond trueBody falseBody) =
|
||||
(text "if" <+> prettyNix cond)
|
||||
<$$> (text "then" <+> prettyNix trueBody)
|
||||
<$$> (text "else" <+> prettyNix falseBody)
|
||||
|
||||
go (NWith scope body) = text "with" <+> prettyNix scope <> semi <+> prettyNix body
|
||||
go (NAssert cond body) = text "assert" <+> prettyNix cond <> semi <+> prettyNix body
|
||||
|
||||
go (NVar e) = prettyNix e
|
||||
go (NApp fun arg) = prettyNix fun <+> parens (prettyNix arg)
|
||||
go (NAbs args body) = (prettyNix args <> colon) <$$> prettyNix body
|
||||
phi (NLet _binds _body) = simpleExpr $ text "let"
|
||||
phi (NIf cond trueBody falseBody) = leastPrecedence $
|
||||
group $ nest 2 $ (text "if" <+> withoutParens cond) <$>
|
||||
( align (text "then" <+> withoutParens trueBody)
|
||||
<$> align (text "else" <+> withoutParens falseBody)
|
||||
)
|
||||
phi (NWith scope body) = leastPrecedence $
|
||||
text "with" <+> withoutParens scope <> semi <+> withoutParens body
|
||||
phi (NAssert cond body) = leastPrecedence $
|
||||
text "assert" <+> withoutParens cond <> semi <+> withoutParens body
|
||||
|
|
|
|||
354
Nix/Types.hs
354
Nix/Types.hs
|
|
@ -1,4 +1,6 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
|
@ -12,8 +14,10 @@ import Data.Data
|
|||
import Data.Foldable
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text hiding (concat, concatMap, head, map)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Text hiding (concat, concatMap, head, map, zipWith, reverse, intercalate)
|
||||
import Data.Traversable
|
||||
import GHC.Exts
|
||||
import GHC.Generics
|
||||
import Prelude hiding (readFile, concat, concatMap, elem, mapM,
|
||||
sequence)
|
||||
|
|
@ -27,121 +31,179 @@ cataM :: (Traversable f, Monad m) => (f a -> m a) -> Fix f -> m a
|
|||
cataM f = f <=< mapM (cataM f) . outF
|
||||
|
||||
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) = "NStr " ++ show s
|
||||
show (NInt i) = "NInt " ++ show i
|
||||
show (NPath p) = "NPath " ++ show p
|
||||
show (NBool b) = "NBool " ++ show b
|
||||
show (NSym s) = "NSym " ++ show s
|
||||
show NNull = "NNull"
|
||||
= NInt Integer
|
||||
| NPath FilePath
|
||||
| NBool Bool
|
||||
| NSym Text
|
||||
| NNull
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
||||
|
||||
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"
|
||||
|
||||
-- | 'Antiquoted' represents an expression that is either
|
||||
-- antiquoted (surrounded by ${...}) or plain (not antiquoted).
|
||||
data Antiquoted v r = Plain v | Antiquoted r
|
||||
deriving (Ord, Eq, Generic, Typeable, Data, Functor, Show)
|
||||
|
||||
runAntiquoted :: (v -> a) -> (r -> a) -> Antiquoted v r -> a
|
||||
runAntiquoted f _ (Plain v) = f v
|
||||
runAntiquoted _ f (Antiquoted r) = f r
|
||||
|
||||
-- | A 'NixString' is a list of things that are either a plain string
|
||||
-- or an antiquoted expression. After the antiquotes have been evaluated,
|
||||
-- the final string is constructed by concating all the parts.
|
||||
newtype NString r = NString [Antiquoted Text r]
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Functor, Show)
|
||||
|
||||
instance IsString (NString r) where
|
||||
fromString = NString . (:[]) . Plain . pack
|
||||
|
||||
-- | A 'KeyName' is something that can appear at the right side of an equals sign.
|
||||
-- For example, @a@ is a 'KeyName' in @{ a = 3; }@, @let a = 3; in ...@, @{}.a@ or @{} ? a@.
|
||||
--
|
||||
-- Nix supports both static keynames (just an identifier) and dynamic identifiers.
|
||||
-- Dynamic identifiers can be either a string (e.g.: @{ "a" = 3; }@) or an antiquotation
|
||||
-- (e.g.: @let a = "example"; in { ${a} = 3; }.example@).
|
||||
--
|
||||
-- Note: There are some places where a dynamic keyname is not allowed. In particular, those include:
|
||||
--
|
||||
-- * the RHS of a @binding@ inside @let@: @let ${"a"} = 3; in ...@ produces a syntax error.
|
||||
-- * the attribute names of an 'inherit': @inherit ${"a"};@ is forbidden.
|
||||
--
|
||||
-- Note: In Nix, a simple string without antiquotes such as @"foo"@ is allowed even if
|
||||
-- the context requires a static keyname, but the parser still considers it a
|
||||
-- 'DynamicKey' for simplicity.
|
||||
data NKeyName r
|
||||
= DynamicKey (Antiquoted (NString r) r)
|
||||
| StaticKey Text
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
||||
|
||||
-- deriving this instance automatically is not possible
|
||||
-- because r occurs not only as last argument in Antiquoted (NString r) r
|
||||
instance Functor NKeyName where
|
||||
fmap f (DynamicKey (Plain str)) = DynamicKey . Plain $ fmap f str
|
||||
fmap f (DynamicKey (Antiquoted e)) = DynamicKey . Antiquoted $ f e
|
||||
fmap _ (StaticKey key) = StaticKey key
|
||||
|
||||
type NSelector r = [NKeyName r]
|
||||
|
||||
data NOperF r
|
||||
= NNot r
|
||||
| NNeg r
|
||||
= NUnary NUnaryOp r
|
||||
| NBinary NBinaryOp r r
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Functor, Show)
|
||||
|
||||
| NEq r r
|
||||
| NNEq r r
|
||||
| NLt r r
|
||||
| NLte r r
|
||||
| NGt r r
|
||||
| NGte r r
|
||||
| NAnd r r
|
||||
| NOr r r
|
||||
| NImpl r r
|
||||
| NUpdate r r
|
||||
| NHasAttr r r
|
||||
| NAttr r r
|
||||
data NUnaryOp = NNeg | NNot deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
||||
data NSpecialOp = NHasAttrOp | NSelectOp | NAppOp
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
||||
data NBinaryOp
|
||||
= NEq
|
||||
| NNEq
|
||||
| NLt
|
||||
| NLte
|
||||
| NGt
|
||||
| NGte
|
||||
| NAnd
|
||||
| NOr
|
||||
| NImpl
|
||||
| NUpdate
|
||||
|
||||
| NPlus r r
|
||||
| NMinus r r
|
||||
| NMult r r
|
||||
| NDiv r r
|
||||
| NConcat r r
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Functor)
|
||||
| NPlus
|
||||
| NMinus
|
||||
| NMult
|
||||
| NDiv
|
||||
| NConcat
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
||||
|
||||
instance Show f => Show (NOperF f) where
|
||||
show (NNot r) = "! " ++ show r
|
||||
show (NNeg r) = "-" ++ show r
|
||||
data NAssoc = NAssocNone | NAssocLeft | NAssocRight
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
||||
|
||||
show (NEq r1 r2) = show r1 ++ " == " ++ show r2
|
||||
show (NNEq r1 r2) = show r1 ++ " != " ++ show r2
|
||||
show (NLt r1 r2) = show r1 ++ " < " ++ show r2
|
||||
show (NLte r1 r2) = show r1 ++ " <= " ++ show r2
|
||||
show (NGt r1 r2) = show r1 ++ " > " ++ show r2
|
||||
show (NGte r1 r2) = show r1 ++ " >= " ++ show r2
|
||||
show (NAnd r1 r2) = show r1 ++ " && " ++ show r2
|
||||
show (NOr r1 r2) = show r1 ++ " || " ++ show r2
|
||||
show (NImpl r1 r2) = show r1 ++ " -> " ++ show r2
|
||||
show (NUpdate r1 r2) = show r1 ++ " // " ++ show r2
|
||||
show (NHasAttr r1 r2) = show r1 ++ " ? " ++ show r2
|
||||
show (NAttr r1 r2) = show r1 ++ "." ++ show r2
|
||||
data NOperatorDef
|
||||
= NUnaryDef String NUnaryOp
|
||||
| NBinaryDef String NBinaryOp NAssoc
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
||||
|
||||
show (NPlus r1 r2) = show r1 ++ " + " ++ show r2
|
||||
show (NMinus r1 r2) = show r1 ++ " - " ++ show r2
|
||||
show (NMult r1 r2) = show r1 ++ " * " ++ show r2
|
||||
show (NDiv r1 r2) = show r1 ++ " / " ++ show r2
|
||||
nixOperators :: [Either NSpecialOp [NOperatorDef]]
|
||||
nixOperators =
|
||||
[ Left NSelectOp
|
||||
, Left NAppOp
|
||||
, Right [ NUnaryDef "-" NNeg ]
|
||||
, Left NHasAttrOp
|
||||
] ++ map Right
|
||||
[ [ NBinaryDef "++" NConcat NAssocRight ]
|
||||
, [ NBinaryDef "*" NMult NAssocLeft , NBinaryDef "/" NDiv NAssocLeft ]
|
||||
, [ NBinaryDef "+" NPlus NAssocLeft , NBinaryDef "-" NMinus NAssocLeft ]
|
||||
, [ NUnaryDef "!" NNot ]
|
||||
, [ NBinaryDef "//" NUpdate NAssocRight ]
|
||||
, [ NBinaryDef "<" NLt NAssocLeft , NBinaryDef ">" NGt NAssocLeft
|
||||
, NBinaryDef "<=" NLte NAssocLeft , NBinaryDef ">=" NGte NAssocLeft
|
||||
]
|
||||
, [ NBinaryDef "==" NEq NAssocNone , NBinaryDef "!=" NNEq NAssocNone ]
|
||||
, [ NBinaryDef "&&" NAnd NAssocLeft ]
|
||||
, [ NBinaryDef "||" NOr NAssocLeft ]
|
||||
, [ NBinaryDef "->" NImpl NAssocNone ]
|
||||
]
|
||||
|
||||
data OperatorInfo = OperatorInfo
|
||||
{ precedence :: Int
|
||||
, associativity :: NAssoc
|
||||
, operatorName :: String
|
||||
} deriving (Eq, Ord, Generic, Typeable, Data, Show)
|
||||
|
||||
getUnaryOperator :: NUnaryOp -> OperatorInfo
|
||||
getUnaryOperator = (m Map.!) where
|
||||
m = Map.fromList . concat . zipWith buildEntry [1..] . reverse $ nixOperators
|
||||
buildEntry _ (Left _) = []
|
||||
buildEntry i (Right ops) =
|
||||
[ (op, OperatorInfo i NAssocNone name) | NUnaryDef name op <- ops ]
|
||||
|
||||
getBinaryOperator :: NBinaryOp -> OperatorInfo
|
||||
getBinaryOperator = (m Map.!) where
|
||||
m = Map.fromList . concat . zipWith buildEntry [1..] . reverse $ nixOperators
|
||||
buildEntry _ (Left _) = []
|
||||
buildEntry i (Right ops) =
|
||||
[ (op, OperatorInfo i assoc name) | NBinaryDef name op assoc <- ops ]
|
||||
|
||||
getSpecialOperatorPrec :: NSpecialOp -> Int
|
||||
getSpecialOperatorPrec = (m Map.!) where
|
||||
m = Map.fromList . catMaybes . zipWith buildEntry [1..] $ nixOperators
|
||||
buildEntry _ (Right _) = Nothing
|
||||
buildEntry i (Left op) = Just (op, i)
|
||||
|
||||
selectOp :: OperatorInfo
|
||||
selectOp = OperatorInfo (getSpecialOperatorPrec NSelectOp) NAssocLeft "."
|
||||
|
||||
hasAttrOp :: OperatorInfo
|
||||
hasAttrOp = OperatorInfo (getSpecialOperatorPrec NHasAttrOp) NAssocLeft "?"
|
||||
|
||||
appOp :: OperatorInfo
|
||||
appOp = OperatorInfo (getSpecialOperatorPrec NAppOp) NAssocLeft " "
|
||||
|
||||
show (NConcat r1 r2) = show r1 ++ " ++ " ++ show r2
|
||||
|
||||
data NSetBind = Rec | NonRec
|
||||
deriving (Ord, Eq, Generic, Typeable, Data)
|
||||
deriving (Ord, Eq, Generic, Typeable, Data, Show)
|
||||
|
||||
instance Show NSetBind where
|
||||
show Rec = "rec"
|
||||
show NonRec = ""
|
||||
|
||||
-- | A single line of the bindings section of a let expression.
|
||||
data Binding r = NamedVar r r | Inherit [r] | ScopedInherit r [r]
|
||||
deriving (Typeable, Data, Ord, Eq, Functor)
|
||||
|
||||
instance Show r => Show (Binding r) where
|
||||
show (NamedVar name val) = show name ++ " = " ++ show val ++ ";"
|
||||
show (Inherit names) = "inherit " ++ concatMap show names ++ ";"
|
||||
show (ScopedInherit context names) = "inherit (" ++ show context ++ ") " ++ concatMap show names ++ ";"
|
||||
-- | A single line of the bindings section of a let expression or of
|
||||
-- a set.
|
||||
data Binding r
|
||||
= NamedVar (NSelector r) r
|
||||
| Inherit (Maybe r) [NSelector r]
|
||||
deriving (Typeable, Data, Ord, Eq, Functor, Show)
|
||||
|
||||
data FormalParamSet r = FormalParamSet (Map Text (Maybe r))
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Functor)
|
||||
|
||||
instance Show r => Show (FormalParamSet r) where
|
||||
show (FormalParamSet 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
|
||||
deriving (Eq, Ord, Generic, Typeable, Data, Functor, Show, Foldable, Traversable)
|
||||
|
||||
-- | @Formals@ represents all the ways the formal parameters to a
|
||||
-- function can be represented.
|
||||
data Formals r =
|
||||
FormalName Text |
|
||||
FormalSet (FormalParamSet r) |
|
||||
FormalLeftAt Text (FormalParamSet r) |
|
||||
FormalRightAt (FormalParamSet r) Text
|
||||
deriving (Ord, Eq, Generic, Typeable, Data, Functor)
|
||||
|
||||
instance Show r => Show (Formals r) where
|
||||
show (FormalName n) = show n
|
||||
show (FormalSet s) = show s
|
||||
show (FormalLeftAt n s) = show n ++ "@" ++ show s
|
||||
show (FormalRightAt s n) = show s ++ "@" ++ show n
|
||||
data Formals r
|
||||
= FormalName Text
|
||||
| FormalSet (FormalParamSet r)
|
||||
| FormalLeftAt Text (FormalParamSet r)
|
||||
| FormalRightAt (FormalParamSet r) Text
|
||||
deriving (Ord, Eq, Generic, Typeable, Data, Functor, Show, Foldable, Traversable)
|
||||
|
||||
-- | @formalsAsMap@ combines the outer and inner name bindings of
|
||||
-- 'Formals'
|
||||
|
|
@ -152,25 +214,25 @@ formalsAsMap (FormalLeftAt n (FormalParamSet s)) = Map.insert n Nothing s
|
|||
formalsAsMap (FormalRightAt (FormalParamSet s) n) = Map.insert n Nothing s
|
||||
|
||||
data NExprF r
|
||||
-- value types
|
||||
= NConstant NAtom
|
||||
|
||||
| NOper (NOperF r)
|
||||
|
||||
| NStr (NString r)
|
||||
| NList [r]
|
||||
-- ^ A "concat" is a list of things which must combine to form a string.
|
||||
| NArgs (Formals r)
|
||||
| NSet NSetBind [Binding r]
|
||||
| NAbs (Formals r) r
|
||||
|
||||
-- operators
|
||||
| NOper (NOperF r)
|
||||
| NSelect r (NSelector r) (Maybe r)
|
||||
| NHasAttr r (NSelector r)
|
||||
| NApp r r
|
||||
|
||||
-- language constructs
|
||||
| NLet [Binding 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, Functor)
|
||||
deriving (Ord, Eq, Generic, Typeable, Data, Functor, Show)
|
||||
|
||||
type NExpr = Fix NExprF
|
||||
|
||||
|
|
@ -178,48 +240,11 @@ 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
|
||||
|
||||
instance Show f => Show (NExprF f) where
|
||||
show (NConstant x) = show x
|
||||
show (NOper x) = show x
|
||||
|
||||
show (NList l) = "[ " ++ go l ++ " ]"
|
||||
where
|
||||
go [] = ""
|
||||
go [x] = show x
|
||||
go (x:xs) = show x ++ ", " ++ go xs
|
||||
|
||||
show (NArgs fs) = show fs
|
||||
show (NSet b xs) = show b ++ " { " ++ concatMap show xs ++ " }"
|
||||
|
||||
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 " ++ show x
|
||||
phi (NOper x) = "NOper " ++ show x
|
||||
phi (NList l) = "NList [" ++ show l ++ "]"
|
||||
phi (NArgs xs) = "NArgs " ++ show xs
|
||||
phi (NSet b xs) = "NSet " ++ show b ++ " " ++ show xs
|
||||
phi (NLet v e) = "NLet " ++ show 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
|
||||
mkStr = Fix . NStr . NString . (:[]) . Plain
|
||||
|
||||
mkPath :: FilePath -> NExpr
|
||||
mkPath = Fix . NConstant . NPath
|
||||
|
|
@ -227,44 +252,43 @@ mkPath = Fix . NConstant . NPath
|
|||
mkSym :: Text -> NExpr
|
||||
mkSym = Fix . NConstant . NSym
|
||||
|
||||
mkSelector :: Text -> NSelector NExpr
|
||||
mkSelector = (:[]) . StaticKey
|
||||
|
||||
mkBool :: Bool -> NExpr
|
||||
mkBool = Fix . NConstant . NBool
|
||||
|
||||
mkNull :: NExpr
|
||||
mkNull = Fix (NConstant NNull)
|
||||
|
||||
-- An 'NValue' is the most reduced form of an 'NExpr' after evaluation
|
||||
|
||||
-- | An 'NValue' is the most reduced form of an 'NExpr' after evaluation
|
||||
-- is completed.
|
||||
data NValueF r
|
||||
= NVConstant NAtom
|
||||
| NVStr Text
|
||||
| NVList [r]
|
||||
| NVSet (Map Text r)
|
||||
| NVArgSet (Map Text (Maybe r))
|
||||
| NVFunction r (NValue -> IO r)
|
||||
deriving (Generic, Typeable)
|
||||
|
||||
type NValue = Fix NValueF
|
||||
|
||||
instance Show (Fix NValueF) where show (Fix f) = show f
|
||||
|
||||
instance Functor NValueF where
|
||||
fmap _ (NVConstant a) = NVConstant a
|
||||
fmap f (NVList xs) = NVList (fmap f xs)
|
||||
fmap f (NVSet h) = NVSet (fmap f h)
|
||||
fmap f (NVArgSet h) = NVArgSet (fmap (fmap f) h)
|
||||
fmap f (NVFunction argset k) = NVFunction (f argset) (fmap f . k)
|
||||
| NVFunction (Formals r) (NValue -> IO r)
|
||||
deriving (Generic, Typeable, Functor)
|
||||
|
||||
instance Show f => Show (NValueF f) where
|
||||
show (NVConstant a) = "NVConstant " ++ show a
|
||||
show (NVList xs) = "NVList " ++ show xs
|
||||
show (NVSet h) = "NVSet " ++ show h
|
||||
show (NVArgSet h) = "NVArgSet " ++ show h
|
||||
show (NVFunction argset _) = "NVFunction " ++ show argset
|
||||
showsPrec = flip go where
|
||||
go (NVConstant atom) = showsCon1 "NVConstant" atom
|
||||
go (NVStr text) = showsCon1 "NVStr" text
|
||||
go (NVList list) = showsCon1 "NVList" list
|
||||
go (NVSet attrs) = showsCon1 "NVSet" attrs
|
||||
go (NVFunction r _) = showsCon1 "NVFunction" r
|
||||
|
||||
showsCon1 :: Show a => String -> a -> Int -> String -> String
|
||||
showsCon1 con a d = showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
|
||||
|
||||
type NValue = Fix NValueF
|
||||
instance Show (Fix NValueF) where show (Fix f) = show f
|
||||
|
||||
valueText :: NValue -> Text
|
||||
valueText = cata phi where
|
||||
phi (NVConstant a) = atomText a
|
||||
phi (NVStr t) = t
|
||||
phi (NVList _) = error "Cannot coerce a list to a string"
|
||||
phi (NVSet _) = error "Cannot coerce a set to a string"
|
||||
phi (NVArgSet _) = error "Cannot coerce an argument list to a string"
|
||||
phi (NVFunction _ _) = error "Cannot coerce a function to a string"
|
||||
|
|
|
|||
|
|
@ -23,35 +23,51 @@ case_constant_bool = do
|
|||
case_simple_set :: Assertion
|
||||
case_simple_set = do
|
||||
assertParseString "{ a = 23; b = 4; }" $ Fix $ NSet NonRec
|
||||
[ NamedVar (mkSym "a") $ mkInt 23
|
||||
, NamedVar (mkSym "b") $ mkInt 4
|
||||
[ NamedVar (mkSelector "a") $ mkInt 23
|
||||
, NamedVar (mkSelector "b") $ mkInt 4
|
||||
]
|
||||
assertParseFail "{ a = 23 }"
|
||||
|
||||
case_set_inherit :: Assertion
|
||||
case_set_inherit = do
|
||||
assertParseString "{ e = 3; inherit a b; }" $ Fix $ NSet NonRec
|
||||
[ NamedVar (mkSym "e") $ mkInt 3
|
||||
, Inherit [mkSym "a", mkSym "b"]
|
||||
[ NamedVar (mkSelector "e") $ mkInt 3
|
||||
, Inherit Nothing [mkSelector "a", mkSelector "b"]
|
||||
]
|
||||
assertParseString "{ inherit; }" $ Fix $ NSet NonRec [ Inherit [] ]
|
||||
assertParseString "{ inherit; }" $ Fix $ NSet NonRec [ Inherit Nothing [] ]
|
||||
|
||||
case_set_scoped_inherit :: Assertion
|
||||
case_set_scoped_inherit = assertParseString "{ inherit (a) b c; e = 4; inherit(a)b c; }" $ Fix $ NSet NonRec
|
||||
[ ScopedInherit (mkSym "a") [mkSym "b", mkSym "c"]
|
||||
, NamedVar (mkSym "e") $ mkInt 4
|
||||
, ScopedInherit (mkSym "a") [mkSym "b", mkSym "c"]
|
||||
[ Inherit (Just (mkSym "a")) [mkSelector "b", mkSelector "c"]
|
||||
, NamedVar (mkSelector "e") $ mkInt 4
|
||||
, Inherit (Just (mkSym "a")) [mkSelector "b", mkSelector "c"]
|
||||
]
|
||||
|
||||
case_set_rec :: Assertion
|
||||
case_set_rec = assertParseString "rec { a = 3; b = a; }" $ Fix $ NSet Rec
|
||||
[ NamedVar (mkSym "a") $ mkInt 3
|
||||
, NamedVar (mkSym "b") $ mkSym "a"
|
||||
[ NamedVar (mkSelector "a") $ mkInt 3
|
||||
, NamedVar (mkSelector "b") $ mkSym "a"
|
||||
]
|
||||
|
||||
case_set_complex_keynames :: Assertion
|
||||
case_set_complex_keynames = do
|
||||
assertParseString "{ \"\" = null; }" $ Fix $ NSet NonRec
|
||||
[ NamedVar [DynamicKey (Plain "")] mkNull ]
|
||||
assertParseString "{ a.b = 3; a.c = 4; }" $ Fix $ NSet NonRec
|
||||
[ NamedVar [StaticKey "a", StaticKey "b"] $ mkInt 3
|
||||
, NamedVar [StaticKey "a", StaticKey "c"] $ mkInt 4
|
||||
]
|
||||
assertParseString "{ ${let a = \"b\"; in a} = 4; }" $ Fix $ NSet NonRec
|
||||
[ NamedVar [DynamicKey (Antiquoted letExpr)] $ mkInt 4 ]
|
||||
assertParseString "{ \"a${let a = \"b\"; in a}c\".e = 4; }" $ Fix $ NSet NonRec
|
||||
[ NamedVar [DynamicKey (Plain str), StaticKey "e"] $ mkInt 4 ]
|
||||
where
|
||||
letExpr = Fix $ NLet [ NamedVar (mkSelector "a") (mkStr "b") ] (mkSym "a")
|
||||
str = NString [Plain "a", Antiquoted letExpr, Plain "c"]
|
||||
|
||||
case_set_inherit_direct :: Assertion
|
||||
case_set_inherit_direct = assertParseString "{ inherit ({a = 3;}); }" $ Fix $ NSet NonRec
|
||||
[ flip ScopedInherit [] $ Fix $ NSet NonRec [NamedVar (mkSym "a") $ mkInt 3]
|
||||
[ flip Inherit [] $ Just $ Fix $ NSet NonRec [NamedVar (mkSelector "a") $ mkInt 3]
|
||||
]
|
||||
|
||||
case_int_list :: Assertion
|
||||
|
|
@ -62,45 +78,50 @@ case_int_null_list :: Assertion
|
|||
case_int_null_list = assertParseString "[1 2 3 null 4]" $ Fix (NList (map (Fix . NConstant) [NInt 1, NInt 2, NInt 3, NNull, NInt 4]))
|
||||
|
||||
case_simple_lambda :: Assertion
|
||||
case_simple_lambda = assertParseString "a: a" $ Fix (NAbs (Fix $ NArgs $ FormalName "a") (mkSym "a"))
|
||||
case_simple_lambda = assertParseString "a: a" $ Fix $ NAbs (FormalName "a") (mkSym "a")
|
||||
|
||||
case_lambda_pattern :: Assertion
|
||||
case_lambda_pattern = do
|
||||
assertParseString "{b, c ? 1}: b" $
|
||||
Fix $ NAbs (Fix $ NArgs $ FormalSet args) (mkSym "b")
|
||||
Fix $ NAbs (FormalSet args) (mkSym "b")
|
||||
assertParseString "{b ? x: x}: b" $
|
||||
Fix $ NAbs (FormalSet args2) (mkSym "b")
|
||||
assertParseString "a@{b,c ? 1}: b" $
|
||||
Fix $ NAbs (Fix $ NArgs $ FormalLeftAt "a" args) (mkSym "b")
|
||||
Fix $ NAbs (FormalLeftAt "a" args) (mkSym "b")
|
||||
assertParseString "{b,c?1}@a: c" $
|
||||
Fix $ NAbs (Fix $ NArgs $ FormalRightAt args "a") (mkSym "c")
|
||||
Fix $ NAbs (FormalRightAt args "a") (mkSym "c")
|
||||
assertParseFail "a@b: a"
|
||||
assertParseFail "{a}@{b}: a"
|
||||
where
|
||||
args = FormalParamSet $ Map.fromList [("b", Nothing), ("c", Just $ mkInt 1)]
|
||||
args2 = FormalParamSet $ Map.fromList [("b", Just lam)]
|
||||
lam = Fix $ NAbs (FormalName "x") (mkSym "x")
|
||||
|
||||
case_lambda_app_int :: Assertion
|
||||
case_lambda_app_int = assertParseString "(a: a) 3" $ Fix (NApp lam int) where
|
||||
int = mkInt 3
|
||||
lam = Fix (NAbs (Fix $ NArgs $ FormalName "a") asym)
|
||||
lam = Fix (NAbs (FormalName "a") asym)
|
||||
asym = mkSym "a"
|
||||
|
||||
case_simple_let :: Assertion
|
||||
case_simple_let = do
|
||||
assertParseString "let a = 4; in a" $ Fix (NLet binds asym)
|
||||
assertParseString "let a = 4; in a" $ Fix (NLet binds $ mkSym "a")
|
||||
assertParseFail "let a = 4 in a"
|
||||
where
|
||||
binds = [NamedVar asym $ mkInt 4]
|
||||
asym = mkSym "a"
|
||||
binds = [NamedVar (mkSelector "a") $ mkInt 4]
|
||||
|
||||
case_nested_let :: Assertion
|
||||
case_nested_let = do
|
||||
assertParseString "let a = 4; in let b = 5; in a" $ Fix $ NLet [NamedVar (mkSym "a") $ mkInt 4] $
|
||||
Fix $ NLet [NamedVar (mkSym "b") $ mkInt 5] $ mkSym "a"
|
||||
assertParseString "let a = 4; in let b = 5; in a" $ Fix $ NLet
|
||||
[ NamedVar (mkSelector "a") $ mkInt 4 ]
|
||||
(Fix $ NLet [NamedVar (mkSelector "b") $ mkInt 5] $ mkSym "a")
|
||||
assertParseFail "let a = 4; let b = 3; in b"
|
||||
|
||||
case_let_scoped_inherit :: Assertion
|
||||
case_let_scoped_inherit = do
|
||||
assertParseString "let a = null; inherit (b) c; in c" $ Fix $
|
||||
NLet [NamedVar (mkSym "a") mkNull, ScopedInherit (mkSym "b") [mkSym "c"]] $ mkSym "c"
|
||||
assertParseString "let a = null; inherit (b) c; in c" $ Fix $ NLet
|
||||
[ NamedVar (mkSelector "a") mkNull, Inherit (Just $ mkSym "b") [mkSelector "c"] ]
|
||||
(mkSym "c")
|
||||
assertParseFail "let inherit (b) c in c"
|
||||
|
||||
case_identifier_special_chars :: Assertion
|
||||
|
|
@ -125,7 +146,9 @@ case_string_dollar :: Assertion
|
|||
case_string_dollar = mapM_ makeStringParseTest ["a$b", "a$$b", "$cdef", "gh$i"]
|
||||
|
||||
case_string_escape :: Assertion
|
||||
case_string_escape = assertParseString "\"\\$\\n\\t\\r\\\\\"" $ mkStr "$\n\t\r\\"
|
||||
case_string_escape = do
|
||||
assertParseString "\"\\$\\n\\t\\r\\\\\"" $ mkStr "$\n\t\r\\"
|
||||
assertParseString "\" \\\" \\' \"" $ mkStr " \" ' "
|
||||
|
||||
case_if :: Assertion
|
||||
case_if = do
|
||||
|
|
@ -136,6 +159,19 @@ case_if = do
|
|||
assertParseFail "if true then false else false else"
|
||||
assertParseFail "1 + 2 then"
|
||||
|
||||
case_string_antiquote :: Assertion
|
||||
case_string_antiquote = do
|
||||
assertParseString "\"abc${ if true then \"def\" else \"abc\" } g\"" $
|
||||
Fix $ NStr $ NString
|
||||
[ Plain "abc"
|
||||
, Antiquoted $ Fix $ NIf (mkBool True) (mkStr "def") (mkStr "abc")
|
||||
, Plain " g"
|
||||
]
|
||||
assertParseString "\"\\${a}\"" $ mkStr "${a}"
|
||||
assertParseFail "\"a"
|
||||
assertParseFail "${true}"
|
||||
assertParseFail "\"${true\""
|
||||
|
||||
tests :: TestTree
|
||||
tests = $testGroupGenerator
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue