diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Takamasa Mitsuji +Copyright (c) 2016, Takamasa Mitsuji All rights reserved. diff --git a/cbits/hs_fcntl.c b/cbits/hs_fcntl.c new file mode 100644 --- /dev/null +++ b/cbits/hs_fcntl.c @@ -0,0 +1,15 @@ +#include "hs_fcntl.h" + +#include + + +int o_rdonly() { + return O_RDONLY; +} +int o_wronly() { + return O_WRONLY; +} +int o_rdwr() { + return O_RDWR; +} + diff --git a/cbits/hs_i2c.c b/cbits/hs_i2c.c new file mode 100644 --- /dev/null +++ b/cbits/hs_i2c.c @@ -0,0 +1,10 @@ +#include "hs_i2c.h" + +#include +#include +#include + + +int i2c_set_slave(int fd, __u8 slave) { + return ioctl(fd,I2C_SLAVE,slave); +} diff --git a/cbits/hs_spi.c b/cbits/hs_spi.c new file mode 100644 --- /dev/null +++ b/cbits/hs_spi.c @@ -0,0 +1,64 @@ +#include "hs_spi.h" + +#include +#include +#include + + +unsigned char spi_mode_0() { + return SPI_MODE_0; +} +unsigned char spi_mode_1() { + return SPI_MODE_1; +} +unsigned char spi_mode_2() { + return SPI_MODE_2; +} +unsigned char spi_mode_3() { + return SPI_MODE_3; +} + + +int spi_transfer_message_1(int fd, void* buff, __u32 buff_len, __u32 speed, __u8 bits) { + + struct spi_ioc_transfer spi; + spi.tx_buf = (__u64) buff; + spi.rx_buf = (__u64) buff; + spi.len = buff_len; + spi.speed_hz = speed; + spi.bits_per_word = bits; + spi.delay_usecs = 0; + spi.cs_change = 0; + + return ioctl(fd,SPI_IOC_MESSAGE(1),&spi); +} + +int spi_set_rd_mode(int fd, __u8 mode) { + return ioctl(fd,SPI_IOC_RD_MODE,&mode); +} +int spi_set_wr_mode(int fd, __u8 mode) { + return ioctl(fd,SPI_IOC_WR_MODE,&mode); +} + +int spi_set_rd_lbs_first(int fd, __u8 lbs) { + return ioctl(fd,SPI_IOC_RD_LSB_FIRST,&lbs); +} +int spi_set_wr_lbs_first(int fd, __u8 lbs) { + return ioctl(fd,SPI_IOC_WR_LSB_FIRST,&lbs); +} + +int spi_set_rd_bits_per_word(int fd, __u8 bits) { + return ioctl(fd,SPI_IOC_RD_BITS_PER_WORD,&bits); +} +int spi_set_wr_bits_per_word(int fd, __u8 bits) { + return ioctl(fd,SPI_IOC_WR_BITS_PER_WORD,&bits); +} + +int spi_set_rd_max_speed_hz(int fd, __u32 speed) { + return ioctl(fd,SPI_IOC_RD_MAX_SPEED_HZ,&speed); +} +int spi_set_wr_max_speed_hz(int fd, __u32 speed) { + return ioctl(fd,SPI_IOC_WR_MAX_SPEED_HZ,&speed); +} + + diff --git a/huckleberry.cabal b/huckleberry.cabal --- a/huckleberry.cabal +++ b/huckleberry.cabal @@ -1,36 +1,32 @@ name: huckleberry -version: 0.9.0.2 -synopsis: IchigoJam BASIC expressed in Haskell. -description: The EDSL Provides bridge between IchigoJam BASIC and Haskell. +version: 0.9.1.0 +synopsis: Haskell IOT on Intel Edison and other Linux computers. +description: Please see README.md +homepage: https://github.com/mitsuji/huckleberry#readme license: BSD3 license-file: LICENSE author: Takamasa Mitsuji maintainer: tkms@mitsuji.org --- copyright: 2010 Author Here -category: Language +copyright: 2016 Takamasa Mitsuji +category: System build-type: Simple -- extra-source-files: cabal-version: >=1.10 library hs-source-dirs: src - exposed-modules: IchigoJam, Language.Huckleberry.V10101 - other-extensions: GADTs + exposed-modules: System.PIO + , System.PIO.Linux + , System.PIO.Linux.GPIO + , System.PIO.Linux.PWM + , System.PIO.Linux.I2C + , System.PIO.Linux.SPI build-depends: base >= 4.7 && < 5 - , mtl - , bytestring - , serialport default-language: Haskell2010 - -test-suite huckleberry-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: test_Huckleberry_V10101.hs - build-depends: base - , huckleberry - , HUnit - ghc-options: -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 + c-sources: cbits/hs_fcntl.c + , cbits/hs_i2c.c + , cbits/hs_spi.c + include-dirs: include source-repository head type: git diff --git a/src/IchigoJam.hs b/src/IchigoJam.hs deleted file mode 100644 --- a/src/IchigoJam.hs +++ /dev/null @@ -1,93 +0,0 @@ -module IchigoJam ( - Handle(Handle) - ,open - ,opend - ,close - ,send - ,recv - ,led - ,play - ,btn - ) where - - -import qualified Data.ByteString.Char8 as B -import qualified System.Hardware.Serialport as S -import Control.Monad(forM_,foldM,forever) -import Control.Concurrent(ThreadId,forkIO,killThread,threadDelay) - - - - -led :: Handle -> Bool -> IO () -led h on = do - let flag = case on of - True -> "1" - False -> "0" - send h $ "LED " ++ flag ++ "\n" - r <- recv h 4 - return () - - -play :: Handle -> String -> IO () -play h score = do - send h $ "PLAY \"" ++ score ++ "\"\n" - r <- recv h 4 - return () - - -btn :: Handle -> IO Bool -btn h = do - send h $ "PRINT BTN ()\n" - r <- recv h 4 -- [TODO] convert to Bool - putStrLn r - return True - - - - - -defaultSendDelay = 50 * 1000 -defaultRecvDelay = 50 * 1000 - - -data Handle = Handle - { port :: S.SerialPort - , sendDelay :: Int - , recvDelay :: Int - } - - -open :: FilePath -> Int -> Int -> IO Handle -open path sd rd = do - p <- S.openSerial path S.defaultSerialSettings { - S.commSpeed = S.CS115200 - } - return $ Handle p sd rd - -opend path = open path defaultSendDelay defaultRecvDelay - - -close :: Handle -> IO() -close (Handle p sd rd) = do - S.closeSerial p - - -send :: Handle -> String -> IO() -send (Handle p sd _) s = do - forM_ s (\c -> do - S.send p $ B.singleton c - S.flush p - threadDelay sd - ) - - -recv :: Handle -> Int -> IO String -recv (Handle p _ rd) l = do - bs <- foldM( \acc _-> do - b <- S.recv p 1 - threadDelay rd - return $ acc `B.append` b - ) B.empty [1..l] - return $ B.unpack bs - diff --git a/src/Language/Huckleberry/V10101.hs b/src/Language/Huckleberry/V10101.hs deleted file mode 100644 --- a/src/Language/Huckleberry/V10101.hs +++ /dev/null @@ -1,1014 +0,0 @@ -{-# LANGUAGE GADTs #-} - -{-| -The EDSL Provides bridge between IchigoJam BASIC and Haskell. - -References for IchigoJam BASIC are available at -. - - -For example, -\"Jumping rome girl Sacchan\" -could be expressed like this. - -@ -sacchan = do - label 10 $ y=:25 >> v=:99 >> x=:17 >> u=:5 >> s=:0 - label 20 $ ifThen (v\/=99) $ y=:y+v >> v=:v+1 - label 30 $ ifThen (25\> v=:99 >> s=:s+1 - label 40 $ x=:x+u - label 50 $ ifThen (17\> print "\@" - label 110 $ locate x 25 >> print \"-\" - label 120 $ locate 0 0 >> print (\"SCORE:\" ++ s) - label 130 $ ifThen (pre(y==25)*pre(x==17)) end - label 140 $ wait 2 - label 150 $ goto 20 -@ - - -Get IchigoJam BASIC code like this. - -@ -showSacchan = putStr $ translate sacchan -@ - -Also, you can send the code to IchigoJam directly. - -@ -sendSacchan = do - h \<- IJ.opend "\/dev\/ttyUSB0" - IJ.send h $ translate sacchan - IJ.close h -@ - - -To use this, your code should begin with this code block. - -@ -\{\-\# LANGUAGE OverloadedStrings \#\-\} -import Prelude hiding (print,(++),(+),(-),(*),(\/),(%),(==),(\/=),(>=),(>),(\<=),(\<),(&&),(||),not,abs,return) -import qualified Prelude as P -import qualified IchigoJam as IJ -import Language.Huckleberry.V10101 -@ - -For more example. - - - -() is 'pre'. - -Put line number by 'label'. - -\[n\] is 'arr'. - -LET is 'let''. - -\= is '=:'. - -\; is '++'. - -IN is 'in''. - -& is '.&.'. - -| is '.|.'. - -^ is 'xor'. - -\>\> is 'shiftR'. - -\<\< is 'shiftL'. - -~ is 'complement'. - --} -module Language.Huckleberry.V10101 ( - translate - ,pre - ,label - ,ifThenElse - ,ifThen - ,forStepNext - ,forNext - ,a - ,b - ,c - ,d - ,e - ,f - ,g - ,h - ,i - ,j - ,k - ,l - ,m - ,n - ,o - ,p - ,q - ,r - ,s - ,t - ,u - ,v - ,w - ,x - ,y - ,z - ,arr - -- * Commands for beginners - ,let' - ,(=:) - ,print - ,(++) - ,led - ,wait - ,run - ,list - ,list' - ,goto - ,end - ,btn - ,new - ,locate - ,cls - ,rnd - ,save - ,save' - ,load - ,load' - ,files - ,beep - ,beep' - ,play - ,play' - ,tempo - ,(+) - ,(-) - ,(*) - ,(/) - ,(%) - ,input - ,tick - ,clt - ,inkey - ,chr - ,chr' - ,asc - ,scroll - ,scr - ,scr' - ,vpeek - ,vpeek' - ,(==) - ,(/=) - ,(>=) - ,(>) - ,(<=) - ,(<) - ,(&&) - ,(||) - ,not - -- * Commands for experts - ,clv - ,clear - ,clk - ,abs - ,gosub - ,return - ,sound - ,free - ,ver - ,renum - ,renum' - ,lrun - ,file - ,sleep - ,video - ,peek - ,poke - ,clp - ,help - ,ana - ,out - ,out' - ,in' - ,in'' - ,hex - ,hex' - ,bin - ,bin' - ,(.&.) - ,(.|.) - ,xor - ,shiftR - ,shiftL - ,complement - ,bps - ,i2cr - ,i2cw - ,usr -) where - - -import Prelude hiding (print,(++),(+),(-),(*),(/),(%),(==),(/=),(>=),(>),(<=),(<),(&&),(||),not,abs,return) -import Data.Int(Int16) -import Data.List(intercalate) -import qualified Prelude as P -import qualified Data.String as S -import Control.Monad.Writer(Writer,execWriter,tell) - -import qualified IchigoJam as IJ - - - - - -data Expr r where - - Number :: (Num r) => r -> Expr r - Str :: (S.IsString r) => r -> Expr r - - -- Bracket operator - Pre :: Expr Int16 -> Expr Int16 - - A :: Expr Int16 - B :: Expr Int16 - C :: Expr Int16 - D :: Expr Int16 - E :: Expr Int16 - F :: Expr Int16 - G :: Expr Int16 - H :: Expr Int16 - I :: Expr Int16 - J :: Expr Int16 - K :: Expr Int16 - L :: Expr Int16 - M :: Expr Int16 - N :: Expr Int16 - O :: Expr Int16 - P :: Expr Int16 - Q :: Expr Int16 - R :: Expr Int16 - S :: Expr Int16 - T :: Expr Int16 - U :: Expr Int16 - V :: Expr Int16 - W :: Expr Int16 - X :: Expr Int16 - Y :: Expr Int16 - Z :: Expr Int16 - Array :: Expr Int16 -> Expr Int16 - - Concat :: (Show a, Show b, S.IsString c) => Expr a -> Expr b -> Expr c - - - -- - -- Commands for beginners - -- - - -- [TODO] [num]：0(button)/UP/DOWN/RIGHT/LEFT/SPACE, defautl 0 - Btn :: Expr Int16 -> Expr Int16 - - Rnd :: Expr Int16 -> Expr Int16 - - Add :: Expr Int16 -> Expr Int16 -> Expr Int16 - Subtract :: Expr Int16 -> Expr Int16 -> Expr Int16 - Multiply :: Expr Int16 -> Expr Int16 -> Expr Int16 - Divide :: Expr Int16 -> Expr Int16 -> Expr Int16 - Remind :: Expr Int16 -> Expr Int16 -> Expr Int16 - - Tick :: Expr Int16 - Inkey :: Expr Int16 - - Chr :: [Expr Int16] -> Expr String - - Asc :: String -> Expr Int16 - - Scr :: Expr Int16 -> Expr Int16 -> Expr Int16 - Scr' :: Expr Int16 - - Equal :: Expr Int16 -> Expr Int16 -> Expr Int16 - NotEqual :: Expr Int16 -> Expr Int16 -> Expr Int16 - GreaterThanEqual :: Expr Int16 -> Expr Int16 -> Expr Int16 - GreaterThan :: Expr Int16 -> Expr Int16 -> Expr Int16 - LessThanEqual :: Expr Int16 -> Expr Int16 -> Expr Int16 - LessThan :: Expr Int16 -> Expr Int16 -> Expr Int16 - And :: Expr Int16 -> Expr Int16 -> Expr Int16 - Or :: Expr Int16 -> Expr Int16 -> Expr Int16 - Not :: Expr Int16 -> Expr Int16 - - - -- - -- Commands for experts - -- - Abs :: Expr Int16 -> Expr Int16 - Sound :: Expr Int16 - Free :: Expr Int16 - Ver :: Expr Int16 - File :: Expr Int16 - Peek :: Expr Int16 -> Expr Int16 - Ana :: Expr Int16 -> Expr Int16 - - In' :: Expr Int16 -> Expr Int16 - In'' :: Expr Int16 - - Hex :: Expr Int16 -> Expr Int16 -> Expr String - Hex' :: Expr Int16 -> Expr String - - Bin :: Expr Int16 -> Expr Int16 -> Expr String - Bin' :: Expr Int16 -> Expr String - - BitAnd :: Expr Int16 -> Expr Int16 -> Expr Int16 - BitOr :: Expr Int16 -> Expr Int16 -> Expr Int16 - XOr :: Expr Int16 -> Expr Int16 -> Expr Int16 - ShiftR :: Expr Int16 -> Expr Int16 -> Expr Int16 - ShiftL :: Expr Int16 -> Expr Int16 -> Expr Int16 - Complement :: Expr Int16 -> Expr Int16 - - I2CR :: Expr Int16 -> Expr Int16 -> Expr Int16 -> Expr Int16 -> Expr Int16 -> Expr Int16 - I2CW :: Expr Int16 -> Expr Int16 -> Expr Int16 -> Expr Int16 -> Expr Int16 -> Expr Int16 - USR :: Expr Int16 -> Expr Int16 -> Expr Int16 - - --- Num Literal -instance (Num a) => Num (Expr a) where - (+) (Number n1) (Number n2) = Number (n1 P.+ n2) - (-) (Number n1) (Number n2) = Number (n1 P.- n2) - (*) (Number n1) (Number n2) = Number (n1 P.* n2) - negate (Number n) = Number (negate n) - abs (Number n) = Number (P.abs n) - signum (Number n) = Number (signum n) - fromInteger n = Number (fromInteger n) - - --- OverloadedStrings -instance (S.IsString a) => S.IsString (Expr a) where - fromString s = Str (S.fromString s) - - - - -data Stmt where - - Label :: Int16 -> [Stmt] -> Stmt - - -- IF could be nested - IfThenElse :: Expr Int16 -> [Stmt] -> [Stmt] -> Stmt - IfThen :: Expr Int16 -> [Stmt] -> Stmt - ForStepNext :: Expr Int16 -> Expr Int16 -> Expr Int16 -> Expr Int16 -> [Stmt] -> Stmt - ForNext :: Expr Int16 -> Expr Int16 -> Expr Int16 -> [Stmt] -> Stmt - - - -- - -- Commands for beginners - -- - Let' :: Expr Int16 -> [Expr Int16] -> Stmt - Assign :: Expr Int16 -> Expr Int16 -> Stmt - - Print :: (Show r) => Expr r -> Stmt - - Led :: Expr Int16 -> Stmt - Wait :: Expr Int16 -> Stmt - Run :: Stmt - - List :: Expr Int16 -> Expr Int16 -> Stmt - List' :: Stmt - - - Goto :: Expr Int16 -> Stmt - End :: Stmt - - New :: Stmt - Locate :: Expr Int16 -> Expr Int16 -> Stmt - Cls :: Stmt - - Save :: Expr Int16 -> Stmt - Save' :: Stmt - - Load :: Expr Int16 -> Stmt - Load' :: Stmt - - Files :: Expr Int16 -> Stmt - - Beep :: Expr Int16 -> Expr Int16 -> Stmt - Beep' :: Stmt - - Play :: String -> Stmt - Play' :: Stmt - - Tempo :: Expr Int16 -> Stmt - - Input :: String -> Expr Int16 -> Stmt - Clt :: Stmt - - Scroll :: Expr Int16 -> Stmt - - - -- - -- Commands for experts - -- - Clv :: Stmt - Clk :: Stmt - - Gosub :: Expr Int16 -> Stmt - Return :: Stmt - - Renum :: Expr Int16 -> Stmt - Renum' :: Stmt - - LRun :: Expr Int16 -> Stmt - - Sleep :: Stmt - Video :: Expr Int16 -> Stmt - Poke :: Expr Int16 -> Expr Int16 -> Stmt - Clp :: Stmt - Help :: Stmt - - Out :: Expr Int16 -> Expr Int16 -> Stmt - Out' :: Expr Int16 -> Stmt - - Bps :: Expr Int16 -> Stmt - - - - - -reify :: (Show r) => Expr r -> String - -reify (Number v) = show v -reify (Str v) = show v - -reify (Pre v) = concat ["(", reify v, ")"] - -reify (A) = "A" -reify (B) = "B" -reify (C) = "C" -reify (D) = "D" -reify (E) = "E" -reify (F) = "F" -reify (G) = "G" -reify (H) = "H" -reify (I) = "I" -reify (J) = "J" -reify (K) = "K" -reify (L) = "L" -reify (M) = "M" -reify (N) = "N" -reify (O) = "O" -reify (P) = "P" -reify (Q) = "Q" -reify (R) = "R" -reify (S) = "S" -reify (T) = "T" -reify (U) = "U" -reify (V) = "V" -reify (W) = "W" -reify (X) = "X" -reify (Y) = "Y" -reify (Z) = "Z" -reify (Array i) = concat ["[", reify i, "]"] - -reify (Concat v1 v2) = concat [reify v1, ";", reify v2] - -reify (Btn v) = concat ["BTN(", reify v, ")"] -reify (Rnd v) = concat ["RND(", reify v, ")"] - -reify (Add v1 v2) = concat [reify v1, "+", reify v2] -reify (Subtract v1 v2) = concat [reify v1, "-", reify v2] -reify (Multiply v1 v2) = concat [reify v1, "*", reify v2] -reify (Divide v1 v2) = concat [reify v1, "/", reify v2] -reify (Remind v1 v2) = concat [reify v1, "%", reify v2] - -reify (Tick) = "TICK()" -reify (Inkey) = "INKEY()" -reify (Chr v) = concat ["CHR$(",(intercalate "," (fmap reify v)), ")"] -reify (Asc v) = concat ["ASC(\"", v, "\")"] -reify (Scr') = concat ["SCR()"] -reify (Scr v1 v2) = concat ["SCR(", reify v1, ",", reify v2, ")"] - -reify (Equal v1 v2) = concat [reify v1, "=", reify v2] -reify (NotEqual v1 v2) = concat [reify v1, "!=", reify v2] -reify (GreaterThanEqual v1 v2) = concat [reify v1, ">=", reify v2] -reify (GreaterThan v1 v2) = concat [reify v1, ">", reify v2] -reify (LessThanEqual v1 v2) = concat [reify v1, "<=", reify v2] -reify (LessThan v1 v2) = concat [reify v1, "<", reify v2] -reify (And v1 v2) = concat [reify v1, "AND", reify v2] -reify (Or v1 v2) = concat [reify v1, "OR", reify v2] -reify (Not v) = concat ["!", reify v] - -reify (Abs v) = concat ["ABS(", reify v, ")"] -reify (Sound) = "SOUND()" -reify (Free) = "FREE()" -reify (Ver) = "VER()" -reify (File) = "FILE()" -reify (Peek v) = concat ["PEEK(", reify v, ")"] -reify (Ana v) = concat ["ANA(", reify v, ")"] -reify (In' v) = concat ["IN(", reify v, ")"] -reify (In'') = concat ["IN()"] -reify (Hex v1 v2) = concat ["HEX$(", reify v1, ",", reify v2, ")"] -reify (Hex' v) = concat ["HEX$(", reify v, ")"] -reify (Bin v1 v2) = concat ["BIN$(", reify v1, ",", reify v2, ")"] -reify (Bin' v) = concat ["BIN$(", reify v, ")"] - -reify (BitAnd v1 v2) = concat [reify v1, "&", reify v2] -reify (BitOr v1 v2) = concat [reify v1, "|", reify v2] -reify (XOr v1 v2) = concat [reify v1, "^", reify v2] -reify (ShiftR v1 v2) = concat [reify v1, ">>", reify v2] -reify (ShiftL v1 v2) = concat [reify v1, "<<", reify v2] -reify (Complement v) = concat ["~", reify v] - -reify (I2CR v1 v2 v3 v4 v5) = concat ["I2CR(", reify v1, ",", reify v2, ",", reify v3, ",", reify v4, ",", reify v5, ")"] -reify (I2CW v1 v2 v3 v4 v5) = concat ["I2CW(", reify v1, ",", reify v2, ",", reify v3, ",", reify v4, ",", reify v5, ")"] -reify (USR v1 v2) = concat ["USR(", reify v1, ",", reify v2, ")"] - - - -lToString :: [Stmt] -> String -lToString st = intercalate ":" $ map toString st - - -toString :: Stmt -> String - -toString (Label n st) = concat [(show n), " ", lToString st] -toString (IfThenElse c st1 st2) = concat ["IF", reify c, lToString st1, "ELSE", lToString st2] -toString (IfThen c st) = concat ["IF", reify c, lToString st] -toString (ForStepNext v ini inc step st) = concat ["FOR", reify v, "=", reify ini, "TO", reify inc, "STEP", reify step, ":", lToString st, ":NEXT"] -toString (ForNext v ini inc st) = concat ["FOR", reify v, "=", reify ini, "TO", reify inc, ":", lToString st, ":NEXT"] -toString (Let' v1 v2) = concat ["LET", reify v1, ",", (intercalate "," (fmap reify v2))] -toString (Assign v1 v2) = concat [reify v1, "=", reify v2] -toString (Print v) = concat ["?", reify v] -toString (Led v) = concat ["LED", reify v] -toString (Wait v) = concat ["WAIT", reify v] -toString (Run) = "RUN" -toString (List v1 v2) = concat ["LIST", reify v1, ",", reify v2] -toString (List') = "LIST" -toString (Goto v) = concat ["GOTO", reify v] -toString (End) = "END" -toString (New) = "NEW" -toString (Locate v1 v2) = concat ["LC", reify v1, ",", reify v2] -toString (Cls) = "CLS" -toString (Save v) = concat ["SAVE", reify v] -toString (Save') = "SAVE" -toString (Load v) = concat ["LOAD", reify v] -toString (Load') = "LOAD" -toString (Files v) = concat ["FILES", reify v] -toString (Beep v1 v2) = concat ["BEEP", reify v1, ",", reify v2] -toString (Beep') = "BEEP" -toString (Play v) = concat ["PLAY\"", v, "\""] -toString (Play') = "PLAY" -toString (Tempo v) = concat ["TEMPO", reify v] -toString (Input v1 v2) = concat ["INPUT\"", v1, "\",", reify v2] -toString (Clt) = "CLT" -toString (Scroll v) = concat ["SCROLL", reify v] -toString (Clv) = "CLV" -toString (Clk) = "CLK" -toString (Gosub v) = concat ["GOSUB", reify v] -toString (Return) = "RETURN" -toString (Renum v) = concat ["RENUM", reify v] -toString (Renum') = "RENUM" -toString (LRun v) = concat ["LRUN", reify v] -toString (Sleep) = "SLEEP" -toString (Video v) = concat ["VIDEO", reify v] -toString (Poke v1 v2) = concat ["POKE", reify v1, ",", reify v2] -toString (Clp) = "CLP" -toString (Help) = "HELP" -toString (Out v1 v2) = concat ["OUT", reify v1, ",", reify v2] -toString (Out' v) = concat ["OUT", reify v] -toString (Bps v) = concat ["BPS", reify v] - - - - -type Code = Writer [Stmt] - -{-| Translate huckleberry code to IchigoJam BASIC code. - --} -translate :: Code() -> String -translate c = (intercalate "\n" $ map toString (execWriter c)) P.++ "\n" - -{-| Bracket operator. - -the expression - -@ -pre(y==25)*pre(x==17) -@ - -evaluated as this expression in IchigoJam BASIC. - -@ -(Y=25)*(X=17) -@ - --} -pre = Pre - -{-| Line number statement. - -this expression - -@ -label 40 $ x=:x+u -@ - -evaluated as this statement in IchigoJam BASIC. - -@ -40 X=X+U -@ - --} -label :: Int16 -> Code() -> Code() -label l st = tell [Label l (execWriter st)] - -{-| IF .. THEN .. ELSE .. statement. - --} -ifThenElse :: Expr Int16 -> Code() -> Code() -> Code() -ifThenElse c st1 st2 = tell [IfThenElse c (execWriter st1) (execWriter st2)] - -{-| IF .. THEN .. statement. - --} -ifThen :: Expr Int16 -> Code() -> Code() -ifThen c st = tell [IfThen c (execWriter st)] - -{-| FOR .. = .. TO .. STEP .. .. NEXT statement. - --} -forStepNext :: Expr Int16 -> Expr Int16 -> Expr Int16 -> Expr Int16 -> Code() -> Code() -forStepNext v ini inc step st = tell [ForStepNext v ini inc step (execWriter st)] - -{-| FOR .. = .. TO .. .. NEXT statement. - --} -forNext :: Expr Int16 -> Expr Int16 -> Expr Int16 -> Code() -> Code() -forNext v ini inc st = tell [ForNext v ini inc (execWriter st)] - - -a = A -b = B -c = C -d = D -e = E -f = F -g = G -h = H -i = I -j = J -k = K -l = L -m = M -n = N -o = O -p = P -q = Q -r = R -s = S -t = T -u = U -v = V -w = W -x = X -y = Y -z = Z - -{-| Array valiables expression. - -This expression - -@ -arr 3 -@ - -evaluated as this expression in IchigoJam BASIC. - -@ -\[3\] -@ --} -arr = Array - - - --- --- Commands for beginners --- - -{-| LET statement. - -This expression - -@ -let' a [3] -@ - -evaluated as this statement in IchigoJam BASIC. - -@ -LET A,3 -@ - -Also, this expression - -@ -let' (arr 3) [11,12,13] -@ - -evaluated as this statement in IchigoJam BASIC. - -@ -LET[3],11,12,13 -@ --} -let' :: Expr Int16 -> [Expr Int16] -> Code() -let' v1 v2 = tell [Let' v1 v2] - -{-| Assignment operator.(\=) - -This expression - -@ -x =: x+u -@ - -evaluated as this statement in IchigoJam BASIC. - -@ -X=X+U -@ - --} -(=:) :: Expr Int16 -> Expr Int16 -> Code() -(=:) v1 v2 = tell [Assign v1 v2] -infix 2 =: - -{-| PRINT statement. - --} -print :: (Show r) => Expr r -> Code() -print x = tell [Print x] - -{-| Concatation operator.(;) - --} -(++) :: (Show a, Show b, S.IsString c) => Expr a -> Expr b -> Expr c -(++) = Concat -infixl 2 ++ - -led :: Expr Int16 -> Code() -led s = tell [Led s] - -wait :: Expr Int16 -> Code() -wait t = tell [Wait t] - -run :: Code() -run = tell [Run] - -list :: Expr Int16 -> Expr Int16 -> Code() -list v1 v2 = tell [List v1 v2] - -list' :: Code() -list' = tell [List'] - -goto :: Expr Int16 -> Code() -goto t = tell [Goto t] - -end :: Code() -end = tell [End] - -btn = Btn - -new :: Code() -new = tell [New] - -locate :: Expr Int16 -> Expr Int16 -> Code() -locate v1 v2 = tell [Locate v1 v2] - -cls :: Code() -cls = tell [Cls] - -rnd = Rnd - -save :: Expr Int16 -> Code() -save v = tell [Save v] -save' :: Code() -save' = tell [Save'] - -load :: Expr Int16 -> Code() -load v = tell [Load v] -load' :: Code() -load' = tell [Load'] - -files :: Expr Int16 -> Code() -files v = tell [Files v] - -beep :: Expr Int16 -> Expr Int16 -> Code() -beep v1 v2 = tell [Beep v1 v2] -beep' :: Code() -beep' = tell [Beep'] - -play :: String -> Code() -play c = tell [Play c] -play' :: Code() -play' = tell [Play'] - -tempo :: Expr Int16 -> Code() -tempo t = tell [Tempo t] - -(+) = Add -infixl 6 + - -(-) = Subtract -infixl 6 - - -(*) = Multiply -infixl 7 * - -(/) = Divide -infixl 7 / - -(%) = Remind -infixl 7 % - -input :: String -> Expr Int16 -> Code() -input s v = tell [Input s v] - -tick = Tick - -clt :: Code() -clt = tell [Clt] - -inkey = Inkey - -chr :: Expr Int16 -> Expr String -chr v = Chr [v] - -{-| - --} -chr' :: [Expr Int16] -> Expr String -chr' = Chr - -asc = Asc - -scroll :: Expr Int16 -> Code() -scroll v = tell [Scroll v] - -scr = Scr -scr' = Scr' -vpeek = scr -- alias -vpeek' = scr' -- alias - -(==) = Equal -infix 5 == - -(/=) = NotEqual -infix 5 /= - -(>=) = GreaterThanEqual -infix 5 >= - -(>) = GreaterThan -infix 5 > - -(<=) = LessThanEqual -infix 5 <= - -(<) = LessThan -infix 5 < - -(&&) = And -infixr 4 && - -(||) = Or -infixr 3 || - -not = Not - - - --- --- Commands for experts --- - -clv :: Code() -clv = tell [Clv] -clear = clv -- alias - -clk :: Code() -clk = tell [Clk] - -abs = Abs - -gosub :: Expr Int16 -> Code() -gosub t = tell [Gosub t] - -return :: Code() -return = tell [Return] - -sound = Sound - -free = Free - -ver = Ver - -renum :: Expr Int16 -> Code() -renum v = tell [Renum v] -renum' :: Code() -renum' = tell [Renum'] - -lrun :: Expr Int16 -> Code() -lrun v = tell [LRun v] - -file = File - -sleep :: Code() -sleep = tell [Sleep] - -video :: Expr Int16 -> Code() -video sw = tell [Video sw] - -peek = Peek - -poke :: Expr Int16 -> Expr Int16 -> Code() -poke v1 v2 = tell [Poke v1 v2] - -clp :: Code() -clp = tell [Clp] - -help :: Code() -help = tell [Help] - -ana = Ana - -out :: Expr Int16 -> Expr Int16 -> Code() -out v1 v2 = tell [Out v1 v2] -out' :: Expr Int16 -> Code() -out' v = tell [Out' v] - -{-| IN expression. - --} -in' = In' -in'' = In'' - -hex = Hex -hex' = Hex' - -bin = Bin -bin' = Bin' - -{-| Bitwise AND operator (&) - --} -(.&.) = BitAnd -infixl 7 .&. - -{-| Bitwise OR operator (|) - --} -(.|.) = BitOr -infixl 6 .|. - -{-| Bitwise XOR expression (^) - --} -xor = XOr -infixl 7 `xor` - -{-| Right shift expression (>>) - --} -shiftR = ShiftR -infixl 7 `shiftR` - -{-| Left shift expression (\<\<) - --} -shiftL = ShiftL -infixl 7 `shiftL` - -{-| Complement expression (~) - --} -complement = Complement - -bps :: Expr Int16 -> Code() -bps s = tell [Bps s] - -i2cr = I2CR - -i2cw = I2CW - -usr = USR - diff --git a/src/System/PIO.hs b/src/System/PIO.hs new file mode 100644 --- /dev/null +++ b/src/System/PIO.hs @@ -0,0 +1,34 @@ +module System.PIO ( + binToNum, + octToNum, + hexToNum + ) where + +import Numeric(readInt,readOct,readHex) + +readBin :: (Eq a, Num a) => ReadS a +readBin = readInt 2 f1 f2 + where + f1 n = elem n ['0','1'] + f2 '0' = 0 + f2 '1' = 1 + + +binToNum :: (Eq a, Num a) => String -> a +binToNum s = case readBin s of + (x,""):_ -> x + _ -> error "binToNum: parse error" + + +octToNum :: (Eq a, Num a) => String -> a +octToNum s = case readOct s of + (x,""):_ -> x + _ -> error "octToNum: parse error" + + +hexToNum :: (Eq a, Num a) => String -> a +hexToNum s = case readHex s of + (x,""):_ -> x + _ -> error "hexToNum: parse error" + + diff --git a/src/System/PIO/Linux.hs b/src/System/PIO/Linux.hs new file mode 100644 --- /dev/null +++ b/src/System/PIO/Linux.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.PIO.Linux ( + fdOpen, + fdClose, + fdPutBuf, + fdGetBuf, + oRdOnly, + oWrOnly, + oRdWr + ) where + +import Foreign.Ptr(Ptr) +import Foreign.C.String(CString,withCString) + +foreign import ccall "open" open :: CString -> Int -> IO Int +foreign import ccall "close" fdClose :: Int -> IO Int + +foreign import ccall "write" fdPutBuf :: Int -> Ptr a -> Int -> IO Int +foreign import ccall "read" fdGetBuf :: Int -> Ptr a -> Int -> IO Int + +foreign import ccall "o_rdonly" oRdOnly :: Int +foreign import ccall "o_wronly" oWrOnly :: Int +foreign import ccall "o_rdwr" oRdWr :: Int + +fdOpen :: String -> Int -> IO Int +fdOpen path flags = withCString path $ \cs -> open cs flags + + diff --git a/src/System/PIO/Linux/GPIO.hs b/src/System/PIO/Linux/GPIO.hs new file mode 100644 --- /dev/null +++ b/src/System/PIO/Linux/GPIO.hs @@ -0,0 +1,21 @@ +module System.PIO.Linux.GPIO ( + setValue, + getValue + ) where + +import System.IO (writeFile, readFile) + + +valueFilePath :: Int -> String +valueFilePath n = "/sys/class/gpio/gpio" ++ (show n) ++ "/value" + + +setValue :: Int -> Bool -> IO () +setValue n flag = + writeFile (valueFilePath n) $ show $ fromEnum flag + + +getValue :: Int -> IO Bool +getValue n = + (\flag -> toEnum $ read flag) <$> readFile (valueFilePath n) + diff --git a/src/System/PIO/Linux/I2C.hs b/src/System/PIO/Linux/I2C.hs new file mode 100644 --- /dev/null +++ b/src/System/PIO/Linux/I2C.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.PIO.Linux.I2C ( + setSlave + ) where + +import Data.Word(Word8) + +foreign import ccall "i2c_set_slave" setSlave :: Int -> Word8 -> IO Int + diff --git a/src/System/PIO/Linux/PWM.hs b/src/System/PIO/Linux/PWM.hs new file mode 100644 --- /dev/null +++ b/src/System/PIO/Linux/PWM.hs @@ -0,0 +1,46 @@ +module System.PIO.Linux.PWM ( + setEnable, + getEnable, + setValue, + getValue + ) where + +import System.IO (writeFile, readFile) + + +interfaceFilePath :: Int -> String -> String +interfaceFilePath n file = "/sys/class/pwm/pwmchip0/pwm" ++ (show n) ++ file + +enableFilePath :: Int -> String +enableFilePath n = interfaceFilePath n "/enable" + +periodFilePath :: Int -> String +periodFilePath n = interfaceFilePath n "/period" + +dutyCycleFilePath :: Int -> String +dutyCycleFilePath n = interfaceFilePath n "/duty_cycle" + + +setEnable :: Int -> Bool -> IO () +setEnable n flag = + writeFile (enableFilePath n) $ show $ fromEnum flag + + +getEnable :: Int -> IO Bool +getEnable n = + (\flag -> toEnum $ read flag) <$> readFile (enableFilePath n) + + +setValue :: Int -> Int -> Int -> IO () +setValue n period dutyCycle = do + let dutyCycleFilePath' = dutyCycleFilePath n + writeFile dutyCycleFilePath' $ show 0 + writeFile (periodFilePath n) $ show period + writeFile dutyCycleFilePath' $ show dutyCycle + + +getValue :: Int -> IO (Int, Int) +getValue n = + (\p dc -> (read p, read dc)) <$> readFile (periodFilePath n) <*> readFile (dutyCycleFilePath n) + + diff --git a/src/System/PIO/Linux/SPI.hs b/src/System/PIO/Linux/SPI.hs new file mode 100644 --- /dev/null +++ b/src/System/PIO/Linux/SPI.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.PIO.Linux.SPI ( + mode0, + mode1, + mode2, + mode3, + transferMessage1, + setRdMode, + setWrMode, + setRdLbsFirst, + setWrLbsFirst, + setRdBitsPerWord, + setWrBitsPerWord, + setRdMaxSpeedHz, + setWrMaxSpeedHz, + ) where + +import Foreign.Ptr(Ptr) +import Data.Word(Word8,Word32) + +foreign import ccall "spi_mode_0" mode0 :: Word8 +foreign import ccall "spi_mode_1" mode1 :: Word8 +foreign import ccall "spi_mode_2" mode2 :: Word8 +foreign import ccall "spi_mode_3" mode3 :: Word8 + +foreign import ccall "spi_transfer_message_1" transferMessage1 :: Int -> Ptr a -> Int -> Word32 -> Word8 -> IO Int + +foreign import ccall "spi_set_rd_mode" setRdMode :: Int -> Word8 -> IO Int +foreign import ccall "spi_set_wr_mode" setWrMode :: Int -> Word8 -> IO Int + +foreign import ccall "spi_set_rd_lbs_first" setRdLbsFirst :: Int -> Word8 -> IO Int +foreign import ccall "spi_set_wr_lbs_first" setWrLbsFirst :: Int -> Word8 -> IO Int + +foreign import ccall "spi_set_rd_bits_per_word" setRdBitsPerWord :: Int -> Word8 -> IO Int +foreign import ccall "spi_set_wr_bits_per_word" setWrBitsPerWord :: Int -> Word8 -> IO Int + +foreign import ccall "spi_set_rd_max_speed_hz" setRdMaxSpeedHz :: Int -> Word32 -> IO Int +foreign import ccall "spi_set_wr_max_speed_hz" setWrMaxSpeedHz :: Int -> Word32 -> IO Int + diff --git a/test/test_Huckleberry_V10101.hs b/test/test_Huckleberry_V10101.hs deleted file mode 100644 --- a/test/test_Huckleberry_V10101.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -import Test.HUnit (Assertion, (@=?), runTestTT, Test(..), Counts(..)) -import System.Exit (ExitCode(..), exitWith) -import Data.Char (toUpper) - -import Prelude hiding (print,(++),(+),(-),(*),(/),(%),(==),(/=),(>=),(>),(<=),(<),(&&),(||),not,abs,return) -import qualified Prelude as P -import Language.Huckleberry.V10101 - - -exitProperly :: IO Counts -> IO () -exitProperly m = do - counts <- m - exitWith $ if failures counts P./= 0 P.|| errors counts P./= 0 then ExitFailure 1 else ExitSuccess - -testCase :: String -> Assertion -> Test -testCase label assertion = TestLabel label (TestCase assertion) - -main :: IO () -main = exitProperly $ runTestTT $ TestList [ TestList huckleberryTests ] - -huckleberryTests :: [Test] -huckleberryTests = - [ testCase "number literal" $ "?1234\n" @=? (translate $ print 1234) - , testCase "number literal" $ "?102575\n" @=? (translate $ print 0x190AF) - , testCase "string literal" $ "?\"abcd\"\n" @=? (translate $ print "abcd") - , testCase "variable" $ "?A\n" @=? (translate $ print a) - , testCase "variable" $ "?A+1\n" @=? (translate $ print $ a+1) - , testCase "array" $ "?[8]\n" @=? (translate $ print $ arr 8) - , testCase "array" $ "?[A]\n" @=? (translate $ print $ arr a) - , testCase "array" $ "?[A+1]\n" @=? (translate $ print $ arr (a+1)) - , testCase "++" $ "?\"abc\";\"def\"\n" @=? (translate $ print $ "abc" ++ "def") - , testCase "++" $ "?1234;5678\n" @=? (translate $ print $ 1234 ++ 5678) - , testCase "++" $ "?\"abc\";5678\n" @=? (translate $ print $ "abc" ++ 5678) - , testCase "++" $ "?1234;\"def\"\n" @=? (translate $ print $ 1234 ++ "def") - , testCase "let'" $ "LETA,1\n" @=? (translate $ let' a [1]) - , testCase "let'" $ "LETA+1,1\n" @=? (translate $ let' (a+1) [1]) - , testCase "let'" $ "LETA,1,2,3\n" @=? (translate $ let' a [1,2,3]) - , testCase "let'" $ "LETA+1,1,2,3\n" @=? (translate $ let' (a+1) [1,2,3]) - , testCase "let'" $ "LET[8],1,2,3\n" @=? (translate $ let' (arr 8) [1,2,3]) - , testCase "let'" $ "LET[A],A+1,2,3\n" @=? (translate $ let' (arr a) [a+1,2,3]) - , testCase "let'" $ "LET[A+1],1,2,3\n" @=? (translate $ let' (arr (a+1)) [1,2,3]) - , testCase "=:" $ "A=1\n" @=? (translate $ a=:1) - , testCase "=:" $ "A=B\n" @=? (translate $ a=:b) - , testCase "ifThenElse" $ "IFA=B?\"S\"ELSE?\"N\"\n" - @=? (translate $ ifThenElse (a==b) (print "S") (print "N")) - , testCase "ifThen" $ "IFA=B?\"S\"\n" - @=? (translate $ ifThen (a==b) (print "S")) - , testCase "forStepNext" $ "FORA=0TO99STEP2:?[A+1]+2:NEXT\n" - @=? (translate $ forStepNext a 0 99 2 (print $ arr (a+1) +2)) - , testCase "forNext" $ "FORA=0TO99:?[A+1]+2:NEXT\n" - @=? (translate $ forNext a 0 99 (print $ arr (a+1) +2)) - , testCase "pre" $ "?(A-1)*(B+1)\n" @=? (translate $ print $ pre(a-1)*pre(b+1)) - , testCase "pre" $ "?A-1*B+1\n" @=? (translate $ print $ (a-1)*(b+1)) - , testCase "led" $ "LEDA+1\n" @=? (translate $ led (a+1)) - , testCase "wait" $ "WAITA+1\n" @=? (translate $ wait(a+1)) - , testCase "run" $ "RUN\n" @=? (translate $ run) - , testCase "list" $ "LISTA+1,B+2\n" @=? (translate $ list (a+1) (b+2)) - , testCase "list'" $ "LIST\n" @=? (translate $ list') - , testCase "goto" $ "GOTOA+1\n" @=? (translate $ goto (a+1)) - , testCase "end" $ "END\n" @=? (translate $ end) - , testCase "btn" $ "?BTN(A+1)+2\n" @=? (translate $ print $ (btn (a+1)) +2) - , testCase "new" $ "NEW\n" @=? (translate $ new) - , testCase "locate" $ "LCA+1,B+2\n" @=? (translate $ locate (a+1) (b+2)) - , testCase "cls" $ "CLS\n" @=? (translate $ cls) - , testCase "rnd" $ "?RND(A+1)+2\n" @=? (translate $ print $ (rnd (a+1)) +2) - , testCase "save" $ "SAVEA+1\n" @=? (translate $ save (a+1)) - , testCase "save'" $ "SAVE\n" @=? (translate $ save') - , testCase "load" $ "LOADA+1\n" @=? (translate $ load (a+1)) - , testCase "load'" $ "LOAD\n" @=? (translate $ load') - , testCase "files" $ "FILESA+1\n" @=? (translate $ files (a+1)) - , testCase "beep" $ "BEEPA+1,B+2\n" @=? (translate $ beep (a+1) (b+2)) - , testCase "beep'" $ "BEEP\n" @=? (translate $ beep') - , testCase "play" $ "PLAY\"ABCD\"\n" @=? (translate $ play "ABCD") - , testCase "play'" $ "PLAY\n" @=? (translate $ play') - , testCase "tempo" $ "TEMPOA+1\n" @=? (translate $ tempo (a+1)) - , testCase "+" $ "?A+B\n" @=? (translate $ print $ a+b) - , testCase "-" $ "?A-B\n" @=? (translate $ print $ a-b) - , testCase "*" $ "?A*B\n" @=? (translate $ print $ a*b) - , testCase "/" $ "?A/B\n" @=? (translate $ print $ a/b) - , testCase "%" $ "?A%B\n" @=? (translate $ print $ a%b) - , testCase "input" $ "INPUT\"Q?\",A\n" @=? (translate $ input "Q?" a) - , testCase "tick" $ "?TICK()+1\n" @=? (translate $ print $ tick +1) - , testCase "clt" $ "CLT\n" @=? (translate $ clt) - , testCase "inkey" $ "?INKEY()+1\n" @=? (translate $ print $ inkey +1) - , testCase "chr" $ "?CHR$(A+1);\"def\"\n" @=? (translate $ print $ chr (a+1) ++ "def") - , testCase "chr'" $ "?CHR$(65,66,67)\n" @=? (translate $ print $ chr'[65,66,67]) - , testCase "asc" $ "?ASC(\"abcd\")\n" @=? (translate $ print $ asc "abcd") - , testCase "scroll" $ "SCROLLA+1\n" @=? (translate $ scroll (a+1)) - , testCase "scr" $ "?SCR(A+1,B+2)+2\n" @=? (translate $ print $ (scr (a+1) (b+2))+2) - , testCase "scr'" $ "?SCR()+1\n" @=? (translate $ print $ scr'+1) - , testCase "vpeek" $ "?SCR(A+1,B+2)+2\n" @=? (translate $ print $ (vpeek (a+1) (b+2))+2) - , testCase "vpeek'" $ "?SCR()+1\n" @=? (translate $ print $ vpeek'+1) - , testCase "==" $ "?A=B\n" @=? (translate $ print $ a==b) - , testCase "/=" $ "?A!=B\n" @=? (translate $ print $ a/=b) - , testCase ">=" $ "?A>=B\n" @=? (translate $ print $ a>=b) - , testCase ">" $ "?A>B\n" @=? (translate $ print $ a>b) - , testCase "<=" $ "?A<=B\n" @=? (translate $ print $ a<=b) - , testCase "<" $ "?A>B\n" @=? (translate $ print $ a`shiftR`b) - , testCase "shiftL" $ "?A<