Began work on the evaluator
This commit is contained in:
parent
7d8615aaf7
commit
305598ea7f
155
Nix.hs
155
Nix.hs
|
@ -18,26 +18,30 @@
|
||||||
module Nix where
|
module Nix where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Monad hiding (forM_)
|
import Control.Arrow
|
||||||
|
import Control.Monad hiding (forM_, mapM, sequence)
|
||||||
--import Control.Monad.IO.Class
|
--import Control.Monad.IO.Class
|
||||||
--import Control.Monad.Trans.Class
|
--import Control.Monad.Trans.Class
|
||||||
--import Control.Monad.Trans.Control
|
--import Control.Monad.Trans.Control
|
||||||
--import Control.Monad.Trans.Either
|
--import Control.Monad.Trans.Either
|
||||||
|
--import Control.Monad.Trans.Reader
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Data
|
import Data.Data
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
--import Data.Monoid
|
--import Data.Monoid
|
||||||
|
import qualified Data.Text as T
|
||||||
import Data.Text hiding (concat, concatMap, head, map)
|
import Data.Text hiding (concat, concatMap, head, map)
|
||||||
import Data.Text.IO
|
--import Data.Text.IO
|
||||||
--import Data.Traversable
|
import Data.Traversable
|
||||||
--import Data.Typeable
|
--import Data.Typeable
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import qualified Prelude
|
import qualified Prelude
|
||||||
import Prelude hiding (readFile, concat, concatMap, elem)
|
import Prelude hiding (readFile, concat, concatMap, elem, mapM,
|
||||||
|
sequence)
|
||||||
import System.Environment
|
import System.Environment
|
||||||
import System.IO.Memoize
|
--import System.IO.Memoize
|
||||||
-- import Text.Parsec hiding ((<|>), many, optional)
|
-- import Text.Parsec hiding ((<|>), many, optional)
|
||||||
-- import Text.Parsec.Text
|
-- import Text.Parsec.Text
|
||||||
import Text.Trifecta
|
import Text.Trifecta
|
||||||
|
@ -51,6 +55,14 @@ loeb :: Functor f => f (f a -> a) -> f a
|
||||||
loeb xs = ys where ys = fmap ($ ys) xs
|
loeb xs = ys where ys = fmap ($ ys) xs
|
||||||
{-# INLINE loeb #-}
|
{-# INLINE loeb #-}
|
||||||
|
|
||||||
|
newtype Fix (f :: * -> *) = Fix { outF :: f (Fix f) }
|
||||||
|
|
||||||
|
cata :: Functor f => (f a -> a) -> Fix f -> a
|
||||||
|
cata f = f . fmap (cata f) . outF
|
||||||
|
|
||||||
|
cataM :: (Traversable f, Monad m) => (f a -> m a) -> Fix f -> m a
|
||||||
|
cataM f = f <=< mapM (cataM f) . outF
|
||||||
|
|
||||||
data NAtom
|
data NAtom
|
||||||
= NStr Text
|
= NStr Text
|
||||||
| NInt Integer
|
| NInt Integer
|
||||||
|
@ -104,6 +116,16 @@ data NExprF r
|
||||||
-- ^ The untyped lambda calculus core
|
-- ^ The untyped lambda calculus core
|
||||||
deriving (Ord, Eq, Generic, Typeable, Data)
|
deriving (Ord, Eq, Generic, Typeable, Data)
|
||||||
|
|
||||||
|
-- An 'NValue' is the most reduced form of an 'NExpr' after evaluation
|
||||||
|
-- is completed.
|
||||||
|
data NValueF r
|
||||||
|
= NVConstant NAtom
|
||||||
|
| NVList [r]
|
||||||
|
| NVSet (Map Text r)
|
||||||
|
| NVArgSet (Map Text (Maybe r))
|
||||||
|
| NVFunction r (NValue -> IO r)
|
||||||
|
deriving (Generic, Typeable)
|
||||||
|
|
||||||
instance Functor NExprF where
|
instance Functor NExprF where
|
||||||
fmap _ (NConstant a) = NConstant a
|
fmap _ (NConstant a) = NConstant a
|
||||||
fmap f (NList r) = NList (fmap f r)
|
fmap f (NList r) = NList (fmap f r)
|
||||||
|
@ -119,14 +141,16 @@ instance Functor NExprF where
|
||||||
fmap f (NApp r r1) = NApp (f r) (f r1)
|
fmap f (NApp r r1) = NApp (f r) (f r1)
|
||||||
fmap f (NAbs r r1) = NAbs (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
|
type NExpr = Fix NExprF
|
||||||
|
|
||||||
newtype NEnv a = NEnv { getEnv :: Map a a }
|
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)
|
||||||
|
|
||||||
|
type NValue = Fix NValueF
|
||||||
|
|
||||||
instance Show f => Show (NExprF f) where
|
instance Show f => Show (NExprF f) where
|
||||||
show (NConstant x) = show x
|
show (NConstant x) = show x
|
||||||
|
@ -181,6 +205,13 @@ dumpExpr = cata phi where
|
||||||
phi (NApp f x) = "NApp " ++ f ++ " " ++ x
|
phi (NApp f x) = "NApp " ++ f ++ " " ++ x
|
||||||
phi (NAbs a b) = "NAbs " ++ a ++ " " ++ b
|
phi (NAbs a b) = "NAbs " ++ a ++ " " ++ b
|
||||||
|
|
||||||
|
valueText :: NValue -> Text
|
||||||
|
valueText = cata phi where
|
||||||
|
phi (NVConstant a) = atomText a
|
||||||
|
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"
|
||||||
|
|
||||||
mkInt :: Integer -> NExpr
|
mkInt :: Integer -> NExpr
|
||||||
mkInt = Fix . NConstant . NInt
|
mkInt = Fix . NConstant . NInt
|
||||||
|
|
||||||
|
@ -199,23 +230,9 @@ mkBool = Fix . NConstant . NBool
|
||||||
mkNull :: NExpr
|
mkNull :: NExpr
|
||||||
mkNull = Fix (NConstant NNull)
|
mkNull = Fix (NConstant NNull)
|
||||||
|
|
||||||
instance Show (Fix NExprF) where
|
instance Show (Fix NExprF) where show (Fix f) = show f
|
||||||
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 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 :: Parser NExpr
|
||||||
nixApp = go <$> some (whiteSpace *> nixTerm True)
|
nixApp = go <$> some (whiteSpace *> nixTerm True)
|
||||||
|
@ -262,9 +279,9 @@ maybeSetOrLambda allowLambdas = do
|
||||||
trace ("results are = " ++ show y) $ return ()
|
trace ("results are = " ++ show y) $ return ()
|
||||||
if y
|
if y
|
||||||
then if allowLambdas
|
then if allowLambdas
|
||||||
then trace "looking for set" $ setOrArgs
|
then setOrArgs
|
||||||
else error "Unexpected lambda"
|
else error "Unexpected lambda"
|
||||||
else trace "just want a string" $ (keyName <?> "string")
|
else keyName <?> "string"
|
||||||
|
|
||||||
isPathChar :: Char -> Bool
|
isPathChar :: Char -> Bool
|
||||||
isPathChar c = isAlpha c || c `Prelude.elem` ".:/"
|
isPathChar c = isAlpha c || c `Prelude.elem` ".:/"
|
||||||
|
@ -279,11 +296,9 @@ stringChar = char '\\' *> oneChar
|
||||||
|
|
||||||
symName :: Parser Text
|
symName :: Parser Text
|
||||||
symName = do
|
symName = do
|
||||||
trace "symName" $ return ()
|
|
||||||
chars <- some (satisfy (\c -> isAlpha c || c == '.'))
|
chars <- some (satisfy (\c -> isAlpha c || c == '.'))
|
||||||
trace ("chars = " ++ show chars) $ return ()
|
trace ("chars = " ++ show chars) $ return ()
|
||||||
guard (isLower (head chars))
|
guard (isLower (head chars))
|
||||||
trace ("chars2 = " ++ show chars) $ return ()
|
|
||||||
return $ pack (trace ("chars: " ++ show chars) chars)
|
return $ pack (trace ("chars: " ++ show chars) chars)
|
||||||
|
|
||||||
stringish :: Parser NExpr
|
stringish :: Parser NExpr
|
||||||
|
@ -364,13 +379,79 @@ setOrArgs = do
|
||||||
-- Left e -> error (show e)
|
-- Left e -> error (show e)
|
||||||
-- Right r -> return $ Just r
|
-- Right r -> return $ Just r
|
||||||
|
|
||||||
|
buildArgument :: NValue -> NValue -> NValue
|
||||||
|
buildArgument paramSpec arg = do
|
||||||
|
-- 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
|
||||||
|
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
|
||||||
|
|
||||||
|
evalExpr :: NExpr -> NValue -> IO NValue
|
||||||
|
evalExpr = cata phi
|
||||||
|
where
|
||||||
|
phi :: NExprF (NValue -> IO NValue) -> NValue -> IO NValue
|
||||||
|
phi (NConstant x) = const $ return $ Fix $ NVConstant x
|
||||||
|
|
||||||
|
phi (NList l) = \env ->
|
||||||
|
Fix . NVList <$> mapM ($ env) l
|
||||||
|
|
||||||
|
phi (NConcat l) = \env ->
|
||||||
|
Fix . NVConstant . NStr . T.concat
|
||||||
|
<$> mapM (fmap valueText . ($ env)) l
|
||||||
|
|
||||||
|
phi (NArgSet xs) = error "Cannot evaluate an argument set"
|
||||||
|
|
||||||
|
phi (NSet b xs) = \env ->
|
||||||
|
Fix . NVSet . Map.fromList
|
||||||
|
<$> mapM (fmap (first valueText) . go env) xs
|
||||||
|
where
|
||||||
|
go env (x, y) = liftM2 (,) (x env) (y env)
|
||||||
|
|
||||||
|
phi (NLet v e) = error "let: not implemented"
|
||||||
|
phi (NIf i t e) = error "if: not implemented"
|
||||||
|
phi (NWith c v) = error "with: not implemented"
|
||||||
|
phi (NAssert e v) = error "assert: not implemented"
|
||||||
|
phi (NVar v) = error "var: not implemented"
|
||||||
|
|
||||||
|
phi (NApp fun x) = \env -> do
|
||||||
|
fun' <- fun env
|
||||||
|
case fun' of
|
||||||
|
Fix (NVFunction argset f) -> do
|
||||||
|
arg <- x env
|
||||||
|
let arg' = buildArgument argset arg
|
||||||
|
f arg'
|
||||||
|
_ -> error "Attempt to call non-function"
|
||||||
|
|
||||||
|
phi (NAbs a b) = \env -> do
|
||||||
|
-- jww (2014-06-28): arglists should not receive the current
|
||||||
|
-- environment, but rather should recursively view their own arg
|
||||||
|
-- set
|
||||||
|
args <- a env
|
||||||
|
return $ Fix $ NVFunction args b
|
||||||
|
|
||||||
nix :: FilePath -> IO ()
|
nix :: FilePath -> IO ()
|
||||||
nix path = do
|
nix path = do
|
||||||
mpkgs <- parseFromFile nixApp path
|
mn <- parseFromFile nixApp path
|
||||||
forM_ mpkgs $ \pkgs -> do
|
forM_ mn $ \n -> do
|
||||||
mem <- once (return pkgs)
|
top <- evalExpr n (Fix (NVSet Map.empty)) -- evaluate the top level
|
||||||
res <- join $ loeb (return (const mem))
|
case top of
|
||||||
Prelude.print res
|
Fix (NVConstant atom) ->
|
||||||
|
Prelude.putStrLn $ "Evaluated atom: " ++ show atom
|
||||||
|
Fix (NVList xs) ->
|
||||||
|
Prelude.putStrLn "Evaluated to a list"
|
||||||
|
Fix (NVSet atom) ->
|
||||||
|
Prelude.putStrLn "Evaluated to a set"
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
|
|
Loading…
Reference in a new issue