resolver.hs

import Data.List
import Data.Char
import Data.Maybe

data Ty = Cons String [Ty] | Var String deriving (Eq)

data Args a = Args { noArgs :: Maybe a, arg :: Trie (Args a) } deriving (Eq, Show)
data Trie a = Trie { var :: Maybe a, cons :: [(String, Args a)] } deriving (Eq, Show)

emptyTrie :: Trie a
emptyTrie = Trie Nothing []

emptyArgs :: Args a
emptyArgs = Args Nothing emptyTrie

getTrie :: Ty -> Trie a -> [a]
getTrie (Var s) (Trie v cs) = maybe [] pure v -- TODO: Map String Ty with type assignments
getTrie (Cons s xs) (Trie v cs) = maybe [] (getArgs xs) (lookup s cs) ++ maybe [] pure v

getArgs :: [Ty] -> Args a -> [a]
getArgs []     (Args Nothing t) = []
getArgs []     (Args (Just a) t) = [a]
getArgs (x:xs) (Args _ t) = concatMap (getArgs xs) (getTrie x t)

updateTrie :: Ty -> (Maybe a -> Maybe a) -> Trie a -> Trie a
updateTrie (Var s)     f (Trie v cs) = Trie (f v) cs
updateTrie (Cons s xs) f (Trie v cs) = Trie v $ updateMap s update cs where
  update m = updateArgs xs f $ fromMaybe emptyArgs m

updateArgs :: [Ty] -> (Maybe a -> Maybe a) -> Args a -> Args a
updateArgs []     f (Args n t) = Args (f n) t
updateArgs (x:xs) f (Args n t) = Args n $ updateTrie x update t where
  update = Just . updateArgs xs f . fromMaybe emptyArgs

setTrie :: Ty -> a -> Trie a -> Trie a
setTrie t v = updateTrie t (const $ Just v)

updateMap :: Eq a => a -> (Maybe b -> b) -> [(a, b)] -> [(a, b)]
updateMap k f m = (k, f (lookup k m)) : filter (\(l, v) -> l /= k) m

fromListTrie :: [String] -> Trie Int
fromListTrie = foldl add emptyTrie . flip zip [0..] where
  add m (k, v) = setTrie (read k) v m
findTrie :: String -> Trie a -> [a]
findTrie k = getTrie $ read k
runTest :: String -> [String] -> IO ()
runTest s xs = do
  putStrLn $ "Needle:   " ++ s
  putStrLn $ ("Haystack: " ++) $ intercalate ", " xs
  putStrLn $ ("Matches:  " ++ ) $ intercalate ", " $ map (xs !!) $ findTrie s $ fromListTrie xs
  putStrLn ""

main = do
  -- print $ fromListTrie ["Either<Int, Int>"]
  runTest "Maybe<Int>" ["u", "Maybe<t>", "Maybe<Int>"]
  runTest "Maybe<String>" ["u", "Maybe<t>", "Maybe<Int>"]
  runTest "Maybe<Int>" ["u", "Maybe<t>"]
  runTest "String" ["u", "Maybe<t>"]
  runTest "Either<Int, Int>" ["Either<t, u>", "Either<Cell, Cell>"]
  runTest "Either<Int, Int>" ["Either<t, u>", "Either<Int, v>"]
  runTest "Either<Int, Int>" ["Either<t, Int>", "Either<Int, v>"] -- FIXME: must be an error
  runTest "Either<Int, String>" ["Either<t, t>"] -- FIXME: must be an error
  
instance Show Ty where
  show (Cons s xs) = concat [s, "<", intercalate ", " $ map show xs, ">"]
  show (Var s) = s
instance Read Ty where
  readsPrec _ = readsTy
readsTy :: ReadS Ty
readsTy s = case parseTy (dropWhile isSpace s) of
  Just res -> [res]
  Nothing  -> []
parseTy :: String -> Maybe (Ty, String)
parseTy [] = Nothing
parseTy s@(c:_)
  | isAlpha c = parseConsOrVar s
  | otherwise = Nothing
parseConsOrVar :: String -> Maybe (Ty, String)
parseConsOrVar s =
  let (name, rest) = span isAlpha s
      rest' = dropWhile isSpace rest
  in case rest' of
       ('<':r) | isUpper (head name) -> parseArgs r [] name
       _ | isUpper (head name)       -> Just (Cons name [], rest)
         | otherwise                 -> Just (Var name, rest)
parseArgs :: String -> [Ty] -> String -> Maybe (Ty, String)
parseArgs s acc name =
  let s' = dropWhile isSpace s in
  case s' of
    ('>':r) -> Just (Cons name (reverse acc), r)
    _       -> do
      (ty, rest) <- parseTy s'
      let rest' = dropWhile isSpace rest
      case rest' of
        (',':r) -> parseArgs r (ty:acc) name
        ('>':r) -> Just (Cons name (reverse (ty:acc)), r)
        _       -> Nothing