a6/mart/skeleton6a.icl

   1 module skeleton6a
   2
   3 import StdTuple, 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 :: *TaskResult a :== (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 viewInformation :: Description a TaskState -> TaskResult a | iTasksLite a
  52 viewInformation d a ts=:{console} =
  53         (a, {ts & console=console <<< d <<< ": " <<< print a <<< ".\n"})
  54
  55 enterInformation :: Description TaskState -> TaskResult a | iTasksLite a
  56 enterInformation d ts=:{console}
  57 # (a, console) = freadline (console <<< d <<< ": ")
  58 = case parse a of
  59         Just x = (x, {ts & console=console})
  60         Nothing = enterInformation d {ts & console=console <<< "Wrong format, try again.\n"}
  61
  62 store :: a (StoreID a) TaskState -> TaskResult a | iTasksLite a
  63 store v s ts=:{store} = (v, {ts & store=store_ v s store})
  64
  65 retrieve :: (StoreID a) TaskState -> TaskResult a | iTasksLite a
  66 retrieve s ts=:{store} = (retrieve_ s store, ts)
  67
  68 eval :: (TaskState -> TaskResult a) *File -> (a, *File) | iTasksLite a
  69 eval taskFunc console
  70     # (r, st) = taskFunc ({store = newMap, console = console})
  71     = (r, st.console)
  72
  73 task0 :: TaskState -> TaskResult Int
  74 task0 st = (42, st)
  75
  76 // The type is surrounded by parenthesis because its a constant that happens to
  77 // be a function
  78 task1 :: (TaskState -> TaskResult Int)
  79 task1 = viewInformation "The answer is" 42
  80
  81 task2 :: TaskState -> TaskResult Int
  82 task2 st
  83 # (x, st) = enterInformation "Enter the answer" st
  84 = viewInformation "The answer is" x st
  85
  86 task3 :: TaskState -> TaskResult Int
  87 task3 st
  88     # (_, st) = store 1 intStore st
  89     =           retrieve intStore st
  90 where
  91     intStore :: StoreID Int
  92     intStore = "intStore"
  93
  94 task3Fail :: TaskState -> TaskResult Int
  95 task3Fail st = retrieve intStore st
  96         where
  97                 intStore :: StoreID Int
  98                 intStore = "intStore"
  99
 100 task3TypeFail :: TaskState -> TaskResult Int
 101 task3TypeFail st = retrieve intStore (snd (store "1" stringStore st))
 102         where
 103     intStore :: StoreID Int
 104     intStore = "intStore"
 105     stringStore :: StoreID String
 106     stringStore = "intStore"
 107
 108 // This gives a heap full error, because the console is never queried it just
 109 // continues. The strictness enforced the immediate query of the console.
 110 task4 :: TaskState -> TaskResult Void
 111 task4 st
 112     # (_, st) = store [] ideaStore st
 113     = addIdea st
 114 where
 115     addIdea st
 116         # (ideas, st) = retrieve ideaStore st
 117           (_,     st) = viewInformation "All ideas" ideas st
 118           (idea,  st) = enterInformation "Enter new idea" st
 119           (_,     st) = store (ideas ++ [toString (length ideas+1) +++ ". " +++ idea]) ideaStore st
 120         = addIdea st
 121
 122     ideaStore :: StoreID [String]
 123     ideaStore = "ideas"
 124
 125 Start world
 126  #      (console, world) = stdio world
 127         console                  = console <<< "Welcome to iTasksLite\n\n"
 128     (r, console)     = eval task3 console
 129     console          = console <<< "\nThe result of the task is " <<< print r <<< ".\n"
 130         (_, world)           = fclose console world
 131  = world