implementation module ufpl

import StdArray
import StdBool
import StdClass
from StdFunc import const, flip, id, o
from StdGeneric import :: Bimap{..}, bimapId; bm :== bimapId
import StdInt
import StdList
import StdMisc
import StdOverloaded
import StdString
import StdTuple

from Data.Func import $
import Data.List

import Arduino
import Bootstrap
import C
import Util

typedfun :: CType String -> String
typedfun t f = flip (+++) f case t of
	CTBool   -> "b"
	CTInt  s -> sig s +++ "i"
	CTChar s -> sig s +++ "c"
	CTLong s -> sig s +++ "l"
where
	sig :: Signedness -> String
	sig Sig = ""
	sig Unsig = "u"

append :: Shares Shares -> Shares
append NoShares ss = ss
append (Shares s ss) sss = Shares s (append ss sss)

removeDupShares :: Shares -> Shares
removeDupShares NoShares = NoShares
removeDupShares (Shares s ss) = if exists id (Shares s) (removeDupShares ss)
where
	exists = any (\s` -> s.sname == s`) (sharesMap (\s -> s.sname) ss)

sharesMap :: (A.t rw: (Shared t rw) -> a) Shares -> [a]
sharesMap _ NoShares = []
sharesMap f (Shares s ss) = [f s:sharesMap f ss]

instance allShares [t] | allShares t
where
	allShares` [] = NoShares
	allShares` [x:xs] = append (allShares` x) (allShares` xs)

instance allShares (Expr t rw)
where
	allShares` (ELit _) = NoShares
	allShares` (EShared s) = Shares s NoShares
	allShares` (a +. b) = append (allShares` a) (allShares` b)
	allShares` (a -. b) = append (allShares` a) (allShares` b)
	allShares` (a *. b) = append (allShares` a) (allShares` b)
	allShares` (a /. b) = append (allShares` a) (allShares` b)
	allShares` (EEq  _ a b) = append (allShares` a) (allShares` b)
	allShares` (ELt  _ a b) = append (allShares` a) (allShares` b)
	allShares` (EAnd _ a b) = append (allShares` a) (allShares` b)
	allShares` (EOr  _ a b) = append (allShares` a) (allShares` b)
	allShares` (EIf  b t e) = append (allShares` b) (append (allShares` t) (allShares` e))

