Skip to content

Commit

Permalink
first commit
Browse files Browse the repository at this point in the history
  • Loading branch information
Haoqiang Fan committed Dec 18, 2016
0 parents commit 91cfcd2
Show file tree
Hide file tree
Showing 10 changed files with 808 additions and 0 deletions.
79 changes: 79 additions & 0 deletions UData.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,79 @@
module UData where

data BNum = BInt Int | BFloat Double deriving Show
data BBinaryArith = BAdd | BSub | BMul | BDiv | BMod deriving Show
data BArith = BArith2 BBinaryArith BNum | BToInt | BToFloat deriving Show
data BFunc = BArithFunc BArith | BArith2Func BBinaryArith deriving Show
data BValue = BNumVal BNum | BFuncVal BFunc | BIntList [Int] deriving Show
data BResult = BClean BValue | BException [Char] deriving Show

numToBResult :: BNum -> BResult
numToBResult a = BClean (BNumVal a)

data BCompType = BLe | BGe | BNLe | BNGe | BEq | BNEq deriving Show

applyBVal :: BValue -> BValue -> BResult
applyBVal (BFuncVal b) (BNumVal v) = applyBFunc b v
applyBVal (BFuncVal b) _ = BException ("cannot apply non-numeric argument to builtin function "++(show b))
applyBVal (BIntList args) (BNumVal (BInt v)) = BClean (BIntList (v:args))
applyBVal (BIntList args) _ = BException "cannot append non-integer number in IntList"
applyBVal _ _ = BException "cannot use numeric value as function"

applyBFunc :: BFunc -> BNum -> BResult
applyBFunc (BArith2Func a) d = BClean (BFuncVal (BArithFunc (BArith2 a d)))
applyBFunc (BArithFunc a) v = applyBArith a v

applyBArith :: BArith -> BNum -> BResult
applyBArith (BArith2 a b) c = applyBBinaryArith a b c
applyBArith BToInt (BInt a) = numToBResult (BInt a)
applyBArith BToInt (BFloat a) = numToBResult (BInt (floor a))
applyBArith BToFloat (BFloat a) = numToBResult (BFloat a)
applyBArith BToFloat (BInt a) = numToBResult (BFloat (fromIntegral a))

applyBBinaryArith :: BBinaryArith -> BNum -> BNum -> BResult
applyBBinaryArith BAdd (BInt a) (BInt b) = numToBResult (BInt (a+b))
applyBBinaryArith BAdd (BFloat a) (BInt b) = numToBResult (BFloat (a+(fromIntegral b)))
applyBBinaryArith BAdd (BInt a) (BFloat b) = numToBResult (BFloat ((fromIntegral a)+b))
applyBBinaryArith BAdd (BFloat a) (BFloat b) = numToBResult (BFloat (a+b))
applyBBinaryArith BSub (BInt a) (BInt b) = numToBResult (BInt (a-b))
applyBBinaryArith BSub (BFloat a) (BInt b) = numToBResult (BFloat (a-(fromIntegral b)))
applyBBinaryArith BSub (BInt a) (BFloat b) = numToBResult (BFloat ((fromIntegral a)-b))
applyBBinaryArith BSub (BFloat a) (BFloat b) = numToBResult (BFloat (a-b))
applyBBinaryArith BMul (BInt a) (BInt b) = numToBResult (BInt (a*b))
applyBBinaryArith BMul (BFloat a) (BInt b) = numToBResult (BFloat (a*(fromIntegral b)))
applyBBinaryArith BMul (BInt a) (BFloat b) = numToBResult (BFloat ((fromIntegral a)*b))
applyBBinaryArith BMul (BFloat a) (BFloat b) = numToBResult (BFloat (a*b))
applyBBinaryArith BDiv _ (BInt 0) = BException "divided by zero"
applyBBinaryArith BDiv (BInt a) (BInt b) = numToBResult (BInt (a `div`b))
applyBBinaryArith BDiv (BFloat a) (BInt b) = numToBResult (BFloat (a/(fromIntegral b)))
applyBBinaryArith BDiv (BInt a) (BFloat b) = numToBResult (BFloat ((fromIntegral a)/b))
applyBBinaryArith BDiv (BFloat a) (BFloat b) = numToBResult (BFloat (a/b))
applyBBinaryArith BMod _ (BInt 0) = BException "mod by zero"
applyBBinaryArith BMod (BInt a) (BInt b) = numToBResult (BInt (a `div`b))
applyBBinaryArith BMod _ _ = BException "cannot use non-integer value in mod"

