commit f86fa28d6caff89f884b300fd39ab74021e53408
parent 11d7a8d25ed4c2e12723ebb141a74a4e64e1c823
Author: Jared Tobin <jared@jtobin.ca>
Date: Wed, 15 Jul 2015 20:07:49 -0400
Add stringreplace, orderedwords.
Diffstat:
3 files changed, 351 insertions(+), 2 deletions(-)
diff --git a/20150522_stringreplace/Main.hs b/20150522_stringreplace/Main.hs
@@ -1,10 +1,31 @@
-module Replace where
+module Main where
-stringReplace :: String -> String -> String -> String
+import System.Environment
+
+data Replace a = Replace {
+ pattern :: [a]
+ , replacement :: [a]
+ }
+
+stringReplace :: Eq a => [a] -> [a] -> [a] -> [a]
stringReplace pat rep = foldr alg [] where
patLength = length pat
alg c acc
| take patLength (c:acc) == pat = rep ++ drop patLength (c:acc)
| otherwise = c : acc
+replace :: Eq a => Replace a -> [a] -> [a]
+replace (Replace pat rep) = foldr alg [] where
+ patLength = length pat
+ alg c acc
+ | take patLength (c:acc) == pat = rep ++ drop patLength (c:acc)
+ | otherwise = c : acc
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case args of
+ (pat:rep:str:_) -> putStrLn (stringReplace pat rep str)
+ _ -> putStrLn "USAGE: ./stringReplace PATTERN REPLACEMENT STRING"
+
diff --git a/20150522_stringreplace/core.tmp b/20150522_stringreplace/core.tmp
@@ -0,0 +1,314 @@
+[1 of 1] Compiling Main ( Main.hs, Main.o )
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 394, types: 238, coercions: 9}
+
+main_$sstringReplace :: [Char] -> [Char] -> [Char] -> [Char]
+[GblId, Arity=2, Caf=NoCafRefs, Str=DmdType <L,U><L,U>]
+main_$sstringReplace =
+ \ (pat :: [Char]) (rep :: [Char]) ->
+ let {
+ lvl :: Bool
+ [LclId, Str=DmdType]
+ lvl = $fEq[]_$s$c== ([] @ Char) pat } in
+ let {
+ patLength [Dmd=<L,U(U)>] :: Int
+ [LclId, Str=DmdType]
+ patLength =
+ case $wlenAcc @ Char pat 0 of ww { __DEFAULT -> I# ww } } in
+ \ (eta :: [Char]) ->
+ case eta of _ [Occ=Dead] {
+ [] -> [] @ Char;
+ : y ys ->
+ case patLength of _ [Occ=Dead] { I# n# ->
+ let {
+ acc :: [Char]
+ [LclId, Str=DmdType]
+ acc =
+ letrec {
+ go [Occ=LoopBreaker] :: [Char] -> [Char]
+ [LclId, Arity=1, Str=DmdType <S,1*U>]
+ go =
+ \ (ds :: [Char]) ->
+ case ds of _ [Occ=Dead] {
+ [] -> [] @ Char;
+ : y1 ys1 ->
+ let {
+ acc1 :: [Char]
+ [LclId, Str=DmdType]
+ acc1 = go ys1 } in
+ let {
+ $j :: Void# -> [Char]
+ [LclId, Arity=1, Str=DmdType <L,A>]
+ $j =
+ \ _ [Occ=Dead] ->
+ ++
+ @ Char
+ rep
+ (case tagToEnum# @ Bool (<# n# 0) of _ [Occ=Dead] {
+ False -> drop_drop# @ Char n# (: @ Char y1 acc1);
+ True -> : @ Char y1 acc1
+ }) } in
+ case tagToEnum# @ Bool (<=# n# 0) of _ [Occ=Dead] {
+ False ->
+ case tagToEnum# @ Bool (>=# n# 0) of _ [Occ=Dead] {
+ False ->
+ case lvl of _ [Occ=Dead] {
+ False -> : @ Char y1 acc1;
+ True -> $j void#
+ };
+ True ->
+ case $fEq[]_$s$c==
+ (take_unsafe_UInt @ Char n# (: @ Char y1 acc1)) pat
+ of _ [Occ=Dead] {
+ False -> : @ Char y1 acc1;
+ True -> $j void#
+ }
+ };
+ True ->
+ case lvl of _ [Occ=Dead] {
+ False -> : @ Char y1 acc1;
+ True -> $j void#
+ }
+ }
+ }; } in
+ go ys } in
+ let {
+ $j :: Void# -> [Char]
+ [LclId, Arity=1, Str=DmdType <L,A>]
+ $j =
+ \ _ [Occ=Dead] ->
+ ++
+ @ Char
+ rep
+ (case tagToEnum# @ Bool (<# n# 0) of _ [Occ=Dead] {
+ False -> drop_drop# @ Char n# (: @ Char y acc);
+ True -> : @ Char y acc
+ }) } in
+ case tagToEnum# @ Bool (<=# n# 0) of _ [Occ=Dead] {
+ False ->
+ case tagToEnum# @ Bool (>=# n# 0) of _ [Occ=Dead] {
+ False ->
+ case lvl of _ [Occ=Dead] {
+ False -> : @ Char y acc;
+ True -> $j void#
+ };
+ True ->
+ case $fEq[]_$s$c==
+ (take_unsafe_UInt @ Char n# (: @ Char y acc)) pat
+ of _ [Occ=Dead] {
+ False -> : @ Char y acc;
+ True -> $j void#
+ }
+ };
+ True ->
+ case lvl of _ [Occ=Dead] {
+ False -> : @ Char y acc;
+ True -> $j void#
+ }
+ }
+ }
+ }
+
+stringReplace :: forall a. Eq a => [a] -> [a] -> [a] -> [a]
+[GblId,
+ Arity=3,
+ Caf=NoCafRefs,
+ Str=DmdType <L,U(C(C1(U)),A)><L,U><L,U>]
+stringReplace =
+ \ (@ a) ($dEq :: Eq a) (pat :: [a]) (rep :: [a]) ->
+ let {
+ lvl :: Bool
+ [LclId, Str=DmdType]
+ lvl = $fEq[]_$c== @ a $dEq ([] @ a) pat } in
+ let {
+ patLength [Dmd=<L,U(U)>] :: Int
+ [LclId, Str=DmdType]
+ patLength =
+ case $wlenAcc @ a pat 0 of ww { __DEFAULT -> I# ww } } in
+ \ (eta :: [a]) ->
+ case eta of _ [Occ=Dead] {
+ [] -> [] @ a;
+ : y ys ->
+ case patLength of _ [Occ=Dead] { I# n# ->
+ let {
+ acc :: [a]
+ [LclId, Str=DmdType]
+ acc =
+ letrec {
+ go [Occ=LoopBreaker] :: [a] -> [a]
+ [LclId, Arity=1, Str=DmdType <S,1*U>]
+ go =
+ \ (ds :: [a]) ->
+ case ds of _ [Occ=Dead] {
+ [] -> [] @ a;
+ : y1 ys1 ->
+ let {
+ acc1 :: [a]
+ [LclId, Str=DmdType]
+ acc1 = go ys1 } in
+ let {
+ $j :: Void# -> [a]
+ [LclId, Arity=1, Str=DmdType <L,A>]
+ $j =
+ \ _ [Occ=Dead] ->
+ ++
+ @ a
+ rep
+ (case tagToEnum# @ Bool (<# n# 0) of _ [Occ=Dead] {
+ False -> drop_drop# @ a n# (: @ a y1 acc1);
+ True -> : @ a y1 acc1
+ }) } in
+ case tagToEnum# @ Bool (<=# n# 0) of _ [Occ=Dead] {
+ False ->
+ case tagToEnum# @ Bool (>=# n# 0) of _ [Occ=Dead] {
+ False ->
+ case lvl of _ [Occ=Dead] {
+ False -> : @ a y1 acc1;
+ True -> $j void#
+ };
+ True ->
+ case $fEq[]_$c==
+ @ a $dEq (take_unsafe_UInt @ a n# (: @ a y1 acc1)) pat
+ of _ [Occ=Dead] {
+ False -> : @ a y1 acc1;
+ True -> $j void#
+ }
+ };
+ True ->
+ case lvl of _ [Occ=Dead] {
+ False -> : @ a y1 acc1;
+ True -> $j void#
+ }
+ }
+ }; } in
+ go ys } in
+ let {
+ $j :: Void# -> [a]
+ [LclId, Arity=1, Str=DmdType <L,A>]
+ $j =
+ \ _ [Occ=Dead] ->
+ ++
+ @ a
+ rep
+ (case tagToEnum# @ Bool (<# n# 0) of _ [Occ=Dead] {
+ False -> drop_drop# @ a n# (: @ a y acc);
+ True -> : @ a y acc
+ }) } in
+ case tagToEnum# @ Bool (<=# n# 0) of _ [Occ=Dead] {
+ False ->
+ case tagToEnum# @ Bool (>=# n# 0) of _ [Occ=Dead] {
+ False ->
+ case lvl of _ [Occ=Dead] {
+ False -> : @ a y acc;
+ True -> $j void#
+ };
+ True ->
+ case $fEq[]_$c==
+ @ a $dEq (take_unsafe_UInt @ a n# (: @ a y acc)) pat
+ of _ [Occ=Dead] {
+ False -> : @ a y acc;
+ True -> $j void#
+ }
+ };
+ True ->
+ case lvl of _ [Occ=Dead] {
+ False -> : @ a y acc;
+ True -> $j void#
+ }
+ }
+ }
+ }
+
+main2 :: [Char]
+[GblId,
+ Str=DmdType,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=False,
+ ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 160 0}]
+main2 =
+ unpackCString# "USAGE: ./stringReplace PATTERN REPLACEMENT STRING"#
+
+$wa :: State# RealWorld -> (# State# RealWorld, () #)
+[GblId,
+ Arity=1,
+ Str=DmdType <L,U>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
+ ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [0] 40 0}]
+$wa = \ (w :: State# RealWorld) -> hPutStr2 stdout main2 True w
+
+main1 :: State# RealWorld -> (# State# RealWorld, () #)
+[GblId,
+ Arity=1,
+ Str=DmdType <L,U>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
+ ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [0] 190 0}]
+main1 =
+ \ (eta :: State# RealWorld) ->
+ case getArgs1 eta of _ [Occ=Dead] { (# ipv, ipv1 #) ->
+ case ipv1 of _ [Occ=Dead] {
+ [] -> $wa ipv;
+ : pat ds ->
+ case ds of _ [Occ=Dead] {
+ [] -> $wa ipv;
+ : rep ds2 ->
+ case ds2 of _ [Occ=Dead] {
+ [] -> $wa ipv;
+ : str ds3 ->
+ hPutStr2 stdout (main_$sstringReplace pat rep str) True ipv
+ }
+ }
+ }
+ }
+
+main :: IO ()
+[GblId,
+ Arity=1,
+ Str=DmdType <L,U>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
+ ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
+main =
+ main1
+ `cast` (Sym (NTCo:IO[0] <()>_R)
+ :: (State# RealWorld -> (# State# RealWorld, () #)) ~# IO ())
+
+main3 :: State# RealWorld -> (# State# RealWorld, () #)
+[GblId,
+ Arity=1,
+ Str=DmdType <L,U>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=1, Value=True,
+ ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
+main3 =
+ \ (eta :: State# RealWorld) ->
+ runMainIO1
+ @ ()
+ (main1
+ `cast` (Sym (NTCo:IO[0] <()>_R)
+ :: (State# RealWorld -> (# State# RealWorld, () #)) ~# IO ()))
+ eta
+
+main :: IO ()
+[GblId,
+ Arity=1,
+ Str=DmdType <L,U>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Arity=0, Value=True,
+ ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(unsat_ok=True,boring_ok=True)}]
+main =
+ main3
+ `cast` (Sym (NTCo:IO[0] <()>_R)
+ :: (State# RealWorld -> (# State# RealWorld, () #)) ~# IO ())
+
+
+------ Local rules for imported ids --------
+"SPEC stringReplace [Char]" [ALWAYS]
+ forall ($dEq :: Eq Char).
+ stringReplace @ Char $dEq
+ = main_$sstringReplace
+
+
+Linking stringReplace ...
diff --git a/20150714_orderedwords/Ordered.hs b/20150714_orderedwords/Ordered.hs
@@ -0,0 +1,14 @@
+
+module Ordered where
+
+import Data.Function (on)
+import Data.List (sort, maximumBy)
+
+longestOrdered :: Ord a => [[a]] -> Maybe [a]
+longestOrdered dict = safeMaximumBy (compare `on` length)
+ [word | word <- dict, sort word == word]
+
+safeMaximumBy :: (a -> a -> Ordering) -> [a] -> Maybe a
+safeMaximumBy _ [] = Nothing
+safeMaximumBy p xs = Just (maximumBy p xs)
+
