+++ /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