compBNum :: BCompType -> BNum -> BNum -> Bool
compBNum BLe (BInt a) (BInt b) = (a<b)
compBNum BLe (BInt a) (BFloat b) = ((fromIntegral a)<b)
compBNum BLe (BFloat a) (BInt b) = (a<(fromIntegral b))
compBNum BLe (BFloat a) (BFloat b) = (a<b)
compBNum BNLe (BInt a) (BInt b) = (a>=b)
compBNum BNLe (BInt a) (BFloat b) = ((fromIntegral a)>=b)
compBNum BNLe (BFloat a) (BInt b) = (a>=(fromIntegral b))
compBNum BNLe (BFloat a) (BFloat b) = (a>=b)
compBNum BGe (BInt a) (BInt b) = (a>b)
compBNum BGe (BInt a) (BFloat b) = ((fromIntegral a)>b)
compBNum BGe (BFloat a) (BInt b) = (a>(fromIntegral b))
compBNum BGe (BFloat a) (BFloat b) = (a>b)
compBNum BNGe (BInt a) (BInt b) = (a<=b)
compBNum BNGe (BInt a) (BFloat b) = ((fromIntegral a)<=b)
compBNum BNGe (BFloat a) (BInt b) = (a<=(fromIntegral b))
compBNum BNGe (BFloat a) (BFloat b) = (a<=b)
compBNum BEq (BInt a) (BInt b) = (a==b)
compBNum BEq (BInt a) (BFloat b) = ((fromIntegral a)==b)
compBNum BEq (BFloat a) (BInt b) = (a==(fromIntegral b))
compBNum BEq (BFloat a) (BFloat b) = (a==b)
compBNum BNEq (BInt a) (BInt b) = (a/=b)
compBNum BNEq (BInt a) (BFloat b) = ((fromIntegral a)/=b)
compBNum BNEq (BFloat a) (BInt b) = (a/=(fromIntegral b))
compBNum BNEq (BFloat a) (BFloat b) = (a/=b)
131 changes: 131 additions & 0 deletions UEnvironment.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,131 @@
module UEnvironment where

import System.IO
import System.Environment
import Data.Char
import qualified Data.Map as Map



class UEnv e where
eExit :: Int -> e ()
eException :: [Char] -> e ()
eOpen :: [Int] -> Int -> e Int
eClose :: Int -> e Int
eGetChar :: Int -> e Int
ePeekChar :: Int -> e Int
ePutChar :: Int -> Int -> e Int
eGetArg :: e Int

efOpenModes = [ReadMode,WriteMode,AppendMode,ReadWriteMode]
-- currently, only r and w are supported

data UFinishState a = URunning a | UFinished Int | UExceptionHappened [Char] deriving Show
data UFileList h = UFileList {flFiles::[Maybe h],flArgToRead::[Int]} deriving Show

flAddHandle :: h -> UFileList h -> (Int,UFileList h)
flAddHandle h (UFileList hdls args) = findEmptySlot hdls id 0 where
findEmptySlot [] prefix curno = (curno,UFileList (prefix [Just h]) args)
findEmptySlot (Nothing:r) prefix curno = (curno,UFileList (prefix ((Just h):r)) args)
findEmptySlot (a:r) prefix curno = findEmptySlot r (\x -> prefix (a:x)) (curno+1)

flGetHandle :: Int -> UFileList h -> Maybe h
flGetHandle fno (UFileList hdls args)
| fno>=0 && fno<length hdls = hdls!!fno
| otherwise = Nothing
flCloseHandle :: Int -> UFileList h -> UFileList h
flCloseHandle fno (UFileList hdls args)
| fno>=0 && fno<length hdls = UFileList ((take fno hdls)++(Nothing:(drop (fno+1) hdls))) args
| otherwise = UFileList hdls args
flGetArg :: UFileList h -> (Int,UFileList h)
flGetArg (UFileList hdls []) = ((-1),UFileList hdls [])
flGetArg (UFileList hdls (a:ar)) = (a,UFileList hdls ar)


newtype URealWorldEnv a = URealWorldEnv {runRealWorldEnv :: UFileList Handle ->IO (UFinishState a,UFileList Handle)}

instance Monad URealWorldEnv where
-- f :: UFileList -> IO (UFinishState a,UFileList)
-- g :: a -> URealWorldEnv (UFileList -> IO (UFinishState b,UFileList))
(URealWorldEnv f) >>= g = URealWorldEnv (\initfiles ->
(f initfiles) >>= (\(finishstate1,files1) ->
case finishstate1 of
UFinished r -> return (UFinished r ,files1)
UExceptionHappened e -> return (UExceptionHappened e,files1)
URunning va -> runRealWorldEnv (g va) files1
)
)
f >> g = (f >>= (const g))
return a = URealWorldEnv (\f -> return (URunning a,f))

isValidCharInt :: Int -> Bool
isValidCharInt a = (a>=0 && a<1114112)

