{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TemplateHaskell #-}

module Emanote.Model.Link.Rel where

import Commonmark.Extensions.WikiLink qualified as WL
import Data.Aeson (ToJSON)
import Data.IxSet.Typed (Indexable (..), IxSet, ixFun, ixList)
import Data.IxSet.Typed qualified as Ix
import Data.List.NonEmpty qualified as NEL
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Emanote.Model.Note (Note, noteDoc, noteRoute)
import Emanote.Route (LMLRoute, ModelRoute)
import Emanote.Route qualified as R
import Emanote.Route.SiteRoute.Type qualified as SR
import Optics.Operators as Lens ((^.))
import Optics.TH (makeLenses)
import Relude
import System.FilePath (normalise, (</>))
import Text.Pandoc.Definition qualified as B
import Text.Pandoc.LinkContext qualified as LC

-- | A relation from one note to anywhere in the model.
--
-- Target will remain unresolved in the `Rel`, and can be resolved at a latter
-- time (eg: during rendering).
data Rel = Rel
  { -- The note containing this relation
    Rel -> LMLRoute
_relFrom :: LMLRoute,
    -- The target of the relation (can be a note or anything)
    Rel -> UnresolvedRelTarget
_relTo :: UnresolvedRelTarget,
    -- | The relation context in LML
    Rel -> [Block]
_relCtx :: [B.Block]
  }
  deriving stock (Rel -> Rel -> Bool
(Rel -> Rel -> Bool) -> (Rel -> Rel -> Bool) -> Eq Rel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rel -> Rel -> Bool
$c/= :: Rel -> Rel -> Bool
== :: Rel -> Rel -> Bool
$c== :: Rel -> Rel -> Bool
Eq, Eq Rel
Eq Rel
-> (Rel -> Rel -> Ordering)
-> (Rel -> Rel -> Bool)
-> (Rel -> Rel -> Bool)
-> (Rel -> Rel -> Bool)
-> (Rel -> Rel -> Bool)
-> (Rel -> Rel -> Rel)
-> (Rel -> Rel -> Rel)
-> Ord Rel
Rel -> Rel -> Bool
Rel -> Rel -> Ordering
Rel -> Rel -> Rel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Rel -> Rel -> Rel
$cmin :: Rel -> Rel -> Rel
max :: Rel -> Rel -> Rel
$cmax :: Rel -> Rel -> Rel
>= :: Rel -> Rel -> Bool
$c>= :: Rel -> Rel -> Bool
> :: Rel -> Rel -> Bool
$c> :: Rel -> Rel -> Bool
<= :: Rel -> Rel -> Bool
$c<= :: Rel -> Rel -> Bool
< :: Rel -> Rel -> Bool
$c< :: Rel -> Rel -> Bool
compare :: Rel -> Rel -> Ordering
$ccompare :: Rel -> Rel -> Ordering
Ord, Int -> Rel -> ShowS
[Rel] -> ShowS
Rel -> FilePath
(Int -> Rel -> ShowS)
-> (Rel -> FilePath) -> ([Rel] -> ShowS) -> Show Rel
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Rel] -> ShowS
$cshowList :: [Rel] -> ShowS
show :: Rel -> FilePath
$cshow :: Rel -> FilePath
showsPrec :: Int -> Rel -> ShowS
$cshowsPrec :: Int -> Rel -> ShowS
Show)