instance allShares Trigger
where
	allShares` (Change t) = allShares` t
	allShares` (s ?= t) = append (allShares` s) (allShares` t)
	allShares` (a ?& b) = append (allShares` a) (allShares` b)
	allShares` (a ?| b) = append (allShares` a) (allShares` b)

instance allShares Rule
where
	allShares` (s <# e) = append (allShares` s) (allShares` e)
	allShares` (When t rs) = foldr1 append [allShares` t:map allShares` rs]
	allShares` (t >>> rs) = foldr1 append [allShares` t:map allShares` rs]
	allShares` (SetCursor (c,r)) = append (allShares` c) (allShares` r)
	allShares` (Print v) = allShares` v

instance allShares NamedRule
where
	allShares` (_ :=: r) = allShares` r

instance Expr Int where litExpr i = CEInt i
instance Expr Bool where litExpr b = CEBool b
instance Expr Char where litExpr c = CEChar c

lit :: (t -> Expr t RO)
lit = ELit

(?) infix 4 :: (Expr Bool rwa) (Expr t rwb, Expr t rwc) -> Expr t RO
(?) b (t,e) = EIf b t e

(==.) infix 4 :: (Expr t rwa) (Expr t rwb) -> Expr Bool RO | Expr, == t
(==.) a b = EEq bm a b

(<.) infix 4 :: (Expr t rwa) (Expr t rwb) -> Expr Bool RO | Expr, < t
(<.) a b = ELt bm a b

(>.) infix 4 :: (Expr t rwa) (Expr t rwb) -> Expr Bool RO | Expr, < t
(>.) a b = ELt bm b a

(&&.) infixr 3 :: (Expr Bool rwa) (Expr Bool rwb) -> Expr Bool RO
(&&.) a b = EAnd bm a b

(||.) infixr 4 :: (Expr Bool rwa) (Expr Bool rwb) -> Expr Bool RO
(||.) a b = EOr bm a b

instance :. Rule   where (:.) a b = [a,b]
instance :. [Rule] where (:.) r rs = [r:rs]

instance ||| NamedRule   where (|||) a b = [a,b]
instance ||| [NamedRule] where (|||) r rs = [r:rs]

instance gen (Expr t rw) CExpr | Expr t
where
	gen (ELit v) = litExpr v
	gen (EShared s) = CEGlobal ("s" +++ s.sname +++ ".val")
	gen (a +. b) = CEInfix "+" (gen a) (gen b)
	gen (a -. b) = CEInfix "-" (gen a) (gen b)
	gen (a *. b) = CEInfix "*" (gen a) (gen b)
	gen (a /. b) = CEInfix "/" (gen a) (gen b)
	gen (EEq  _ a b) = CEInfix "==" (gen a) (gen b)
	gen (ELt  _ a b) = CEInfix "<"  (gen a) (gen b)
	gen (EAnd _ a b) = CEInfix "&&" (gen a) (gen b)
	gen (EOr  _ a b) = CEInfix "||" (gen a) (gen b)
	gen (EIf b t e) = CEIf (gen b) (gen t) (gen e)

instance gen (Shared t rw) CVar
where
	gen shr =
		{ name  = "s" +++ shr.sname
		, type  = CTStruct (typedfun shr.stype "share")
		, value = CEStruct
			[ ("val", shr.srepr.map_to shr.sinit)
			, ("dirty", CEInt 0)
			, ("subscriptions", CEInt 0)
			]
		}

instance gen Trigger CExpr
where
	gen (Change (EShared shr)) = CEApp (typedfun shr.stype "dirty") [CERef (CEGlobal ("s" +++ shr.sname))]
	gen (EShared shr ?= e) = CEInfix "&&" (gen (Change (EShared shr))) (CEInfix "==" (CEGlobal ("s" +++ shr.sname +++ ".val")) (gen e))
	gen (a ?& b) = CEInfix "&&" (gen a) (gen b)
	gen (a ?| b) = CEInfix "||" (gen a) (gen b)

instance gen Rule CBody
where
	gen (EShared shr <# val) = CBExpr (CEApp (typedfun shr.stype "set") [CERef (CEGlobal ("s" +++ shr.sname)), gen val])
	gen (When b rs) = CBIf (gen b) (gen rs) CBEmpty
	gen (t >>> rs) = CBIf (gen t) (gen rs) CBEmpty
	gen (SetCursor (c,r)) = CBExpr (CEApp "lcd.setCursor" [gen c, gen r])
	gen (Print e) = CBExpr (CEApp "lcd.print" [gen e])

instance gen [r] CBody | gen r CBody
where
	gen [] = CBEmpty
	gen rs = foldr1 CBSeq (map gen rs)

instance gen NamedRule CFun
where
	gen (name :=: rs) =
		{ params = []
		, body   = gen rs
		, fresh  = 0
		, type   = CTVoid
		, name   = "t" +++ name
		}

instance gen [NamedRule] String
where
	gen rs = foldl1 (+++) $
		[rts] ++
		["\n" +++ printToString var \\ var <- sharesMap genv (allShares rs)] ++
		["\n" +++ printToString (genf rule) \\ rule <- rs]
	where
		genf :: (NamedRule -> CFun)
		genf = gen

		genv :: ((Shared t rw) -> CVar)
		genv = gen

instance gen NamedRule   CProg
where
	gen r = combinePrograms zero
		{ bootstrap = ""
		, globals   = sharesMap gen (allShares r)
		, funs      = [gen r]
		}

instance gen [NamedRule] CProg
where
	gen rs = foldr (combinePrograms o gen) zero rs

Start = printToString (genp example_score)
where
	genp :: (a -> CProg) | gen a CProg
	genp = gen

example_score :: [NamedRule]
example_score =
		"a" :=: b0 ?= true >>> [scorea <# scorea +. lit 1]
	||| "b" :=: b1 ?= true >>> [scoreb <# scoreb +. lit 1]
	||| "r" :=: b2 ?= true >>> [scorea <# lit 0, scoreb <# lit 0]
	||| "print" :=: Change scorea ?| Change scoreb >>>
		SetCursor (lit 0, lit 0) :.
		Print scorea :.
		Print (lit '-') :.
		Print scoreb
where
	scorea = rwInt "scorea" 0
	scoreb = rwInt "scoreb" 0

example_countdown :: [NamedRule]
example_countdown =
		"time" :=:
			When (millis -. DELAY >. counter)
				(counter <# counter +. DELAY :.
				seconds <# seconds -. lit 1 :.
				SetCursor (lit 0, lit 0) :.
				Print minutes :.
				Print (lit ':') :.
				Print seconds)
		:.  When (seconds ==. lit 0) (seconds <# lit 60 :. minutes <# minutes -. lit 1)
	||| "status" :=:
			When (seconds ==. lit 60 &&. minutes ==. lit 0) [running <# false]
where
	running = rwBool "running" False
	minutes = rwUInt "minutes" 0
	seconds = rwUInt "seconds" 0
	counter = rwULong "counter" 1000 // If set to 0, this will overflow on first iteration
	DELAY = lit 1000