Super toy implementation of regular expression derivatives

rederiv.hs

data Lang = DEmpty | DEps | DChar String | DCat Lang Lang | DAlt Lang Lang | DRep Lang

stringOfLang l = case l of
    DEmpty -> "DEmpty"
    DEps -> "DEps"
    DChar x -> "DChar (" ++ x ++ ")"
    DCat lx ly -> "DCat (" ++ (stringOfLang lx) ++ ", " ++ (stringOfLang ly) ++ ")"
    DAlt lx ly -> "DAlt (" ++ (stringOfLang lx) ++ ", " ++ (stringOfLang ly) ++ ")"
    DRep lx -> "DRep (" ++ (stringOfLang lx) ++ ")"

langEqual l1 l2 = case l1 of
    DEmpty -> (case l2 of
        DEmpty -> True
        _ -> False)
    DEps -> (case l2 of
        DEps -> True
        _ -> False)
    DChar x -> (case l2 of
        DChar y -> x == y
        _ -> False)
    DCat lw lx -> (case l2 of
        DCat ly lz -> (langEqual lw ly) && (langEqual lx lz)
        _ -> False)
    DAlt lw lx -> (case l2 of
        DAlt ly lz -> (langEqual lw ly) && (langEqual lx lz)
        _ -> False)
    DRep lx -> (case l2 of
        DRep ly -> (langEqual lx ly)
        _ -> False)

nullable l = case l of
    DEmpty -> DEmpty
    DEps -> DEps
    DChar _ -> DEmpty
    DCat lx ly -> DCat (nullable lx) (nullable ly)
    DAlt lx ly -> DAlt (nullable lx) (nullable ly)
    DRep _ -> DEps

derivative c l = case l of
    DEmpty -> DEmpty
    DEps -> DEmpty
    DChar x -> if x == c then DEps else DEmpty
    DCat lx ly -> DAlt (DCat (derivative c lx) ly) (DCat (nullable lx) (derivative c ly))
    DAlt lx ly -> DAlt (derivative c lx) (derivative c ly)
    DRep lx -> DCat (derivative c lx) (DRep lx)

reduce l = case l of
    DEmpty -> DEmpty
    DEps -> DEps
    DChar x -> DChar x
    DCat _ DEmpty -> DEmpty
    DCat DEmpty _ -> DEmpty
    DAlt lx DEmpty -> (reduce lx)
    DAlt DEmpty ly -> (reduce ly)
    DCat lx DEps -> (reduce lx)
    DCat DEps ly -> (reduce ly)
    DAlt DEps DEps -> DEps
    DCat lx ly -> DCat (reduce lx) (reduce ly)
    DAlt lx ly -> DAlt (reduce lx) (reduce ly)
    DRep lx -> DRep (reduce lx)

fullyReduce l =
    let l' = reduce l in if langEqual l l' then l else fullyReduce l'

accepts str l =
    let reduced = fullyReduce l in
    if str == "" then fullyReduce (nullable reduced) else accepts (tail str) (derivative [(head str)] reduced)

printAccepts str l = putStrLn (stringOfLang (accepts str l))

testLang = DRep (DChar "x") -- { "", "x", "xx", "xxx", ... }
testLang2 = DCat (DChar "f") (DCat (DChar "o") (DChar "o")) -- { "foo" }


main = do
    printAccepts "" testLang -- Expected: DEps
    printAccepts "" testLang2 -- Expected: DEmpty

    printAccepts "x" testLang -- Expected: DEps
    printAccepts "x" testLang2 -- Expected: DEmpty

    printAccepts "foo" testLang -- Expected: DEmpty
    printAccepts "foo" testLang2 -- Expected: DEps

    printAccepts [ 'x' | _ <- [1..100000]] testLang -- Expected: DEps
    printAccepts [ 'x' | _ <- [1..100000]] testLang2 -- Expected: DEmpty