content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE BangPatterns #-}
  
  module Notes where
  
  import Data.Either
  import Data.Foldable
  import qualified Data.ByteString as BS
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import qualified Data.Map.Strict as M
  import qualified Data.Set as S
  import System.Directory (doesFileExist)
  import Data.Array
  import Data.List (sortBy)
  import Data.Ord
  
  data SrcLoc = SrcLoc { fileName :: FilePath
                       , row :: !Int
                       , column :: !Int
                       }
    deriving (Eq, Ord, Show)
  
  showSrcLoc :: SrcLoc -> String
  showSrcLoc loc =
      concat [fileName loc, ":", show (row loc), ":", show (column loc), ":"]
  
  newtype NoteName = NoteName T.Text
    deriving (Eq, Ord, Show)
  
  showNoteName :: NoteName -> String
  showNoteName (NoteName x) = "Note [" <> T.unpack x <> "]"
  
  data NoteDef = NoteDef { noteDefSrcLoc :: !SrcLoc
                         , noteDefName   :: !NoteName
                         }
    deriving (Eq, Ord, Show)
  
  showNoteDef :: NoteDef -> String
  showNoteDef (NoteDef{noteDefSrcLoc=loc, noteDefName=name}) =
      "def    " <> showSrcLoc loc <> "     " <> showNoteName name
  
  data NoteRef = NoteRef { noteRefSrcLoc :: !SrcLoc
                         , noteRefName   :: !NoteName
                         }
    deriving (Eq, Ord, Show)
  
  showNoteRef :: NoteRef -> String
  showNoteRef (NoteRef{noteRefSrcLoc=loc, noteRefName=name}) =
      "ref    " <> showSrcLoc loc <> "     " <> showNoteName name
  
  findNotes :: FilePath -> T.Text -> [Either NoteRef NoteDef]
  findNotes fname t =
      go 1 (T.lines t)
    where
      go :: Int -> [T.Text] -> [Either NoteRef NoteDef]
      -- Note definitions:
      -- We look for a "Note [" token with a "~~~" rule beneath it.
      go !lineNo (l0 : l1 : ls)
        | hasRule = Right (NoteDef srcLoc name) : go (lineNo+2) ls
        where
          (prefix, rest) = T.breakOn "Note [" l0
          startCol = T.length prefix
          hasRule = T.take 3 (T.drop startCol l1) == "~~~"
          srcLoc = SrcLoc fname lineNo startCol
          name = NoteName $ T.takeWhile (/= ']') $ T.drop 6 rest
  
      -- Note references:
      -- We look for a "Note [...]", strip away any beginning-of-line
      -- comment symbols, and merge whitespace.
      go lineNo (l0 : ls) =
          [ Left (NoteRef srcLoc (NoteName name))
          | (prefix, rest) <- T.breakOnAll "Note [" l0
          , let startCol = T.length prefix
                srcLoc = SrcLoc fname lineNo startCol
                (name, suffix) = T.breakOn "]" (T.drop 6 rest<>" "<>T.concat (map stripBeginningOfLineComment $ take 1 ls))
          , "]" `T.isPrefixOf` suffix
          ] ++ go (lineNo+1) ls
  
      go _lineNo [] = []
  
  stripBeginningOfLineComment :: T.Text -> T.Text
  stripBeginningOfLineComment = T.pack . go . T.unpack
    where
      -- This implements the following regular expression substitution:
      --
      --    s/$ *[(\-\- )\#( \* )] */ /
  
      go :: String -> String
      go ('#':rest)     = finish rest
      go ('-':'-':rest) = finish rest
      go (' ':'*':rest) = finish rest
      go ('/':'/':rest) = finish rest
      go (' ':rest)     = go rest
      go xs             = finish xs
  
      finish :: String -> String
      finish = dropWhile (==' ')
  
  data NoteDb = NoteDb { noteRefs :: M.Map FilePath (S.Set NoteRef)
                       , noteDefs :: M.Map NoteName (S.Set NoteDef)
                       }
  
  instance Monoid NoteDb where
      mempty = NoteDb M.empty M.empty
  
  instance Semigroup NoteDb where
      NoteDb a b <> NoteDb c d =
          NoteDb (M.unionWith (<>) a c) (M.unionWith (<>) b d)
  
  allNoteDefs :: NoteDb -> [NoteDef]
  allNoteDefs db =
      [ def
      | defs <- M.elems (noteDefs db)
      , def <- S.toList defs
      ]
  
  allNoteRefs :: NoteDb -> [NoteRef]
  allNoteRefs db =
      [ ref
      | (_fname, refs) <- M.toList (noteRefs db)
      , ref <- S.toList refs
      ]
  
  showNoteDb :: NoteDb -> String
  showNoteDb db = unlines $
      map showNoteRef (allNoteRefs db)
      ++
      map showNoteDef (allNoteDefs db)
  
  filesNotes :: [FilePath]
             -> IO NoteDb
  filesNotes = fmap mconcat . mapM fileNotes
  
  fileNotes :: FilePath -> IO NoteDb
  fileNotes fname = do
      is_file <- doesFileExist fname
      if is_file
        then do
          bs <- BS.readFile fname
          return $ case T.decodeUtf8' bs of
            Left _ -> mempty
            Right t ->
                let (refs, defs) = partitionEithers (findNotes fname t)
                in NoteDb
                     { noteRefs = M.singleton fname (S.fromList refs)
                     , noteDefs = M.fromList
                         [ (noteDefName def, S.singleton def)
                         | def <- defs
                         ]
                     }
        else return mempty
  
  brokenNoteRefs :: NoteDb -> [(NoteRef, NoteDef)]
  brokenNoteRefs db =
      [ (ref, best_match)
      | (_fname, refs) <- M.toList (noteRefs db)
      , ref <- S.toList refs
      , Nothing <- pure $ M.lookup (noteRefName ref) (noteDefs db)
      , let best_match = bestLev  (show (noteRefName ref)) (concatMap S.toList (M.elems (noteDefs db)))
      ]
  
  bestLev :: String -> [NoteDef] -> NoteDef
  bestLev x ds = head $ sortBy (comparing (\d -> lev x (show (noteDefName d)))) ds
  
  
  lev:: (Eq a) => [a] -> [a] -> Int
  lev xs ys = levMemo ! (n, m)
    where levMemo = array ((0,0),(n,m)) [((i,j),lev' i j) | i <- [0..n], j <- [0..m]]
          n = length xs
          m = length ys
          xa = listArray (1, n) xs
          ya = listArray (1, m) ys
          lev' 0 v = v
          lev' u 0 = u
          lev' u v
            | xa ! u == ya ! v = levMemo ! (u-1, v-1)
            | otherwise        = 1 + minimum [levMemo ! (u, v-1),
                                              levMemo ! (u-1, v),
                                              levMemo ! (u-1, v-1)]
  
  unreferencedNotes :: NoteDb -> S.Set NoteDef
  unreferencedNotes db =
      fold $ noteDefs db `M.withoutKeys` referencedNotes
    where
      referencedNotes = S.fromList $ map noteRefName (allNoteRefs db)
  