garepinoh (empty) → 0.9.9.1
raw patch · 10 files changed
+726/−0 lines, 10 filesdep +basedep +haskelinedep +numberssetup-changed
Dependencies added: base, haskeline, numbers, transformers
Files
- Setup.hs +11/−0
- code/Console/Garepinoh/BoolMain.hs +12/−0
- code/Console/Garepinoh/Calculate.hs +19/−0
- code/Console/Garepinoh/DoubleMain.hs +12/−0
- code/Console/Garepinoh/GenMain.hs +176/−0
- code/Console/Garepinoh/Preludes.hs +256/−0
- code/Console/Garepinoh/Types.hs +81/−0
- code/Console/Garepinoh/Utils.hs +93/−0
- garepinoh.cabal +65/−0
- text/LICENSE +1/−0
+ Setup.hs view
@@ -0,0 +1,11 @@+--------------------------------------------------------------------------------+module Main where+++--------------------------------------------------------------------------------+import Distribution.Simple+++--------------------------------------------------------------------------------+main :: IO ()+main = defaultMain
+ code/Console/Garepinoh/BoolMain.hs view
@@ -0,0 +1,12 @@+--------------------------------------------------------------------------------+module Main where+++--------------------------------------------------------------------------------+import Console.Garepinoh.GenMain (genMain)+import Console.Garepinoh.Preludes (boolPrelude)+++--------------------------------------------------------------------------------+main :: IO ()+main = genMain boolPrelude
+ code/Console/Garepinoh/Calculate.hs view
@@ -0,0 +1,19 @@+--------------------------------------------------------------------------------+module Console.Garepinoh.Calculate+ ( calculate+ , module Console.Garepinoh.Utils+ , module Console.Garepinoh.Types+ ) where+++--------------------------------------------------------------------------------+import Console.Garepinoh.Types+import Console.Garepinoh.Utils+++--------------------------------------------------------------------------------+-- |Given a 'Prelude', 'calculate' tries to calculate the value of the given+-- input and returns either the caused error message or the resulting stack.+calculate :: Read t => Prelude t -> [String] -> Result t+calculate fl = foldl (step fl) (Right [])+
+ code/Console/Garepinoh/DoubleMain.hs view
@@ -0,0 +1,12 @@+--------------------------------------------------------------------------------+module Main where+++--------------------------------------------------------------------------------+import Console.Garepinoh.GenMain (genMain,Prelude)+import Console.Garepinoh.Preludes (floatingPrelude)+++--------------------------------------------------------------------------------+main :: IO ()+main = genMain (floatingPrelude :: Prelude Double)
+ code/Console/Garepinoh/GenMain.hs view
@@ -0,0 +1,176 @@+--------------------------------------------------------------------------------+{-# LANGUAGE TupleSections #-}+++--------------------------------------------------------------------------------+module Console.Garepinoh.GenMain+ ( genMain+ , module Console.Garepinoh.Calculate+ ) where+++--------------------------------------------------------------------------------+import Control.Monad.IO.Class (liftIO)+import Data.List (find,intercalate,tails)+import Data.Maybe (isNothing)+import System.Environment (getArgs)+++--------------------------------------------------------------------------------+import System.Console.Haskeline (runInputT,defaultSettings,InputT,getInputLine)+++--------------------------------------------------------------------------------+import Console.Garepinoh.Calculate+++--------------------------------------------------------------------------------+-- | A general @main@ function which behaves just like the @garepinoh@+-- executable, but depending on a 'Prelude'.+--+-- In fact, the @main@ function of the executable `garepinoh` is just+--+-- @+-- main = genMain 'Console.Garepinoh.Preludes.floatingPrelude'+-- @+-- +-- whereas the main function of @garepiboh@ is:+-- +-- @+-- main = genMain 'Console.Garepinoh.Preludes.boolPrelude'+-- @+genMain :: (Read t, Show t) => Prelude t-> IO ()+genMain fl =+ getArgs >>= \as ->+ runInputT defaultSettings $ loop as [] fl >> return ()+++--------------------------------------------------------------------------------+loop :: (Read t, Show t)+ => [String] -> [String] -> Prelude t+ -> InputT IO ()+loop as postulates p =+ getLn as >>= \mayLn ->+ case fmap words mayLn of+ Nothing -- case: e.g. C-d+ -> return () -- don't change this! (because of loading)+ Just [] -- case: e.g. RET+ -> continue+ Just (",,":_) -- case: comment+ -> continue+ Just (",":name:[]) -- case: postulate+ | repl+ -> loop as (name:postulates) p+ | otherwise+ -> return ()+ Just (",":name:def@(_:_)) -- case: function definition+ | repl+ -> either+ ((>> continue) . liftIO . putStrLn)+ (loop as postulates)+ (addDef name def postulates p)+ | otherwise+ -> return ()+ Just ((',':',':cmd):ws) -- case: command+ | cmd `elem` helpList+ -> (>> continue) $ liftIO $ putStr $ helpText p+ | cmd `elem` cmndList+ -> (>> continue) $ liftIO $ putStr cmndText+ | cmd `elem` postList+ -> (>> continue) $ liftIO $ putStr $ postText p postulates+ | cmd `elem` funcList+ -> (>> continue) $ liftIO $ putStr $ funcText p+ | cmd `elem` exitList+ -> return ()+ | cmd `elem` ["l","load"] -- && null ws && not repl+ -- if ,load is the only command-line argument:+ -> loop [] postulates p+ | cmd `elem` ["scan","debug","trace"]+ -> (>> continue) $ mapM_ calc $+ map reverse $ reverse $ tails $ reverse ws -- TODO: make it better+ | otherwise+ -> return ()+ Just ws+ -> calc ws+ >> continue+ where+ continue+ | repl+ = loop as postulates p+ | otherwise+ = return ()+ calc ws = liftIO $ putStrLn $ either+ (",, Error: "++)+ ((",, "++) . show . reverse)+ (calculate p ws)+ repl = null as+++--------------------------------------------------------------------------------+addDef :: (Read t, Show t)+ => String -> [String] -> [String] -> Prelude t -> Either String (Prelude t)+addDef name def postulates p =+ case find invalid def of -- ugly.+ Nothing -> Right $ Func+ { symb = NEL name []+ , func = map Ref def+ } : p+ Just x+ | x `elem` postulates+ -> Left $ ",, Error: " ++ show x ++ " postulated but not defined."+ | otherwise+ -> Left $ ",, Error: Unkown function " ++ show x ++ "."+ where+ invalid (',':d) = invalid d -- FIXME: this case is very critical and probably buggy! (is ,,x valid?)+ invalid d = and+ [ d `notElem` concatMap (list . symb) p+ , isNothing $ asTypeOf (value d) $ Just $ Fu $ head p+ , d /= name+ , d `notElem` postulates+ ]+++--------------------------------------------------------------------------------+getLn :: [String] -> InputT IO (Maybe String)+getLn as+ | null as = getInputLine ""+ | otherwise = return $ Just $ unwords as+++--------------------------------------------------------------------------------+funcText, helpText :: (Read t, Show t) => Prelude t -> String++funcText p = intercalate "\n"+ [ ",, Functions (and Variables):"+ , printList p (list . symb)+ ]++helpText p = funcText p ++ cmndText++cmndText :: String+cmndText = intercalate "\n"+ [ ",, Commands:"+ , ",, Use commands by typing \",,<command>\" as the first word."+ , printList [exitList,helpList,funcList,cmndList] id+ ]++postText :: Prelude t -> [String] -> String+postText prelude postulates = intercalate "\n"+ [ ",, Postulates:"+ , flip printList id $ map return $ filter (`notElem` preluded) postulates+ ]+ where+ preluded = concatMap (list . symb) prelude+++--------------------------------------------------------------------------------+exitList, funcList, helpList, cmndList, postList :: [String]+exitList = ["quit","q","exit","x"]+helpList = ["help","h"]+funcList = ["func","f","functions"]+cmndList = ["cmnd","c","commands"]+postList = ["post","p","postulates"]++printList :: [a] -> (a -> [String]) -> String+printList l f = flip concatMap l+ $ (++"\n") . (",, * "++) . intercalate ", " . f
+ code/Console/Garepinoh/Preludes.hs view
@@ -0,0 +1,256 @@+--------------------------------------------------------------------------------+{-# LANGUAGE LambdaCase #-}+++--------------------------------------------------------------------------------+module Console.Garepinoh.Preludes+ ( abstractPrelude+ , floatingPrelude+ , boolPrelude+ ) where+++--------------------------------------------------------------------------------+import Console.Garepinoh.Types+import Console.Garepinoh.Utils+++--------------------------------------------------------------------------------+-- |The abstract 'Prelude' which implements functions typical for concatenative +-- programming languages.+abstractPrelude :: (Read t, Show t, Eq t) => Prelude t+abstractPrelude =+ [ Func+ { symb = NEL "swap" ["swp","s"]+ , func = [ Fun $ const $ \case+ (a:b:es) -> Right (b:a:es)+ _ -> Left "swap expects two elements."+ ]+ }+ , Func+ { symb = NEL "drop" ["drp","d"]+ , func = [ Fun $ const $ \case+ (_:es) -> Right es+ _ -> Left "drop expects an element."+ ]+ }+ , Func+ { symb = NEL "flip" []+ , func = [ Fun $ const $ \case+ (Fu (Func (NEL sy _) fu)):es -> Right $ (:es) $ Fu $ Func+ (NEL ("flip "++sy) [])+ (Ref "swap":fu)+ _ -> Left "flip expects one argument, being a function."+ ]+ }+ , Func+ { symb = NEL "emptylist" ["el","[]"]+ , func = [ Fun $ const $ Right . (Li []:)+ ]+ }+ , Func+ { symb = NEL "cons" ["#",":"] -- FIXME: : doesn't work+ , func = [ Fun $ const $ \case+ x:Li l:es -> Right $ (:es) $ Li (l++[x]) -- order? i belive it's nice like this.+ _ -> Left "cons expects two arguments, the second being a list."+ ]+ }+ , Func+ { symb = NEL "dup" ["duplicate"]+ , func = [ Fun $ const $ \case+ a:es -> Right (a:a:es)+ _ -> Left "dup expects one argument."+ ]+ }+ , Func+ { symb = NEL "map" []+ , func = [ Fun $ \p -> \case+ f:Li l:es ->+ fmap+ ((:es) . Li . concat)+ (mapM (apply p f . return) l)+ _ -> Left "map expects two arguments, the second being a list."+ ]+ }+ , Func+ { symb = NEL "curry" [",","c"] -- FIXME: buggy: 1 sqrt c+ , func = [ Fun $ \p -> \case+ (f@(Fu (Func (NEL sy _) fu)):x:es) ->+ case apply p f [x] of+ Right resultStack -> Right (resultStack++es)+ Left _ -> Right $ (:es) $ Fu $+ Func (NEL (sy++" "++show x) []) (Ele x:fu)+ _ -> Left $ "curry expects two arguments, "+ ++ "the first being a function."+ ]+ }+ , Func+ { symb = NEL "apply" ["$","a"]+ , func = [ Fun $ \p -> \case+ (f:es) -> apply p f es+ _ -> Left $ "apply expects two arguments, "+ ++ "the first being a function."+ ]+ }+ , Func+ { symb = NEL "id" ["identity"]+ , func = [ Fun $ const Right+ ]+ }+ , Func+ { symb = NEL "geneq" ["generalequality"]+ , func = [ Fun $ const $ \case+ t:e:a:a':es -> Right $ (:es) $ if a == a' then t else e+ _ -> Left $ "generalequality expects four arguments."+ ]+ }+ , Func+ { symb = NEL "appendlist" ["unlist"]+ , func = [ Fun $ const $ \case+ Li l:es -> Right $ l++es+ _ -> Left $ "appendlist expects one argument, being a list."+ ]+ }+ , Func+ { symb = NEL "." ["functioncomposition","comp","∘"]+ , func = [ Fun $ const $ \case+ Fu (Func (NEL fsy _) fhs):Fu (Func (NEL gsy _) ghs):es ->+ Right $ (:es) $ Fu $ Func (NEL ("("++unwords [gsy,fsy,"∘"]++")") []) (ghs++fhs) -- order? i believe it' correct this way.+ _ -> Left $ "appendlist expects one argument, being a list."+ ]+ }+ ]++--------------------------------------------------------------------------------+-- |'Prelude' floating-point numbers.+--+-- Beside arithmetic operations and common mathematical constants etc.,+-- it also contains the 'abstractPrelude'.+floatingPrelude :: (Show t, Read t, Eq t, Floating t) => Prelude t+floatingPrelude = abstractPrelude +++ [ Func+ { symb = NEL "addition" ["add","plus","+"]+ , func = [ Fun $ const $ \case+ (Va a:Va b:es) -> Right $ (:es) $ Va $ a+b+ _ -> Left "addition expects two arguments, both being values."+ ]+ }+ , Func+ { symb = NEL "subtraction" ["-","minus","take","subtract"]+ , func = [ Fun $ const $ \case+ (Va a:Va b:es) -> Right $ (:es) $ Va $ a-b+ _ -> Left "subtraction expects two arguments, both being values."+ ]+ }+ , Func+ { symb = NEL "multiplication" ["times","*","·","×"]+ , func = [ Fun $ const $ \case+ (Va a:Va b:es) -> Right $ (:es) $ Va $ a*b+ _ -> Left "multiplication expects two arguments, both being values."+ ]+ }+ , Func+ { symb = NEL "division" ["div","/","%","\\","÷"]+ , func = [ Fun $ const $ \case+ (Va a:Va b:es) -> Right $ (:es) $ Va $ a/b+ _ -> Left "division expects two arguments, both being values."+ ]+ }+ , Func+ { symb = NEL "exponentiation" ["pow","power","^","**"]+ , func = [ Fun $ const $ \case+ (Va a:Va b:es) -> Right $ (:es) $ Va $ a**b+ _ -> Left "exponentiation expects two arguments, both being values."+ ]+ }+ , Func+ { symb = NEL "logarithm" ["log","logbase","?"]+ , func = [ Fun $ const $ \case+ (Va a:Va b:es) -> Right $ (:es) $ Va $ logBase a b -- TODO order+ _ -> Left "logarithm expects two arguments, both being values."+ ]+ }+ , Func+ { symb = NEL "pi" ["π"]+ , func = [ Fun $ const $ Right . (Va pi:)+ ]+ }+ , Func+ { symb = NEL "e" ["euler"]+ , func = [ Fun $ const $ Right . (Va (exp 1):)+ ]+ }+ , Func+ { symb = NEL "i" []+ , func = [ Ele $ Va $ sqrt (-1)+ ]+ }+ , Func+ { symb = NEL "sqrt" []+ , func = [ Fun $ const $ \case+ (Va a:es) -> Right $ (:es) $ Va $ sqrt a+ _ -> Left "sqrt expects one argument, being a value."+ ]+ }+ , Func+ { symb = NEL "bool" ["tei","thenelseif"]+ , func = [ Fun $ const $ \case+ t:e:Va i:es -> Right $ if i /= 0 then t:es else e:es+ _ -> Left "bool expects three argument, the third being a value."+ ]+ }+ ]+++--------------------------------------------------------------------------------+-- |'Prelude' for Booleans.+--+-- Beside Boolean operations (e.g. conjunction and disjunction), it also+-- contains the 'abstractPrelude'.+boolPrelude :: Prelude Bool+boolPrelude = abstractPrelude +++ [ Func+ { symb = NEL "conjunction" ["and","&","&&","∧"]+ , func = [ Fun $ const $ \case+ (Va a:Va b:es) -> Right (Va (a && b):es)+ _ -> Left "conjunction expects two arguments, both being values."+ ]+ }+ , Func+ { symb = NEL "disjunction" ["or","|","||","∨"]+ , func = [ Fun $ const $ \case+ (Va a:Va b:es) -> Right (Va (a || b):es)+ _ -> Left "disjunction expects two arguments, both being values."+ ]+ }+ , Func+ { symb = NEL "not" ["-","~","¬"]+ , func = [ Fun $ const $ \case+ (Va a:es) -> Right (Va (not a):es)+ _ -> Left "not expects one arguments, being a value."+ ]+ }+ , Func+ { symb = NEL "nand" []+ , func = [ Ref "and"+ , Ref "not"+ ]+ }+ , Func+ { symb = NEL "bool" ["tei","thenelseif"]+ , func = [ Fun $ const $ \case+ t:e:Va i:es -> Right $ if i then t:es else e:es+ _ -> Left "bool expects one argument, being a value."+ ]+ }+ , Func+ { symb = NEL "true" ["t","1"]+ , func = [ Ele (Va True)+ ]+ }+ , Func+ { symb = NEL "false" ["f","0"]+ , func = [ Ele (Va False)+ ]+ }+ ]
+ code/Console/Garepinoh/Types.hs view
@@ -0,0 +1,81 @@+--------------------------------------------------------------------------------+{-# LANGUAGE GADTs #-}+++--------------------------------------------------------------------------------+module Console.Garepinoh.Types+ ( Result+ , Prelude+ , Stack+ , El(..)+ , NonEmptyList(..)+ , Func(..)+ , Function(..)+ ) where+++--------------------------------------------------------------------------------+-- |'Result' is either an error message or a 'Stack'.+type Result t = Either String (Stack t)+++--------------------------------------------------------------------------------+-- |A 'Prelude' is a list of pre-defined functions.+type Prelude t = [Func t]+++--------------------------------------------------------------------------------+-- |A 'Stack' is (simulated by) a list of elements.+type Stack t = [El t]+++--------------------------------------------------------------------------------+-- |An element is either...+data El t = Va t -- ^ a value of type @t@,+ | Li [El t] -- ^ a list of elements, or+ | Fu (Func t) -- ^ a function++instance Eq t => Eq (El t) where+ Va a == Va b = a == b+ Li a == Li b = a == b+ Fu a == Fu b = hd (symb a) == hd (symb b)+ _ == _ = False++instance Show t => Show (El t) where+ show (Va n) = show n+ show (Li l) = show l+ show (Fu f) = show f+++--------------------------------------------------------------------------------+-- |'NonEmptyList' is a non-empty list.+data NonEmptyList t = NEL+ { hd :: t -- ^ first element (head) of the (non-empty) list.+ , tl :: [t] -- ^ remaining part (tail) of the (non-empty) list.+ }+++--------------------------------------------------------------------------------+-- |A Function consists of:+data Func t = Func+ { symb :: NonEmptyList String+ -- ^ a non-empty list of identifiers;+ , func :: [Function t]+ -- ^ a list (@[f_fst,f_snd,..,f_last@]) of+ -- primitive/undivisible 'Function's which are evaluated step-by-step.+ }++instance Show (Func t) where show = hd . symb+++--------------------------------------------------------------------------------+-- |A primitive/undivisible 'Function' is one of:+ -- + -- +data Function t+ = Ele (El t)+ -- ^ an element 'El';+ | Ref String+ -- ^ a reference to other functions; or+ | Fun (Prelude t -> Stack t -> Either String (Stack t))+ -- ^ an actual primitive/pre-defined/hard-coded function.
+ code/Console/Garepinoh/Utils.hs view
@@ -0,0 +1,93 @@+--------------------------------------------------------------------------------+{-# LANGUAGE PatternGuards #-}+++--------------------------------------------------------------------------------+module Console.Garepinoh.Utils+ ( step+ , value+ , appendFunction+ , function+ , append+ , apply+ , list+ ) where+++--------------------------------------------------------------------------------+import Data.List+++--------------------------------------------------------------------------------+import Console.Garepinoh.Types+++--------------------------------------------------------------------------------+step :: Read t => Prelude t -> Result t -> String -> Result t+step _ (Left ermsg) _ = Left ermsg+step fl (Right stack) word+ | Just x <- value word+ = append x stack+ | Just x <- appendFunction word fl+ = append (el Va Li (\f -> Fu (f { symb = NEL (tail word) [] })) x) stack+ | Just x <- applyFunction word fl+ = apply fl x stack+ | otherwise+ = Left $ "Invalid input " ++ show word ++ "."+++--------------------------------------------------------------------------------+value :: Read t => String -> Maybe (El t)+value word = case reads word of+ [(v, "")] -> Just $ Va v+ _ -> Nothing+++--------------------------------------------------------------------------------+appendFunction :: String -> Prelude t -> Maybe (El t)+appendFunction (',':word) = applyFunction word+appendFunction _ = const Nothing+++--------------------------------------------------------------------------------+applyFunction :: String -> Prelude t -> Maybe (El t)+applyFunction word = fmap Fu . find (elem word . list . symb)+++--------------------------------------------------------------------------------+append :: El t -> Stack t -> Result t+append e l = Right (e:l)+++--------------------------------------------------------------------------------+apply :: Read t => Prelude t -> El t -> Stack t -> Result t+apply fl (Fu (Func _ fs)) stack = applyAll fs stack+ where+ applyAll [] s = Right s+ applyAll (g:gs) s = either Left (applyAll gs) $ function+ (Right . (:s))+ (step fl (Right s))+ (\h -> h fl s)+ g+apply _ _ _ = Left "Expecting a function to be applied."+++--------------------------------------------------------------------------------+list :: NonEmptyList t -> [t]+list (NEL x xs) = x:xs+++--------------------------------------------------------------------------------+-- |Destructor of 'El'.+el :: (t -> x) -> ([El t] -> x) -> (Func t -> x) -> El t -> x+el f _ _ (Va x) = f x+el _ f _ (Li x) = f x+el _ _ f (Fu x) = f x+++--------------------------------------------------------------------------------+-- |Destructor of 'Function'.+function :: (El t -> x) -> (String -> x) -> ((Prelude t -> Stack t -> Either String (Stack t)) -> x) -> Function t -> x+function f _ _ (Ele x) = f x+function _ f _ (Ref x) = f x+function _ _ f (Fun x) = f x
+ garepinoh.cabal view
@@ -0,0 +1,65 @@+name: garepinoh+version: 0.9.9.1+synopsis: reverse prefix notation calculator and calculation library+description: Another concatenative and stack-based calculator using+ reverse prefix (– not polish! –) notation.+stability: provisional+category: Math, Console, Tools+homepage: http://hub.darcs.net/mekeor/Garepinoh/text/README.md+bug-reports: mailto:mekeor.melire@gmail.com+license: PublicDomain+license-file: text/LICENSE+copyright: Public Domain+author: Mekeor Melire <mekeor.melire@gmail.com>+maintainer: Mekeor Melire <mekeor.melire@gmail.com>+bug-reports: http://hub.darcs.net/mekeor/Garepinoh/issues+tested-with: GHC ==7.6.3+cabal-version: >= 1.8+build-type: Simple++source-repository head+ type:+ darcs+ location:+ http://hub.darcs.net/mekeor/garepinoh++executable garepinoh+ hs-source-dirs:+ code+ build-depends:+ base >2 && <5,+ haskeline >= 0.7 && <= 1,+ transformers == 0.3.*+ main-is:+ Console/Garepinoh/DoubleMain.hs+ ghc-options:+ -Wall++executable garepiboh+ hs-source-dirs:+ code+ build-depends:+ base >2 && <5,+ haskeline >= 0.7 && <= 1,+ transformers == 0.3.*+ main-is:+ Console/Garepinoh/BoolMain.hs+ ghc-options:+ -Wall++library+ hs-source-dirs:+ code+ build-depends:+ base >2 && <5,+ numbers >= 3000,+ haskeline >= 0.7 && <= 1,+ transformers == 0.3.*+ exposed-modules:+ Console.Garepinoh.Calculate,+ Console.Garepinoh.GenMain,+ Console.Garepinoh.Preludes,+ Console.Garepinoh.Types,+ Console.Garepinoh.Utils+ ghc-options:+ -Wall
+ text/LICENSE view
@@ -0,0 +1,1 @@+Published into public domain.