--- /dev/null
+implementation module GenPrint\r
+\r
+import StdGeneric, StdEnv, StdMaybe\r
+\r
+//-------------------------------------------------------------------------------------\r
+\r
+:: *StringOutput = {so_str :: !*String, so_pos :: !Int}\r
+\r
+\r
+instance PrintOutput StringOutput where\r
+ printOutput ch s=:{so_str, so_pos} \r
+ #! new_str = realloc_if_needed so_pos so_str \r
+ = {s & so_str = {new_str & [so_pos] = ch}, so_pos = inc so_pos}\r
+ where\r
+ realloc_if_needed :: Int u:String -> v:String, [u <= v]\r
+ realloc_if_needed pos str\r
+ #! size_str = size str\r
+ | pos == size_str\r
+ #! new_str = createArray ((size_str + 1) * 3 /2) '\0'\r
+ #! (new_str, str) = fill 0 size_str new_str str\r
+ = new_str\r
+ | otherwise \r
+ = str \r
+ fill i n new_str str \r
+ | i == n\r
+ = (new_str, str)\r
+ | otherwise \r
+ #! (ch, str) = str![i] \r
+ = fill (inc i) n {new_str & [i] = ch} str \r
+ \r
+instance PrintOutput File where\r
+ printOutput x s\r
+ = fwritec x s\r
+\r
+\r
+//-------------------------------------------------------------------------------------\r
+\r
+\r
+($) infixl 9\r
+($) x y = y o x\r
+\r
+(@) infix 8 \r
+(@) x y = x y\r
+\r
+mapSt f [] st = ([], st)\r
+mapSt f [x:xs] st\r
+ # (y, st) = f x st\r
+ # (ys, st) = mapSt f xs st\r
+ = ([y:ys], st)\r
+\r
+foldSt f [] = id \r
+foldSt f [x:xs] = foldSt f xs o f x\r
+\r
+//-------------------------------------------------------------------------------------\r
+:: PrintState s =\r
+ { ps_output :: !s\r
+ , ps_context :: !Context\r
+ }\r
+:: Context \r
+ = CtxNone // initial env\r
+ | CtxNullary // nullary constructor\r
+ | CtxRecord // record constructor \r
+ | CtxTuple // tuple constructor\r
+ | CtxNonfix // normal nonfix constructor\r
+ | CtxInfix // infix constructor\r
+ String // name\r
+ GenConsAssoc // constructor's associativity \r
+ Prio // constructors priority \r
+ GenConsAssoc // left or right argument\r
+:: Prio :== Int\r
+ \r
+instance == GenConsAssoc where\r
+ (==) GenConsAssocNone GenConsAssocNone = True\r
+ (==) GenConsAssocLeft GenConsAssocLeft = True\r
+ (==) GenConsAssocRight GenConsAssocRight = True\r
+ (==) _ _ = False\r
+\r
+mkContext :: GenericConsDescriptor -> Context\r
+mkContext {gcd_prio=GenConsNoPrio, gcd_fields, gcd_name, gcd_arity}\r
+ | isEmpty gcd_fields \r
+ | gcd_arity == 0\r
+ = CtxNullary\r
+ | is_tuple gcd_name\r
+ = CtxTuple\r
+ | otherwise\r
+ = CtxNonfix\r
+ | otherwise \r
+ = CtxRecord \r
+where\r
+ is_tuple name \r
+ #! size_name = size name\r
+ = (size_name == 7 || size_name == 8)\r
+ && name.[0] == '_'\r
+ && name.[1] == 'T'\r
+ && name.[2] == 'u'\r
+ && name.[3] == 'p'\r
+ && name.[4] == 'l'\r
+ && name.[5] == 'e'\r
+ && isDigit name.[6]\r
+ && (size_name == 7 || isDigit name.[7])\r
+ \r
+mkContext {gcd_prio=GenConsPrio assoc prio, gcd_name} \r
+ = CtxInfix gcd_name assoc prio GenConsAssocNone\r
+\r
+needParenthesis :: Context Context -> Bool\r
+needParenthesis CtxNone outer_ctx = abort "needParenthesis: this_ctx = CtxNone"\r
+needParenthesis this_ctx CtxNullary = abort "needParenthesis: outer_ctx = CtxNullary"\r
+needParenthesis CtxNullary outer_ctx = False\r
+needParenthesis CtxTuple outer_ctx = True // the tuple parenthesis\r
+needParenthesis CtxRecord outer_ctx = False\r
+needParenthesis CtxNonfix CtxNone = False\r
+needParenthesis CtxNonfix CtxTuple = False\r
+needParenthesis CtxNonfix CtxRecord = False\r
+needParenthesis CtxNonfix CtxNonfix = True\r
+needParenthesis CtxNonfix (CtxInfix _ _ _ _) = False\r
+needParenthesis (CtxInfix _ _ _ _) CtxNone = False\r
+needParenthesis (CtxInfix _ _ _ _) CtxNullary = True\r
+needParenthesis (CtxInfix _ _ _ _) CtxTuple = False\r
+needParenthesis (CtxInfix _ _ _ _) CtxRecord = False\r
+needParenthesis (CtxInfix _ _ _ _) CtxNonfix = True // False // PK\r
+needParenthesis (CtxInfix _ this_assoc this_prio _) (CtxInfix _ outer_assoc outer_prio branch) \r
+ = outer_prio > this_prio \r
+ || (outer_prio == this_prio && not (this_assoc == outer_assoc && this_assoc == branch))\r
+\r
+//derive bimap PrintState\r
+\r
+//-------------------------------------------------------------------------------------\r
+\r
+\r
+printChar :: Char (PrintState *s) -> (PrintState *s) | PrintOutput s \r
+printChar ch s=:{ps_output}\r
+ # ps_output = printOutput ch ps_output\r
+ = {s & ps_output = ps_output}\r
+\r
+printCharLiteral '\\' = printChar '\\' $ printChar '\\'\r
+printCharLiteral '\n' = printChar '\\' $ printChar '\n'\r
+printCharLiteral '\t' = printChar '\\' $ printChar '\t'\r
+printCharLiteral '\b' = printChar '\\' $ printChar '\b'\r
+printCharLiteral '\'' = printChar '\\' $ printChar '\''\r
+printCharLiteral '\"' = printChar '\\' $ printChar '\"'\r
+printCharLiteral '\0' = printChar '\\' $ printChar '\0'\r
+printCharLiteral c = printChar c\r
+\r
+printString str\r
+ #! size_str = size str\r
+ = do_it 0 size_str str\r
+where\r
+ do_it i n str\r
+ | i == n\r
+ = id\r
+ = printChar str.[i]\r
+ $ do_it (inc i) n str \r
+\r
+printStringLiteral str\r
+ #! size_str = size str\r
+ = do_it 0 size_str str\r
+where\r
+ do_it i n str\r
+ | i == n\r
+ = id\r
+ = printCharLiteral str.[i]\r
+ $ do_it (inc i) n str \r
+\r
+\r
+printList f xs ps=:{ps_context}\r
+ = { print_list f xs { ps & ps_context = CtxNone} \r
+ & ps_context = ps_context \r
+ }\r
+where\r
+ print_list f [] = id\r
+ print_list f [x] = f x\r
+ print_list f [x:xs] \r
+ = f x \r
+ $ printString ", "\r
+ $ print_list f xs \r
+\r
+//-------------------------------------------------------------------------------------\r
+generic gPrint a :: a (PrintState *s) -> (PrintState *s) | PrintOutput s\r
+gPrint{|Int|} x st \r
+ = printString (toString x) st\r
+gPrint{|Real|} x st \r
+ # str = toString x\r
+ | all isDigit [c\\c<-:str] // add .0 if needed\r
+ = printString (str +++ ".0") st \r
+ | str.[0] == '.'\r
+ = printString ("0" +++ str) st\r
+ | otherwise \r
+ = printString str st\r
+gPrint{|Bool|} x st \r
+ = printString (toString x) st\r
+gPrint{|Char|} x st \r
+ = printChar '\'' $ printCharLiteral x $ printChar '\'' @ st \r
+gPrint{|String|} x st \r
+ = printChar '"'\r
+ $ printStringLiteral x \r
+ $ printChar '"'\r
+ @ st\r
+gPrint{|UNIT|} x st \r
+ = st\r
+ \r
+gPrint{|EITHER|} fl fr (LEFT x) st = fl x st\r
+gPrint{|EITHER|} fl fr (RIGHT x) st = fr x st\r
+\r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxNone}\r
+ = abort "gOutput{|PAIR|}: CtxNone\n" \r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxNullary}\r
+ = abort "gOutput{|PAIR|}: CtxNullary\n" \r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxTuple}\r
+ = fx x $ printString ", " $ fy y @ st\r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxRecord}\r
+ = fx x $ printString ", " $ fy y @ st\r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxNonfix}\r
+ = fx x $ printChar ' ' $ fy y @ st \r
+gPrint{|PAIR|} fx fy (PAIR x y) st=:{ps_context = CtxInfix name assoc prio branch} \r
+ # st = fx x {st & ps_context = CtxInfix name assoc prio GenConsAssocLeft} \r
+ # st = printChar ' ' $ printStringLiteral name $ printChar ' ' @ st\r
+ # st = fy y {st & ps_context = CtxInfix name assoc prio GenConsAssocRight} \r
+ = {st & ps_context = CtxInfix name assoc prio branch} \r
+\r
+gPrint{|CONS of d|} print_arg (CONS x) st=:{ps_context}\r
+ #! ctx = mkContext d\r
+ #! st = { st & ps_context = ctx }\r
+ | needParenthesis ctx ps_context\r
+ = { printChar '(' \r
+ $ print print_arg ctx \r
+ $ printChar ')' \r
+ @ st \r
+ & ps_context = ps_context \r
+ }\r
+ | otherwise\r
+ = { print print_arg ctx st & ps_context = ps_context }\r
+where\r
+ print print_arg CtxNone \r
+ = abort "gOutput{|CONS|}: CtxNone\n"\r
+ print print_arg CtxNullary \r
+ = printStringLiteral d.gcd_name \r
+ print print_arg CtxTuple\r
+ = print_arg x\r
+ print print_arg CtxRecord \r
+ = printString "{ " \r
+ $ foldSt printChar (tl [c\\c<-:d.gcd_name]) //printStringLiteral d.gcd_name \r
+ $ printString " | "\r
+ $ print_arg x\r
+ $ printString " }"\r
+ print print_arg CtxNonfix \r
+ = printStringLiteral d.gcd_name\r
+ $ printChar ' '\r
+ $ print_arg x \r
+ print print_arg (CtxInfix _ _ _ _) \r
+ = print_arg x\r
+\r
+gPrint{|FIELD of d|} f (FIELD x) st\r
+ = printStringLiteral d.gfd_name\r
+ $ printString " = " \r
+ $ f x \r
+ @ st\r
+gPrint{|OBJECT|} f (OBJECT x) st\r
+ = f x st \r
+ \r
+gPrint{|[]|} f xs st\r
+ = printChar '['\r
+ $ printList f xs \r
+ $ printChar ']'\r
+ @ st\r
+\r
+gPrint{|{}|} f xs st\r
+ = printChar '{'\r
+ $ printList f [ x \\ x <-: xs] \r
+ $ printChar '}'\r
+ @ st\r
+\r
+gPrint{|{!}|} f xs st\r
+ = printChar '{'\r
+ $ printList f [ x \\ x <-: xs] \r
+ $ printChar '}'\r
+ @ st\r
+\r
+//derive gOutput (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)\r
+ \r
+//-------------------------------------------------------------------------------------\r
+(<<-) infixl 0 :: (PrintState *s) a -> *(PrintState *s) | gPrint{|*|} a & PrintOutput s\r
+(<<-) s x = gPrint{|*|} x s\r
+\r
+mkPrintState :: *s -> PrintState *s | PrintOutput s\r
+mkPrintState s =\r
+ { ps_output = s\r
+ , ps_context = CtxNone\r
+ } \r
+\r
+mkStringPrintState :: PrintState StringOutput\r
+mkStringPrintState = mkPrintState {so_pos = 0, so_str = createArray 16 '\0'}\r
+\r
+openFilePrintState :: String *fs -> (Maybe (PrintState *File), *fs) | FileSystem fs\r
+openFilePrintState name fs \r
+ # (ok, file, fs) = fopen name FWriteText fs\r
+ | ok = (Just (mkPrintState file), fs)\r
+ = (Nothing, fs)\r
+\r
+printToString :: a -> String | gPrint{|*|} a\r
+printToString x\r
+ # string_output = (mkStringPrintState <<- x).ps_output\r
+ = string_output.so_str % (0,string_output.so_pos-1)\r
+\r
+//-------------------------------------------------------------------------------------\r
+\r
+//Start = 1
\ No newline at end of file
repositories / tt2015.git / blobdiff