-- | A link target that has not been resolved (using model) yet.
--
-- Resolving this may or may not result in a resource in the model. The ADT
-- constructors capture the different possible types of links the user is
-- allowed to link to.
data UnresolvedRelTarget
  = URTWikiLink (WL.WikiLinkType, WL.WikiLink)
  | URTResource ModelRoute
  | URTVirtual SR.VirtualRoute
  deriving stock (UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
(UnresolvedRelTarget -> UnresolvedRelTarget -> Bool)
-> (UnresolvedRelTarget -> UnresolvedRelTarget -> Bool)
-> Eq UnresolvedRelTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
$c/= :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
== :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
$c== :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
Eq, Int -> UnresolvedRelTarget -> ShowS
[UnresolvedRelTarget] -> ShowS
UnresolvedRelTarget -> FilePath
(Int -> UnresolvedRelTarget -> ShowS)
-> (UnresolvedRelTarget -> FilePath)
-> ([UnresolvedRelTarget] -> ShowS)
-> Show UnresolvedRelTarget
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [UnresolvedRelTarget] -> ShowS
$cshowList :: [UnresolvedRelTarget] -> ShowS
show :: UnresolvedRelTarget -> FilePath
$cshow :: UnresolvedRelTarget -> FilePath
showsPrec :: Int -> UnresolvedRelTarget -> ShowS
$cshowsPrec :: Int -> UnresolvedRelTarget -> ShowS
Show, Eq UnresolvedRelTarget
Eq UnresolvedRelTarget
-> (UnresolvedRelTarget -> UnresolvedRelTarget -> Ordering)
-> (UnresolvedRelTarget -> UnresolvedRelTarget -> Bool)
-> (UnresolvedRelTarget -> UnresolvedRelTarget -> Bool)
-> (UnresolvedRelTarget -> UnresolvedRelTarget -> Bool)
-> (UnresolvedRelTarget -> UnresolvedRelTarget -> Bool)
-> (UnresolvedRelTarget
    -> UnresolvedRelTarget -> UnresolvedRelTarget)
-> (UnresolvedRelTarget
    -> UnresolvedRelTarget -> UnresolvedRelTarget)
-> Ord UnresolvedRelTarget
UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
UnresolvedRelTarget -> UnresolvedRelTarget -> Ordering
UnresolvedRelTarget -> UnresolvedRelTarget -> UnresolvedRelTarget
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnresolvedRelTarget -> UnresolvedRelTarget -> UnresolvedRelTarget
$cmin :: UnresolvedRelTarget -> UnresolvedRelTarget -> UnresolvedRelTarget
max :: UnresolvedRelTarget -> UnresolvedRelTarget -> UnresolvedRelTarget
$cmax :: UnresolvedRelTarget -> UnresolvedRelTarget -> UnresolvedRelTarget
>= :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
$c>= :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
> :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
$c> :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
<= :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
$c<= :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
< :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
$c< :: UnresolvedRelTarget -> UnresolvedRelTarget -> Bool
compare :: UnresolvedRelTarget -> UnresolvedRelTarget -> Ordering
$ccompare :: UnresolvedRelTarget -> UnresolvedRelTarget -> Ordering
Ord, (forall x. UnresolvedRelTarget -> Rep UnresolvedRelTarget x)
-> (forall x. Rep UnresolvedRelTarget x -> UnresolvedRelTarget)
-> Generic UnresolvedRelTarget
forall x. Rep UnresolvedRelTarget x -> UnresolvedRelTarget
forall x. UnresolvedRelTarget -> Rep UnresolvedRelTarget x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UnresolvedRelTarget x -> UnresolvedRelTarget
$cfrom :: forall x. UnresolvedRelTarget -> Rep UnresolvedRelTarget x
Generic)
  deriving anyclass ([UnresolvedRelTarget] -> Encoding
[UnresolvedRelTarget] -> Value
UnresolvedRelTarget -> Encoding
UnresolvedRelTarget -> Value
(UnresolvedRelTarget -> Value)
-> (UnresolvedRelTarget -> Encoding)
-> ([UnresolvedRelTarget] -> Value)
-> ([UnresolvedRelTarget] -> Encoding)
-> ToJSON UnresolvedRelTarget
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [UnresolvedRelTarget] -> Encoding
$ctoEncodingList :: [UnresolvedRelTarget] -> Encoding
toJSONList :: [UnresolvedRelTarget] -> Value
$ctoJSONList :: [UnresolvedRelTarget] -> Value
toEncoding :: UnresolvedRelTarget -> Encoding
$ctoEncoding :: UnresolvedRelTarget -> Encoding
toJSON :: UnresolvedRelTarget -> Value
$ctoJSON :: UnresolvedRelTarget -> Value
ToJSON)

type RelIxs = '[LMLRoute, UnresolvedRelTarget]

type IxRel = IxSet RelIxs Rel

instance Indexable RelIxs Rel where
  indices :: IxList RelIxs Rel
indices =
    Ix LMLRoute Rel -> Ix UnresolvedRelTarget Rel -> IxList RelIxs Rel
forall (ixs :: [Type]) a r. MkIxList ixs ixs a r => r
ixList
      ((Rel -> [LMLRoute]) -> Ix LMLRoute Rel
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun ((Rel -> [LMLRoute]) -> Ix LMLRoute Rel)
-> (Rel -> [LMLRoute]) -> Ix LMLRoute Rel
forall a b. (a -> b) -> a -> b
$ LMLRoute -> [LMLRoute]
forall x. One x => OneItem x -> x
one (LMLRoute -> [LMLRoute]) -> (Rel -> LMLRoute) -> Rel -> [LMLRoute]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rel -> LMLRoute
_relFrom)
      ((Rel -> [UnresolvedRelTarget]) -> Ix UnresolvedRelTarget Rel
forall ix a. Ord ix => (a -> [ix]) -> Ix ix a
ixFun ((Rel -> [UnresolvedRelTarget]) -> Ix UnresolvedRelTarget Rel)
-> (Rel -> [UnresolvedRelTarget]) -> Ix UnresolvedRelTarget Rel
forall a b. (a -> b) -> a -> b
$ UnresolvedRelTarget -> [UnresolvedRelTarget]
forall x. One x => OneItem x -> x
one (UnresolvedRelTarget -> [UnresolvedRelTarget])
-> (Rel -> UnresolvedRelTarget) -> Rel -> [UnresolvedRelTarget]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rel -> UnresolvedRelTarget
_relTo)

makeLenses ''Rel

noteRels :: Note -> IxRel
noteRels :: Note -> IxRel
noteRels Note
note =
  Map Text (NonEmpty ([(Text, Text)], [Block])) -> IxRel
extractLinks (Map Text (NonEmpty ([(Text, Text)], [Block])) -> IxRel)
-> (Pandoc -> Map Text (NonEmpty ([(Text, Text)], [Block])))
-> Pandoc
-> IxRel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pandoc -> Map Text (NonEmpty ([(Text, Text)], [Block]))
LC.queryLinksWithContext (Pandoc -> IxRel) -> Pandoc -> IxRel
forall a b. (a -> b) -> a -> b
$ Note
note Note -> Optic' A_Lens ('[] @Type) Note Pandoc -> Pandoc
forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens ('[] @Type) Note Pandoc
noteDoc
  where
    extractLinks :: Map Text (NonEmpty ([(Text, Text)], [B.Block])) -> IxRel
    extractLinks :: Map Text (NonEmpty ([(Text, Text)], [Block])) -> IxRel
extractLinks Map Text (NonEmpty ([(Text, Text)], [Block]))
m =
      [Rel] -> IxRel
forall (ixs :: [Type]) a. Indexable ixs a => [a] -> IxSet ixs a
Ix.fromList ([Rel] -> IxRel) -> [Rel] -> IxRel
forall a b. (a -> b) -> a -> b
$
        (((Text, NonEmpty ([(Text, Text)], [Block])) -> [Rel])
 -> [(Text, NonEmpty ([(Text, Text)], [Block]))] -> [Rel])
-> [(Text, NonEmpty ([(Text, Text)], [Block]))]
-> ((Text, NonEmpty ([(Text, Text)], [Block])) -> [Rel])
-> [Rel]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Text, NonEmpty ([(Text, Text)], [Block])) -> [Rel])
-> [(Text, NonEmpty ([(Text, Text)], [Block]))] -> [Rel]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
concatMap (Map Text (NonEmpty ([(Text, Text)], [Block]))
-> [(Text, NonEmpty ([(Text, Text)], [Block]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text (NonEmpty ([(Text, Text)], [Block]))
m) (((Text, NonEmpty ([(Text, Text)], [Block])) -> [Rel]) -> [Rel])
-> ((Text, NonEmpty ([(Text, Text)], [Block])) -> [Rel]) -> [Rel]
forall a b. (a -> b) -> a -> b
$ \(Text
url, NonEmpty ([(Text, Text)], [Block])
instances) -> do
          ((([(Text, Text)], [Block]) -> Maybe Rel)
 -> [([(Text, Text)], [Block])] -> [Rel])
-> [([(Text, Text)], [Block])]
-> (([(Text, Text)], [Block]) -> Maybe Rel)
-> [Rel]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([(Text, Text)], [Block]) -> Maybe Rel)
-> [([(Text, Text)], [Block])] -> [Rel]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NonEmpty ([(Text, Text)], [Block]) -> [([(Text, Text)], [Block])]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NonEmpty ([(Text, Text)], [Block])
instances) ((([(Text, Text)], [Block]) -> Maybe Rel) -> [Rel])
-> (([(Text, Text)], [Block]) -> Maybe Rel) -> [Rel]
forall a b. (a -> b) -> a -> b
$ \([(Text, Text)]
attrs, [Block]
ctx) -> do
            let parentR :: Maybe (R @() 'Folder)
parentR = (forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> Maybe (R @() 'Folder))
-> LMLRoute -> Maybe (R @() 'Folder)
forall r.
(forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> r)
-> LMLRoute -> r
R.withLmlRoute forall {a} (ext :: FileType a). R @a ext -> Maybe (R @() 'Folder)
forall (lmlType :: LML).
HasExt @SourceExt ('LMLType lmlType) =>
R @SourceExt ('LMLType lmlType) -> Maybe (R @() 'Folder)
R.routeParent (LMLRoute -> Maybe (R @() 'Folder))
-> LMLRoute -> Maybe (R @() 'Folder)
forall a b. (a -> b) -> a -> b
$ Note
note Note -> Optic' A_Lens ('[] @Type) Note LMLRoute -> LMLRoute
forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens ('[] @Type) Note LMLRoute
noteRoute
            (UnresolvedRelTarget
target, Maybe Anchor
_manchor) <- Maybe (R @() 'Folder)
-> [(Text, Text)]
-> Text
-> Maybe (UnresolvedRelTarget, Maybe Anchor)
parseUnresolvedRelTarget Maybe (R @() 'Folder)
parentR [(Text, Text)]
attrs Text
url
            Rel -> Maybe Rel
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Rel -> Maybe Rel) -> Rel -> Maybe Rel
forall a b. (a -> b) -> a -> b
$ LMLRoute -> UnresolvedRelTarget -> [Block] -> Rel
Rel (Note
note Note -> Optic' A_Lens ('[] @Type) Note LMLRoute -> LMLRoute
forall k s (is :: [Type]) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens ('[] @Type) Note LMLRoute
noteRoute) UnresolvedRelTarget
target [Block]
ctx

unresolvedRelsTo :: ModelRoute -> [UnresolvedRelTarget]
unresolvedRelsTo :: ModelRoute -> [UnresolvedRelTarget]
unresolvedRelsTo ModelRoute
r =
  let allowedWikiLinks :: R @a ext -> NonEmpty (WikiLinkType, WikiLink)
allowedWikiLinks = HasCallStack => NonEmpty Slug -> NonEmpty (WikiLinkType, WikiLink)
NonEmpty Slug -> NonEmpty (WikiLinkType, WikiLink)
WL.allowedWikiLinks (NonEmpty Slug -> NonEmpty (WikiLinkType, WikiLink))
-> (R @a ext -> NonEmpty Slug)
-> R @a ext
-> NonEmpty (WikiLinkType, WikiLink)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R @a ext -> NonEmpty Slug
forall a (ext :: FileType a). R @a ext -> NonEmpty Slug
R.unRoute
      wls :: NonEmpty (WikiLinkType, WikiLink)
wls = (LMLRoute -> NonEmpty (WikiLinkType, WikiLink))
-> (R @SourceExt 'AnyExt -> NonEmpty (WikiLinkType, WikiLink))
-> Either LMLRoute (R @SourceExt 'AnyExt)
-> NonEmpty (WikiLinkType, WikiLink)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType)
 -> NonEmpty (WikiLinkType, WikiLink))
-> LMLRoute -> NonEmpty (WikiLinkType, WikiLink)
forall r.
(forall (lmlType :: LML).
 HasExt @SourceExt ('LMLType lmlType) =>
 R @SourceExt ('LMLType lmlType) -> r)
-> LMLRoute -> r
R.withLmlRoute forall {a} {ext :: FileType a}.
R @a ext -> NonEmpty (WikiLinkType, WikiLink)
forall (lmlType :: LML).
HasExt @SourceExt ('LMLType lmlType) =>
R @SourceExt ('LMLType lmlType)
-> NonEmpty (WikiLinkType, WikiLink)
allowedWikiLinks) R @SourceExt 'AnyExt -> NonEmpty (WikiLinkType, WikiLink)
forall {a} {ext :: FileType a}.
R @a ext -> NonEmpty (WikiLinkType, WikiLink)
allowedWikiLinks (Either LMLRoute (R @SourceExt 'AnyExt)
 -> NonEmpty (WikiLinkType, WikiLink))
-> Either LMLRoute (R @SourceExt 'AnyExt)
-> NonEmpty (WikiLinkType, WikiLink)
forall a b. (a -> b) -> a -> b
$ ModelRoute -> Either LMLRoute (R @SourceExt 'AnyExt)
R.modelRouteCase ModelRoute
r
   in ((WikiLinkType, WikiLink) -> UnresolvedRelTarget
URTWikiLink ((WikiLinkType, WikiLink) -> UnresolvedRelTarget)
-> [(WikiLinkType, WikiLink)] -> [UnresolvedRelTarget]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (WikiLinkType, WikiLink) -> [(WikiLinkType, WikiLink)]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NonEmpty (WikiLinkType, WikiLink)
wls)
        [UnresolvedRelTarget]
-> [UnresolvedRelTarget] -> [UnresolvedRelTarget]
forall a. Semigroup a => a -> a -> a
<> [ModelRoute -> UnresolvedRelTarget
URTResource ModelRoute
r]

-- | Parse a relative URL string for later resolution.
--
-- TODO: Need tests for this function.
parseUnresolvedRelTarget :: Maybe (R.R 'R.Folder) -> [(Text, Text)] -> Text -> Maybe (UnresolvedRelTarget, Maybe WL.Anchor)
parseUnresolvedRelTarget :: Maybe (R @() 'Folder)
-> [(Text, Text)]
-> Text
-> Maybe (UnresolvedRelTarget, Maybe Anchor)
parseUnresolvedRelTarget Maybe (R @() 'Folder)
baseDir [(Text, Text)]
attrs Text
url = do
  (Either (WikiLinkType, WikiLink) FilePath
wlRes, Maybe Anchor
manchor) <- [(Text, Text)]
-> Text
-> Maybe (Either (WikiLinkType, WikiLink) FilePath, Maybe Anchor)
WL.delineateLink [(Text, Text)]
attrs Text
url
  UnresolvedRelTarget
res <- case Either (WikiLinkType, WikiLink) FilePath
wlRes of
    Left (WikiLinkType, WikiLink)
wl ->
      UnresolvedRelTarget -> Maybe UnresolvedRelTarget
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (UnresolvedRelTarget -> Maybe UnresolvedRelTarget)
-> UnresolvedRelTarget -> Maybe UnresolvedRelTarget
forall a b. (a -> b) -> a -> b
$ (WikiLinkType, WikiLink) -> UnresolvedRelTarget
URTWikiLink (WikiLinkType, WikiLink)
wl
    Right FilePath
fp ->
      (VirtualRoute -> UnresolvedRelTarget)
-> Maybe VirtualRoute -> Maybe UnresolvedRelTarget
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap VirtualRoute -> UnresolvedRelTarget
URTVirtual (FilePath -> Maybe VirtualRoute
SR.decodeVirtualRoute FilePath
fp)
        Maybe UnresolvedRelTarget
-> Maybe UnresolvedRelTarget -> Maybe UnresolvedRelTarget
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> (ModelRoute -> UnresolvedRelTarget)
-> Maybe ModelRoute -> Maybe UnresolvedRelTarget
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ModelRoute -> UnresolvedRelTarget
URTResource
          ( FilePath
fp
              FilePath -> ShowS -> FilePath
forall a b. a -> (a -> b) -> b
& Maybe FilePath -> ShowS
relocateRelUrlUnder (R @() 'Folder -> FilePath
forall a (ft :: FileType a). HasExt @a ft => R @a ft -> FilePath
R.encodeRoute (R @() 'Folder -> FilePath)
-> Maybe (R @() 'Folder) -> Maybe FilePath
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (R @() 'Folder)
baseDir)
              FilePath -> (FilePath -> Maybe ModelRoute) -> Maybe ModelRoute
forall a b. a -> (a -> b) -> b
& FilePath -> Maybe ModelRoute
R.mkModelRouteFromFilePath
          )
  (UnresolvedRelTarget, Maybe Anchor)
-> Maybe (UnresolvedRelTarget, Maybe Anchor)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (UnresolvedRelTarget
res, Maybe Anchor
manchor)

relocateRelUrlUnder :: Maybe FilePath -> FilePath -> FilePath
relocateRelUrlUnder :: Maybe FilePath -> ShowS
relocateRelUrlUnder Maybe FilePath
mbase FilePath
fp =
  ShowS
normalizeIgnoringSymlinks ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    case Maybe FilePath
mbase of
      Maybe FilePath
Nothing -> FilePath
fp
      Just FilePath
x -> FilePath
x FilePath -> ShowS
</> FilePath
fp

-- | Like `System.FilePath.normalise` but also normalises '..'
normalizeIgnoringSymlinks :: FilePath -> FilePath
normalizeIgnoringSymlinks :: ShowS
normalizeIgnoringSymlinks = ShowS
dropDotDot ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
normalise

-- Remove '..' from path component.
--
-- `System.FilePath.normalize` ought to do this already, but it doesn't due to
-- symlinks (which we don't use anyway.)
--
-- See https://github.com/haskell/filepath/issues/87
dropDotDot :: FilePath -> FilePath
dropDotDot :: ShowS
dropDotDot =
  let go :: Int -> NonEmpty Text -> [Text]
      go :: Int -> NonEmpty Text -> [Text]
go Int
n = \case
        (Text
".." :| [Text]
xs) -> [Text]
-> (NonEmpty Text -> [Text]) -> Maybe (NonEmpty Text) -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Int -> NonEmpty Text -> [Text]
go (Int -> NonEmpty Text -> [Text]) -> Int -> NonEmpty Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Maybe (NonEmpty Text) -> [Text])
-> Maybe (NonEmpty Text) -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Text]
xs
        (Text
x :| [Text]
xs) | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> Text
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
-> (NonEmpty Text -> [Text]) -> Maybe (NonEmpty Text) -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Int -> NonEmpty Text -> [Text]
go Int
0) ([Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Text]
xs)
        NonEmpty Text
x -> [Text]
-> (NonEmpty Text -> [Text]) -> Maybe (NonEmpty Text) -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (Int -> NonEmpty Text -> [Text]
go Int
0) (Maybe (NonEmpty Text) -> [Text])
-> Maybe (NonEmpty Text) -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Text] -> Maybe (NonEmpty Text))
-> [Text] -> Maybe (NonEmpty Text)
forall a b. (a -> b) -> a -> b
$ Int -> NonEmpty Text -> [Text]
forall a. Int -> NonEmpty a -> [a]
NEL.drop Int
n NonEmpty Text
x
   in Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> (FilePath -> Text) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> (FilePath -> [Text]) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text]
-> (NonEmpty Text -> [Text]) -> Maybe (NonEmpty Text) -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> (NonEmpty Text -> [Text]) -> NonEmpty Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> NonEmpty Text -> [Text]
go Int
0 (NonEmpty Text -> [Text])
-> (NonEmpty Text -> NonEmpty Text) -> NonEmpty Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> NonEmpty Text
forall a. NonEmpty a -> NonEmpty a
NEL.reverse) (Maybe (NonEmpty Text) -> [Text])
-> (FilePath -> Maybe (NonEmpty Text)) -> FilePath -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Text] -> Maybe (NonEmpty Text))
-> (FilePath -> [Text]) -> FilePath -> Maybe (NonEmpty Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> (FilePath -> Text) -> FilePath -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
forall a. ToText a => a -> Text
toText

-- | An `UnresolvedRelTarget` that has been resolved.
--
-- See @Model.Link.Resolve@ for actual resolution logic.
data ResolvedRelTarget a
  = RRTMissing
  | RRTAmbiguous (NonEmpty a)
  | RRTFound a
  deriving stock (ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
(ResolvedRelTarget a -> ResolvedRelTarget a -> Bool)
-> (ResolvedRelTarget a -> ResolvedRelTarget a -> Bool)
-> Eq (ResolvedRelTarget a)
forall a.
Eq a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
$c/= :: forall a.
Eq a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
== :: ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
$c== :: forall a.
Eq a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
Eq, Int -> ResolvedRelTarget a -> ShowS
[ResolvedRelTarget a] -> ShowS
ResolvedRelTarget a -> FilePath
(Int -> ResolvedRelTarget a -> ShowS)
-> (ResolvedRelTarget a -> FilePath)
-> ([ResolvedRelTarget a] -> ShowS)
-> Show (ResolvedRelTarget a)
forall a. Show a => Int -> ResolvedRelTarget a -> ShowS
forall a. Show a => [ResolvedRelTarget a] -> ShowS
forall a. Show a => ResolvedRelTarget a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ResolvedRelTarget a] -> ShowS
$cshowList :: forall a. Show a => [ResolvedRelTarget a] -> ShowS
show :: ResolvedRelTarget a -> FilePath
$cshow :: forall a. Show a => ResolvedRelTarget a -> FilePath
showsPrec :: Int -> ResolvedRelTarget a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ResolvedRelTarget a -> ShowS
Show, Eq (ResolvedRelTarget a)
Eq (ResolvedRelTarget a)
-> (ResolvedRelTarget a -> ResolvedRelTarget a -> Ordering)
-> (ResolvedRelTarget a -> ResolvedRelTarget a -> Bool)
-> (ResolvedRelTarget a -> ResolvedRelTarget a -> Bool)
-> (ResolvedRelTarget a -> ResolvedRelTarget a -> Bool)
-> (ResolvedRelTarget a -> ResolvedRelTarget a -> Bool)
-> (ResolvedRelTarget a
    -> ResolvedRelTarget a -> ResolvedRelTarget a)
-> (ResolvedRelTarget a
    -> ResolvedRelTarget a -> ResolvedRelTarget a)
-> Ord (ResolvedRelTarget a)
ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
ResolvedRelTarget a -> ResolvedRelTarget a -> Ordering
ResolvedRelTarget a -> ResolvedRelTarget a -> ResolvedRelTarget a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (ResolvedRelTarget a)
forall a.
Ord a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
forall a.
Ord a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> Ordering
forall a.
Ord a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> ResolvedRelTarget a
min :: ResolvedRelTarget a -> ResolvedRelTarget a -> ResolvedRelTarget a
$cmin :: forall a.
Ord a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> ResolvedRelTarget a
max :: ResolvedRelTarget a -> ResolvedRelTarget a -> ResolvedRelTarget a
$cmax :: forall a.
Ord a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> ResolvedRelTarget a
>= :: ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
$c>= :: forall a.
Ord a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
> :: ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
$c> :: forall a.
Ord a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
<= :: ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
$c<= :: forall a.
Ord a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
< :: ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
$c< :: forall a.
Ord a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> Bool
compare :: ResolvedRelTarget a -> ResolvedRelTarget a -> Ordering
$ccompare :: forall a.
Ord a =>
ResolvedRelTarget a -> ResolvedRelTarget a -> Ordering
Ord, (forall a b.
 (a -> b) -> ResolvedRelTarget a -> ResolvedRelTarget b)
-> (forall a b. a -> ResolvedRelTarget b -> ResolvedRelTarget a)
-> Functor ResolvedRelTarget
forall a b. a -> ResolvedRelTarget b -> ResolvedRelTarget a
forall a b. (a -> b) -> ResolvedRelTarget a -> ResolvedRelTarget b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ResolvedRelTarget b -> ResolvedRelTarget a
$c<$ :: forall a b. a -> ResolvedRelTarget b -> ResolvedRelTarget a
fmap :: forall a b. (a -> b) -> ResolvedRelTarget a -> ResolvedRelTarget b
$cfmap :: forall a b. (a -> b) -> ResolvedRelTarget a -> ResolvedRelTarget b
Functor, (forall x. ResolvedRelTarget a -> Rep (ResolvedRelTarget a) x)
-> (forall x. Rep (ResolvedRelTarget a) x -> ResolvedRelTarget a)
-> Generic (ResolvedRelTarget a)
forall x. Rep (ResolvedRelTarget a) x -> ResolvedRelTarget a
forall x. ResolvedRelTarget a -> Rep (ResolvedRelTarget a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (ResolvedRelTarget a) x -> ResolvedRelTarget a
forall a x. ResolvedRelTarget a -> Rep (ResolvedRelTarget a) x
$cto :: forall a x. Rep (ResolvedRelTarget a) x -> ResolvedRelTarget a
$cfrom :: forall a x. ResolvedRelTarget a -> Rep (ResolvedRelTarget a) x
Generic)
  deriving anyclass ([ResolvedRelTarget a] -> Encoding
[ResolvedRelTarget a] -> Value
ResolvedRelTarget a -> Encoding
ResolvedRelTarget a -> Value
(ResolvedRelTarget a -> Value)
-> (ResolvedRelTarget a -> Encoding)
-> ([ResolvedRelTarget a] -> Value)
-> ([ResolvedRelTarget a] -> Encoding)
-> ToJSON (ResolvedRelTarget a)
forall a. ToJSON a => [ResolvedRelTarget a] -> Encoding
forall a. ToJSON a => [ResolvedRelTarget a] -> Value
forall a. ToJSON a => ResolvedRelTarget a -> Encoding
forall a. ToJSON a => ResolvedRelTarget a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ResolvedRelTarget a] -> Encoding
$ctoEncodingList :: forall a. ToJSON a => [ResolvedRelTarget a] -> Encoding
toJSONList :: [ResolvedRelTarget a] -> Value
$ctoJSONList :: forall a. ToJSON a => [ResolvedRelTarget a] -> Value
toEncoding :: ResolvedRelTarget a -> Encoding
$ctoEncoding :: forall a. ToJSON a => ResolvedRelTarget a -> Encoding
toJSON :: ResolvedRelTarget a -> Value
$ctoJSON :: forall a. ToJSON a => ResolvedRelTarget a -> Value
ToJSON)

resolvedRelTargetFromCandidates :: [a] -> ResolvedRelTarget a
resolvedRelTargetFromCandidates :: forall a. [a] -> ResolvedRelTarget a
resolvedRelTargetFromCandidates [a]
xs =
  case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [a]
xs of
    Maybe (NonEmpty a)
Nothing ->
      ResolvedRelTarget a
forall a. ResolvedRelTarget a
RRTMissing
    Just (a
x :| []) ->
      a -> ResolvedRelTarget a
forall a. a -> ResolvedRelTarget a
RRTFound a
x
    Just NonEmpty a
xs' ->
      NonEmpty a -> ResolvedRelTarget a
forall a. NonEmpty a -> ResolvedRelTarget a
RRTAmbiguous NonEmpty a
xs'