From: Mart Lubbers <mart@martlubbers.net>
Date: Wed, 14 Nov 2018 09:43:18 +0000 (+0100)
Subject: fundeps a8
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=85be4012fc8ee04ef900d0586f84a00af8aa7862;p=clean-tests.git

fundeps a8
---

diff --git a/.gitignore b/.gitignore
index 407ad86..6938473 100644
--- a/.gitignore
+++ b/.gitignore
@@ -9,3 +9,4 @@ getopt
 *.o
 test
 gopt
+afp/a[0-9]/a[0-9]
diff --git a/afp/a6/a7.icl b/afp/a6/a7.icl
new file mode 100644
index 0000000..b55361c
--- /dev/null
+++ b/afp/a6/a7.icl
@@ -0,0 +1,170 @@
+module a7
+
+import StdEnv
+
+import qualified Data.List as List
+import Data.Func
+import Control.Applicative
+
+import iTasks
+
+:: Job =
+	{ id        :: Int
+	, jobName   :: String
+	, skills    :: [Skill]
+	, blocked   :: Bool
+	, children  :: [Job]
+	}
+:: Skill = Programming | Design | Testing
+:: Worker =
+	{ username :: String
+	, password :: String
+	, skills   :: [Skill]
+	, loggedIn :: Bool
+	}
+instance == Worker where == w1 w2 = w1.Worker.username == w2.Worker.username
+instance == Skill where == s1 s2 = s1 === s2
+instance == Job where == s1 s2 = s1.jobName == s2.jobName
+derive class iTask Worker, Skill, Job
+derive JSONEncode Set
+derive JSONDecode Set
+derive gText Set
+derive gEditor Set
+derive gDefault Set
+
+usersStore :: Shared [Worker]
+usersStore = sharedStore "Users" [{Worker|username="mart",password="mart",loggedIn=False,skills=[Design,Testing]}]
+userStore :: String -> Shared Worker
+userStore u = mapReadWriteError
+	(\wl->case filter (\w->w.Worker.username == u) wl of
+		[u] = Ok u
+		u = Error (exception ("worker not found: " +++ toSingleLineText u))
+	,\nw wl->Ok $ Just [nw:filter (\w->w.Worker.username <> u) wl]
+	) usersStore
+
+jobsStore :: Shared [Job]
+jobsStore = sharedStore "Jobs"
+	[{id=1,jobName="Testing",skills=[Testing],children=[],blocked=False}
+	,{id=2,jobName="Bigjob",skills=[Testing],blocked=False,children=
+		[{id=3,jobName="subjob1",skills=[Testing],children=[],blocked=False}
+		,{id=4,jobName="subjob1",skills=[Testing],children=[],blocked=False}
+		]}
+	]	
+jobStore :: Int -> Shared Job
+jobStore i = mapReadWriteError
+	(findJob i
+	,\nj jl->Ok $ Just $ map (updateJob nj) jl
+	) jobsStore
+where
+	findJob i [] = Error (exception "Job not found")
+	findJob i [j=:{Job|id}:_] | id == i = Ok j
+	findJob i [j:js] = case findJob i j.Job.children of
+		Error e = findJob i js
+		Ok u = Ok u
+
+	updateJob nj j=:{Job|id} | id == i = nj
+	updateJob nj j = {Job|j & children=map (updateJob nj) j.Job.children}
+
+removeJob :: Int [Job] -> [Job]
+removeJob i [] = []
+removeJob i [j=:{Job|id}:js] | i == id = js
+removeJob i [j:js] = [{Job|j & children=removeJob i j.Job.children}:removeJob i js]
+	
+jobID :: Shared Int
+jobID = sharedStore "JobIDS" 4
+
+Start w = doTasks ((login -||- register <<@ ArrangeWithTabs False) >>- work) w
+
+register :: Task Worker
+register = tune (Title "Register") 
+	$ enterInformation "Enter credentials" [EnterUsing id credentialEditor]
+	-&&- enterInformation "Enter Skills" []
+	>>= \((u, p),s)->get usersStore
+	@   filter (\a->a.Worker.username==u)
+	>>- \exists->case exists of
+		[] = let user = {loggedIn=True,username=u,password=p,skills=removeDup s}
+		     in  upd (\l->[user:l]) usersStore >>| treturn user
+		_ = viewInformation "User already exists" [] () >>| register
+
+login :: Task Worker
+login = tune (Title "Login")
+	$ enterInformation "Enter credentials" [EnterUsing id credentialEditor]
+	>>= \(u,p)->get usersStore
+	@   filter (\a->a.Worker.username==u && a.Worker.password==p)
+	>>- \u->case u of
+		[] = viewInformation "User not found or incorrect password" [] () >>| login
+		[{loggedIn=True}] = viewInformation "User is already logged in" [] () >>| login
+		[u] = upd (\w->{w & loggedIn=True}) (userStore u.Worker.username)
+
+credentialEditor = panel2
+	(textField <<@ labelAttr "Username")
+	(passwordField <<@ labelAttr "Password")
+
+work :: Worker -> Task [()]
+work {Worker|username} = allTasks
+	[ viewJobs
+	, createNewJobs
+	, updateSkills
+	] <<@ Title ("Welcome " +++ username) <<@ ArrangeWithTabs False
+where
+	viewJobs
+		= tune (Title "View jobs")
+		$ editSelectionWithShared "Select a job" False
+			(SelectInTree toCN fromSel)
+			(jobsStore >*< userStore username)
+			(\_->[])
+		>^*
+			[OnAction (Action "Execute") $ ifValue (\j->j=:[_]) \[j]->
+				    upd (\j->{j & blocked=True}) (jobStore j.Job.id)
+				>>| viewSharedInformation "Job" [] (jobStore j.Job.id)
+				>>*
+					[OnAction (Action "Finish") $ always $
+						upd (removeJob j.Job.id) jobsStore
+					,OnAction (Action "Split") $ always $
+						    enterInformation "Enter sub jobs" [EnterUsing id (gEditor{|*->*|} jobEditor gText{|*|} JSONEncode{|*|} JSONDecode{|*|})]
+						>>= \sjs->sequence (take (length sjs) (repeat (upd inc jobID)))
+						>>= \ids->upd (\j->{Job|j & blocked=False,children=[{Job|id=i,jobName=n,skills=s,blocked=False,children=[]}\\(n,s)<-sjs & i<-ids]}) (jobStore j.Job.id)
+						@! []
+					,OnAction (Action "Cancel") $ always $
+						upd (\j->{j & blocked=False}) (jobStore j.Job.id)
+						@! []
+					]
+			]
+		@! ()
+	
+	toCN ::([Job],Worker) -> [ChoiceNode]
+	toCN (jobs, worker) =
+		[
+			{id=if (job.Job.blocked || not (job.Job.children =: []) || not (matchSkills job)) (~job.Job.id) job.Job.id
+			,label=job.Job.jobName +++ "(" +++ toSingleLineText job.Job.skills +++ ")"
+			,icon=if (job.Job.blocked || not (matchSkills job)) (Just "document-error") Nothing
+			,expanded=True
+			,children=toCN (job.Job.children, worker)
+			}
+		\\job<-jobs
+		]
+	where
+		matchSkills job = 'List'.difference job.Job.skills worker.Worker.skills == []
+
+	fromSel :: ([Job],Worker) [Int] -> [Job]
+	fromSel (jobs,w) ids
+		=  [j\\j<-jobs | isMember j.Job.id ids]
+		++ flatten [fromSel (j.Job.children, w) ids\\j<-jobs]
+
+	createNewJobs
+		= tune (Title "Create new jobs")
+		$ forever
+		$ enterInformation "Enter job" [EnterUsing id jobEditor]
+		>>= \(name, skills)->upd inc jobID
+		>>= \i->upd ((++) [{Job|id=i,skills=skills,jobName=name,blocked=False,children=[]}]) jobsStore
+		@! ()
+	
+	jobEditor :: Editor (String, [Skill])
+	jobEditor = panel2
+		(gEditor{|*|} <<@ labelAttr "Name")
+		(gEditor{|*|} <<@ labelAttr "Skills")
+
+	updateSkills
+		= tune (Title "Edit skills")
+		$ updateSharedInformation "Skills" [UpdateAs (\w->w.Worker.skills) (\w s->{Worker|w & skills=s})] (userStore username)
+		@! ()
diff --git a/afp/a8/a8.icl b/afp/a8/a8.icl
new file mode 100644
index 0000000..95e679d
--- /dev/null
+++ b/afp/a8/a8.icl
@@ -0,0 +1,179 @@
+module a8
+
+/*
+  Advanced Progrmming 2018, Assignment 8
+  Pieter Koopman, pieter@cs.ru.nl
+*/
+import StdEnv
+
+import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
+import Data.Func
+import Data.Functor
+import Data.Either
+import Data.Maybe
+
+import Text => qualified join
+
+import qualified Data.List as List
+import qualified Data.Map as Map
+
+:: Expression
+  = New      [Int]
+  | Elem     Int
+  | Variable Ident
+  | Size     Set
+  | (+.) infixl 6 Expression Expression
+  | (-.) infixl 6 Expression Expression
+  | (*.) infixl 7 Expression Expression
+  | (=.) infixl 2 Ident Expression
+
+:: Logical
+  = TRUE | FALSE
+  | (In) infix 4 Elem Set
+  | (==.) infix 4 Expression Expression
+  | (<=.) infix 4 Expression Expression
+  | Not Logical
+  | (||.) infixr 2 Logical Logical
+  | (&&.) infixr 3 Logical Logical
+
+:: Stmt
+  = Expression Expression
+  | Logical Logical
+  | For Ident Set Stmt
+  | If Logical Stmt Stmt
+
+:: Set    :== Expression
+:: Elem   :== Expression
+:: Ident  :== String
+
+// === State
+:: Val :== Either Int [Int]
+:: SemState :== 'Map'.Map String Val
+:: Sem a :== StateT SemState (Either String) a
+
+store :: Ident Val -> Sem Val
+store k v = modify ('Map'.put k v) *> pure v
+
+read :: Ident -> Sem Val
+read k = gets ('Map'.get k) >>= maybe (fail "Unknown ident") pure
+
+fail :: String -> Sem a
+fail s = liftT (Left s)
+
+// === semantics
+isset :: (Sem Val) -> Sem [Int]
+isset s = s >>= either (\_->fail "Expected Set, got Elem") pure
+
+iselem :: (Sem Val) -> Sem Int
+iselem s = s >>= either pure (\_->fail "Expected Elem, got Set")
+
+class eval t ~v :: t -> Sem v
+
+instance eval Expression Val
+where
+	eval :: Expression -> Sem Val
+	eval (New s)      = pure $ Right s
+	eval (Elem i)     = pure $ Left i
+	eval (Variable i) = read i
+	eval (Size s)     = isset (eval s) >>= pure o Left o length
+	eval (l +. r)     = eval l >>= \x->eval r >>= \y->case (x, y) of
+		(Left  x, Left  y) = pure $ Left (x + y)
+		(Left  x, Right y) = pure $ Right $ 'List'.union [x] y
+		(Right x, Left  y) = pure $ Right $ 'List'.union x [y]
+		(Right x, Right y) = pure $ Right $ 'List'.union x y
+	eval (l -. r)     = eval l >>= \x->eval r >>= \y->case (x, y) of
+		(Left  x, Left  y) = pure $ Left (x - y)
+		(Left  x, Right y) = fail "Elem -. Set is illegal"
+		(Right x, Left  y) = pure $ Right $ 'List'.intersect x [y]
+		(Right x, Right y) = pure $ Right $ 'List'.intersect x y
+	eval (l *. r)     = eval l >>= \x->eval r >>= \y->case (x, y) of
+		(Left  x, Left  y) = pure $ Left (x * y)
+		(Left  x, Right y) = pure $ Right [x*y\\y<-y]
+		(Right x, Left  y) = fail "Set *. Elem is illegal"
+		(Right x, Right y) = pure $ Right $ 'List'.intersect x y
+	eval (v =. b)    = eval b >>= store v
+
+instance eval Logical Bool
+where
+	eval TRUE        = pure True
+	eval FALSE       = pure False
+	eval (e In s)    = liftM2 'List'.elem (iselem (eval e)) (isset (eval s))
+	eval (e1 ==. e2) = liftM2 (===) (eval e1) (eval e2)
+	eval (e1 <=. e2) = evalExpr e1 >>= \x->evalExpr e2 >>= \y->case (x, y) of
+		(Left e1, Left e2) = pure $ e1 < e2
+		(Left e1, Right e2) = pure $ True
+		(Right e1, Left e2) = pure $ False
+		(Right e1, Right e2) = pure $ length e1 < length e2
+	where
+		evalExpr :: (Expression -> Sem Val)
+		evalExpr = eval
+	eval (Not l)     = not <$> eval l
+	eval (l1 ||. l2) = liftM2 (||) (eval l1) (eval l2)
+	eval (l1 &&. l2) = liftM2 (&&) (eval l1) (eval l2)
+
+instance eval Stmt ()
+where
+	eval (Expression e) = eval e >>| pure ()
+	eval (Logical l)    = eval l >>| pure ()
+	eval (For i e s)    = (eval e >>= store i) *> eval s
+	eval (If l s1 s2)   = eval l >>= \b->if b (eval s1) (eval s2)
+
+class print t :: t [String] -> [String]
+instance print Expression
+where
+	print (New s)      c = ["[":'List'.intersperse "," $ map toString s] ++ ["]":c]
+	print (Elem i)     c = [toString i:c]
+	print (Variable i) c = [i:c]
+	print (Size s)     c = ["size(":print s [")":c]]
+	print (l +. r)     c = ["(":print l ["+.":print r [")":c]]]
+	print (l -. r)     c = ["(":print l ["-.":print r [")":c]]]
+	print (l *. r)     c = ["(":print l ["*.":print r [")":c]]]
+	print (l =. r)     c = [l,"=.":print r c]
+
+instance print Logical
+where
+	print TRUE        c = ["True":c]
+	print FALSE       c = ["False":c]
+	print (e In s)    c = print e [" in ":print s c]
+	print (e1 ==. e2) c = ["(":print e1 ["==.":print e2 [")":c]]]
+	print (e1 <=. e2) c = ["(":print e1 ["<=.":print e2 [")":c]]]
+	print (Not l)     c = ["not (":print l [")":c]]
+	print (l1 ||. l2) c = ["(":print l1 ["||.":print l2 [")":c]]]
+	print (l1 &&. l2) c = ["(":print l1 ["&&.":print l2 [")":c]]]
+
+instance print Stmt
+where
+	print (Expression e) c = print e c
+	print (Logical l)    c = print l c
+	print (For i e s)    c = ["For ",i,"=":print e ["in":print s ["Rof":c]]]
+	print (If l s1 s2)   c = ["If":print l ["then":print s1 ["else":print s2 ["Fi":c]]]]
+
+// === simulation
+stateShared :: Shared SemState
+stateShared = sharedStore "sharedSemState" 'Map'.newMap
+
+derive class iTask Expression, Logical, Stmt
+
+main :: Task SemState
+main = 'iTasks'.forever $
+	    enterInformation "Enter a statement" []
+	-|| viewSharedInformation "Old state" [ViewAs printer] stateShared
+	>&^ viewSharedInformation "Print" [ViewAs viewer]
+	>&> viewSharedInformation "New state" [ViewAs $ fmap printer] o mapRead evaler o ((>*<) stateShared)
+	>>* [OnAction (Action "Execute") $ ifValue (\e->e=:(Right _)) $ \(Right s)->set s stateShared]
+where
+	viewer = maybe
+		"No expression selected"
+		('Text'.join " " o flip print [])
+	evaler :: (SemState, Maybe Stmt) -> Either String SemState
+	evaler (s, t) = maybe
+		(Left "No expression selected")
+		(\e->execStateT (eval e) s) t
+	printer m = [k +++ "=" +++ toSingleLineText v\\(k,v)<-'Map'.toList m]
+
+Start w = doTasks main w
diff --git a/afp/a8/a8_old.icl b/afp/a8/a8_old.icl
new file mode 100644
index 0000000..f5bbc32
--- /dev/null
+++ b/afp/a8/a8_old.icl
@@ -0,0 +1,165 @@
+module a8
+
+/*
+  Advanced Progrmming 2018, Assignment 8
+  Pieter Koopman, pieter@cs.ru.nl
+*/
+import StdEnv
+
+import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
+import Data.Func
+import Data.Functor
+import Data.Either
+import Data.Maybe
+
+import Text => qualified join
+
+import qualified Data.List as List
+import qualified Data.Map as Map
+
+:: Expression
+  = New      [Int]
+  | Elem     Int
+  | Variable Ident
+  | Size     Set
+  | (+.) infixl 6 Expression Expression
+  | (-.) infixl 6 Expression Expression
+  | (*.) infixl 7 Expression Expression
+  | (=.) infixl 2 Ident Expression
+
+:: Logical
+  = TRUE | FALSE
+  | (In) infix 4 Elem Set
+  | (==.) infix 4 Expression Expression
+  | (<=.) infix 4 Expression Expression
+  | Not Logical
+  | (||.) infixr 2 Logical Logical
+  | (&&.) infixr 3 Logical Logical
+
+:: Stmt
+  = Expression Expression
+  | Logical Logical
+  | For Ident Set Stmt
+  | If Logical Stmt Stmt
+
+:: Set    :== Expression
+:: Elem   :== Expression
+:: Ident  :== String
+
+// === State
+:: Val :== Either Int [Int]
+:: SemState :== 'Map'.Map String Val
+
+:: Sem a :== StateT SemState (Either String) a
+store :: Ident Val -> Sem Val
+store k v = modify ('Map'.put k v) *> pure v
+
+read :: Ident -> Sem Val
+read k = gets ('Map'.get k) >>= maybe (fail "Unknown ident") pure
+
+fail :: String -> Sem a
+fail s = liftT (Left s)
+
+// === semantics
+isset :: (Sem Val) -> Sem [Int]
+isset s = s >>= either (\_->fail "Expected Set, got Elem") pure
+
+iselem :: (Sem Val) -> Sem Int
+iselem s = s >>= either pure (\_->fail "Expected Elem, got Set")
+
+evalExpr :: Expression -> Sem Val
+evalExpr (New s)      = pure $ Right s
+evalExpr (Elem i)     = pure $ Left i
+evalExpr (Variable i) = read i
+evalExpr (Size s)     = isset (evalExpr s) >>= pure o Left o length
+evalExpr (l +. r)     = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of
+	(Left  x, Left  y) = pure $ Left (x + y)
+	(Left  x, Right y) = pure $ Right $ 'List'.union [x] y
+	(Right x, Left  y) = pure $ Right $ 'List'.union x [y]
+	(Right x, Right y) = pure $ Right $ 'List'.union x y
+evalExpr (l -. r)     = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of
+	(Left  x, Left  y) = pure $ Left (x - y)
+	(Left  x, Right y) = fail "Elem -. Set is illegal"
+	(Right x, Left  y) = pure $ Right $ 'List'.intersect x [y]
+	(Right x, Right y) = pure $ Right $ 'List'.intersect x y
+evalExpr (l *. r)     = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of
+	(Left  x, Left  y) = pure $ Left (x * y)
+	(Left  x, Right y) = pure $ Right [x*y\\y<-y]
+	(Right x, Left  y) = fail "Set *. Elem is illegal"
+	(Right x, Right y) = pure $ Right $ 'List'.intersect x y
+evalExpr (v =. b)    = evalExpr b >>= store v
+
+evalLogic :: Logical -> Sem Bool
+evalLogic TRUE        = pure True
+evalLogic FALSE       = pure False
+evalLogic (e In s)    = liftM2 'List'.elem (iselem (evalExpr e)) (isset (evalExpr s))
+evalLogic (e1 ==. e2) = liftM2 (===) (evalExpr e1) (evalExpr e2)
+evalLogic (e1 <=. e2) = evalExpr e1 >>= \x->evalExpr e2 >>= \y->case (x, y) of
+	(Left e1, Left e2) = pure $ e1 < e2
+	(Left e1, Right e2) = pure $ True
+	(Right e1, Left e2) = pure $ False
+	(Right e1, Right e2) = pure $ length e1 < length e2
+evalLogic (Not l)     = not <$> evalLogic l
+evalLogic (l1 ||. l2) = liftM2 (||) (evalLogic l1) (evalLogic l2)
+evalLogic (l1 &&. l2) = liftM2 (&&) (evalLogic l1) (evalLogic l2)
+
+evalStmt :: Stmt -> Sem ()
+evalStmt (Expression e) = evalExpr e >>| pure ()
+evalStmt (Logical l)    = evalLogic l >>| pure ()
+evalStmt (For i e s)    = (evalExpr e >>= store i) *> evalStmt s
+evalStmt (If l s1 s2)   = evalLogic l >>= \b->if b (evalStmt s1) (evalStmt s2)
+
+printExpr :: Expression [String] -> [String]
+printExpr (New s)      c = ["[":'List'.intersperse "," $ map toString s] ++ ["]":c]
+printExpr (Elem i)     c = [toString i:c]
+printExpr (Variable i) c = [i:c]
+printExpr (Size s)     c = ["size(":printExpr s [")":c]]
+printExpr (l +. r)     c = ["(":printExpr l ["+.":printExpr r [")":c]]]
+printExpr (l -. r)     c = ["(":printExpr l ["-.":printExpr r [")":c]]]
+printExpr (l *. r)     c = ["(":printExpr l ["*.":printExpr r [")":c]]]
+printExpr (l =. r)     c = [l,"=.":printExpr r c]
+
+printLogic :: Logical [String] -> [String]
+printLogic TRUE        c = ["True":c]
+printLogic FALSE       c = ["False":c]
+printLogic (e In s)    c = printExpr e [" in ":printExpr s c]
+printLogic (e1 ==. e2) c = ["(":printExpr e1 ["==.":printExpr e2 [")":c]]]
+printLogic (e1 <=. e2) c = ["(":printExpr e1 ["<=.":printExpr e2 [")":c]]]
+printLogic (Not l)     c = ["not (":printLogic l [")":c]]
+printLogic (l1 ||. l2) c = ["(":printLogic l1 ["||.":printLogic l2 [")":c]]]
+printLogic (l1 &&. l2) c = ["(":printLogic l1 ["&&.":printLogic l2 [")":c]]]
+
+printStmt :: Stmt [String] -> [String]
+printStmt (Expression e) c = printExpr e c
+printStmt (Logical l)    c = printLogic l c
+printStmt (For i e s)    c = ["For ",i,"=":printExpr e ["in":printStmt s ["Rof":c]]]
+printStmt (If l s1 s2)   c = ["If":printLogic l ["then":printStmt s1 ["else":printStmt s2 ["Fi":c]]]]
+
+// === simulation
+stateShared :: Shared SemState
+stateShared = sharedStore "sharedSemState" 'Map'.newMap
+
+derive class iTask Expression, Logical, Stmt
+
+main :: Task SemState
+main = 'iTasks'.forever $
+	    enterInformation "Enter a statement" []
+	-|| viewSharedInformation "Old state" [ViewAs printState] stateShared
+	>&^ viewSharedInformation "Print" [ViewAs viewer]
+	>&> viewSharedInformation "New state" [ViewAs $ fmap printState] o mapRead evaler o ((>*<) stateShared)
+	>>* [OnAction (Action "Execute") $ ifValue (\e->e=:(Right _)) $ \(Right s)->set s stateShared]
+where
+	viewer = maybe
+		"No expression selected"
+		('Text'.join " " o flip printStmt [])
+	evaler (s, t) = maybe
+		(Left "No expression selected")
+		(\e->execStateT (evalStmt e) s) t
+	printState m = [k +++ "=" +++ toSingleLineText v\\(k,v)<-'Map'.toList m]
+
+Start w = doTasks main w
diff --git a/parserParser/test.icl b/parserParser/test.icl
new file mode 100644
index 0000000..5eb04d6
--- /dev/null
+++ b/parserParser/test.icl
@@ -0,0 +1,45 @@
+module test
+
+import StdEnv
+
+import Data.Functor
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
+
+import Text.Parsers.Simple.Core
+
+:: In a b = (:.) infix 0 a b
+
+:: Gram
+	= Def (Gram -> In Gram Gram)
+	| Def2 ((Gram,Gram) -> In (Gram, Gram) Gram)
+	| Lit String
+	| Int
+	| (-.) infixr 2 Gram Gram
+	| (|.) infix 1 Gram Gram
+:: Gast
+	= INT Int
+	| LIT String
+	| BIN Gast Gast
+
+parseFromGram :: Gram -> Parser String Gast
+parseFromGram (Def g)  = let (body :. gram) = g body in parseFromGram gram
+parseFromGram  Int     = INT o toInt <$> pSatisfy (\s->toString (toInt s) == s)
+parseFromGram (Lit i)  = LIT <$> pSatisfy ((==)i)
+parseFromGram (a -. b) = BIN <$> parseFromGram a <*> parseFromGram b
+parseFromGram (a |. b) = parseFromGram a <|> parseFromGram b
+
+//Start = runParser (parseFromGram gram) [".","."]
+Start = parse (parseFromGram gram) ["5"]
+where
+	gram =
+		Def \lit =  Int
+		         |. Lit "(" -. expr -. Lit ")"
+		Def \fac =  lit -. Lit "*" -. fac
+		         |. lit -. Lit "/" -. fac
+		         |. lit :.
+		Def \expr=  fac -. Lit "+" -. expr
+		         |. fac -. Lit "-" -. expr
+		         |. fac :.
+		expr