a6/mart/skeleton6b.icl

   1 module skeleton6b
   2
   3 import StdList, StdInt, StdChar, StdMisc, StdClass, StdString, StdFile, StdArray, Data.Maybe, Data.Map, Control.Monad, Data.Tuple, Data.Void
   4 import qualified Text
   5 from Text import class Text, instance Text String
   6
   7 class print a :: a -> String
   8
   9 instance print Void where print _ = "Void"
  10 instance print String where print s = s
  11 instance print Int where print i = toString i
  12 instance print [a] | print a where print l = 'Text'.join ", " (map print l)
  13
  14 class parse a :: String -> Maybe a
  15
  16 instance parse Void where parse _ = Just Void
  17
  18 instance parse String where
  19     parse s = let len = size s
  20               in  Just (if (select s (len-1) == '\n') (s % (0, len - 2)) s) // remove newline
  21 instance parse Int where
  22         parse s
  23                 # len = size s
  24                 | len > 0
  25                         # s = if (select s (len-1) == '\n') (s % (0, len - 2)) s // remove newline
  26                         # i = toInt s
  27                         | toString i == s
  28                                 = Just i
  29                         = Nothing
  30
  31 instance parse [a] | parse a where parse s = foldr (\xs list -> maybe Nothing (\e -> fmap (\l -> [e:l]) list) (parse xs)) (Just []) ('Text'.split "," s)
  32
  33 class iTasksLite a | print a & parse a & TC a
  34
  35 :: Description   :== String
  36 :: StoreID a     :== String
  37 :: Task a        = Task (*TaskState -> *(a, *TaskState))
  38 :: *TaskState    = { console :: !*File
  39                    , store   :: Map String Dynamic
  40                    }
  41
  42 store_ :: a (StoreID a) (Map String Dynamic) -> Map String Dynamic | TC a
  43 store_ v sid store = put sid (dynamic v) store
  44
  45 retrieve_ :: (StoreID a) (Map String Dynamic) -> a | TC a
  46 retrieve_ sid store = case get sid store of
  47     Just (a :: a^) = a
  48     Just _         = abort "type error\n"
  49     Nothing        = abort "empty store\n"
  50
  51 instance Functor Task where
  52     fmap :: (a -> b) (Task a) -> Task b
  53     fmap f (Task g) = Task \st.let (x, st1) = g st in (f x, st1)
  54
  55 instance Applicative Task where
  56     pure :: a -> Task a
  57     pure x = Task \st.(x, st)
  58
  59     (<*>) infixl 4  :: (Task (a -> b)) (Task a) -> Task b
  60     (<*>) (Task f) (Task g) = Task \st.let (x, st1) = g st in let (y, st2) = f st1 in (y x, st2)
  61
  62 instance Monad Task where
  63     bind :: (Task a) (a -> Task b) -> Task b
  64     bind (Task f) g = Task \st.let (x, st1) = f st in let (Task y) = g x in y st1
  65
  66 eval :: (Task a) *File -> (a, *File) | iTasksLite a
  67 eval (Task taskFunc) console
  68     # (r, {console}) = taskFunc {store = newMap, console = console}
  69     = (r, console)
  70
  71 viewInformation :: Description a -> Task a | iTasksLite a
  72 viewInformation d x = Task \st=:{console}.(x, {st & console=console <<< d <<< ": " <<< print x <<< ".\n"})
  73
  74 enterInformation :: Description -> Task a | iTasksLite a
  75 enterInformation d = Task f
  76         where
  77                 f st=:{console}
  78                 # (a, console) = freadline (console <<< d <<< ": ")
  79                 = case parse a of
  80                         Just x = (x, {st & console=console})
  81                         Nothing = f {st & console=console <<< "Wrong format, try again.\n"}
  82
  83 store :: a (StoreID a) -> Task a | iTasksLite a
  84 store v s = Task \st=:{store}.(v, {st & store=store_ v s store})
  85
  86 retrieve :: (StoreID a) -> Task a | iTasksLite a
  87 retrieve s = Task \st=:{store}.(retrieve_ s store, st)
  88
  89 task0 :: Task Int
  90 task0 = return 42
  91
  92 task1 :: Task Int
  93 task1 = viewInformation "The answer is" 42
  94
  95 task2 :: Task Int
  96 task2 =
  97      enterInformation "Enter the answer"
  98  >>= viewInformation "The answer is"
  99
 100 task3 :: Task Int
 101 task3 =
 102         store 1 intStore
 103     >>| retrieve intStore
 104 where
 105     intStore :: StoreID Int
 106     intStore = "intStore"
 107
 108 task3Fail :: Task Int
 109 task3Fail = retrieve intStore
 110 where
 111     intStore :: StoreID Int
 112     intStore = "intStore"
 113
 114 task4 :: Task Void
 115 task4 =
 116         store [] ideaStore
 117     >>| addIdea
 118 where
 119     addIdea =
 120                       retrieve ideaStore
 121         >>= \ideas -> viewInformation "All ideas" ideas
 122         >>|           enterInformation "Enter new idea"
 123         >>= \idea  -> store (ideas ++ [toString (length ideas+1) +++ ". " +++ idea]) ideaStore
 124         >>|           addIdea
 125
 126     ideaStore :: StoreID [String]
 127     ideaStore = "ideas"
 128
 129 Start world
 130  #      (console, world) = stdio world
 131         console                  = console <<< "Welcome to iTasksLite" <<< "\n\n"
 132     (r, console)     = eval task4 console
 133     console          = console <<< "\n" <<< "The result of the task is " <<< print r <<< ".\n"
 134         (_, world)           = fclose console world
 135  = world
 136