Flavour.icl 2.65 KB
Newer Older
1
implementation module Sapl.Target.Flavour
2

3
import StdList, StdFunc, StdArray
4
import Data.Maybe, Data.Functor, Text.JSON, Text.StringAppender
5
import Sapl.SaplParser
6

7
from Data.Set import qualified fromList, member
8
from Data.Set import :: Set
9
import qualified Data.Map as DM
10
           
11 12 13
derive JSONEncode FlavourRep, BIFRep
derive JSONDecode FlavourRep, BIFRep

14
:: X = StringPart !String | Binding !Int | ForceBinding !Int
15 16 17 18 19

extractBindings str = extractBindings` (fromString str) []
where
	extractBindings` [] [] = []
	extractBindings` [] ss = [StringPart (revstr ss)]
20 21 22 23
	extractBindings` [':','!',x,':':xs] ss 
		| isDigit x = case ss of
						[] = [ForceBinding (digitToInt x):extractBindings` xs []]
						ss = [StringPart (revstr ss),ForceBinding (digitToInt x):extractBindings` xs []]
24 25 26 27 28 29 30 31 32
	extractBindings` [':',x,':':xs] ss 
		| isDigit x = case ss of
						[] = [Binding (digitToInt x):extractBindings` xs []]
						ss = [StringPart (revstr ss),Binding (digitToInt x):extractBindings` xs []]
	extractBindings` [x:xs] ss = extractBindings` xs [x:ss]
	
	revstr ss = toString (reverse ss)

toFlavour :: !String -> Maybe Flavour
33 34 35 36
toFlavour str = fmap fromFlavourRep (fromJSON (fromString str))

fromFlavourRep :: !FlavourRep -> Flavour
fromFlavourRep rep 
37 38 39 40
		= { fun_prefix = rep.FlavourRep.fun_prefix
		  , options = 'Data.Set'.fromList rep.FlavourRep.options
		  , builtInFunctions = builtInFunctions
		  , inlineFunctions = inlineFunctions}  
41
where
42 43
		bifs = filter (\f -> isJust f.ext_fun) rep.bifs
		bifList = map (\f -> (f.sapl_fun, (fromJust f.ext_fun, f.BIFRep.arity))) bifs
44
		builtInFunctions = 'DM'.fromList bifList
45

46
		ifs = filter (\f -> isJust f.inline_exp) rep.bifs
47
		ifList = map toInlineFunDef ifs
48
		inlineFunctions = 'DM'.fromList ifList
49 50 51 52 53 54 55
			
		toInlineFunDef f 
				=	(f.sapl_fun,  { InlineFunDef 
								  |	fun			= toInlineFun
								  , arity 		= f.BIFRep.arity
								  , strictness  = collectStrictnessInfo (createArray f.BIFRep.arity '0') bindings
								  ,	data_cons 	= maybe False id f.BIFRep.data_cons })	
56
		where
57
			toInlineFun = inst
58
			where
59 60 61 62 63 64 65 66 67 68 69 70 71 72
				inst eval feval args a = foldl app a bindings
				where
					app a (StringPart str) = a <++ str
					app a (Binding x) = eval (args!!(x-1)) a
					app a (ForceBinding x) = feval (args!!(x-1)) a			 
					  
			template = fromJust f.inline_exp							  
			bindings = extractBindings template				  
			
			collectStrictnessInfo arr [] = arr
			collectStrictnessInfo arr [ForceBinding i:bs] 
				# arr = if (i<=size arr) (update arr (i-1) '1') arr
				= collectStrictnessInfo arr bs
			collectStrictnessInfo arr [_:bs] = collectStrictnessInfo arr bs
73 74 75 76 77 78

isSet :: !Flavour !String -> Bool
isSet f opt = 'Data.Set'.member opt f.Flavour.options



79