From 65e5bccfdd395caa062a6c63c8023bd2d625f193 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Fri, 5 Jun 2020 10:38:04 +0200 Subject: [PATCH] t --- lambda/test.dcl | 2 ++ lambda/test.icl | 82 +++++++++++++++++++++++++++++++++++++++++++++++ structs/GenC.dcl | 2 +- structs/GenC.icl | 64 +++++++++++++++++++++++------------- structs/qualified | 0 structs/test.icl | 6 +++- test.icl | 21 ++---------- 7 files changed, 134 insertions(+), 43 deletions(-) create mode 100644 lambda/test.dcl create mode 100644 lambda/test.icl create mode 100644 structs/qualified diff --git a/lambda/test.dcl b/lambda/test.dcl new file mode 100644 index 0000000..7829f92 --- /dev/null +++ b/lambda/test.dcl @@ -0,0 +1,2 @@ +definition module test + diff --git a/lambda/test.icl b/lambda/test.icl new file mode 100644 index 0000000..2dfb06f --- /dev/null +++ b/lambda/test.icl @@ -0,0 +1,82 @@ +module test + +import StdEnv +import Data.Functor +import Data.Func +import Data.Maybe +import Control.Applicative +import Control.Monad + +:: In a b = In infixl 0 a b +class lambda v +where + (@) infixr 1 :: (v (a -> b)) (v a) -> v b + \| :: ((v a) -> v b) -> v (a -> b) + +class expr v +where + lit :: a -> v a | toString a + (+.) infixl 6 :: (v a) (v a) -> v a | + a + (-.) infixl 6 :: (v a) (v a) -> v a | - a + (*.) infixl 6 :: (v a) (v a) -> v a | * a + (/.) infixl 6 :: (v a) (v a) -> v a | / a + (==.) infix 4 :: (v a) (v a) -> v Bool | == a + If :: (v Bool) (v a) (v a) -> v a + +class let v +where + lett :: ((v a) -> In (v a) (v b)) -> v b + +:: Printer a = P ([String] [String] -> [String]) +unP (P a) = a +print :: (Printer a) -> [String] +print (P a) = a ["v" +++ toString i\\i<-[0..]] [] +instance lambda Printer +where + (@) (P l) (P r) = P \i c->l i [" ":r i c] + \| def = P \[i:is] c->["(\\", i, "->":unP (def (P \_ c->[i:c])) is [")":c]] + +instance expr Printer +where + lit a = P \i c->[toString a:c] + (+.) (P l) (P r) = P \i c->["(":l i ["+":r i [")":c]]] + (-.) (P l) (P r) = P \i c->["(":l i ["-":r i [")":c]]] + (*.) (P l) (P r) = P \i c->["(":l i ["*":r i [")":c]]] + (/.) (P l) (P r) = P \i c->["(":l i ["/":r i [")":c]]] + (==.) (P l) (P r) = P \i c->["(":l i ["==":r i [")":c]]] + If (P p) (P t) (P e) = P \i c->["if ":p i [" then ":t i [" else ":e i [" fi":c]]]] + +instance let Printer +where + lett def = P \[i:is] c-> + let (x In y) = def $ P \_ c->[i:c] + in ["let ",i,"=":(unP x) [i:is] [" in ":(unP y) is c]] + +eval :: (Maybe a) -> Maybe a +eval a = a + +instance lambda Maybe +where + (@) l r = ($) <$> l <*> r + \| def = Just (\a->fromJust (def (Just a))) + +instance expr Maybe +where + lit a = pure a + (+.) l r = (+) <$> l <*> r + (-.) l r = (-) <$> l <*> r + (*.) l r = (*) <$> l <*> r + (/.) l r = (/) <$> l <*> r + (==.) l r = (==) <$> l <*> r + If i t e = if` <$> i <*> t <*> e + +instance let Maybe +where + lett def = let (x In y) = def x in y + +Start = (print t, "\n", eval t) +where + t :: (v Int) | expr, lambda, let v + t = lett \id =(\| \x->x) + In lett \fac=(\| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1))) + In fac @ lit 10 diff --git a/structs/GenC.dcl b/structs/GenC.dcl index b33d991..840bc09 100644 --- a/structs/GenC.dcl +++ b/structs/GenC.dcl @@ -28,7 +28,7 @@ toStruct :: Box GTSState a | gToStruct{|*|} a :: GTSState instance zero GTSState generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a) -derive gToStruct Int, Bool, Char, Real, UNIT, CONS, FIELD, EITHER, PAIR, OBJECT of {gtd_name,gtd_conses,gtd_num_conses}, RECORD of {grd_name,grd_fields} +derive gToStruct Int, Bool, Char, Real, UNIT, CONS, FIELD, EITHER, PAIR, OBJECT of {gtd_arity,gtd_name,gtd_conses,gtd_num_conses}, RECORD of {grd_arity,grd_name,grd_fields} /** * Given a GTSState, generate typedefinitions diff --git a/structs/GenC.icl b/structs/GenC.icl index c566d23..19a0652 100644 --- a/structs/GenC.icl +++ b/structs/GenC.icl @@ -5,6 +5,7 @@ import Data.Map => qualified updateAt import Data.Func, Data.Tuple import Data.Maybe import Data.Either +import Data.List => qualified difference, union, find import Text import scc @@ -35,7 +36,7 @@ gPotInf{|RECORD of {grd_name}|} f s :: CType = CTTypeDef String | CTEnum [String] - | CTStruct [(String, [(String, Bool, String)])] + | CTStruct Int [(String, [(String, Bool, String)])] :: GTSState = {dict :: Map String CType} instance zero GTSState where zero = {dict=newMap} @@ -75,7 +76,8 @@ gToStruct{|PAIR|} fl _ fr _ st (a, GTSPair l) = GTSPair [a:l] (l, r) = GTSPair [l, r] , box st) -gToStruct{|OBJECT of {gtd_name,gtd_conses,gtd_num_conses}|} f i st +import Debug.Trace +gToStruct{|OBJECT of {gtd_name,gtd_arity,gtd_conses,gtd_num_conses}|} f i st # (Box isPInf) = i [] # ty = GTSType isPInf = case get gtd_name st.dict of @@ -92,18 +94,26 @@ gToStruct{|OBJECT of {gtd_name,gtd_conses,gtd_num_conses}|} f i st # (n, Box st) = appFst mkty $ f $ putst gtd_name (CTTypeDef gtd_name) st = ( GTSType isPInf gtd_name - , box $ putst gtd_name (CTStruct (zip2 [gcd.gcd_name\\gcd<-gtd_conses] (map (toT o mkccons) n))) st + , box $ putst gtd_name + (CTStruct gtd_arity $ zipWith ctcons gtd_conses $ map mkccons n) st ) where + mkty :: GTSResult -> [GTSResult] mkty (GTSEither l) = l mkty t = [t] + mkccons :: GTSResult -> [GTSResult] mkccons (GTSType pi t) = [GTSType pi t] mkccons (GTSPair t) = t mkccons _ = [] - - toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons] -gToStruct{|RECORD of {grd_name,grd_fields}|} f i st + + ctcons :: GenericConsDescriptor [GTSResult] -> (String, [(String, Bool, String)]) + ctcons gcd cons + # (_, gcd_name, _, cons, _) = trace_stdout ("\n---\n", gcd.gcd_name, gcd.gcd_type, cons, "\n---\n") + = (gcd_name, toT cons) + where + toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons] +gToStruct{|RECORD of {grd_arity,grd_name,grd_fields}|} f i st # (Box isPInf) = i [] = case get grd_name st.dict of Just n = (GTSType isPInf grd_name, box st) @@ -112,7 +122,7 @@ gToStruct{|RECORD of {grd_name,grd_fields}|} f i st = case n of GTSPair l = ( GTSType isPInf grd_name - , box $ putst grd_name (CTStruct [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st) + , box $ putst grd_name (CTStruct grd_arity [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st) _ = (GTSError, box st) /** @@ -123,7 +133,7 @@ toCType {dict=m} = foldr proc [] $ scc $ map (appSnd refs) $ toList m where refs (CTTypeDef s) = [s] refs (CTEnum _) = [] - refs (CTStruct cs) = map fst3 (flatten (map snd cs)) + refs (CTStruct _ cs) = map fst3 (flatten (map snd cs)) proc [] c = c proc [x] c = ctypedef x (find x m) c @@ -135,12 +145,12 @@ where ctypedef :: String CType [String] -> [String] ctypedef name (CTTypeDef a) c = ["typedef ", a, " ", name, ";\n":c] ctypedef name (CTEnum a) c = ["enum ", name, " {": enum a ["};\n":c]] - ctypedef name (CTStruct [(_, fs)]) c = + ctypedef name (CTStruct _ [(_, fs)]) c = [ "struct ", name, " {\n" : foldr (uncurry3 (field 1)) ["};\n":c] fs ] - ctypedef name (CTStruct cs) c = + ctypedef name (CTStruct _ cs) c = [ "struct ", name, " {\n" : ind 1 ["enum {" : enum (map fst cs) @@ -162,7 +172,7 @@ where enum [x:xs] c = [x, ",": enum xs c] typeName ty m c = [case get ty m of - Just (CTStruct _) = "struct " + Just (CTStruct _ _) = "struct " Just (CTEnum _) = "enum " _ = "" , ty:c] @@ -179,24 +189,32 @@ uncurry3 f (x,y,z) = f x y z toCParser :: GTSState -> ([String], [String]) toCParser {dict=m} = (funsigs, foldr funbody [] (toList m)) where - funsigs = [concat $ funsig n [";\n"]\\(n, _)<-toList m] + funsigs = foldr (uncurry funsig) [";\n"] $ toList m pfname n c = ["parse_", n:c] pfcall n c = pfname n ["(get, alloc, err);":c] - funsig n c - = typeName n m [" ": pfname n ["(\n" - : ind 1 ["uint8_t (*get)(void),\n" - : ind 1 ["void *(*alloc)(size_t),\n" - : ind 1 ["void (*err)(const char *errmsg, ...))" - :c]]]]] - funbody (n, ty) c = funsig n + funsig n (CTStruct i _) c + | i > 0 + = typeName n m [" " + : pfname n ["(\n" + : funargs 1 + $ foldr (\i c-> + [",\n":ind 1 ["void *(*parse_", toString i, ")(\n" + : funargs 2 [")":c]]]) [")":c] [0..i-1]]] + funsig n _ c = typeName n m [" ": pfname n ["(\n":funargs 1 [")":c]]] + funbody (n, ty) c = funsig n ty ["\n{\n" :ind 1 $ typeName n m [" r;\n" :funb ty $ ind 1 ["return r;\n}\n":c]]] + funargs i c + = ind i ["uint8_t (*get)(void),\n" + : ind i ["void *(*alloc)(size_t size),\n" + : ind i ["void (*err)(const char *errmsg, ...)" + :c]]] funb (CTTypeDef a) c = ind 1 ["r = ":pfcall a ["\n":c]] funb (CTEnum a) c = ind 1 ["r = get()\n":c] - funb (CTStruct [(_, fs)]) c = foldr (sfield 1 "r") c fs - funb (CTStruct fs) c + funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs + funb (CTStruct _ fs) c = ind 1 ["switch(r.cons = get()) {\n" :foldr field ( ind 1 ["default:\n" @@ -233,8 +251,8 @@ where funb (CTTypeDef a) c = ind 1 $ pfcall "r" a ["\n":c] funb (CTEnum a) c = ind 1 ["put(r)\n":c] - funb (CTStruct [(_, fs)]) c = foldr (sfield 1 "r") c fs - funb (CTStruct fs) c = + funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs + funb (CTStruct _ fs) c = ind 1 ["put(r.cons);\n" : ind 1 ["switch(r.cons) {\n" :foldr field diff --git a/structs/qualified b/structs/qualified new file mode 100644 index 0000000..e69de29 diff --git a/structs/test.icl b/structs/test.icl index 8585bd0..a0cd464 100644 --- a/structs/test.icl +++ b/structs/test.icl @@ -1,6 +1,7 @@ module test import GenC +import Text :: List a = Nil | Cons a (List a) :: NInt =: NInt Int @@ -11,9 +12,12 @@ import GenC derive gToStruct NInt, T, List, R, Muta, Mutb, (,), (), [], (,,) derive gPotInf NInt, T, List, R, Muta, Mutb, (,), (), [], (,,) -Start = (toCFiles t) + +Start = let (l, r) = (toCParser (unBox t2)) in concat r where t :: Box String (List (Muta Int)) // t :: Box GTSState NInt t = Box "listmutaint" + t2 :: Box GTSState (Bool, Int) + t2 = toStruct diff --git a/test.icl b/test.icl index dddfbe1..6df4935 100644 --- a/test.icl +++ b/test.icl @@ -1,20 +1,5 @@ module test +class C m :: u:m -> v:m -import StdEnv - -import graph_copy_with_names, symbols_in_program -import System.CommandLine - -test :: !{#Symbol} a -> a -test symbols a - # (a, b, c) = copy_to_string_with_names a - # (a, r) = copy_from_string_with_names a b c symbols - = a - -polyid :: (A.a: a -> a) -> (Int, Bool) -polyid f = (f 42, f True) - -Start w - # ([argv0:_], w) = getCommandLine w - # (symbols, w) = accFiles (read_symbols argv0) w - = test symbols (polyid id) +//Start :: *World -> *(State () *World) +Start = 42 -- 2.20.1