instance UEnv URealWorldEnv where
eExit retval = URealWorldEnv (\initfiles ->
return (UFinished retval,initfiles))
eException msg = URealWorldEnv (\initfiles ->
return (UExceptionHappened msg,initfiles))
eOpen filename mode = URealWorldEnv (\initfiles ->
if (mode>=0 && mode<=length efOpenModes) then
return (URunning (-2),initfiles)
else if (any (not.isValidCharInt) filename) then
return (URunning (-3),initfiles)
else
(openFile (map chr filename) (efOpenModes!!mode) >>=
(\handle -> ( let (fno,files1) = flAddHandle handle initfiles in
return (URunning fno,files1)
)))
)
eClose fno = URealWorldEnv (\initfiles ->
case (flGetHandle fno initfiles) of
Nothing -> return (URunning (-2),initfiles)
Just hdl -> ( hClose hdl >> (
return (URunning 0,(flCloseHandle fno initfiles))
))
)
eGetChar fno = URealWorldEnv (\initfiles ->
case (flGetHandle fno initfiles) of
Nothing -> return (URunning (-2),initfiles)
Just hdl -> (hIsEOF hdl) >>= (\iseof -> case iseof of
False -> hGetChar hdl >>= (\c ->return (URunning (ord c),initfiles))
True -> return (URunning (-1),initfiles)
)
)
ePeekChar fno = URealWorldEnv (\initfiles ->
case (flGetHandle fno initfiles) of
Nothing -> return (URunning (-2),initfiles)
Just hdl -> (hIsEOF hdl) >>= (\iseof -> case iseof of
False -> hLookAhead hdl >>= (\c -> return (URunning (ord c),initfiles))
True -> return (URunning (-1),initfiles)
)
)
ePutChar fno content = URealWorldEnv (\initfiles ->
if isValidCharInt content then
case (flGetHandle fno initfiles) of
Nothing -> return (URunning (-2),initfiles)
Just hdl -> ( hPutChar hdl (chr content) >> (
return (URunning (0),initfiles)
))
else
return (URunning (-3),initfiles)
)
eGetArg = URealWorldEnv (\initfiles ->
let (ret,files1)=flGetArg initfiles in
return (URunning ret,files1)
)

initRealWorldEnv = URealWorldEnv (\oldstate ->
getArgs >>= (\args ->
let iargs = listjoin (-1) (map (map ord) args) in
return (URunning (),UFileList [Just stdin,Just stdout] iargs))) where
listjoin s [] = []
listjoin s (a:[]) = a
listjoin s (a:ar) = a++(s:(listjoin s ar))
runRealWorld a = (runRealWorldEnv (initRealWorldEnv >> a) (UFileList [] [])) >>= (\(exitstate,_) ->
case exitstate of
UFinished 0 -> return ()
UFinished a -> putStrLn ("exit with code "++show a)
UExceptionHappened e -> putStrLn e
URunning _ -> putStrLn "execution interupted"
)
40 changes: 40 additions & 0 deletions UParse.bak.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,40 @@
module UParse where

import Data.Char

data SToken = SUnresolved [Char] | SIntConst Int | SDoubleConst Double
type STokenPos = (SToken,Int)

applySnd f (x,y) = (x,f y)
applyPair f g (x,y) = (f x,g y)
consFst a (x,y) = (a:x,y)

dropSpaceAndComment :: [Char] -> [Char]
dropSpaceAndComment x
| null x = []
| isSpace (head x) = dropSpaceAndComment (tail x)
| (head x)==';' = dropSpaceAndComment (dropWhile (/='\n') (tail x))
| otherwise = x

groupUntil get_next should_stop s
| should_stop s = ([],s)
| otherwise = (cur:remain_group,remain_s) where
(cur,s_other) = get_next s
(remain_group,remain_s) = groupUntil get_next should_stop s_other

parseToStrings :: [Char] -> [[Char]]
parseToStrings = parseToStrings' . dropSpaceAndComment where
parseToStrings' = fst.(groupUntil nextString' null)
nextString' = (applySnd dropSpaceAndComment).nextString
nextString (x:xs)
| elem x ['\'','"'] = (consFst x) (nextLexical x xs)
| elem x ['(',')','\\'] = ([x],xs)
| otherwise = (span validIdChar (x:xs))
validIdChar a = not (isSpace a) && not (elem a ['(',')','\\'])
nextLexical d [] = ([],[])
nextLexical d (x:xs)
| x==d = ([d],xs)
| x=='\\' && not (null xs) && x1==d = (consFst x)$(consFst x1)$(nextLexical d x1s)
| otherwise = consFst x (nextLexical d xs) where
x1:x1s = xs

Loading

0 comments on commit 91cfcd2

Please sign in to comment.