implementation module Generics.gCons

/*
	Pieter Koopman 2015
	pieter@cs.ru.nl
	Radboud University, Nijmegen, The Netherlands
	ARDSL project
*/

import StdEnv, StdGeneric, GenBimap, _SystemStrictLists
import Data.Functor
import Data.List
import Data.Maybe

consByName :: String -> Maybe a | conses{|*|}, consName{|*|} a
consByName a = let cs = conses{|*|}
	in ((!!) cs) <$> elemIndex a (map consName{|*|} cs)
	

generic consName a :: a -> String
consName{|CONS of {gcd_name}|} f x = gcd_name
consName{|UNIT|}   _ = "UNIT"
consName{|PAIR|}   f g (PAIR x y) = f x
consName{|EITHER|} f g (LEFT x)   = f x
consName{|EITHER|} f g (RIGHT y)  = g y
consName{|OBJECT|} f   (OBJECT x) = f x
consName{|RECORD|} f   (RECORD x) = f x
consName{|FIELD|}  f   (FIELD x)  = f x
consName{|Int|}        i = toString i
consName{|Bool|}       b = toString b
consName{|Char|}       c = toString c
consName{|Real|}       r = toString r
consName{|String|}     s = s
consName{|[]|} _ _ = "[]"
consName{|[!]|} _ _ = "[!]"
consName{|[ !]|} _ _ = "[ !]"
consName{|[!!]|} _ _ = "[!!]"
consName{|{}|} _ _ = "{}"
consName{|{!}|} _ _ = "{!}"
consName{|(->)|}   f g x = g (x undef)
consName{|()|} _ = "()"
consName{|(,)|} _ _ _ = "(,)"
consName{|(,,)|}  _ _ _ _ = "(,,)"
consName{|(,,,)|}  _ _ _ _ _ = "(,,,)"
consName{|(,,,,)|}  _ _ _ _ _ _ = "(,,,,)"
consName{|(,,,,,)|}  _ _ _ _ _ _ _ = "(,,,,,)"
consName{|(,,,,,,)|}  _ _ _ _ _ _ _ _ = "(,,,,,,)"
consName{|(,,,,,,,)|}  _ _ _ _ _ _ _ _ _ = "(,,,,,,,)"
consName{|(,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,)"
consName{|(,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,)"
consName{|(,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,)"
consName{|(,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)"
consName{|(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)|}  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ = "(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)"

generic consIndex a :: a -> Int
consIndex{|CONS of {gcd_index}|} f x = gcd_index
consIndex{|UNIT|} _ = 0
consIndex{|PAIR|} f g (PAIR x y) = f x
consIndex{|EITHER|} f g (LEFT x) = f x
consIndex{|EITHER|} f g (RIGHT y) = g y
consIndex{|OBJECT|} f (OBJECT x) = f x
consIndex{|RECORD|} f (RECORD x) = f x
consIndex{|FIELD|} f (FIELD x) = f x
consIndex{|Int|} i = i
consIndex{|Bool|} b = if b 1 0
consIndex{|Char|} c = toInt c
consIndex{|Real|} r = toInt r
consIndex{|String|} _ = 0
consIndex{|{}|} _ _ = 0
consIndex{|{!}|} _ _ = 0
consIndex{|(->)|} _ _ _ = 0
derive consIndex [],[!],[ !],[!!],(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)

generic conses a :: [a]
conses{|CONS|} f = [CONS (hd f)]
conses{|UNIT|} = [UNIT]
conses{|PAIR|} f g = []
conses{|EITHER|} f g = map LEFT f ++ map RIGHT g
conses{|OBJECT|} f = map OBJECT f
conses{|RECORD|} f = map RECORD f
conses{|FIELD|} f = map FIELD f
conses{|Int|} = [0]
conses{|Bool|} = [True]
conses{|Char|} = ['\0']
conses{|Real|} = [0.0]
conses{|String|} = [""]
conses{|{}|} _ = [{}]
conses{|{!}|} _ = [{!}]
conses{|(->)|} _ _ = [const undef]
derive conses [],[!],[ !],[!!],(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)

generic consNum a :: a -> Int
consNum{|CONS of {gcd_arity}|} f x = gcd_arity
consNum{|UNIT|} _ = 0
consNum{|PAIR|} f _ (PAIR x y) = f x
consNum{|EITHER|} f _ (LEFT x) = f x
consNum{|EITHER|} _ g (RIGHT y) = g y
consNum{|OBJECT|} f (OBJECT x) = f x
consNum{|RECORD|} f (RECORD x) = f x
consNum{|FIELD|} f (FIELD x) = f x
consNum{|Int|} _ = 0
consNum{|Bool|} _ = 0
consNum{|Char|} _ = 0
consNum{|Real|} _ = 0
consNum{|String|} _ = 0
consNum{|{}|} _ _ = 0
consNum{|{!}|} _ _ = 0
consNum{|(->)|} _ _ _ = 0
derive consNum [],[!],[ !],[!!],(),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)