NXTDSL (empty) → 0.1
raw patch · 10 files changed
+879/−0 lines, 10 filesdep +basedep +mtldep +resourcetsetup-changed
Dependencies added: base, mtl, resourcet, stm, unordered-containers
Files
- Example.hs +7/−0
- ExampleVM.hs +36/−0
- LICENSE +9/−0
- NXT/Common.hs +17/−0
- NXT/Core.hs +376/−0
- NXT/Interpretation.hs +321/−0
- NXT/Motor.hs +48/−0
- NXT/Sensor.hs +34/−0
- NXTDSL.cabal +29/−0
- Setup.hs +2/−0
+ Example.hs view
@@ -0,0 +1,7 @@+import ExampleCode+import NXT.Core++import Control.Monad ((=<<), (>>=))++main =+ tree >>= (mkProg "lineFollow.nxc")
+ ExampleVM.hs view
@@ -0,0 +1,36 @@+import ExampleCode+import NXT.Interpretation++import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Resource+import Control.Concurrent+import Control.Concurrent.STM++main =+ do t <- tree+ runResourceT $ do env <- runVM t+ liftIO $ threadDelay 500000 -- 50 ms setup time+ liftIO $ setLoop env+ where+ assertMotor name m expect =+ do got <- atomically $ do b <- readTVar (m_b m)+ c <- readTVar (m_c m)+ return (b, c)+ when (expect /= got) $ error $ "Assertion (" ++ name ++ ") failed. Expected motor values: "+ ++ (show expect) ++ ". Got: " ++ (show got)++ setLoop t@(envQ, motor) =+ do atomically $ writeTBQueue envQ (RealEnv 55 55)+ threadDelay 100000 -- 10 ms+ assertMotor "light = 55" motor (37, 37)++ atomically $ writeTBQueue envQ (RealEnv 0 0)+ threadDelay 100000 -- 10 ms+ assertMotor "light = 0" motor (0, 75)++ atomically $ writeTBQueue envQ (RealEnv 100 0)+ threadDelay 100000 -- 10 ms+ assertMotor "light = 100" motor (75, 0)++ setLoop t
+ LICENSE view
@@ -0,0 +1,9 @@+Copyright (c) 2013, Alexander Thiemann+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 the <ORGANIZATION> nor the names of its 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 HOLDER 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.
+ NXT/Common.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Module : NXT.Interpretation+-- Copyright : Alexander Thiemann <mail@agrafix.net>+-- License : BSD3+--+-- Maintainer : Alexander Thiemann <mail@agrafix.net>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+module NXT.Common where++import NXT.Core+import Data.Typeable++wait :: V (V Integer -> V ())+wait = defExt "Wait"
+ NXT/Core.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE InstanceSigs #-}+-- |+-- Module : NXT.Core+-- Copyright : Alexander Thiemann <mail@agrafix.net>+-- License : BSD3+--+-- Maintainer : Alexander Thiemann <mail@agrafix.net>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+module NXT.Core+ ( void, (#=), ($=), newVar, newFun, ret, ifThenElse, while, when+ , (<), (>), (<=), (>=), (==), (/=), (&&), (||)+ , (.!)+ , castFloat, castInt+ , true, false+ , mkProg, setMain, mkTree+ , callF, callF1, callF2, callF3, callF4+ , vCallF, vCallF1, vCallF2, vCallF3, vCallF4+ , defExt, mkLit+ , V, def+ )+where++import NXT.Types+import NXT.Interpretation++import Data.List+import Data.Typeable+import Control.Monad hiding (void, when)+import Control.Monad.RWS hiding (void, when)++import Data.String++import Prelude hiding ((<), (>), (<=), (>=), (==), (/=), (&&), (||))+import qualified Prelude as P++prettyFD :: FunDefinition -> String+prettyFD (FunDefinition name ty args body) =+ ty ++ " " ++ name ++ "(" ++ arglist ++ ") {" ++ (concatMap prettyStmt body) ++ "}"+ where+ arglist = intercalate ", " $ map (\(DeclVar arg) -> ((getCType arg) ++ " " ++ (prettyV arg))) args++prettyStmt :: Stmt -> String+prettyStmt (If cond t f) =+ "if (" ++ (prettyV cond) ++ ") {"+ ++ (concatMap prettyStmt t) ++ "}"+ ++ (case f of+ [] -> ""+ _ -> "else { " ++ (concatMap prettyStmt f) ++ "}"+ )+prettyStmt (While cond loop) =+ "while (" ++ (prettyV cond) ++ ") {"+ ++ (concatMap prettyStmt loop) ++ "}"+prettyStmt (DeclVar var@(V (VarP name))) =+ (getCType var) ++ " " ++ (prettyV var) ++ ";"+prettyStmt (AssignVar v@(V (VarP pointer)) val) =+ (prettyV v) ++ " = " ++ (prettyV val) ++ ";"+prettyStmt (Eval something) =+ (prettyV something) ++ ";"+prettyStmt (FunReturn val) =+ "return " ++ prettyV val ++ ";"++prettyStmt _ = error "Error: Invalid syntax tree"++instance (Num a, Typeable a) => Num (V a) where+ x + y = pack $ BinOp BAdd x y+ x * y = pack $ BinOp BMul x y+ x - y = pack $ BinOp BSub x y+ abs x = error "Not implemented"+ signum x = error "Not implemented"+ fromInteger = pack . Lit . fromInteger++instance Fractional (V Float) where+ x / y = pack $ BinOp BDiv x y+ fromRational = pack . Rat . fromRational++instance IsString (V String) where+ fromString str = pack . StrLit $ str++-- | logic and+(&&) :: V Bool -> V Bool -> V Bool+a && b = pack $ BinOp BAnd a b++-- | logic or+(||) :: V Bool -> V Bool -> V Bool+a || b = pack $ BinOp BOr a b++-- | compare two numbers for >+(>) :: (Num a) => V a -> V a -> V Bool+a > b = pack $ BinOp BLt a b++-- | compare two numbers for <+(<) :: (Num a) => V a -> V a -> V Bool+a < b = pack $ BinOp BSt a b++-- | compare two numbers for >=+(>=) :: (Num a) => V a -> V a -> V Bool+a >= b = pack $ BinOp BLEq a b++-- | compare two numbers for <=+(<=) :: (Num a) => V a -> V a -> V Bool+a <= b = pack $ BinOp BSEq a b++-- | the c++ == operation+(==) :: V a -> V a -> V Bool+a == b = pack $ BinOp BEq a b++-- | the c++ != operation+(/=) :: V a -> V a -> V Bool+a /= b = pack $ BinOp BNEq a b++-- | string concatination+(&) :: V String -> V String -> V String+a & b = pack $ FunCall2 "StrCat" a b++-- | Define an external function. Don't forget to add a type signature+defExt :: (Typeable a) => String -> V a+defExt name = pack $ FunP name++-- | Define an external literal. Don't forget to add a type signature+mkLit :: (Typeable a) => Int -> V a+mkLit lit = pack $ Lit lit++-- | Just "true"+true :: V Bool+true = pack $ BoolLit True++-- | Just "false"+false :: V Bool+false = pack $ BoolLit False++-- | Cast an int to a float+castFloat :: V Int -> V Float+castFloat x = pack $ CastOp "cast2float" x+++-- | Cast a float to an int+castInt :: V Float -> V Int+castInt x = pack $ CastOp "cast2int" x++-- | Void. Do nothing+void :: V ()+void = pack $ Void++-- | Execute a void statement+(.!) :: (Typeable a) => V a -> FunM ()+(.!) stmt =+ tell [Eval stmt]++-- | non monadic variable assignment+($=) :: (Typeable a) => V a -> V a -> FunM ()+varP $= nonMonadic =+ varP #= (return nonMonadic)++-- | monadic variable assignment (deprecated)+(#=) :: (Typeable a) => V a -> FunM (V a) -> FunM ()+v@(V (VarP pointer)) #= val =+ do rVal <- val+ tell [AssignVar v rVal]+(#=) _ _ = error "LH must be variable!"++newtype FResult a = FResult { unFResult :: a }++-- | define a functions return value+ret :: (Typeable a) => V a -> FunM (FResult (V a))+ret val =+ do tell [FunReturn val]+ return $ FResult val++-- | the c++ while construct+while :: V Bool -> FunM () -> FunM ()+while cond loop =+ do orig <- get+ (_, _, loopOut) <- lift $ runRWST loop "loop" (orig + 200)+ tell [While cond loopOut]++-- | when+when :: V Bool -> FunM () -> FunM ()+when cond t =+ ifThenElse cond t ((.!) void)++-- | the c++ if then else construct+ifThenElse :: V Bool -> FunM () -> FunM () -> FunM ()+ifThenElse cond t f =+ do orig <- get+ (_, _, tOut) <- lift $ runRWST t "ifTrue" (orig + 200)+ (_, _, fOut) <- lift $ runRWST f "ifFalse" (orig + 200)+ tell [If cond tOut fOut]++getCType :: (Typeable a) => V a -> String+getCType a+ | (aT P.== strT) = "string"+ | (aT P.== boolT) = "bool"+ | (aT P.== intT) = "int"+ | (aT P.== integerT) = "int"+ | (aT P.== dblT) = "double"+ | (aT P.== floatT) = "float"+ | (aT P.== voidT) = "void"+ | otherwise = error $ "Unknown type " ++ show aT+ where+ aT = typeOf a+ voidT = typeOf $ (undefined :: V ())+ strT = typeOf $ (undefined :: V String)+ boolT = typeOf $ (undefined :: V Bool)+ integerT = typeOf $ (undefined :: V Integer)+ intT = typeOf $ (undefined :: V Int)+ dblT = typeOf $ (undefined :: V Double)+ floatT = typeOf $ (undefined :: V Float)++-- | declare a new variable, no type signature needed, will be inferred.+newVar :: forall a. (Typeable a)+ => FunM (V a)+newVar =+ do orig <- get+ let name = orig + 1+ var :: V a+ var = V (VarP $ "v" ++ show name)+ put name+ tell [DeclVar var]+ --tell ((getCType var) ++ " " ++ (prettyV var) ++ ";")+ return $ var++-- | declare a new function, no type signature needed, will be inferred.+newFun :: forall a. (Typeable a)+ => TopM (V a)+newFun =+ do orig <- get+ let name = orig + 1+ fun = FunP $ "f" ++ (show name)+ put name+ return $ pack fun++funTpl funN fType fArgs fBody =+ do tell $ funHeader ++ ";"+ tell $ funHeader ++ " { " ++ (concatMap prettyStmt fBody) ++ " }"+ where+ funHeader = fType ++ " " ++ funN+ ++ "(" ++ (intercalate "," $ map (\(t, v) -> t ++ " " ++ v) fArgs) ++ ")"++class (Typeable a) => FunDef a b | b -> a where+ -- | Define a declared function+ def :: V a -> b -> TopM ()++instance forall a. (Typeable a) => FunDef a (FunM (FResult (V a))) where+ def name funAction =+ do (x, _, out) <- runRWST (funAction) (prettyV name) 0+ tell [FunDefinition (prettyV name) (getCType $ unFResult x) [] out]+ return ()++instance forall a b. (Typeable a, Typeable b) => FunDef (V a -> V b) (V a -> FunM (FResult (V b))) where+ def name funAction =+ do let var :: V a+ var = V (VarP "p1")+ (x, _, out) <- runRWST (funAction var) (prettyV name) 0+ tell [FunDefinition (prettyV name) (getCType $ unFResult x) [DeclVar var] out]+ return ()++instance forall a b c. (Typeable a, Typeable b, Typeable c) => FunDef (V a -> V b -> V c) ((V a -> V b -> FunM (FResult (V c)))) where+ def name funAction =+ do let var :: V a+ var = V (VarP "p1")+ var2 :: V b+ var2 = V (VarP "p2")+ (x, _, out) <- runRWST (funAction var var2) (prettyV name) 0+ tell [FunDefinition (prettyV name) (getCType $ unFResult x) [DeclVar var, DeclVar var2] out]+ return ()++instance forall a b c d. (Typeable a, Typeable b, Typeable c, Typeable d) => FunDef (V a -> V b -> V c -> V d) ((V a -> V b -> V c -> FunM (FResult (V d)))) where+ def name funAction =+ do let var :: V a+ var = V (VarP "p1")+ var2 :: V b+ var2 = V (VarP "p2")+ var3 :: V c+ var3 = V (VarP "p3")+ (x, _, out) <- runRWST (funAction var var2 var3) (prettyV name) 0+ tell [FunDefinition (prettyV name) (getCType $ unFResult x) [DeclVar var, DeclVar var2, DeclVar var3] out]+ return ()++instance forall a b c d e. (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) => FunDef (V a -> V b -> V c -> V d -> V e) ((V a -> V b -> V c -> V d -> FunM (FResult (V e)))) where+ def name funAction =+ do let var :: V a+ var = V (VarP "p1")+ var2 :: V b+ var2 = V (VarP "p2")+ var3 :: V c+ var3 = V (VarP "p3")+ var4 :: V d+ var4 = V (VarP "p4")+ (x, _, out) <- runRWST (funAction var var2 var3 var4) (prettyV name) 0+ tell [FunDefinition (prettyV name) (getCType $ unFResult x) [DeclVar var, DeclVar var2, DeclVar var3, DeclVar var4] out]+ return ()++-- | Call a function with no arguments+callF :: forall a. (Typeable a)+ => (V a) -> (V a)+callF fp@(V (FunP name)) =+ pack $ FunCall (prettyV fp)+callF _ = error "Can only call functions!"++-- | Call a function with one argument+callF1 :: forall a b. (Typeable a, Typeable b)+ => (V (V a -> V b)) -> V a -> (V b)+callF1 fp@(V (FunP name)) arg =+ pack $ FunCall1 (prettyV fp) arg+callF1 _ _ = error "Can only call functions!"++-- | Call a function with two arguments+callF2 :: forall a b c. (Typeable a, Typeable b, Typeable c)+ => (V (V a -> V b -> V c)) -> V a -> V b -> (V c)+callF2 fp@(V (FunP name)) arg1 arg2 =+ pack $ FunCall2 (prettyV fp) arg1 arg2+callF2 _ _ _ = error "Can only call functions!"++-- | Call a function with tree arguments+callF3 :: forall a b c d. (Typeable a, Typeable b, Typeable c, Typeable d)+ => (V (V a -> V b -> V c -> V d)) -> V a -> V b -> V c -> V d+callF3 fp@(V (FunP name)) arg1 arg2 arg3 =+ pack $ FunCall3 (prettyV fp) arg1 arg2 arg3+callF3 _ _ _ _ = error "Can only call functions!"++-- | Call a function with four arguments+callF4 :: forall a b c d e. (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)+ => (V (V a -> V b -> V c -> V d -> V e)) -> V a -> V b -> V c -> V d -> V e+callF4 fp@(V (FunP name)) arg1 arg2 arg3 arg4 =+ pack $ FunCall4 (prettyV fp) arg1 arg2 arg3 arg4+callF4 _ _ _ _ _ = error "Can only call functions!"++vCallF fp = (.!)$ callF fp+vCallF1 fp arg = (.!)$ callF1 fp arg+vCallF2 fp argA argB = (.!)$ callF2 fp argA argB+vCallF3 fp argA argB argC = (.!)$ callF3 fp argA argB argC+vCallF4 fp argA argB argC argD = (.!)$ callF4 fp argA argB argC argD++-- | Make Syntax-Tree+mkTree :: TopM a -> IO [FunDefinition]+mkTree prog =+ do (_, _, out) <- runRWST (mkStdLib >> prog) () 0+ return out++-- | Generate NXC code from your dsl+mkProg :: FilePath -> [FunDefinition] -> IO ()+mkProg filename prog =+ do writeFile filename $ concatMap prettyFD prog+ putStrLn "Finished generating NXC code ..."+ putStrLn $ "Written to " ++ filename++mkStdLib :: TopM ()+mkStdLib =+ do let var :: V Float+ var = V (VarP "f")+ body = [FunReturn var]++ var2 :: V Int+ var2 = V (VarP "i")+ body2 = [FunReturn var2]++ tell [FunDefinition "cast2int" "int" [DeclVar var] body]+ tell [FunDefinition "cast2float" "float" [DeclVar var2] body2]++-- | Define a function as main task+setMain :: V a -> TopM ()+setMain fp@(V (FunP name)) =+ tell [FunDefinition "main" "task" [] [Eval $ callF fp]]
+ NXT/Interpretation.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE GADTs, DeriveDataTypeable, DoAndIfThenElse #-}+-- |+-- Module : NXT.Interpretation+-- Copyright : Alexander Thiemann <mail@agrafix.net>+-- License : BSD3+--+-- Maintainer : Alexander Thiemann <mail@agrafix.net>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+module NXT.Interpretation+ ( runVM+ , RealEnv (..)+ , MotorState(..)+ )+where++import NXT.Types++import Data.IORef+import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.Trans+import Control.Monad.Trans.Resource+import qualified Data.HashMap.Strict as HM++type EnvChan = TBQueue RealEnv+data RealEnv+ = RealEnv+ { re_light :: Int+ , re_ultra :: Int+ } deriving (Show)++data MotorState+ = MotorState+ { m_a :: TVar Int+ , m_b :: TVar Int+ , m_c :: TVar Int+ }++getMS 0 = m_a+getMS 1 = m_b+getMS 2 = m_c++data SensorState+ = SensorState+ { s_1 :: TVar Int+ , s_2 :: TVar Int+ , s_3 :: TVar Int+ , s_4 :: TVar Int+ }++data SensorReads+ = SensorReads+ { sr_1 :: TVar (RealEnv -> Int)+ , sr_2 :: TVar (RealEnv -> Int)+ , sr_3 :: TVar (RealEnv -> Int)+ , sr_4 :: TVar (RealEnv -> Int)+ }++getSS :: Int -> (SensorState -> TVar Int)+getSS 0 = s_1+getSS 1 = s_2+getSS 2 = s_3+getSS 3 = s_4++getSR :: Int -> (SensorReads -> TVar (RealEnv -> Int))+getSR 0 = sr_1+getSR 1 = sr_2+getSR 2 = sr_3+getSR 3 = sr_4++data FunMap+ = FunMap+ { fm_funs :: HM.HashMap String FunDefinition+ , fm_apiCall :: String -> [NXTVal] -> IO NXTVal+ }++type Env = IORef (HM.HashMap String (IORef NXTVal))++data NXTVal+ = NInt Int+ | NFloat Float+ | NStr String+ | NBool Bool+ | NVoid+ deriving (Eq, Show, Ord)++emptyEnv :: IO Env+emptyEnv = newIORef HM.empty++isBound :: Env -> String -> IO Bool+isBound envR var =+ readIORef envR >>= return . maybe False (const True) . HM.lookup var++getVar :: Env -> String -> IO NXTVal+getVar envR var =+ do env <- liftIO $ readIORef envR+ maybe (error $ "Getting an unbound variable " ++ var)+ (liftIO . readIORef)+ (HM.lookup var env)++setVar :: Env -> String -> NXTVal -> IO NXTVal+setVar envR var value =+ do env <- liftIO $ readIORef envR+ maybe (error $ "Setting an unbound variable " ++ var)+ (liftIO . (flip writeIORef value))+ (HM.lookup var env)+ return value++defineVar :: Env -> String -> NXTVal -> IO NXTVal+defineVar envR var value = do+ alreadyDefined <- liftIO $ isBound envR var+ if alreadyDefined+ then setVar envR var value >> return value+ else liftIO $ do+ valueR <- newIORef value+ env <- readIORef envR+ writeIORef envR (HM.insert var valueR env)+ return value++runVM :: MonadResource m => [FunDefinition] -> m (EnvChan, MotorState)+runVM fd =+ do env <- liftIO emptyEnv+ envChan <- liftIO $ atomically $ newTBQueue 20+ b <- liftIO motorState+ c <- liftIO sensorState+ d <- liftIO sensorReads++ case HM.lookup "main" funMap of+ Just fd ->+ do _ <- allocate (forkIO (updateLoop envChan c d)) (killThread)+ _ <- allocate (forkIO $ runDef (FunMap funMap (apiCall envChan b c d)) env fd) (killThread)+ return (envChan, b)+ Nothing ->+ error "No main task found."+ where+ updateLoop envQ sensor sensorR =+ do logE <- atomically $+ do env <- readTBQueue envQ+ mapM_ (\sensorId ->+ do extractFun <- readTVar ((getSR sensorId) sensorR)+ let envVal = (extractFun env)+ writeTVar ((getSS sensorId) sensor) envVal+ ) [0..3]+ return env+ putStrLn $ "New Environment: " ++ (show logE)+ updateLoop envQ sensor sensorR++ funMap = foldl (\hm f@(FunDefinition name _ _ _) -> HM.insert name f hm) HM.empty fd+ apiCall env motor sensor sensorR funName input =+ do ret <- apiCall' env motor sensor sensorR funName input+ putStrLn $ "Called " ++ (show (funName, input))+ putStrLn $ "Got: " ++ show ret+ return ret+ apiCall' env motor sensor sensorR funName input =+ case (funName, input) of+ ("Wait", [NInt time]) ->+ do threadDelay (1000 * time)+ return NVoid+ ("SetSensorLight", [NInt sensorId]) ->+ do atomically $ writeTVar ((getSR sensorId) sensorR) re_light+ return NVoid+ ("Sensor", [NInt sensorId]) ->+ do ct <- atomically $ readTVar ((getSS sensorId) sensor)+ return $ NInt ct+ ("OnFwd", [NInt motorId, NInt motorPwr]) ->+ do atomically $ writeTVar ((getMS motorId) motor) motorPwr+ return NVoid+ x ->+ error $ "Call to undefined function " ++ (show x)++ motorState = MotorState <$> zero <*> zero <*> zero+ sensorState = SensorState <$> zero <*> zero <*> zero <*> zero+ sensorReads = SensorReads+ <$> unknown+ <*> unknown+ <*> unknown+ <*> unknown+ zero = atomically $ newTVar 0+ unknown = atomically $ newTVar $ (\_ -> -1)++runDef :: FunMap -> Env -> FunDefinition -> IO ()+runDef funMap env (FunDefinition _ _ _ body) =+ mapM_ (runStmt funMap env) body++runStmt :: FunMap -> Env -> Stmt -> IO ()+runStmt funMap env (If condR t f) =+ do (NBool cond) <- runV funMap env condR+ if cond+ then mapM_ (runStmt funMap env) t+ else mapM_ (runStmt funMap env) f+runStmt funMap env l@(While condR loop) =+ do (NBool cond) <- runV funMap env condR+ if cond+ then do mapM_ (runStmt funMap env) loop+ runStmt funMap env l+ else return ()+runStmt funMap env (DeclVar (V (VarP p))) =+ do defineVar env p NVoid+ return ()+runStmt funMap env (AssignVar (V (VarP p)) valR) =+ do val <- runV funMap env valR+ setVar env p val+ return ()++runStmt funMap env (Eval v) =+ do _ <- runV funMap env v+ return ()+runStmt funMap env (FunReturn v) =+ do val <- runV funMap env v+ defineVar env "__funReturnVal" val+ return ()++runV :: FunMap -> Env -> V a -> IO NXTVal+runV funMap env ct = runT funMap env (unpack ct)++runT :: FunMap -> Env -> T a -> IO NXTVal+runT _ _ Void = return NVoid+runT _ env (VarP p) = getVar env p+runT _ env (Lit i) = return $ NInt i+runT _ env (Rat i) = return $ NFloat i+runT _ env (StrLit str) = return $ NStr str+runT _ env (BoolLit b) = return $ NBool b++runT funMap env (CastOp "cast2int" val) =+ do evaluated <- runV funMap env val+ case evaluated of+ NFloat f -> return $ NInt $ floor f+ _ -> error "Invalid cast."+runT funMap env (CastOp "cast2float" val) =+ do evaluated <- runV funMap env val+ case evaluated of+ NInt i -> return $ NFloat $ fromIntegral i+ _ -> error "Invalid cast."++runT funMap env (BinOp op xR yR) =+ do x <- runV funMap env xR+ y <- runV funMap env yR++ case (x, op, y) of+ (NInt a, BAdd, NInt b) -> return $ NInt (a + b)+ (NInt a, BSub, NInt b) -> return $ NInt (a - b)+ (NInt a, BMul, NInt b) -> return $ NInt (a * b)++ (NFloat a, BAdd, NFloat b) -> return $ NFloat (a + b)+ (NFloat a, BSub, NFloat b) -> return $ NFloat (a - b)+ (NFloat a, BMul, NFloat b) -> return $ NFloat (a * b)+ (NFloat a, BDiv, NFloat b) -> return $ NFloat (a / b)++ (NInt a, BSub, NFloat b) -> return $ NFloat ((fromIntegral a) - b)+ (NFloat a, BSub, NInt b) -> return $ NFloat (a - (fromIntegral b))+ (NInt a, BMul, NFloat b) -> return $ NFloat ((fromIntegral a) * b)+ (NFloat a, BMul, NInt b) -> return $ NFloat (a * (fromIntegral b))+ (NInt a, BAdd, NFloat b) -> return $ NFloat ((fromIntegral a) + b)+ (NFloat a, BAdd, NInt b) -> return $ NFloat (a + (fromIntegral b))++ (a, BEq, b) -> return $ NBool (a == b)+ (a, BNEq, b) -> return $ NBool (a /= b)+ (a, BLt, b) -> return $ NBool (a > b)+ (a, BSt, b) -> return $ NBool (a < b)+ (a, BLEq, b) -> return $ NBool (a >= b)+ (a, BSEq, b) -> return $ NBool (a <= b)++ (NBool a, BAnd, NBool b) -> return $ NBool (a && b)+ (NBool a, BOr, NBool b) -> return $ NBool (a || b)+ x -> error $ "Unknown operation: " ++ show x++runT funMap env (FunCall name) =+ apply funMap name []++runT funMap env (FunCall1 name a) =+ do aR <- runV funMap env a+ apply funMap name [aR]++runT funMap env (FunCall2 name a b) =+ do aR <- runV funMap env a+ bR <- runV funMap env b+ apply funMap name [aR, bR]++runT funMap env (FunCall3 name a b c) =+ do aR <- runV funMap env a+ bR <- runV funMap env b+ cR <- runV funMap env c+ apply funMap name [aR, bR, cR]++runT funMap env (FunCall4 name a b c d) =+ do aR <- runV funMap env a+ bR <- runV funMap env b+ cR <- runV funMap env c+ dR <- runV funMap env d+ apply funMap name [aR, bR, cR, dR]++runT _ env t = error $ "Not implemented:" ++ (prettyT t)++reqV (V (VarP p)) = p+reqV x = error $ "Require a variable, but got: " ++ (prettyV x)++getArgs funMap funName =+ case HM.lookup funName (fm_funs funMap) of+ Just (FunDefinition _ _ args _) ->+ map (\(DeclVar arg) -> reqV arg) args+ Nothing ->+ error $ "Function " ++ funName ++ " is not defined."++apply :: FunMap -> String -> [NXTVal] -> IO NXTVal+apply funMap funName inpVals =+ do funEnv <- emptyEnv++ case HM.lookup funName (fm_funs funMap) of+ Just fd ->+ do let args = getArgs funMap funName+ vars = zip inpVals args+ mapM_ (\(src, tgt) ->+ defineVar funEnv tgt src+ ) vars+ runDef funMap funEnv fd+ getVar funEnv "__funReturnVal"+ Nothing ->+ (fm_apiCall funMap) funName inpVals
+ NXT/Motor.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Module : NXT.Motor+-- Copyright : Alexander Thiemann <mail@agrafix.net>+-- License : BSD3+--+-- Maintainer : Alexander Thiemann <mail@agrafix.net>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+module NXT.Motor where++import NXT.Core+import Data.Typeable++data Motor = Motor deriving (Typeable)++_OUT_A_ :: V Motor+_OUT_A_ = mkLit 0++_OUT_B_ :: V Motor+_OUT_B_ = mkLit 1++_OUT_C_ :: V Motor+_OUT_C_ = mkLit 2++{--+_OUT_AB_ :: V Motor+_OUT_AB_ = mkLit 3++_OUT_AC_ :: V Motor+_OUT_AC_ = mkLit 4++_OUT_BC_ :: V Motor+_OUT_BC_ = mkLit 5++_OUT_ABC_ :: V Motor+_OUT_ABC_ = mkLit 6+--}++onFwd :: V (V Motor -> V Int -> V ())+onFwd = defExt "OnFwd"++onRev :: V (V Motor -> V Int -> V ())+onRev = defExt "OnRev"++off :: V (V Motor -> V ())+off = defExt "Off"
+ NXT/Sensor.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Module : NXT.Sensor+-- Copyright : Alexander Thiemann <mail@agrafix.net>+-- License : BSD3+--+-- Maintainer : Alexander Thiemann <mail@agrafix.net>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+module NXT.Sensor where++import NXT.Core+import Data.Typeable++data Sensor = Sensor deriving (Typeable)++_IN_1_ :: V Sensor+_IN_1_ = mkLit 0++_IN_2_ :: V Sensor+_IN_2_ = mkLit 1++_IN_3_ :: V Sensor+_IN_3_ = mkLit 2++_IN_4_ :: V Sensor+_IN_4_ = mkLit 3++setSensorLight :: V (V Sensor -> V ())+setSensorLight = defExt "SetSensorLight"++sensor :: V (V Sensor -> V Int)+sensor = defExt "Sensor"
+ NXTDSL.cabal view
@@ -0,0 +1,29 @@+Name: NXTDSL+Version: 0.1+Synopsis: Generate NXC Code from DSL+Description: Typesafe code generation for the LEGO-NXT+License: BSD3+License-File: LICENSE+Author: Alexander Thiemann+Maintainer: Alexander Thiemann <mail@agrafix.net>+Copyright: Copyright (c) 2013 Alexander Thiemann+Build-Type: Simple+Cabal-Version: >=1.6+Category: Language, Compilers/Interpreters+Homepage: https://github.com/agrafix/legoDSL+Bug-reports: https://github.com/agrafix/legoDSL/issues++Library+ Build-Depends: base >= 3 && < 5, mtl, unordered-containers, resourcet >= 0.4.4, stm >= 2.4.2+ Exposed-modules: NXT.Core, NXT.Interpretation, NXT.Common, NXT.Motor, NXT.Sensor++Executable ExampleRun+ Main-Is: Example.hs++Executable ExampleVM+ Main-Is: ExampleVM.hs+ ghc-options: -threaded++Source-repository head+ Type: git+ Location: git://github.com/agrafix/legoDSL.git
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain