Merge pull request #17 from srid/ext-kind

Polymorphic file-ext in Route and Source

src/Emanote/Class.hs

@@ -1,17 +1,44 @@
+{-# LANGUAGE DataKinds #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Emanote.Class where
 
+import Control.Lens.Operators ((^.))
+import qualified Data.IxSet.Typed as Ix
+import qualified Data.Set as Set
 import Ema (Ema (..))
 import Emanote.Model (Model)
 import qualified Emanote.Model as M
-import Emanote.Route (MarkdownRoute)
+import qualified Emanote.Model.Note as N
+import Emanote.Route (Route)
 import qualified Emanote.Route as R
+import Emanote.Route.Ext (FileType (Html, LMLType, OtherExt))
+
+-- | TODO: Use `OpenUnion` here?
+data EmanoteRoute
+  = ERNoteHtml (Route 'Html)
+  | EROtherFile (Route 'OtherExt)
+  deriving (Eq, Show, Ord)
+
+instance Ema Model EmanoteRoute where
+  encodeRoute = \case
+    ERNoteHtml r ->
+      R.encodeRoute r
+    EROtherFile r ->
+      R.encodeRoute r
 
-instance Ema Model (Either FilePath MarkdownRoute) where
-  encodeRoute =
-    either id R.encodeRoute
   decodeRoute model fp =
-    fmap Left (M.modelLookupStaticFile fp model)
-      <|> fmap Right (R.decodeRoute fp)
-  allRoutes = M.allRoutes
+    fmap EROtherFile (M.modelLookupStaticFile fp model)
+      <|> fmap ERNoteHtml (R.decodeHtmlRoute fp)
+  allRoutes model =
+    let htmlRoutes =
+          model ^. M.modelNotes
+            & Ix.toList
+            <&> htmlRouteForLmlRoute . (^. N.noteRoute)
+        staticFiles =
+          Set.toList $ model ^. M.modelStaticFiles
+     in fmap ERNoteHtml htmlRoutes
+          <> fmap EROtherFile staticFiles
+
+htmlRouteForLmlRoute :: Route ('LMLType x) -> Route 'Html
+htmlRouteForLmlRoute = coerce

src/Emanote/Model.hs

@@ -27,8 +27,9 @@ import Emanote.Model.Note
 import Emanote.Model.Rel (IxRel)
 import qualified Emanote.Model.Rel as Rel
 import Emanote.Model.SData (IxSData, SData (SData))
-import Emanote.Route (MarkdownRoute)
+import Emanote.Route (Route)
 import qualified Emanote.Route as R
+import Emanote.Route.Ext (FileType (LMLType, OtherExt), LML (Md))
 import qualified Emanote.Route.Ext as Ext
 import qualified Emanote.Route.WikiLinkTarget as WL
 import Heist.Extra.TemplateState (TemplateState)
@@ -40,7 +41,7 @@ data Model = Model
     _modelRels :: IxRel,
     _modelData :: IxSData,
     _modelDataDefault :: Aeson.Value,
-    _modelStaticFiles :: Set FilePath,
+    _modelStaticFiles :: Set (Route 'OtherExt),
     _modelNav :: [Tree Slug],
     _modelHeistTemplate :: TemplateState
   }
@@ -50,43 +51,43 @@ makeLenses ''Model
 instance Default Model where
   def = Model Ix.empty Ix.empty Ix.empty Aeson.Null mempty mempty def
 
-modelInsertMarkdown :: MarkdownRoute -> (Aeson.Value, Pandoc) -> Model -> Model
+modelInsertMarkdown :: Route ('LMLType 'Md) -> (Aeson.Value, Pandoc) -> Model -> Model
 modelInsertMarkdown k v =
   modelNotes %~ Ix.updateIx k note
     >>> modelRels %~ (Ix.deleteIx k >>> Ix.insertList (Rel.extractRels note))
     >>> modelNav %~ PathTree.treeInsertPath (R.unRoute k)
   where
     note = Note (snd v) (fst v) k
 
-modelDeleteMarkdown :: MarkdownRoute -> Model -> Model
+modelDeleteMarkdown :: Route ('LMLType 'Md) -> Model -> Model
 modelDeleteMarkdown k =
   modelNotes %~ Ix.deleteIx k
     >>> modelRels %~ Ix.deleteIx k
     >>> modelNav %~ PathTree.treeDeletePath (R.unRoute k)
 
-modelInsertData :: R.Route Ext.Yaml -> Aeson.Value -> Model -> Model
+modelInsertData :: R.Route 'Ext.Yaml -> Aeson.Value -> Model -> Model
 modelInsertData r v =
   modelData %~ Ix.updateIx r (SData v r)
 
-modelDeleteData :: R.Route Ext.Yaml -> Model -> Model
+modelDeleteData :: R.Route 'Ext.Yaml -> Model -> Model
 modelDeleteData k =
   modelData %~ Ix.deleteIx k
 
-modelLookup :: MarkdownRoute -> Model -> Maybe Note
+modelLookup :: Route ('LMLType 'Md) -> Model -> Maybe Note
 modelLookup k =
   Ix.getOne . Ix.getEQ k . _modelNotes
 
-modelLookupTitle :: MarkdownRoute -> Model -> Text
+modelLookupTitle :: Route ('LMLType 'Md) -> Model -> Text
 modelLookupTitle r =
   maybe (R.routeFileBase r) noteTitle . modelLookup r
 
-modelLookupRouteByWikiLink :: WL.WikiLinkTarget -> Model -> [MarkdownRoute]
+modelLookupRouteByWikiLink :: WL.WikiLinkTarget -> Model -> [Route ('LMLType 'Md)]
 modelLookupRouteByWikiLink wl model =
   -- TODO: Also lookup wiki links to *directories* without an associated zettel.
   -- Eg: my [[Public Post Ideas]]
   fmap (^. noteRoute) . Ix.toList $ (model ^. modelNotes) @= SelfRef wl
 
-modelLookupBacklinks :: MarkdownRoute -> Model -> [(MarkdownRoute, NonEmpty [B.Block])]
+modelLookupBacklinks :: Route ('LMLType 'Md) -> Model -> [(Route ('LMLType 'Md), NonEmpty [B.Block])]
 modelLookupBacklinks r model =
   let refsToSelf =
         Set.fromList $
@@ -96,13 +97,8 @@ modelLookupBacklinks r model =
    in backlinks <&> \rel ->
         (rel ^. Rel.relFrom, rel ^. Rel.relCtx)
 
-modelLookupStaticFile :: FilePath -> Model -> Maybe FilePath
+modelLookupStaticFile :: FilePath -> Model -> Maybe (Route 'OtherExt)
 modelLookupStaticFile fp model = do
-  guard $ Set.member fp $ model ^. modelStaticFiles
-  pure fp
-
-allRoutes :: Model -> [Either FilePath MarkdownRoute]
-allRoutes model =
-  let mdRoutes = (fmap (^. noteRoute) . Ix.toList . (^. modelNotes)) model
-      staticFiles = Set.toList $ model ^. modelStaticFiles
-   in fmap Right mdRoutes <> fmap Left staticFiles
+  r <- R.mkRouteFromFilePath fp
+  guard $ Set.member r $ model ^. modelStaticFiles
+  pure r

src/Emanote/Model/Meta.hs

@@ -18,13 +18,13 @@ import Emanote.Model.Note
   ( noteMeta,
   )
 import Emanote.Model.SData (sdataValue)
-import Emanote.Route (MarkdownRoute)
 import qualified Emanote.Route as R
+import Emanote.Route.Ext
 import qualified Emanote.Route.Ext as Ext
 import Relude.Extra.Map (StaticMap (lookup))
 
 -- | Look up a specific key in the meta for a given route.
-lookupMeta :: FromJSON a => a -> NonEmpty Text -> MarkdownRoute -> Model -> a
+lookupMeta :: FromJSON a => a -> NonEmpty Text -> R.Route ('LMLType 'Md) -> Model -> a
 lookupMeta x k r =
   lookupMetaFrom x k . getEffectiveRouteMeta r
 
@@ -44,11 +44,11 @@ lookupMetaFrom x (k :| ks) meta =
 
 -- | Get the (final) metadata of a note at the given route, by merging it with
 -- the defaults specified in parent routes all the way upto index.yaml.
-getEffectiveRouteMeta :: MarkdownRoute -> Model -> Aeson.Value
+getEffectiveRouteMeta :: R.Route ('LMLType 'Md) -> Model -> Aeson.Value
 getEffectiveRouteMeta mr model = do
   let appDefault = model ^. modelDataDefault
   fromMaybe appDefault $ do
-    let defaultFiles = R.routeInits @Ext.Yaml (coerce mr)
+    let defaultFiles = R.routeInits @'Ext.Yaml (coerce mr)
     let defaults = flip mapMaybe (toList defaultFiles) $ \r -> do
           v <- fmap (^. sdataValue) . Ix.getOne . Ix.getEQ r $ model ^. modelData
           guard $ v /= Aeson.Null

src/Emanote/Model/Note.hs

@@ -13,15 +13,16 @@ import qualified Data.Aeson as Aeson
 import Data.Data (Data)
 import Data.IxSet.Typed (Indexable (..), IxSet, ixFun, ixGen, ixList)
 import qualified Emanote.PandocUtil as PandocUtil
-import Emanote.Route (MarkdownRoute)
+import Emanote.Route (Route)
 import qualified Emanote.Route as R
+import Emanote.Route.Ext
 import qualified Emanote.Route.WikiLinkTarget as WL
 import Text.Pandoc.Definition (Pandoc (..))
 
 data Note = Note
   { _noteDoc :: Pandoc,
     _noteMeta :: Aeson.Value,
-    _noteRoute :: MarkdownRoute
+    _noteRoute :: Route ('LMLType 'Md)
   }
   deriving (Eq, Ord, Data, Show, Generic, Aeson.ToJSON)
 
@@ -31,16 +32,17 @@ newtype SelfRef = SelfRef {unSelfRef :: WL.WikiLinkTarget}
 
 -- | Wiki-links that refer to this note.
 noteSelfRefs :: Note -> [SelfRef]
-noteSelfRefs = fmap SelfRef . toList . WL.allowedWikiLinkTargets . _noteRoute
+noteSelfRefs =
+  fmap SelfRef . toList . WL.allowedWikiLinkTargets . _noteRoute
 
-type NoteIxs = '[MarkdownRoute, SelfRef]
+type NoteIxs = '[Route ('LMLType 'Md), SelfRef]
 
 type IxNote = IxSet NoteIxs Note
 
 instance Indexable NoteIxs Note where
   indices =
     ixList
-      (ixGen $ Proxy @MarkdownRoute)
+      (ixGen $ Proxy @(Route ('LMLType 'Md)))
       (ixFun noteSelfRefs)
 
 makeLenses ''Note

src/Emanote/Model/Rel.hs

@@ -15,17 +15,18 @@ import Data.IxSet.Typed (Indexable (..), IxSet, ixGen, ixList)
 import qualified Data.Map.Strict as Map
 import qualified Data.Text as T
 import Emanote.Model.Note (Note, noteDoc, noteRoute)
-import Emanote.Route (MarkdownRoute)
 import qualified Emanote.Route as R
-import Emanote.Route.Ext (Md)
+import Emanote.Route.Ext
 import qualified Emanote.Route.WikiLinkTarget as WL
 import qualified Text.Pandoc.Definition as B
 import qualified Text.Pandoc.LinkContext as LC
 
+type TargetRoute = Either WL.WikiLinkTarget (R.Route ('LMLType 'Md))
+
 -- | A relation from one note to another.
 data Rel = Rel
-  { _relFrom :: MarkdownRoute,
-    _relTo :: Either WL.WikiLinkTarget R.MarkdownRoute,
+  { _relFrom :: R.Route ('LMLType 'Md),
+    _relTo :: TargetRoute,
     -- | The relation context of 'from' note linking to 'to' note.
     _relCtx :: NonEmpty [B.Block]
   }
@@ -37,15 +38,15 @@ instance Eq Rel where
 instance Ord Rel where
   (<=) = (<=) `on` (_relFrom &&& _relTo)
 
-type RelIxs = '[MarkdownRoute, Either WL.WikiLinkTarget R.MarkdownRoute]
+type RelIxs = '[R.Route ('LMLType 'Md), TargetRoute]
 
 type IxRel = IxSet RelIxs Rel
 
 instance Indexable RelIxs Rel where
   indices =
     ixList
-      (ixGen $ Proxy @MarkdownRoute)
-      (ixGen $ Proxy @(Either WL.WikiLinkTarget R.MarkdownRoute))
+      (ixGen $ Proxy @(R.Route ('LMLType 'Md)))
+      (ixGen $ Proxy @TargetRoute)
 
 makeLenses ''Rel
 
@@ -60,8 +61,8 @@ extractRels note =
         pure $ Rel (note ^. noteRoute) target ctx
 
 -- | Parse a URL string
-parseUrl :: Text -> Maybe (Either WL.WikiLinkTarget MarkdownRoute)
+parseUrl :: Text -> Maybe TargetRoute
 parseUrl url = do
   guard $ not $ "://" `T.isInfixOf` url
-  fmap Right (R.mkRouteFromFilePath @Md $ toString url)
+  fmap Right (R.mkRouteFromFilePath @('LMLType 'Md) $ toString url)
     <|> fmap Left (WL.mkWikiLinkTargetFromUrl url)

src/Emanote/Model/SData.hs

@@ -18,17 +18,17 @@ import qualified Emanote.Route.Ext as Ext
 -- value.  Example: /foo/bar.yaml file
 data SData = SData
   { _sdataValue :: Aeson.Value,
-    _sdataRoute :: R.Route Ext.Yaml
+    _sdataRoute :: R.Route 'Ext.Yaml
   }
   deriving (Eq, Ord, Data, Show, Generic, Aeson.ToJSON)
 
-type SDataIxs = '[R.Route Ext.Yaml]
+type SDataIxs = '[R.Route 'Ext.Yaml]
 
 type IxSData = IxSet SDataIxs SData
 
 instance Indexable SDataIxs SData where
   indices =
     ixList
-      (ixGen $ Proxy @(R.Route Ext.Yaml))
+      (ixGen $ Proxy @(R.Route 'Ext.Yaml))
 
 makeLenses ''SData

src/Emanote/Route.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -11,8 +12,8 @@ import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
 import Ema (Slug)
 import qualified Ema
-import Emanote.Route.Ext (Ext (..), Md)
-import System.FilePath (splitExtension, splitPath)
+import Emanote.Route.Ext
+import System.FilePath (splitPath)
 import qualified Text.Show (Show (show))
 
 -- | Represents the relative path to a source (.md) file under some directory.
@@ -22,16 +23,14 @@ import qualified Text.Show (Show (show))
 --
 -- If you are using this repo as a template, you might want to use an ADT as
 -- route (eg: data Route = Index | About)
-newtype Route ext = Route {unRoute :: NonEmpty Slug}
+newtype Route (ext :: FileType) = Route {unRoute :: NonEmpty Slug}
   deriving (Eq, Ord, Data, Generic, ToJSON)
 
-type MarkdownRoute = Route Md
-
-instance Ext ext => Show (Route ext) where
+instance HasExt ext => Show (Route ext) where
   show (Route slugs) =
     toString $
       "R["
-        <> toText (getExt (Proxy @ext))
+        <> show (fileType @ext)
         <> "]:"
         <> T.intercalate "/" (toList $ fmap Ema.unSlug slugs)
 
@@ -42,18 +41,15 @@ indexRoute = Route $ "index" :| []
 -- | Convert foo/bar.md to a @Route@
 --
 -- If the file is not a Markdown file, return Nothing.
-mkRouteFromFilePath :: forall ext. Ext ext => FilePath -> Maybe (Route ext)
+mkRouteFromFilePath :: forall ext. HasExt ext => FilePath -> Maybe (Route ext)
 mkRouteFromFilePath fp = do
-  let (base, ext) = splitExtension fp
-  guard $ ext == getExt (Proxy @ext)
+  base <- withoutKnownExt @ext fp
   let slugs = fromString . toString . T.dropWhileEnd (== '/') . toText <$> splitPath base
-   in Route <$> nonEmpty slugs
+  Route <$> nonEmpty slugs
 
-routeSourcePath :: forall ext. Ext ext => Route ext -> FilePath
+routeSourcePath :: forall ext. HasExt ext => Route ext -> FilePath
 routeSourcePath r =
-  if r == indexRoute
-    then "index" <> getExt (Proxy @ext)
-    else toString (T.intercalate "/" $ fmap Ema.unSlug $ toList $ unRoute r) <> ".md"
+  withExt @ext $ toString (T.intercalate "/" $ fmap Ema.unSlug $ toList $ unRoute r)
 
 -- | Filename of the markdown file without extension
 routeFileBase :: Route ext -> Text
@@ -81,17 +77,17 @@ routeInits (Route (slug :| rest')) =
               this : go (unRoute this) ys
 
 -- | Convert a route to html filepath
-encodeRoute :: Route Md -> FilePath
+encodeRoute :: forall ft. HasExt ft => Route ft -> FilePath
 encodeRoute (Route slugs) =
-  (<> ".html") $ case nonEmpty (Ema.unSlug <$> toList slugs) of
-    Nothing -> "index.html"
+  withExt @ft $ case nonEmpty (Ema.unSlug <$> toList slugs) of
+    Nothing -> "index"
     Just parts ->
       toString $ T.intercalate "/" (toList parts)
 
 -- | Parse our route from html file path
 -- See FIXME: in Ema.Route's Either instance for FileRoute.
-decodeRoute :: FilePath -> Maybe (Route Md)
-decodeRoute fp = do
+decodeHtmlRoute :: FilePath -> Maybe (Route 'Html)
+decodeHtmlRoute fp = do
   if null fp
     then pure $ Route $ one "index"
     else do